aboutsummaryrefslogtreecommitdiff
path: root/gcc/ada
diff options
context:
space:
mode:
authorThomas Koenig <tkoenig@gcc.gnu.org>2021-01-03 21:40:04 +0100
committerThomas Koenig <tkoenig@gcc.gnu.org>2021-01-03 21:40:04 +0100
commitafae4a55ccaa0de95ea11e5f634084db6ab2f444 (patch)
treed632cc867d10410ba9fb750523be790b86846ac4 /gcc/ada
parent9d9a82ec8478ff52c7a9d61f58cd2a7b6295b5f9 (diff)
parentd2eb616a0f7bea78164912aa438c29fe1ef5774a (diff)
downloadgcc-afae4a55ccaa0de95ea11e5f634084db6ab2f444.zip
gcc-afae4a55ccaa0de95ea11e5f634084db6ab2f444.tar.gz
gcc-afae4a55ccaa0de95ea11e5f634084db6ab2f444.tar.bz2
Merge branch 'master' into devel/coarray_native
Diffstat (limited to 'gcc/ada')
-rw-r--r--gcc/ada/ChangeLog3131
-rw-r--r--gcc/ada/Makefile.rtl84
-rw-r--r--gcc/ada/ada_get_targ.adb32
-rw-r--r--gcc/ada/adabkend.adb3
-rw-r--r--gcc/ada/adaint.c31
-rw-r--r--gcc/ada/adaint.h10
-rw-r--r--gcc/ada/ali-util.adb10
-rw-r--r--gcc/ada/ali.adb10
-rw-r--r--gcc/ada/ali.ads4
-rw-r--r--gcc/ada/aspects.adb28
-rw-r--r--gcc/ada/aspects.ads50
-rw-r--r--gcc/ada/bindo-writers.adb2
-rw-r--r--gcc/ada/checks.adb252
-rw-r--r--gcc/ada/checks.ads16
-rw-r--r--gcc/ada/contracts.adb534
-rw-r--r--gcc/ada/contracts.ads15
-rw-r--r--gcc/ada/cstand.adb12
-rw-r--r--gcc/ada/debug.adb7
-rw-r--r--gcc/ada/doc/gnat_rm/implementation_defined_aspects.rst2
-rw-r--r--gcc/ada/doc/gnat_rm/implementation_defined_attributes.rst35
-rw-r--r--gcc/ada/doc/gnat_rm/implementation_defined_characteristics.rst30
-rw-r--r--gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst52
-rw-r--r--gcc/ada/doc/gnat_rm/intrinsic_subprograms.rst4
-rw-r--r--gcc/ada/doc/gnat_ugn/building_executable_programs_with_gnat.rst15
-rw-r--r--gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst2
-rw-r--r--gcc/ada/doc/gnat_ugn/gnat_utility_programs.rst4
-rw-r--r--gcc/ada/doc/gnat_ugn/the_gnat_compilation_model.rst4
-rw-r--r--gcc/ada/einfo.adb178
-rw-r--r--gcc/ada/einfo.ads50
-rw-r--r--gcc/ada/errout.adb25
-rw-r--r--gcc/ada/errout.ads16
-rw-r--r--gcc/ada/exp_aggr.adb68
-rw-r--r--gcc/ada/exp_attr.adb330
-rw-r--r--gcc/ada/exp_ch11.adb85
-rw-r--r--gcc/ada/exp_ch13.adb5
-rw-r--r--gcc/ada/exp_ch2.adb44
-rw-r--r--gcc/ada/exp_ch3.adb218
-rw-r--r--gcc/ada/exp_ch4.adb440
-rw-r--r--gcc/ada/exp_ch5.adb74
-rw-r--r--gcc/ada/exp_ch6.adb213
-rw-r--r--gcc/ada/exp_ch7.adb850
-rw-r--r--gcc/ada/exp_ch7.ads7
-rw-r--r--gcc/ada/exp_ch8.adb12
-rw-r--r--gcc/ada/exp_ch9.adb25
-rw-r--r--gcc/ada/exp_dbug.adb32
-rw-r--r--gcc/ada/exp_disp.adb2
-rw-r--r--gcc/ada/exp_dist.adb2
-rw-r--r--gcc/ada/exp_fixd.adb385
-rw-r--r--gcc/ada/exp_imgv.adb334
-rw-r--r--gcc/ada/exp_intr.adb15
-rw-r--r--gcc/ada/exp_pakd.adb11
-rw-r--r--gcc/ada/exp_prag.adb34
-rw-r--r--gcc/ada/exp_sel.adb18
-rw-r--r--gcc/ada/exp_sel.ads9
-rw-r--r--gcc/ada/exp_spark.adb260
-rw-r--r--gcc/ada/exp_strm.adb30
-rw-r--r--gcc/ada/exp_tss.adb42
-rw-r--r--gcc/ada/exp_tss.ads1
-rw-r--r--gcc/ada/exp_unst.adb25
-rw-r--r--gcc/ada/exp_util.adb975
-rw-r--r--gcc/ada/exp_util.ads54
-rw-r--r--gcc/ada/expect.c8
-rw-r--r--gcc/ada/freeze.adb254
-rw-r--r--gcc/ada/gcc-interface/Make-lang.in13
-rw-r--r--gcc/ada/gcc-interface/Makefile.in13
-rw-r--r--gcc/ada/gcc-interface/decl.c93
-rw-r--r--gcc/ada/gcc-interface/gigi.h2
-rw-r--r--gcc/ada/gcc-interface/misc.c16
-rw-r--r--gcc/ada/gcc-interface/trans.c157
-rw-r--r--gcc/ada/gcc-interface/utils.c82
-rw-r--r--gcc/ada/gcc-interface/utils2.c32
-rw-r--r--gcc/ada/get_targ.adb32
-rw-r--r--gcc/ada/get_targ.ads4
-rw-r--r--gcc/ada/gnat1drv.adb27
-rw-r--r--gcc/ada/gnat_rm.texi1097
-rw-r--r--gcc/ada/gnat_ugn.texi39
-rw-r--r--gcc/ada/impunit.adb2
-rw-r--r--gcc/ada/inline.adb46
-rw-r--r--gcc/ada/inline.ads14
-rw-r--r--gcc/ada/lib-load.adb4
-rw-r--r--gcc/ada/lib-writ.adb13
-rw-r--r--gcc/ada/lib-xref.adb2
-rw-r--r--gcc/ada/lib.adb2
-rw-r--r--gcc/ada/libgnarl/s-osinte__solaris.ads3
-rw-r--r--gcc/ada/libgnarl/s-tasren.adb14
-rw-r--r--gcc/ada/libgnarl/s-tassta.adb11
-rw-r--r--gcc/ada/libgnarl/s-tpobop.adb10
-rw-r--r--gcc/ada/libgnarl/s-tporft.adb1
-rw-r--r--gcc/ada/libgnat/a-cbdlli.adb10
-rw-r--r--gcc/ada/libgnat/a-cbdlli.ads6
-rw-r--r--gcc/ada/libgnat/a-cbhase.adb2
-rw-r--r--gcc/ada/libgnat/a-cbmutr.ads2
-rw-r--r--gcc/ada/libgnat/a-cborse.adb2
-rw-r--r--gcc/ada/libgnat/a-cbsyqu.ads10
-rw-r--r--gcc/ada/libgnat/a-cdlili.adb10
-rw-r--r--gcc/ada/libgnat/a-cdlili.ads6
-rw-r--r--gcc/ada/libgnat/a-cidlli.adb10
-rw-r--r--gcc/ada/libgnat/a-cidlli.ads6
-rw-r--r--gcc/ada/libgnat/a-cihama.adb2
-rw-r--r--gcc/ada/libgnat/a-cobove.adb73
-rw-r--r--gcc/ada/libgnat/a-cobove.ads44
-rw-r--r--gcc/ada/libgnat/a-cohama.adb2
-rw-r--r--gcc/ada/libgnat/a-cohase.adb2
-rw-r--r--gcc/ada/libgnat/a-coinve.adb64
-rw-r--r--gcc/ada/libgnat/a-coinve.ads43
-rw-r--r--gcc/ada/libgnat/a-convec.adb80
-rw-r--r--gcc/ada/libgnat/a-convec.ads78
-rw-r--r--gcc/ada/libgnat/a-decima__128.ads69
-rw-r--r--gcc/ada/libgnat/a-except.adb30
-rw-r--r--gcc/ada/libgnat/a-nbnbin.adb193
-rw-r--r--gcc/ada/libgnat/a-nbnbin.ads2
-rw-r--r--gcc/ada/libgnat/a-nbnbre.adb247
-rw-r--r--gcc/ada/libgnat/a-nbnbre.ads4
-rw-r--r--gcc/ada/libgnat/a-strfix.ads894
-rw-r--r--gcc/ada/libgnat/a-strmap.ads179
-rw-r--r--gcc/ada/libgnat/a-stzhas.adb14
-rw-r--r--gcc/ada/libgnat/a-stzhas.ads6
-rw-r--r--gcc/ada/libgnat/a-tags.adb44
-rw-r--r--gcc/ada/libgnat/a-tags.ads50
-rw-r--r--gcc/ada/libgnat/a-ticoau.adb23
-rw-r--r--gcc/ada/libgnat/a-ticoau.ads35
-rw-r--r--gcc/ada/libgnat/a-ticoio.adb94
-rw-r--r--gcc/ada/libgnat/a-tideau.adb188
-rw-r--r--gcc/ada/libgnat/a-tideau.ads74
-rw-r--r--gcc/ada/libgnat/a-tideio.adb58
-rw-r--r--gcc/ada/libgnat/a-tideio__128.adb177
-rw-r--r--gcc/ada/libgnat/a-tifiau.adb159
-rw-r--r--gcc/ada/libgnat/a-tifiau.ads97
-rw-r--r--gcc/ada/libgnat/a-tifiio.adb737
-rw-r--r--gcc/ada/libgnat/a-tifiio.ads2
-rw-r--r--gcc/ada/libgnat/a-tifiio__128.adb436
-rw-r--r--gcc/ada/libgnat/a-tiflau.adb125
-rw-r--r--gcc/ada/libgnat/a-tiflau.ads31
-rw-r--r--gcc/ada/libgnat/a-tiflio.adb74
-rw-r--r--gcc/ada/libgnat/a-tiflio.ads2
-rw-r--r--gcc/ada/libgnat/a-tigeau.adb100
-rw-r--r--gcc/ada/libgnat/a-tigeau.ads6
-rw-r--r--gcc/ada/libgnat/a-wtcoau.adb23
-rw-r--r--gcc/ada/libgnat/a-wtcoau.ads45
-rw-r--r--gcc/ada/libgnat/a-wtcoio.adb95
-rw-r--r--gcc/ada/libgnat/a-wtcoio.ads16
-rw-r--r--gcc/ada/libgnat/a-wtdeau.adb192
-rw-r--r--gcc/ada/libgnat/a-wtdeau.ads75
-rw-r--r--gcc/ada/libgnat/a-wtdeio.adb73
-rw-r--r--gcc/ada/libgnat/a-wtdeio__128.adb190
-rw-r--r--gcc/ada/libgnat/a-wtenau.adb15
-rw-r--r--gcc/ada/libgnat/a-wtenio.adb4
-rw-r--r--gcc/ada/libgnat/a-wtfiau.adb159
-rw-r--r--gcc/ada/libgnat/a-wtfiau.ads97
-rw-r--r--gcc/ada/libgnat/a-wtfiio.adb171
-rw-r--r--gcc/ada/libgnat/a-wtfiio__128.adb326
-rw-r--r--gcc/ada/libgnat/a-wtflau.adb131
-rw-r--r--gcc/ada/libgnat/a-wtflau.ads39
-rw-r--r--gcc/ada/libgnat/a-wtflio.adb86
-rw-r--r--gcc/ada/libgnat/a-wtgeau.adb100
-rw-r--r--gcc/ada/libgnat/a-wtgeau.ads6
-rw-r--r--gcc/ada/libgnat/a-wtinio.adb15
-rw-r--r--gcc/ada/libgnat/a-wtinio__128.adb19
-rw-r--r--gcc/ada/libgnat/a-wtmoio.adb15
-rw-r--r--gcc/ada/libgnat/a-wtmoio__128.adb15
-rw-r--r--gcc/ada/libgnat/a-ztcoau.adb23
-rw-r--r--gcc/ada/libgnat/a-ztcoau.ads41
-rw-r--r--gcc/ada/libgnat/a-ztcoio.adb96
-rw-r--r--gcc/ada/libgnat/a-ztcoio.ads14
-rw-r--r--gcc/ada/libgnat/a-ztdeau.adb190
-rw-r--r--gcc/ada/libgnat/a-ztdeau.ads75
-rw-r--r--gcc/ada/libgnat/a-ztdeio.adb82
-rw-r--r--gcc/ada/libgnat/a-ztdeio__128.adb190
-rw-r--r--gcc/ada/libgnat/a-ztenau.adb15
-rw-r--r--gcc/ada/libgnat/a-ztenio.adb4
-rw-r--r--gcc/ada/libgnat/a-ztfiau.adb159
-rw-r--r--gcc/ada/libgnat/a-ztfiau.ads97
-rw-r--r--gcc/ada/libgnat/a-ztfiio.adb171
-rw-r--r--gcc/ada/libgnat/a-ztfiio__128.adb327
-rw-r--r--gcc/ada/libgnat/a-ztflau.adb133
-rw-r--r--gcc/ada/libgnat/a-ztflau.ads39
-rw-r--r--gcc/ada/libgnat/a-ztflio.adb85
-rw-r--r--gcc/ada/libgnat/a-ztgeau.adb100
-rw-r--r--gcc/ada/libgnat/a-ztgeau.ads6
-rw-r--r--gcc/ada/libgnat/a-ztinio.adb15
-rw-r--r--gcc/ada/libgnat/a-ztinio__128.adb19
-rw-r--r--gcc/ada/libgnat/a-ztmoio.adb15
-rw-r--r--gcc/ada/libgnat/a-ztmoio__128.adb15
-rw-r--r--gcc/ada/libgnat/g-diopit.adb5
-rw-r--r--gcc/ada/libgnat/g-diopit.ads2
-rw-r--r--gcc/ada/libgnat/g-expect.adb6
-rw-r--r--gcc/ada/libgnat/g-rannum.adb86
-rw-r--r--gcc/ada/libgnat/g-rannum.ads2
-rw-r--r--gcc/ada/libgnat/g-sercom__linux.adb92
-rw-r--r--gcc/ada/libgnat/g-socket.adb75
-rw-r--r--gcc/ada/libgnat/g-socpol.adb3
-rw-r--r--gcc/ada/libgnat/g-spogwa.adb6
-rw-r--r--gcc/ada/libgnat/memtrack.adb33
-rw-r--r--gcc/ada/libgnat/s-arit32.adb182
-rw-r--r--gcc/ada/libgnat/s-arit32.ads55
-rw-r--r--gcc/ada/libgnat/s-bitfie.ads6
-rw-r--r--gcc/ada/libgnat/s-bituti.adb1
-rw-r--r--gcc/ada/libgnat/s-dwalin.adb21
-rw-r--r--gcc/ada/libgnat/s-fatgen.adb682
-rw-r--r--gcc/ada/libgnat/s-fatgen.ads15
-rw-r--r--gcc/ada/libgnat/s-finmas.adb14
-rw-r--r--gcc/ada/libgnat/s-finmas.ads4
-rw-r--r--gcc/ada/libgnat/s-fode128.ads (renamed from gcc/ada/libgnat/s-fatsfl.ads)27
-rw-r--r--gcc/ada/libgnat/s-fode32.ads48
-rw-r--r--gcc/ada/libgnat/s-fode64.ads48
-rw-r--r--gcc/ada/libgnat/s-fofi128.ads50
-rw-r--r--gcc/ada/libgnat/s-fofi32.ads50
-rw-r--r--gcc/ada/libgnat/s-fofi64.ads50
-rw-r--r--gcc/ada/libgnat/s-fore_d.adb62
-rw-r--r--gcc/ada/libgnat/s-fore_d.ads47
-rw-r--r--gcc/ada/libgnat/s-fore_f.adb136
-rw-r--r--gcc/ada/libgnat/s-fore_f.ads54
-rw-r--r--gcc/ada/libgnat/s-forrea.adb (renamed from gcc/ada/libgnat/s-fore.adb)25
-rw-r--r--gcc/ada/libgnat/s-forrea.ads (renamed from gcc/ada/libgnat/s-fore.ads)15
-rw-r--r--gcc/ada/libgnat/s-genbig.adb26
-rw-r--r--gcc/ada/libgnat/s-genbig.ads4
-rw-r--r--gcc/ada/libgnat/s-imaged.adb (renamed from gcc/ada/libgnat/s-imglld.adb)39
-rw-r--r--gcc/ada/libgnat/s-imaged.ads (renamed from gcc/ada/libgnat/s-imglld.ads)41
-rw-r--r--gcc/ada/libgnat/s-imagef.adb362
-rw-r--r--gcc/ada/libgnat/s-imagef.ads (renamed from gcc/ada/libgnat/s-imgdec.ads)99
-rw-r--r--gcc/ada/libgnat/s-imagei.adb47
-rw-r--r--gcc/ada/libgnat/s-imageu.adb39
-rw-r--r--gcc/ada/libgnat/s-imde128.ads63
-rw-r--r--gcc/ada/libgnat/s-imde32.ads63
-rw-r--r--gcc/ada/libgnat/s-imde64.ads63
-rw-r--r--gcc/ada/libgnat/s-imfi128.ads69
-rw-r--r--gcc/ada/libgnat/s-imfi32.ads69
-rw-r--r--gcc/ada/libgnat/s-imfi64.ads69
-rw-r--r--gcc/ada/libgnat/s-imgrea.adb44
-rw-r--r--gcc/ada/libgnat/s-imgrea.ads7
-rw-r--r--gcc/ada/libgnat/s-imguti.adb (renamed from gcc/ada/libgnat/s-imgdec.adb)75
-rw-r--r--gcc/ada/libgnat/s-imguti.ads61
-rw-r--r--gcc/ada/libgnat/s-objrea.adb4
-rw-r--r--gcc/ada/libgnat/s-objrea.ads5
-rw-r--r--gcc/ada/libgnat/s-os_lib.adb25
-rw-r--r--gcc/ada/libgnat/s-powflt.ads85
-rw-r--r--gcc/ada/libgnat/s-powlfl.ads355
-rw-r--r--gcc/ada/libgnat/s-powllf.ads (renamed from gcc/ada/libgnat/s-powtab.ads)12
-rw-r--r--gcc/ada/libgnat/s-rannum.adb35
-rw-r--r--gcc/ada/libgnat/s-rident.ads2
-rw-r--r--gcc/ada/libgnat/s-secsta.adb15
-rw-r--r--gcc/ada/libgnat/s-stratt.adb210
-rw-r--r--gcc/ada/libgnat/s-stratt.ads107
-rw-r--r--gcc/ada/libgnat/s-trasym.ads3
-rw-r--r--gcc/ada/libgnat/s-vade128.ads (renamed from gcc/ada/libgnat/s-valdec.adb)54
-rw-r--r--gcc/ada/libgnat/s-vade32.ads58
-rw-r--r--gcc/ada/libgnat/s-vade64.ads60
-rw-r--r--gcc/ada/libgnat/s-vafi128.ads60
-rw-r--r--gcc/ada/libgnat/s-vafi32.ads60
-rw-r--r--gcc/ada/libgnat/s-vafi64.ads60
-rw-r--r--gcc/ada/libgnat/s-valflt.ads57
-rw-r--r--gcc/ada/libgnat/s-vallfl.ads57
-rw-r--r--gcc/ada/libgnat/s-vallld.adb70
-rw-r--r--gcc/ada/libgnat/s-valllf.ads57
-rw-r--r--gcc/ada/libgnat/s-valrea.adb641
-rw-r--r--gcc/ada/libgnat/s-valrea.ads19
-rw-r--r--gcc/ada/libgnat/s-valued.adb263
-rw-r--r--gcc/ada/libgnat/s-valued.ads (renamed from gcc/ada/libgnat/s-valdec.ads)44
-rw-r--r--gcc/ada/libgnat/s-valuef.adb368
-rw-r--r--gcc/ada/libgnat/s-valuef.ads (renamed from gcc/ada/libgnat/s-vallld.ads)59
-rw-r--r--gcc/ada/libgnat/s-valuei.adb2
-rw-r--r--gcc/ada/libgnat/s-valuer.adb685
-rw-r--r--gcc/ada/libgnat/s-valuer.ads101
-rw-r--r--gcc/ada/libgnat/system-aix.ads4
-rw-r--r--gcc/ada/libgnat/system-darwin-arm.ads4
-rw-r--r--gcc/ada/libgnat/system-darwin-ppc.ads4
-rw-r--r--gcc/ada/libgnat/system-darwin-x86.ads4
-rw-r--r--gcc/ada/libgnat/system-djgpp.ads4
-rw-r--r--gcc/ada/libgnat/system-dragonfly-x86_64.ads4
-rw-r--r--gcc/ada/libgnat/system-freebsd.ads4
-rw-r--r--gcc/ada/libgnat/system-hpux-ia64.ads4
-rw-r--r--gcc/ada/libgnat/system-hpux.ads4
-rw-r--r--gcc/ada/libgnat/system-linux-alpha.ads4
-rw-r--r--gcc/ada/libgnat/system-linux-arm.ads4
-rw-r--r--gcc/ada/libgnat/system-linux-hppa.ads4
-rw-r--r--gcc/ada/libgnat/system-linux-ia64.ads4
-rw-r--r--gcc/ada/libgnat/system-linux-m68k.ads4
-rw-r--r--gcc/ada/libgnat/system-linux-mips.ads4
-rw-r--r--gcc/ada/libgnat/system-linux-ppc.ads4
-rw-r--r--gcc/ada/libgnat/system-linux-riscv.ads4
-rw-r--r--gcc/ada/libgnat/system-linux-s390.ads4
-rw-r--r--gcc/ada/libgnat/system-linux-sh4.ads4
-rw-r--r--gcc/ada/libgnat/system-linux-sparc.ads4
-rw-r--r--gcc/ada/libgnat/system-linux-x86.ads4
-rw-r--r--gcc/ada/libgnat/system-lynxos178-ppc.ads6
-rw-r--r--gcc/ada/libgnat/system-lynxos178-x86.ads6
-rw-r--r--gcc/ada/libgnat/system-mingw.ads4
-rw-r--r--gcc/ada/libgnat/system-qnx-aarch64.ads4
-rw-r--r--gcc/ada/libgnat/system-rtems.ads4
-rw-r--r--gcc/ada/libgnat/system-solaris-sparc.ads4
-rw-r--r--gcc/ada/libgnat/system-solaris-x86.ads4
-rw-r--r--gcc/ada/libgnat/system-vxworks-arm-rtp-smp.ads4
-rw-r--r--gcc/ada/libgnat/system-vxworks-arm-rtp.ads4
-rw-r--r--gcc/ada/libgnat/system-vxworks-arm.ads4
-rw-r--r--gcc/ada/libgnat/system-vxworks-e500-kernel.ads4
-rw-r--r--gcc/ada/libgnat/system-vxworks-e500-rtp-smp.ads4
-rw-r--r--gcc/ada/libgnat/system-vxworks-e500-rtp.ads4
-rw-r--r--gcc/ada/libgnat/system-vxworks-e500-vthread.ads4
-rw-r--r--gcc/ada/libgnat/system-vxworks-ppc-kernel.ads4
-rw-r--r--gcc/ada/libgnat/system-vxworks-ppc-ravenscar.ads4
-rw-r--r--gcc/ada/libgnat/system-vxworks-ppc-rtp-smp.ads4
-rw-r--r--gcc/ada/libgnat/system-vxworks-ppc-rtp.ads4
-rw-r--r--gcc/ada/libgnat/system-vxworks-ppc-vthread.ads4
-rw-r--r--gcc/ada/libgnat/system-vxworks-ppc.ads4
-rw-r--r--gcc/ada/libgnat/system-vxworks-x86-kernel.ads4
-rw-r--r--gcc/ada/libgnat/system-vxworks-x86-rtp-smp.ads4
-rw-r--r--gcc/ada/libgnat/system-vxworks-x86-rtp.ads4
-rw-r--r--gcc/ada/libgnat/system-vxworks-x86-vthread.ads4
-rw-r--r--gcc/ada/libgnat/system-vxworks-x86.ads4
-rw-r--r--gcc/ada/libgnat/system-vxworks7-aarch64-rtp-smp.ads4
-rw-r--r--gcc/ada/libgnat/system-vxworks7-aarch64.ads4
-rw-r--r--gcc/ada/libgnat/system-vxworks7-arm-rtp-smp.ads4
-rw-r--r--gcc/ada/libgnat/system-vxworks7-arm.ads4
-rw-r--r--gcc/ada/libgnat/system-vxworks7-e500-kernel.ads4
-rw-r--r--gcc/ada/libgnat/system-vxworks7-e500-rtp-smp.ads4
-rw-r--r--gcc/ada/libgnat/system-vxworks7-e500-rtp.ads4
-rw-r--r--gcc/ada/libgnat/system-vxworks7-ppc-kernel.ads4
-rw-r--r--gcc/ada/libgnat/system-vxworks7-ppc-rtp-smp.ads4
-rw-r--r--gcc/ada/libgnat/system-vxworks7-ppc-rtp.ads4
-rw-r--r--gcc/ada/libgnat/system-vxworks7-ppc64-kernel.ads4
-rw-r--r--gcc/ada/libgnat/system-vxworks7-ppc64-rtp-smp.ads4
-rw-r--r--gcc/ada/libgnat/system-vxworks7-x86-kernel.ads4
-rw-r--r--gcc/ada/libgnat/system-vxworks7-x86-rtp-smp.ads4
-rw-r--r--gcc/ada/libgnat/system-vxworks7-x86-rtp.ads4
-rw-r--r--gcc/ada/libgnat/system-vxworks7-x86_64-kernel.ads4
-rw-r--r--gcc/ada/libgnat/system-vxworks7-x86_64-rtp-smp.ads4
-rw-r--r--gcc/ada/make.adb20
-rw-r--r--gcc/ada/opt.ads17
-rw-r--r--gcc/ada/osint-c.adb8
-rw-r--r--gcc/ada/par-ch10.adb13
-rw-r--r--gcc/ada/par-ch11.adb5
-rw-r--r--gcc/ada/par-ch12.adb76
-rw-r--r--gcc/ada/par-ch13.adb36
-rw-r--r--gcc/ada/par-ch3.adb113
-rw-r--r--gcc/ada/par-ch4.adb90
-rw-r--r--gcc/ada/par-ch5.adb28
-rw-r--r--gcc/ada/par-ch6.adb41
-rw-r--r--gcc/ada/par-ch9.adb27
-rw-r--r--gcc/ada/par-load.adb2
-rw-r--r--gcc/ada/par-prag.adb9
-rw-r--r--gcc/ada/par-tchk.adb1
-rw-r--r--gcc/ada/par.adb4
-rw-r--r--gcc/ada/repinfo.adb80
-rw-r--r--gcc/ada/repinfo.ads88
-rw-r--r--gcc/ada/rtsfind.adb2
-rw-r--r--gcc/ada/rtsfind.ads152
-rw-r--r--gcc/ada/s-oscons-tmplt.c38
-rw-r--r--gcc/ada/sa_messages.ads2
-rw-r--r--gcc/ada/scng.adb19
-rw-r--r--gcc/ada/sem_aggr.adb183
-rw-r--r--gcc/ada/sem_attr.adb478
-rw-r--r--gcc/ada/sem_aux.adb116
-rw-r--r--gcc/ada/sem_aux.ads25
-rw-r--r--gcc/ada/sem_cat.adb9
-rw-r--r--gcc/ada/sem_ch10.adb16
-rw-r--r--gcc/ada/sem_ch11.adb2
-rw-r--r--gcc/ada/sem_ch12.adb98
-rw-r--r--gcc/ada/sem_ch13.adb1143
-rw-r--r--gcc/ada/sem_ch13.ads37
-rw-r--r--gcc/ada/sem_ch3.adb191
-rw-r--r--gcc/ada/sem_ch4.adb20
-rw-r--r--gcc/ada/sem_ch5.adb126
-rw-r--r--gcc/ada/sem_ch6.adb333
-rw-r--r--gcc/ada/sem_ch8.adb93
-rw-r--r--gcc/ada/sem_ch9.adb20
-rw-r--r--gcc/ada/sem_disp.adb2
-rw-r--r--gcc/ada/sem_elab.adb18
-rw-r--r--gcc/ada/sem_eval.adb325
-rw-r--r--gcc/ada/sem_eval.ads5
-rw-r--r--gcc/ada/sem_prag.adb475
-rw-r--r--gcc/ada/sem_res.adb361
-rw-r--r--gcc/ada/sem_type.adb118
-rw-r--r--gcc/ada/sem_util.adb914
-rw-r--r--gcc/ada/sem_util.ads60
-rw-r--r--gcc/ada/sem_warn.adb39
-rw-r--r--gcc/ada/sinfo.adb16
-rw-r--r--gcc/ada/sinfo.ads18
-rw-r--r--gcc/ada/snames.ads-tmpl191
-rw-r--r--gcc/ada/spark_xrefs.ads3
-rw-r--r--gcc/ada/stand.ads9
-rw-r--r--gcc/ada/switch-c.adb6
-rw-r--r--gcc/ada/symbols.adb90
-rw-r--r--gcc/ada/symbols.ads115
-rw-r--r--gcc/ada/targparm.adb16
-rw-r--r--gcc/ada/targparm.ads10
-rw-r--r--gcc/ada/terminals.c2
-rw-r--r--gcc/ada/tracebak.c7
-rw-r--r--gcc/ada/ttypes.ads31
-rw-r--r--gcc/ada/uintp.ads12
-rw-r--r--gcc/ada/urealp.adb168
-rw-r--r--gcc/ada/urealp.ads32
-rw-r--r--gcc/ada/validsw.adb50
-rw-r--r--gcc/ada/validsw.ads13
-rw-r--r--gcc/ada/vxworks7-cert-rtp-link.spec9
-rw-r--r--gcc/ada/xsnamest.adb9
395 files changed, 23451 insertions, 10124 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 4b4e760..5ce188d 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,3134 @@
+2020-12-17 Arnaud Charlet <charlet@adacore.com>
+
+ * libgnat/a-tags.ads, libgnat/a-tags.adb (CW_Membership): Move
+ to spec to allow inlining.
+
+2020-12-17 Arnaud Charlet <charlet@adacore.com>
+
+ * checks.adb: Remove, not used.
+ * checks.ads: Likewise.
+ * exp_ch6.adb: Likewise.
+ * exp_ch7.adb: Likewise.
+ * exp_ch7.ads: Likewise.
+ * exp_fixd.adb: Likewise.
+ * exp_tss.adb: Likewise.
+ * exp_tss.ads: Likewise.
+ * exp_util.adb: Likewise.
+ * exp_util.ads: Likewise.
+ * gnat1drv.adb: Likewise.
+ * libgnat/s-finmas.adb: Likewise.
+ * libgnat/s-finmas.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.
+ * repinfo.adb: Likewise.
+ * repinfo.ads: Likewise.
+ * rtsfind.ads: Likewise.
+ * sem_aux.adb: Likewise.
+ * sem_aux.ads: Likewise.
+ * sem_ch13.adb: Likewise.
+ * sem_ch13.ads: Likewise.
+ * sem_util.adb (Validity_Checks_Suppressed, TSS,
+ Is_All_Null_Statements, Known_Non_Negative,
+ Non_Limited_Designated_Type, Get_Binary_Nkind, Get_Unary_Nkind,
+ Is_Protected_Operation, Number_Components, Package_Body,
+ Validate_Independence, Independence_Checks): Likewise; update
+ comments.
+ * targparm.adb: Likewise.
+ * targparm.ads (AAM, AAM_Str, Fractional_Fixed_Ops,
+ Frontend_Layout, Make_Detach_Call, Target_Has_Fixed_Ops, Detach,
+ Back_End_Layout, Create_Dynamic_SO_Ref, Get_Dynamic_SO_Entity,
+ Is_Dynamic_SO_Ref, Is_Static_SO_Ref,
+ Fractional_Fixed_Ops_On_Target): Likewise.
+ * validsw.adb (Save_Validity_Check_Options,
+ Set_Default_Validity_Check_Options): Likewise.
+ * validsw.ads: Likewise.
+
+2020-12-17 Arnaud Charlet <charlet@adacore.com>
+
+ * symbols.ads, symbols.adb: Removed no longer used.
+
+2020-12-17 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_util.adb (New_Requires_Transient_Scope): Renamed
+ Requires_Transient_Scope.
+ (Requires_Transient_Scope, Old_Requires_Transient_Scope,
+ Results_Differ): Removed.
+ * debug.adb: Remove -gnatdQ.
+
+2020-12-17 Eric Botcazou <ebotcazou@adacore.com>
+
+ * libgnat/s-valrea.adb (Need_Extra): Fix comment.
+
+2020-12-17 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_ch5.adb (Analyze_Case_Statement): Move modification of
+ Unblocked_Exit_Count after early return statements; fix typo in
+ comment.
+
+2020-12-17 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_ch5.adb (Analyze_Case_Statement): Change local variable
+ Exp to constant; remove unreferenced Last_Choice variable;
+ reduce scope of other variables.
+ (Analyze_If_Statement): Reduce scope of a local variable; add
+ comment.
+
+2020-12-17 Piotr Trojanek <trojanek@adacore.com>
+
+ * opt.ads (Multiple_Unit_Index): Refine type from Int to Nat.
+
+2020-12-17 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_util.adb (In_Check_Node): Add guard and rename Node to
+ Par, just like it is done in surrounding routines, e.g.
+ In_Assertion_Expression_Pragma and In_Generic_Formal_Package.
+
+2020-12-17 Bob Duff <duff@adacore.com>
+
+ * libgnat/a-cbdlli.adb, libgnat/a-cbdlli.ads,
+ libgnat/a-cdlili.adb, libgnat/a-cdlili.ads,
+ libgnat/a-cidlli.adb, libgnat/a-cidlli.ads,
+ libgnat/a-cobove.adb, libgnat/a-cobove.ads,
+ libgnat/a-coinve.adb, libgnat/a-coinve.ads,
+ libgnat/a-convec.adb, libgnat/a-convec.ads: Add *_Vector
+ operations, remove default for Count, rename Append_One to be
+ Append.
+
+2020-12-17 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_res.adb (Resolve_Declare_Expression): Need to establish a
+ transient scope in case Expression (N) requires actions to be
+ wrapped. Code cleanup.
+ * exp_ch7.adb, exp_ch11.adb: Code cleanup.
+
+2020-12-17 Piotr Trojanek <trojanek@adacore.com>
+
+ * par-ch3.adb (P_Identifier_Declarations): Reuse
+ Error_Msg_Ada_2020_Feature for object renaming without subtype.
+ * par-ch4.adb (P_Primary): Likewise for target name.
+ (P_Iterated_Component_Association): Likewise for iterated
+ component.
+ (P_Declare_Expression): Likewise for declare expression.
+ * par-ch6.adb (P_Formal_Part): Likewise for aspect on formal
+ parameter.
+ * sem_aggr.adb (Resolve_Delta_Aggregate): Ditto.
+ * sem_ch8.adb (Analyze_Object_Renaming): Reuse
+ Error_Msg_Ada_2020_Feature.
+ * sem_ch13.adb (Validate_Aspect_Aggregate): Reuse
+ Error_Msg_Ada_2020_Feature; use lower case for "aspect" and
+ don't use underscore for "Ada_2020"; don't give up on analysis
+ in Ada 2012 mode.
+ (Validate_Aspect_Stable_Properties): Reuse
+ Error_Msg_Ada_2020_Feature; use lower case for "aspect"; minor
+ style fixes.
+
+2020-12-17 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_ch4.adb (Analyze_Selected_Component): Request a compile
+ time error replacement in Apply_Compile_Time_Constraint_Error
+ in case of an invalid field.
+ * sem_ch3.adb (Create_Constrained_Components): Take advantage of
+ Gather_Components also in the case of a record extension and
+ also constrain records in the case of compile time known discriminant
+ values, as already done in gigi.
+ * sem_util.ads, sem_util.adb (Gather_Components): New parameter
+ Allow_Compile_Time to allow compile time known (but non static)
+ discriminant values, needed by Create_Constrained_Components,
+ and new parameter Include_Interface_Tag.
+ (Is_Dependent_Component_Of_Mutable_Object): Use Original_Node to
+ perform check on the original tree.
+ (Is_Object_Reference): Likewise. Only call Original_Node when
+ relevant via a new function Safe_Prefix.
+ (Is_Static_Discriminant_Component, In_Check_Node): New.
+ (Is_Actual_Out_Or_In_Out_Parameter): New.
+ * exp_ch4.adb (Expand_N_Selected_Component): Remove no longer needed
+ code preventing evaluating statically discriminants in more cases.
+ * exp_ch5.adb (Expand_N_Loop_Statement): Simplify expansion of loops
+ with an N_Raise_xxx_Error node to avoid confusing the code generator.
+ (Make_Component_List_Assign): Try to find a constrained type to
+ extract discriminant values from, so that the case statement
+ built gets an opportunity to be folded by
+ Expand_N_Case_Statement.
+ (Expand_Assign_Record): Update comments, code cleanups.
+ * sem_attr.adb (Analyze_Attribute): Perform most of the analysis
+ on the original prefix node to deal properly with a prefix rewritten
+ as a N_Raise_xxx_Error.
+ * sem_ch5.adb (Analyze_Loop_Parameter_Specification): Handle properly
+ a discrete subtype definition being rewritten as N_Raise_xxx_Error.
+ * sem_ch8.adb (Analyze_Object_Renaming): Handle N_Raise_xxx_Error
+ nodes as part of the expression being renamed.
+ * sem_eval.ads, sem_eval.adb (Fold, Eval_Selected_Component): New.
+ (Compile_Time_Known_Value, Expr_Value, Expr_Rep_Value): Evaluate
+ static discriminant component values.
+ * sem_res.adb (Resolve_Selected_Component): Call
+ Eval_Selected_Component.
+
+2020-12-17 Piotr Trojanek <trojanek@adacore.com>
+
+ * exp_ch4.adb (Expand_N_Unchecked_Type_Conversion): Remove
+ folding of discrete values.
+ * exp_intr.adb (Expand_Unc_Conversion): Analyze, resolve and
+ evaluate (if possible) calls to instances of
+ Ada.Unchecked_Conversion after they have been expanded into
+ N_Unchecked_Type_Conversion.
+ * sem_eval.adb (Eval_Unchecked_Conversion): Add folding of
+ discrete values.
+
+2020-12-17 Eric Botcazou <ebotcazou@adacore.com>
+
+ * Makefile.rtl (GNATRTL_NONTASKING_OBJS): Likewise.
+ * exp_imgv.adb (Expand_Value_Attribute): Use RE_Value_Long_Float in
+ lieu of RE_Value_Long_Long_Float as fallback for fixed-point types.
+ Also use it for Long_Long_Float if it has same size as Long_Float.
+ * libgnat/s-imgrea.adb: Replace Powten_Table with Powen_LLF.
+ * libgnat/s-powflt.ads: New file.
+ * libgnat/s-powlfl.ads: Likewise.
+ * libgnat/s-powtab.ads: Rename to...
+ * libgnat/s-powllf.ads: ...this.
+ * libgnat/s-valflt.ads: Add with clause for System.Powten_Flt and
+ pass its table as actual parameter to System.Val_Real.
+ * libgnat/s-vallfl.ads: Likewise for System.Powten_LFlt.
+ * libgnat/s-valllf.ads: Likewise for System.Powten_LLF.
+ * libgnat/s-valrea.ads: Add Maxpow and Powten_Address parameters.
+ * libgnat/s-valrea.adb: Add pragma Warnings (Off).
+ (Need_Extra): New boolean constant.
+ (Precision_Limit): Set it according to Need_Extra.
+ (Impl): Adjust actual parameter.
+ (Integer_to_Rea): Add assertion on the machine radix. Take into
+ account the extra digit only if Need_Extra is true. Reimplement
+ the computation of the final value for bases 2, 4, 8, 10 and 16.
+ * libgnat/s-valued.adb (Impl): Adjust actual parameter.
+ (Scan_Decimal): Add pragma Unreferenced.
+ (Value_Decimal): Likewise.
+ * libgnat/s-valuef.adb (Impl): Adjust actual parameter.
+ * libgnat/s-valuer.ads (Floating): Remove.
+ (Round): New formal parameter.
+ * libgnat/s-valuer.adb (Round_Extra): New procedure.
+ (Scan_Decimal_Digits): Use it to round the extra digit if Round
+ is set to True in the instantiation.
+ (Scan_Integral_Digits): Likewise.
+
+2020-12-17 Erwan Le Guillou <leguillou@adacore.com>
+
+ * libgnat/system-lynxos178-ppc.ads,
+ libgnat/system-lynxos178-x86.ads: Fix small typo in comments.
+
+2020-12-17 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_dbug.adb (Get_Encoded_Name): Generate encodings for fixed
+ point types only if -fgnat-encodings=all is specified.
+
+2020-12-17 Justin Squirek <squirek@adacore.com>
+
+ * checks.adb (Build_Discriminant_Checks): Add condition to
+ replace references to the current instance of the type when we
+ are within an Init_Proc.
+ (Replace_Current_Instance): Examine a given node and replace the
+ current instance of the type with the corresponding _init
+ formal.
+ (Search_And_Replace_Current_Instance): Traverse proc which calls
+ Replace_Current_Instance in order to replace all references
+ within a given expression.
+
+2020-12-17 Piotr Trojanek <trojanek@adacore.com>
+
+ * par-ch12.adb (P_Formal_Derived_Type_Definition): Complain
+ about formal type with aspect specification, which only become
+ legal in Ada 2020.
+ * par-ch9.adb (P_Protected_Operation_Declaration_Opt): Reuse
+ Error_Msg_Ada_2005_Extension.
+ (P_Entry_Declaration): Likewise.
+ * scng.adb (Scan): Improve diagnostics for target_name; emit
+ error, but otherwise continue in earlier than Ada 2020 modes.
+
+2020-12-17 Ed Schonberg <schonberg@adacore.com>
+
+ * libgnat/a-cbsyqu.ads (Implementation): Provide a box
+ initialization for the element array used internally to
+ represent the queue, so that its components are properly
+ initialized if the given element type has default
+ initialization. Suppress warnings on the rest of the package in
+ case the element type has no default or discriminant, because it
+ is bound to be confusing to the user.
+
+2020-12-17 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_util.adb (Inherit_Predicate_Flags): No-op before Ada 2012.
+
+2020-12-17 Arnaud Charlet <charlet@adacore.com>
+
+ * exp_ch7.adb (Make_Final_Call, Make_Init_Call): Take protected
+ types into account.
+ * sem_util.ads: Fix typo.
+
+2020-12-17 Yannick Moy <moy@adacore.com>
+
+ * checks.adb: Rework error messages.
+ * exp_ch3.adb: Likewise.
+ * freeze.adb: Likewise.
+ * lib-load.adb: Likewise.
+ * par-ch12.adb: Likewise.
+ * par-ch3.adb: Likewise.
+ * par-ch4.adb: Likewise.
+ * par-ch9.adb: Likewise.
+ * sem_aggr.adb: Likewise.
+ * sem_attr.adb: Likewise.
+ * sem_cat.adb: Likewise.
+ * sem_ch10.adb: Likewise.
+ * sem_ch12.adb: Likewise.
+ (Instantiate_Type): Fix CODEFIX comment, applicable only on
+ continuation message, and identify the second message as a
+ continuation.
+ * sem_ch13.adb: Rework error messages.
+ * sem_ch3.adb: Likewise.
+ * sem_ch4.adb: Likewise.
+ * sem_ch5.adb: Likewise.
+ * sem_ch6.adb: Likewise.
+ * sem_ch8.adb: Likewise.
+ * sem_ch9.adb: Likewise.
+ * sem_prag.adb: Likewise.
+ * sem_res.adb: Likewise.
+ * sem_util.adb: Likewise.
+ (Wrong_Type): Fix CODEFIX comment, applicable only on
+ continuation message, and identify the second message as a
+ continuation.
+ * symbols.adb: Rework error messages.
+
+2020-12-17 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_attr.adb (OK_Self_Reference): Return True if node does not
+ come from source (e.g. a rewritten aggregate).
+
+2020-12-17 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_ch13.adb (Parse_Aspect_Stable_Properties): Fix style;
+ limit the scope of local variables; remove extra assignment in
+ Extract_Entity.
+ (Validate_Aspect_Stable_Properties): Simplify with procedural
+ Next.
+
+2020-12-16 Arnaud Charlet <charlet@adacore.com>
+
+ * ali.ads, ali.adb, bindo-writers.adb, lib-writ.adb (Scope):
+ Renamed to IS_Scope.
+
+2020-12-16 Joffrey Huguet <huguet@adacore.com>
+
+ * libgnat/a-strfix.ads: Add postconditions and contract cases to
+ subprograms.
+
+2020-12-16 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch5.adb (Analyze_Iterator_Specification): If iterator
+ filter is present, preanalyze filter without expansion.
+ (Analyze_Loop_Parameter_Specification): When
+ loop_Parameter_Specification is rewritten as
+ Iterator_Specification, transfer Iterator_Filter if present.
+
+2020-12-16 Doug Rupp <rupp@adacore.com>
+
+ * libgnat/s-objrea.ads (Object_Arch): Add ARM enum
+ * libgnat/s-objrea.adb (Initialize): Add EM_ARM case.
+ (Read_Address): Add ARM case to 32bit read.
+ * Makefile.rtl: Add trasym units to the runtime for armhf-linux.
+
+2020-12-16 Dmitriy Anisimkov <anisimko@adacore.com>
+
+ * libgnat/g-expect.adb (Non_Blocking_Spawn): Deallocate elements
+ on Arg_List after calling Set_Up_Child_Communications.
+
+2020-12-16 Piotr Trojanek <trojanek@adacore.com>
+
+ * par-ch3.adb (P_Modular_Type_Definition): Remove colon from
+ error message.
+ * sem_ch11.adb (Check_Duplication): Likewise.
+ * sem_ch3.adb (Derived_Type_Declaration): Likewise.
+
+2020-12-16 Piotr Trojanek <trojanek@adacore.com>
+
+ * par-ch12.adb (P_Formal_Object_Declarations): Refine types to
+ Pos.
+
+2020-12-16 Piotr Trojanek <trojanek@adacore.com>
+
+ * impunit.adb (Not_Impl_Defined_Unit): Fix typo in iteration
+ over Non_Imp_File_Names_12 array.
+
+2020-12-16 Piotr Trojanek <trojanek@adacore.com>
+
+ * exp_ch9.adb, sem_warn.adb: Simplify membership test.
+
+2020-12-16 Piotr Trojanek <trojanek@adacore.com>
+
+ * exp_ch6.adb, exp_util.adb, sem_ch4.adb, sem_disp.adb,
+ sem_elab.adb: Simplify membership test.
+
+2020-12-16 Eric Botcazou <ebotcazou@adacore.com>
+
+ * libgnat/s-powtab.ads (Maxpow): Use explicit formula in comment.
+
+2020-12-16 Philippe Gil <gil@adacore.com>
+
+ * libgnarl/s-tporft.adb (Register_Foreign_Thread): Set
+ Global_Task_Lock_Nesting before using allocator.
+
+2020-12-16 Eric Botcazou <ebotcazou@adacore.com>
+
+ * libgnat/s-valrea.adb (Maxexp32): New constant array.
+ (Maxexp64): Likewise.
+ (Maxexp80): Likewise.
+ (Integer_to_Real): New local constants Maxexp and B.
+ When the exponent is too negative, do the divison in two steps.
+
+2020-12-16 Piotr Trojanek <trojanek@adacore.com>
+
+ * doc/gnat_rm/implementation_defined_pragmas.rst
+ (Test_Case): Change integer to float literals.
+ * gnat_rm.texi: Regenerate.
+
+2020-12-16 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_ch13.adb (Analyze_Aspect_Specifications): Add a codefix
+ for extra parentheses around aspect Annotate expression; reject
+ "(null record)" aggregate and extra parentheses around aspect
+ Test_Case expression.
+ * sem_prag.adb (Analyze_Pragma): Reject "null", "(null record)"
+ and extra parentheses around pragma Contract_Cases; likewise for
+ pragma Subprogram_Variant.
+
+2020-12-16 Dmitriy Anisimkov <anisimko@adacore.com>
+
+ * adaint.h (__gnat_in_child_after_fork): New flag to express
+ child process side after fork call.
+ * adaint.c (__gnat_portable_spawn): Set flag
+ __gnat_in_child_after_fork.
+ * expect.c (__gnat_expect_fork): Set __gnat_in_child_after_fork
+ to one on child side.
+ * libgnat/memtrack.adb
+ (In_Child_After_Fork): Flag to disable memory tracking.
+ (Allow_Trace): New routine defining if memory should be tracked.
+ (Alloc, Realloc, Free): Use Allow_Trace in "if" condition
+ instead of First_Call.
+
+2020-12-16 Yannick Moy <moy@adacore.com>
+
+ * libgnat/a-tifiio.adb: Mark body not in SPARK.
+ * libgnat/a-tifiio.ads: Mark spec in SPARK.
+ * libgnat/a-tifiio__128.adb: Mark body not in SPARK.
+
+2020-12-16 Eric Botcazou <ebotcazou@adacore.com>
+
+ * libgnat/s-valuer.adb (Scan_Decimal_Digits): Tweak overflow test.
+ (Scan_Integral_Digits): Likewise.
+
+2020-12-16 Pascal Obry <obry@adacore.com>
+
+ * s-oscons-tmplt.c: Add some OS constants.
+
+2020-12-15 Pascal Obry <obry@adacore.com>
+
+ * libgnat/g-sercom__linux.adb (Set): Use cfsetospeed and
+ cfsetispeed to set the baud rate. Clear non-blocking serial port
+ status when blocking is requested.
+
+2020-12-15 Eric Botcazou <ebotcazou@adacore.com>
+
+ * libgnat/s-valrea.adb (Integer_to_Real): Always use Extra.
+
+2020-12-15 Piotr Trojanek <trojanek@adacore.com>
+
+ * par-ch5.adb (P_Condition): Simplify condition for warning
+ about extra parens and make it easier to understand.
+
+2020-12-15 Piotr Trojanek <trojanek@adacore.com>
+
+ * errout.ads (Error_Msg_Ada_2005_Extension): New routine (spec).
+ * errout.adb (Error_Msg_Ada_2005_Extension): New routine (body).
+ * par-ch10.adb: Reuse new routine; correct casing for "LIMITED
+ WITH".
+ * par-ch11.adb: Likewise.
+ * par-ch12.adb: Likewise.
+ * par-ch3.adb: Likewise.
+ * par-ch4.adb: Likewise; replace "box" with "<>".
+ * par-ch6.adb: Likewise.
+ * par-ch9.adb: Likewise; correct casing for "THEN ABORT".
+
+2020-12-15 Eric Botcazou <ebotcazou@adacore.com>
+
+ * doc/gnat_ugn/gnat_and_program_execution.rst: Minor fix.
+ * gnat_ugn.texi: Regenerate.
+ * libgnat/s-valuer.ads (Precision_Limit): New formal parameter.
+ * libgnat/s-valuer.adb (Precision_Limit): Remove.
+ (Scan_Decimal_Digits): Robustify overflow check.
+ (Scan_Integral_Digits): Likewise.
+ * libgnat/s-valrea.adb: Add assertion on the size of the unsigned
+ type and instantiate System.Value_R with the mantissa limit.
+ (Integer_to_Real): Add Extra parameter and take it into account.
+ (Scan_Real): Pass Extra to Integer_to_Real.
+ (Value_Real): Likewise.
+ * libgnat/s-valued.adb: Add assertion on the size of the unsigned
+ type and instantiate System.Value_R with the mantissa limit.
+ * libgnat/s-valuef.adb: Likewise.
+
+2020-12-15 Justin Squirek <squirek@adacore.com>
+
+ * contracts.adb, contracts.ads (Build_Postconditions_Procedure):
+ Add declarations for Postcond_Enabled,
+ Result_Object_For_Postcondition, and
+ Return_Success_For_Postcond, and place all postconditions within
+ an if statement to control their execution for interactions when
+ cleanup actions get generated.
+ (Get_Postcond_Enabled): Created to fetch object declared to
+ handle new expansion of postconditions.
+ (Get_Result_Object_For_Postcond): Created to fetch object
+ declared to handle new expansion of postconditions.
+ (Get_Return_Success_For_Postcond): Created to fetch object
+ declared to handle new expansion of postconditions.
+ * einfo.adb, einfo.ads: Modify flag Stores_Attribute_Old_Prefix
+ to apply to constants, variables, and types.
+ * exp_ch6.adb (Add_Return): Add assignment to
+ Return_Success_For_Postcond.
+ (Expand_Non_Function_Return): Add assignment to
+ Return_Success_For_Postcond
+ (Expand_Simple_Function_Return): Add assignment to
+ Result_Object_For_Postcond and Return_Success_For_Postcond.
+ * exp_ch7.adb (Build_Finalization_Master): Mark finalization
+ masters which finalize types created store 'Old objects as
+ storing 'Old objects.
+ (Build_Finalizer): Created to generated a unified and special
+ expansion for finalization when postconditions are present.
+ (Build_Finalizer_Helper): Renamed Build_Finalizer and added
+ parameter to facilitate the creation of separate finalization
+ routines for 'Old objects and general objects.
+ (Create_Finalizer): Add condition for the insertion of the
+ finalizer spec to avoid malformed trees.
+ (Expand_Cleanup_Actions): Move _postconditions and related
+ declarations to the new declarative section. Fix the loop to
+ properly stop at the subprogram declaration for the
+ postconditions procedure and exclude its body from being moved
+ to the new list of declarations to avoid freezing issues.
+ * exp_prag.adb (Expand_Attributes): Mark temporary created to
+ store 'Old objects as storing a 'Old attribute.
+ * sem_ch6.adb (Find_What_Applies_To): Remove strange exception
+ to postconditions when traversing the scope stack.
+ * sem_prag.adb (Find_Related_Declaration_Or_Body): Use the newly
+ created Enclosing_HSS function to find the HSS for a potentially
+ nested statement.
+ * sem_util.adb, sem_util.ads (Declare_Indirect_Temp): Mark types
+ created to store 'Old objects as storing 'Old attributes.
+ (Enclosing_HSS): Created to find the enclosing handled sequence
+ of statements for a given statement.
+ * snames.ads-tmpl: Add multiple names to aid in the expansion of
+ finalization and to control the evaluation of postconditions.
+ Including _finalization_controller, a new routine to centralize
+ finalization actions and postcondition evaluation.
+
+2020-12-15 Piotr Trojanek <trojanek@adacore.com>
+
+ * par-ch5.adb (P_Loop_Parameter_Specification): Complain about
+ missing -gnat2020 switch.
+ (P_Iterator_Specification): Likewise.
+
+2020-12-15 Piotr Trojanek <trojanek@adacore.com>
+
+ * par-ch4.adb (P_Aggregate_Or_Paren_Expr): Simplify with
+ Append_New.
+
+2020-12-15 Eric Botcazou <ebotcazou@adacore.com>
+
+ * Makefile.rtl (GNATRTL_NONTASKING_OBJS): Remove s-fatsfl$(objext)
+ and add s-valflt$(objext), s-vallfl$(objext), s-valllf$(objext).
+ * exp_attr.adb (Find_Fat_Info): Merge Short_Float and Float cases.
+ * exp_imgv.adb (Expand_Value_Attribute): Replace RE_Value_Real with
+ RE_Value_Long_Long_Float for fixed-point types and use appropriate
+ base type for floating-point types.
+ * rtsfind.ads (RTU_Id): Remove System_Fat_IEEE_Long_Float,
+ System_Fat_IEEE_Short_Float and System_Val_Real, add System_Val_Flt,
+ System_Val_LFlt and System_Val_LLF.
+ (RE_Id): Remove RE_Attr_IEEE_Long, RE_Fat_IEEE_Long,
+ RE_Attr_IEEE_Short, RE_Fat_IEEE_Short, RE_Attr_Short_Float, add
+ RE_Value_Float, RE_Value_Long_Float, RE_Value_Long_Long_Float,
+ (RE_Unit_Table): Likewise.
+ * libgnat/a-ticoau.ads: Add with clause for Float_Aux and make the
+ package generic.
+ (Get): Change parameter types to Num.
+ (Put): Likewise.
+ (Gets): Likewise.
+ (Puts): Likewise.
+ * libgnat/a-ticoau.adb: Remove clause and renaming for Float_Aux.
+ (Get): Change parameter types to Num.
+ (Gets): Likewise.
+ (Put): Likewise.
+ (Puts): Likewise. Add conversion to Long_Long_Float.
+ * libgnat/a-ticoio.adb: Remove with clause for Ada.Text_IO, add with
+ clause for Float_Aux, add with and use clauses for System.Val_Flt,
+ System.Val_LFlt and System.Val_LLF. Instantiate Float_Aux and
+ Complex_Aux on Float, Long_Float, and Long_Long_Float.
+ (OK_Float): New boolean constant.
+ (OK_Long_Float): Likewise.
+ (Get): Call appropriate Get routine from auxiliary package.
+ (Get): Call appropriate Gets routine from auxiliary package.
+ (Put): Call appropriate Put routine from auxiliary package.
+ (Put): Call appropriate Puts routine from auxiliary package.
+ * libgnat/a-tideau.adb: Remove with and use clause for Float_Aux.
+ * libgnat/a-tifiau.adb: Likewise.
+ * libgnat/a-tifiio.adb: Add with and use clause for System.Val_LLF.
+ Instantiate Float_Aux on Long_Long_Float.
+ (Get): Adjust call to Get routine from auxiliary package.
+ (Get): Adjust call to Gets routine from auxiliary package.
+ (Put): Adjust call to Put routine from auxiliary package.
+ (Put): Adjust call to Puts routine from auxiliary package.
+ * libgnat/a-tifiio__128.adb: Likewise.
+ (Get): Likewise.
+ (Get): Likewise.
+ (Put): Likewise.
+ (Put): Likewise.
+ * libgnat/a-tiflau.ads: Make the package generic.
+ (Get): Change parameter type to Num.
+ (Put): Likewise.
+ (Gets): Likewise.
+ (Puts): Likewise.
+ * libgnat/a-tiflau.adb: Remove clauses for System.Val_Real.
+ (Get): Change parameter type to Num and call Scan routine.
+ (Gets): Likewise.
+ (Load_Real): Move to...
+ (Put): Change parameter type and add conversion to Long_Long_Float.
+ (Puts): Likewise.
+ * libgnat/a-tiflio.adb: Add with and use clauses for System.Val_Flt,
+ System.Val_LFlt and System.Val_LLF. Instantiate Float_Aux on Float,
+ Long_Float and Long_Long_Float.
+ (OK_Float): New boolean constant.
+ (OK_Long_Float): Likewise.
+ (Get): Call appropriate Get routine from auxiliary package.
+ (Get): Call previous variant.
+ (Get): Call appropriate Gets routine from auxiliary package.
+ (Put): Call appropriate Put routine from auxiliary package.
+ (Put): Call previous variant.
+ (Put): Call appropriate Puts routine from auxiliary package.
+ * libgnat/a-tigeau.ads (Load_Real): New procedure.
+ * libgnat/a-tigeau.adb (Load_Real): ...here.
+ * libgnat/a-wtcoau.ads: Add with clause for Float_Aux and make the
+ package generic.
+ (Get): Change parameter types to Num.
+ (Put): Likewise.
+ (Gets): Likewise.
+ (Puts): Likewise.
+ * libgnat/a-wtcoau.adb: Remove clause and renaming for Float_Aux.
+ (Get): Change parameter types to Num.
+ (Gets): Likewise.
+ (Put): Likewise.
+ (Puts): Likewise. Add conversion to Long_Long_Float.
+ * libgnat/a-wtcoio.ads: Remove use clause for Complex_Types and use
+ qualified names throughout accordingly.
+ * libgnat/a-wtcoio.adb: Remove clause for Ada.Unchecked_Conversion,
+ add with clause for Float_Aux, add clauses for System.Val_Flt,
+ System.Val_LFlt and System.Val_LLF. Add clause for Complex_Types.
+ Instantiate Float_Aux and Complex_Aux on Float, Long_Float, and
+ Long_Long_Float. Remove LLF subtype and TFT instantiation.
+ (OK_Float): New boolean constant.
+ (OK_Long_Float): Likewise.
+ (Get): Call appropriate Get routine from auxiliary package.
+ (Get): Call appropriate Gets routine from auxiliary package.
+ (Put): Call appropriate Put routine from auxiliary package.
+ (Put): Call appropriate Puts routine from auxiliary package.
+ * libgnat/a-wtdeau.adb: Remove with and use clause for Float_Aux.
+ * libgnat/a-wtfiau.adb: Likewise.
+ * libgnat/a-wtfiio.adb: Add with and use clause for System.Val_LLF.
+ Instantiate Float_Aux on Long_Long_Float.
+ (Get): Adjust call to Get routine from auxiliary package.
+ (Get): Adjust call to Gets routine from auxiliary package.
+ (Put): Adjust call to Put routine from auxiliary package.
+ (Put): Adjust call to Puts routine from auxiliary package.
+ * libgnat/a-wtfiio__128.adb: Likewise.
+ (Get): Likewise.
+ (Get): Likewise.
+ (Put): Likewise.
+ (Put): Likewise.
+ * libgnat/a-wtflau.ads: Make the package generic.
+ (Get): Change parameter type to Num.
+ (Put): Likewise.
+ (Gets): Likewise.
+ (Puts): Likewise.
+ * libgnat/a-wtflau.adb: Remove clauses for System.Val_Real.
+ (Get): Change parameter type to Num and call Scan routine. Set
+ Ptr parameter lazily.
+ (Gets): Likewise.
+ (Load_Real): Move to...
+ (Put): Change parameter type and add conversion to Long_Long_Float.
+ Bump buffer length to Max_Real_Image_Length.
+ (Puts): Likewise.
+ * libgnat/a-wtflio.adb: Add with and use clauses for System.Val_Flt,
+ System.Val_LFlt and System.Val_LLF. Instantiate Float_Aux on Float,
+ Long_Float and Long_Long_Float.
+ (OK_Float): New boolean constant.
+ (OK_Long_Float): Likewise.
+ (Get): Call appropriate Get routine from auxiliary package. Add
+ pragma Unsuppress (Range_Check) and manual validity check.
+ (Get): Call appropriate Gets routine from auxiliary package. Add
+ pragma Unsuppress (Range_Check) and manual validity check.
+ (Put): Call appropriate Put routine from auxiliary package.
+ (Put): Call appropriate Puts routine from auxiliary package.
+ * libgnat/a-wtgeau.ads (Load_Real): New procedure.
+ * libgnat/a-wtgeau.adb (Load_Real): ...here.
+ * libgnat/a-ztcoau.ads: Add with clause for Float_Aux and make the
+ package generic.
+ (Get): Change parameter types to Num.
+ (Put): Likewise.
+ (Gets): Likewise.
+ (Puts): Likewise.
+ * libgnat/a-ztcoau.adb: Remove clause and renaming for Float_Aux.
+ (Get): Change parameter types to Num.
+ (Gets): Likewise.
+ (Put): Likewise.
+ (Puts): Likewise. Add conversion to Long_Long_Float.
+ * libgnat/a-ztcoio.ads: Remove use clause for Complex_Types and use
+ qualified names throughout accordingly.
+ * libgnat/a-ztcoio.adb: Remove clause for Ada.Unchecked_Conversion,
+ add with clause for Float_Aux, add clauses for System.Val_Flt,
+ System.Val_LFlt and System.Val_LLF. Add clause for Complex_Types.
+ Instantiate Float_Aux and Complex_Aux on Float, Long_Float, and
+ Long_Long_Float. Remove LLF subtype and TFT instantiation.
+ (OK_Float): New boolean constant.
+ (OK_Long_Float): Likewise.
+ (Get): Call appropriate Get routine from auxiliary package.
+ (Get): Call appropriate Gets routine from auxiliary package.
+ (Put): Call appropriate Put routine from auxiliary package.
+ (Put): Call appropriate Puts routine from auxiliary package.
+ * libgnat/a-ztdeau.adb: Remove with and use clause for Float_Aux.
+ * libgnat/a-ztfiau.adb: Likewise.
+ * libgnat/a-ztfiio.adb: Add with and use clause for System.Val_LLF.
+ Instantiate Float_Aux on Long_Long_Float.
+ (Get): Adjust call to Get routine from auxiliary package.
+ (Get): Adjust call to Gets routine from auxiliary package.
+ (Put): Adjust call to Put routine from auxiliary package.
+ (Put): Adjust call to Puts routine from auxiliary package.
+ * libgnat/a-ztfiio__128.adb: Likewise.
+ (Get): Likewise.
+ (Get): Likewise.
+ (Put): Likewise.
+ (Put): Likewise.
+ * libgnat/a-ztflau.ads: Make the package generic.
+ (Get): Change parameter type to Num.
+ (Put): Likewise.
+ (Gets): Likewise.
+ (Puts): Likewise.
+ * libgnat/a-ztflau.adb: Remove clauses for System.Val_Real.
+ (Get): Change parameter type to Num and call Scan routine. Set
+ Ptr parameter lazily.
+ (Gets): Likewise.
+ (Load_Real): Move to...
+ (Put): Change parameter type and add conversion to Long_Long_Float.
+ Bump buffer length to Max_Real_Image_Length.
+ (Puts): Likewise.
+ * libgnat/a-ztflio.adb: Add with and use clauses for System.Val_Flt,
+ System.Val_LFlt and System.Val_LLF. Instantiate Float_Aux on Float,
+ Long_Float and Long_Long_Float.
+ (OK_Float): New boolean constant.
+ (OK_Long_Float): Likewise.
+ (Get): Call appropriate Get routine from auxiliary package. Add
+ pragma Unsuppress (Range_Check) and manual validity check.
+ (Get): Call appropriate Gets routine from auxiliary package. Add
+ pragma Unsuppress (Range_Check) and manual validity check.
+ (Put): Call appropriate Put routine from auxiliary package.
+ (Put): Call appropriate Puts routine from auxiliary package.
+ * libgnat/a-ztgeau.ads (Load_Real): New procedure.
+ * libgnat/a-ztgeau.adb (Load_Real): ...here.
+ * libgnat/s-fatsfl.ads: Delete.
+ * libgnat/s-valflt.ads: New package.
+ * libgnat/s-vallfl.ads: Likewise.
+ * libgnat/s-valllf.ads: Likewise.
+ * libgnat/s-valrea.ads: Make generic. Add assertions, defensive
+ code and clarify intent.
+ (Scan_Real): Change parameter type to Num.
+ (Value_Real): Likewise.
+ * libgnat/s-valrea.adb: Instantiate Value_R on Uns.
+ (Integer_to_Real): Change parameter and result to Num.
+ Call Float_Control.Reset only if the mantissa is 64 bits. Use
+ a divide to compute the final value if the scale is negative.
+ (Scan_Real): Change result to Num.
+ (Value_Real): Likewise.
+ * libgnat/s-valuer.adb: Add assertions, defensive code and
+ clarify intent.
+ (F_Limit): Delete.
+ (I_Limit): Likewise.
+ (Precision_Limit): Always use the integer limit.
+ * libgnat/s-fatgen.adb: Add pragma Annotate.
+
+2020-12-15 Yannick Moy <moy@adacore.com>
+
+ * libgnat/a-tiflio.adb: Mark body not in SPARK.
+ * libgnat/a-tiflio.ads: Mark spec in SPARK.
+
+2020-12-15 Arnaud Charlet <charlet@adacore.com>
+
+ * exp_ch6.adb (Build_Procedure_Body_Form): Adjust, the
+ declaration of the procedure form is now insert before the
+ original function body rather than after.
+ (Expand_N_Subprogram_Declaration): Deal with private types whose
+ full views are arrays.
+ * exp_unst.adb (Unnest_Subprogram): Deal with private types.
+ (Needs_Fat_Pointer): Code cleanup.
+ * freeze.adb (Freeze_Subprogram): Ditto.
+ * exp_util.adb (Build_Procedure_Form): Insert the procedure form
+ decl before and not after.
+ * sem_ch6.adb (Analyze_Subprogram_Body_Helper): Build missing
+ spec when needed for Transform_Function_Array.
+ * sem_util.adb (Get_Fullest_View): Deal with null entity.
+
+2020-12-15 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_ch13.adb (Analyze_Aspect_Specifications): Simplify code
+ for aspect Priority.
+ * sem_prag.adb (Analyze_Pragma): Simplify code for pragma
+ Priority.
+
+2020-12-15 Arnaud Charlet <charlet@adacore.com>
+
+ * exp_ch7.adb (Reset_Scopes_To_Block_Elab_Proc): Do not crash on
+ a block with no Identifier. Code cleanups.
+
+2020-12-15 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_attr.adb (Analyze_Attribute): Reuse existing code for
+ attribute Value when analyzing attributes Wide_Value and
+ Wide_Wide_Value.
+
+2020-12-15 Pascal Obry <obry@adacore.com>
+
+ * libgnat/g-diopit.adb (Find): Fix possible infinite recursion
+ in Find iterator.
+ * libgnat/g-diopit.ads (Find): Update comments accordingly.
+
+2020-12-15 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_attr.adb (Analyze_Attribute): Merge identical code for
+ Callable and Terminated attributes; refactor calls to Set_Etype
+ occurring in both THEN and ELSE branches of an IF statement for
+ attribute Storage_Size.
+
+2020-12-15 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_attr.adb (Analyze_Attribute): Merge identical code for
+ Wide_Wide_Width, Wide_Width and Width attributes.
+
+2020-12-15 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_attr.adb (Analyze_Attribute): Merge identical code for
+ Pred and Succ attributes.
+
+2020-12-15 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_attr.adb (Analyze_Attribute): Merge identical code for
+ Size, Object_Size and Value_Size attributes.
+
+2020-12-15 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_attr.adb (Analyze_Attribute): Consistently call
+ Check_Fixed_Point_Type before checking the number of attribute
+ expressions (like it is done for floating point types); reuse
+ Check_Fixed_Point_Type_0.
+
+2020-12-15 Piotr Trojanek <trojanek@adacore.com>
+
+ * exp_disp.adb (Make_Tags): Remove call to UI_To_Int.
+ * sem_attr.adb (Check_Array_Type): Likewise; also, refine type
+ of a local variable.
+ (Analyze_Attribute): Likewise.
+ (Get_Enclosing_Object): Likewise.
+ * sem_util.adb (Get_Enum_Lit_From_Pos): Likewise.
+
+2020-12-15 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_attr.adb (Analyze_Attribute): Merge identical code for
+ First_Bit/Last_Bit and Position attributes.
+
+2020-12-15 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_attr.adb (Analyze_Attribute): Merge identical code for
+ Machine_Radix and Mantissa attributes.
+
+2020-12-15 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_attr.adb (Analyze_Attribute): Merge identical code for
+ Machine_Overflows and Machine_Rounds attributes.
+
+2020-12-15 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_attr.adb (Analyze_Attribute): Merge identical code for
+ Large, Small, Safe_Large and Safe_Small attributes.
+
+2020-12-15 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_attr.adb (Analyze_Attribute): Merge identical code for
+ Epsilon, Model_Epsilon, Model_Small, Safe_First and Safe_Las
+ attributes.
+
+2020-12-15 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_attr.adb (Analyze_Attribute): Merge identical code for
+ Emax, Machine_Emax, Machine_Emin, Machine_Mantissa, Model_Emin,
+ Model_Mantissa and Safe_Emax attributes.
+
+2020-12-15 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_attr.adb (Analyze_Attribute): Merge identical code for
+ Denorm and Signed_Zeros attributes.
+
+2020-12-15 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_attr.adb (Analyze_Attribute): Merge identical code for
+ Adjacent, Copy_Sign and Remainder attributes.
+ (Check_Floating_Point_Type_2): Fix style in comment.
+
+2020-12-15 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_attr.adb (Analyze_Attribute): Merge identical code for
+ Compose, Leading_Part and Scaling attributes.
+
+2020-12-14 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_attr.adb (Analyze_Attribute): Resolve second parameter of
+ attribute Scaling just like it is resolved for a similar
+ attribute Compose.
+
+2020-12-14 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_attr.adb (Analyze_Attribute): Merge identical code for
+ First/Last, First_Bit/Last_Bit and First_Valid/Last_Valid
+ attributes.
+
+2020-12-14 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_attr.adb (Analyze_Attribute): Merge similar code for
+ Truncation and other floating point attributes.
+
+2020-12-14 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_attr.adb (Analyze_Attribute): Merge identical code for
+ Ceiling, Floor, Fraction, Machine, Machine_Rounding, Model,
+ Rounding and Unbiased_Rounding.
+
+2020-12-14 Eric Botcazou <ebotcazou@adacore.com>
+
+ * libgnat/a-tifiio.adb: Adjust documentation.
+ (OK_Get_32): Compare the object size of the base type.
+ (OK_Put_32): Likewise.
+ (OK_Get_64): Likewise.
+ (OK_Put_64): Likewise.
+ * libgnat/a-tifiio__128.adb: Adjust documentation.
+ (OK_Get_32): Compare the object size of the base type.
+ (OK_Put_32): Likewise.
+ (OK_Get_64): Likewise.
+ (OK_Put_64): Likewise.
+ (OK_Get_128): Likewise.
+ (OK_Put_128): Likewise.
+ * libgnat/a-wtfiio.adb (OK_Get_32): Likewise.
+ (OK_Put_32): Likewise.
+ (OK_Get_64): Likewise.
+ (OK_Put_64): Likewise
+ * libgnat/a-wtfiio__128.adb (OK_Get_32): Likewise.
+ (OK_Put_32): Likewise.
+ (OK_Get_64): Likewise.
+ (OK_Put_64): Likewise.
+ (OK_Get_128): Likewise.
+ (OK_Put_128): Likewise.
+ * libgnat/a-ztfiio.adb (OK_Get_32): Likewise.
+ (OK_Put_32): Likewise.
+ (OK_Get_64): Likewise.
+ (OK_Put_64): Likewise
+ * libgnat/a-ztfiio__128.adb (OK_Get_32): Likewise.
+ (OK_Put_32): Likewise.
+ (OK_Get_64): Likewise.
+ (OK_Put_64): Likewise.
+ (OK_Get_128): Likewise.
+ (OK_Put_128): Likewise.
+
+2020-12-14 Eric Botcazou <ebotcazou@adacore.com>
+
+ * libgnat/a-tifiio.adb (Get): Replace Current_Input with Current_In.
+ * libgnat/a-tifiio__128.adb: (Get): Likewise.
+ * libgnat/a-wtcoio.adb (Get): Likewise.
+ (Put): Replace Current_Output with Current_Out.
+ * libgnat/a-wtdeio.adb (Get): Likewise.
+ (Put): Likewise.
+ * libgnat/a-wtdeio__128.adb (Get): Likewise.
+ (Put): Likewise.
+ * libgnat/a-wtenio.adb (Get): Likewise.
+ (Put): Likewise.
+ * libgnat/a-wtfiio.adb (Get): Likewise.
+ (Put): Likewise.
+ * libgnat/a-wtfiio__128.adb (Get): Likewise.
+ (Put): Likewise.
+ * libgnat/a-wtflio.adb (Get): Likewise.
+ (Put): Likewise.
+ * libgnat/a-wtinio.adb (Get): Likewise.
+ (Put): Likewise.
+ * libgnat/a-wtinio__128.adb (Get): Likewise.
+ (Put): Likewise.
+ * libgnat/a-wtmoio.adb (Get): Likewise.
+ (Put): Likewise.
+ * libgnat/a-wtmoio__128.adb (Get): Likewise.
+ (Put): Likewise.
+ * libgnat/a-ztcoio.adb (Get): Likewise.
+ (Put): Likewise.
+ * libgnat/a-ztdeio.adb (Get): Likewise.
+ (Put): Likewise.
+ * libgnat/a-ztdeio__128.adb (Get): Likewise.
+ (Put): Likewise.
+ * libgnat/a-ztenio.adb (Get): Likewise.
+ (Put): Likewise.
+ * libgnat/a-ztfiio.adb (Get): Likewise.
+ (Put): Likewise.
+ * libgnat/a-ztfiio__128.adb (Get): Likewise.
+ (Put): Likewise.
+ * libgnat/a-ztflio.adb (Get): Likewise.
+ (Put): Likewise.
+ * libgnat/a-ztinio.adb (Get): Likewise.
+ (Put): Likewise.
+ * libgnat/a-ztinio__128.adb (Get): Likewise.
+ (Put): Likewise.
+ * libgnat/a-ztmoio.adb (Get): Likewise.
+ (Put): Likewise.
+ * libgnat/a-ztmoio__128.adb (Get): Likewise.
+ (Put): Likewise.
+
+2020-12-14 Justin Squirek <squirek@adacore.com>
+
+ * sem_util.adb, sem_util.ads (In_Generic_Formal_Package):
+ Created to identify type declarations occurring within generic
+ formal packages.
+ * sem_res.adb (Resolve_Allocator): Add condition to avoid
+ emitting an error for allocators when the type being allocated
+ is class-wide and from a generic formal package.
+
+2020-12-14 Eric Botcazou <ebotcazou@adacore.com>
+
+ * libgnat/s-fatgen.adb (Tiny80): Add alignment clause.
+
+2020-12-14 Arnaud Charlet <charlet@adacore.com>
+
+ * exp_util.adb (Process_Current_Value_Condition): Add assertion.
+ * libgnat/s-fatgen.adb (Scaling): Add annotation.
+
+2020-12-14 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_eval.adb (Fold_Shift): Compute values using the base type.
+
+2020-12-14 Eric Botcazou <ebotcazou@adacore.com>
+
+ * libgnat/s-fatgen.adb: Add with clause for Interfaces and use
+ type clause for Interfaces.Unsigned_64.
+ (Small): Comment out.
+ (Tiny): Likewise.
+ (Tiny16): New integer constant.
+ (Tiny32): Likewise.
+ (Tiny64): Likewise.
+ (Tiny80): New integer array constant.
+ (Pred): Declare a local overlay for Tiny.
+ (Succ): Likewise.
+
+2020-12-14 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_pakd.adb (Expand_Bit_Packed_Element_Set): Fix again packed
+ array type in complex cases where array is Volatile.
+ * exp_util.adb (Remove_Side_Effects): Do not force a renaming to
+ be handled by the back-end.
+
+2020-12-14 Eric Botcazou <ebotcazou@adacore.com>
+
+ * libgnat/s-fatgen.adb: Remove use clause for
+ System.Unsigned_Types.
+ (Scaling): Add renaming of System.Unsigned_Types and use type
+ clause for Long_Long_Unsigned.
+
+2020-12-14 Eric Botcazou <ebotcazou@adacore.com>
+
+ * libgnat/s-fatgen.ads (Compose): Add pragma Inline.
+ (Copy_Sign): Likewise.
+ (Exponent): Likewise.
+ (Fraction): Likewise.
+ * libgnat/s-fatgen.adb: Remove with clause for System, add
+ with and use clauses for System.Unsigned_Types.
+ Add pragma Warnings (Off) for non-static constants.
+ Remove precomputed tables of powers of radix and add a few
+ constants describing the floating-point format.
+ (Gradual_Scaling): Delete.
+ (Copy_Sign): Reimplement directly.
+ (Decompose): Likewise.
+ (Scaling): Likewise.
+ (Pred): Speed up.
+ (Succ): Likewise.
+ (Truncation): Tidy up.
+ (Valid): Move constants to library level.
+
+2020-12-14 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_eval.adb (CV_Cache): Remove initialization at elaboration.
+
+2020-12-14 Gary Dismukes <dismukes@adacore.com>
+
+ * doc/gnat_ugn/building_executable_programs_with_gnat.rst:
+ Correct documentation of the -gnatw.K switch to say that it
+ disables rather than activates the warning.
+ * gnat_ugn.texi: Regenerate.
+
+2020-12-14 Doug Rupp <rupp@adacore.com>
+
+ * tracebak.c: Add a section for ARM Linux.
+
+2020-12-14 Ghjuvan Lacambre <lacambre@adacore.com>
+
+ * par-ch3.adb (P_Discriminant_Part_Opt): Parse aspects, update
+ documentation.
+ * par-ch6.adb (P_Return_Statement): Likewise.
+ * par-ch9.adb (P_Entry_Index_Specification): Likewise.
+
+2020-12-14 Gary Dismukes <dismukes@adacore.com>
+
+ * exp_aggr.adb (Build_Array_Aggr_Code.Gen_Assign): Move
+ generation of the call for DIC check past the optional
+ generation of calls to controlled Initialize procedures.
+ * exp_ch3.adb
+ (Build_Array_Init_Proc.Init_One_Dimension.Possible_DIC_Call):
+ Suppress generation of a DIC call when the array component type
+ is controlled. The call will now be generated later inside the
+ array's DI (Deep_Initialize) procedure.
+ * exp_ch7.adb
+ (Make_Deep_Array_Body.Build_Initialize_Statements): Generate a
+ DIC call (when needed by the array component type) after any
+ call to the component type's controlled Initialize procedure, or
+ generate the DIC call by itself if there's no Initialize to
+ call.
+ * sem_aggr.adb (Resolve_Record_Aggregate.Add_Association):
+ Simplify condition to only test Is_Box_Init_By_Default (previous
+ condition was overkill, as well as incorrect in some cases).
+ * sem_elab.adb (Active_Scenarios.Output_Call): For
+ Default_Initial_Condition, suppress call to
+ Output_Verification_Call when the subprogram is a partial DIC
+ procedure.
+
+2020-12-14 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_attr.adb (Expand_N_Attribute_Reference) <Attribute_Round>:
+ Adjust commentary and set the Rounded_Result flag on the type
+ conversion node when the node is needed.
+ * exp_ch4.adb (Expand_N_Type_Conversion): Minor tweak.
+ (Fixup_Universal_Fixed_Operation): Look through the type conversion
+ only when it is to Universal_Real.
+ * exp_fixd.adb: Remove with and use clauses for Snames.
+ (Build_Divide): Remove redundant test.
+ (Expand_Convert_Float_To_Fixed): Use Rounded_Result flag on the
+ node to set the truncation parameter.
+
+2020-12-14 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_prag.adb (Analyze_Refinement_Clause): Simplify recently
+ added code for preventing cascaded errors.
+
+2020-12-14 Bob Duff <duff@adacore.com>
+
+ * exp_ch6.adb (Is_Build_In_Place_Result_Type): Further narrow
+ the conditions under which we enable build-in-place for
+ controlled types.
+
+2020-12-14 Yannick Moy <moy@adacore.com>
+
+ * sem_warn.adb (Output_Non_Modified_In_Out_Warnings): Use right
+ warning control character 'k' in both comment and call to
+ Errout_Msg_N.
+
+2020-12-14 Yannick Moy <moy@adacore.com>
+
+ * sem_prag.adb (Analyze_Refined_State_In_Decl_Part): Refine the
+ error message for missing Part_Of on constituent. Avoid
+ cascading error.
+
+2020-12-14 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_prag.adb (Analyze_Depends_In_Decl_Part): Replace early
+ returns with goto Leave.
+ (Collect_Subprogram_Inputs_Outputs): Fix style in comment.
+
+2020-12-14 Eric Botcazou <ebotcazou@adacore.com>
+
+ * libgnat/s-fatgen.ads (Valid): Add again pragma Inline.
+ * libgnat/s-fatgen.adb (Valid): Improve commentary, tidy up left
+ and right, and remove superfluous trick for denormalized numbers.
+
+2020-12-14 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_prag.adb (Find_Role): Constant object of
+ access-to-constant and access-to-subprogram types are not
+ writable.
+ (Collect_Subprogram_Inputs_Outputs): In-parameters of
+ access-to-variable type can act as outputs of the Depends
+ contracts.
+
+2020-12-14 Piotr Trojanek <trojanek@adacore.com>
+
+ * sa_messages.ads: Reference Subprogram_Variant in the comment
+ for Assertion_Check.
+ * sem_prag.adb (Analyze_Pragma): Add Subprogram_Variant as an
+ ID_ASSERTION_KIND; move Default_Initial_Condition as an
+ RM_ASSERTION_KIND.
+
+2020-12-14 Yannick Moy <moy@adacore.com>
+
+ * inline.adb (Cannot_Inline): Add No_Info parameter to disable
+ info message.
+ * inline.ads (Cannot_Inline): When No_Info is set to True, do
+ not issue info message in GNATprove mode, but still mark the
+ subprogram as not always inlined.
+ * sem_res.adb (Resolve_Call): Always call Cannot_Inline inside
+ an assertion expression.
+
+2020-12-14 Eric Botcazou <ebotcazou@adacore.com>
+
+ * libgnat/s-imguti.ads (Set_Decimal_Digits): Adjust documentation.
+
+2020-12-10 Ed Schonberg <schonberg@adacore.com>
+
+ PR ada/98230
+ * exp_attr.adb (Expand_N_Attribute_Reference, case Mod): Use base
+ type of argument to obtain static bound and required size.
+
+2020-12-07 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/Make-lang.in: Remove ^L characters.
+ * gcc-interface/decl.c (create_concat_name): Add cast.
+
+2020-12-07 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/trans.c (maybe_make_gnu_thunk): Return false if the
+ target is local and thunk and target do not have the same context.
+
+2020-12-07 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/trans.c (lvalue_for_aggregate_p): Also return true
+ for return statements.
+ * gcc-interface/utils.c (gnat_write_global_declarations): Use the
+ maximum index for the dummy object to avoid a name collision.
+
+2020-12-07 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/decl.c (gnat_to_gnu_entity) <Fixed_Point_Type>: Put
+ back the "else" unduly removed.
+
+2020-12-07 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/trans.c (Call_to_gnu): Also create a temporary for
+ the return value if the LHS is a bit-field and the return type is
+ a type padding a self-referential type.
+ (gnat_to_gnu): Do not remove the padding on the result if it is too
+ small with regard to the natural padding size.
+
+2020-12-07 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/utils.c (convert) <INTEGER_TYPE>: Call fold_convert
+ in the cases where convert_to_integer is not called.
+ <BOOLEAN_TYPE>: Call fold_convert instead of convert_to_integer.
+
+2020-12-07 Matthias Klose <doko@ubuntu.com>
+
+ PR ada/97504
+ * Makefile.rtl (LIBGNAT_TARGET_PAIRS) <mips*-*-linux*>: Use wraplf
+ version of Aux_Long_Long_Float.
+
+2020-11-30 Pierre-Marie de Rodat <derodat@adacore.com>
+
+ * libgnat/s-trasym.ads: Update the list of supported platforms.
+
+2020-11-30 Arnaud Charlet <charlet@adacore.com>
+
+ * gcc-interface/Makefile.in, gcc-interface/trans.c: Remove ^L
+ characters.
+
+2020-11-30 Arnaud Charlet <charlet@adacore.com>
+
+ * gcc-interface/Makefile.in (GNATLIBFLAGS): Enable checks by
+ default.
+ * libgnat/s-bitfie.ads: Suppress alignment checks.
+ * libgnat/s-bituti.adb: Minor reformatting.
+ * libgnat/s-secsta.adb (SS_Allocate): Support Size = 0.
+
+2020-11-30 Arnaud Charlet <charlet@adacore.com>
+
+ * exp_ch3.adb (Replace_Discr_Ref): Removed, no longer needed.
+
+2020-11-30 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_ch5.adb (Process_Statements): Replace low-level membership
+ test with a high-level wrapper.
+
+2020-11-30 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_ch5.adb (Set_Assignment_Type): Combine calls to Ekind
+ using membership test.
+ (Should_Transform_BIP_Assignment): Replace assignment to a
+ "Result" variable with simple return statements; avoid repeated
+ calls to Unqual_Conv by declaring a local constant.
+
+2020-11-30 Piotr Trojanek <trojanek@adacore.com>
+
+ * lib-xref.adb (Generate_Reference): Fix reference to
+ Analyze_Assignment.
+ * sem_ch5.adb (Diagnose_Non_Variable_Lhs): Reuse existing
+ utility function.
+
+2020-11-30 Eric Botcazou <ebotcazou@adacore.com>
+
+ * contracts.adb (Check_Type_Or_Object_External_Properties): Make
+ sure to exclude all return objects from the SPARK legality rule
+ on effectively volatile variables.
+ * exp_ch6.adb (Expand_N_Extended_Return_Statement): Use the fast
+ track only when the declaration of the return object can be
+ dropped.
+
+2020-11-30 Gary Dismukes <dismukes@adacore.com>
+
+ * einfo.ads (Is_Partial_DIC_Procedure): New function.
+ (Partial_DIC_Procedure): New procedure.
+ * einfo.adb (Is_Partial_DIC_Procedure): New function to return
+ whether a subprogram is a partial Default_Initial_Condition
+ procedure by checking the name (to avoid adding a new field).
+ (DIC_Procedure): Add a test that excludes partial DIC procedures
+ from being returned.
+ (Partial_DIC_Procedure): New procedure to return the partial DIC
+ procedure of a type, if it has one (otherwise returns Empty).
+ (Set_DIC_Procedure): Remove check for duplicate DIC procedures.
+ * exp_aggr.adb (Gen_Assign): Generate a call to the type's DIC
+ procedure in the case where an array component is default
+ initialized (due to an association with a box).
+ (Build_Record_Aggr_Code): For an extension aggregate, generate a
+ call to the ancestor type's DIC procedure (if any) when the
+ ancestor part is a subtype mark. For a record component
+ association that was specified with a box (tested for by
+ checking the new flag Was_Default_Init_Box_Association),
+ generate a call to the component type's DIC procedure (if it has
+ one).
+ * exp_ch4.adb (Expand_N_Allocator): When the allocated object is
+ default initialized and the designated type has a DIC aspect,
+ generate a call to the DIC procedure.
+ * exp_util.ads (Build_DIC_Call): Change the formal Obj_Id to
+ name Obj_Name, and change its type from Entity_Id to Node_Id
+ (and update comment).
+ (Build_DIC_Procedure_Body): Add formal Partial_DIC, remove
+ formal For_Freeze, and update comment accordingly.
+ (Build_DIC_Procedure_Declaration): Add formal Partial_DIC and
+ update comment.
+ * exp_util.adb
+ (Build_DIC_Call): Revised to use its Obj_Name (formerly Obj_Id)
+ formal directly rather than calling New_Occurrence_Of on it, to
+ allow arbitrary names to be passed rather than being limited to
+ Entity_Ids.
+ (Build_DIC_Procedure_Body): Call Add_Parent_DICs to generate
+ checks for DICs associated with any parent types, implementing
+ the required "additive" semantics for DICs. When building a DIC
+ procedure body for a partial view (when Partial_DIC is True),
+ call Add_Own_DIC when the type has its own DIC. In the case of
+ "full" DIC procedures, a call is generated to any partial DIC
+ procedure of the type (unless the procedure has a null body),
+ along with checks for any DICs inherited by the full view.
+ (Build_DIC_Procedure_Declaration): Add handling for partial DIC
+ procedures. For the suffix of a regular DIC procedure's name,
+ use "DIC" (instead of "Default_Initial_Condition"), and for the
+ suffix of a partial DIC procedure's name, use "Partial_DIC".
+ (Add_DIC_Check): Add the DIC pragma to the list of seen pragmas
+ (Pragmas_Seen).
+ (Add_Inherited_Tagged_DIC): Remove the formals Par_Typ,
+ Deriv_Typ, and Obj_Id, and add formal Expr, which denotes DIC's
+ expression. Remove the call to Replace_References (which is now
+ done in Add_Inherited_DICs).
+ (Add_Inherited_DICs): New procedure to locate a DIC pragma
+ associated with a parent type, replace its references
+ appropriately (such as any current instance references), and add
+ a check for the DIC.
+ (Add_Own_DIC): Add an Obj_Id formal to allow caller to pass the
+ _init formal of the generated DIC procedure.
+ (Add_Parent_DICs): New procedure to traverse a type's parents,
+ looking for DICs associated with those and calling
+ Add_Inherited_DICs to apply the appropriate DIC checks.
+ (Is_Verifiable_DIC_Pragma): Treat pragmas that have an Empty
+ first argument the same as a pragma without any arguments
+ (returning False for that case).
+ * exp_ch3.adb (Init_One_Dimension): Generate calls to the
+ component's DIC procedure when needed.
+ (Possible_DIC_Call): New function nested in Init_One_Dimension
+ to build a call to the array component type's DIC-checking
+ function when appropriate.
+ (Build_Array_Init_Proc): The presence of a DIC on the component
+ type is an additional condition for generating an init proc for
+ an array type.
+ (Build_Init_Statements): When the record component's type has a
+ DIC, and the component declaration does not have an
+ initialization expression, generate a call to the component
+ type's DIC procedure.
+ (Expand_N_Object_Declaration): Modify the call to Build_DIC_Call
+ to pass a new occurrence of the object's defining id rather than
+ the id itself.
+ (Freeze_Type): Only build a type's DIC procedure (if it has one)
+ for types that are not interfaces.
+ * exp_spark.adb (Expand_SPARK_N_Freeze_Type): Remove From_Freeze
+ actual and add a ??? comment.
+ (Expand_SPARK_N_Object_Declaration): Modify call to
+ Build_DIC_Call to pass a new occurrence of the object id rather
+ than the object id itself.
+ * sem_aggr.adb (Resolve_Record_Aggregate): Declare local flag
+ Is_Box_Init_By_Default and set it in cases where the component
+ association has a box and the component is being initialized by
+ default (as opposed to initialized by an initialization
+ expression associated with the component's declaration).
+ (Add_Association): If the association has a box for a component
+ initialized by default, the flag
+ Was_Default_Init_Box_Association is set on the new component
+ association (for later testing during expansion).
+ (Get_Value): Reset Is_Box_Init_By_Default to False.
+ * sem_ch3.adb (Build_Assertion_Bodies_For_Type): Rearrange code
+ to build DIC procedure bodies for a (noninterface) type that
+ Has_Own_DIC (for partial type views) or Has_DIC (for full type
+ views) as appropriate.
+ * sem_ch13.adb (Analyze_Aspect_Specifications,
+ Aspect_Default_Initial_Condition): Add an extra argument to the
+ DIC pragma to denote the type associated with the pragma (for
+ use in Build_DIC_Procedure_Body).
+ * sem_prag.adb (Analyze_Pragma): Allow two arguments for pragma
+ Default_Initial_Condition. If not already present, add an extra
+ argument denoting the type that the pragma is associated with.
+ * sem_util.adb (Propagate_DIC_Attributes): Retrieve any partial
+ DIC procedure associated with the type and add it to the type's
+ list of subprograms (Subprograms_For_Type).
+ * sinfo.ads (Was_Default_Init_Box_Association): New flag on
+ N_Component_Association nodes. Add subprograms to get and set
+ flag, as well as updating the documentation.
+ * sinfo.adb (Was_Default_Init_Box_Association): New function to
+ retrieve the corresponding flag (Flag14).
+ (Set_Was_Default_Init_Box_Association): New procedure to set the
+ corresponding flag (Flag14).
+
+2020-11-30 Arnaud Charlet <charlet@adacore.com>
+
+ * par-ch6.adb (P_Formal_Part): Remove extra call to Scan.
+ * par-tchk.adb: Minor reformatting.
+
+2020-11-30 Eric Botcazou <ebotcazou@adacore.com>
+
+ * libgnat/a-nbnbre.adb (Float_Conversions): Instantiate Conv
+ package only once in the body.
+ (Fixed_Conversions.Float_Aux): New instance.
+ (Fixed_Conversions.Conv_I): Likewise.
+ (Fixed_Conversions.Conv_U): Likewise.
+ (Fixed_Conversions.LLLI): New subtype.
+ (Fixed_Conversions.LLLU): Likewise.
+ (Fixed_Conversions.Too_Large): New constant.
+ (Fixed_Conversions.To_Big_Real): Reimplement.
+ (Fixed_Conversions.From_Big_Real): Likewise.
+
+2020-11-30 Bob Duff <duff@adacore.com>
+
+ * exp_ch3.adb (Expand_N_Object_Declaration): Avoid crash in case
+ of conditional expression.
+
+2020-11-30 Eric Botcazou <ebotcazou@adacore.com>
+
+ * doc/gnat_rm/implementation_defined_attributes.rst (Pool_Address):
+ Fix pasto.
+ (Small_Denominator): New entry.
+ (Small_Numerator): Likewise.
+ * doc/gnat_rm/implementation_defined_characteristics.rst (3.5.9):
+ Relax conditions on 128-bit smalls and integer-only implementation.
+ * gnat_rm.texi: Regenerate.
+ * exp_attr.adb (Expand_N_Attribute_Reference) <Attribute_Fore>:
+ Relax conditions on integer implementation for ordinary fixed-point
+ types and pass a third parameter to the routine.
+ <Attribute_Small_Denominator>: Raise Program_Error.
+ <Attribute_Small_Numerator>: Likewise.
+ * exp_fixd.adb (Expand_Convert_Fixed_To_Fixed): Use a scaled divide
+ if the numerator and denominator of the small ratio are sufficiently
+ small integers.
+ (Expand_Convert_Fixed_To_Integer): Use a scaled divide if numerator
+ and denominator of the small value are sufficiently small integers.
+ (Expand_Convert_Integer_To_Fixed): Likewise.
+ * exp_imgv.adb (Expand_Image_Attribute): Relax the conditions on the
+ integer implementation for ordinary fixed-point types.
+ (Expand_Value_Attribute): Likewise.
+ * freeze.adb (Freeze_Fixed_Point_Type): Relax conditions on 128-bit
+ smalls.
+ * sem_attr.adb (Analyze_Attribute) <Attribute_Small_Denominator>:
+ Check no arguments, fixed-point and set type to Universal_Integer.
+ <Attribute_Small_Numerator>: Likewise.
+ (Eval_Attribute) <Attribute_Small_Denominator>: Fold statically.
+ <Attribute_Small_Numerator>: Likewise.
+ * snames.ads-tmpl (Name_Small_Denominator): New attribute name.
+ (Name_Small_Numerator): Likewise.
+ (Attribute_Id): Add Attribute_Small_{Denominator,Numerator}.
+ * libgnat/a-tifiio.adb (Exact): Delete.
+ (Need_64): Likewise.
+ (OK_Get_32): New boolean constant.
+ (OK_Put_32): Likewise.
+ (OK_Get_64): Likewise.
+ (OK_Put_64): Likewise.
+ (E): Adjust.
+ (Get procedures): Likewise.
+ (Put procedures): Likewise.
+ * libgnat/a-tifiio__128.adb (Exact): Delete.
+ (Need_64): Likewise.
+ (Need_128): Likewise.
+ (OK_Get_32): New boolean constant.
+ (OK_Put_32): Likewise.
+ (OK_Get_64): Likewise.
+ (OK_Put_64): Likewise.
+ (OK_Get_128): Likewise.
+ (OK_Put_128): Likewise.
+ (E): Adjust.
+ (Get procedures): Likewise.
+ (Put procedures): Likewise.
+ * libgnat/a-wtfiio.adb (Exact): Delete.
+ (Need_64): Likewise.
+ (OK_Get_32): New boolean constant.
+ (OK_Put_32): Likewise.
+ (OK_Get_64): Likewise.
+ (OK_Put_64): Likewise.
+ (E): Adjust.
+ (Get procedures): Likewise.
+ (Put procedures): Likewise.
+ * libgnat/a-wtfiio__128.adb (Exact): Delete.
+ (Need_64): Likewise.
+ (Need_128): Likewise.
+ (OK_Get_32): New boolean constant.
+ (OK_Put_32): Likewise.
+ (OK_Get_64): Likewise.
+ (OK_Put_64): Likewise.
+ (OK_Get_128): Likewise.
+ (OK_Put_128): Likewise.
+ (E): Adjust.
+ (Get procedures): Likewise.
+ (Put procedures): Likewise.
+ * libgnat/a-ztfiio.adb (Exact): Delete.
+ (Need_64): Likewise.
+ (OK_Get_32): New boolean constant.
+ (OK_Put_32): Likewise.
+ (OK_Get_64): Likewise.
+ (OK_Put_64): Likewise.
+ (E): Adjust.
+ (Get procedures): Likewise.
+ (Put procedures): Likewise.
+ * libgnat/a-ztfiio__128.adb (Exact): Delete.
+ (Need_64): Likewise.
+ (Need_128): Likewise.
+ (OK_Get_32): New boolean constant.
+ (OK_Put_32): Likewise.
+ (OK_Get_64): Likewise.
+ (OK_Put_64): Likewise.
+ (OK_Get_128): Likewise.
+ (OK_Put_128): Likewise.
+ (E): Adjust.
+ (Get procedures): Likewise.
+ (Put procedures): Likewise.
+ * libgnat/s-fore_f.ads (Fore_Fixed): Adjust signature.
+ * libgnat/s-fore_f.adb (Fore_Fixed): Reimplement.
+ * libgnat/s-fofi32.ads (Fore_Fixed32): Adjust signature.
+ * libgnat/s-fofi64.ads (Fore_Fixed64): Likewise.
+ * libgnat/s-fofi128.ads (Fore_Fixed128): Likewise.
+ * libgnat/s-imagef.ads: Adjust description.
+ * libgnat/s-imagef.adb (Maxdigs): Move around.
+ (Set_Image_Integer): Remove assertion.
+ * libgnat/s-valuef.ads: Adjust description.
+ * libgnat/s-valuef.adb (Integer_To_Fixed): Minor tweak.
+
+2020-11-30 Ghjuvan Lacambre <lacambre@adacore.com>
+
+ * doc/gnat_ugn/building_executable_programs_with_gnat.rst:
+ Describe -gnateb switch.
+ * doc/gnat_ugn/the_gnat_compilation_model.rst: Mention -gnateb
+ switch in configuration pragma files section.
+ * gnat_ugn.texi: Regenerate.
+ * lib-writ.adb (Write_ALI): Strip directories from configuration
+ files path if needed.
+ * opt.ads: Declare Config_Files_Store_Basename option.
+ * par.adb (Par): Save configuration file checksum.
+ * switch-c.adb (Scan_Front_End_Switches): Set
+ Config_Files_Store_Basename true if -gnateb is present.
+
+2020-11-30 Arnaud Charlet <charlet@adacore.com>
+
+ * exp_dist.adb (RCI_Cache): Initialize.
+
+2020-11-30 Arnaud Charlet <charlet@adacore.com>
+
+ * terminals.c (allocate_pty_desc): Copy one less byte since the
+ last byte will always be set to 0.
+
+2020-11-30 Eric Botcazou <ebotcazou@adacore.com>
+
+ * doc/gnat_ugn/building_executable_programs_with_gnat.rst (-xdr):
+ Document that XDR is not supported for 128-bit integer types.
+ * gnat_ugn.texi: Regenerate.
+ * exp_strm.adb (Build_Elementary_Input_Call): Deal with types
+ larger than Long_Long_Integer.
+ (Build_Elementary_Write_Call): Likewise.
+ * rtsfind.ads (RE_Id): Add RE_I_LLL{I,U] and RE_W_LLL{I,U}.
+ (RE_Unit_Table): Add entries for them.
+ * libgnat/s-stratt.ads (I_LLLI): New inline function.
+ (I_LLLU): Likewise.
+ (W_LLLI): New inline procedure.
+ (W_LLLU): Likewise.
+ * libgnat/s-stratt.adb (S_LLLI): New subtype of SEA.
+ (S_LLLU): Likewise.
+ (From_LLLI): New instance of Unchecked_Conversion.
+ (From_LLLU): Likewise.
+ (To_LLLI): Likewise.
+ (To_LLLU): Likewise.
+ (I_LLLI): Implement.
+ (I_LLLU): Likewise.
+ (W_LLLI): Likewise.
+ (W_LLLU): Likewise.
+
+2020-11-30 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_ch5.adb (Expand_Iterator_Loop_Over_Container): Check the
+ signature of the private operation Get_Element_Access to prevent
+ accidental use of a user-defined homonym subprogram.
+
+2020-11-30 Yannick Moy <moy@adacore.com>
+
+ * spark_xrefs.ads: Add comment for Heap that it may remain
+ Empty.
+
+2020-11-30 Pascal Obry <obry@adacore.com>
+
+ * libgnat/g-sercom__linux.adb (Set): Fix control flags of the
+ serial port setting.
+
+2020-11-30 Pascal Obry <obry@adacore.com>
+
+ * libgnat/g-sercom__linux.adb: Minor style fixes.
+
+2020-11-30 Piotr Trojanek <trojanek@adacore.com>
+
+ * exp_util.adb (Get_Current_Value_Condition): Don't use current
+ value tracking in GNATprove mode.
+ * sem_res.adb (Resolve_Comparison_Op): Remove incomplete
+ special-casing for folding in GNATprove mode.
+
+2020-11-30 Bob Duff <duff@adacore.com>
+
+ * errout.adb (Error_Msg_NEL): Do not call Set_Posted if errors
+ are being ignored.
+ (Error_Msg): Change Errors_Must_Be_Ignored to use the getter.
+ * sem_ch8.adb (Find_Direct_Name): Do not skip all the error
+ checks when ignoring errors, but instead do not add an entry to
+ the Urefs table if errors are being ignored.
+ * exp_ch5.adb: Minor comment fix.
+
+2020-11-30 Yannick Moy <moy@adacore.com>
+
+ * sem_aggr.adb (Resolve_Array_Aggregate): Improve error message.
+
+2020-11-30 Eric Botcazou <ebotcazou@adacore.com>
+
+ * libgnat/s-valuef.adb (Integer_To_Fixed): Do not modify numerator
+ or denominator in order to reduce the exponent.
+
+2020-11-30 Arnaud Charlet <charlet@adacore.com>
+
+ * ali-util.adb (Get_File_Checksum): Remove dead code.
+ * exp_ch4.adb (Expand_Boolean_Operator, Expand_N_Op_Not,
+ Make_Boolean_Array_Op): Take Transform_Function_Array into
+ account.
+ * exp_ch6.adb (Expand_Call_Helper): Update comment. Code
+ cleanup.
+ * exp_util.adb (Build_Procedure_Form): Use new predefined name
+ Name_UP_RESULT.
+ * snames.ads-tmpl (Name_UP_RESULT): New predefined name. Code
+ cleanup: remove unused names from the project parser, moved to
+ gprbuild sources.
+ * xsnamest.adb: Add support for uppercase names.
+
+2020-11-30 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_util.adb (Enter_Name): When an inherited operation for a
+ local derived type is hidden by an explicit declaration of a
+ non-overloadable entity in the same scope, make the inherited
+ operation non-visible to prevent its accidental use elsewhere.
+
+2020-11-29 John David Anglin <danglin@gcc.gnu.org>
+
+ PR ada/97504
+ * Makefile.rtl (LIBGNAT_TARGET_PAIRS) <hppa*-*-hpux*>: Use wraplf
+ version of Aux_Long_Long_Float.
+
+2020-11-27 Eric Botcazou <ebotcazou@adacore.com>
+
+ * libgnat/s-valuef.adb (Integer_To_Fixed): Take into account the
+ extra digit when scaling up the input.
+ * libgnat/s-valuer.adb (Scan_Decimal_Digits): Restrict previous
+ change to fixed-point types.
+ (Scan_Integral_Digits): Likewise.
+
+2020-11-27 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_res.adb (Parent_Is_Boolean): Simplify.
+ (Resolve_Op_Not): Reduce scope of a local variable.
+
+2020-11-27 Piotr Trojanek <trojanek@adacore.com>
+
+ * cstand.adb: Simplify with Append_New_Elmt.
+ * sem_util.adb: Likewise.
+
+2020-11-27 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_eval.adb (Fold_Shift): Fix evaluation of Shift_Right on
+ negative values.
+
+2020-11-27 Arnaud Charlet <charlet@adacore.com>
+
+ * exp_ch6.adb (Expand_Call): Properly split
+ Transform_Function_Array and Modify_Tree_For_C.
+
+2020-11-27 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_eval.ads (Compile_Time_Compare): Restore parameter Diff to
+ be of an access type.
+ * sem_eval.adb (Compile_Time_Compare): Adapt body and callers.
+ * sem_attr.adb (Eval_Attribute): Adapt callers.
+
+2020-11-27 Eric Botcazou <ebotcazou@adacore.com>
+
+ * libgnat/s-valuer.adb (Scan_Decimal_Digits): Round Extra.
+ (Scan_Integral_Digits): Likewise.
+
+2020-11-27 Yannick Moy <moy@adacore.com>
+
+ * checks.adb (Selected_Range_Checks): Adapt the condition for
+ applying range checks so that it is not done inside generics.
+
+2020-11-27 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_fixd.adb (Build_Double_Divide): Only use a 128-bit
+ division if one of the operands is larger than 64 bits.
+ (Build_Double_Divide_Code): Likewise.
+ (Build_Scaled_Divide): Likewise.
+ (Build_Scaled_Divide_Code): Likewise.
+
+2020-11-27 Arnaud Charlet <charlet@adacore.com>
+
+ * libgnat/s-os_lib.adb (To_GM_Time): Return valid and consistent
+ values for Invalid_Time.
+
+2020-11-27 Steve Baird <baird@adacore.com>
+
+ * snames.ads-tmpl: Define new Name_Stable_Properties Name_Id
+ value.
+ * aspects.ads, aspects.adb: Add new Aspect_Stable_Properties
+ enumeration literal to Aspect_Id type. Add Class_Present
+ parameter to Find_Aspect and related
+ functions (Find_Value_Of_Aspect and Has_Aspect).
+ * sem_util.adb (Has_Nontrivial_Precondition): Fix
+ previously-latent bug uncovered by adding Class_Present
+ parameter to Aspect.Find_Aspect. The code was wrong before, but
+ with the change the bug was more likely to make a user-visible
+ difference.
+ * sem_ch6.adb (Analyze_Operator_Symbol): If a string literal
+ like "abs" or "-" occurs in a Stable_Properties aspect
+ specification, then it is to be interpreted as an operator
+ symbol and not as a string literal.
+ * sem_ch13.ads: Export new Parse_Aspect_Stable_Properties
+ function, analogous to the existing Parse_Aspect_Aggregate
+ exported procedure.
+ * sem_ch13.adb: (Parse_Aspect_Stable_Properties): New function;
+ analogous to existing Parse_Aspect_Aggregate.
+ (Validate_Aspect_Stable_Properties): New procedure; analogous to
+ existing Validate_Aspect_Aggregate. Called from the same case
+ statement (casing on an Aspect_Id value) where
+ Validate_Aspect_Aggregate is called.
+ (Resolve_Aspect_Stable_Properties): New procedure; analogous to
+ existing Resolve_Aspect_Aggregate. Called from the same two case
+ statements (each casing on an Aspect_Id value) where
+ Resolve_Aspect_Aggregate is called.
+ (Analyze_Aspect_Specifications): Set Has_Delayed_Aspects and
+ Is_Delayed_Aspect attributes for Aspect_Stable_Properties aspect
+ specifications.
+ (Check_Aspect_At_End_Of_Declarations): The syntactic
+ "expression" for a Stable_Properties aspect specification is not
+ semantically an expression; it doesn't have a type. Thus, force
+ T to be empty in this case.
+ * contracts.adb (Expand_Subprogram_Contract): Add call to new
+ local procedure,
+ Expand_Subprogram_Contract.Add_Stable_Property_Contracts, which
+ generates Postcondition pragmas corresponding to stable property
+ checks.
+
+2020-11-27 Piotr Trojanek <trojanek@adacore.com>
+
+ * doc/gnat_rm/implementation_defined_pragmas.rst:
+ (Assertion_Policy): Move "Default_Initial_Condition" from
+ ID_ASSERTION_KIND to RM_ASSERTION_KIND section.
+ * gnat_rm.texi: Regenerate.
+
+2020-11-27 Piotr Trojanek <trojanek@adacore.com>
+
+ * doc/gnat_rm/implementation_defined_pragmas.rst
+ (Assertion_Policy): Add "Default_Initial_Condition",
+ "Initial_Condition" and "Subprogram_Variant".
+ * gnat_rm.texi: Regenerate.
+
+2020-11-27 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_prag.adb (Is_Valid_Assertion_Kind): Return False on
+ "Assertion_Policy"
+
+2020-11-27 Eric Botcazou <ebotcazou@adacore.com>
+
+ * make.adb (GNAT_Flag): Change to "-gnatg".
+ (Compile): Adjust comments accordingly.
+
+2020-11-27 Piotr Trojanek <trojanek@adacore.com>
+
+ * exp_ch4.adb (Rewrite_Comparison): Add assertion to confirm
+ that evaluation folds comparisons with static operands; when
+ folding comparison with non-static operands, the resulting
+ literal is non-static.
+ * sem_eval.adb (Eval_Relational_Op): Refactor nested IF
+ statement for the special case in the THEN branch; move code for
+ the "general case" out of the ELSE branch.
+ * sem_res.adb (Resolve_Comparison_Op): Only apply a dubious
+ special-case for GNATprove in the GNATprove_Mode.
+
+2020-11-27 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_eval.ads (Compile_Time_Compare): Change parameter Diff
+ from access to mode out.
+ * sem_eval.adb (Compile_Time_Compare): Adapt body and callers.
+ * sem_attr.adb (Eval_Attribute): Adapt callers.
+
+2020-11-27 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_ch4.adb (Expand_N_Op_Multiply): Move down block calling
+ Narrow_Large_Operation if the type is Universal_Integer.
+
+2020-11-27 Eric Botcazou <ebotcazou@adacore.com>
+
+ * libgnat/a-nbnbre.adb: Remove clauses for System.Img_Real and
+ add them for System.Unsigned_Types.
+ (Float_Conversions.To_Big_Real): Reimplement.
+ (Float_Conversions.From_Big_Real): Likewise.
+
+2020-11-27 Eric Botcazou <ebotcazou@adacore.com>
+
+ * checks.ads (Determine_Range_To_Discrete): New procedure.
+ * checks.adb (Apply_Scalar_Range_Check): Call it to determine
+ a range for the expression when the target type is discrete.
+ And also apply the tests for discrete types to fixed-point
+ types when they are treated as integers.
+ (Apply_Type_Conversion_Checks): Apply checks to conversions
+ involving fixed-point types when they are treated as integers.
+ (Determine_Range) <N_Type_Conversion>: Factor out code into...
+ (Determine_Range_To_Discrete): ...this new procedure and add
+ support for fixed-point types when they are treated as integers.
+ * einfo.ads (Type_High_Bound): Remove obsolete sentence.
+ (Type_Low_Bound): Likewise.
+ * exp_ch4.adb (Discrete_Range_Check): Remove obsolete code.
+ (Real_Range_Check): Likewise.
+ (Expand_N_Type_Conversion): In case of a no-op conversion, clear
+ the Do_Range_Check flag on the operand before substituting it.
+ Remove calls to Real_Range_Check and Discrete_Range_Check that
+ are not guarded by the Do_Range_Check flag, and an assertion.
+ * sem_res.adb (Resolve_Type_Conversion): Always apply range
+ checks in GNATprove mode; in normal mode, use the updated type
+ of the operand in the test against Universal_Fixed. Remove
+ obsolete code setting the Do_Range_Check flag at the end.
+
+2020-11-27 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_prag.adb (Analyze_Pragma): Change "Ref Manual" to RM;
+ replace uses of an unnecessary "Ok" variable with RETURN
+ statements; replace nested IF with ELSIF.
+
+2020-11-27 Arnaud Charlet <charlet@adacore.com>
+
+ * libgnarl/s-tasren.adb (Local_Complete_Rendezvous): Always call
+ Defer_Abort.
+ * libgnat/a-except.adb: Abort does not need to be deferred.
+ * libgnarl/s-tpobop.adb (Exceptional_Complete_Entry_Body): Abort
+ never needs to be undeferred here.
+ * exp_ch11.adb (Expand_Exception_Handlers): Remove difference
+ between ZCX and SJLJ.
+ * exp_ch9.adb (Expand_N_Asynchronous_Select): Remove different
+ handling for sjlj.
+ * exp_sel.ads, exp_sel.adb (Build_Abort_Block,
+ Build_Abort_Block_Handler): Ditto.
+
+2020-11-27 Ghjuvan Lacambre <lacambre@adacore.com>
+
+ * sem_prag.adb (Analyze_Pragma): declare new Check_No_Return
+ function and call it.
+
+2020-11-27 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_ch12.adb (Instantiate_Object): Consistently use
+ New_Copy_Tree instead of New_Copy.
+
+2020-11-27 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_fixd.adb (Build_Conversion): Adjust head comment.
+ (Build_Divide): Likewise.
+ (Build_Double_Divide): Likewise.
+ (Build_Multiply): Likewise.
+ (Build_Rem): Likewise.
+ (Build_Scaled_Divide): Likewise.
+
+2020-11-27 Arnaud Charlet <charlet@adacore.com>
+
+ * libgnat/s-genbig.ads, libgnat/s-genbig.adb (To_Bignum): New
+ variant taking an Unsigned_128.
+ * libgnat/a-nbnbin.adb (To_Big_Integer): Add support for 128
+ bits signed and unsigned types.
+
+2020-11-27 Eric Botcazou <ebotcazou@adacore.com>
+
+ * libgnat/s-imagef.adb (Set_Image_Fixed): Pass the full value
+ of the quotient to Set_Image_Integer during the first round and
+ adjust the handling of the minus sign.
+
+2020-11-27 Arnaud Charlet <charlet@adacore.com>
+
+ * libgnat/a-nbnbre.adb ("=", "<"): Fix.
+
+2020-11-27 Eric Botcazou <ebotcazou@adacore.com>
+
+ * libgnat/s-valuer.adb (Scan_Raw_Real): Move pragma Annotate around
+ and adjust its parameters.
+
+2020-11-27 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_fixd.adb (Build_Double_Divide): Use the RM size of types and
+ a more precise estimate for the size of the denominator.
+ (Build_Double_Divide_Code): Likewise.
+ (Build_Multiply): Use a more precise estimate for the size of the
+ result.
+ (Build_Scaled_Divide): Use the RM size of types and a more precise
+ estimate for the size of the numerator.
+ (Build_Scaled_Divide_Code): Likewise.
+
+2020-11-26 Rainer Orth <ro@CeBiTec.Uni-Bielefeld.DE>
+
+ * Makefile.rtl <sparc*-sun-solaris*> (THREADSLIB): Remove.
+ (MISCLIB): Remove -lposix4.
+ <*86-*-solaris2*>: Likewise.
+ * libgnarl/s-osinte__solaris.ads (System.OS_Interface): Remove
+ -lposix4 -lthread.
+
+2020-11-26 Arnaud Charlet <charlet@adacore.com>
+
+ * libgnat/a-nbnbre.adb (To_Big_Real): Do not loose precision.
+
+2020-11-26 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_ch8.adb (Analyze_Object_Renaming): Check for AI12-0401.
+
+2020-11-26 Eric Botcazou <ebotcazou@adacore.com>
+
+ * Makefile.rtl (GNATRTL_NONTASKING_OBJS): Likewise.
+ (GNATRTL_128BIT_OBJS): Likewise.
+ (GNATRTL_128BIT_PAIRS): Add new 128-bit variants.
+ * cstand.adb (Create_Standard): Create Standard_Integer_128.
+ * doc/gnat_rm/implementation_defined_characteristics.rst: Document
+ new limits on 64-bit platforms in entry for 3.5.9(10).
+ * gnat_rm.texi: Regenerate.
+ * exp_attr.adb: Add with and use clauses for Urealp.
+ (Expand_N_Attribute_Reference) <Attribute_Fore>: Call new routines
+ for decimal fixed-point types and common ordinary fixed-point types.
+ * exp_ch4.adb (Real_Range_Check): Extend conversion trick to all
+ ordinary fixed-point types and use Small_Integer_Type_For.
+ * exp_fixd.adb: Add with and use clauses for Ttypes.
+ (Build_Divide): Add special case for 32-bit values and deal with
+ 128-bit types.
+ (Build_Double_Divide): Deal with 128-bit types.
+ (Build_Double_Divide_Code): Likewise. Do not apply conversions
+ before calling Build_Multiply.
+ (Build_Multiply): Likewise. Add special case for 32-bit values.
+ (Build_Scaled_Divide): Deal with 128-bit types.
+ (Build_Scaled_Divide_Code): Likewise. Fix size computation. Do not
+ apply conversions before calling Build_Multiply.
+ (Do_Multiply_Fixed_Fixed): Minor tweak.
+ (Integer_Literal): Deal with 128-bit values.
+ * exp_imgv.adb (Has_Decimal_Small): Delete.
+ (Expand_Image_Attribute): Call new routines for common ordinary
+ fixed-point types.
+ (Expand_Value_Attribute): Likewise.
+ (Expand_Width_Attribute): Add new expansion for fixed-point types.
+ * freeze.adb (Freeze_Entity): Move error checks for ordinary
+ fixed-point types to...
+ (Freeze_Fixed_Point_Type): ...here. Deal with 128-bit types and
+ adjust limitations for 32-bnt and 64-bit types.
+ * rtsfind.ads (RTU_Id): Add entries for new System_Fore, System_Img,
+ and System_Val units and remove them for obsolete units.
+ (RE_Id): Add entries for Double_Divide128, Scaled_Divide128, the new
+ Fore, Image, Value routines and remove them for obsolete units.
+ (RE_Unit_Table): Likewise.
+ * sem_ch3.adb (Decimal_Fixed_Point_Type_Declaration): Deal with
+ 128-bit types.
+ * stand.ads (Standard_Entity_Type): Add Standard_Integer_128.
+ * uintp.ads (Uint_31): New deferred constant.
+ (Uint_Minus_18): Likewise.
+ (Uint_Minus_31): Likewise.
+ (Uint_Minus_76): Likewise.
+ (Uint_Minus_127): Likewise.
+ * urealp.ads (Ureal_2_31): New function.
+ (Ureal_2_63): Likewise.
+ (Ureal_2_127): Likewise.
+ (Ureal_2_M_127): Likewise.
+ (Ureal_2_10_18): Likewise.
+ (Ureal_M_2_10_18): Likewise.
+ (Ureal_9_10_36): Likewise.
+ (Ureal_M_9_10_36): Likewise.
+ (Ureal_10_76): Likewise.
+ (Ureal_M_10_76): Likewise.
+ (Ureal_10_36): Delete.
+ (Ureal_M_10_36): Likewise.
+ * urealp.adb (UR_2_10_18): New variable.
+ (UR_9_10_36): Likewise.
+ (UR_10_76): Likewise.
+ (UR_M_2_10_18): Likewise.
+ (UR_M_9_10_36): Likewise.
+ (UR_M_10_76): Likewise.
+ (UR_2_31): Likewise.
+ (UR_2_63): Likewise.
+ (UR_2_127): Likewise.
+ (UR_2_M_127): Likewise.
+ (UR_10_36): Delete.
+ (UR_M_10_36): Likewise.
+ (Initialize): Initialize them.
+ (UR_Write): Do not use awkward Ada literal style.
+ (Ureal_2_10_18): New function.
+ (Ureal_9_10_36): Likewise.
+ (Ureal_10_76): Likewise.
+ (Ureal_2_31): Likewise.
+ (Ureal_2_63): Likewise.
+ (Ureal_2_127): Likewise.
+ (Ureal_2_M_127): Likewise.
+ (Ureal_M_2_10_18): Likewise.
+ (Ureal_M_9_10_36): Likewise.
+ (Ureal_10_76): Likewise.
+ (Ureal_M_10_76): Likewise.
+ (Ureal_10_36): Delete.
+ (Ureal_M_10_36): Likewise.
+ * libgnat/a-decima__128.ads: New file.
+ * libgnat/a-tideau.ads, libgnat/a-tideau.adb: Reimplement as
+ generic unit.
+ * libgnat/a-tideio.adb: Reimplement.
+ * libgnat/a-tideio__128.adb: New file.
+ * libgnat/a-tifiau.ads, libgnat/a-tifiau.adb: New generic unit.
+ * libgnat/a-tifiio.adb: Move bulk of implementation to s-imagef
+ and reimplement.
+ * libgnat/a-tifiio__128.adb: New file.
+ * libgnat/a-tiflau.adb (Get): Minor consistency fix.
+ (Gets): Likewise.
+ * libgnat/a-wtdeau.ads, libgnat/a-wtdeau.adb: Reimplement as
+ generic unit.
+ * libgnat/a-wtdeio.adb: Reimplement.
+ * libgnat/a-wtdeio__128.adb: New file.
+ * libgnat/a-wtfiau.ads, libgnat/a-wtfiau.adb: New generic unit.
+ * libgnat/a-wtfiio.adb: Reimplement.
+ * libgnat/a-wtfiio__128.adb: New file.
+ * libgnat/a-ztdeau.ads, libgnat/a-ztdeau.adb: Reimplement as
+ generic unit.
+ * libgnat/a-ztdeio.adb: Reimplement.
+ * libgnat/a-ztdeio__128.adb: New file.
+ * libgnat/a-ztfiau.ads, libgnat/a-ztfiau.adb: New generic unit.
+ * libgnat/a-ztfiio.adb: Reimplement.
+ * libgnat/a-ztfiio__128.adb: New file.
+ * libgnat/g-rannum.adb (Random_Decimal_Fixed): Use a subtype of the
+ appropiate size for the instantiation.
+ (Random_Ordinary_Fixed): Likewise.
+ * libgnat/s-arit32.ads, libgnat/s-arit32.adb: New support unit.
+ * libgnat/s-fode128.ads: New instantiation.
+ * 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.ads, libgnat/s-fore_d.adb: New generic unit.
+ * libgnat/s-fore_f.ads, libgnat/s-fore_f.adb: Likewise.
+ * libgnat/s-fore.ads, libgnat/s-fore.adb: Rename into...
+ * libgnat/s-forrea.ads, libgnat/s-forrea.adb: ...this.
+ * libgnat/s-imaged.ads, libgnat/s-imaged.adb: New generic unit.
+ * libgnat/s-imagef.ads, libgnat/s-imagef.adb: Likewise, taken
+ from a-tifiio.adb.
+ * libgnat/s-imde128.ads: New instantiation.
+ * libgnat/s-imde32.ads: Likewise.
+ * libgnat/s-imde64.ads: Likewise.
+ * libgnat/s-imfi128.ads: Likewise.
+ * libgnat/s-imfi32.ads: Likewise.
+ * libgnat/s-imfi64.ads: Likewise.
+ * libgnat/s-imgdec.ads, libgnat/s-imgdec.adb: Delete.
+ * libgnat/s-imglld.ads, libgnat/s-imglld.adb: Likewise.
+ * libgnat/s-imgrea.adb (Set_Image_Real): Replace Sign local variable
+ with Minus local variable for the sake of consistency.
+ * libgnat/s-imguti.ads, libgnat/s-imguti.adb: New support unit.
+ * libgnat/s-vade128.ads: New instantiation.
+ * 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-valdec.ads, libgnat/s-valdec.adb: Delete.
+ * libgnat/s-vallld.ads, libgnat/s-vallld.adb: Likewise.
+ * libgnat/s-valued.ads, libgnat/s-valued.adb: New generic unit.
+ * libgnat/s-valuef.ads, libgnat/s-valuef.adb: Likewise.
+ * libgnat/s-valuei.adb: Minor rewording.
+ * libgnat/s-valrea.adb: Move bulk of implementation to...
+ * libgnat/s-valuer.ads, libgnat/s-valuer.adb: ...here. New
+ generic unit.
+ * libgnat/system-aix.ads (Max_Mantissa): Adjust.
+ * libgnat/system-darwin-arm.ads (Max_Mantissa): Likewise.
+ * libgnat/system-darwin-ppc.ads (Max_Mantissa): Likewise.
+ * libgnat/system-darwin-x86.ads (Max_Mantissa): Likewise.
+ * libgnat/system-djgpp.ads (Max_Mantissa): Likewise.
+ * libgnat/system-dragonfly-x86_64.ads (Max_Mantissa): Likewise.
+ * libgnat/system-freebsd.ads (Max_Mantissa): Likewise.
+ * libgnat/system-hpux-ia64.ads (Max_Mantissa): Likewise.
+ * libgnat/system-hpux.ads (Max_Mantissa): Likewise.
+ * libgnat/system-linux-alpha.ads (Max_Mantissa): Likewise.
+ * libgnat/system-linux-arm.ads (Max_Mantissa): Likewise.
+ * libgnat/system-linux-hppa.ads (Max_Mantissa): Likewise.
+ * libgnat/system-linux-ia64.ads (Max_Mantissa): Likewise.
+ * libgnat/system-linux-m68k.ads (Max_Mantissa): Likewise.
+ * libgnat/system-linux-mips.ads (Max_Mantissa): Likewise.
+ * libgnat/system-linux-ppc.ads (Max_Mantissa): Likewise.
+ * libgnat/system-linux-riscv.ads (Max_Mantissa): Likewise.
+ * libgnat/system-linux-s390.ads (Max_Mantissa): Likewise.
+ * libgnat/system-linux-sh4.ads (Max_Mantissa): Likewise.
+ * libgnat/system-linux-sparc.ads (Max_Mantissa): Likewise.
+ * libgnat/system-linux-x86.ads (Max_Mantissa): Likewise.
+ * libgnat/system-lynxos178-ppc.ads (Max_Mantissa): Likewise.
+ * libgnat/system-lynxos178-x86.ads (Max_Mantissa): Likewise.
+ * libgnat/system-mingw.ads (Max_Mantissa): Likewise.
+ * libgnat/system-qnx-aarch64.ads (Max_Mantissa): Likewise.
+ * libgnat/system-rtems.ads (Max_Mantissa): Likewise.
+ * libgnat/system-solaris-sparc.ads (Max_Mantissa): Likewise.
+ * libgnat/system-solaris-x86.ads (Max_Mantissa): Likewise.
+ * libgnat/system-vxworks-arm-rtp-smp.ads (Max_Mantissa): Likewise.
+ * libgnat/system-vxworks-arm-rtp.ads (Max_Mantissa): Likewise.
+ * libgnat/system-vxworks-arm.ads (Max_Mantissa): Likewise.
+ * libgnat/system-vxworks-e500-kernel.ads (Max_Mantissa): Likewise.
+ * libgnat/system-vxworks-e500-rtp-smp.ads (Max_Mantissa): Likewise.
+ * libgnat/system-vxworks-e500-rtp.ads (Max_Mantissa): Likewise.
+ * libgnat/system-vxworks-e500-vthread.ads (Max_Mantissa): Likewise.
+ * libgnat/system-vxworks-ppc-kernel.ads (Max_Mantissa): Likewise.
+ * libgnat/system-vxworks-ppc-ravenscar.ads (Max_Mantissa): Likewise.
+ * libgnat/system-vxworks-ppc-rtp-smp.ads (Max_Mantissa): Likewise.
+ * libgnat/system-vxworks-ppc-rtp.ads (Max_Mantissa): Likewise.
+ * libgnat/system-vxworks-ppc-vthread.ads (Max_Mantissa): Likewise.
+ * libgnat/system-vxworks-ppc.ads (Max_Mantissa): Likewise.
+ * libgnat/system-vxworks-x86-kernel.ads (Max_Mantissa): Likewise.
+ * libgnat/system-vxworks-x86-rtp-smp.ads (Max_Mantissa): Likewise.
+ * libgnat/system-vxworks-x86-rtp.ads (Max_Mantissa): Likewise.
+ * libgnat/system-vxworks-x86-vthread.ads (Max_Mantissa): Likewise.
+ * libgnat/system-vxworks-x86.ads (Max_Mantissa): Likewise.
+ * libgnat/system-vxworks7-aarch64-rtp-smp.ads (Max_Mantissa):
+ Likewise.
+ * libgnat/system-vxworks7-aarch64.ads (Max_Mantissa): Likewise.
+ * libgnat/system-vxworks7-arm-rtp-smp.ads (Max_Mantissa): Likewise.
+ * libgnat/system-vxworks7-arm.ads (Max_Mantissa): Likewise.
+ * libgnat/system-vxworks7-e500-kernel.ads (Max_Mantissa): Likewise.
+ * libgnat/system-vxworks7-e500-rtp-smp.ads (Max_Mantissa): Likewise.
+ * libgnat/system-vxworks7-e500-rtp.ads (Max_Mantissa): Likewise.
+ * libgnat/system-vxworks7-ppc-kernel.ads (Max_Mantissa): Likewise.
+ * libgnat/system-vxworks7-ppc-rtp-smp.ads (Max_Mantissa): Likewise.
+ * libgnat/system-vxworks7-ppc-rtp.ads (Max_Mantissa): Likewise.
+ * libgnat/system-vxworks7-ppc64-kernel.ads (Max_Mantissa): Likewise.
+ * libgnat/system-vxworks7-ppc64-rtp-smp.ads (Max_Mantissa): Likewise.
+ * libgnat/system-vxworks7-x86-kernel.ads (Max_Mantissa): Likewise.
+ * libgnat/system-vxworks7-x86-rtp-smp.ads (Max_Mantissa): Likewise.
+ * libgnat/system-vxworks7-x86-rtp.ads (Max_Mantissa): Likewise.
+ * libgnat/system-vxworks7-x86_64-kernel.ads (Max_Mantissa): Likewise.
+ * libgnat/system-vxworks7-x86_64-rtp-smp.ads (Max_Mantissa): Likewise.
+
+2020-11-26 Liaiss Merzougue <merzougue@adacore.com>
+
+ * libgnat/s-imgrea.ads (Image_Ordinary_Fixed_Point): Add a
+ remark concerning the irrelevant use of Inf and -0.0
+
+2020-11-26 Arnaud Charlet <charlet@adacore.com>
+
+ * osint-c.adb (Set_Output_Object_File_Name): Add support for
+ .c output file.
+
+2020-11-26 Piotr Trojanek <trojanek@adacore.com>
+
+ * lib-writ.adb, sem_ch8.adb, sem_prag.adb: Use
+ Is_Generic_Subprogram instead of low-level membership tests.
+
+2020-11-26 Gary Dismukes <dismukes@adacore.com>
+
+ * sem_ch6.adb (Analyze_Call_And_Resolve): Reformatted a comment.
+ * sem_prag.adb (Process_Restrictions_Or_Restriction_Warnings):
+ Fixed a typo.
+
+2020-11-26 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_res.adb (Resolve_Membership_Op): Replace pragma Warnings
+ with pragma Assert.
+
+2020-11-26 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch6.adb (Analyze_Call_And_Resolve): Add information to the
+ error message on an illegal procedure call, when the illegality
+ is due to the presence of a component of the full view of the
+ target object, as well as a procedure with the same name (See RM
+ 4.1.3 (9.2/3)).
+
+2020-11-26 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_prag.adb (Process_Restrictions_Or_Restriction_Warnings):
+ when the restriction is a configuration pragma and specifies
+ No_Tasking, a global flag is set to reject task declarations,
+ and to prevent the construction of Master entities. The flag
+ must not be set if the pragma is a Restriction_Warning, in which
+ case task declarationns are allowed.
+
+2020-11-26 Piotr Trojanek <trojanek@adacore.com>
+
+ * libgnat/a-stzhas.adb (Wide_Wide_Hash): Instantiate inside a
+ wrapper function.
+ * libgnat/a-stzhas.ads (Wide_Wide_Hash): Likewise; remove wrong
+ comment, because this is indeed a RM unit, as described in Ada
+ RM A.4.8 (1/3).
+
+2020-11-26 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_eval.adb (Eval_Slice): Refactor repeated calls to Prefix
+ with a local constant (named just like in Resolve_Slice).
+
+2020-11-26 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_eval.adb (Eval_Slice): Emit warning not just for
+ constants, but for any objects.
+
+2020-11-26 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_ch4.adb (Indicate_Name_And_Type): Fix whitespace in
+ comment.
+ * sem_res.adb (Resolve_Call): Remove redundant parens.
+ * sem_util.adb (Set_Entity_With_Checks): Remove extra call to
+ Set_Entity.
+
+2020-11-26 Bob Duff <duff@adacore.com>
+
+ * exp_ch4.adb (Expand_Concatenate): Call Set_No_Initialization
+ on the N_Allocator node that is supposed to allocate on the
+ secondary stack.
+
+2020-11-26 Piotr Trojanek <trojanek@adacore.com>
+
+ * exp_ch13.adb, exp_ch9.adb, sem_ch8.adb, sem_util.adb: Replace
+ a combination of Is_Protected_Type and Is_Task_Type by
+ Is_Concurrent_Type.
+
+2020-11-26 Arnaud Charlet <charlet@adacore.com>
+
+ * libgnarl/s-tassta.adb (Task_Wrapper): Fix computation of
+ Pattern_Size.
+
+2020-11-26 Bob Duff <duff@adacore.com>
+
+ * freeze.adb (Freeze_Array_Type): Remove propagation of
+ Has_Own_Invariants to the first subtype. This is a no-op,
+ because the current (incorrect) version of Has_Own_Invariants
+ calls Base_Type.
+ * sem_prag.adb, sem_util.adb: Pass the base type to
+ Set_Has_Own_Invariants.
+
+2020-11-26 Eric Botcazou <ebotcazou@adacore.com>
+
+ * einfo.ads (Aft_Value): Adjust documentation.
+ (Scale_Value): Likewise.
+
+2020-11-26 Justin Squirek <squirek@adacore.com>
+
+ * exp_ch4.adb (Expand_N_Type_Conversion): Use the unexpanded
+ operand when generating accessibility checks.
+
+2020-11-26 Piotr Trojanek <trojanek@adacore.com>
+
+ * libgnat/a-cbhase.adb (Read): Remove extra whitespace.
+ * libgnat/a-cbmutr.ads (Read): Likewise.
+ * libgnat/a-cborse.adb (Read): Likewise.
+
+2020-11-26 Piotr Trojanek <trojanek@adacore.com>
+
+ * exp_ch7.adb, exp_util.adb, freeze.adb: Rewrite with
+ Is_Access_Object_Type.
+
+2020-11-26 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_prag.adb (Check_Valid_Library_Unit_Pragma): Raise
+ exception.
+ (Analyze_Pragma): Remove detection of rewritten pragmas.
+
+2020-11-26 Joffrey Huguet <huguet@adacore.com>
+
+ * libgnat/a-strmap.ads: Add preconditions and postconditions to
+ all subprograms.
+
+2020-11-26 Yannick Moy <moy@adacore.com>
+
+ * sem_res.adb (Resolve_Equality_Op): Warn when -gnatwq is used
+ (the default) and the problematic case is encountered.
+
+2020-11-26 Yannick Moy <moy@adacore.com>
+
+ * sem_attr.adb (Analyze_Attribute): Issue a continuation message
+ to give proper recommendation here.
+
+2020-11-26 Gary Dismukes <dismukes@adacore.com>
+
+ * exp_util.adb (Expand_Subtype_From_Expr): A typo correction,
+ plus other minor reformatting.
+
+2020-11-26 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch12.adb (Instantiate_Formal_Package): If previous matched
+ entity is overloadable, advance in the list of actuals of the
+ actual package, to prevent an erroneous match of two adjacent
+ overloadable homonyms with the same entity.
+
+2020-11-26 Justin Squirek <squirek@adacore.com>
+
+ * sem_ch6.adb (First_Selector): Utility routine to return the
+ first selector or choice in an association.
+ (Check_Return_Construct_Accessibility): Modify loop to handle
+ named associations when iterating through discriminants.
+
+2020-11-26 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_ch12.adb: Fix casing from "Instantiation" to
+ "instantiation".
+
+2020-11-25 Ed Schonberg <schonberg@adacore.com>
+
+ * freeze.adb (Is_Uninitialized_Aggregate): Move...
+ * exp_util.adb (Is_Uninitialized_Aggregate): ... here.
+ (Expand_Subtype_From_Expr): If the expression is an
+ uninitialized aggregate, capture subtype for declared object and
+ remove expression to suppress further superfluous expansion.
+
+2020-11-25 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_eval.adb (Subtypes_Statically_Compatible): Scalar types
+ with compatible static bounds are statically compatible if
+ predicates are compatible, even if they are not static subtypes.
+ Same for private types without discriminants.
+
+2020-11-25 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_ch11.adb (Expand_N_Raise_Statement): Use Is_Entity_Name
+ consistently in tests on the name of the statement.
+ * exp_prag.adb (Expand_Pragma_Check): In the local propagation
+ case, wrap the raise statement in a block statement.
+
+2020-11-25 Piotr Trojanek <trojanek@adacore.com>
+
+ * exp_ch8.adb (Expand_N_Exception_Renaming_Declaration): Move
+ "Nam" constant after the body of a nested subprogram; change "T"
+ from variable to constant.
+
+2020-11-25 Piotr Trojanek <trojanek@adacore.com>
+
+ * make.adb (Scan_Make_Arg): Merge ELSIF branches for -u and -U.
+
+2020-11-25 Piotr Trojanek <trojanek@adacore.com>
+
+ * doc/gnat_rm/implementation_defined_attributes.rst
+ (Has_Tagged_Values): Document based on the existing description
+ of Has_Access_Type and the comment for Has_Tagged_Component,
+ which is where frontend evaluates this attribute.
+ * gnat_rm.texi: Regenerate.
+ * sem_attr.adb (Analyze_Attribute): Merge processing of
+ Has_Access_Type and Has_Tagged_Component attributes.
+ * sem_util.adb (Has_Access_Type): Fix casing in comment.
+ * sem_util.ads (Has_Tagged_Component): Remove wrong (or
+ outdated) comment about the use of this routine to implement the
+ equality operator.
+
+2020-11-25 Piotr Trojanek <trojanek@adacore.com>
+
+ * exp_attr.adb (Expand_Size_Attribute): Remove whitespace;
+ simplify with a membership test, which are now allowed in the
+ frontend code.
+
+2020-11-25 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_ch13.adb (Analyze_One_Aspect): Fix inconsistent calls to
+ Make_Aitem_Pragma.
+
+2020-11-25 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_ch13.adb (Check_Expr_Constants): Simplify with
+ Is_Named_Number.
+ * sem_prag.adb (Process_Convention): Likewise.
+
+2020-11-25 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_ch13.adb (Analyze_One_Aspect): Detect aspect identifiers
+ with membership tests.
+ (Check_Aspect_At_End_Of_Declarations): Likewise.
+ (Freeze_Entity_Checks): Likewise; a local constant is no longer
+ needed.
+ (Is_Operational_Item): Similar simplification for attribute
+ identifiers.
+ (Is_Type_Related_Rep_Item): Likewise.
+ (Resolve_Iterable_Operation): Detect names with a membership
+ test.
+ (Validate_Independence): Replace repeated Ekind with a
+ membership test.
+
+2020-11-25 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_ch13.adb (Analyze_One_Aspect): Replace duplicate of
+ Effective_Reads.
+
+2020-11-25 Piotr Trojanek <trojanek@adacore.com>
+
+ * einfo.adb: Use composite wrappers (e.g.
+ Is_Subprogram_Or_Entry) and membership tests where it appears to
+ improve clarity.
+
+2020-11-25 Piotr Trojanek <trojanek@adacore.com>
+
+ * einfo.adb (Is_Standard_Character_Type,
+ Is_Standard_String_Type): Simplify.
+ (Last_Formal): Use procedural variant of Next_Formal.
+
+2020-11-25 Piotr Trojanek <trojanek@adacore.com>
+
+ * einfo.adb: Replace "E" with Entity_Id in local object
+ declarations.
+
+2020-11-25 Steve Baird <baird@adacore.com>
+
+ * exp_ch2.adb (Expand_Entity_Reference): A new local predicate
+ Is_Object_Renaming_Name indicates whether a given expression
+ occurs (after looking through qualified expressions and type
+ conversions) as the name of an object renaming declaration. If
+ Current_Value is available but this new predicate is True, then
+ ignore the availability of Current_Value.
+
+2020-11-25 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_ch12.adb (Instantiate_Type): Remove extra whitespace.
+ (Validate_Access_Type_Instance): Remove dead (and duplicated)
+ code.
+
+2020-11-25 Gary Dismukes <dismukes@adacore.com>
+
+ * exp_util.adb (Possible_Side_Effect_In_SPARK): Replace hyphen
+ with a space in "side-effect" (two instances).
+
+2020-11-25 Justin Squirek <squirek@adacore.com>
+
+ * doc/gnat_rm/intrinsic_subprograms.rst (Shifts and Rotates):
+ Document behavior on negative numbers
+ * gnat_rm.texi: Regenerate.
+ * sem_eval.adb (Fold_Shift): Set modulus to be based on the RM
+ size for non-modular integer types.
+
+2020-11-25 Olivier Hainque <hainque@adacore.com>
+
+ * adaint.c (__gnat_copy_attribs): Reinstate code based on utime
+ for timestamp processing on VxWorks 6.
+
+2020-11-25 Yannick Moy <moy@adacore.com>
+
+ * exp_util.adb (Remove_Side_Effects): Only remove side-effects
+ in GNATprove mode when this is useful.
+ * sem_res.adb (Set_Slice_Subtype): Make sure in GNATprove mode
+ to define the Itype when needed, so that run-time errors can be
+ analyzed.
+ * sem_util.adb (Enclosing_Declaration): Correctly take into
+ account renaming declarations.
+
+2020-11-25 Eric Botcazou <ebotcazou@adacore.com>
+
+ * libgnat/s-rannum.adb (Random_Discrete): Specifically deal with
+ the case where the size of the base type is larger than 64 bits.
+
+2020-11-25 Yannick Moy <moy@adacore.com>
+
+ * sem_ch3.adb (Access_Type_Declaration): Set Etype before
+ checking for volatility compatibility.
+
+2020-11-25 Eric Botcazou <ebotcazou@adacore.com>
+
+ * libgnat/g-rannum.ads (Random): New functions returning 128-bit.
+ * libgnat/g-rannum.adb (Random): Implement them and alphabetize.
+ (To_Signed): New unchecked conversion function for 128-bit.
+
+2020-11-25 Arnaud Charlet <charlet@adacore.com>
+
+ * exp_ch7.adb (Build_Finalization_Master, Build_Finalizer,
+ Build_Object_Declarations, Make_Deep_Array_Body,
+ Wrap_Transient_Expression): Call Set_Debug_Info_Needed on
+ temporaries when Debug_Generated_Code is True.
+
+2020-11-25 Liaiss Merzougue <merzougue@adacore.com>
+
+ * libgnat/s-imagei.adb
+ (Set_Digits): Rewrite the procedure to remove recursion.
+ (Image_Integer, Set_Image_Integer): Update assertions and remove
+ redundant ones.
+ * libgnat/s-imageu.adb
+ (Set_Image_Unsigned): Rewrite the procedure to remove recursion.
+
+2020-11-25 Piotr Trojanek <trojanek@adacore.com>
+
+ * exp_util.adb (Attribute_Constrained_Static_Value): Fix body
+ box.
+ * sem_attr.adb (Eval_Attribute): Replace repeated calls to
+ Attribute_Name with a captured value of the Attribute_Id; also,
+ remove extra parens around Is_Generic_Type.
+
+2020-11-25 Ghjuvan Lacambre <lacambre@adacore.com>
+
+ * sem_prag.adb (Analyze_Pragma): Emit error on wrong argument
+ nkind.
+
+2020-11-25 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_attr.adb, sem_prag.adb: Use Is_Named_Number.
+
+2020-11-25 Piotr Trojanek <trojanek@adacore.com>
+
+ * exp_attr.adb, exp_util.adb: Fix style and typos in comments.
+
+2020-11-25 Piotr Trojanek <trojanek@adacore.com>
+
+ * exp_attr.adb (Expand_N_Attribute_Reference): A variable that
+ is only incremented in the code has now type Nat; conversion is
+ now unnecessary.
+
+2020-11-24 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_prag.adb (Analyze_Global_Item): Call SPARK_Msg_NE with the
+ entity, not with its identifier.
+
+2020-11-24 Arnaud Charlet <charlet@adacore.com>
+
+ * opt.ads (Generate_Asm): New flag.
+ * osint-c.adb (Set_Output_Object_File_Name): Accept any
+ extension when generating assembly.
+ * adabkend.adb (Scan_Compiler_Args): Recognize -S.
+
+2020-11-24 Piotr Trojanek <trojanek@adacore.com>
+
+ * exp_attr.adb, exp_ch4.adb, exp_intr.adb, sem_ch8.adb,
+ sem_res.adb, sem_type.adb, sem_util.adb: Reuse Is_Packed_Array.
+
+2020-11-24 Piotr Trojanek <trojanek@adacore.com>
+
+ * checks.adb (Apply_Access_Check): Remove unbalanced paren.
+ * exp_attr.adb (Expand_N_Attribute_Reference): Fix typo in
+ comment.
+
+2020-11-24 Justin Squirek <squirek@adacore.com>
+
+ * sem_prag.adb (Analyze_Pragma): Mark relevant pragmas as ghost
+ when they are within a ghost region.
+
+2020-11-24 Piotr Trojanek <trojanek@adacore.com>
+
+ * contracts.adb, freeze.adb, sem_ch12.adb, sem_prag.adb: Reuse
+ In_Same_List.
+
+2020-11-24 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_prag.adb (Is_Loop_Pragma): Avoid repeated calls to
+ Original_Node; remove unnecessary IF statement.
+
+2020-11-24 Piotr Trojanek <trojanek@adacore.com>
+
+ * exp_spark.adb (Expand_SPARK_N_Attribute_Reference): Rewrite
+ with a CASE statement.
+
+2020-11-24 Piotr Trojanek <trojanek@adacore.com>
+
+ * exp_attr.adb (Expand_N_Attribute_Reference): Replace calls to
+ Sloc with a local constant Loc; remove call to
+ Analyze_And_Resolve and return, which is exactly what happens
+ anyway (and other branches in the Constrained declare block
+ appear to rely on analysis, resolution and returning happening
+ in all cases).
+ * sem_util.adb: Remove useless parens.
+
+2020-11-24 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_util.adb (Is_Object_Reference): Delta and extension
+ aggregates are objects.
+
+2020-11-24 Ghjuvan Lacambre <lacambre@adacore.com>
+
+ * libgnat/s-rident.ads (System.Rident): Register new restriction
+ IDs.
+ * par-ch13.adb (Get_Aspect_Specifications): Add restriction check.
+ * par-prag.adb (Process_Restrictions_Or_Restriction_Warnings):
+ Register No_Unrecognized_Aspects restriction.
+ * sem_prag.adb (Analyze_Pragma): Add restriction check.
+ * snames.ads-tmpl: Create restriction names.
+
+2020-11-24 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_attr.adb (Declared_Within): Return True for objects
+ declared within the attribute Loop_Entry prefix itself.
+
+2020-11-24 Yannick Moy <moy@adacore.com>
+
+ * sem_ch3.adb (Process_Discriminants): Correctly set right
+ context for analyzing default value of discriminant.
+
+2020-11-24 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_type.adb (Add_One_Interp.Is_Universal_Operation): Account
+ for universal_access = operator.
+ (Disambiguate): Take into account preference on universal_access
+ = operator when relevant.
+ (Disambiguate.Is_User_Defined_Anonymous_Access_Equality): New.
+
+2020-11-24 Arnaud Charlet <charlet@adacore.com>
+
+ * exp_util.adb (Is_Finalizable_Transient): Take into account return
+ statements containing N_Expression_With_Actions. Also clean up a
+ condition to make it more readable.
+ * exp_ch6.adb: Fix typo.
+
+2020-11-24 Eric Botcazou <ebotcazou@adacore.com>
+
+ * libgnat/a-wtdeio.adb (TFT): Delete and adjust throughout.
+ * libgnat/a-wtenau.adb (TFT): Likewise.
+ * libgnat/a-wtfiio.adb (TFT): Likewise.
+ * libgnat/a-wtflio.adb (TFT): Likewise.
+ * libgnat/a-wtinio.adb (TFT): Likewise.
+ * libgnat/a-wtinio__128.adb (TFT): Likewise.
+ * libgnat/a-wtmoio.adb (TFT): Likewise.
+ * libgnat/a-wtmoio__128.adb (TFT): Likewise.
+ * libgnat/a-ztdeio.adb (TFT): Likewise.
+ * libgnat/a-ztenau.adb (TFT): Likewise.
+ * libgnat/a-ztfiio.adb (TFT): Likewise.
+ * libgnat/a-ztflio.adb (TFT): Likewise.
+ * libgnat/a-ztinio.adb (TFT): Likewise.
+ * libgnat/a-ztinio__128.adb (TFT): Likewise.
+ * libgnat/a-ztmoio.adb (TFT): Likewise.
+ * libgnat/a-ztmoio__128.adb (TFT): Likewise.
+
+2020-11-24 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_ch13.adb (Validate_Literal_Aspect): Add support for named
+ numbers and in particular overload of the Real_Literal function.
+ * sem_res.adb (Resolve): Add support for named numbers in
+ Real_Literal and Integer_Literal resolution.
+ * einfo.adb, einfo.ads (Related_Expression,
+ Set_Related_Expression): Allow E_Function.
+ * uintp.ads (UI_Image_Max): Bump size of buffer to avoid loosing
+ precision.
+ * sem_eval.adb: Fix typo in comment.
+ * libgnat/a-nbnbin.adb, libgnat/a-nbnbin.ads (From_String):
+ Return a Valid_Big_Integer.
+ * libgnat/a-nbnbre.adb, libgnat/a-nbnbre.ads (From_String): New
+ variant taking two strings. Return a Valid_Big_Real.
+
+2020-11-24 Eric Botcazou <ebotcazou@adacore.com>
+
+ * sem_ch12.adb (Analyze_Associations) <Explicit_Freeze_Check>: Test
+ that the instance is in a statement sequence instead of local scope.
+ (Freeze_Subprogram_Body): Use the special delayed placement with
+ regard to the parent instance only if its Sloc is strictly greater.
+ (Install_Body): Likewise.
+
+2020-11-24 Steve Baird <baird@adacore.com>
+
+ * sem_ch13.adb (Validate_Literal_Aspect): Call to Base_Type
+ needed in order to correctly check result type of String_Literal
+ function when the first named subtype differs from the base
+ type (e.g.:
+ type T is range 1 .. 10 with String_Literal => ... ;
+ ).
+
+2020-11-24 Yannick Moy <moy@adacore.com>
+
+ * sem_prag.adb (Analyze_Global_Item): Handle specially the
+ current instance of a PO.
+ * sem_util.ads (Is_Effectively_Volatile,
+ Is_Effectively_Volatile_For_Reading): Add parameter
+ Ignore_Protected.
+ * sem_util.adb (Is_Effectively_Volatile,
+ Is_Effectively_Volatile_For_Reading): Add parameter
+ Ignore_Protected to compute the query results ignoring protected
+ objects/types.
+ (Is_Effectively_Volatile_Object,
+ Is_Effectively_Volatile_Object_For_Reading): Adapt to new
+ signature.
+
+2020-11-24 Ghjuvan Lacambre <lacambre@adacore.com>
+
+ * doc/gnat_ugn/building_executable_programs_with_gnat.rst:
+ Update documentation on -gnatyk.
+ * gnat_ugn.texi: Regenerate.
+
+2020-11-24 Yannick Moy <moy@adacore.com>
+
+ * sem_ch10.adb (Analyze_Compilation_Unit): Move aspects from
+ body to the newly created spec.
+
+2020-11-24 Arnaud Charlet <charlet@adacore.com>
+
+ * exp_ch6.adb (Add_Cond_Expression_Extra_Actual): Simplify
+ handling of function calls and remove bug in handling of
+ transient objects. Minor reformatting along the way.
+
+2020-11-24 Arnaud Charlet <charlet@adacore.com>
+
+ * libgnat/a-nbnbin.adb (From_String): Implement fully.
+
+2020-11-24 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_aggr.adb (Resolve_Delta_Array_Aggregate): If the choice is
+ a subtype_indication then call
+ Resolve_Discrete_Subtype_Indication; both for choices
+ immediately inside array delta aggregates and inside
+ iterated_component_association within array delta aggregates.
+
+2020-11-24 Piotr Trojanek <trojanek@adacore.com>
+
+ * lib-load.adb, lib-writ.adb, lib.adb, par-load.adb,
+ rtsfind.adb, sem_ch10.adb: Use Present where possible.
+
+2020-11-24 Yannick Moy <moy@adacore.com>
+
+ * sem_prag.adb (Analyze_Depends_Global): Reject Global and
+ Depends on null procedure.
+
+2020-11-24 Arnaud Charlet <charlet@adacore.com>
+
+ * libgnat/a-nbnbre.adb (From_String): Handle properly '_'
+ characters.
+
+2020-11-24 Piotr Trojanek <trojanek@adacore.com>
+
+ * exp_spark.adb (Expand_SPARK_Array_Aggregate,
+ Expand_SPARK_N_Aggregate): Remove, no longer needed.
+ * sem_aggr.adb (Resolve_Iterated_Component_Association): Only
+ remove references in the analyzed expression when generating
+ code and the expression needs to be analyzed anew after being
+ rewritten into a loop.
+
+2020-11-24 Eric Botcazou <ebotcazou@adacore.com>
+
+ * doc/gnat_rm/implementation_defined_characteristics.rst: Complete
+ entry of 3.5.9(10).
+ * gnat_rm.texi: Regenerate.
+
+2020-11-20 Maciej W. Rozycki <macro@linux-mips.org>
+
+ * adaint.c (__gnat_number_of_cpus): Check for the presence of
+ _SC_NPROCESSORS_ONLN rather than a list of OS-specific macros
+ to decide whether to use `sysconf'.
+
+2020-11-20 Jakub Jelinek <jakub@redhat.com>
+
+ PR other/97911
+ * gcc-interface/Make-lang.in (ada.serial): Change from goal to a
+ variable.
+ (.PHONY): Drop ada.serial and ada.prev.
+ (gnat1$(exeext)): Depend on $(ada.serial) rather than ada.serial.
+
+2020-11-19 Eric Botcazou <ebotcazou@adacore.com>
+
+ PR ada/97805
+ * adaint.c: Include climits in C++ and limits.h otherwise.
+
+2020-11-19 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_dbug.adb (Is_Handled_Scale_Factor): Delete.
+ (Get_Encoded_Name): Do not call it.
+ * gcc-interface/decl.c (gnat_to_gnu_entity) <Fixed_Point_Type>:
+ Tidy up and always use a meaningful description for arbitrary
+ scale factors.
+ * gcc-interface/misc.c (gnat_get_fixed_point_type_info): Remove
+ obsolete block and adjust the description of the scale factor.
+
+2020-11-18 Jakub Jelinek <jakub@redhat.com>
+
+ * gcc-interface/Make-lang.in (ada.serial): New goal.
+ (.PHONY): Add ada.serial ada.prev.
+ (gnat1$(exeext)): Depend on ada.prev. Call LINK_PROGRESS.
+
+2020-11-18 Matthias Klose <doko@ubuntu.com>
+
+ PR ada/97859
+ * Makefile.rtl (powerpc% linux%): Also match powerpc64le cpu.
+
+2020-11-11 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/gigi.h: Remove ^L characters throughout.
+ * gcc-interface/decl.c: Likewise.
+ * gcc-interface/utils.c: Likewise.
+ * gcc-interface/utils2.c: Likewise.
+ * gcc-interface/trans.c (gnat_to_gnu) <N_Allocator>: Do not explicitly
+ go to the base type for the Has_Constrained_Partial_View flag.
+
+2020-11-11 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/trans.c (build_binary_op_trapv): Convert operands
+ to the result type before doing generic overflow checking.
+
+2020-11-11 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/trans.c (can_be_lower_p): Remove.
+ (Regular_Loop_to_gnu): Add ENTRY_COND unconditionally if
+ BOTTOM_COND is non-zero.
+
+2020-11-11 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/decl.c (gnat_to_gnu_entity) <E_Constant>: In case
+ the constant is not being defined, get the expression in type
+ annotation mode only if its type is elementary.
+
+2020-11-11 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/trans.c (gnat_to_gnu) <N_Op_Shift>: Also convert
+ GNU_MAX_SHIFT if the type of the operation has been changed.
+ * gcc-interface/utils.c (can_materialize_object_renaming_p): Add
+ pair of missing parentheses.
+
+2020-11-07 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/Makefile.in: Force target_cpu to powerpc if the
+ nominal target is powerpc64-suse-linux.
+
+2020-11-07 Iain Sandoe <iain@sandoe.co.uk>
+
+ * gcc-interface/misc.c (gnat_printable_name): Change
+ DECL_IS_BUILTIN -> DECL_IS_UNDECLARED_BUILTIN.
+
+2020-10-28 Alexandre Oliva <oliva@adacore.com>
+
+ PR ada/97504
+ * Makefile.rtl (LIBGNAT_TARGET_PAIRS> <riscv*-*-*>: Use wraplf
+ version of Aux_Long_Long_Float.
+
+2020-10-27 Doug Rupp <rupp@adacore.com>
+
+ * Makefile.rtl: Add vx7r2cert spec file to ARM, PowerPC and x86
+ targets.
+ * vxworks7-cert-rtp-link.spec: New spec file.
+
+2020-10-27 Arnaud Charlet <charlet@adacore.com>
+
+ * Makefile.rtl (GNATRTL_NONTASKING_OBJS): Add g-spogwa object.
+ * libgnat/g-spogwa.adb: Fix style errors.
+
+2020-10-27 Piotr Trojanek <trojanek@adacore.com>
+
+ * exp_spark.adb (Expand_SPARK_Array_Aggregate): Dedicated
+ routine for array aggregates; mostly reuses existing code, but
+ calls itself recursively for multi-dimensional array aggregates.
+ (Expand_SPARK_N_Aggregate): Call Expand_SPARK_Array_Aggregate to
+ do the actual expansion, starting from the first index of the
+ array type.
+
+2020-10-27 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_aggr.adb (Resolve_Iterated_Component_Association): new
+ internal subprogram Remove_References, to reset semantic
+ information on each reference to the index variable of the
+ association, so that Collect_Aggregate_Bounds can work properly
+ on multidimensional arrays with nested associations, and
+ subsequent expansion into loops can verify that dimensions of
+ each subaggregate are compatible.
+
+2020-10-27 Ghjuvan Lacambre <lacambre@adacore.com>
+
+ * exp_prag.adb (Append_Copies): Handle N_Parameter_Associations.
+
+2020-10-27 Eric Botcazou <ebotcazou@adacore.com>
+
+ * ada_get_targ.adb (Digits_From_Size): Delete.
+ (Width_From_Size): Likewise.
+ * get_targ.adb (Digits_From_Size): Likewise.
+ (Width_From_Size): Likewise.
+ * get_targ.ads (Digits_From_Size): Likewise.
+ (Width_From_Size): Likewise.
+ * ttypes.ads: Remove with clause for Get_Targ.
+ (Standard_Short_Short_Integer_Width): Delete.
+ (Standard_Short_Integer_Width): Likewise.
+ (Standard_Integer_Width): Likewise.
+ (Standard_Long_Integer_Width): Likewise.
+ (Standard_Long_Long_Integer_Width): Likewise.
+ (Standard_Long_Long_Long_Integer_Width): Likewise.
+ (Standard_Short_Float_Digits): Likewise.
+ (Standard_Float_Digits): Likewise.
+ (Standard_Long_Float_Digits): Likewise.
+ (Standard_Long_Long_Float_Digits): Likewise.
+ * gnat1drv.adb (Adjust_Global_Switches): Adjust.
+
+2020-10-27 Arnaud Charlet <charlet@adacore.com>
+
+ * exp_ch6.adb, freeze.adb, gnat1drv.adb, opt.ads, sem_ch6.adb
+ (Transform_Function_Array): New flag, split from Modify_Tree_For_C.
+ * exp_unst.adb: Minor reformatting.
+
+2020-10-27 Dmitriy Anisimkov <anisimko@adacore.com>
+
+ * libgnat/g-socpol.adb (Wait): Do not exit from loop on EINTR
+ error and timeout is over.
+
+2020-10-26 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_aggr.adb (Build_Array_Aggr_Code): If the aggregate
+ includes an Others_Choice in an association that is an
+ Iterated_Component_Association, generate a proper loop for it.
+
+2020-10-26 Eric Botcazou <ebotcazou@adacore.com>
+
+ * libgnat/a-tifiio.adb: Add missing sign in documentation.
+ * libgnat/s-imgrea.ads: Minor fixes in commentary.
+
+2020-10-26 Pat Rogers <rogers@adacore.com>
+
+ * doc/gnat_rm/implementation_defined_pragmas.rst: Include
+ "Jorvik" in pragma Profile description.
+ * gnat_rm.texi: Regenerate.
+
+2020-10-26 Bob Duff <duff@adacore.com>
+
+ * sem_attr.adb (Check_Image_Type): Remove "|", so the compiler
+ will not crash.
+ * errout.ads: Improve comment. This has nothing to do with
+ -gnatQ.
+
+2020-10-26 Eric Botcazou <ebotcazou@adacore.com>
+
+ * libgnat/a-tifiio.adb: Minor editions to documentation.
+
+2020-10-26 Piotr Trojanek <trojanek@adacore.com>
+
+ * contracts.adb (Causes_Contract_Freezing): Extend condition to
+ match the one in Analyze_Subprogram_Body_Helper. This routine is
+ used both as an assertion at the very start of
+ Freeze_Previous_Contracts and to detect previous declaration for
+ which Freeze_Previous_Contracts has been executed.
+
+2020-10-26 Eric Botcazou <ebotcazou@adacore.com>
+
+ * libgnat/a-tifiio.adb: Move around documentaton paragraph.
+
+2020-10-26 Piotr Trojanek <trojanek@adacore.com>
+
+ * inline.adb (Establish_Actual_Mapping_For_Inlined_Call): Add
+ guard for a call to Set_Last_Assignment with the same condition
+ as the assertion in that routine and explain why this guard
+ fails in GNATprove mode.
+
+2020-10-26 Eric Botcazou <ebotcazou@adacore.com>
+
+ * doc/gnat_rm/implementation_defined_characteristics.rst: Adjust
+ the entries of 3.5.9(8) and 3.5.9(10).
+ * gnat_rm.texi: Regenerate.
+
+2020-10-26 Eric Botcazou <ebotcazou@adacore.com>
+
+ * libgnat/a-tifiio.adb: Change the range of supported Small
+ values.
+ (E0, E1, E2): Adjust factors.
+ (Exact): Return false if the Small does not fit in 64 bits.
+
+2020-10-26 Dmitriy Anisimkov <anisimko@adacore.com>
+
+ * libgnat/g-socket.adb (Wait_On_Socket): Boolean parameter
+ For_Read changed to Event parameter of type
+ GNAT.Sockets.Poll.Wait_Event_Set. Implementation is simplified
+ and based on call to GNAT.Sockets.Poll.Wait now.
+
+2020-10-26 Eric Botcazou <ebotcazou@adacore.com>
+
+ * libgnat/a-tifiio.adb: Minor editions to documentation.
+
+2020-10-26 Yannick Moy <moy@adacore.com>
+
+ * sem_ch12.adb (Restore_Private_Views): Do not lose the
+ information provided by Is_Generic_Actual_Type in GNATprove
+ mode.
+
+2020-10-26 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_warn.adb (Warn_On_Unreferenced_Entity): Suppress warning
+ on formal parameters of all dispatching operations.
+
+2020-10-26 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_aggr.adb (Resolve_Delta_Array_Aggregate): Fix typos in
+ error message.
+
+2020-10-26 Olivier Hainque <hainque@adacore.com>
+
+ * libgnat/s-dwalin.adb (Symbolic_Traceback): Always emit the hex
+ address at the beginning of an entry if suppression is not
+ requested. Consistently output a "???" for the subprogram name
+ when it is unknown.
+
+2020-10-26 Doug Rupp <rupp@adacore.com>
+
+ * s-oscons-tmplt.c (_nfds_t): Use sizeof (unsigned long int).
+
+2020-10-26 Piotr Trojanek <trojanek@adacore.com>
+
+ * par-ch4.adb (P_Iterated_Component_Association): Move code for
+ iterated_element_association to
+ Build_Iterated_Element_Association.
+
+2020-10-26 Yannick Moy <moy@adacore.com>
+
+ * sem_ch12.adb (Needs_Body_Instantiated): In GNATprove mode, do
+ not instantiate bodies outside of the main unit.
+
+2020-10-26 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_aggr.adb (Resolve_Delta_Array_Aggregate): For an
+ association that is an iterated component association, attach
+ the copy of the expression to the tree prior to analysis, in
+ order to preserve its context. This is needed when verifying
+ static semantic rules that depend on context, for example that a
+ use of 'Old appears only within a postcondition.
+
+2020-10-26 Bob Duff <duff@adacore.com>
+
+ * doc/gnat_ugn/gnat_utility_programs.rst: Document that
+ --no-comments-fill is now the default.
+
+2020-10-26 Gary Dismukes <dismukes@adacore.com>
+
+ * sem_aggr.adb (Resolve_Extension_Aggregate): When testing for
+ an aggregate that is illegal due to having an ancestor type that
+ has unknown discriminants, add an "or else" condition testing
+ whether the aggregate type has unknown discriminants and that
+ Partial_View_Has_Unknown_Discr is also set on the ancestor type.
+ Extend the comment, including adding ??? about a possible
+ simpler test.
+
+2020-10-26 Bob Duff <duff@adacore.com>
+
+ * libgnat/a-cihama.adb, libgnat/a-cohama.adb,
+ libgnat/a-cohase.adb (Delete): Set Position.Position, and
+ assert.
+
+2020-10-26 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_ch8.adb (Find_Direct_Name.Undefined): Handle known unit
+ names with 3 selectors.
+
+2020-10-26 Piotr Trojanek <trojanek@adacore.com>
+
+ * exp_spark.adb (Expand_SPARK_Delta_Or_Update): Add missing call
+ to Enter_Name, just like it is called for
+ iterated_component_association in Expand_SPARK_N_Aggregate.
+
+2020-10-26 Piotr Trojanek <trojanek@adacore.com>
+
+ * exp_spark.adb (Expand_SPARK_Delta_Or_Update): Reuse local
+ constant Expr and the Choice_List routine.
+ (Expand_SPARK_N_Aggregate): Reuse local constant Expr.
+
+2020-10-26 Piotr Trojanek <trojanek@adacore.com>
+
+ * par-ch4.adb (P_Iterated_Component_Association): Fix typos in
+ comments.
+
+2020-10-26 Arnaud Charlet <charlet@adacore.com>
+
+ * par-ch6.adb (P_Formal_Part): Ada 2020 supports scanning
+ aspects on formal parameters.
+ * doc/gnat_rm/implementation_defined_aspects.rst (Aspect
+ Unreferenced): Update documentation.
+ * gnat_rm.texi: Regenerate.
+
+2020-10-26 Ed Schonberg <schonberg@adacore.com>
+
+ * freeze.adb (Freeze_Type_Refs): When an entity in an expression
+ function is a type, freeze the entity and not just its type,
+ which would be incomplete when the type is derived and/or
+ tagged.
+
+2020-10-26 Piotr Trojanek <trojanek@adacore.com>
+
+ * exp_attr.adb (Expand_Update_Attribute): Handle
+ subtype_indication just like in Expand_Delta_Array_Aggregate.
+
+2020-10-25 Iain Sandoe <iain@sandoe.co.uk>
+
+ * Makefile.rtl: Add GNATRTL_128BIT_PAIRS/OBJS for 64bit
+ PowerPC Darwin cases.
+
2020-10-23 Iain Sandoe <iain@sandoe.co.uk>
* adaint.c: On Darwin platforms, define st_atim to
diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl
index 7b5b334..81df1e8 100644
--- a/gcc/ada/Makefile.rtl
+++ b/gcc/ada/Makefile.rtl
@@ -344,6 +344,7 @@ GNATRTL_NONTASKING_OBJS= \
a-tideio$(objext) \
a-tienau$(objext) \
a-tienio$(objext) \
+ a-tifiau$(objext) \
a-tifiio$(objext) \
a-tiflau$(objext) \
a-tiflio$(objext) \
@@ -371,6 +372,7 @@ GNATRTL_NONTASKING_OBJS= \
a-wtedit$(objext) \
a-wtenau$(objext) \
a-wtenio$(objext) \
+ a-wtfiau$(objext) \
a-wtfiio$(objext) \
a-wtflau$(objext) \
a-wtflio$(objext) \
@@ -394,6 +396,7 @@ GNATRTL_NONTASKING_OBJS= \
a-ztenau$(objext) \
a-ztenio$(objext) \
a-ztexio$(objext) \
+ a-ztfiau$(objext) \
a-ztfiio$(objext) \
a-ztflau$(objext) \
a-ztflio$(objext) \
@@ -483,6 +486,7 @@ GNATRTL_NONTASKING_OBJS= \
g-speche$(objext) \
g-spipat$(objext) \
g-spitbo$(objext) \
+ g-spogwa$(objext) \
g-sptabo$(objext) \
g-sptain$(objext) \
g-sptavs$(objext) \
@@ -519,6 +523,7 @@ GNATRTL_NONTASKING_OBJS= \
s-aomoar$(objext) \
s-aotase$(objext) \
s-aridou$(objext) \
+ s-arit32$(objext) \
s-arit64$(objext) \
s-assert$(objext) \
s-atacco$(objext) \
@@ -591,37 +596,47 @@ GNATRTL_NONTASKING_OBJS= \
s-fatgen$(objext) \
s-fatlfl$(objext) \
s-fatllf$(objext) \
- s-fatsfl$(objext) \
s-ficobl$(objext) \
s-filatt$(objext) \
s-fileio$(objext) \
s-finmas$(objext) \
s-finroo$(objext) \
s-flocon$(objext) \
- s-fore$(objext) \
+ s-fode32$(objext) \
+ s-fode64$(objext) \
+ s-fofi32$(objext) \
+ s-fofi64$(objext) \
+ s-fore_d$(objext) \
+ s-fore_f$(objext) \
+ s-forrea$(objext) \
s-gearop$(objext) \
s-genbig$(objext) \
s-geveop$(objext) \
s-gloloc$(objext) \
s-htable$(objext) \
s-imageb$(objext) \
+ s-imaged$(objext) \
+ s-imagef$(objext) \
s-imagei$(objext) \
s-imageu$(objext) \
s-imagew$(objext) \
+ s-imde32$(objext) \
+ s-imde64$(objext) \
s-imenne$(objext) \
+ s-imfi32$(objext) \
+ s-imfi64$(objext) \
s-imgbiu$(objext) \
s-imgboo$(objext) \
s-imgcha$(objext) \
- s-imgdec$(objext) \
s-imgenu$(objext) \
s-imgint$(objext) \
s-imgllb$(objext) \
- s-imglld$(objext) \
s-imglli$(objext) \
s-imgllu$(objext) \
s-imgllw$(objext) \
s-imgrea$(objext) \
s-imguns$(objext) \
+ s-imguti$(objext) \
s-imgwch$(objext) \
s-imgwiu$(objext) \
s-io$(objext) \
@@ -697,7 +712,9 @@ GNATRTL_NONTASKING_OBJS= \
s-pooglo$(objext) \
s-pooloc$(objext) \
s-poosiz$(objext) \
- s-powtab$(objext) \
+ s-powflt$(objext) \
+ s-powlfl$(objext) \
+ s-powllf$(objext) \
s-purexc$(objext) \
s-putima$(objext) \
s-rannum$(objext) \
@@ -735,14 +752,22 @@ GNATRTL_NONTASKING_OBJS= \
s-utf_32$(objext) \
s-valboo$(objext) \
s-valcha$(objext) \
- s-valdec$(objext) \
+ s-vade32$(objext) \
+ s-vade64$(objext) \
+ s-vafi32$(objext) \
+ s-vafi64$(objext) \
s-valenu$(objext) \
+ s-valflt$(objext) \
s-valint$(objext) \
- s-vallld$(objext) \
+ s-vallfl$(objext) \
+ s-valllf$(objext) \
s-vallli$(objext) \
s-valllu$(objext) \
s-valrea$(objext) \
+ s-valued$(objext) \
+ s-valuef$(objext) \
s-valuei$(objext) \
+ s-valuer$(objext) \
s-valueu$(objext) \
s-valuns$(objext) \
s-valuti$(objext) \
@@ -884,10 +909,17 @@ TRASYM_DWARF_UNIX_OBJS = $(TRASYM_DWARF_COMMON_OBJS) s-mmauni$(objext)
TRASYM_DWARF_MINGW_OBJS = $(TRASYM_DWARF_COMMON_OBJS)
GNATRTL_128BIT_PAIRS = \
+ a-decima.ads<libgnat/a-decima__128.ads \
+ a-tideio.adb<libgnat/a-tideio__128.adb \
+ a-tifiio.adb<libgnat/a-tifiio__128.adb \
a-tiinio.adb<libgnat/a-tiinio__128.adb \
a-timoio.adb<libgnat/a-timoio__128.adb \
+ a-wtdeio.adb<libgnat/a-wtdeio__128.adb \
+ a-wtfiio.adb<libgnat/a-wtfiio__128.adb \
a-wtinio.adb<libgnat/a-wtinio__128.adb \
a-wtmoio.adb<libgnat/a-wtmoio__128.adb \
+ a-ztdeio.adb<libgnat/a-ztdeio__128.adb \
+ a-ztfiio.adb<libgnat/a-ztfiio__128.adb \
a-ztinio.adb<libgnat/a-ztinio__128.adb \
a-ztmoio.adb<libgnat/a-ztmoio__128.adb \
i-cexten.ads<libgnat/i-cexten__128.ads \
@@ -902,6 +934,10 @@ GNATRTL_128BIT_OBJS = \
s-exnllli$(objext) \
s-expllli$(objext) \
s-explllu$(objext) \
+ s-fode128$(objext) \
+ s-fofi128$(objext) \
+ s-imde128$(objext) \
+ s-imfi128$(objext) \
s-imglllb$(objext) \
s-imgllli$(objext) \
s-imglllu$(objext) \
@@ -969,6 +1005,8 @@ GNATRTL_128BIT_OBJS = \
s-pack125$(objext) \
s-pack126$(objext) \
s-pack127$(objext) \
+ s-vade128$(objext) \
+ s-vafi128$(objext) \
s-valllli$(objext) \
s-vallllu$(objext) \
s-widllli$(objext) \
@@ -1135,6 +1173,7 @@ ifeq ($(strip $(filter-out powerpc% wrs vxworks vxworksspe vxworks7% vxworks7spe
else
GCC_SPEC_FILES+=vxworks7-rtp-base-link.spec
endif
+ GCC_SPEC_FILES+=vxworks7-cert-rtp-link.spec
else
GCC_SPEC_FILES+=vxworks-$(ARCH_STR)-link.spec
GCC_SPEC_FILES+=vxworks-cert-$(ARCH_STR)-link.spec
@@ -1410,6 +1449,7 @@ ifeq ($(strip $(filter-out %86 x86_64 wrs vxworks vxworks7%,$(target_cpu) $(targ
ifeq ($(strip $(filter-out vxworks7%, $(target_os))),)
GCC_SPEC_FILES+=vxworks7-$(X86CPU)-rtp-base-link.spec
+ GCC_SPEC_FILES+=vxworks7-cert-rtp-link.spec
else
GCC_SPEC_FILES+=vxworks-x86-link.spec
GCC_SPEC_FILES+=vxworks-cert-x86-link.spec
@@ -1533,6 +1573,9 @@ ifeq ($(strip $(filter-out aarch64 arm% coff wrs vx%,$(target_cpu) $(target_vend
GCC_SPEC_FILES+=vxworks-smp-arm-link.spec
endif
endif
+ ifeq ($(strip $(filter-out vxworks7%, $(target_os))),)
+ GCC_SPEC_FILES+=vxworks7-cert-rtp-link.spec
+ endif
endif
# ARM android
@@ -1635,8 +1678,7 @@ ifeq ($(strip $(filter-out sparc% sun solaris%,$(target_cpu) $(target_vendor) $(
endif
EH_MECHANISM=-gcc
- THREADSLIB = -lposix4 -lthread
- MISCLIB = -lposix4 -lnsl -lsocket
+ MISCLIB = -lnsl -lsocket
SO_OPTS = -Wl,-h,
GNATLIB_SHARED = gnatlib-shared-dual
GMEM_LIB = gmemlib
@@ -1689,8 +1731,7 @@ ifeq ($(strip $(filter-out %86 %x86_64 solaris2%,$(target_cpu) $(target_os))),)
EXTRA_GNATRTL_NONTASKING_OBJS += $(TRASYM_DWARF_UNIX_OBJS)
EH_MECHANISM=-gcc
- THREADSLIB = -lposix4 -lthread
- MISCLIB = -lposix4 -lnsl -lsocket
+ MISCLIB = -lnsl -lsocket
SO_OPTS = -Wl,-h,
GNATLIB_SHARED = gnatlib-shared-dual
GMEM_LIB = gmemlib
@@ -2000,6 +2041,7 @@ ifeq ($(strip $(filter-out hppa% hp hpux10%,$(target_cpu) $(target_vendor) $(tar
s-inmaop.adb<libgnarl/s-inmaop__posix.adb \
s-interr.adb<libgnarl/s-interr__sigaction.adb \
s-intman.adb<libgnarl/s-intman__posix.adb \
+ a-nallfl.ads<libgnat/a-nallfl__wraplf.ads \
s-osinte.adb<libgnarl/s-osinte__hpux-dce.adb \
s-osinte.ads<libgnarl/s-osinte__hpux-dce.ads \
s-parame.ads<libgnat/s-parame__hpux.ads \
@@ -2018,6 +2060,7 @@ ifeq ($(strip $(filter-out hppa% hp hpux11%,$(target_cpu) $(target_vendor) $(tar
a-intnam.ads<libgnarl/a-intnam__hpux.ads \
s-inmaop.adb<libgnarl/s-inmaop__posix.adb \
s-intman.adb<libgnarl/s-intman__posix.adb \
+ a-nallfl.ads<libgnat/a-nallfl__wraplf.ads \
s-osinte.adb<libgnarl/s-osinte__posix.adb \
s-osinte.ads<libgnarl/s-osinte__hpux.ads \
s-parame.ads<libgnat/s-parame__hpux.ads \
@@ -2249,6 +2292,7 @@ endif
ifeq ($(strip $(filter-out mips% 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-inmaop.adb<libgnarl/s-inmaop__posix.adb \
s-intman.adb<libgnarl/s-intman__posix.adb \
s-linux.ads<libgnarl/s-linux__mips.ads \
@@ -2299,7 +2343,7 @@ ifeq ($(strip $(filter-out powerpc% linux%,$(target_cpu) $(target_os))),)
$(ATOMICS_BUILTINS_TARGET_PAIRS) \
system.ads<libgnat/system-linux-ppc.ads
- ifeq ($(strip $(filter-out powerpc64,$(target_cpu))),)
+ ifeq ($(strip $(filter-out powerpc64%,$(target_cpu))),)
ifneq ($(strip $(MULTISUBDIR)),/32)
LIBGNAT_TARGET_PAIRS += $(GNATRTL_128BIT_PAIRS)
EXTRA_GNATRTL_NONTASKING_OBJS += $(GNATRTL_128BIT_OBJS)
@@ -2339,12 +2383,14 @@ ifeq ($(strip $(filter-out arm% linux-gnueabi%,$(target_cpu) $(target_os))),)
s-tasinf.adb<libgnarl/s-tasinf__linux.adb \
s-taspri.ads<libgnarl/s-taspri__posix-noaltstack.ads \
s-tpopsp.adb<libgnarl/s-tpopsp__posix-foreign.adb \
+ $(TRASYM_DWARF_UNIX_PAIRS) \
$(ATOMICS_TARGET_PAIRS) \
$(ATOMICS_BUILTINS_TARGET_PAIRS) \
system.ads<libgnat/system-linux-arm.ads
TOOLS_TARGET_PAIRS = indepsw.adb<indepsw-gnu.adb
+ EXTRA_GNATRTL_NONTASKING_OBJS += $(TRASYM_DWARF_UNIX_OBJS)
EXTRA_GNATRTL_TASKING_OBJS=s-linux.o
EH_MECHANISM=-arm
THREADSLIB = -lpthread
@@ -2697,6 +2743,7 @@ endif
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-inmaop.adb<libgnarl/s-inmaop__posix.adb \
s-intman.adb<libgnarl/s-intman__posix.adb \
s-linux.ads<libgnarl/s-linux__riscv.ads \
@@ -2795,8 +2842,19 @@ ifeq ($(strip $(filter-out darwin%,$(target_os))),)
$(ATOMICS_BUILTINS_TARGET_PAIRS) \
system.ads<libgnat/system-darwin-ppc.ads
- ifeq ($(strip $(MULTISUBDIR)),/ppc64)
+ ifeq ($(strip $(filter-out powerpc64,$(target_cpu))),)
+ ifneq ($(strip $(MULTISUBDIR)),/ppc)
+ LIBGNAT_TARGET_PAIRS += $(GNATRTL_128BIT_PAIRS)
+ EXTRA_GNATRTL_NONTASKING_OBJS += $(GNATRTL_128BIT_OBJS)
+ else
+ SO_OPTS += -m32
+ endif
+ else
+ ifeq ($(strip $(MULTISUBDIR)),/ppc64)
SO_OPTS += -m64
+ LIBGNAT_TARGET_PAIRS += $(GNATRTL_128BIT_PAIRS)
+ EXTRA_GNATRTL_NONTASKING_OBJS += $(GNATRTL_128BIT_OBJS)
+ endif
endif
endif
diff --git a/gcc/ada/ada_get_targ.adb b/gcc/ada/ada_get_targ.adb
index ddaca1a..123ba4e 100644
--- a/gcc/ada/ada_get_targ.adb
+++ b/gcc/ada/ada_get_targ.adb
@@ -208,22 +208,6 @@ package body Get_Targ is
return 0;
end Get_Double_Scalar_Alignment;
- ----------------------
- -- Digits_From_Size --
- ----------------------
-
- function Digits_From_Size (Size : Pos) return Pos is
- begin
- case Size is
- when 32 => return 6;
- when 48 => return 9;
- when 64 => return 15;
- when 96 => return 18;
- when 128 => return 18;
- when others => raise Program_Error;
- end case;
- end Digits_From_Size;
-
-----------------------------
-- Get_Max_Unaligned_Field --
-----------------------------
@@ -260,22 +244,6 @@ package body Get_Targ is
Alignment => 64);
end Register_Back_End_Types;
- ---------------------
- -- Width_From_Size --
- ---------------------
-
- function Width_From_Size (Size : Pos) return Pos is
- begin
- case Size is
- when 8 => return 4;
- when 16 => return 6;
- when 32 => return 11;
- when 64 => return 21;
- when 128 => return 40;
- when others => raise Program_Error;
- end case;
- end Width_From_Size;
-
------------------------------
-- Get_Back_End_Config_File --
------------------------------
diff --git a/gcc/ada/adabkend.adb b/gcc/ada/adabkend.adb
index 6fb4a84..b10c0bd 100644
--- a/gcc/ada/adabkend.adb
+++ b/gcc/ada/adabkend.adb
@@ -218,6 +218,9 @@ package body Adabkend is
end case;
end if;
+ elsif Switch_Chars (First .. Last) = "S" then
+ Generate_Asm := True;
+
-- Ignore all other back-end switches
elsif Is_Back_End_Switch (Switch_Chars) then
diff --git a/gcc/ada/adaint.c b/gcc/ada/adaint.c
index 560f352..0a90c92 100644
--- a/gcc/ada/adaint.c
+++ b/gcc/ada/adaint.c
@@ -145,6 +145,13 @@
#include "version.h"
#endif
+/* limits.h is needed for LLONG_MIN. */
+#ifdef __cplusplus
+#include <climits>
+#else
+#include <limits.h>
+#endif
+
#ifdef __cplusplus
extern "C" {
#endif
@@ -237,6 +244,8 @@ UINT __gnat_current_ccs_encoding;
#include "adaint.h"
+int __gnat_in_child_after_fork = 0;
+
#if defined (__APPLE__) && defined (st_mtime)
#define st_atim st_atimespec
#define st_mtim st_mtimespec
@@ -2414,6 +2423,7 @@ __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);
}
@@ -2476,9 +2486,7 @@ __gnat_number_of_cpus (void)
{
int cores = 1;
-#if defined (__linux__) || defined (__sun__) || defined (_AIX) \
- || defined (__APPLE__) || defined (__FreeBSD__) || defined (__OpenBSD__) \
- || defined (__DragonFly__) || defined (__NetBSD__)
+#ifdef _SC_NPROCESSORS_ONLN
cores = (int) sysconf (_SC_NPROCESSORS_ONLN);
#elif defined (__QNX__)
@@ -3262,7 +3270,22 @@ __gnat_copy_attribs (char *from ATTRIBUTE_UNUSED, char *to ATTRIBUTE_UNUSED,
return -1;
}
-#if _POSIX_C_SOURCE >= 200809L
+#if (defined (__vxworks) && _WRS_VXWORKS_MAJOR < 7)
+
+ /* VxWorks prior to 7 only has utime. */
+
+ /* Do we need to copy the timestamp ? */
+ if (mode != 2) {
+ struct utimbuf tbuf;
+
+ tbuf.actime = fbuf.st_atime;
+ tbuf.modtime = fbuf.st_mtime;
+
+ if (utime (to, &tbuf) == -1)
+ return -1;
+ }
+
+#elif _POSIX_C_SOURCE >= 200809L
struct timespec tbuf[2];
if (mode != 2) {
diff --git a/gcc/ada/adaint.h b/gcc/ada/adaint.h
index 4f42f6c..85997b9 100644
--- a/gcc/ada/adaint.h
+++ b/gcc/ada/adaint.h
@@ -139,7 +139,15 @@ struct file_attributes {
* fit the above struct on any system)
*/
-extern int __gnat_max_path_len;
+extern int __gnat_max_path_len;
+extern int __gnat_in_child_after_fork;
+/* This flag expresses the state when the fork call just returned zero result,
+ * i.e. when the new born child process is created and the new executable is
+ * not loaded yet. It is used to e.g. disable tracing memory
+ * allocation/deallocation in memtrack.adb just after fork returns in the child
+ * process to avoid both parent and child writing to the same gmem.out file
+ * simultaneously */
+
extern OS_Time __gnat_current_time (void);
extern void __gnat_current_time_string (char *);
extern void __gnat_to_gm_time (OS_Time *, int *, int *,
diff --git a/gcc/ada/ali-util.adb b/gcc/ada/ali-util.adb
index 9dcc656..7dabbfb 100644
--- a/gcc/ada/ali-util.adb
+++ b/gcc/ada/ali-util.adb
@@ -31,7 +31,6 @@ with Osint; use Osint;
with Scans; use Scans;
with Scng;
with Sinput.C;
-with Snames; use Snames;
with Stringt;
with Styleg;
@@ -154,15 +153,6 @@ package body ALI.Util is
Scanner.Initialize_Scanner (Source_Index);
- -- Make sure that the project language reserved words are not
- -- recognized as reserved words, but as identifiers. The byte info for
- -- those names have been set if we are in gnatmake.
-
- Set_Name_Table_Byte (Name_Project, 0);
- Set_Name_Table_Byte (Name_Extends, 0);
- Set_Name_Table_Byte (Name_External, 0);
- Set_Name_Table_Byte (Name_External_As_List, 0);
-
-- Scan the complete file to compute its checksum
loop
diff --git a/gcc/ada/ali.adb b/gcc/ada/ali.adb
index 3bf1257..f213c30 100644
--- a/gcc/ada/ali.adb
+++ b/gcc/ada/ali.adb
@@ -3814,15 +3814,15 @@ package body ALI is
return No_ALI_Id;
end Scan_ALI;
- -----------
- -- Scope --
- -----------
+ --------------
+ -- IS_Scope --
+ --------------
- function Scope (IS_Id : Invocation_Signature_Id) return Name_Id is
+ function IS_Scope (IS_Id : Invocation_Signature_Id) return Name_Id is
begin
pragma Assert (Present (IS_Id));
return Invocation_Signatures.Table (IS_Id).Scope;
- end Scope;
+ end IS_Scope;
---------
-- SEq --
diff --git a/gcc/ada/ali.ads b/gcc/ada/ali.ads
index 928fdbd..ccb516f 100644
--- a/gcc/ada/ali.ads
+++ b/gcc/ada/ali.ads
@@ -1350,8 +1350,8 @@ package ALI is
pragma Inline (Name);
-- Obtain the name of invocation signature IS_Id
- function Scope (IS_Id : Invocation_Signature_Id) return Name_Id;
- pragma Inline (Scope);
+ function IS_Scope (IS_Id : Invocation_Signature_Id) return Name_Id;
+ pragma Inline (IS_Scope);
-- Obtain the scope of invocation signature IS_Id
procedure Set_Invocation_Graph_Encoding
diff --git a/gcc/ada/aspects.adb b/gcc/ada/aspects.adb
index 37bbcae..91550c8 100644
--- a/gcc/ada/aspects.adb
+++ b/gcc/ada/aspects.adb
@@ -44,6 +44,7 @@ package body Aspects is
Aspect_Discard_Names => True,
Aspect_Independent_Components => True,
Aspect_Iterator_Element => True,
+ Aspect_Stable_Properties => True,
Aspect_Type_Invariant => True,
Aspect_Unchecked_Union => True,
Aspect_Variable_Indexing => True,
@@ -185,7 +186,11 @@ package body Aspects is
-- Find_Aspect --
-----------------
- function Find_Aspect (Id : Entity_Id; A : Aspect_Id) return Node_Id is
+ function Find_Aspect
+ (Id : Entity_Id;
+ A : Aspect_Id;
+ Class_Present : Boolean := False) return Node_Id
+ is
Decl : Node_Id;
Item : Node_Id;
Owner : Entity_Id;
@@ -219,6 +224,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)
then
return Item;
end if;
@@ -241,7 +247,9 @@ package body Aspects is
if Permits_Aspect_Specifications (Decl) then
Spec := First (Aspect_Specifications (Decl));
while Present (Spec) loop
- if Get_Aspect_Id (Spec) = A then
+ if Get_Aspect_Id (Spec) = A
+ and then Class_Present = Sinfo.Class_Present (Spec)
+ then
return Spec;
end if;
@@ -260,10 +268,12 @@ package body Aspects is
--------------------------
function Find_Value_Of_Aspect
- (Id : Entity_Id;
- A : Aspect_Id) return Node_Id
+ (Id : Entity_Id;
+ A : Aspect_Id;
+ Class_Present : Boolean := False) return Node_Id
is
- Spec : constant Node_Id := Find_Aspect (Id, A);
+ Spec : constant Node_Id := Find_Aspect (Id, A,
+ Class_Present => Class_Present);
begin
if Present (Spec) then
@@ -296,9 +306,13 @@ package body Aspects is
-- Has_Aspect --
----------------
- function Has_Aspect (Id : Entity_Id; A : Aspect_Id) return Boolean is
+ function Has_Aspect
+ (Id : Entity_Id;
+ A : Aspect_Id;
+ Class_Present : Boolean := False) return Boolean
+ is
begin
- return Present (Find_Aspect (Id, A));
+ return Present (Find_Aspect (Id, A, Class_Present => Class_Present));
end Has_Aspect;
------------------
diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads
index 1470efe..e16ceb0 100644
--- a/gcc/ada/aspects.ads
+++ b/gcc/ada/aspects.ads
@@ -142,6 +142,7 @@ package Aspects is
Aspect_Size,
Aspect_Small,
Aspect_SPARK_Mode, -- GNAT
+ Aspect_Stable_Properties,
Aspect_Static_Predicate,
Aspect_Storage_Pool,
Aspect_Storage_Size,
@@ -237,16 +238,17 @@ package Aspects is
-- The following array indicates aspects that accept 'Class
Class_Aspect_OK : constant array (Aspect_Id) of Boolean :=
- (Aspect_Input => True,
- Aspect_Invariant => True,
- Aspect_Output => True,
- Aspect_Pre => True,
- Aspect_Predicate => True,
- Aspect_Post => True,
- Aspect_Read => True,
- Aspect_Write => True,
- Aspect_Type_Invariant => True,
- others => False);
+ (Aspect_Input => True,
+ Aspect_Invariant => True,
+ Aspect_Output => True,
+ Aspect_Pre => True,
+ Aspect_Predicate => True,
+ Aspect_Post => True,
+ Aspect_Read => True,
+ Aspect_Write => True,
+ Aspect_Stable_Properties => True,
+ Aspect_Type_Invariant => True,
+ others => False);
-- The following array identifies all implementation defined aspects
@@ -427,6 +429,7 @@ package Aspects is
Aspect_Size => Expression,
Aspect_Small => Expression,
Aspect_SPARK_Mode => Optional_Name,
+ Aspect_Stable_Properties => Expression,
Aspect_Static_Predicate => Expression,
Aspect_Storage_Pool => Name,
Aspect_Storage_Size => Expression,
@@ -528,6 +531,7 @@ package Aspects is
Aspect_Size => True,
Aspect_Small => True,
Aspect_SPARK_Mode => False,
+ Aspect_Stable_Properties => False,
Aspect_Static_Predicate => False,
Aspect_Storage_Pool => True,
Aspect_Storage_Size => True,
@@ -704,6 +708,7 @@ package Aspects is
Aspect_Size => Name_Size,
Aspect_Small => Name_Small,
Aspect_SPARK_Mode => Name_SPARK_Mode,
+ Aspect_Stable_Properties => Name_Stable_Properties,
Aspect_Static => Name_Static,
Aspect_Static_Predicate => Name_Static_Predicate,
Aspect_Storage_Pool => Name_Storage_Pool,
@@ -965,6 +970,7 @@ package Aspects is
Aspect_Refined_State => Never_Delay,
Aspect_Relaxed_Initialization => Never_Delay,
Aspect_SPARK_Mode => Never_Delay,
+ Aspect_Stable_Properties => Always_Delay,
Aspect_Static => Never_Delay,
Aspect_Subprogram_Variant => Never_Delay,
Aspect_Synchronization => Never_Delay,
@@ -1094,18 +1100,24 @@ package Aspects is
-- aspect specification list, the routine has no effect. It is assumed that
-- both nodes can support aspects.
- function Find_Aspect (Id : Entity_Id; A : Aspect_Id) return Node_Id;
- -- Find the aspect specification of aspect A associated with entity I.
+ function Find_Aspect (Id : Entity_Id;
+ A : Aspect_Id;
+ Class_Present : Boolean := False) return Node_Id;
+ -- Find the aspect specification of aspect A (or A'Class if Class_Present)
+ -- associated with entity I.
-- Return Empty if Id does not have the requested aspect.
function Find_Value_Of_Aspect
- (Id : Entity_Id;
- A : Aspect_Id) return Node_Id;
- -- Find the value of aspect A associated with entity Id. Return Empty if
- -- Id does not have the requested aspect.
-
- function Has_Aspect (Id : Entity_Id; A : Aspect_Id) return Boolean;
- -- Determine whether entity Id has aspect A
+ (Id : Entity_Id;
+ A : Aspect_Id;
+ Class_Present : Boolean := False) return Node_Id;
+ -- Find the value of aspect A (or A'Class, if Class_Present) associated
+ -- with entity Id. Return Empty if Id does not have the requested aspect.
+
+ function Has_Aspect (Id : Entity_Id;
+ A : Aspect_Id;
+ Class_Present : Boolean := False) return Boolean;
+ -- Determine whether entity Id has aspect A (or A'Class, if Class_Present)
procedure Move_Aspects (From : Node_Id; To : Node_Id);
-- Relocate the aspect specifications of node From to node To. On entry it
diff --git a/gcc/ada/bindo-writers.adb b/gcc/ada/bindo-writers.adb
index cca6687..926fb82 100644
--- a/gcc/ada/bindo-writers.adb
+++ b/gcc/ada/bindo-writers.adb
@@ -222,7 +222,7 @@ package body Bindo.Writers is
Write_Eol;
Write_Str (" Scope = ");
- Write_Name (Scope (IS_Id));
+ Write_Name (IS_Scope (IS_Id));
Write_Eol;
end Write_Invocation_Signature;
diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb
index b389da5..61e41dd 100644
--- a/gcc/ada/checks.adb
+++ b/gcc/ada/checks.adb
@@ -535,7 +535,7 @@ package body Checks is
-- We do not need checks if we are not generating code (i.e. the
-- expander is not active). This is not just an optimization, there
-- are cases (e.g. with pragma Debug) where generating the checks
- -- can cause real trouble).
+ -- can cause real trouble.
if not Expander_Active then
return;
@@ -3258,23 +3258,16 @@ package body Checks is
end if;
-- Return if we know expression is definitely in the range of the target
- -- type as determined by Determine_Range. Right now we only do this for
- -- discrete types, and not fixed-point or floating-point types.
-
- -- The additional less-precise tests below catch these cases
-
- -- In GNATprove_Mode, also deal with the case of a conversion from
- -- floating-point to integer. It is only possible because analysis
- -- in GNATprove rules out the possibility of a NaN or infinite value.
+ -- type as determined by Determine_Range_To_Discrete. Right now we only
+ -- do this for discrete target types, i.e. neither for fixed-point nor
+ -- for floating-point types. But the additional less precise tests below
+ -- catch these cases.
-- Note: skip this if we are given a source_typ, since the point of
-- supplying a Source_Typ is to stop us looking at the expression.
-- We could sharpen this test to be out parameters only ???
if Is_Discrete_Type (Target_Typ)
- and then (Is_Discrete_Type (Etype (Expr))
- or else (GNATprove_Mode
- and then Is_Floating_Point_Type (Etype (Expr))))
and then not Is_Unconstrained_Subscr_Ref
and then No (Source_Typ)
then
@@ -3318,35 +3311,8 @@ package body Checks is
-- Otherwise determine range of value
- if Is_Discrete_Type (Etype (Expr)) then
- Determine_Range
- (Expr, OK, Lo, Hi, Assume_Valid => True);
-
- -- When converting a float to an integer type, determine the
- -- range in real first, and then convert the bounds using
- -- UR_To_Uint which correctly rounds away from zero when
- -- half way between two integers, as required by normal
- -- Ada 95 rounding semantics. It is only possible because
- -- analysis in GNATprove rules out the possibility of a NaN
- -- or infinite value.
-
- elsif GNATprove_Mode
- and then Is_Floating_Point_Type (Etype (Expr))
- then
- declare
- Hir : Ureal;
- Lor : Ureal;
-
- begin
- Determine_Range_R
- (Expr, OK, Lor, Hir, Assume_Valid => True);
-
- if OK then
- Lo := UR_To_Uint (Lor);
- Hi := UR_To_Uint (Hir);
- end if;
- end;
- end if;
+ Determine_Range_To_Discrete
+ (Expr, OK, Lo, Hi, Fixed_Int, Assume_Valid => True);
if OK then
@@ -3389,10 +3355,12 @@ package body Checks is
-- Check if we can determine at compile time whether Expr is in the
-- range of the target type. Note that if S_Typ is within the bounds
-- of Target_Typ then this must be the case. This check is meaningful
- -- only if this is not a conversion between integer and real types.
+ -- only if this is not a conversion between integer and real types,
+ -- unless for a fixed-point type if Fixed_Int is set.
if not Is_Unconstrained_Subscr_Ref
- and then Is_Discrete_Type (S_Typ) = Is_Discrete_Type (Target_Typ)
+ and then (Is_Discrete_Type (S_Typ) = Is_Discrete_Type (Target_Typ)
+ or else (Fixed_Int and then Is_Discrete_Type (Target_Typ)))
and then
(In_Subrange_Of (S_Typ, Target_Typ, Fixed_Int)
@@ -3705,12 +3673,15 @@ package body Checks is
then
Apply_Float_Conversion_Check (Expr, Target_Type);
else
- -- Conversions involving fixed-point types are expanded
- -- separately, and do not need a Range_Check flag, except
- -- in GNATprove_Mode, where the explicit constraint check
- -- will not be generated.
+ -- Raw conversions involving fixed-point types are expanded
+ -- separately and do not need a Range_Check flag yet, except
+ -- in GNATprove_Mode where this expansion is not performed.
+ -- This does not apply to conversion where fixed-point types
+ -- are treated as integers, which are precisely generated by
+ -- this expansion.
if GNATprove_Mode
+ or else Conv_OK
or else (not Is_Fixed_Point_Type (Expr_Type)
and then not Is_Fixed_Point_Type (Target_Type))
then
@@ -3951,6 +3922,13 @@ package body Checks is
function Aggregate_Discriminant_Val (Disc : Entity_Id) return Node_Id;
+ function Replace_Current_Instance
+ (N : Node_Id) return Traverse_Result;
+ -- Replace a reference to the current instance of the type with the
+ -- corresponding _init formal of the initialization procedure. Note:
+ -- this function relies on us currently being within the initialization
+ -- procedure.
+
--------------------------------
-- Aggregate_Discriminant_Val --
--------------------------------
@@ -3978,6 +3956,26 @@ package body Checks is
raise Program_Error;
end Aggregate_Discriminant_Val;
+ ------------------------------
+ -- Replace_Current_Instance --
+ ------------------------------
+
+ function Replace_Current_Instance
+ (N : Node_Id) return Traverse_Result is
+ begin
+ if Is_Entity_Name (N)
+ and then Etype (N) = Entity (N)
+ then
+ Rewrite (N,
+ New_Occurrence_Of (First_Formal (Current_Subprogram), Loc));
+ end if;
+
+ return OK;
+ end Replace_Current_Instance;
+
+ procedure Search_And_Replace_Current_Instance is new
+ Traverse_Proc (Replace_Current_Instance);
+
-- Start of processing for Build_Discriminant_Checks
begin
@@ -4007,6 +4005,13 @@ package body Checks is
Dval := Duplicate_Subexpr_No_Checks (Dval);
end if;
+ -- Replace references to the current instance of the type with the
+ -- corresponding _init formal of the initialization procedure.
+
+ if Within_Init_Proc then
+ Search_And_Replace_Current_Instance (Dval);
+ end if;
+
-- If we have an Unchecked_Union node, we can infer the discriminants
-- of the node.
@@ -4415,7 +4420,7 @@ package body Checks is
Apply_Compile_Time_Constraint_Error
(N => Expr,
Msg =>
- "(Ada 2005) null not allowed in null-excluding "
+ "(Ada 2005) NULL not allowed in null-excluding "
& "components??",
Reason => CE_Null_Not_Allowed);
@@ -4423,7 +4428,7 @@ package body Checks is
Apply_Compile_Time_Constraint_Error
(N => Expr,
Msg =>
- "(Ada 2005) null not allowed in null-excluding "
+ "(Ada 2005) NULL not allowed in null-excluding "
& "objects??",
Reason => CE_Null_Not_Allowed);
@@ -4431,7 +4436,7 @@ package body Checks is
Apply_Compile_Time_Constraint_Error
(N => Expr,
Msg =>
- "(Ada 2005) null not allowed in null-excluding "
+ "(Ada 2005) NULL not allowed in null-excluding "
& "formals??",
Reason => CE_Null_Not_Allowed);
@@ -5354,38 +5359,11 @@ package body Checks is
end case;
when N_Type_Conversion =>
+ -- For a type conversion, we can try to refine the range using the
+ -- converted value.
- -- For type conversion from one discrete type to another, we can
- -- refine the range using the converted value.
-
- if Is_Discrete_Type (Etype (Expression (N))) then
- Determine_Range (Expression (N), OK1, Lor, Hir, Assume_Valid);
-
- -- When converting a float to an integer type, determine the range
- -- in real first, and then convert the bounds using UR_To_Uint
- -- which correctly rounds away from zero when half way between two
- -- integers, as required by normal Ada 95 rounding semantics. It
- -- is only possible because analysis in GNATprove rules out the
- -- possibility of a NaN or infinite value.
-
- elsif GNATprove_Mode
- and then Is_Floating_Point_Type (Etype (Expression (N)))
- then
- declare
- Lor_Real, Hir_Real : Ureal;
- begin
- Determine_Range_R (Expression (N), OK1, Lor_Real, Hir_Real,
- Assume_Valid);
-
- if OK1 then
- Lor := UR_To_Uint (Lor_Real);
- Hir := UR_To_Uint (Hir_Real);
- end if;
- end;
-
- else
- OK1 := False;
- end if;
+ Determine_Range_To_Discrete
+ (Expression (N), OK1, Lor, Hir, Conversion_OK (N), Assume_Valid);
-- Nothing special to do for all other expression kinds
@@ -5905,6 +5883,96 @@ package body Checks is
end if;
end Determine_Range_R;
+ ---------------------------------
+ -- Determine_Range_To_Discrete --
+ ---------------------------------
+
+ procedure Determine_Range_To_Discrete
+ (N : Node_Id;
+ OK : out Boolean;
+ Lo : out Uint;
+ Hi : out Uint;
+ Fixed_Int : Boolean := False;
+ Assume_Valid : Boolean := False)
+ is
+ Typ : constant Entity_Id := Etype (N);
+
+ begin
+ -- For a discrete type, simply defer to Determine_Range
+
+ if Is_Discrete_Type (Typ) then
+ Determine_Range (N, OK, Lo, Hi, Assume_Valid);
+
+ -- For a fixed point type treated as an integer, we can determine the
+ -- range using the Corresponding_Integer_Value of the bounds of the
+ -- type or base type. This is done by the calls to Expr_Value below.
+
+ elsif Is_Fixed_Point_Type (Typ) and then Fixed_Int then
+ declare
+ Btyp, Ftyp : Entity_Id;
+ Bound : Node_Id;
+
+ begin
+ if Assume_Valid then
+ Ftyp := Typ;
+ else
+ Ftyp := Underlying_Type (Base_Type (Typ));
+ end if;
+
+ Btyp := Base_Type (Ftyp);
+
+ -- First the low bound
+
+ Bound := Type_Low_Bound (Ftyp);
+
+ if Compile_Time_Known_Value (Bound) then
+ Lo := Expr_Value (Bound);
+ else
+ Lo := Expr_Value (Type_Low_Bound (Btyp));
+ end if;
+
+ -- Then the high bound
+
+ Bound := Type_High_Bound (Ftyp);
+
+ if Compile_Time_Known_Value (Bound) then
+ Hi := Expr_Value (Bound);
+ else
+ Hi := Expr_Value (Type_High_Bound (Btyp));
+ end if;
+
+ OK := True;
+ end;
+
+ -- For a floating-point type, we can determine the range in real first,
+ -- and then convert the bounds using UR_To_Uint, which correctly rounds
+ -- away from zero when half way between two integers, as required by
+ -- normal Ada 95 rounding semantics. But this is only possible because
+ -- GNATprove's analysis rules out the possibility of a NaN or infinite.
+
+ elsif GNATprove_Mode and then Is_Floating_Point_Type (Typ) then
+ declare
+ Lo_Real, Hi_Real : Ureal;
+
+ begin
+ Determine_Range_R (N, OK, Lo_Real, Hi_Real, Assume_Valid);
+
+ if OK then
+ Lo := UR_To_Uint (Lo_Real);
+ Hi := UR_To_Uint (Hi_Real);
+ else
+ Lo := No_Uint;
+ Hi := No_Uint;
+ end if;
+ end;
+
+ else
+ Lo := No_Uint;
+ Hi := No_Uint;
+ OK := False;
+ end if;
+ end Determine_Range_To_Discrete;
+
------------------------------------
-- Discriminant_Checks_Suppressed --
------------------------------------
@@ -10551,10 +10619,10 @@ package body Checks is
begin
-- Checks will be applied only when generating code. In GNATprove mode,
-- we do not apply the checks, but we still call Selected_Range_Checks
- -- to possibly issue errors on SPARK code when a run-time error can be
- -- detected at compile time.
+ -- outside of generics to possibly issue errors on SPARK code when a
+ -- run-time error can be detected at compile time.
- if not Expander_Active and not GNATprove_Mode then
+ if Inside_A_Generic or (not GNATprove_Mode and not Expander_Active) then
return Ret_Result;
end if;
@@ -11127,8 +11195,7 @@ package body Checks is
procedure Validity_Check_Range
(N : Node_Id;
- Related_Id : Entity_Id := Empty)
- is
+ Related_Id : Entity_Id := Empty) is
begin
if Validity_Checks_On and Validity_Check_Operands then
if Nkind (N) = N_Range then
@@ -11145,17 +11212,4 @@ package body Checks is
end if;
end Validity_Check_Range;
- --------------------------------
- -- Validity_Checks_Suppressed --
- --------------------------------
-
- function Validity_Checks_Suppressed (E : Entity_Id) return Boolean is
- begin
- if Present (E) and then Checks_May_Be_Suppressed (E) then
- return Is_Check_Suppressed (E, Validity_Check);
- else
- return Scope_Suppress.Suppress (Validity_Check);
- end if;
- end Validity_Checks_Suppressed;
-
end Checks;
diff --git a/gcc/ada/checks.ads b/gcc/ada/checks.ads
index aca1b7e..e7b7261 100644
--- a/gcc/ada/checks.ads
+++ b/gcc/ada/checks.ads
@@ -64,7 +64,6 @@ package Checks is
function Range_Checks_Suppressed (E : Entity_Id) return Boolean;
function Storage_Checks_Suppressed (E : Entity_Id) return Boolean;
function Tag_Checks_Suppressed (E : Entity_Id) return Boolean;
- function Validity_Checks_Suppressed (E : Entity_Id) return Boolean;
-- These functions check to see if the named check is suppressed, either
-- by an active scope suppress setting, or because the check has been
-- specifically suppressed for the given entity. If no entity is relevant
@@ -338,6 +337,21 @@ package Checks is
-- For that to happen, the possibility of arguments of infinite or NaN
-- value should be taken into account, which is not the case currently.
+ procedure Determine_Range_To_Discrete
+ (N : Node_Id;
+ OK : out Boolean;
+ Lo : out Uint;
+ Hi : out Uint;
+ Fixed_Int : Boolean := False;
+ Assume_Valid : Boolean := False);
+ -- Similar to Determine_Range, but attempts to return a discrete range even
+ -- if N is not of a discrete type by doing a conversion. The Fixed_Int flag
+ -- if set causes any fixed-point values to be treated as though they were
+ -- discrete values (i.e. the underlying integer value is used), in which
+ -- case no conversion is needed. At the current time, this is used only for
+ -- discrete types, for fixed-point types if Fixed_Int is set, and also for
+ -- floating-point types in GNATprove, see Determine_Range_R above.
+
procedure Install_Null_Excluding_Check (N : Node_Id);
-- Determines whether an access node requires a run-time access check and
-- if so inserts the appropriate run-time check.
diff --git a/gcc/ada/contracts.adb b/gcc/ada/contracts.adb
index 9e328e2..29557ec 100644
--- a/gcc/ada/contracts.adb
+++ b/gcc/ada/contracts.adb
@@ -47,6 +47,7 @@ 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;
@@ -904,9 +905,12 @@ package body Contracts is
-- The following checks are relevant only when SPARK_Mode is on, as
-- they are not standard Ada legality rules. Internally generated
- -- temporaries are ignored.
+ -- temporaries are ignored, as well as return objects.
- if SPARK_Mode = On and then Comes_From_Source (Type_Or_Obj_Id) then
+ if SPARK_Mode = On
+ and then Comes_From_Source (Type_Or_Obj_Id)
+ and then not Is_Return_Object (Type_Or_Obj_Id)
+ then
if Is_Effectively_Volatile (Type_Or_Obj_Id) then
-- The declaration of an effectively volatile object or type must
@@ -1668,6 +1672,12 @@ package body Contracts is
-- function, Result contains the entity of parameter _Result, to be
-- used in the creation of procedure _Postconditions.
+ procedure Add_Stable_Property_Contracts
+ (Subp_Id : Entity_Id; Class_Present : Boolean);
+ -- Augment postcondition contracts to reflect Stable_Property aspect
+ -- (if Class_Present = False) or Stable_Property'Class aspect (if
+ -- Class_Present = True).
+
procedure Append_Enabled_Item (Item : Node_Id; List : in out List_Id);
-- Append a node to a list. If there is no list, create a new one. When
-- the item denotes a pragma, it is added to the list only when it is
@@ -1905,6 +1915,244 @@ package body Contracts is
end loop;
end Add_Invariant_And_Predicate_Checks;
+ -----------------------------------
+ -- Add_Stable_Property_Contracts --
+ -----------------------------------
+
+ procedure Add_Stable_Property_Contracts
+ (Subp_Id : Entity_Id; Class_Present : Boolean)
+ is
+ Loc : constant Source_Ptr := Sloc (Subp_Id);
+
+ procedure Insert_Stable_Property_Check
+ (Formal : Entity_Id; Property_Function : Entity_Id);
+ -- Build the pragma for one check and insert it in the tree.
+
+ function Make_Stable_Property_Condition
+ (Formal : Entity_Id; Property_Function : Entity_Id) return Node_Id;
+ -- Builds tree for "Func (Formal) = Func (Formal)'Old" expression.
+
+ function Stable_Properties
+ (Aspect_Bearer : Entity_Id; Negated : out Boolean)
+ return Subprogram_List;
+ -- If no aspect specified, then returns length-zero result.
+ -- Negated indicates that reserved word NOT was specified.
+
+ ----------------------------------
+ -- Insert_Stable_Property_Check --
+ ----------------------------------
+
+ procedure Insert_Stable_Property_Check
+ (Formal : Entity_Id; Property_Function : Entity_Id) is
+
+ Args : constant List_Id :=
+ New_List
+ (Make_Pragma_Argument_Association
+ (Sloc => Loc,
+ Expression =>
+ Make_Stable_Property_Condition
+ (Formal => Formal,
+ Property_Function => Property_Function)),
+ Make_Pragma_Argument_Association
+ (Sloc => Loc,
+ Expression =>
+ Make_String_Literal
+ (Sloc => Loc,
+ Strval =>
+ "failed stable property check at "
+ & Build_Location_String (Loc)
+ & " for parameter "
+ & To_String (Fully_Qualified_Name_String
+ (Formal, Append_NUL => False))
+ & " and property function "
+ & To_String (Fully_Qualified_Name_String
+ (Property_Function, Append_NUL => False))
+ )));
+
+ Prag : constant Node_Id :=
+ Make_Pragma (Loc,
+ Pragma_Identifier =>
+ Make_Identifier (Loc, Name_Postcondition),
+ Pragma_Argument_Associations => Args,
+ Class_Present => Class_Present);
+
+ Subp_Decl : Node_Id := Subp_Id;
+ begin
+ -- Enclosing_Declaration may return, for example,
+ -- a N_Procedure_Specification node. Cope with this.
+ loop
+ Subp_Decl := Enclosing_Declaration (Subp_Decl);
+ exit when Is_Declaration (Subp_Decl);
+ Subp_Decl := Parent (Subp_Decl);
+ pragma Assert (Present (Subp_Decl));
+ end loop;
+
+ Insert_After_And_Analyze (Subp_Decl, Prag);
+ end Insert_Stable_Property_Check;
+
+ ------------------------------------
+ -- Make_Stable_Property_Condition --
+ ------------------------------------
+
+ function Make_Stable_Property_Condition
+ (Formal : Entity_Id; Property_Function : Entity_Id) return Node_Id
+ is
+ function Call_Property_Function return Node_Id is
+ (Make_Function_Call
+ (Loc,
+ Name =>
+ New_Occurrence_Of (Property_Function, Loc),
+ Parameter_Associations =>
+ New_List (New_Occurrence_Of (Formal, Loc))));
+ begin
+ return Make_Op_Eq
+ (Loc,
+ Call_Property_Function,
+ Make_Attribute_Reference
+ (Loc,
+ Prefix => Call_Property_Function,
+ Attribute_Name => Name_Old));
+ end Make_Stable_Property_Condition;
+
+ -----------------------
+ -- Stable_Properties --
+ -----------------------
+
+ function Stable_Properties
+ (Aspect_Bearer : Entity_Id; Negated : out Boolean)
+ return Subprogram_List
+ is
+ Aspect_Spec : Node_Id :=
+ Find_Value_Of_Aspect
+ (Aspect_Bearer, Aspect_Stable_Properties,
+ Class_Present => Class_Present);
+ begin
+ -- ??? For a derived type, we wish Find_Value_Of_Aspect
+ -- somehow knew that this aspect is not inherited.
+ -- But it doesn't, so we cope with that here.
+ --
+ -- There are probably issues here with inheritance from
+ -- interface types, where just looking for the one parent type
+ -- isn't enough. But this is far from the only work needed for
+ -- Stable_Properties'Class for interface types.
+
+ if Is_Derived_Type (Aspect_Bearer) then
+ declare
+ Parent_Type : constant Entity_Id :=
+ Etype (Base_Type (Aspect_Bearer));
+ begin
+ if Aspect_Spec =
+ Find_Value_Of_Aspect
+ (Parent_Type, Aspect_Stable_Properties,
+ Class_Present => Class_Present)
+ then
+ -- prevent inheritance
+ Aspect_Spec := Empty;
+ end if;
+ end;
+ end if;
+
+ if No (Aspect_Spec) then
+ Negated := Aspect_Bearer = Subp_Id;
+ -- This is a little bit subtle.
+ -- We need to assign True in the Subp_Id case in order to
+ -- distinguish between no aspect spec at all vs. an
+ -- explicitly specified "with S_P => []" empty list.
+ -- In both cases Stable_Properties will return a length-0
+ -- array, but the two cases are not equivalent.
+ -- Very roughly speaking the lack of an S_P aspect spec for
+ -- a subprogram would be equivalent to something like
+ -- "with S_P => [not]", where we apply the "not" modifier to
+ -- an empty set of subprograms, if such a construct existed.
+ -- We could just assign True here, but it seems untidy to
+ -- return True in the case of an aspect spec for a type
+ -- (since negation is only allowed for subp S_P aspects).
+
+ return (1 .. 0 => <>);
+ else
+ return Parse_Aspect_Stable_Properties
+ (Aspect_Spec, Negated => Negated);
+ end if;
+ end Stable_Properties;
+
+ Formal : Entity_Id := First_Formal (Subp_Id);
+ Type_Of_Formal : Entity_Id;
+
+ Subp_Properties_Negated : Boolean;
+ Subp_Properties : constant Subprogram_List :=
+ Stable_Properties (Subp_Id, Subp_Properties_Negated);
+
+ -- start of processing for Add_Stable_Property_Contracts
+
+ begin
+ if not (Is_Primitive (Subp_Id) and then Comes_From_Source (Subp_Id))
+ then
+ return;
+ end if;
+
+ while Present (Formal) loop
+ Type_Of_Formal := Base_Type (Etype (Formal));
+
+ if not Subp_Properties_Negated then
+
+ for SPF_Id of Subp_Properties loop
+ if Type_Of_Formal = Base_Type (Etype (First_Formal (SPF_Id)))
+ and then Scope (Type_Of_Formal) = Scope (Subp_Id)
+ then
+ -- ??? Need to filter out checks for SPFs that are
+ -- mentioned explicitly in the postcondition of
+ -- Subp_Id.
+
+ Insert_Stable_Property_Check
+ (Formal => Formal, Property_Function => SPF_Id);
+ end if;
+ end loop;
+
+ elsif Scope (Type_Of_Formal) = Scope (Subp_Id) then
+ declare
+ Ignored : Boolean range False .. False;
+
+ Typ_Property_Funcs : constant Subprogram_List :=
+ Stable_Properties (Type_Of_Formal, Negated => Ignored);
+
+ function Excluded_By_Aspect_Spec_Of_Subp
+ (SPF_Id : Entity_Id) return Boolean;
+ -- Examine Subp_Properties to determine whether SPF should
+ -- be excluded.
+
+ -------------------------------------
+ -- Excluded_By_Aspect_Spec_Of_Subp --
+ -------------------------------------
+
+ function Excluded_By_Aspect_Spec_Of_Subp
+ (SPF_Id : Entity_Id) return Boolean is
+ begin
+ pragma Assert (Subp_Properties_Negated);
+ -- Look through renames for equality test here ???
+ return (for some F of Subp_Properties => F = SPF_Id);
+ end Excluded_By_Aspect_Spec_Of_Subp;
+
+ -- Look through renames for equality test here ???
+ Subp_Is_Stable_Property_Function : constant Boolean :=
+ (for some F of Typ_Property_Funcs => F = Subp_Id);
+ begin
+ if not Subp_Is_Stable_Property_Function then
+ for SPF_Id of Typ_Property_Funcs loop
+ if not Excluded_By_Aspect_Spec_Of_Subp (SPF_Id) then
+ -- ??? Need to filter out checks for SPFs that are
+ -- mentioned explicitly in the postcondition of
+ -- Subp_Id.
+ Insert_Stable_Property_Check
+ (Formal => Formal, Property_Function => SPF_Id);
+ end if;
+ end loop;
+ end if;
+ end;
+ end if;
+ Next_Formal (Formal);
+ end loop;
+ end Add_Stable_Property_Contracts;
+
-------------------------
-- Append_Enabled_Item --
-------------------------
@@ -1950,12 +2198,24 @@ package body Contracts is
Result : Entity_Id)
is
Loc : constant Source_Ptr := Sloc (Body_Decl);
+ Last_Decl : Node_Id;
Params : List_Id := No_List;
Proc_Bod : Node_Id;
Proc_Decl : Node_Id;
Proc_Id : Entity_Id;
Proc_Spec : Node_Id;
+ -- Extra declarations needed to handle interactions between
+ -- postconditions and finalization.
+
+ Postcond_Enabled_Decl : Node_Id;
+ Return_Success_Decl : Node_Id;
+ Result_Obj_Decl : Node_Id;
+ Result_Obj_Type_Decl : Node_Id;
+ Result_Obj_Type : Entity_Id;
+
+ -- Start of processing for Build_Postconditions_Procedure
+
begin
-- Nothing to do if there are no actions to check on exit
@@ -1963,6 +2223,29 @@ package body Contracts is
return;
end if;
+ -- Otherwise, we generate the postcondition procedure and add
+ -- associated objects and conditions used to coordinate postcondition
+ -- evaluation with finalization.
+
+ -- Generate:
+ --
+ -- procedure _postconditions (Return_Exp : Result_Typ);
+ --
+ -- -- Result_Obj_Type created when Result_Type is non-elementary
+ -- [type Result_Obj_Type is access all Result_Typ;]
+ --
+ -- Result_Obj : Result_Obj_Type;
+ --
+ -- Postcond_Enabled : Boolean := True;
+ -- Return_Success_For_Postcond : Boolean := False;
+ --
+ -- procedure _postconditions (Return_Exp : Result_Typ) is
+ -- begin
+ -- if Postcond_Enabled and then Return_Success_For_Postcond then
+ -- [stmts];
+ -- end if;
+ -- end;
+
Proc_Id := Make_Defining_Identifier (Loc, Name_uPostconditions);
Set_Debug_Info_Needed (Proc_Id);
Set_Postconditions_Proc (Subp_Id, Proc_Id);
@@ -2000,12 +2283,14 @@ package body Contracts is
-- body. This ensures that the body will not cause any premature
-- freezing, as it may mention types:
+ -- Generate:
+ --
-- procedure Proc (Obj : Array_Typ) is
-- procedure _postconditions is
-- begin
-- ... Obj ...
-- end _postconditions;
-
+ --
-- subtype T is Array_Typ (Obj'First (1) .. Obj'Last (1));
-- begin
@@ -2017,12 +2302,121 @@ package body Contracts is
Insert_Before_First_Source_Declaration
(Proc_Decl, Declarations (Body_Decl));
Analyze (Proc_Decl);
+ Last_Decl := Proc_Decl;
+
+ -- When Result is present (e.g. the postcondition checks apply to a
+ -- function) we make a local object to capture the result, so, if
+ -- needed, we can call the generated postconditions procedure during
+ -- finalization instead of at the point of return.
+
+ -- Note: The placement of the following declarations before the
+ -- declaration of the body of the postconditions, but after the
+ -- declaration of the postconditions spec is deliberate and required
+ -- since other code within the expander expects them to be located
+ -- here. Perhaps when more space is available in the tree this will
+ -- no longer be necessary ???
+
+ if Present (Result) then
+ -- Elementary result types mean a copy is cheap and preferred over
+ -- using pointers.
+
+ if Is_Elementary_Type (Etype (Result)) then
+ Result_Obj_Type := Etype (Result);
+
+ -- Otherwise, we create a named access type to capture the result
+
+ -- Generate:
+ --
+ -- type Result_Obj_Type is access all [Result_Type];
+
+ else
+ Result_Obj_Type := Make_Temporary (Loc, 'R');
+
+ Result_Obj_Type_Decl :=
+ Make_Full_Type_Declaration (Loc,
+ Defining_Identifier => Result_Obj_Type,
+ Type_Definition =>
+ Make_Access_To_Object_Definition (Loc,
+ All_Present => True,
+ Subtype_Indication => New_Occurrence_Of
+ (Etype (Result), Loc)));
+ Insert_After_And_Analyze (Proc_Decl, Result_Obj_Type_Decl);
+ Last_Decl := Result_Obj_Type_Decl;
+ end if;
+
+ -- Create the result obj declaration
+
+ -- Generate:
+ --
+ -- Result_Object_For_Postcond : Result_Obj_Type;
+
+ Result_Obj_Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier
+ (Loc, Name_uResult_Object_For_Postcond),
+ Object_Definition =>
+ New_Occurrence_Of
+ (Result_Obj_Type, Loc));
+ Set_No_Initialization (Result_Obj_Decl);
+ Insert_After_And_Analyze (Last_Decl, Result_Obj_Decl);
+ Last_Decl := Result_Obj_Decl;
+ end if;
+
+ -- Build the Postcond_Enabled flag used to delay evaluation of
+ -- postconditions until finalization has been performed when cleanup
+ -- actions are present.
+
+ -- Generate:
+ --
+ -- Postcond_Enabled : Boolean := True;
+
+ Postcond_Enabled_Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier
+ (Loc, Name_uPostcond_Enabled),
+ Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
+ Expression => New_Occurrence_Of (Standard_True, Loc));
+ Insert_After_And_Analyze (Last_Decl, Postcond_Enabled_Decl);
+ Last_Decl := Postcond_Enabled_Decl;
+
+ -- Create a flag to indicate that return has been reached
+
+ -- This is necessary for deciding whether to execute _postconditions
+ -- during finalization.
+
+ -- Generate:
+ --
+ -- Return_Success_For_Postcond : Boolean := False;
+
+ Return_Success_Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier
+ (Loc, Name_uReturn_Success_For_Postcond),
+ Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
+ Expression => New_Occurrence_Of (Standard_False, Loc));
+ Insert_After_And_Analyze (Last_Decl, Return_Success_Decl);
+ Last_Decl := Return_Success_Decl;
-- Set an explicit End_Label to override the sloc of the implicit
-- RETURN statement, and prevent it from inheriting the sloc of one
-- 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.
+
+ -- Generate:
+ --
+ -- procedure _postconditions is
+ -- begin
+ -- if Postcond_Enabled and then Return_Success_For_Postcond then
+ -- [Stmts];
+ -- end if;
+ -- end;
+
Proc_Bod :=
Make_Subprogram_Body (Loc,
Specification =>
@@ -2030,10 +2424,22 @@ package body Contracts is
Declarations => Empty_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
- Statements => Stmts,
- End_Label => Make_Identifier (Loc, Chars (Proc_Id))));
+ 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))));
+ Insert_After_And_Analyze (Last_Decl, Proc_Bod);
- Insert_After_And_Analyze (Proc_Decl, Proc_Bod);
end Build_Postconditions_Procedure;
----------------------------
@@ -2559,8 +2965,7 @@ package body Contracts is
Was_Expression_Function (Body_Decl)
and then Sloc (Body_Id) /= Sloc (Subp_Id)
and then In_Same_Source_Unit (Body_Id, Subp_Id)
- and then List_Containing (Body_Decl) /=
- List_Containing (Subp_Decl);
+ and then not In_Same_List (Body_Decl, Subp_Decl);
if Present (Items) then
Prag := Pre_Post_Conditions (Items);
@@ -2794,30 +3199,39 @@ package body Contracts is
-- Routine _Postconditions holds all contract assertions that must be
-- verified on exit from the related subprogram.
- -- Step 1: Handle all preconditions. This action must come before the
+ -- Step 1: augment contracts list with postconditions associated with
+ -- Stable_Properties and Stable_Properties'Class aspects. This must
+ -- precede Process_Postconditions.
+
+ for Class_Present in Boolean loop
+ Add_Stable_Property_Contracts
+ (Subp_Id, Class_Present => Class_Present);
+ end loop;
+
+ -- Step 2: Handle all preconditions. This action must come before the
-- processing of pragma Contract_Cases because the pragma prepends items
-- to the body declarations.
Process_Preconditions;
- -- Step 2: Handle all postconditions. This action must come before the
+ -- Step 3: Handle all postconditions. This action must come before the
-- processing of pragma Contract_Cases because the pragma appends items
-- to list Stmts.
Process_Postconditions (Stmts);
- -- Step 3: Handle pragma Contract_Cases. This action must come before
+ -- Step 4: Handle pragma Contract_Cases. This action must come before
-- the processing of invariants and predicates because those append
-- items to list Stmts.
Process_Contract_Cases (Stmts);
- -- Step 4: Apply invariant and predicate checks on a function result and
+ -- Step 5: Apply invariant and predicate checks on a function result and
-- all formals. The resulting checks are accumulated in list Stmts.
Add_Invariant_And_Predicate_Checks (Subp_Id, Stmts, Result);
- -- Step 5: Construct procedure _Postconditions
+ -- Step 6: Construct procedure _Postconditions
Build_Postconditions_Procedure (Subp_Id, Stmts, Result);
@@ -2833,7 +3247,10 @@ package body Contracts is
procedure Freeze_Previous_Contracts (Body_Decl : Node_Id) is
function Causes_Contract_Freezing (N : Node_Id) return Boolean;
pragma Inline (Causes_Contract_Freezing);
- -- Determine whether arbitrary node N causes contract freezing
+ -- Determine whether arbitrary node N causes contract freezing. This is
+ -- used as an assertion for the current body declaration that caused
+ -- contract freezing, and as a condition to detect body declaration that
+ -- already caused contract freezing before.
procedure Freeze_Contracts;
pragma Inline (Freeze_Contracts);
@@ -2851,9 +3268,17 @@ package body Contracts is
function Causes_Contract_Freezing (N : Node_Id) return Boolean is
begin
- return Nkind (N) in
- N_Entry_Body | N_Package_Body | N_Protected_Body |
- N_Subprogram_Body | N_Subprogram_Body_Stub | N_Task_Body;
+ -- The following condition matches guards for calls to
+ -- Freeze_Previous_Contracts from routines that analyze various body
+ -- declarations. In particular, it detects expression functions, as
+ -- described in the call from Analyze_Subprogram_Body_Helper.
+
+ return
+ Comes_From_Source (Original_Node (N))
+ and then
+ Nkind (N) in
+ N_Entry_Body | N_Package_Body | N_Protected_Body |
+ N_Subprogram_Body | N_Subprogram_Body_Stub | N_Task_Body;
end Causes_Contract_Freezing;
----------------------
@@ -3013,6 +3438,81 @@ package body Contracts is
Freeze_Contracts;
end Freeze_Previous_Contracts;
+ --------------------------
+ -- Get_Postcond_Enabled --
+ --------------------------
+
+ function Get_Postcond_Enabled (Subp : Entity_Id) return Node_Id is
+ Decl : Node_Id;
+ begin
+ Decl :=
+ Next (Unit_Declaration_Node (Postconditions_Proc (Subp)));
+ while Present (Decl) loop
+
+ if Nkind (Decl) = N_Object_Declaration
+ and then Chars (Defining_Identifier (Decl))
+ = Name_uPostcond_Enabled
+ then
+ return Defining_Identifier (Decl);
+ end if;
+
+ Next (Decl);
+ end loop;
+
+ return Empty;
+ end Get_Postcond_Enabled;
+
+ ------------------------------------
+ -- Get_Result_Object_For_Postcond --
+ ------------------------------------
+
+ function Get_Result_Object_For_Postcond
+ (Subp : Entity_Id) return Node_Id
+ is
+ Decl : Node_Id;
+ begin
+ Decl :=
+ Next (Unit_Declaration_Node (Postconditions_Proc (Subp)));
+ while Present (Decl) loop
+
+ if Nkind (Decl) = N_Object_Declaration
+ and then Chars (Defining_Identifier (Decl))
+ = Name_uResult_Object_For_Postcond
+ then
+ return Defining_Identifier (Decl);
+ end if;
+
+ Next (Decl);
+ end loop;
+
+ return Empty;
+ end Get_Result_Object_For_Postcond;
+
+ -------------------------------------
+ -- Get_Return_Success_For_Postcond --
+ -------------------------------------
+
+ function Get_Return_Success_For_Postcond (Subp : Entity_Id) return Node_Id
+ is
+ Decl : Node_Id;
+ begin
+ Decl :=
+ Next (Unit_Declaration_Node (Postconditions_Proc (Subp)));
+ while Present (Decl) loop
+
+ if Nkind (Decl) = N_Object_Declaration
+ and then Chars (Defining_Identifier (Decl))
+ = Name_uReturn_Success_For_Postcond
+ then
+ return Defining_Identifier (Decl);
+ end if;
+
+ Next (Decl);
+ end loop;
+
+ return Empty;
+ end Get_Return_Success_For_Postcond;
+
---------------------------------
-- Inherit_Subprogram_Contract --
---------------------------------
diff --git a/gcc/ada/contracts.ads b/gcc/ada/contracts.ads
index 4782ef5..b8a12ff 100644
--- a/gcc/ada/contracts.ads
+++ b/gcc/ada/contracts.ads
@@ -188,6 +188,21 @@ package Contracts is
-- denoted by Body_Decl. In addition, freeze the contract of the nearest
-- enclosing package body.
+ function Get_Postcond_Enabled (Subp : Entity_Id) return Entity_Id;
+ -- Get the defining identifier for a subprogram's Postcond_Enabled
+ -- object created during the expansion of the subprogram's postconditions.
+
+ function Get_Result_Object_For_Postcond (Subp : Entity_Id) return Entity_Id;
+ -- Get the defining identifier for a subprogram's
+ -- Result_Object_For_Postcond object created during the expansion of the
+ -- subprogram's postconditions.
+
+ function Get_Return_Success_For_Postcond
+ (Subp : Entity_Id) return Entity_Id;
+ -- Get the defining identifier for a subprogram's
+ -- Return_Success_For_Postcond object created during the expansion of the
+ -- subprogram's postconditions.
+
procedure Inherit_Subprogram_Contract
(Subp : Entity_Id;
From_Subp : Entity_Id);
diff --git a/gcc/ada/cstand.adb b/gcc/ada/cstand.adb
index fa335c1..3f5389c 100644
--- a/gcc/ada/cstand.adb
+++ b/gcc/ada/cstand.adb
@@ -1326,6 +1326,12 @@ package body CStand is
Set_Scope (Standard_Integer_64, Standard_Standard);
Build_Signed_Integer_Type (Standard_Integer_64, 64);
+ Standard_Integer_128 := New_Standard_Entity ("integer_128");
+ Decl := New_Node (N_Full_Type_Declaration, Stloc);
+ Set_Defining_Identifier (Decl, Standard_Integer_128);
+ Set_Scope (Standard_Integer_128, Standard_Standard);
+ Build_Signed_Integer_Type (Standard_Integer_128, 128);
+
-- Standard_*_Unsigned subtypes are not user visible, but they are
-- used internally. They are unsigned types with the same length as
-- the correspondingly named signed integer types.
@@ -2068,11 +2074,7 @@ package body CStand is
Build_Float_Type
(Ent, Pos (Digs), Float_Rep, Int (Size), Int (Alignment / 8));
- if No (Back_End_Float_Types) then
- Back_End_Float_Types := New_Elmt_List;
- end if;
-
- Append_Elmt (Ent, Back_End_Float_Types);
+ Append_New_Elmt (Ent, Back_End_Float_Types);
end Register_Float_Type;
----------------------
diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb
index f57b148..2c7c712 100644
--- a/gcc/ada/debug.adb
+++ b/gcc/ada/debug.adb
@@ -74,7 +74,7 @@ package body Debug is
-- dN No file name information in exception messages
-- dO Output immediate error messages
-- dP Do not check for controlled objects in preelaborable packages
- -- dQ Use old secondary stack method
+ -- dQ
-- dR Bypass check for correct version of s-rpc
-- dS Never convert numbers to machine numbers in Sem_Eval
-- dT Convert to machine numbers only for constant declarations
@@ -643,11 +643,6 @@ package body Debug is
-- in preelaborable packages, but this restriction is a huge pain,
-- especially in the predefined library units.
- -- dQ Use old method for determining what goes on the secondary stack.
- -- This disables some newer optimizations. The intent is to use this
- -- temporarily to measure before/after efficiency. ???Remove this
- -- when we are done (see Sem_Util.Requires_Transient_Scope).
-
-- dR Bypass the check for a proper version of s-rpc being present
-- to use the -gnatz? switch. This allows debugging of the use
-- of stubs generation without needing to have GLADE (or some
diff --git a/gcc/ada/doc/gnat_rm/implementation_defined_aspects.rst b/gcc/ada/doc/gnat_rm/implementation_defined_aspects.rst
index de5efea..6f39de6 100644
--- a/gcc/ada/doc/gnat_rm/implementation_defined_aspects.rst
+++ b/gcc/ada/doc/gnat_rm/implementation_defined_aspects.rst
@@ -566,7 +566,7 @@ Aspect Unreferenced
This boolean aspect is equivalent to :ref:`pragma Unreferenced<Pragma-Unreferenced>`.
-When using the ``-gnatX`` switch, this aspect is also supported on formal
+When using the ``-gnat2020`` 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 f98a427..f8d41ea 100644
--- a/gcc/ada/doc/gnat_rm/implementation_defined_attributes.rst
+++ b/gcc/ada/doc/gnat_rm/implementation_defined_attributes.rst
@@ -483,6 +483,19 @@ otherwise. The intended use of this attribute is in conjunction with generic
definitions. If the attribute is applied to a generic private type, it
indicates whether or not the corresponding actual type has discriminants.
+Attribute Has_Tagged_Values
+===========================
+.. index:: Tagged values, testing for
+
+.. index:: Has_Tagged_Values
+
+The prefix of the ``Has_Tagged_Values`` attribute is a type. The result is a
+Boolean value which is True if the type is a composite type (array or record)
+that is either a tagged type or has a subcomponent that is tagged, and is False
+otherwise. The intended use of this attribute is in conjunction with generic
+definitions. If the attribute is applied to a generic private type, it
+indicates whether or not the corresponding actual type has access values.
+
Attribute Img
=============
.. index:: Img
@@ -804,8 +817,6 @@ and is static. For non-scalar types, the result is nonstatic.
Attribute Pool_Address
======================
-.. index:: Parameters, when passed by reference
-
.. index:: Pool_Address
``X'Pool_Address`` for any object ``X`` returns the address
@@ -1129,6 +1140,26 @@ for compatibility with Ada 83. See
the Ada 83 reference manual for an exact description of the semantics of
this attribute when applied to floating-point types.
+Attribute Small_Denominator
+===========================
+.. index:: Small
+
+.. index:: Small_Denominator
+
+``typ'Small_Denominator`` for any fixed-point subtype `typ` yields the
+denominator in the representation of ``typ'Small`` as a rational number
+with coprime factors (i.e. as an irreducible fraction).
+
+Attribute Small_Numerator
+=========================
+.. index:: Small
+
+.. index:: Small_Numerator
+
+``typ'Small_Numerator`` for any fixed-point subtype `typ` yields the
+numerator in the representation of ``typ'Small`` as a rational number
+with coprime factors (i.e. as an irreducible fraction).
+
Attribute Storage_Unit
======================
.. index:: Storage_Unit
diff --git a/gcc/ada/doc/gnat_rm/implementation_defined_characteristics.rst b/gcc/ada/doc/gnat_rm/implementation_defined_characteristics.rst
index 71e1834..10fcfc9 100644
--- a/gcc/ada/doc/gnat_rm/implementation_defined_characteristics.rst
+++ b/gcc/ada/doc/gnat_rm/implementation_defined_characteristics.rst
@@ -147,19 +147,33 @@ Type Representation
*
"The small of an ordinary fixed point type. See 3.5.9(8)."
-``Fine_Delta`` is 2**(-63)
+The small is the largest power of two that does not exceed the delta.
*
"What combinations of small, range, and digits are
supported for fixed point types. See 3.5.9(10)."
-Any combinations are permitted that do not result in a small less than
-``Fine_Delta`` and do not result in a mantissa larger than 63 bits.
-If the mantissa is larger than 53 bits on machines where Long_Long_Float
-is 64 bits (true of all architectures except x86), then the output from
-Text_IO is accurate to only 53 bits, rather than the full mantissa. This
-is because floating-point conversions are used to convert fixed point.
-
+For an ordinary fixed point type, on 32-bit platforms, the small must lie in
+2.0**(-80) .. 2.0**80 and the range in -9.0E+36 .. 9.0E+36; any combination
+is permitted that does not result in a mantissa larger than 63 bits.
+
+On 64-bit platforms, the small must lie in 2.0**(-127) .. 2.0**127 and the
+range in -1.0E+76 .. 1.0E+76; any combination is permitted that does not
+result in a mantissa larger than 63 bits, and any combination is permitted
+that results in a mantissa between 64 and 127 bits if the small is the
+ratio of two integers that lie in 1 .. 2.0**127.
+
+If the small is the ratio of two integers with 64-bit magnitude on 32-bit
+platforms and 128-bit magnitude on 64-bit platforms, which is the case if
+no ``small`` clause is provided, then the operations of the fixed point
+type are entirely implemented by means of integer instructions. In the
+other cases, some operations, in particular input and output, may be
+implemented by means of floating-point instructions and may be affected
+by accuracy issues on architectures other than x86.
+
+For a decimal fixed point type, on 32-bit platforms, the small must lie in
+1.0E-18 .. 1.0E+18 and the digits in 1 .. 18. On 64-bit platforms, the
+small must lie in 1.0E-38 .. 1.0E+38 and the digits in 1 .. 38.
*
"The result of ``Tags.Expanded_Name`` for types declared
diff --git a/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst b/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst
index e1e6853..74b9718 100644
--- a/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst
+++ b/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst
@@ -434,15 +434,16 @@ Syntax::
ASSERTION_KIND ::= RM_ASSERTION_KIND | ID_ASSERTION_KIND
- RM_ASSERTION_KIND ::= Assert |
- Static_Predicate |
- Dynamic_Predicate |
- Pre |
- Pre'Class |
- Post |
- Post'Class |
- Type_Invariant |
- Type_Invariant'Class
+ RM_ASSERTION_KIND ::= Assert |
+ Static_Predicate |
+ Dynamic_Predicate |
+ Pre |
+ Pre'Class |
+ Post |
+ Post'Class |
+ Type_Invariant |
+ Type_Invariant'Class |
+ Default_Initial_Condition
ID_ASSERTION_KIND ::= Assertions |
Assert_And_Cut |
@@ -450,6 +451,7 @@ Syntax::
Contract_Cases |
Debug |
Ghost |
+ Initial_Condition |
Invariant |
Invariant'Class |
Loop_Invariant |
@@ -458,7 +460,8 @@ Syntax::
Precondition |
Predicate |
Refined_Post |
- Statement_Assertions
+ Statement_Assertions |
+ Subprogram_Variant
POLICY_IDENTIFIER ::= Check | Disable | Ignore | Suppressible
@@ -5079,7 +5082,7 @@ Syntax:
.. code-block:: ada
- pragma Profile (Ravenscar | Restricted | Rational |
+ pragma Profile (Ravenscar | Restricted | Rational | Jorvik |
GNAT_Extended_Ravenscar | GNAT_Ravenscar_EDF );
@@ -5087,10 +5090,12 @@ This pragma is standard in Ada 2005, but is available in all earlier
versions of Ada as an implementation-defined pragma. This is a
configuration pragma that establishes a set of configuration pragmas
that depend on the argument. ``Ravenscar`` is standard in Ada 2005.
+``Jorvik`` is standard in Ada 202x.
The other possibilities (``Restricted``, ``Rational``,
``GNAT_Extended_Ravenscar``, ``GNAT_Ravenscar_EDF``)
-are implementation-defined. The set of configuration pragmas
-is defined in the following sections.
+are implementation-defined. ``GNAT_Extended_Ravenscar`` is an alias for ``Jorvik``.
+
+The set of configuration pragmas is defined in the following sections.
* Pragma Profile (Ravenscar)
@@ -5160,7 +5165,7 @@ is defined in the following sections.
* ``Simple_Barriers``
The Ravenscar profile also includes the following restrictions that specify
- that there are no semantic dependences on the corresponding predefined
+ that there are no semantic dependencies on the corresponding predefined
packages:
* ``No_Dependence => Ada.Asynchronous_Task_Control``
@@ -5201,12 +5206,10 @@ is defined in the following sections.
automatically causes the use of a simplified,
more efficient version of the tasking run-time library.
-* Pragma Profile (GNAT_Extended_Ravenscar)
+* Pragma Profile (Jorvik)
- This profile corresponds to a GNAT specific extension of the
- Ravenscar profile. The profile may change in the future although
- only in a compatible way: some restrictions may be removed or
- relaxed. It is defined as a variation of the Ravenscar profile.
+ ``Jorvik`` is the new profile added to the Ada 202x draft standard,
+ previously implemented under the name ``GNAT_Extended_Ravenscar``.
The ``No_Implicit_Heap_Allocations`` restriction has been replaced
by ``No_Implicit_Task_Allocations`` and
@@ -5218,6 +5221,13 @@ is defined in the following sections.
The ``Max_Protected_Entries``, ``Max_Entry_Queue_Length``, and
``No_Relative_Delay`` restrictions have been removed.
+ Details on the rationale for ``Jorvik`` and implications for use may be
+ found in :title:`A New Ravenscar-Based Profile` by P. Rogers, J. Ruiz,
+ T. Gingold and P. Bernardi, in :title:`Reliable Software Technologies --
+ Ada Europe 2017`, Springer-Verlag Lecture Notes in Computer Science,
+ Number 10300.
+
+
* Pragma Profile (GNAT_Ravenscar_EDF)
This profile corresponds to the Ravenscar profile but using
@@ -6642,8 +6652,8 @@ expression. The following is an example of use within a package spec:
function Sqrt (Arg : Float) return Float;
pragma Test_Case (Name => "Test 1",
Mode => Nominal,
- Requires => Arg < 10000,
- Ensures => Sqrt'Result < 10);
+ Requires => Arg < 10000.0,
+ Ensures => Sqrt'Result < 10.0);
...
end Math_Functions;
diff --git a/gcc/ada/doc/gnat_rm/intrinsic_subprograms.rst b/gcc/ada/doc/gnat_rm/intrinsic_subprograms.rst
index bf9f0b9e..e448816 100644
--- a/gcc/ada/doc/gnat_rm/intrinsic_subprograms.rst
+++ b/gcc/ada/doc/gnat_rm/intrinsic_subprograms.rst
@@ -217,7 +217,9 @@ 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.
+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.
.. _Source_Location:
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 1dec487..82e992a 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
@@ -1517,6 +1517,13 @@ Alphabetical List of All Switches
an exception because ``Self(Obj)`` produces an anonymous object which does
not share the memory location of ``Obj``.
+.. index:: -gnateb (gcc)
+
+:switch:`-gnateb`
+ Store configuration files by their basename in ALI files. This switch is
+ used for instance by gprbuild for distributed builds in order to prevent
+ issues where machine-specific absolute paths could end up being stored in
+ ALI files.
.. index:: -gnatec (gcc)
@@ -3337,7 +3344,7 @@ of the pragma in the :title:`GNAT_Reference_manual`).
:switch:`-gnatw.K`
*Suppress warnings on redefinition of names in standard.*
- This switch activates warnings for declarations that declare a name that
+ This switch disables warnings for declarations that declare a name that
is defined in package Standard.
@@ -4807,7 +4814,8 @@ checks to be performed. The following checks are defined:
All keywords must be in lower case (with the exception of keywords
such as ``digits`` used as attribute names to which this check
- does not apply).
+ does not apply). A single error is reported for each line breaking
+ this rule even if multiple casing issues exist on a same line.
.. index:: -gnatyl (gcc)
@@ -6703,6 +6711,9 @@ be presented in subsequent sections.
Use the target-independent XDR protocol for stream oriented attributes
instead of the default implementation which is based on direct binary
representations and is therefore target-and endianness-dependent.
+ However it does not support 128-bit integer types and the exception
+ ``Ada.IO_Exceptions.Device_Error`` is raised if any attempt is made
+ at streaming 128-bit integer types with it.
.. index:: -Xnnn (gnatbind)
diff --git a/gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst b/gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst
index ba2c9b6..c4f186e 100644
--- a/gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst
+++ b/gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst
@@ -1840,7 +1840,7 @@ improves performance for your program.
.. _Floating_Point_Operations:
-Floating_Point_Operations
+Floating Point Operations
^^^^^^^^^^^^^^^^^^^^^^^^^
.. index:: Floating-Point Operations
diff --git a/gcc/ada/doc/gnat_ugn/gnat_utility_programs.rst b/gcc/ada/doc/gnat_ugn/gnat_utility_programs.rst
index 5c51222..f152ce3 100644
--- a/gcc/ada/doc/gnat_ugn/gnat_utility_programs.rst
+++ b/gcc/ada/doc/gnat_ugn/gnat_utility_programs.rst
@@ -1920,8 +1920,8 @@ building specialized scripts.
:switch:`--comments-fill`
- Fill comment blocks. This is the default.
- Use :switch:`--no-comments-fill` to turn off filling.
+ Fill comment blocks.
+ The default is :switch:`--no-comments-fill`.
:switch:`--comments-special`
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 2f0e10c..46d589a 100644
--- a/gcc/ada/doc/gnat_ugn/the_gnat_compilation_model.rst
+++ b/gcc/ada/doc/gnat_ugn/the_gnat_compilation_model.rst
@@ -1560,6 +1560,10 @@ temporary files that are immediately deleted; it doesn't make sense to
depend on a file that no longer exists. Such tools include
``gprbuild``, ``gnatmake``, and ``gnatcheck``.
+By default, configuration pragma files are stored by their absolute paths in
+ALI files. You can use the :switch:`-gnateb` switch in order to store them by
+their basename instead.
+
If you are using project file, a separate mechanism is provided using
project attributes.
diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb
index f39b3bc..8c401ca 100644
--- a/gcc/ada/einfo.adb
+++ b/gcc/ada/einfo.adb
@@ -2543,6 +2543,29 @@ package body Einfo is
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);
@@ -3040,7 +3063,7 @@ package body Einfo is
function Overridden_Operation (Id : E) return E is
begin
- pragma Assert (Is_Subprogram (Id) or else Is_Generic_Subprogram (Id));
+ pragma Assert (Is_Subprogram_Or_Generic_Subprogram (Id));
return Node26 (Id);
end Overridden_Operation;
@@ -3133,7 +3156,7 @@ package body Einfo is
function Protected_Body_Subprogram (Id : E) return E is
begin
- pragma Assert (Is_Subprogram (Id) or else Is_Entry (Id));
+ pragma Assert (Is_Subprogram_Or_Entry (Id));
return Node11 (Id);
end Protected_Body_Subprogram;
@@ -3202,7 +3225,8 @@ package body Einfo is
function Related_Expression (Id : E) return N is
begin
- pragma Assert (Ekind (Id) in Type_Kind | E_Constant | E_Variable);
+ pragma Assert
+ (Ekind (Id) in Type_Kind | E_Constant | E_Variable | E_Function);
return Node24 (Id);
end Related_Expression;
@@ -4914,7 +4938,7 @@ package body Einfo is
procedure Set_Has_Out_Or_In_Out_Parameter (Id : E; V : B := True) is
begin
pragma Assert
- (Ekind (Id) in E_Entry | E_Entry_Family
+ (Is_Entry (Id)
or else Is_Subprogram_Or_Generic_Subprogram (Id));
Set_Flag110 (Id, V);
end Set_Has_Out_Or_In_Out_Parameter;
@@ -6201,7 +6225,7 @@ package body Einfo is
procedure Set_No_Return (Id : E; V : B := True) is
begin
- pragma Assert (Is_Subprogram (Id) or else Is_Generic_Subprogram (Id));
+ pragma Assert (Is_Subprogram_Or_Generic_Subprogram (Id));
Set_Flag113 (Id, V);
end Set_No_Return;
@@ -6308,7 +6332,7 @@ package body Einfo is
procedure Set_Overridden_Operation (Id : E; V : E) is
begin
- pragma Assert (Is_Subprogram (Id) or else Is_Generic_Subprogram (Id));
+ pragma Assert (Is_Subprogram_Or_Generic_Subprogram (Id));
Set_Node26 (Id, V);
end Set_Overridden_Operation;
@@ -6406,7 +6430,7 @@ package body Einfo is
procedure Set_Protected_Body_Subprogram (Id : E; V : E) is
begin
- pragma Assert (Is_Subprogram (Id) or else Is_Entry (Id));
+ pragma Assert (Is_Subprogram_Or_Entry (Id));
Set_Node11 (Id, V);
end Set_Protected_Body_Subprogram;
@@ -6478,7 +6502,8 @@ package body Einfo is
procedure Set_Related_Expression (Id : E; V : N) is
begin
pragma Assert
- (Ekind (Id) in Type_Kind | E_Constant | E_Variable | E_Void);
+ (Ekind (Id) in
+ Type_Kind | E_Constant | E_Variable | E_Function | E_Void);
Set_Node24 (Id, V);
end Set_Related_Expression;
@@ -6777,7 +6802,9 @@ package body Einfo is
procedure Set_Stores_Attribute_Old_Prefix (Id : E; V : B := True) is
begin
- pragma Assert (Ekind (Id) = E_Constant);
+ pragma Assert (Is_Type (Id)
+ or else (Ekind (Id) in E_Constant
+ | E_Variable));
Set_Flag270 (Id, V);
end Set_Stores_Attribute_Old_Prefix;
@@ -7358,7 +7385,7 @@ package body Einfo is
---------------------
function Designated_Type (Id : E) return E is
- Desig_Type : E;
+ Desig_Type : Entity_Id;
begin
Desig_Type := Directly_Designated_Type (Id);
@@ -7399,7 +7426,13 @@ package body Einfo is
while Present (Subp_Elmt) loop
Subp_Id := Node (Subp_Elmt);
- if Is_DIC_Procedure (Subp_Id) then
+ -- 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;
@@ -7425,7 +7458,7 @@ package body Einfo is
---------------------
function First_Component (Id : E) return E is
- Comp_Id : E;
+ Comp_Id : Entity_Id;
begin
pragma Assert
@@ -7447,7 +7480,7 @@ package body Einfo is
-------------------------------------
function First_Component_Or_Discriminant (Id : E) return E is
- Comp_Id : E;
+ Comp_Id : Entity_Id;
begin
pragma Assert
@@ -7470,7 +7503,7 @@ package body Einfo is
------------------
function First_Formal (Id : E) return E is
- Formal : E;
+ Formal : Entity_Id;
begin
pragma Assert
@@ -7511,7 +7544,7 @@ package body Einfo is
------------------------------
function First_Formal_With_Extras (Id : E) return E is
- Formal : E;
+ Formal : Entity_Id;
begin
pragma Assert
@@ -8152,9 +8185,7 @@ package body Einfo is
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
+ 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
@@ -8173,10 +8204,9 @@ package body Einfo 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);
+ or else Is_Generic_Unit (Id)
+ or else Is_Subprogram_Or_Entry (Id)
+ or else Is_Task_Type (Id);
end Is_Elaboration_Target;
-----------------------
@@ -8307,21 +8337,10 @@ package body Einfo is
function Is_Standard_Character_Type (Id : E) return B is
begin
- if Is_Type (Id) then
- declare
- R : constant Entity_Id := Root_Type (Id);
- begin
- return
- R = Standard_Character
- or else
- R = Standard_Wide_Character
- or else
- R = Standard_Wide_Wide_Character;
- end;
-
- else
- return False;
- end if;
+ return Is_Type (Id)
+ and then Root_Type (Id) in Standard_Character
+ | Standard_Wide_Character
+ | Standard_Wide_Wide_Character;
end Is_Standard_Character_Type;
-----------------------------
@@ -8330,21 +8349,10 @@ package body Einfo is
function Is_Standard_String_Type (Id : E) return B is
begin
- if Is_Type (Id) then
- declare
- R : constant Entity_Id := Root_Type (Id);
- begin
- return
- R = Standard_String
- or else
- R = Standard_Wide_String
- or else
- R = Standard_Wide_Wide_String;
- end;
-
- else
- return False;
- end if;
+ return Is_Type (Id)
+ and then Root_Type (Id) in Standard_String
+ | Standard_Wide_String
+ | Standard_Wide_Wide_String;
end Is_Standard_String_Type;
--------------------
@@ -8435,7 +8443,7 @@ package body Einfo is
-----------------
function Last_Formal (Id : E) return E is
- Formal : E;
+ Formal : Entity_Id;
begin
pragma Assert
@@ -8452,7 +8460,7 @@ package body Einfo is
if Present (Formal) then
while Present (Next_Formal (Formal)) loop
- Formal := Next_Formal (Formal);
+ Next_Formal (Formal);
end loop;
end if;
@@ -8591,7 +8599,7 @@ package body Einfo is
--------------------
function Next_Component (Id : E) return E is
- Comp_Id : E;
+ Comp_Id : Entity_Id;
begin
Comp_Id := Next_Entity (Id);
@@ -8608,7 +8616,7 @@ package body Einfo is
------------------------------------
function Next_Component_Or_Discriminant (Id : E) return E is
- Comp_Id : E;
+ Comp_Id : Entity_Id;
begin
Comp_Id := Next_Entity (Id);
@@ -8667,7 +8675,7 @@ package body Einfo is
-----------------
function Next_Formal (Id : E) return E is
- P : E;
+ P : Entity_Id;
begin
-- Follow the chain of declared entities as long as the kind of the
@@ -8815,6 +8823,36 @@ package body Einfo is
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 --
---------------------------------
@@ -9131,7 +9169,7 @@ package body Einfo is
---------------
function Root_Type (Id : E) return E is
- T, Etyp : E;
+ T, Etyp : Entity_Id;
begin
pragma Assert (Nkind (Id) in N_Entity);
@@ -9294,8 +9332,6 @@ package body Einfo is
procedure Set_DIC_Procedure (Id : E; V : E) is
Base_Typ : Entity_Id;
- Subp_Elmt : Elmt_Id;
- Subp_Id : Entity_Id;
Subps : Elist_Id;
begin
@@ -9309,21 +9345,17 @@ package body Einfo is
Set_Subprograms_For_Type (Base_Typ, Subps);
end if;
- Subp_Elmt := First_Elmt (Subps);
Prepend_Elmt (V, Subps);
+ end Set_DIC_Procedure;
- -- Check for a duplicate default initial condition procedure
-
- while Present (Subp_Elmt) loop
- Subp_Id := Node (Subp_Elmt);
-
- if Is_DIC_Procedure (Subp_Id) then
- raise Program_Error;
- end if;
+ -------------------------------------
+ -- Set_Partial_Invariant_Procedure --
+ -------------------------------------
- Next_Elmt (Subp_Elmt);
- end loop;
- 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_Invariant_Procedure --
@@ -10122,7 +10154,7 @@ package body Einfo is
when Array_Kind =>
declare
- Index : E;
+ Index : Entity_Id;
begin
Write_Attribute
diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads
index be195ab..cc0c815 100644
--- a/gcc/ada/einfo.ads
+++ b/gcc/ada/einfo.ads
@@ -420,8 +420,10 @@ package Einfo is
-- output of certain warnings.
-- Aft_Value (synthesized)
--- Applies to fixed and decimal types. Computes a universal integer that
--- holds value of the Aft attribute for the type.
+-- Applies to fixed-point types and subtypes. This yields the value of
+-- the Aft attribute for the type, i.e. the number of decimal digits
+-- 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)
-- Defined in overloadable entities (literals, subprograms, entries) and
@@ -3930,6 +3932,20 @@ package Einfo is
-- of a single protected/task type, the references are examined as they
-- must appear only within the type defintion and the corresponding body.
+-- Partial_DIC_Procedure (synthesized)
+-- Defined in type entities. Set for a private type and its full view
+-- when the type is subject to pragma Default_Initial_Condition (DIC), or
+-- when the type inherits a DIC pragma from a parent type. Points to the
+-- entity of a procedure that takes a single argument of the given type
+-- and verifies the assertion expression of the DIC pragma at run time.
+-- When present, the Partial_DIC_Procedure of a type only checks DICs
+-- associated with the partial (private) view of the type, and is invoked
+-- by the full DIC_Procedure (which may check additional DICs associated
+-- with the full view).
+
+-- 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.
+
-- Partial_Invariant_Procedure (synthesized)
-- Defined in types and subtypes. Set for private types when one or more
-- [class-wide] type invariants apply to them. Points to the entity for a
@@ -4115,14 +4131,16 @@ package Einfo is
-- only for type-related error messages.
-- Related_Expression (Node24)
--- Defined in variables and types. 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
+-- 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
-- for generating clearer messages from CodePeer. It is used on source
-- entities that are variables in iterator specifications, to provide
-- a link to the container that is the domain of iteration. This allows
-- for better cross-reference information when the loop modifies elements
-- of the container, and suppresses spurious warnings.
+-- Finally this node is used on functions specified via the Real_Literal
+-- aspect, to denote the 2-parameter overloading, if found.
--
-- Shouldn't it also be used for the same purpose in errout? It seems
-- odd to have two mechanisms here???
@@ -4261,9 +4279,10 @@ package Einfo is
-- explicit range).
-- Scale_Value (Uint16)
--- Defined in decimal fixed-point types and subtypes. Contains the scale
--- for the type (i.e. the value of type'Scale = the number of decimal
--- digits after the decimal point).
+-- 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)
-- Defined in all entities. Points to the entity for the scope (block,
@@ -4484,8 +4503,8 @@ package Einfo is
-- stored discriminants for the record (sub)type.
-- Stores_Attribute_Old_Prefix (Flag270)
--- Defined in constants. Set when the constant has been generated to save
--- the value of attribute 'Old's 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]
-- Defined in all type entities. Indicates that the type is by-reference
@@ -4591,15 +4610,13 @@ package Einfo is
-- Applies to scalar types. Returns the tree node (Node_Id) that contains
-- the high bound of a scalar type. The returned value is literal for a
-- base type, but may be an expression in the case of scalar type with
--- dynamic bounds. Note that in the case of a fixed point type, the high
--- bound is in units of small, and is an integer.
+-- dynamic bounds.
-- Type_Low_Bound (synthesized)
-- Applies to scalar types. Returns the tree node (Node_Id) that contains
-- the low bound of a scalar type. The returned value is literal for a
-- base type, but may be an expression in the case of scalar type with
--- dynamic bounds. Note that in the case of a fixed point type, the low
--- bound is in units of small, and is an integer.
+-- dynamic bounds.
-- Underlying_Full_View (Node19)
-- Defined in private subtypes that are the completion of other private
@@ -5818,6 +5835,7 @@ package Einfo is
-- Is_Full_Access (synth)
-- Is_Controlled (synth)
-- Object_Size_Clause (synth)
+ -- Partial_DIC_Procedure (synth)
-- Partial_Invariant_Procedure (synth)
-- Predicate_Function (synth)
-- Predicate_Function_M (synth)
@@ -6583,6 +6601,7 @@ package Einfo is
-- 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)
@@ -7402,6 +7421,7 @@ package Einfo is
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;
@@ -8306,12 +8326,14 @@ package Einfo is
---------------------------------------------------
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);
diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb
index 049db89..cc291c6 100644
--- a/gcc/ada/errout.adb
+++ b/gcc/ada/errout.adb
@@ -337,7 +337,7 @@ package body Errout is
begin
-- Return if all errors are to be ignored
- if Errors_Must_Be_Ignored then
+ if Get_Ignore_Errors then
return;
end if;
@@ -612,6 +612,25 @@ package body Errout is
end;
end Error_Msg;
+ ----------------------------------
+ -- Error_Msg_Ada_2005_Extension --
+ ----------------------------------
+
+ procedure Error_Msg_Ada_2005_Extension (Extension : String) is
+ Loc : constant Source_Ptr := Token_Ptr;
+ begin
+ if Ada_Version < Ada_2005 then
+ Error_Msg (Extension & " is an Ada 2005 extension", Loc);
+
+ if No (Ada_Version_Pragma) then
+ Error_Msg ("\unit must be compiled with -gnat05 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_2005_Extension;
+
--------------------------------
-- Error_Msg_Ada_2012_Feature --
--------------------------------
@@ -1430,7 +1449,9 @@ package body Errout is
Last_Killed := True;
end if;
- Set_Posted (N);
+ if not Get_Ignore_Errors then
+ Set_Posted (N);
+ end if;
end Error_Msg_NEL;
------------------
diff --git a/gcc/ada/errout.ads b/gcc/ada/errout.ads
index e46433f..02cfdee 100644
--- a/gcc/ada/errout.ads
+++ b/gcc/ada/errout.ads
@@ -381,12 +381,11 @@ package Errout is
-- continuations are being gathered into a single message.
-- Insertion character | (Vertical bar: non-serious error)
- -- By default, error messages (other than warning messages) are
- -- considered to be fatal error messages which prevent expansion or
- -- generation of code in the presence of the -gnatQ switch. If the
- -- insertion character | appears, the message is considered to be
- -- non-serious, and does not cause Serious_Errors_Detected to be
- -- incremented (so expansion is not prevented by such a msg). This
+ -- By default, error messages (but not warning messages) are considered
+ -- to be fatal error messages, which prevent expansion and generation
+ -- of code. If the insertion character | appears, the message is
+ -- considered to be nonserious, and Serious_Errors_Detected is not
+ -- incremented, so expansion is not prevented by such a msg. This
-- insertion character is ignored in continuation messages.
-- Insertion character ~ (Tilde: insert string)
@@ -903,6 +902,11 @@ package Errout is
-- overridden interface primitive Iface_Prim) indicating wrong mode of the
-- first formal (RM 9.4(11.9/3)).
+ procedure Error_Msg_Ada_2005_Extension (Extension : String);
+ -- Analogous to Error_Msg_Ada_2012_Feature, but phrase the message using
+ -- "extension" and not "feature". This routine is only used in the parser,
+ -- so the error is always placed at the Token_Ptr.
+
procedure Error_Msg_Ada_2012_Feature (Feature : String; Loc : Source_Ptr);
-- If not operating in Ada 2012 mode or higher, posts errors complaining
-- that Feature is only supported in Ada 2012, with appropriate suggestions
diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb
index 469777f..d7e5470 100644
--- a/gcc/ada/exp_aggr.adb
+++ b/gcc/ada/exp_aggr.adb
@@ -1895,6 +1895,22 @@ package body Exp_Aggr is
Append_To (Stmts, Init_Call);
end if;
end if;
+
+ -- If Default_Initial_Condition applies to the component type,
+ -- add a DIC check after the component is default-initialized,
+ -- as well as after an Initialize procedure is called, in the
+ -- case of components of a controlled type. It will be analyzed
+ -- and resolved before the code for initialization of other
+ -- components.
+
+ -- Theoretically this might also be needed for cases where Expr
+ -- is not empty, but a default init still applies, such as for
+ -- Default_Value cases, in which case we won't get here. ???
+
+ if Has_DIC (Ctype) and then Present (DIC_Procedure (Ctype)) then
+ Append_To (Stmts,
+ Build_DIC_Call (Loc, New_Copy_Tree (Indexed_Comp), Ctype));
+ end if;
end if;
return Add_Loop_Actions (Stmts);
@@ -2448,18 +2464,30 @@ package body Exp_Aggr is
Next (Expr);
end loop;
- -- STEP 2 (b): Generate final loop if an others choice is present
+ -- STEP 2 (b): Generate final loop if an others choice is present.
-- Here Nb_Elements gives the offset of the last positional element.
if Present (Component_Associations (N)) then
Assoc := Last (Component_Associations (N));
- -- Ada 2005 (AI-287)
+ if Nkind (Assoc) = N_Iterated_Component_Association then
+ -- Ada 2020: 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.
- Append_List (Gen_While (Add (Nb_Elements, To => Aggr_L),
- Aggr_High,
- Get_Assoc_Expr (Assoc)), -- AI-287
- To => New_Code);
+ Append_List (Gen_Loop (Add (Nb_Elements + 1, To => Aggr_L),
+ Aggr_High,
+ Expression (Assoc)),
+ To => New_Code);
+ else
+ -- Ada 2005 (AI-287)
+
+ Append_List (Gen_While (Add (Nb_Elements, To => Aggr_L),
+ Aggr_High,
+ Get_Assoc_Expr (Assoc)),
+ To => New_Code);
+ end if;
end if;
end if;
@@ -3492,6 +3520,18 @@ package body Exp_Aggr is
then
Check_Ancestor_Discriminants (Entity (Ancestor));
end if;
+
+ -- If ancestor type has Default_Initialization_Condition,
+ -- add a DIC check after the ancestor object is initialized
+ -- by default.
+
+ if Has_DIC (Entity (Ancestor))
+ and then Present (DIC_Procedure (Entity (Ancestor)))
+ then
+ Append_To (L,
+ Build_DIC_Call
+ (Loc, New_Copy_Tree (Ref), Entity (Ancestor)));
+ end if;
end if;
-- Handle calls to C++ constructors
@@ -4097,6 +4137,22 @@ package body Exp_Aggr is
end;
end if;
+ -- If the component association was specified with a box and the
+ -- component type has a Default_Initial_Condition, then generate
+ -- a call to the DIC procedure.
+
+ if Has_DIC (Etype (Selector))
+ and then Was_Default_Init_Box_Association (Comp)
+ and then Present (DIC_Procedure (Etype (Selector)))
+ then
+ Append_To (L,
+ Build_DIC_Call (Loc,
+ Make_Selected_Component (Loc,
+ Prefix => New_Copy_Tree (Target),
+ Selector_Name => New_Occurrence_Of (Selector, Loc)),
+ Etype (Selector)));
+ end if;
+
Next (Comp);
end loop;
diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb
index d3468d5..7f63a2d 100644
--- a/gcc/ada/exp_attr.adb
+++ b/gcc/ada/exp_attr.adb
@@ -67,6 +67,7 @@ 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
@@ -1209,7 +1210,7 @@ package body Exp_Attr is
-- by Expand_Fpt_Attribute
procedure Expand_Fpt_Attribute_R (N : Node_Id) is
- E1 : constant Node_Id := First (Expressions (N));
+ E1 : constant Node_Id := First (Expressions (N));
Ftp : Entity_Id;
Pkg : RE_Id;
begin
@@ -1229,10 +1230,10 @@ package body Exp_Attr is
-- by Expand_Fpt_Attribute
procedure Expand_Fpt_Attribute_RI (N : Node_Id) is
- E1 : constant Node_Id := First (Expressions (N));
+ E1 : constant Node_Id := First (Expressions (N));
+ E2 : constant Node_Id := Next (E1);
Ftp : Entity_Id;
Pkg : RE_Id;
- E2 : constant Node_Id := Next (E1);
begin
Find_Fat_Info (Etype (E1), Ftp, Pkg);
Expand_Fpt_Attribute
@@ -2822,7 +2823,7 @@ package body Exp_Attr is
Id_Kind : constant Entity_Id := RTE (RO_AT_Task_Id);
Ent : constant Entity_Id := Entity (Pref);
Conctype : constant Entity_Id := Scope (Ent);
- Nest_Depth : Integer := 0;
+ Nest_Depth : Nat := 0;
Name : Node_Id;
S : Entity_Id;
@@ -2885,7 +2886,7 @@ package body Exp_Attr is
New_Occurrence_Of (RTE (RE_Task_Entry_Caller), Loc),
Parameter_Associations => New_List (
Make_Integer_Literal (Loc,
- Intval => Int (Nest_Depth))))));
+ Intval => Nest_Depth)))));
end if;
Analyze_And_Resolve (N, Id_Kind);
@@ -2923,8 +2924,6 @@ package body Exp_Attr is
when Attribute_Constrained => Constrained : declare
Formal_Ent : constant Entity_Id := Param_Entity (Pref);
- -- Start of processing for Constrained
-
begin
-- Reference to a parameter where the value is passed as an extra
-- actual, corresponding to the extra formal referenced by the
@@ -2938,7 +2937,7 @@ package body Exp_Attr is
then
Rewrite (N,
New_Occurrence_Of
- (Extra_Constrained (Formal_Ent), Sloc (N)));
+ (Extra_Constrained (Formal_Ent), Loc));
-- If the prefix is an access to object, the attribute applies to
-- the designated object, so rewrite with an explicit dereference.
@@ -2949,8 +2948,6 @@ package body Exp_Attr is
then
Rewrite (Pref,
Make_Explicit_Dereference (Loc, Relocate_Node (Pref)));
- Analyze_And_Resolve (N, Standard_Boolean);
- return;
-- For variables with a Extra_Constrained field, we use the
-- corresponding entity.
@@ -2961,7 +2958,7 @@ package body Exp_Attr is
then
Rewrite (N,
New_Occurrence_Of
- (Extra_Constrained (Entity (Pref)), Sloc (N)));
+ (Extra_Constrained (Entity (Pref)), Loc));
-- For all other cases, we can tell at compile time
@@ -2978,8 +2975,7 @@ package body Exp_Attr is
Rewrite (N,
New_Occurrence_Of
(Boolean_Literals
- (Exp_Util.Attribute_Constrained_Static_Value
- (Pref)), Sloc (N)));
+ (Exp_Util.Attribute_Constrained_Static_Value (Pref)), Loc));
end if;
Analyze_And_Resolve (N, Standard_Boolean);
@@ -2990,7 +2986,7 @@ package body Exp_Attr is
---------------
-- Transforms 'Copy_Sign into a call to the floating-point attribute
- -- function Copy_Sign in Fat_xxx (where xxx is the root type)
+ -- function Copy_Sign in Fat_xxx (where xxx is the root type).
when Attribute_Copy_Sign =>
Expand_Fpt_Attribute_RR (N);
@@ -3389,7 +3385,7 @@ package body Exp_Attr is
Size : Entity_Id;
- -- Start of Finalization_Size
+ -- Start of processing for Finalization_Size
begin
-- An object of a class-wide type first requires a runtime check to
@@ -3620,31 +3616,145 @@ package body Exp_Attr is
-- expands into
- -- Result_Type (System.Fore (Universal_Real (Type'First)),
- -- Universal_Real (Type'Last))
+ -- System.Fore_xx (ftyp (Typ'First), ftyp (Typ'Last) [,pm])
+
+ -- For decimal fixed-point types
+ -- xx = Decimal{32,64,128}
+ -- ftyp = Integer_{32,64,128}
+ -- pm = Typ'Scale
+
+ -- For the most common ordinary fixed-point types
+ -- xx = Fixed{32,64,128}
+ -- ftyp = Integer_{32,64,128}
+ -- pm = numerator of Typ'Small
+ -- denominator of Typ'Small
+ -- min (scale of Typ'Small, 0)
+
+ -- For other ordinary fixed-point types
+ -- xx = Real
+ -- ftyp = Universal_Real
+ -- pm = none
-- Note that we know that the type is a nonstatic subtype, or Fore would
- -- have itself been computed dynamically in Eval_Attribute.
+ -- have been computed statically in Eval_Attribute.
when Attribute_Fore =>
- Rewrite (N,
- Convert_To (Typ,
- Make_Function_Call (Loc,
- Name =>
- New_Occurrence_Of (RTE (RE_Fore), Loc),
+ declare
+ Arg_List : List_Id;
+ Fid : RE_Id;
+ Ftyp : Entity_Id;
- Parameter_Associations => New_List (
- Convert_To (Universal_Real,
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Ptyp, Loc),
- Attribute_Name => Name_First)),
+ begin
+ if Is_Decimal_Fixed_Point_Type (Ptyp) then
+ if Esize (Ptyp) <= 32 then
+ Fid := RE_Fore_Decimal32;
+ Ftyp := RTE (RE_Integer_32);
+ elsif Esize (Ptyp) <= 64 then
+ Fid := RE_Fore_Decimal64;
+ Ftyp := RTE (RE_Integer_64);
+ else
+ Fid := RE_Fore_Decimal128;
+ Ftyp := RTE (RE_Integer_128);
+ end if;
- Convert_To (Universal_Real,
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Ptyp, Loc),
- Attribute_Name => Name_Last))))));
+ else
+ declare
+ Num : constant Uint := Norm_Num (Small_Value (Ptyp));
+ Den : constant Uint := Norm_Den (Small_Value (Ptyp));
+ Max : constant Uint := UI_Max (Num, Den);
+ Min : constant Uint := UI_Min (Num, Den);
+ Siz : constant Uint := Esize (Ptyp);
- Analyze_And_Resolve (N, Typ);
+ begin
+ if Siz <= 32
+ and then Max <= Uint_2 ** 31
+ and then (Min = Uint_1
+ or else Num < Den
+ or else Num < Uint_10 ** 8)
+ then
+ Fid := RE_Fore_Fixed32;
+ Ftyp := RTE (RE_Integer_32);
+ elsif Siz <= 64
+ and then Max <= Uint_2 ** 63
+ and then (Min = Uint_1
+ or else Num < Den
+ or else Num < Uint_10 ** 17)
+ then
+ Fid := RE_Fore_Fixed64;
+ Ftyp := RTE (RE_Integer_64);
+ elsif System_Max_Integer_Size = 128
+ and then Max <= Uint_2 ** 127
+ and then (Min = Uint_1
+ or else Num < Den
+ or else Num < Uint_10 ** 37)
+ then
+ Fid := RE_Fore_Fixed128;
+ Ftyp := RTE (RE_Integer_128);
+ else
+ Fid := RE_Fore_Real;
+ Ftyp := Universal_Real;
+ end if;
+ end;
+ end if;
+
+ Arg_List := New_List (
+ Convert_To (Ftyp,
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Ptyp, Loc),
+ Attribute_Name => Name_First)));
+
+ Append_To (Arg_List,
+ Convert_To (Ftyp,
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Ptyp, Loc),
+ Attribute_Name => Name_Last)));
+
+ -- For decimal, append Scale and also set to do literal conversion
+
+ if Is_Decimal_Fixed_Point_Type (Ptyp) then
+ Set_Conversion_OK (First (Arg_List));
+ Set_Conversion_OK (Next (First (Arg_List)));
+
+ Append_To (Arg_List,
+ Make_Integer_Literal (Loc, Scale_Value (Ptyp)));
+
+ -- For ordinary fixed-point types, append Num, Den and Scale
+ -- parameters and also set to do literal conversion
+
+ elsif Fid /= RE_Fore_Real then
+ Set_Conversion_OK (First (Arg_List));
+ Set_Conversion_OK (Next (First (Arg_List)));
+
+ Append_To (Arg_List,
+ Make_Integer_Literal (Loc, -Norm_Num (Small_Value (Ptyp))));
+
+ Append_To (Arg_List,
+ Make_Integer_Literal (Loc, -Norm_Den (Small_Value (Ptyp))));
+
+ declare
+ Val : Ureal := Small_Value (Ptyp);
+ Scale : Int := 0;
+
+ begin
+ while Val >= Ureal_10 loop
+ Val := Val / Ureal_10;
+ Scale := Scale - 1;
+ end loop;
+
+ Append_To (Arg_List,
+ Make_Integer_Literal (Loc, UI_From_Int (Scale)));
+ end;
+ end if;
+
+ Rewrite (N,
+ Convert_To (Typ,
+ Make_Function_Call (Loc,
+ Name =>
+ New_Occurrence_Of (RTE (Fid), Loc),
+ Parameter_Associations => Arg_List)));
+
+ Analyze_And_Resolve (N, Typ);
+ end;
--------------
-- Fraction --
@@ -4240,7 +4350,7 @@ package body Exp_Attr is
begin
-- Processing for packed array types
- if Is_Array_Type (Ptyp) and then Is_Packed (Ptyp) then
+ if Is_Packed_Array (Ptyp) then
Ityp := Get_Index_Subtype (N);
-- If the index type, Ityp, is an enumeration type with holes,
@@ -4338,7 +4448,7 @@ package body Exp_Attr is
Xtyp : Entity_Id;
begin
- if Is_Array_Type (Dtyp) and then Is_Packed (Dtyp) then
+ if Is_Packed_Array (Dtyp) then
Xtyp := Get_Index_Subtype (N);
Rewrite (N,
@@ -4592,13 +4702,15 @@ package body Exp_Attr is
when Attribute_Mod => Mod_Case : declare
Arg : constant Node_Id := Relocate_Node (First (Exprs));
- Hi : constant Node_Id := Type_High_Bound (Etype (Arg));
+ Hi : constant Node_Id := Type_High_Bound (Base_Type (Etype (Arg)));
Modv : constant Uint := Modulus (Btyp);
begin
-- This is not so simple. The issue is what type to use for the
- -- computation of the modular value.
+ -- computation of the modular value. In addition we need to use
+ -- the base type as above to retrieve a static bound for the
+ -- comparisons that follow.
-- The easy case is when the modulus value is within the bounds
-- of the signed integer type of the argument. In this case we can
@@ -5717,14 +5829,14 @@ package body Exp_Attr is
when Attribute_Reduce =>
declare
- Loc : constant Source_Ptr := Sloc (N);
- E1 : constant Node_Id := First (Expressions (N));
- E2 : constant Node_Id := Next (E1);
- Bnn : constant Entity_Id := Make_Temporary (Loc, 'B', N);
- Typ : constant Entity_Id := Etype (N);
+ Loc : constant Source_Ptr := Sloc (N);
+ E1 : constant Node_Id := First (Expressions (N));
+ E2 : constant Node_Id := Next (E1);
+ Bnn : constant Entity_Id := Make_Temporary (Loc, 'B', N);
+ Typ : constant Entity_Id := Etype (N);
New_Loop : Node_Id;
- Stat : Node_Id;
+ Stat : Node_Id;
function Build_Stat (Comp : Node_Id) return Node_Id;
-- The reducer can be a function, a procedure whose first
@@ -5739,14 +5851,14 @@ package body Exp_Attr is
function Build_Stat (Comp : Node_Id) return Node_Id is
begin
if Nkind (E1) = N_Attribute_Reference then
- Stat := Make_Assignment_Statement (Loc,
- Name => New_Occurrence_Of (Bnn, Loc),
- Expression => Make_Attribute_Reference (Loc,
- Attribute_Name => Attribute_Name (E1),
- Prefix => New_Copy (Prefix (E1)),
- Expressions => New_List (
- New_Occurrence_Of (Bnn, Loc),
- Comp)));
+ Stat := Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Bnn, Loc),
+ Expression => Make_Attribute_Reference (Loc,
+ Attribute_Name => Attribute_Name (E1),
+ Prefix => New_Copy (Prefix (E1)),
+ Expressions => New_List (
+ New_Occurrence_Of (Bnn, Loc),
+ Comp)));
elsif Ekind (Entity (E1)) = E_Procedure then
Stat := Make_Procedure_Call_Statement (Loc,
@@ -5755,13 +5867,13 @@ package body Exp_Attr is
New_Occurrence_Of (Bnn, Loc),
Comp));
else
- Stat := Make_Assignment_Statement (Loc,
- Name => New_Occurrence_Of (Bnn, Loc),
- Expression => Make_Function_Call (Loc,
- Name => New_Occurrence_Of (Entity (E1), Loc),
- Parameter_Associations => New_List (
- New_Occurrence_Of (Bnn, Loc),
- Comp)));
+ Stat := Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Bnn, Loc),
+ Expression => Make_Function_Call (Loc,
+ Name => New_Occurrence_Of (Entity (E1), Loc),
+ Parameter_Associations => New_List (
+ New_Occurrence_Of (Bnn, Loc),
+ Comp)));
end if;
return Stat;
@@ -5769,9 +5881,8 @@ package body Exp_Attr is
-- If the prefix is an aggregate, its unique component is an
-- Iterated_Element, and we create a loop out of its iterator.
- -- The iterated_component_Association is parsed as a loop
- -- parameter specification with "in" or as a container
- -- iterator with "of".
+ -- The iterated_component_association is parsed as a loop parameter
+ -- specification with "in" or as a container iterator with "of".
begin
if Nkind (Prefix (N)) = N_Aggregate then
@@ -6085,20 +6196,19 @@ package body Exp_Attr is
-- Round --
-----------
- -- The handling of the Round attribute is quite delicate. The processing
- -- in Sem_Attr introduced a conversion to universal real, reflecting the
- -- semantics of Round, but we do not want anything to do with universal
- -- real at runtime, since this corresponds to using floating-point
- -- arithmetic.
+ -- The handling of the Round attribute is delicate when the operand is
+ -- universal fixed. In this case, the processing in Sem_Attr introduced
+ -- a conversion to universal real, reflecting the semantics of Round,
+ -- but we do not want anything to do with universal real at run time,
+ -- since this corresponds to using floating-point arithmetic.
-- What we have now is that the Etype of the Round attribute correctly
-- indicates the final result type. The operand of the Round is the
-- conversion to universal real, described above, and the operand of
-- this conversion is the actual operand of Round, which may be the
- -- special case of a fixed point multiplication or division (Etype =
- -- universal fixed)
+ -- special case of a fixed point multiplication or division.
- -- The exapander will expand first the operand of the conversion, then
+ -- The expander will expand first the operand of the conversion, then
-- the conversion, and finally the round attribute itself, since we
-- always work inside out. But we cannot simply process naively in this
-- order. In the semantic world where universal fixed and real really
@@ -6106,14 +6216,13 @@ package body Exp_Attr is
-- implementation world, where universal real is a floating-point type,
-- we would get the wrong result.
- -- So the approach is as follows. First, when expanding a multiply or
- -- divide whose type is universal fixed, we do nothing at all, instead
- -- deferring the operation till later.
-
- -- The actual processing is done in Expand_N_Type_Conversion which
- -- handles the special case of Round by looking at its parent to see if
- -- it is a Round attribute, and if it is, handling the conversion (or
- -- its fixed multiply/divide child) in an appropriate manner.
+ -- So the approach is as follows. When expanding a multiply or divide
+ -- whose type is universal fixed, Fixup_Universal_Fixed_Operation will
+ -- look up and skip the conversion to universal real if its parent is
+ -- a Round attribute, taking information from this attribute node. In
+ -- the other cases, Expand_N_Type_Conversion does the same by looking
+ -- at its parent to see if it is a Round attribute, before calling the
+ -- fixed-point expansion routine.
-- This means that by the time we get to expanding the Round attribute
-- itself, the Round is nothing more than a type conversion (and will
@@ -6121,8 +6230,12 @@ package body Exp_Attr is
-- appropriate conversion operation.
when Attribute_Round =>
- Rewrite (N,
- Convert_To (Etype (N), Relocate_Node (First (Exprs))));
+ if Etype (First (Exprs)) = Etype (N) then
+ Rewrite (N, Relocate_Node (First (Exprs)));
+ else
+ Rewrite (N, Convert_To (Etype (N), First (Exprs)));
+ Set_Rounded_Result (N);
+ end if;
Analyze_And_Resolve (N);
--------------
@@ -6229,7 +6342,7 @@ package body Exp_Attr is
then
Set_Attribute_Name (N, Name_Object_Size);
- -- In all other cases, Size and VADS_Size are the sane
+ -- In all other cases, Size and VADS_Size are the same
else
Set_Attribute_Name (N, Name_Size);
@@ -6293,7 +6406,7 @@ package body Exp_Attr is
------------------
when Attribute_Storage_Size => Storage_Size : declare
- Alloc_Op : Entity_Id := Empty;
+ Alloc_Op : Entity_Id := Empty;
begin
@@ -6714,7 +6827,7 @@ package body Exp_Attr is
------------
when Attribute_To_Any => To_Any : declare
- Decls : constant List_Id := New_List;
+ Decls : constant List_Id := New_List;
begin
Rewrite (N,
Build_To_Any_Call
@@ -6743,7 +6856,7 @@ package body Exp_Attr is
--------------
when Attribute_TypeCode => TypeCode : declare
- Decls : constant List_Id := New_List;
+ Decls : constant List_Id := New_List;
begin
Rewrite (N, Build_TypeCode_Call (Loc, Ptyp, Decls));
Insert_Actions (N, Decls);
@@ -7671,7 +7784,7 @@ package body Exp_Attr is
-- The following attributes should not appear at this stage, since they
-- have already been handled by the analyzer (and properly rewritten
- -- with corresponding values or entities to represent the right values)
+ -- with corresponding values or entities to represent the right values).
when Attribute_Abort_Signal
| Attribute_Address_Size
@@ -7725,6 +7838,8 @@ package body Exp_Attr is
| Attribute_Scale
| Attribute_Signed_Zeros
| Attribute_Small
+ | Attribute_Small_Denominator
+ | Attribute_Small_Numerator
| Attribute_Storage_Unit
| Attribute_Stub_Type
| Attribute_System_Allocator_Alignment
@@ -7802,17 +7917,17 @@ package body Exp_Attr is
---------------------------
procedure Expand_Size_Attribute (N : Node_Id) is
- Loc : constant Source_Ptr := Sloc (N);
- Typ : constant Entity_Id := Etype (N);
- Pref : constant Node_Id := Prefix (N);
- Ptyp : constant Entity_Id := Etype (Pref);
- Id : constant Attribute_Id := Get_Attribute_Id (Attribute_Name (N));
- Siz : Uint;
+ Loc : constant Source_Ptr := Sloc (N);
+ Typ : constant Entity_Id := Etype (N);
+ Pref : constant Node_Id := Prefix (N);
+ Ptyp : constant Entity_Id := Etype (Pref);
+ Id : constant Attribute_Id := Get_Attribute_Id (Attribute_Name (N));
+ Siz : Uint;
begin
-- Case of known RM_Size of a type
- if (Id = Attribute_Size or else Id = Attribute_Value_Size)
+ if Id in Attribute_Size | Attribute_Value_Size
and then Is_Entity_Name (Pref)
and then Is_Type (Entity (Pref))
and then Known_Static_RM_Size (Entity (Pref))
@@ -7874,8 +7989,7 @@ package body Exp_Attr is
if Is_Entity_Name (Pref)
and then Is_Formal (Entity (Pref))
- and then Is_Array_Type (Ptyp)
- and then Is_Packed (Ptyp)
+ and then Is_Packed_Array (Ptyp)
then
Rewrite (N,
Make_Attribute_Reference (Loc,
@@ -7889,9 +8003,8 @@ package body Exp_Attr is
-- type, but also a hint to the actual constrained type.
elsif Nkind (Pref) = N_Explicit_Dereference
- and then Is_Array_Type (Ptyp)
+ and then Is_Packed_Array (Ptyp)
and then not Is_Constrained (Ptyp)
- and then Is_Packed (Ptyp)
then
Set_Actual_Designated_Subtype (Pref, Get_Actual_Subtype (Pref));
@@ -8164,6 +8277,9 @@ package body Exp_Attr is
while Present (Comp) loop
if Nkind (Comp) = N_Range then
Process_Range_Update (Temp, Comp, Expr, Typ);
+ elsif Nkind (Comp) = N_Subtype_Indication then
+ Process_Range_Update
+ (Temp, Range_Expression (Constraint (Comp)), Expr, Typ);
else
Process_Component_Or_Element_Update (Temp, Comp, Expr, Typ);
end if;
@@ -8195,27 +8311,25 @@ package body Exp_Attr is
-- All we do is use the root type (historically this dealt with
-- VAX-float .. to be cleaned up further later ???)
- Fat_Type := Rtyp;
-
- if Fat_Type = Standard_Short_Float then
- Fat_Pkg := RE_Attr_Short_Float;
+ if Rtyp = Standard_Short_Float or else Rtyp = Standard_Float then
+ Fat_Type := Standard_Float;
+ Fat_Pkg := RE_Attr_Float;
- elsif Fat_Type = Standard_Float then
- Fat_Pkg := RE_Attr_Float;
+ elsif Rtyp = Standard_Long_Float then
+ Fat_Type := Standard_Long_Float;
+ Fat_Pkg := RE_Attr_Long_Float;
- elsif Fat_Type = Standard_Long_Float then
- Fat_Pkg := RE_Attr_Long_Float;
-
- elsif Fat_Type = Standard_Long_Long_Float then
- Fat_Pkg := RE_Attr_Long_Long_Float;
+ elsif Rtyp = Standard_Long_Long_Float then
+ Fat_Type := Standard_Long_Long_Float;
+ Fat_Pkg := RE_Attr_Long_Long_Float;
-- Universal real (which is its own root type) is treated as being
-- equivalent to Standard.Long_Long_Float, since it is defined to
-- have the same precision as the longest Float type.
- elsif Fat_Type = Universal_Real then
+ elsif Rtyp = Universal_Real then
Fat_Type := Standard_Long_Long_Float;
- Fat_Pkg := RE_Attr_Long_Long_Float;
+ Fat_Pkg := RE_Attr_Long_Long_Float;
else
raise Program_Error;
diff --git a/gcc/ada/exp_ch11.adb b/gcc/ada/exp_ch11.adb
index abc91a2..a501bf1 100644
--- a/gcc/ada/exp_ch11.adb
+++ b/gcc/ada/exp_ch11.adb
@@ -189,7 +189,6 @@ package body Exp_Ch11 is
Handlrs : constant List_Id := Exception_Handlers (HSS);
Loc : constant Source_Ptr := Sloc (HSS);
Handler : Node_Id;
- Others_Choice : Boolean;
Obj_Decl : Node_Id;
Next_Handler : Node_Id;
@@ -197,12 +196,6 @@ package body Exp_Ch11 is
-- This procedure handles the expansion of exception handlers for the
-- optimization of local raise statements into goto statements.
- procedure Prepend_Call_To_Handler
- (Proc : RE_Id;
- Args : List_Id := No_List);
- -- Routine to prepend a call to the procedure referenced by Proc at
- -- the start of the handler code for the current Handler.
-
procedure Replace_Raise_By_Goto (Raise_S : Node_Id; Goto_L1 : Node_Id);
-- Raise_S is a raise statement (possibly expanded, and possibly of the
-- form of a Raise_xxx_Error node with a condition. This procedure is
@@ -850,36 +843,6 @@ package body Exp_Ch11 is
end;
end Expand_Local_Exception_Handlers;
- -----------------------------
- -- Prepend_Call_To_Handler --
- -----------------------------
-
- procedure Prepend_Call_To_Handler
- (Proc : RE_Id;
- Args : List_Id := No_List)
- is
- Ent : constant Entity_Id := RTE (Proc);
-
- begin
- -- If we have no Entity, then we are probably in no run time mode or
- -- some weird error has occurred. In either case do nothing. Note use
- -- of No_Location to hide this code from the debugger, so single
- -- stepping doesn't jump back and forth.
-
- if Present (Ent) then
- declare
- Call : constant Node_Id :=
- Make_Procedure_Call_Statement (No_Location,
- Name => New_Occurrence_Of (RTE (Proc), No_Location),
- Parameter_Associations => Args);
-
- begin
- Prepend_To (Statements (Handler), Call);
- Analyze (Call, Suppress => All_Checks);
- end;
- end if;
- end Prepend_Call_To_Handler;
-
---------------------------
-- Replace_Raise_By_Goto --
---------------------------
@@ -1089,44 +1052,6 @@ package body Exp_Ch11 is
(Statements (Handler), Suppress => All_Checks);
end;
end if;
-
- -- For the normal case, we have to worry about the state of
- -- abort deferral. Generally, we defer abort during runtime
- -- handling of exceptions. When control is passed to the
- -- handler, then in the normal case we undefer aborts. In
- -- any case this entire handling is relevant only if aborts
- -- are allowed.
-
- if Abort_Allowed
- and then not ZCX_Exceptions
- then
- -- There are some special cases in which we do not do the
- -- undefer. In particular a finalization (AT END) handler
- -- wants to operate with aborts still deferred.
-
- -- We also suppress the call if this is the special handler
- -- for Abort_Signal, since if we are aborting, we want to
- -- keep aborts deferred (one abort is enough).
-
- -- If abort really needs to be deferred the expander must
- -- add this call explicitly, see
- -- Expand_N_Asynchronous_Select.
-
- Others_Choice :=
- Nkind (First (Exception_Choices (Handler))) =
- N_Others_Choice;
-
- if (Others_Choice
- or else Entity (First (Exception_Choices (Handler))) /=
- Stand.Abort_Signal)
- and then not
- (Others_Choice
- and then
- All_Others (First (Exception_Choices (Handler))))
- then
- Prepend_Call_To_Handler (RE_Abort_Undefer);
- end if;
- end if;
end if;
end if;
@@ -1553,7 +1478,7 @@ package body Exp_Ch11 is
begin
-- Processing for locally handled exception (exclude reraise case)
- if Present (Name (N)) and then Nkind (Name (N)) = N_Identifier then
+ if Present (Name (N)) and then Is_Entity_Name (Name (N)) then
if Debug_Flag_Dot_G
or else Restriction_Active (No_Exception_Propagation)
then
@@ -1657,7 +1582,7 @@ package body Exp_Ch11 is
-- but this is also faster in all modes). Propagate Comes_From_Source
-- flag to the new node.
- if Present (Name (N)) and then Nkind (Name (N)) = N_Identifier then
+ if Present (Name (N)) and then Is_Entity_Name (Name (N)) then
Src := Comes_From_Source (N);
if Entity (Name (N)) = Standard_Constraint_Error then
@@ -1689,7 +1614,7 @@ package body Exp_Ch11 is
-- where location_string identifies the file/line of the raise
- if Present (Name (N)) then
+ if Present (Name (N)) and then Is_Entity_Name (Name (N)) then
declare
Id : Entity_Id := Entity (Name (N));
Buf : Bounded_String;
@@ -1939,8 +1864,8 @@ package body Exp_Ch11 is
then
return Empty;
- -- Test for handled sequence of statements with at least one
- -- exception handler which might be the one we are looking for.
+ -- Test for handled sequence of statements with at least one
+ -- exception handler which might be the one we are looking for.
elsif Nkind (P) = N_Handled_Sequence_Of_Statements
and then Present (Exception_Handlers (P))
diff --git a/gcc/ada/exp_ch13.adb b/gcc/ada/exp_ch13.adb
index 30f101d..89efca9 100644
--- a/gcc/ada/exp_ch13.adb
+++ b/gcc/ada/exp_ch13.adb
@@ -582,9 +582,8 @@ package body Exp_Ch13 is
Install_Visible_Declarations (E_Scope);
end if;
- if Is_Package_Or_Generic_Package (E_Scope) or else
- Is_Protected_Type (E_Scope) or else
- Is_Task_Type (E_Scope)
+ if Is_Concurrent_Type (E_Scope)
+ or else Is_Package_Or_Generic_Package (E_Scope)
then
Install_Private_Declarations (E_Scope);
end if;
diff --git a/gcc/ada/exp_ch2.adb b/gcc/ada/exp_ch2.adb
index 5c3435b..6c41e08 100644
--- a/gcc/ada/exp_ch2.adb
+++ b/gcc/ada/exp_ch2.adb
@@ -338,8 +338,43 @@ package body Exp_Ch2 is
-----------------------------
procedure Expand_Entity_Reference (N : Node_Id) is
+
+ function Is_Object_Renaming_Name (N : Node_Id) return Boolean;
+ -- Indicates that N occurs (after accounting for qualified expressions
+ -- and type conversions) as the name of an object renaming declaration.
+ -- We don't want to fold values in that case.
+
+ -----------------------------
+ -- Is_Object_Renaming_Name --
+ -----------------------------
+
+ function Is_Object_Renaming_Name (N : Node_Id) return Boolean is
+ Trailer : Node_Id := N;
+ Rover : Node_Id;
+ begin
+ loop
+ Rover := Parent (Trailer);
+ case Nkind (Rover) is
+ when N_Qualified_Expression | N_Type_Conversion =>
+ -- Conservative for type conversions; only necessary if
+ -- conversion does not introduce a new object (as opposed
+ -- to a new view of an existing object).
+ null;
+ when N_Object_Renaming_Declaration =>
+ return Trailer = Name (Rover);
+ when others =>
+ return False; -- the usual case
+ end case;
+ Trailer := Rover;
+ end loop;
+ end Is_Object_Renaming_Name;
+
+ -- Local variables
+
E : constant Entity_Id := Entity (N);
+ -- Start of processing for Expand_Entity_Reference
+
begin
-- Defend against errors
@@ -441,10 +476,17 @@ package body Exp_Ch2 is
end;
end if;
- -- Interpret possible Current_Value for variable case
+ -- Interpret possible Current_Value for variable case. The
+ -- Is_Object_Renaming_Name test is needed for cases such as
+ -- X : Integer := 1;
+ -- Y : Integer renames Integer'(X);
+ -- where the value of Y is changed by any subsequent assignments to X.
+ -- In cases like this, we do not want to use Current_Value even though
+ -- it is available.
if Is_Assignable (E)
and then Present (Current_Value (E))
+ and then not Is_Object_Renaming_Name (N)
then
Expand_Current_Value (N);
diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index f8b6ee6..e0040ed 100644
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -671,24 +671,90 @@ package body Exp_Ch3 is
------------------------
function Init_One_Dimension (N : Int) return List_Id is
- Index : Entity_Id;
+ Index : Entity_Id;
+ DIC_Call : Node_Id;
+ Result_List : List_Id;
+
+ function Possible_DIC_Call return Node_Id;
+ -- If the component type has Default_Initial_Conditions and a DIC
+ -- procedure that is not an empty body, then builds a call to the
+ -- DIC procedure and returns it.
+
+ -----------------------
+ -- Possible_DIC_Call --
+ -----------------------
+
+ function Possible_DIC_Call return Node_Id is
+ begin
+ -- When the component's type has a Default_Initial_Condition, then
+ -- create a call for the DIC check.
+
+ if Has_DIC (Comp_Type)
+ -- In GNATprove mode, the component DICs are checked by other
+ -- means. They should not be added to the record type DIC
+ -- procedure, so that the procedure can be used to check the
+ -- record type invariants or DICs if any.
+
+ and then not GNATprove_Mode
+
+ -- DIC checks for components of controlled types are done later
+ -- (see Exp_Ch7.Make_Deep_Array_Body).
+
+ and then not Is_Controlled (Comp_Type)
+
+ and then Present (DIC_Procedure (Comp_Type))
+
+ and then not Has_Null_Body (DIC_Procedure (Comp_Type))
+ then
+ return
+ Build_DIC_Call (Loc,
+ Make_Indexed_Component (Loc,
+ Prefix => Make_Identifier (Loc, Name_uInit),
+ Expressions => Index_List),
+ Comp_Type);
+ else
+ return Empty;
+ end if;
+ end Possible_DIC_Call;
+
+ -- Start of processing for Init_One_Dimension
begin
-- If the component does not need initializing, then there is nothing
-- to do here, so we return a null body. This occurs when generating
-- the dummy Init_Proc needed for Initialize_Scalars processing.
+ -- An exception is if component type has a Default_Initial_Condition,
+ -- in which case we generate a call to the type's DIC procedure.
if not Has_Non_Null_Base_Init_Proc (Comp_Type)
and then not Comp_Simple_Init
and then not Has_Task (Comp_Type)
and then not Has_Default_Aspect (A_Type)
+ and then (not Has_DIC (Comp_Type)
+ or else N > Number_Dimensions (A_Type))
then
- return New_List (Make_Null_Statement (Loc));
+ DIC_Call := Possible_DIC_Call;
+
+ if Present (DIC_Call) then
+ return New_List (DIC_Call);
+ else
+ return New_List (Make_Null_Statement (Loc));
+ end if;
-- If all dimensions dealt with, we simply initialize the component
+ -- and append a call to component type's DIC procedure when needed.
elsif N > Number_Dimensions (A_Type) then
- return Init_Component;
+ DIC_Call := Possible_DIC_Call;
+
+ if Present (DIC_Call) then
+ Result_List := Init_Component;
+ Append (DIC_Call, Result_List);
+ return Result_List;
+
+ else
+ return Init_Component;
+ end if;
-- Here we generate the required loop
@@ -753,6 +819,7 @@ package body Exp_Ch3 is
-- 3. Tasks are present
-- 4. The type is marked as a public entity
-- 5. The array type has a Default_Component_Value aspect
+ -- 6. The array component type has a Default_Initialization_Condition
-- The reason for the public entity test is to deal properly with the
-- Initialize_Scalars pragma. This pragma can be set in the client and
@@ -771,7 +838,8 @@ package body Exp_Ch3 is
Has_Default_Init := Has_Non_Null_Base_Init_Proc (Comp_Type)
or else Comp_Simple_Init
or else Has_Task (Comp_Type)
- or else Has_Default_Aspect (A_Type);
+ or else Has_Default_Aspect (A_Type)
+ or else Has_DIC (Comp_Type);
if Has_Default_Init
or else (not Restriction_Active (No_Initialize_Scalars)
@@ -1945,47 +2013,6 @@ package body Exp_Ch3 is
Lhs : Node_Id;
Res : List_Id;
- function Replace_Discr_Ref (N : Node_Id) return Traverse_Result;
- -- Analysis of the aggregate has replaced discriminants by their
- -- corresponding discriminals, but these are irrelevant when the
- -- component has a mutable type and is initialized with an aggregate.
- -- Instead, they must be replaced by the values supplied in the
- -- aggregate, that will be assigned during the expansion of the
- -- assignment.
-
- -----------------------
- -- Replace_Discr_Ref --
- -----------------------
-
- function Replace_Discr_Ref (N : Node_Id) return Traverse_Result is
- Val : Node_Id;
-
- begin
- if Is_Entity_Name (N)
- and then Present (Entity (N))
- and then Is_Formal (Entity (N))
- and then Present (Discriminal_Link (Entity (N)))
- then
- Val :=
- Make_Selected_Component (Default_Loc,
- Prefix => New_Copy_Tree (Lhs),
- Selector_Name =>
- New_Occurrence_Of
- (Discriminal_Link (Entity (N)), Default_Loc));
-
- if Present (Val) then
- Rewrite (N, New_Copy_Tree (Val));
- end if;
- end if;
-
- return OK;
- end Replace_Discr_Ref;
-
- procedure Replace_Discriminant_References is
- new Traverse_Proc (Replace_Discr_Ref);
-
- -- Start of processing for Build_Assignment
-
begin
Lhs :=
Make_Selected_Component (Default_Loc,
@@ -1993,22 +2020,6 @@ package body Exp_Ch3 is
Selector_Name => New_Occurrence_Of (Id, Default_Loc));
Set_Assignment_OK (Lhs);
- if Nkind (Exp) = N_Aggregate
- and then Has_Discriminants (Typ)
- and then not Is_Constrained (Base_Type (Typ))
- then
- -- The aggregate may provide new values for the discriminants
- -- of the component, and other components may depend on those
- -- discriminants. Previous analysis of those expressions have
- -- replaced the discriminants by the formals of the initialization
- -- procedure for the type, but these are irrelevant in the
- -- enclosing initialization procedure: those discriminant
- -- references must be replaced by the values provided in the
- -- aggregate.
-
- Replace_Discriminant_References (Exp);
- end if;
-
-- 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
@@ -3438,6 +3449,38 @@ package body Exp_Ch3 is
Actions := No_List;
end if;
+ -- When the component's type has a Default_Initial_Condition,
+ -- and the component is default initialized, then check the
+ -- DIC here.
+
+ if Has_DIC (Typ)
+ and then not Present (Expression (Decl))
+ and then Present (DIC_Procedure (Typ))
+ and then not Has_Null_Body (DIC_Procedure (Typ))
+
+ -- The DICs of ancestors are checked as part of the type's
+ -- DIC procedure.
+
+ and then Chars (Id) /= Name_uParent
+
+ -- In GNATprove mode, the component DICs are checked by other
+ -- means. They should not be added to the record type DIC
+ -- procedure, so that the procedure can be used to check the
+ -- record type invariants or DICs if any.
+
+ and then not GNATprove_Mode
+ then
+ Append_New_To (Actions,
+ Build_DIC_Call
+ (Comp_Loc,
+ Make_Selected_Component (Comp_Loc,
+ Prefix =>
+ Make_Identifier (Comp_Loc, Name_uInit),
+ Selector_Name =>
+ New_Occurrence_Of (Id, Comp_Loc)),
+ Typ));
+ end if;
+
if Present (Checks) then
if Chars (Id) = Name_uParent then
Append_List_To (Parent_Stmts, Checks);
@@ -7403,12 +7446,12 @@ package body Exp_Ch3 is
-- If we cannot convert the expression into a renaming we must
-- consider it an internal error because the backend does not
- -- have support to handle it. Also, when a raise expression is
- -- encountered we ignore it since it doesn't return a value and
- -- thus cannot trigger a copy.
+ -- have support to handle it. But avoid crashing on a raise
+ -- expression or conditional expression.
- elsif Nkind (Original_Node (Expr_Q)) /= N_Raise_Expression then
- pragma Assert (False);
+ elsif Nkind (Original_Node (Expr_Q)) not in
+ N_Raise_Expression | N_If_Expression | N_Case_Expression
+ then
raise Program_Error;
end if;
@@ -7552,12 +7595,14 @@ package body Exp_Ch3 is
if Comes_From_Source (Def_Id)
and then Has_DIC (Typ)
and then Present (DIC_Procedure (Typ))
+ and then not Has_Null_Body (DIC_Procedure (Typ))
and then not Has_Init_Expression (N)
and then not Is_Imported (Def_Id)
then
declare
- DIC_Call : constant Node_Id := Build_DIC_Call (Loc, Def_Id, Typ);
-
+ DIC_Call : constant Node_Id :=
+ Build_DIC_Call
+ (Loc, New_Occurrence_Of (Def_Id, Loc), Typ);
begin
if Present (Next_N) then
Insert_Before_And_Analyze (Next_N, DIC_Call);
@@ -8331,13 +8376,6 @@ package body Exp_Ch3 is
Process_Pending_Access_Types (Def_Id);
Freeze_Stream_Operations (N, Def_Id);
- -- Generate the [spec and] body of the procedure tasked with the runtime
- -- verification of pragma Default_Initial_Condition's expression.
-
- if Has_DIC (Def_Id) then
- Build_DIC_Procedure_Body (Def_Id, For_Freeze => True);
- end if;
-
-- Generate the [spec and] body of the invariant procedure tasked with
-- the runtime verification of all invariants that pertain to the type.
-- This includes invariants on the partial and full view, inherited
@@ -8363,14 +8401,24 @@ package body Exp_Ch3 is
-- subprograms, which may involve local declarations of local
-- subtypes to which these checks do not apply.
- elsif Has_Invariants (Def_Id) then
- if not Predicate_Check_In_Scope (Def_Id)
- or else (Ekind (Current_Scope) = E_Function
- and then Is_Predicate_Function (Current_Scope))
- then
- null;
- else
- Build_Invariant_Procedure_Body (Def_Id);
+ else
+ if Has_Invariants (Def_Id) then
+ if not Predicate_Check_In_Scope (Def_Id)
+ or else (Ekind (Current_Scope) = E_Function
+ and then Is_Predicate_Function (Current_Scope))
+ then
+ null;
+ else
+ Build_Invariant_Procedure_Body (Def_Id);
+ end if;
+ end if;
+
+ -- Generate the [spec and] body of the procedure tasked with the
+ -- run-time verification of pragma Default_Initial_Condition's
+ -- expression.
+
+ if Has_DIC (Def_Id) then
+ Build_DIC_Procedure_Body (Def_Id);
end if;
end if;
@@ -8976,13 +9024,13 @@ package body Exp_Ch3 is
if Warning_Needed then
Error_Msg_N
- ("Objects of the type cannot be initialized statically "
+ ("objects of the type cannot be initialized statically "
& "by default??", Parent (E));
end if;
end if;
else
- Error_Msg_N ("Object cannot be initialized statically??", E);
+ Error_Msg_N ("object cannot be initialized statically??", E);
end if;
end if;
end Initialization_Warning;
diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb
index 076e0de..04bd1fe 100644
--- a/gcc/ada/exp_ch4.adb
+++ b/gcc/ada/exp_ch4.adb
@@ -1268,9 +1268,8 @@ package body Exp_Ch4 is
-- expression with a constrained subtype in order to compute the
-- proper size for the allocator.
- if Is_Array_Type (T)
+ if Is_Packed_Array (T)
and then not Is_Constrained (T)
- and then Is_Packed (T)
then
declare
ConstrT : constant Entity_Id := Make_Temporary (Loc, 'A');
@@ -2184,21 +2183,54 @@ package body Exp_Ch4 is
then
return;
else
-
Func_Body := Make_Boolean_Array_Op (Etype (L), N);
Func_Name := Defining_Unit_Name (Specification (Func_Body));
Insert_Action (N, Func_Body);
-- Now rewrite the expression with a call
- Rewrite (N,
- Make_Function_Call (Loc,
- Name => New_Occurrence_Of (Func_Name, Loc),
- Parameter_Associations =>
- New_List (
- L,
- Make_Type_Conversion
- (Loc, New_Occurrence_Of (Etype (L), Loc), R))));
+ if Transform_Function_Array then
+ declare
+ Temp_Id : constant Entity_Id := Make_Temporary (Loc, 'T');
+ Call : Node_Id;
+ Decl : Node_Id;
+
+ begin
+ -- Generate:
+ -- Temp : ...;
+
+ Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Temp_Id,
+ Object_Definition =>
+ New_Occurrence_Of (Etype (L), Loc));
+
+ -- Generate:
+ -- Proc_Call (L, R, Temp);
+
+ Call :=
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Occurrence_Of (Func_Name, Loc),
+ Parameter_Associations =>
+ New_List (
+ L,
+ Make_Type_Conversion
+ (Loc, New_Occurrence_Of (Etype (L), Loc), R),
+ New_Occurrence_Of (Temp_Id, Loc)));
+
+ Insert_Actions (Parent (N), New_List (Decl, Call));
+ Rewrite (N, New_Occurrence_Of (Temp_Id, Loc));
+ end;
+ else
+ Rewrite (N,
+ Make_Function_Call (Loc,
+ Name => New_Occurrence_Of (Func_Name, Loc),
+ Parameter_Associations =>
+ New_List (
+ L,
+ Make_Type_Conversion
+ (Loc, New_Occurrence_Of (Etype (L), Loc), R))));
+ end if;
Analyze_And_Resolve (N, Typ);
end if;
@@ -3506,8 +3538,17 @@ package body Exp_Ch4 is
Alloc :=
Make_Allocator (Loc,
Expression => New_Occurrence_Of (ConstrT, Loc));
+
+ -- Allocate on the secondary stack. This is currently done
+ -- only for type String, which normally doesn't have default
+ -- initialization, but we need to Set_No_Initialization in case
+ -- of Initialize_Scalars or Normalize_Scalars; otherwise, the
+ -- allocator will get transformed and will not use the secondary
+ -- stack.
+
Set_Storage_Pool (Alloc, RTE (RE_SS_Pool));
Set_Procedure_To_Call (Alloc, RTE (RE_SS_Allocate));
+ Set_No_Initialization (Alloc);
Temp := Make_Temporary (Loc, 'R', Alloc);
Insert_Action (Cnode,
@@ -5347,6 +5388,24 @@ package body Exp_Ch4 is
Rewrite (N, New_Occurrence_Of (Temp, Loc));
Analyze_And_Resolve (N, PtrT);
+
+ -- When designated type has Default_Initial_Condition aspects,
+ -- make a call to the type's DIC procedure to perform the
+ -- checks. Theoretically this might also be needed for cases
+ -- where the type doesn't have an init proc, but those should
+ -- be very uncommon, and for now we only support the init proc
+ -- case. ???
+
+ if Has_DIC (Dtyp)
+ and then Present (DIC_Procedure (Dtyp))
+ and then not Has_Null_Body (DIC_Procedure (Dtyp))
+ then
+ Insert_Action (N,
+ Build_DIC_Call (Loc,
+ Make_Explicit_Dereference (Loc,
+ Prefix => New_Occurrence_Of (Temp, Loc)),
+ Dtyp));
+ end if;
end if;
end if;
end;
@@ -9708,16 +9767,6 @@ package body Exp_Ch4 is
end if;
end if;
- -- Try to narrow the operation
-
- if Typ = Universal_Integer then
- Narrow_Large_Operation (N);
-
- if Nkind (N) /= N_Op_Multiply then
- return;
- end if;
- end if;
-
-- Convert x * 2 ** y to Shift_Left (x, y). Note that the fact that
-- Is_Power_Of_2_For_Shift is set means that we know that our left
-- operand is an integer, as required for this to work.
@@ -9794,6 +9843,16 @@ package body Exp_Ch4 is
return;
end if;
+ -- Try to narrow the operation
+
+ if Typ = Universal_Integer then
+ Narrow_Large_Operation (N);
+
+ if Nkind (N) /= N_Op_Multiply then
+ return;
+ end if;
+ end if;
+
-- Do required fixup of universal fixed operation
if Typ = Universal_Fixed then
@@ -9990,12 +10049,21 @@ package body Exp_Ch4 is
-- return B;
-- end Nnnn;
+ -- or in the case of Transform_Function_Array:
+
+ -- procedure Nnnn (A : arr; RESULT : out arr) is
+ -- begin
+ -- for J in a'range loop
+ -- RESULT (J) := not A (J);
+ -- end loop;
+ -- end Nnnn;
+
-- Here arr is the actual subtype of the parameter (and hence always
- -- constrained). Then we replace the not with a call to this function.
+ -- constrained). Then we replace the not with a call to this subprogram.
procedure Expand_N_Op_Not (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
- Typ : constant Entity_Id := Etype (N);
+ Typ : constant Entity_Id := Etype (Right_Opnd (N));
Opnd : Node_Id;
Arr : Entity_Id;
A : Entity_Id;
@@ -10091,7 +10159,13 @@ package body Exp_Ch4 is
end if;
A := Make_Defining_Identifier (Loc, Name_uA);
- B := Make_Defining_Identifier (Loc, Name_uB);
+
+ if Transform_Function_Array then
+ B := Make_Defining_Identifier (Loc, Name_UP_RESULT);
+ else
+ B := Make_Defining_Identifier (Loc, Name_uB);
+ end if;
+
J := Make_Defining_Identifier (Loc, Name_uJ);
A_J :=
@@ -10126,33 +10200,82 @@ package body Exp_Ch4 is
Func_Name := Make_Temporary (Loc, 'N');
Set_Is_Inlined (Func_Name);
- Insert_Action (N,
- Make_Subprogram_Body (Loc,
- Specification =>
- Make_Function_Specification (Loc,
- Defining_Unit_Name => Func_Name,
- Parameter_Specifications => New_List (
- Make_Parameter_Specification (Loc,
- Defining_Identifier => A,
- Parameter_Type => New_Occurrence_Of (Typ, Loc))),
- Result_Definition => New_Occurrence_Of (Typ, Loc)),
+ if Transform_Function_Array then
+ Insert_Action (N,
+ Make_Subprogram_Body (Loc,
+ Specification =>
+ Make_Procedure_Specification (Loc,
+ Defining_Unit_Name => Func_Name,
+ Parameter_Specifications => New_List (
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier => A,
+ Parameter_Type => New_Occurrence_Of (Typ, Loc)),
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier => B,
+ Out_Present => True,
+ Parameter_Type => New_Occurrence_Of (Typ, Loc)))),
+
+ Declarations => New_List,
+
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (Loop_Statement))));
- Declarations => New_List (
- Make_Object_Declaration (Loc,
- Defining_Identifier => B,
- Object_Definition => New_Occurrence_Of (Arr, Loc))),
+ declare
+ Temp_Id : constant Entity_Id := Make_Temporary (Loc, 'T');
+ Call : Node_Id;
+ Decl : Node_Id;
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (
- Loop_Statement,
- Make_Simple_Return_Statement (Loc,
- Expression => Make_Identifier (Loc, Chars (B)))))));
+ begin
+ -- Generate:
+ -- Temp : ...;
- Rewrite (N,
- Make_Function_Call (Loc,
- Name => New_Occurrence_Of (Func_Name, Loc),
- Parameter_Associations => New_List (Opnd)));
+ Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Temp_Id,
+ Object_Definition => New_Occurrence_Of (Typ, Loc));
+
+ -- Generate:
+ -- Proc_Call (Opnd, Temp);
+
+ Call :=
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Occurrence_Of (Func_Name, Loc),
+ Parameter_Associations =>
+ New_List (Opnd, New_Occurrence_Of (Temp_Id, Loc)));
+
+ Insert_Actions (Parent (N), New_List (Decl, Call));
+ Rewrite (N, New_Occurrence_Of (Temp_Id, Loc));
+ end;
+ else
+ Insert_Action (N,
+ Make_Subprogram_Body (Loc,
+ Specification =>
+ Make_Function_Specification (Loc,
+ Defining_Unit_Name => Func_Name,
+ Parameter_Specifications => New_List (
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier => A,
+ Parameter_Type => New_Occurrence_Of (Typ, Loc))),
+ Result_Definition => New_Occurrence_Of (Typ, Loc)),
+
+ Declarations => New_List (
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => B,
+ Object_Definition => New_Occurrence_Of (Arr, Loc))),
+
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (
+ Loop_Statement,
+ Make_Simple_Return_Statement (Loc,
+ Expression => Make_Identifier (Loc, Chars (B)))))));
+
+ Rewrite (N,
+ Make_Function_Call (Loc,
+ Name => New_Occurrence_Of (Func_Name, Loc),
+ Parameter_Associations => New_List (Opnd)));
+ end if;
Analyze_And_Resolve (N, Typ);
end Expand_N_Op_Not;
@@ -11039,7 +11162,7 @@ package body Exp_Ch4 is
-- because the selected component may be a reference to the
-- object being initialized, whose discriminant is not yet
-- set. This only happens in complex cases involving changes
- -- or representation.
+ -- of representation.
if Disc = Entity (Selector_Name (N))
and then (Is_Entity_Name (Dval)
@@ -11051,15 +11174,7 @@ package body Exp_Ch4 is
-- constrained by an outer discriminant, which cannot
-- be optimized away.
- if Denotes_Discriminant
- (Dval, Check_Concurrent => True)
- then
- exit Discr_Loop;
-
- elsif Nkind (Original_Node (Dval)) = N_Selected_Component
- and then
- Denotes_Discriminant
- (Selector_Name (Original_Node (Dval)), True)
+ if Denotes_Discriminant (Dval, Check_Concurrent => True)
then
exit Discr_Loop;
@@ -11457,11 +11572,6 @@ package body Exp_Ch4 is
-- Start of processing for Discrete_Range_Check
begin
- -- Clear the Do_Range_Check flag on N if needed: this can occur when
- -- e.g. a trivial type conversion is rewritten by its expression.
-
- Set_Do_Range_Check (N, False);
-
-- Nothing more to do if conversion was rewritten
if Nkind (N) /= N_Type_Conversion then
@@ -11470,12 +11580,6 @@ package body Exp_Ch4 is
Expr := Expression (N);
- -- Nothing to do if no range check flag set
-
- if not Do_Range_Check (Expr) then
- return;
- end if;
-
-- Clear the Do_Range_Check flag on Expr
Set_Do_Range_Check (Expr, False);
@@ -11748,11 +11852,6 @@ package body Exp_Ch4 is
Tnn : Entity_Id;
begin
- -- Clear the Do_Range_Check flag on N if needed: this can occur when
- -- e.g. a trivial type conversion is rewritten by its expression.
-
- Set_Do_Range_Check (N, False);
-
-- Nothing more to do if conversion was rewritten
if Nkind (N) /= N_Type_Conversion then
@@ -11871,33 +11970,20 @@ package body Exp_Ch4 is
-- which used to fail when Fix_Val was a bound of the type and
-- the 'Small was not a representable number.
-- This transformation requires an integer type large enough to
- -- accommodate a fixed-point value. This will not be the case
- -- in systems where Duration is larger than Long_Integer.
+ -- accommodate a fixed-point value.
if Is_Ordinary_Fixed_Point_Type (Target_Type)
and then Is_Floating_Point_Type (Etype (Expr))
- and then RM_Size (Btyp) <= RM_Size (Standard_Long_Integer)
+ and then RM_Size (Btyp) <= System_Max_Integer_Size
and then Nkind (Lo) = N_Real_Literal
and then Nkind (Hi) = N_Real_Literal
then
declare
Expr_Id : constant Entity_Id := Make_Temporary (Loc, 'T', Conv);
- Int_Type : Entity_Id;
+ Int_Typ : constant Entity_Id :=
+ Small_Integer_Type_For (RM_Size (Btyp), False);
begin
- -- Find an integer type of the appropriate size to perform an
- -- unchecked conversion to the target fixed-point type.
-
- if RM_Size (Btyp) > RM_Size (Standard_Integer) then
- Int_Type := Standard_Long_Integer;
-
- elsif RM_Size (Btyp) > RM_Size (Standard_Short_Integer) then
- Int_Type := Standard_Integer;
-
- else
- Int_Type := Standard_Short_Integer;
- end if;
-
-- Generate a temporary with the integer value. Required in the
-- CCG compiler to ensure that run-time checks reference this
-- integer expression (instead of the resulting fixed-point
@@ -11907,23 +11993,23 @@ package body Exp_Ch4 is
Insert_Action (N,
Make_Object_Declaration (Loc,
Defining_Identifier => Expr_Id,
- Object_Definition => New_Occurrence_Of (Int_Type, Loc),
+ Object_Definition => New_Occurrence_Of (Int_Typ, Loc),
Constant_Present => True,
Expression =>
- Convert_To (Int_Type, Expression (Conv))));
+ Convert_To (Int_Typ, Expression (Conv))));
-- Create integer objects for range checking of result.
Lo_Arg :=
Unchecked_Convert_To
- (Int_Type, New_Occurrence_Of (Expr_Id, Loc));
+ (Int_Typ, New_Occurrence_Of (Expr_Id, Loc));
Lo_Val :=
Make_Integer_Literal (Loc, Corresponding_Integer_Value (Lo));
Hi_Arg :=
Unchecked_Convert_To
- (Int_Type, New_Occurrence_Of (Expr_Id, Loc));
+ (Int_Typ, New_Occurrence_Of (Expr_Id, Loc));
Hi_Val :=
Make_Integer_Literal (Loc, Corresponding_Integer_Value (Hi));
@@ -12037,20 +12123,16 @@ package body Exp_Ch4 is
-- Nothing at all to do if conversion is to the identical type so remove
-- the conversion completely, it is useless, except that it may carry
-- an Assignment_OK attribute, which must be propagated to the operand
- -- and the Do_Range_Check flag on Operand should be taken into account.
+ -- and the Do_Range_Check flag on the operand must be cleared, if any.
if Operand_Type = Target_Type then
if Assignment_OK (N) then
Set_Assignment_OK (Operand);
end if;
- Rewrite (N, Relocate_Node (Operand));
-
- if Do_Range_Check (Operand) then
- pragma Assert (Is_Discrete_Type (Operand_Type));
+ Set_Do_Range_Check (Operand, False);
- Discrete_Range_Check;
- end if;
+ Rewrite (N, Relocate_Node (Operand));
goto Done;
end if;
@@ -12259,7 +12341,7 @@ package body Exp_Ch4 is
else
Apply_Accessibility_Check
- (Operand_Acc, Target_Type, Insert_Node => Operand);
+ (Operand, Target_Type, Insert_Node => Operand);
end if;
-- If the level of the operand type is statically deeper than the
@@ -12466,23 +12548,18 @@ package body Exp_Ch4 is
and then Nkind (Parent (N)) = N_Attribute_Reference
and then Attribute_Name (Parent (N)) = Name_Round
then
- Set_Rounded_Result (N);
Set_Etype (N, Etype (Parent (N)));
Target_Type := Etype (N);
+ Set_Rounded_Result (N);
end if;
if Is_Fixed_Point_Type (Target_Type) then
Expand_Convert_Fixed_To_Fixed (N);
- Real_Range_Check;
-
elsif Is_Integer_Type (Target_Type) then
Expand_Convert_Fixed_To_Integer (N);
- Discrete_Range_Check;
-
else
pragma Assert (Is_Floating_Point_Type (Target_Type));
Expand_Convert_Fixed_To_Float (N);
- Real_Range_Check;
end if;
-- Case of conversions to a fixed-point type
@@ -12497,11 +12574,9 @@ package body Exp_Ch4 is
then
if Is_Integer_Type (Operand_Type) then
Expand_Convert_Integer_To_Fixed (N);
- Real_Range_Check;
else
pragma Assert (Is_Floating_Point_Type (Operand_Type));
Expand_Convert_Float_To_Fixed (N);
- Real_Range_Check;
end if;
-- Case of array conversions
@@ -12661,8 +12736,6 @@ package body Exp_Ch4 is
-- Here at end of processing
<<Done>>
- pragma Assert (not Do_Range_Check (N));
-
-- Apply predicate check if required. Note that we can't just call
-- Apply_Predicate_Check here, because the type looks right after
-- the conversion and it would omit the check. The Comes_From_Source
@@ -12734,56 +12807,6 @@ package body Exp_Ch4 is
return;
end if;
- -- If we have a conversion of a compile time known value to a target
- -- type and the value is in range of the target type, then we can simply
- -- replace the construct by an integer literal of the correct type. We
- -- only apply this to discrete types being converted. Possibly it may
- -- apply in other cases, but it is too much trouble to worry about.
-
- -- Note that we do not do this transformation if the Kill_Range_Check
- -- flag is set, since then the value may be outside the expected range.
- -- This happens in the Normalize_Scalars case.
-
- -- We also skip this if either the target or operand type is biased
- -- because in this case, the unchecked conversion is supposed to
- -- preserve the bit pattern, not the integer value.
-
- if Is_Integer_Type (Target_Type)
- and then not Has_Biased_Representation (Target_Type)
- and then Is_Discrete_Type (Operand_Type)
- and then not Has_Biased_Representation (Operand_Type)
- and then Compile_Time_Known_Value (Operand)
- and then not Kill_Range_Check (N)
- then
- declare
- Val : constant Uint := Expr_Rep_Value (Operand);
-
- begin
- if Compile_Time_Known_Value (Type_Low_Bound (Target_Type))
- and then
- Compile_Time_Known_Value (Type_High_Bound (Target_Type))
- and then
- Val >= Expr_Value (Type_Low_Bound (Target_Type))
- and then
- Val <= Expr_Value (Type_High_Bound (Target_Type))
- then
- Rewrite (N, Make_Integer_Literal (Sloc (N), Val));
-
- -- If Address is the target type, just set the type to avoid a
- -- spurious type error on the literal when Address is a visible
- -- integer type.
-
- if Is_Descendant_Of_Address (Target_Type) then
- Set_Etype (N, Target_Type);
- else
- Analyze_And_Resolve (N, Target_Type);
- end if;
-
- return;
- end if;
- end;
- end if;
-
-- Generate an extra temporary for cases unsupported by the C backend
if Modify_Tree_For_C then
@@ -13294,7 +13317,8 @@ package body Exp_Ch4 is
-- will be to universal real, and our real type comes from the Round
-- attribute (as well as an indication that we must round the result)
- if Nkind (Parent (Conv)) = N_Attribute_Reference
+ if Etype (Conv) = Universal_Real
+ and then Nkind (Parent (Conv)) = N_Attribute_Reference
and then Attribute_Name (Parent (Conv)) = Name_Round
then
Set_Etype (N, Base_Type (Etype (Parent (Conv))));
@@ -13932,6 +13956,15 @@ package body Exp_Ch4 is
-- return C;
-- end Annn;
+ -- or in the case of Transform_Function_Array:
+
+ -- procedure Annn (A : typ; B: typ; RESULT: out typ) is
+ -- begin
+ -- for J in A'range loop
+ -- RESULT (J) := A (J) op B (J);
+ -- end loop;
+ -- end Annn;
+
-- Here typ is the boolean array type
function Make_Boolean_Array_Op
@@ -13942,9 +13975,10 @@ package body Exp_Ch4 is
A : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uA);
B : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uB);
- C : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uC);
J : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uJ);
+ C : Entity_Id;
+
A_J : Node_Id;
B_J : Node_Id;
C_J : Node_Id;
@@ -13956,6 +13990,12 @@ package body Exp_Ch4 is
Loop_Statement : Node_Id;
begin
+ if Transform_Function_Array then
+ C := Make_Defining_Identifier (Loc, Name_UP_RESULT);
+ else
+ C := Make_Defining_Identifier (Loc, Name_uC);
+ end if;
+
A_J :=
Make_Indexed_Component (Loc,
Prefix => New_Occurrence_Of (A, Loc),
@@ -14018,28 +14058,52 @@ package body Exp_Ch4 is
Defining_Identifier => B,
Parameter_Type => New_Occurrence_Of (Typ, Loc)));
+ if Transform_Function_Array then
+ Append_To (Formals,
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier => C,
+ Out_Present => True,
+ Parameter_Type => New_Occurrence_Of (Typ, Loc)));
+ end if;
+
Func_Name := Make_Temporary (Loc, 'A');
Set_Is_Inlined (Func_Name);
- Func_Body :=
- Make_Subprogram_Body (Loc,
- Specification =>
- Make_Function_Specification (Loc,
- Defining_Unit_Name => Func_Name,
- Parameter_Specifications => Formals,
- Result_Definition => New_Occurrence_Of (Typ, Loc)),
+ if Transform_Function_Array then
+ Func_Body :=
+ Make_Subprogram_Body (Loc,
+ Specification =>
+ Make_Procedure_Specification (Loc,
+ Defining_Unit_Name => Func_Name,
+ Parameter_Specifications => Formals),
- Declarations => New_List (
- Make_Object_Declaration (Loc,
- Defining_Identifier => C,
- Object_Definition => New_Occurrence_Of (Typ, Loc))),
+ Declarations => New_List,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (
- Loop_Statement,
- Make_Simple_Return_Statement (Loc,
- Expression => New_Occurrence_Of (C, Loc)))));
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (Loop_Statement)));
+
+ else
+ Func_Body :=
+ Make_Subprogram_Body (Loc,
+ Specification =>
+ Make_Function_Specification (Loc,
+ Defining_Unit_Name => Func_Name,
+ Parameter_Specifications => Formals,
+ Result_Definition => New_Occurrence_Of (Typ, Loc)),
+
+ Declarations => New_List (
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => C,
+ Object_Definition => New_Occurrence_Of (Typ, Loc))),
+
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (
+ Loop_Statement,
+ Make_Simple_Return_Statement (Loc,
+ Expression => New_Occurrence_Of (C, Loc)))));
+ end if;
return Func_Body;
end Make_Boolean_Array_Op;
@@ -14996,6 +15060,14 @@ package body Exp_Ch4 is
return;
end if;
+ -- If both operands are static, then the comparison has been already
+ -- folded in evaluation.
+
+ pragma Assert
+ (not Is_Static_Expression (Left_Opnd (N))
+ or else
+ not Is_Static_Expression (Right_Opnd (N)));
+
-- Determine the potential outcome of the comparison assuming that the
-- operands are valid and emit a warning when the comparison evaluates
-- to True or False only in the presence of invalid values.
@@ -15011,7 +15083,8 @@ package body Exp_Ch4 is
True_Result => True_Result,
False_Result => False_Result);
- -- The outcome is a decisive False or True, rewrite the operator
+ -- The outcome is a decisive False or True, rewrite the operator into a
+ -- non-static literal.
if False_Result or True_Result then
Rewrite (N,
@@ -15019,6 +15092,7 @@ package body Exp_Ch4 is
New_Occurrence_Of (Boolean_Literals (True_Result), Sloc (N))));
Analyze_And_Resolve (N, Typ);
+ Set_Is_Static_Expression (N, False);
Warn_On_Known_Condition (N);
end if;
end Rewrite_Comparison;
diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb
index 93351cf..4cae2ee 100644
--- a/gcc/ada/exp_ch5.adb
+++ b/gcc/ada/exp_ch5.adb
@@ -1469,7 +1469,7 @@ package body Exp_Ch5 is
-- 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
+ -- 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)
@@ -1623,14 +1623,27 @@ package body Exp_Ch5 is
CI : constant List_Id := Component_Items (CL);
VP : constant Node_Id := Variant_Part (CL);
- Alts : List_Id;
- DC : Node_Id;
- DCH : List_Id;
- Expr : Node_Id;
- Result : List_Id;
- V : Node_Id;
+ Constrained_Typ : Entity_Id;
+ Alts : List_Id;
+ DC : Node_Id;
+ DCH : List_Id;
+ Expr : Node_Id;
+ Result : List_Id;
+ V : Node_Id;
begin
+ -- Try to find a constrained type to extract discriminant values
+ -- from, so that the case statement built below gets an
+ -- opportunity to be folded by Expand_N_Case_Statement.
+
+ if U_U or else Is_Constrained (Etype (Rhs)) then
+ Constrained_Typ := Etype (Rhs);
+ elsif Is_Constrained (Etype (Expression (N))) then
+ Constrained_Typ := Etype (Expression (N));
+ else
+ Constrained_Typ := Empty;
+ end if;
+
Result := Make_Field_Assigns (CI);
if Present (VP) then
@@ -1652,17 +1665,12 @@ package body Exp_Ch5 is
Next_Non_Pragma (V);
end loop;
- -- If we have an Unchecked_Union, use the value of the inferred
- -- discriminant of the variant part expression as the switch
- -- for the case statement. The case statement may later be
- -- folded.
-
- if U_U then
+ if Present (Constrained_Typ) then
Expr :=
New_Copy (Get_Discriminant_Value (
Entity (Name (VP)),
- Etype (Rhs),
- Discriminant_Constraint (Etype (Rhs))));
+ Constrained_Typ,
+ Discriminant_Constraint (Constrained_Typ)));
else
Expr :=
Make_Selected_Component (Loc,
@@ -1786,9 +1794,10 @@ package body Exp_Ch5 is
-- Start of processing for Expand_Assign_Record
begin
- -- Note that we use the base types for this processing. This results
- -- in some extra work in the constrained case, but the change of
- -- representation case is so unusual that it is not worth the effort.
+ -- Note that we need to use the base types for this processing in
+ -- order to retrieve the Type_Definition. In the constrained case,
+ -- we filter out the non relevant fields in
+ -- Make_Component_List_Assign.
-- First copy the discriminants. This is done unconditionally. It
-- is required in the unconstrained left side case, and also in the
@@ -1824,7 +1833,7 @@ package body Exp_Ch5 is
CF := F;
end if;
- if Is_Unchecked_Union (Base_Type (R_Typ)) then
+ if Is_Unchecked_Union (R_Typ) then
-- Within an initialization procedure this is the
-- assignment to an unchecked union component, in which
@@ -1916,8 +1925,8 @@ package body Exp_Ch5 is
Insert_Actions (N,
Make_Component_List_Assign (Component_List (RDef), True));
else
- Insert_Actions
- (N, Make_Component_List_Assign (Component_List (RDef)));
+ Insert_Actions (N,
+ Make_Component_List_Assign (Component_List (RDef)));
end if;
Rewrite (N, Make_Null_Statement (Loc));
@@ -4346,10 +4355,21 @@ package body Exp_Ch5 is
Iter_Pack := Scope (Root_Type (Etype (Iter_Type)));
-- Find declarations needed for "for ... of" optimization
+ -- These declarations come from GNAT sources or sources
+ -- derived from them. User code may include additional
+ -- overloadings with similar names, and we need to perforn
+ -- some reasonable resolution to find the needed primitives.
+ -- It is unclear whether this mechanism is fragile if a user
+ -- makes arbitrary changes to the private part of a package
+ -- that supports iterators.
Ent := First_Entity (Pack);
while Present (Ent) loop
- if Chars (Ent) = Name_Get_Element_Access then
+ if Chars (Ent) = Name_Get_Element_Access
+ and then Present (First_Formal (Ent))
+ and then Chars (First_Formal (Ent)) = Name_Position
+ and then No (Next_Formal (First_Formal (Ent)))
+ then
Fast_Element_Access_Op := Ent;
elsif Chars (Ent) = Name_Step
@@ -4670,6 +4690,16 @@ package body Exp_Ch5 is
New_Id : Entity_Id;
begin
+ -- If Discrete_Subtype_Definition has been rewritten as an
+ -- N_Raise_xxx_Error, rewrite the whole loop as a raise node to
+ -- avoid confusing the code generator down the line.
+
+ if Nkind (Discrete_Subtype_Definition (LPS)) in N_Raise_xxx_Error
+ then
+ Rewrite (N, Discrete_Subtype_Definition (LPS));
+ return;
+ end if;
+
if Present (Iterator_Filter (LPS)) then
pragma Assert (Ada_Version >= Ada_2020);
Set_Statements (N,
diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index b762026..2cd40e4 100644
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -883,9 +883,8 @@ package body Exp_Ch6 is
is
Loc : constant Source_Ptr := Sloc (Func_Body);
- Proc_Decl : constant Node_Id :=
- Next (Unit_Declaration_Node (Func_Id));
- -- It is assumed that the next node following the declaration of the
+ Proc_Decl : constant Node_Id := Prev (Unit_Declaration_Node (Func_Id));
+ -- It is assumed that the node before the declaration of the
-- corresponding subprogram spec is the declaration of the procedure
-- form.
@@ -2879,17 +2878,10 @@ package body Exp_Ch6 is
(Formal : Entity_Id)
is
Decl : Node_Id;
-
- -- Suppress warning for the final removal loop
- pragma Warnings (Off, Decl);
-
Lvl : Entity_Id;
- Res : Entity_Id;
- Temp : Node_Id;
- Typ : Node_Id;
procedure Insert_Level_Assign (Branch : Node_Id);
- -- Recursivly add assignment of the level temporary on each branch
+ -- Recursively add assignment of the level temporary on each branch
-- while moving through nested conditional expressions.
-------------------------
@@ -2917,12 +2909,10 @@ package body Exp_Ch6 is
-- There are more nested conditional expressions so we must go
-- deeper.
- if Nkind (Expression (Res_Assn)) =
- N_Expression_With_Actions
+ if Nkind (Expression (Res_Assn)) = N_Expression_With_Actions
and then
- Nkind
- (Original_Node (Expression (Res_Assn)))
- in N_Case_Expression | N_If_Expression
+ Nkind (Original_Node (Expression (Res_Assn)))
+ in N_Case_Expression | N_If_Expression
then
Insert_Level_Assign
(Expression (Res_Assn));
@@ -2932,9 +2922,7 @@ package body Exp_Ch6 is
else
Insert_Before_And_Analyze (Res_Assn,
Make_Assignment_Statement (Loc,
- Name =>
- New_Occurrence_Of
- (Lvl, Loc),
+ Name => New_Occurrence_Of (Lvl, Loc),
Expression =>
Accessibility_Level
(Expression (Res_Assn), Dynamic_Level)));
@@ -2956,9 +2944,7 @@ package body Exp_Ch6 is
Cond := First (Actions (Branch));
while Present (Cond) loop
- exit when Nkind (Cond) in
- N_Case_Statement | N_If_Statement;
-
+ exit when Nkind (Cond) in N_Case_Statement | N_If_Statement;
Next (Cond);
end loop;
@@ -2981,7 +2967,6 @@ package body Exp_Ch6 is
Alt := First (Alternatives (Cond));
while Present (Alt) loop
Expand_Branch (Last (Statements (Alt)));
-
Next (Alt);
end loop;
end if;
@@ -3000,7 +2985,7 @@ package body Exp_Ch6 is
New_Occurrence_Of (Standard_Natural, Loc));
-- Install the declaration and perform necessary expansion if we
- -- are dealing with a function call.
+ -- are dealing with a procedure call.
if Nkind (Call_Node) = N_Procedure_Call_Statement then
-- Generate:
@@ -3019,57 +3004,27 @@ package body Exp_Ch6 is
Insert_Before_And_Analyze (Call_Node, Decl);
- -- A function call must be transformed into an expression with
- -- actions.
+ -- Ditto for a function call. Note that we do not wrap the function
+ -- call into an expression with action to avoid bad interactions with
+ -- Exp_Ch4.Process_Transient_In_Expression.
else
-- Generate:
- -- do
- -- Lvl : Natural;
- -- in Call (do{
- -- If_Exp_Res : Typ
- -- if Cond then
- -- Lvl := 0; -- Access level
- -- If_Exp_Res := Exp;
- -- in If_Exp_Res end;},
- -- Lvl,
- -- ...
- -- )
- -- end;
-
- Res := Make_Temporary (Loc, 'R');
- Typ := Etype (Call_Node);
- Temp := Relocate_Node (Call_Node);
-
- -- Perform the rewrite with the dummy
-
- Rewrite (Call_Node,
-
- Make_Expression_With_Actions (Loc,
- Expression => New_Occurrence_Of (Res, Loc),
- Actions => New_List (
- Decl,
-
- Make_Object_Declaration (Loc,
- Defining_Identifier => Res,
- Object_Definition =>
- New_Occurrence_Of (Typ, Loc)))));
-
- -- Analyze the expression with the dummy
-
- Analyze_And_Resolve (Call_Node, Typ);
-
- -- Properly set the expression and move our view of the call node
-
- Set_Expression (Call_Node, Relocate_Node (Temp));
- Call_Node := Expression (Call_Node);
-
- -- Remove the declaration of the dummy and the subsequent actions
- -- its analysis has created.
+ -- Lvl : Natural; -- placed above the function call
+ -- ...
+ -- Func_Call (
+ -- {do
+ -- If_Exp_Res : Typ
+ -- if Cond then
+ -- Lvl := 0; -- Access level
+ -- If_Exp_Res := Exp;
+ -- in If_Exp_Res end;},
+ -- Lvl,
+ -- ...
+ -- )
- while Present (Remove_Next (Decl)) loop
- null;
- end loop;
+ Insert_Action (Call_Node, Decl);
+ Analyze (Call_Node);
end if;
-- Decorate the conditional expression with assignments to our level
@@ -3536,8 +3491,7 @@ package body Exp_Ch6 is
-- of the dimension I/O packages.
if Ada_Version >= Ada_2012
- and then
- Nkind (Call_Node) in N_Procedure_Call_Statement | N_Function_Call
+ and then Nkind (Call_Node) in N_Subprogram_Call
and then Present (Parameter_Associations (Call_Node))
then
Expand_Put_Call_With_Symbol (Call_Node);
@@ -3665,7 +3619,7 @@ package body Exp_Ch6 is
return;
end if;
- if Modify_Tree_For_C
+ if Transform_Function_Array
and then Nkind (Call_Node) = N_Function_Call
and then Is_Entity_Name (Name (Call_Node))
then
@@ -3681,9 +3635,9 @@ package body Exp_Ch6 is
-- For internally generated calls ensure that they reference
-- the entity of the spec of the called function (needed since
-- the expander may generate calls using the entity of their
- -- body). See for example Expand_Boolean_Operator().
+ -- body).
- if not (Comes_From_Source (Call_Node))
+ if not Comes_From_Source (Call_Node)
and then Nkind (Unit_Declaration_Node (Func_Id)) =
N_Subprogram_Body
then
@@ -3700,7 +3654,8 @@ package body Exp_Ch6 is
-- are passed by pointer in the generated C code, and we cannot
-- take a pointer from a subprogram call.
- elsif Nkind (Parent (Call_Node)) in N_Subprogram_Call
+ elsif Modify_Tree_For_C
+ and then Nkind (Parent (Call_Node)) in N_Subprogram_Call
and then Is_Record_Type (Etype (Func_Id))
then
declare
@@ -5427,13 +5382,15 @@ package body Exp_Ch6 is
end if;
-- Build a simple_return_statement that returns the return object when
- -- there is a statement sequence, or no expression, or the result will
- -- be built in place. Note however that we currently do this for all
- -- composite cases, even though not all are built in place.
+ -- there is a statement sequence, or no expression, or the analysis of
+ -- the return object declaration generated extra actions, or the result
+ -- will be built in place. Note however that we currently do this for
+ -- all composite cases, even though they are not built in place.
if Present (HSS)
- or else Is_Composite_Type (Ret_Typ)
or else No (Exp)
+ or else List_Length (Return_Object_Declarations (N)) > 1
+ or else Is_Composite_Type (Ret_Typ)
then
if No (HSS) then
Stmts := New_List;
@@ -5543,7 +5500,7 @@ package body Exp_Ch6 is
(Expression (Original_Node (Ret_Obj_Decl)))
-- It is a BIP object declaration that displaces the pointer
- -- to the object to reference a convered interface type.
+ -- to the object to reference a converted interface type.
or else
Present (Unqual_BIP_Iface_Function_Call
@@ -6101,16 +6058,11 @@ package body Exp_Ch6 is
end;
end if;
- -- Case where we do not build a block
+ -- Case where we do not need to build a block. But we're about to drop
+ -- Return_Object_Declarations on the floor, so assert that it contains
+ -- only the return object declaration.
- else
- -- We're about to drop Return_Object_Declarations on the floor, so
- -- we need to insert it, in case it got expanded into useful code.
- -- Remove side effects from expression, which may be duplicated in
- -- subsequent checks (see Expand_Simple_Function_Return).
-
- Insert_List_Before (N, Return_Object_Declarations (N));
- Remove_Side_Effects (Exp);
+ else pragma Assert (List_Length (Return_Object_Declarations (N)) = 1);
-- Build simple_return_statement that returns the expression directly
@@ -6293,9 +6245,24 @@ package body Exp_Ch6 is
-- Call the _Postconditions procedure if the related subprogram
-- 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.
+
if Ekind (Spec_Id) = E_Procedure
and then Present (Postconditions_Proc (Spec_Id))
then
+ -- Generate:
+ --
+ -- Return_Success_For_Postcond := True;
+ -- _postconditions;
+
+ Insert_Action (Stmt,
+ Make_Assignment_Statement (Loc,
+ Name =>
+ New_Occurrence_Of
+ (Get_Return_Success_For_Postcond (Spec_Id), Loc),
+ Expression => New_Occurrence_Of (Standard_True, Loc)));
+
Insert_Action (Stmt,
Make_Procedure_Call_Statement (Loc,
Name =>
@@ -6617,6 +6584,7 @@ package body Exp_Ch6 is
Prot_Bod : Node_Id;
Prot_Decl : Node_Id;
Prot_Id : Entity_Id;
+ Typ : Entity_Id;
begin
-- Deal with case of protected subprogram. Do not generate protected
@@ -6691,10 +6659,12 @@ package body Exp_Ch6 is
-- are not needed by the C generator (and this also produces cleaner
-- output).
- if Modify_Tree_For_C
+ Typ := Get_Fullest_View (Etype (Subp));
+
+ if Transform_Function_Array
and then Nkind (Specification (N)) = N_Function_Specification
- and then Is_Array_Type (Etype (Subp))
- and then Is_Constrained (Etype (Subp))
+ and then Is_Array_Type (Typ)
+ and then Is_Constrained (Typ)
and then not Is_Unchecked_Conversion_Instance (Subp)
then
Build_Procedure_Form (N);
@@ -6720,9 +6690,24 @@ package body Exp_Ch6 is
-- Call the _Postconditions procedure if the related subprogram 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.
+
if Ekind (Scope_Id) in E_Entry | E_Entry_Family | E_Procedure
and then Present (Postconditions_Proc (Scope_Id))
then
+ -- Generate:
+ --
+ -- Return_Success_For_Postcond := True;
+ -- _postconditions;
+
+ Insert_Action (N,
+ Make_Assignment_Statement (Loc,
+ Name =>
+ New_Occurrence_Of
+ (Get_Return_Success_For_Postcond (Scope_Id), Loc),
+ Expression => New_Occurrence_Of (Standard_True, Loc)));
+
Insert_Action (N,
Make_Procedure_Call_Statement (Loc,
Name => New_Occurrence_Of (Postconditions_Proc (Scope_Id), Loc)));
@@ -7609,6 +7594,41 @@ package body Exp_Ch6 is
Force_Evaluation (Exp, Mode => Strict);
+ -- Save the return value or a pointer to the return value since we
+ -- may need to call postconditions after finalization when cleanup
+ -- actions are present.
+
+ -- Generate:
+ --
+ -- Result_Object_For_Postcond := [Exp]'Unrestricted_Access;
+
+ Insert_Action (Exp,
+ Make_Assignment_Statement (Loc,
+ Name =>
+ New_Occurrence_Of
+ (Get_Result_Object_For_Postcond (Scope_Id), Loc),
+ Expression =>
+ (if Is_Elementary_Type (Etype (R_Type)) then
+ New_Copy_Tree (Exp)
+ else
+ Make_Attribute_Reference (Loc,
+ Attribute_Name => Name_Unrestricted_Access,
+ Prefix => New_Copy_Tree (Exp)))));
+
+ -- Mark the successful return to signal that postconditions need to
+ -- be evaluated when finalization occurs.
+
+ -- Generate:
+ --
+ -- Return_Success_For_Postcond := True;
+
+ Insert_Action (Exp,
+ Make_Assignment_Statement (Loc,
+ Name =>
+ New_Occurrence_Of
+ (Get_Return_Success_For_Postcond (Scope_Id), Loc),
+ Expression => New_Occurrence_Of (Standard_True, Loc)));
+
-- Generate call to _Postconditions
Insert_Action (Exp,
@@ -8137,6 +8157,7 @@ package body Exp_Ch6 is
if True then
Result := Is_Controlled (T)
+ and then not Is_Generic_Actual_Type (T)
and then Present (Enclosing_Subprogram (T))
and then not Is_Compilation_Unit (Enclosing_Subprogram (T))
and then Ekind (Enclosing_Subprogram (T)) = E_Procedure;
@@ -9321,7 +9342,7 @@ package body Exp_Ch6 is
Tmp_Id : Entity_Id;
begin
- -- No action of the call has already been processed
+ -- No action if the call has already been processed
if Is_Expanded_Build_In_Place_Call (BIP_Func_Call) then
return;
@@ -9996,7 +10017,7 @@ package body Exp_Ch6 is
procedure Warn_BIP (Func_Call : Node_Id) is
begin
if Debug_Flag_Underscore_BB then
- Error_Msg_N ("build-in-place function call?", Func_Call);
+ Error_Msg_N ("build-in-place function call??", Func_Call);
end if;
end Warn_BIP;
diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb
index b58a3c1..5d8ad7d 100644
--- a/gcc/ada/exp_ch7.adb
+++ b/gcc/ada/exp_ch7.adb
@@ -27,42 +27,43 @@
-- - controlled types
-- - transient scopes
-with Atree; use Atree;
-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 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;
package body Exp_Ch7 is
@@ -339,6 +340,17 @@ package body Exp_Ch7 is
-- such as for task termination. Fin_Id is the finalizer declaration
-- entity.
+ procedure Build_Finalizer_Helper
+ (N : Node_Id;
+ Clean_Stmts : List_Id;
+ Mark_Id : Entity_Id;
+ Top_Decls : List_Id;
+ Defer_Abort : Boolean;
+ Fin_Id : out Entity_Id;
+ Finalize_Old_Only : Boolean);
+ -- An internal routine which does all of the heavy lifting on behalf of
+ -- Build_Finalizer.
+
procedure Build_Finalizer_Call (N : Node_Id; Fin_Id : Entity_Id);
-- N is a construct which contains a handled sequence of statements, Fin_Id
-- is the entity of a finalizer. Create an At_End handler which covers the
@@ -1273,6 +1285,10 @@ package body Exp_Ch7 is
Object_Definition =>
New_Occurrence_Of (RTE (RE_Finalization_Master), Loc)));
+ if Debug_Generated_Code then
+ Set_Debug_Info_Needed (Fin_Mas_Id);
+ end if;
+
-- Set the associated pool and primitive Finalize_Address of the new
-- finalization master.
@@ -1393,20 +1409,32 @@ package body Exp_Ch7 is
else
Append_Freeze_Actions (Ptr_Typ, Actions);
end if;
+
+ Analyze_List (Actions);
+
+ -- When the type the finalization master is being generated for was
+ -- created to store a 'Old object, then mark it as such so its
+ -- finalization can be delayed until after postconditions have been
+ -- checked.
+
+ if Stores_Attribute_Old_Prefix (Ptr_Typ) then
+ Set_Stores_Attribute_Old_Prefix (Fin_Mas_Id);
+ end if;
end;
end Build_Finalization_Master;
- ---------------------
- -- Build_Finalizer --
- ---------------------
+ ----------------------------
+ -- Build_Finalizer_Helper --
+ ----------------------------
- procedure Build_Finalizer
+ procedure Build_Finalizer_Helper
(N : Node_Id;
Clean_Stmts : List_Id;
Mark_Id : Entity_Id;
Top_Decls : List_Id;
Defer_Abort : Boolean;
- Fin_Id : out Entity_Id)
+ Fin_Id : out Entity_Id;
+ Finalize_Old_Only : Boolean)
is
Acts_As_Clean : constant Boolean :=
Present (Mark_Id)
@@ -1616,6 +1644,10 @@ package body Exp_Ch7 is
Set_Etype (Counter_Id, Counter_Typ);
+ if Debug_Generated_Code then
+ Set_Debug_Info_Needed (Counter_Id);
+ end if;
+
-- The counter and its type are inserted before the source
-- declarations of N.
@@ -1738,9 +1770,20 @@ package body Exp_Ch7 is
-- The default name is _finalizer
else
- Fin_Id :=
- Make_Defining_Identifier (Loc,
- Chars => New_External_Name (Name_uFinalizer));
+ -- Generation of a finalization procedure exclusively for 'Old
+ -- interally generated constants requires different name since
+ -- there will need to be multiple finalization routines in the
+ -- same scope. See Build_Finalizer for details.
+
+ if Finalize_Old_Only then
+ Fin_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Name_uFinalizer_Old));
+ else
+ Fin_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Name_uFinalizer));
+ end if;
-- The visibility semantics of AT_END handlers force a strange
-- separation of spec and body for stack-related finalizers:
@@ -1778,7 +1821,11 @@ package body Exp_Ch7 is
-- exactly twice (once on the normal path, and once for
-- exceptions/abort), so this won't bloat the code too much.
- Set_Is_Inlined (Fin_Id);
+ Set_Is_Inlined (Fin_Id);
+ end if;
+
+ if Debug_Generated_Code then
+ Set_Debug_Info_Needed (Fin_Id);
end if;
-- Step 2: Creation of the finalizer specification
@@ -1969,6 +2016,10 @@ package body Exp_Ch7 is
Body_Id := Make_Defining_Identifier (Loc, Chars (Fin_Id));
+ if Debug_Generated_Code then
+ Set_Debug_Info_Needed (Body_Id);
+ end if;
+
if For_Package then
Set_Has_Qualified_Name (Body_Id);
Set_Has_Fully_Qualified_Name (Body_Id);
@@ -2035,8 +2086,26 @@ package body Exp_Ch7 is
pragma Assert (Present (Spec_Decls));
- Append_To (Spec_Decls, Fin_Spec);
- Analyze (Fin_Spec);
+ -- It maybe possible that we are finalizing 'Old objects which
+ -- exist in the spec declarations. When this is the case the
+ -- Finalizer_Insert_Node will come before the end of the
+ -- Spec_Decls. So, to mitigate this, we insert the finalizer spec
+ -- earlier at the Finalizer_Insert_Nod instead of appending to the
+ -- end of Spec_Decls to prevent its body appearing before its
+ -- corresponding spec.
+
+ if Present (Finalizer_Insert_Nod)
+ and then List_Containing (Finalizer_Insert_Nod) = Spec_Decls
+ then
+ Insert_After_And_Analyze (Finalizer_Insert_Nod, Fin_Spec);
+ Finalizer_Insert_Nod := Fin_Spec;
+
+ -- Otherwise, Finalizer_Insert_Nod is not in Spec_Decls
+
+ else
+ Append_To (Spec_Decls, Fin_Spec);
+ Analyze (Fin_Spec);
+ end if;
-- When the finalizer acts solely as a cleanup routine, the body
-- is inserted right after the spec.
@@ -2178,9 +2247,26 @@ package body Exp_Ch7 is
Decl := Last_Non_Pragma (Decls);
while Present (Decl) loop
+ -- Depending on the value of flag Finalize_Old_Only we determine
+ -- which objects get finalized as part of the current finalizer
+ -- being built.
+
+ -- When True, only temporaries capturing the value of attribute
+ -- 'Old are finalized and all other cases are ignored.
+
+ -- When False, temporary objects used to capture the value of 'Old
+ -- are ignored and all others are considered.
+
+ if Finalize_Old_Only
+ xor (Nkind (Decl) = N_Object_Declaration
+ and then Stores_Attribute_Old_Prefix
+ (Defining_Identifier (Decl)))
+ then
+ null;
+
-- Library-level tagged types
- if Nkind (Decl) = N_Full_Type_Declaration then
+ elsif Nkind (Decl) = N_Full_Type_Declaration then
Typ := Defining_Identifier (Decl);
-- Ignored Ghost types do not need any cleanup actions because
@@ -2400,8 +2486,7 @@ package body Exp_Ch7 is
if Is_Ignored_Ghost_Entity (Typ) then
null;
- elsif (Is_Access_Type (Typ)
- and then not Is_Access_Subprogram_Type (Typ)
+ elsif (Is_Access_Object_Type (Typ)
and then Needs_Finalization
(Available_View (Designated_Type (Typ))))
or else (Is_Type (Typ) and then Needs_Finalization (Typ))
@@ -2648,6 +2733,10 @@ package body Exp_Ch7 is
Set_Finalization_Master (Ptr_Typ, Fin_Mas_Id);
Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id);
+ if Debug_Generated_Code then
+ Set_Debug_Info_Needed (Pool_Id);
+ end if;
+
-- Create an explicit free statement. Note that the free uses the
-- caller's pool expressed as a renaming.
@@ -3390,7 +3479,7 @@ package body Exp_Ch7 is
New_Occurrence_Of (DT_Ptr, Loc))));
end Process_Tagged_Type_Declaration;
- -- Start of processing for Build_Finalizer
+ -- Start of processing for Build_Finalizer_Helper
begin
Fin_Id := Empty;
@@ -3540,7 +3629,7 @@ package body Exp_Ch7 is
if Acts_As_Clean or else Has_Ctrl_Objs or else Has_Tagged_Types then
Create_Finalizer;
end if;
- end Build_Finalizer;
+ end Build_Finalizer_Helper;
--------------------------
-- Build_Finalizer_Call --
@@ -3624,6 +3713,468 @@ package body Exp_Ch7 is
end Build_Finalizer_Call;
---------------------
+ -- Build_Finalizer --
+ ---------------------
+
+ procedure Build_Finalizer
+ (N : Node_Id;
+ Clean_Stmts : List_Id;
+ Mark_Id : Entity_Id;
+ Top_Decls : List_Id;
+ Defer_Abort : Boolean;
+ Fin_Id : out Entity_Id)
+ is
+ Def_Ent : constant Entity_Id := Unique_Defining_Entity (N);
+ Loc : constant Source_Ptr := Sloc (N);
+
+ -- Declarations used for the creation of _finalization_controller
+
+ Fin_Old_Id : Entity_Id := Empty;
+ Fin_Controller_Id : Entity_Id := Empty;
+ Fin_Controller_Decls : List_Id;
+ Fin_Controller_Stmts : List_Id;
+ Fin_Controller_Body : Node_Id := Empty;
+ Fin_Controller_Spec : Node_Id := Empty;
+ Postconditions_Call : Node_Id := Empty;
+
+ -- Defining identifiers for local objects used to store exception info
+
+ Raised_Post_Exception_Id : Entity_Id := Empty;
+ Raised_Finalization_Exception_Id : Entity_Id := Empty;
+ Saved_Exception_Id : Entity_Id := Empty;
+
+ -- Start of processing for Build_Finalizer
+
+ begin
+ -- Create the general finalization routine
+
+ Build_Finalizer_Helper
+ (N => N,
+ Clean_Stmts => Clean_Stmts,
+ Mark_Id => Mark_Id,
+ Top_Decls => Top_Decls,
+ Defer_Abort => Defer_Abort,
+ Fin_Id => Fin_Id,
+ Finalize_Old_Only => False);
+
+ -- When postconditions are present, expansion gets much more complicated
+ -- due to both the fact that they must be called after finalization and
+ -- that finalization of 'Old objects must occur after the postconditions
+ -- get checked.
+
+ -- Additionally, exceptions between general finalization and 'Old
+ -- finalization must be propagated correctly and exceptions which happen
+ -- during _postconditions need to be saved and reraised after
+ -- finalization of 'Old objects.
+
+ -- Generate:
+ --
+ -- Postcond_Enabled := False;
+ --
+ -- procedure _finalization_controller is
+ --
+ -- -- Exception capturing and tracking
+ --
+ -- Saved_Exception : Exception_Occurrence;
+ -- Raised_Post_Exception : Boolean := False;
+ -- Raised_Finalization_Exception : Boolean := False;
+ --
+ -- -- Start of processing for _finalization_controller
+ --
+ -- begin
+ -- -- Perform general finalization
+ --
+ -- begin
+ -- _finalizer;
+ -- exception
+ -- when others =>
+ -- -- Save the exception
+ --
+ -- Raised_Finalization_Exception := True;
+ -- Save_Occurrence
+ -- (Saved_Exception, Get_Current_Excep.all);
+ -- end;
+ --
+ -- -- Perform postcondition checks after general finalization, but
+ -- -- before finalization of 'Old related objects.
+ --
+ -- if not Raised_Finalization_Exception then
+ -- begin
+ -- -- Re-enable postconditions and check them
+ --
+ -- Postcond_Enabled := True;
+ -- _postconditions [(Result_Obj_For_Postcond[.all])];
+ -- exception
+ -- when others =>
+ -- -- Save the exception
+ --
+ -- Raised_Post_Exception := True;
+ -- Save_Occurrence
+ -- (Saved_Exception, Get_Current_Excep.all);
+ -- end;
+ -- end if;
+ --
+ -- -- Finally finalize 'Old related objects
+ --
+ -- begin
+ -- _finalizer_old;
+ -- exception
+ -- when others =>
+ -- -- Reraise the previous finalization error if there is
+ -- -- one.
+ --
+ -- if Raised_Finalization_Exception then
+ -- Reraise_Occurrence (Saved_Exception);
+ -- end if;
+ --
+ -- -- Otherwise, reraise the current one
+ --
+ -- raise;
+ -- end;
+ --
+ -- -- Reraise any saved exception
+ --
+ -- if Raised_Finalization_Exception
+ -- or else Raised_Post_Exception
+ -- then
+ -- Reraise_Occurrence (Saved_Exception);
+ -- end if;
+ -- end _finalization_controller;
+
+ if Nkind (N) = N_Subprogram_Body
+ and then Present (Postconditions_Proc (Def_Ent))
+ then
+ Fin_Controller_Stmts := New_List;
+ Fin_Controller_Decls := New_List;
+
+ -- Build the 'Old finalizer
+
+ Build_Finalizer_Helper
+ (N => N,
+ Clean_Stmts => Empty_List,
+ Mark_Id => Mark_Id,
+ Top_Decls => Top_Decls,
+ Defer_Abort => Defer_Abort,
+ Fin_Id => Fin_Old_Id,
+ Finalize_Old_Only => True);
+
+ -- Create local declarations for _finalization_controller needed for
+ -- saving exceptions.
+ --
+ -- Generate:
+ --
+ -- Saved_Exception : Exception_Occurrence;
+ -- Raised_Post_Exception : Boolean := False;
+ -- Raised_Finalization_Exception : Boolean := False;
+
+ Saved_Exception_Id := Make_Temporary (Loc, 'S');
+ Raised_Post_Exception_Id := Make_Temporary (Loc, 'P');
+ Raised_Finalization_Exception_Id := Make_Temporary (Loc, 'F');
+
+ Append_List_To (Fin_Controller_Decls, New_List (
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Saved_Exception_Id,
+ Object_Definition =>
+ New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc)),
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Raised_Post_Exception_Id,
+ Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
+ Expression => New_Occurrence_Of (Standard_False, Loc)),
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Raised_Finalization_Exception_Id,
+ Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
+ Expression => New_Occurrence_Of (Standard_False, Loc))));
+
+ -- Call _finalizer and save any exceptions which occur
+
+ -- Generate:
+ --
+ -- begin
+ -- _finalizer;
+ -- exception
+ -- when others =>
+ -- Raised_Finalization_Exception := True;
+ -- Save_Occurrence
+ -- (Saved_Exception, Get_Current_Excep.all);
+ -- end;
+
+ if Present (Fin_Id) then
+ Append_To (Fin_Controller_Stmts,
+ Make_Block_Statement (Loc,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Occurrence_Of (Fin_Id, Loc))),
+ Exception_Handlers => New_List (
+ Make_Exception_Handler (Loc,
+ Exception_Choices => New_List (
+ Make_Others_Choice (Loc)),
+ Statements => New_List (
+ Make_Assignment_Statement (Loc,
+ Name =>
+ New_Occurrence_Of
+ (Raised_Finalization_Exception_Id, Loc),
+ Expression =>
+ New_Occurrence_Of (Standard_True, Loc)),
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Occurrence_Of
+ (RTE (RE_Save_Occurrence), Loc),
+ Parameter_Associations => New_List (
+ New_Occurrence_Of
+ (Saved_Exception_Id, Loc),
+ Make_Explicit_Dereference (Loc,
+ Prefix =>
+ Make_Function_Call (Loc,
+ Name =>
+ Make_Explicit_Dereference (Loc,
+ Prefix =>
+ New_Occurrence_Of
+ (RTE (RE_Get_Current_Excep),
+ Loc))))))))))));
+ end if;
+
+ -- Create the call to postconditions based on the kind of the current
+ -- subprogram, and the type of the Result_Obj_For_Postcond.
+
+ -- Generate:
+ --
+ -- _postconditions (Result_Obj_For_Postcond[.all]);
+ --
+ -- or
+ --
+ -- _postconditions;
+
+ if Ekind (Def_Ent) = E_Procedure then
+ Postconditions_Call :=
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Occurrence_Of
+ (Postconditions_Proc (Def_Ent), Loc));
+ else
+ Postconditions_Call :=
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Occurrence_Of
+ (Postconditions_Proc (Def_Ent), Loc),
+ Parameter_Associations => New_List (
+ (if Is_Elementary_Type (Etype (Def_Ent)) then
+ New_Occurrence_Of
+ (Get_Result_Object_For_Postcond
+ (Def_Ent), Loc)
+ else
+ Make_Explicit_Dereference (Loc,
+ New_Occurrence_Of
+ (Get_Result_Object_For_Postcond
+ (Def_Ent), Loc)))));
+ end if;
+
+ -- Call _postconditions when no general finalization exceptions have
+ -- occured taking care to enable the postconditions and save any
+ -- exception occurrences.
+
+ -- Generate:
+ --
+ -- if not Raised_Finalization_Exception then
+ -- begin
+ -- Postcond_Enabled := True;
+ -- _postconditions [(Result_Obj_For_Postcond[.all])];
+ -- exception
+ -- when others =>
+ -- Raised_Post_Exception := True;
+ -- Save_Occurrence
+ -- (Saved_Exception, Get_Current_Excep.all);
+ -- end;
+ -- end if;
+
+ Append_To (Fin_Controller_Stmts,
+ Make_If_Statement (Loc,
+ Condition =>
+ Make_Op_Not (Loc,
+ Right_Opnd =>
+ New_Occurrence_Of
+ (Raised_Finalization_Exception_Id, Loc)),
+ Then_Statements => New_List (
+ Make_Block_Statement (Loc,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (
+ Make_Assignment_Statement (Loc,
+ Name =>
+ New_Occurrence_Of
+ (Get_Postcond_Enabled (Def_Ent), Loc),
+ Expression =>
+ New_Occurrence_Of
+ (Standard_True, Loc)),
+ Postconditions_Call),
+ Exception_Handlers => New_List (
+ Make_Exception_Handler (Loc,
+ Exception_Choices => New_List (
+ Make_Others_Choice (Loc)),
+ Statements => New_List (
+ Make_Assignment_Statement (Loc,
+ Name =>
+ New_Occurrence_Of
+ (Raised_Post_Exception_Id, Loc),
+ Expression =>
+ New_Occurrence_Of (Standard_True, Loc)),
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Occurrence_Of
+ (RTE (RE_Save_Occurrence), Loc),
+ Parameter_Associations => New_List (
+ New_Occurrence_Of
+ (Saved_Exception_Id, Loc),
+ Make_Explicit_Dereference (Loc,
+ Prefix =>
+ Make_Function_Call (Loc,
+ Name =>
+ Make_Explicit_Dereference (Loc,
+ Prefix =>
+ New_Occurrence_Of
+ (RTE (RE_Get_Current_Excep),
+ Loc))))))))))))));
+
+ -- Call _finalizer_old and reraise any exception that occurred during
+ -- initial finalization within the exception handler. Otherwise,
+ -- propagate the current exception.
+
+ -- Generate:
+ --
+ -- begin
+ -- _finalizer_old;
+ -- exception
+ -- when others =>
+ -- if Raised_Finalization_Exception then
+ -- Reraise_Occurrence (Saved_Exception);
+ -- end if;
+ -- raise;
+ -- end;
+
+ if Present (Fin_Old_Id) then
+ Append_To (Fin_Controller_Stmts,
+ Make_Block_Statement (Loc,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Occurrence_Of (Fin_Old_Id, Loc))),
+ Exception_Handlers => New_List (
+ Make_Exception_Handler (Loc,
+ Exception_Choices => New_List (
+ Make_Others_Choice (Loc)),
+ Statements => New_List (
+ Make_If_Statement (Loc,
+ Condition =>
+ New_Occurrence_Of
+ (Raised_Finalization_Exception_Id, Loc),
+ Then_Statements => New_List (
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Occurrence_Of
+ (RTE (RE_Reraise_Occurrence), Loc),
+ Parameter_Associations => New_List (
+ New_Occurrence_Of
+ (Saved_Exception_Id, Loc))))),
+ Make_Raise_Statement (Loc)))))));
+ end if;
+
+ -- Once finalization is complete reraise any pending exceptions
+
+ -- Generate:
+ --
+ -- if Raised_Post_Exception
+ -- or else Raised_Finalization_Exception
+ -- then
+ -- Reraise_Occurrence (Saved_Exception);
+ -- end if;
+
+ Append_To (Fin_Controller_Stmts,
+ Make_If_Statement (Loc,
+ Condition =>
+ Make_Or_Else (Loc,
+ Left_Opnd =>
+ New_Occurrence_Of
+ (Raised_Post_Exception_Id, Loc),
+ Right_Opnd =>
+ New_Occurrence_Of
+ (Raised_Finalization_Exception_Id, Loc)),
+ Then_Statements => New_List (
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Occurrence_Of (RTE (RE_Reraise_Occurrence), Loc),
+ Parameter_Associations => New_List (
+ New_Occurrence_Of
+ (Saved_Exception_Id, Loc))))));
+
+ -- Make the finalization controller subprogram body and declaration.
+
+ -- Generate:
+ -- procedure _finalization_controller;
+ --
+ -- procedure _finalization_controller is
+ -- begin
+ -- [Fin_Controller_Stmts];
+ -- end;
+
+ Fin_Controller_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Name_uFinalization_Controller));
+
+ Fin_Controller_Spec :=
+ Make_Subprogram_Declaration (Loc,
+ Specification =>
+ Make_Procedure_Specification (Loc,
+ Defining_Unit_Name => Fin_Controller_Id));
+
+ Fin_Controller_Body :=
+ Make_Subprogram_Body (Loc,
+ Specification =>
+ Make_Procedure_Specification (Loc,
+ Defining_Unit_Name =>
+ Make_Defining_Identifier (Loc, Chars (Fin_Controller_Id))),
+ Declarations => Fin_Controller_Decls,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => Fin_Controller_Stmts));
+
+ -- Disable _postconditions calls which get generated before return
+ -- statements to delay their evaluation until after finalization.
+
+ -- This is done by way of the local Postcond_Enabled object which is
+ -- initially assigned to True - we then create an assignment within
+ -- the subprogram's declaration to make it False and assign it back
+ -- to True before _postconditions is called within
+ -- _finalization_controller.
+
+ -- Generate:
+ --
+ -- Postcond_Enable := False;
+
+ Append_To (Top_Decls,
+ Make_Assignment_Statement (Loc,
+ Name =>
+ New_Occurrence_Of
+ (Get_Postcond_Enabled (Def_Ent), Loc),
+ Expression =>
+ New_Occurrence_Of
+ (Standard_False, Loc)));
+
+ -- Add the subprogram to the list of declarations an analyze it
+
+ Append_To (Top_Decls, Fin_Controller_Spec);
+ Analyze (Fin_Controller_Spec);
+ Insert_After (Fin_Controller_Spec, Fin_Controller_Body);
+ Analyze (Fin_Controller_Body, Suppress => All_Checks);
+
+ -- Return the finalization controller as the result Fin_Id
+
+ Fin_Id := Fin_Controller_Id;
+ end if;
+ end Build_Finalizer;
+
+ ---------------------
-- Build_Late_Proc --
---------------------
@@ -3741,6 +4292,10 @@ package body Exp_Ch7 is
Defining_Identifier => Data.Raised_Id,
Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
Expression => New_Occurrence_Of (Standard_False, Loc)));
+
+ if Debug_Generated_Code then
+ Set_Debug_Info_Needed (Data.Raised_Id);
+ end if;
end Build_Object_Declarations;
---------------------------
@@ -4109,20 +4664,23 @@ package body Exp_Ch7 is
procedure Reset_Scopes_To_Block_Elab_Proc (L : List_Id) is
Id : Entity_Id;
Stat : Node_Id;
+ Node : Node_Id;
begin
Stat := First (L);
while Present (Stat) loop
case Nkind (Stat) is
when N_Block_Statement =>
- Id := Entity (Identifier (Stat));
+ if Present (Identifier (Stat)) then
+ Id := Entity (Identifier (Stat));
- -- The Scope of this block needs to be reset to the new
- -- procedure if the block contains nested subprograms.
+ -- The Scope of this block needs to be reset to the new
+ -- procedure if the block contains nested subprograms.
- if Present (Id) and then Contains_Subprogram (Id) then
- Set_Block_Elab_Proc;
- Set_Scope (Id, Block_Elab_Proc);
+ if Present (Id) and then Contains_Subprogram (Id) then
+ Set_Block_Elab_Proc;
+ Set_Scope (Id, Block_Elab_Proc);
+ end if;
end if;
when N_Loop_Statement =>
@@ -4145,34 +4703,20 @@ package body Exp_Ch7 is
when N_If_Statement =>
Reset_Scopes_To_Block_Elab_Proc (Then_Statements (Stat));
-
Reset_Scopes_To_Block_Elab_Proc (Else_Statements (Stat));
- declare
- Elif : Node_Id;
-
- begin
- Elif := First (Elsif_Parts (Stat));
- while Present (Elif) loop
- Reset_Scopes_To_Block_Elab_Proc
- (Then_Statements (Elif));
-
- Next (Elif);
- end loop;
- end;
+ Node := First (Elsif_Parts (Stat));
+ while Present (Node) loop
+ Reset_Scopes_To_Block_Elab_Proc (Then_Statements (Node));
+ Next (Node);
+ end loop;
when N_Case_Statement =>
- declare
- Alt : Node_Id;
-
- begin
- Alt := First (Alternatives (Stat));
- while Present (Alt) loop
- Reset_Scopes_To_Block_Elab_Proc (Statements (Alt));
-
- Next (Alt);
- end loop;
- end;
+ Node := First (Alternatives (Stat));
+ while Present (Node) loop
+ Reset_Scopes_To_Block_Elab_Proc (Statements (Node));
+ Next (Node);
+ end loop;
-- Reset the Scope of a subprogram occurring at the top level
@@ -4794,6 +5338,12 @@ package body Exp_Ch7 is
Nkind (N) = N_Block_Statement
and then Present (Cleanup_Actions (N));
+ Has_Postcondition : constant Boolean :=
+ Nkind (N) = N_Subprogram_Body
+ and then Present
+ (Postconditions_Proc
+ (Unique_Defining_Entity (N)));
+
Actions_Required : constant Boolean :=
Requires_Cleanup_Actions (N, True)
or else Is_Asynchronous_Call
@@ -5008,6 +5558,34 @@ package body Exp_Ch7 is
end;
end if;
+ -- Move the _postconditions subprogram declaration and its associated
+ -- objects into the declarations section so that it is callable
+ -- within _postconditions.
+
+ if Has_Postcondition then
+ declare
+ Decl : Node_Id;
+ Prev_Decl : Node_Id;
+
+ begin
+ Decl :=
+ Prev (Subprogram_Body
+ (Postconditions_Proc (Current_Subprogram)));
+ while Present (Decl) loop
+ Prev_Decl := Prev (Decl);
+
+ Remove (Decl);
+ Prepend_To (New_Decls, Decl);
+
+ exit when Nkind (Decl) = N_Subprogram_Declaration
+ and then Chars (Corresponding_Body (Decl))
+ = Name_uPostconditions;
+
+ Decl := Prev_Decl;
+ end loop;
+ end;
+ end if;
+
-- Ensure the presence of a declaration list in order to successfully
-- append all original statements to it.
@@ -5954,7 +6532,7 @@ package body Exp_Ch7 is
begin
-- Nothing to do if the scope does not manage the secondary stack or
- -- does not contain meaninful actions for insertion.
+ -- does not contain meaningful actions for insertion.
if not Manage_SS
and then No (Act_Before)
@@ -6178,22 +6756,6 @@ package body Exp_Ch7 is
end if;
end Make_Adjust_Call;
- ----------------------
- -- Make_Detach_Call --
- ----------------------
-
- function Make_Detach_Call (Obj_Ref : Node_Id) return Node_Id is
- Loc : constant Source_Ptr := Sloc (Obj_Ref);
-
- begin
- return
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Occurrence_Of (RTE (RE_Detach), Loc),
- Parameter_Associations => New_List (
- Unchecked_Convert_To (RTE (RE_Root_Controlled_Ptr), Obj_Ref)));
- end Make_Detach_Call;
-
---------------
-- Make_Call --
---------------
@@ -6825,22 +7387,49 @@ package body Exp_Ch7 is
Init_Call := Build_Initialization_Call;
- -- Only create finalization block if there is a non-trivial
- -- call to initialization.
-
- if Present (Init_Call)
- and then Nkind (Init_Call) /= N_Null_Statement
+ -- Only create finalization block if there is a nontrivial call
+ -- to initialization or a Default_Initial_Condition check to be
+ -- performed.
+
+ if (Present (Init_Call)
+ and then Nkind (Init_Call) /= N_Null_Statement)
+ or else
+ (Has_DIC (Comp_Typ)
+ and then not GNATprove_Mode
+ and then Present (DIC_Procedure (Comp_Typ))
+ and then not Has_Null_Body (DIC_Procedure (Comp_Typ)))
then
- Init_Loop :=
- Make_Block_Statement (Loc,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (Init_Call),
- Exception_Handlers => New_List (
- Make_Exception_Handler (Loc,
- Exception_Choices => New_List (
- Make_Others_Choice (Loc)),
- Statements => New_List (Final_Block)))));
+ declare
+ Init_Stmts : constant List_Id := New_List;
+
+ begin
+ if Present (Init_Call) then
+ Append_To (Init_Stmts, Init_Call);
+ end if;
+
+ if Has_DIC (Comp_Typ)
+ and then Present (DIC_Procedure (Comp_Typ))
+ then
+ Append_To
+ (Init_Stmts,
+ Build_DIC_Call (Loc,
+ Make_Indexed_Component (Loc,
+ Prefix => Make_Identifier (Loc, Name_V),
+ Expressions => New_References_To (Index_List, Loc)),
+ Comp_Typ));
+ end if;
+
+ Init_Loop :=
+ Make_Block_Statement (Loc,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => Init_Stmts,
+ Exception_Handlers => New_List (
+ Make_Exception_Handler (Loc,
+ Exception_Choices => New_List (
+ Make_Others_Choice (Loc)),
+ Statements => New_List (Final_Block)))));
+ end;
Append_To (Statements (Handled_Statement_Sequence (Init_Loop)),
Make_Assignment_Statement (Loc,
@@ -6906,6 +7495,10 @@ package body Exp_Ch7 is
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (Init_Loop)));
+ if Debug_Generated_Code then
+ Set_Debug_Info_Needed (Counter_Id);
+ end if;
+
-- Otherwise previous errors or a missing full view may prevent the
-- proper freezing of the component type. If this is the case, there
-- is no [Deep_]Initialize primitive to call.
@@ -8428,6 +9021,24 @@ package body Exp_Ch7 is
elsif Is_Tagged_Type (Utyp) then
Fin_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Finalize);
+ -- Protected types: these also require finalization even though they
+ -- are not marked controlled explicitly.
+
+ elsif Is_Protected_Type (Typ) then
+ -- Protected objects do not need to be finalized on restricted
+ -- runtimes.
+
+ if Restricted_Profile then
+ return Empty;
+
+ -- ??? Only handle the simple case for now. Will not support a record
+ -- or array containing protected objects.
+
+ elsif Is_Simple_Protected_Type (Typ) then
+ Fin_Id := RTE (RE_Finalize_Protection);
+ else
+ raise Program_Error;
+ end if;
else
raise Program_Error;
end if;
@@ -8868,8 +9479,11 @@ package body Exp_Ch7 is
-- The underlying type may not be present due to a missing full view.
-- In this case freezing did not take place and there is no suitable
-- [Deep_]Initialize primitive to call.
+ -- If Typ is protected then no additional processing is needed either.
- if No (Utyp) then
+ if No (Utyp)
+ or else Is_Protected_Type (Typ)
+ then
return Empty;
end if;
@@ -8891,7 +9505,7 @@ package body Exp_Ch7 is
and then Present (Alias (Proc))
and then Is_Trivial_Subprogram (Alias (Proc)))
then
- return Make_Null_Statement (Loc);
+ return Empty;
end if;
-- The object reference may need another conversion depending on the
@@ -9681,6 +10295,10 @@ package body Exp_Ch7 is
Expression => Expr),
Par => Parent (N))));
+ if Debug_Generated_Code then
+ Set_Debug_Info_Needed (Temp);
+ end if;
+
Rewrite (N, New_Occurrence_Of (Temp, Loc));
Analyze_And_Resolve (N, Typ);
end Wrap_Transient_Expression;
diff --git a/gcc/ada/exp_ch7.ads b/gcc/ada/exp_ch7.ads
index 235b75a..5f75ab6 100644
--- a/gcc/ada/exp_ch7.ads
+++ b/gcc/ada/exp_ch7.ads
@@ -175,13 +175,6 @@ package Exp_Ch7 is
-- only the components (if any) are adjusted. Return Empty if Adjust or
-- Deep_Adjust is not available, possibly due to previous errors.
- function Make_Detach_Call (Obj_Ref : Node_Id) return Node_Id;
- -- Create a call to unhook an object from an arbitrary list. Obj_Ref is the
- -- object. Generate the following:
- --
- -- Ada.Finalization.Heap_Management.Detach
- -- (System.Finalization_Root.Root_Controlled_Ptr (Obj_Ref));
-
function Make_Final_Call
(Obj_Ref : Node_Id;
Typ : Entity_Id;
diff --git a/gcc/ada/exp_ch8.adb b/gcc/ada/exp_ch8.adb
index 9f4c65c..facd12e 100644
--- a/gcc/ada/exp_ch8.adb
+++ b/gcc/ada/exp_ch8.adb
@@ -101,10 +101,6 @@ package body Exp_Ch8 is
-- More comments needed for this para ???
procedure Expand_N_Object_Renaming_Declaration (N : Node_Id) is
- Nam : constant Node_Id := Name (N);
- Decl : Node_Id;
- T : Entity_Id;
-
function Evaluation_Required (Nam : Node_Id) return Boolean;
-- Determines whether it is necessary to do static name evaluation for
-- renaming of Nam. It is considered necessary if evaluating the name
@@ -165,6 +161,12 @@ package body Exp_Ch8 is
end if;
end Evaluation_Required;
+ -- Local variables
+
+ Decl : Node_Id;
+ Nam : constant Node_Id := Name (N);
+ T : constant Entity_Id := Etype (Defining_Identifier (N));
+
-- Start of processing for Expand_N_Object_Renaming_Declaration
begin
@@ -177,8 +179,6 @@ package body Exp_Ch8 is
-- Deal with construction of subtype in class-wide case
- T := Etype (Defining_Identifier (N));
-
if Is_Class_Wide_Type (T) then
Expand_Subtype_From_Expr (N, T, Subtype_Mark (N), Name (N));
Find_Type (Subtype_Mark (N));
diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb
index 7207723..b055b27 100644
--- a/gcc/ada/exp_ch9.adb
+++ b/gcc/ada/exp_ch9.adb
@@ -7061,7 +7061,6 @@ package body Exp_Ch9 is
Enqueue_Call : Node_Id;
Formals : List_Id;
Hdle : List_Id;
- Handler_Stmt : Node_Id;
Index : Node_Id;
Lim_Typ_Stmts : List_Id;
N_Orig : Node_Id;
@@ -7162,8 +7161,7 @@ package body Exp_Ch9 is
if Ada_Version >= Ada_2005
and then
(No (Original_Node (Ecall))
- or else Nkind (Original_Node (Ecall)) not in
- N_Delay_Relative_Statement | N_Delay_Until_Statement)
+ or else Nkind (Original_Node (Ecall)) not in N_Delay_Statement)
then
Extract_Dispatching_Call (Ecall, Call_Ent, Obj, Actuals, Formals);
@@ -7737,16 +7735,6 @@ package body Exp_Ch9 is
Has_Created_Identifier => True,
Is_Asynchronous_Call_Block => True);
- -- Aborts are not deferred at beginning of exception handlers in
- -- ZCX mode.
-
- if ZCX_Exceptions then
- Handler_Stmt := Make_Null_Statement (Loc);
-
- else
- Handler_Stmt := Build_Runtime_Call (Loc, RE_Abort_Undefer);
- end if;
-
Stmts := New_List (
Make_Block_Statement (Loc,
Handled_Statement_Sequence =>
@@ -7763,11 +7751,11 @@ package body Exp_Ch9 is
Make_Implicit_Exception_Handler (Loc,
-- when Abort_Signal =>
- -- Abort_Undefer.all;
+ -- null;
Exception_Choices =>
New_List (New_Occurrence_Of (Stand.Abort_Signal, Loc)),
- Statements => New_List (Handler_Stmt))))),
+ Statements => New_List (Make_Null_Statement (Loc)))))),
-- if not Cancelled (Bnn) then
-- triggered statements
@@ -10579,13 +10567,12 @@ package body Exp_Ch9 is
Extract_Entry (N, Concval, Ename, Index);
Conc_Typ := Etype (Concval);
- -- Examine the scope stack in order to find nearest enclosing protected
- -- or task type. This will constitute our invocation source.
+ -- Examine the scope stack in order to find nearest enclosing concurrent
+ -- type. This will constitute our invocation source.
Old_Typ := Current_Scope;
while Present (Old_Typ)
- and then not Is_Protected_Type (Old_Typ)
- and then not Is_Task_Type (Old_Typ)
+ and then not Is_Concurrent_Type (Old_Typ)
loop
Old_Typ := Scope (Old_Typ);
end loop;
diff --git a/gcc/ada/exp_dbug.adb b/gcc/ada/exp_dbug.adb
index c2e7741..bb0003d 100644
--- a/gcc/ada/exp_dbug.adb
+++ b/gcc/ada/exp_dbug.adb
@@ -133,11 +133,6 @@ package body Exp_Dbug is
-- Determine whether the bounds of E match the size of the type. This is
-- used to determine whether encoding is required for a discrete type.
- function Is_Handled_Scale_Factor (U : Ureal) return Boolean;
- -- The argument U is the Small_Value of a fixed-point type. This function
- -- determines whether the back-end can handle this scale factor. When it
- -- cannot, we have to output a GNAT encoding for the corresponding type.
-
procedure Output_Homonym_Numbers_Suffix;
-- If homonym numbers are stored, then output them into Name_Buffer
@@ -594,27 +589,6 @@ package body Exp_Dbug is
return Make_Null_Statement (Loc);
end Debug_Renaming_Declaration;
- -----------------------------
- -- Is_Handled_Scale_Factor --
- -----------------------------
-
- function Is_Handled_Scale_Factor (U : Ureal) return Boolean is
- begin
- -- Keep in sync with gigi (see E_*_Fixed_Point_Type handling in
- -- decl.c:gnat_to_gnu_entity).
-
- if UI_Eq (Numerator (U), Uint_1) then
- if Rbase (U) = 2 or else Rbase (U) = 10 then
- return True;
- end if;
- end if;
-
- return
- (UI_Is_In_Int_Range (Norm_Num (U))
- and then
- UI_Is_In_Int_Range (Norm_Den (U)));
- end Is_Handled_Scale_Factor;
-
----------------------
-- Get_Encoded_Name --
----------------------
@@ -671,12 +645,10 @@ package body Exp_Dbug is
Has_Suffix := True;
- -- Fixed-point case: generate GNAT encodings when asked to or when we
- -- know the back-end will not be able to handle the scale factor.
+ -- Fixed-point case: generate GNAT encodings when asked to
if Is_Fixed_Point_Type (E)
- and then (GNAT_Encodings /= DWARF_GNAT_Encodings_Minimal
- or else not Is_Handled_Scale_Factor (Small_Value (E)))
+ and then GNAT_Encodings = DWARF_GNAT_Encodings_All
then
Get_External_Name (E, True, "XF_");
Add_Real_To_Buffer (Delta_Value (E));
diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb
index 1a41d79..14f25db 100644
--- a/gcc/ada/exp_disp.adb
+++ b/gcc/ada/exp_disp.adb
@@ -7241,7 +7241,7 @@ package body Exp_Disp is
-- is used by Build_Get_Prim_Op_Address to expand dispatching calls
-- through the primary dispatch table.
- if UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ))) = 0 then
+ if DT_Entry_Count (First_Tag_Component (Typ)) = 0 then
Analyze_List (Result);
-- Generate:
diff --git a/gcc/ada/exp_dist.adb b/gcc/ada/exp_dist.adb
index 760a412..2d3f75d 100644
--- a/gcc/ada/exp_dist.adb
+++ b/gcc/ada/exp_dist.adb
@@ -902,7 +902,7 @@ package body Exp_Dist is
-- Local variables and structures --
------------------------------------
- RCI_Cache : Node_Id;
+ RCI_Cache : Node_Id := Empty;
-- Needs comments ???
Output_From_Constrained : constant array (Boolean) of Name_Id :=
diff --git a/gcc/ada/exp_fixd.adb b/gcc/ada/exp_fixd.adb
index 42cf626..4c658bb 100644
--- a/gcc/ada/exp_fixd.adb
+++ b/gcc/ada/exp_fixd.adb
@@ -37,9 +37,9 @@ 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 Tbuild; use Tbuild;
+with Ttypes; use Ttypes;
with Uintp; use Uintp;
with Urealp; use Urealp;
@@ -68,7 +68,7 @@ package body Exp_Fixd is
-- Build an expression that converts the expression Expr to type Typ,
-- taking the source location from Sloc (N). If the conversions involve
-- fixed-point types, then the Conversion_OK flag will be set so that the
- -- resulting conversions do not get re-expanded. On return the resulting
+ -- resulting conversions do not get re-expanded. On return, the resulting
-- node has its Etype set. If Rchk is set, then Do_Range_Check is set
-- in the resulting conversion node. If Trunc is set, then the
-- Float_Truncate flag is set on the conversion, which must be from
@@ -85,7 +85,7 @@ package body Exp_Fixd is
-- two operand types), and both operands are converted to this type. The
-- Etype of the result is also set to this value. The Rounded_Result flag
-- of the result in this case is set from the Rounded_Result flag of node
- -- N. On return, the resulting node is analyzed and has its Etype set.
+ -- N. On return, the resulting node has its Etype set.
function Build_Double_Divide
(N : Node_Id;
@@ -93,7 +93,7 @@ package body Exp_Fixd is
-- Returns a node corresponding to the value X/(Y*Z) using the source
-- location from Sloc (N). The division is rounded if the Rounded_Result
-- flag of N is set. The integer types of X, Y, Z may be different. On
- -- return the resulting node is analyzed, and has its Etype set.
+ -- return, the resulting node has its Etype set.
procedure Build_Double_Divide_Code
(N : Node_Id;
@@ -114,11 +114,9 @@ package body Exp_Fixd is
-- Make_Op_Multiply only in that the Etype of the resulting node is set (to
-- Universal_Real), or they can be integer or fixed-point types. In this
-- case the types need not be the same, and Build_Multiply chooses a type
- -- long enough to hold the product (i.e. twice the size of the longer of
- -- the two operand types), and both operands are converted to this type.
- -- The Etype of the result is also set to this value. However, the result
- -- can never overflow Integer_64, so this is the largest type that is ever
- -- generated. On return, the resulting node is analyzed and has Etype set.
+ -- long enough to hold the product and both operands are converted to this
+ -- type. The type of the result is also set to this value. On return, the
+ -- resulting node has its Etype set.
function Build_Rem (N : Node_Id; L, R : Node_Id) return Node_Id;
-- Builds an N_Op_Rem node from the given left and right operand
@@ -127,7 +125,7 @@ package body Exp_Fixd is
-- operand with the smaller sized type to match the type of the other
-- operand and sets this as the result type. The result is never rounded
-- (rem operations cannot be rounded in any case). On return, the resulting
- -- node is analyzed and has its Etype set.
+ -- node has its Etype set.
function Build_Scaled_Divide
(N : Node_Id;
@@ -135,7 +133,7 @@ package body Exp_Fixd is
-- Returns a node corresponding to the value X*Y/Z using the source
-- location from Sloc (N). The division is rounded if the Rounded_Result
-- flag of N is set. The integer types of X, Y, Z may be different. On
- -- return the resulting node is analyzed and has is Etype set.
+ -- return the resulting node has its Etype set.
procedure Build_Scaled_Divide_Code
(N : Node_Id;
@@ -194,12 +192,13 @@ package body Exp_Fixd is
V : Uint;
Negative : Boolean := False) return Node_Id;
-- Given a non-negative universal integer value, build a typed integer
- -- literal node, using the smallest applicable standard integer type. If
- -- and only if Negative is true a negative literal is built. If V exceeds
- -- 2**63-1, the largest value allowed for perfect result set scaling
- -- factors (see RM G.2.3(22)), then Empty is returned. The node N provides
- -- the Sloc value for the constructed literal. The Etype of the resulting
- -- literal is correctly set, and it is marked as analyzed.
+ -- literal node, using the smallest applicable standard integer type.
+ -- If Negative is true, then a negative literal is built. If V exceeds
+ -- 2**(System_Max_Integer_Size - 1) - 1, the largest value allowed for
+ -- perfect result set scaling factors (see RM G.2.3(22)), then Empty is
+ -- returned. The node N provides the Sloc value for the constructed
+ -- literal. The Etype of the resulting literal is correctly set, and it
+ -- is marked as analyzed.
function Real_Literal (N : Node_Id; V : Ureal) return Node_Id;
-- Build a real literal node from the given value, the Etype of the
@@ -347,11 +346,12 @@ package body Exp_Fixd is
return L;
end if;
+ -- Otherwise we need to figure out the correct result type size
-- First figure out the effective sizes of the operands. Normally
-- the effective size of an operand is the RM_Size of the operand.
-- But a special case arises with operands whose size is known at
-- compile time. In this case, we can use the actual value of the
- -- operand to get its size if it would fit signed in 8 or 16 bits.
+ -- operand to get its size if it would fit in signed 8/16/32 bits.
Left_Size := UI_To_Int (RM_Size (Left_Type));
@@ -359,10 +359,12 @@ package body Exp_Fixd is
declare
Val : constant Uint := Expr_Value (L);
begin
- if Val < Int'(2 ** 7) then
+ if Val < Uint_2 ** 7 then
Left_Size := 8;
- elsif Val < Int'(2 ** 15) then
+ elsif Val < Uint_2 ** 15 then
Left_Size := 16;
+ elsif Val < Uint_2 ** 31 then
+ Left_Size := 32;
end if;
end;
end if;
@@ -394,8 +396,11 @@ package body Exp_Fixd is
elsif Rsize <= 32 then
Result_Type := Standard_Integer_32;
- else
+ elsif Rsize <= 64 or else System_Max_Integer_Size < 128 then
Result_Type := Standard_Integer_64;
+
+ else
+ Result_Type := Standard_Integer_128;
end if;
Rnode :=
@@ -411,13 +416,9 @@ package body Exp_Fixd is
-- The result is rounded if the target of the operation is decimal
-- and Rounded_Result is set, or if the target of the operation
- -- is an integer type.
+ -- is an integer type, as determined by Rounded_Result_Set.
- if Is_Integer_Type (Etype (N))
- or else Rounded_Result_Set (N)
- then
- Set_Rounded_Result (Rnode);
- end if;
+ Set_Rounded_Result (Rnode, Rounded_Result_Set (N));
-- One more check. We did the divide operation using the longer of
-- the two sizes, which is reasonable. However, in the case where the
@@ -441,23 +442,29 @@ package body Exp_Fixd is
(N : Node_Id;
X, Y, Z : Node_Id) return Node_Id
is
- Y_Size : constant Nat := UI_To_Int (Esize (Etype (Y)));
- Z_Size : constant Nat := UI_To_Int (Esize (Etype (Z)));
+ X_Size : constant Nat := UI_To_Int (RM_Size (Etype (X)));
+ Y_Size : constant Nat := UI_To_Int (RM_Size (Etype (Y)));
+ Z_Size : constant Nat := UI_To_Int (RM_Size (Etype (Z)));
+ D_Size : constant Nat := Y_Size + Z_Size;
+ M_Size : constant Nat := Nat'Max (X_Size, Nat'Max (Y_Size, Z_Size));
Expr : Node_Id;
begin
- -- If denominator fits in 64 bits, we can build the operations directly
- -- without causing any intermediate overflow, so that's what we do.
+ -- If the denominator fits in Max_Integer_Size bits, we can build the
+ -- operations directly without causing any intermediate overflow. But
+ -- for backward compatibility reasons, we use a 128-bit divide only
+ -- if one of the operands is already larger than 64 bits.
- if Nat'Max (Y_Size, Z_Size) <= 32 then
- return
- Build_Divide (N, X, Build_Multiply (N, Y, Z));
+ if D_Size <= System_Max_Integer_Size
+ and then (D_Size <= 64 or else M_Size > 64)
+ then
+ return Build_Divide (N, X, Build_Multiply (N, Y, Z));
-- Otherwise we use the runtime routine
- -- [Qnn : Interfaces.Integer_64,
- -- Rnn : Interfaces.Integer_64;
- -- Double_Divide (X, Y, Z, Qnn, Rnn, Round);
+ -- [Qnn : Interfaces.Integer_{64|128};
+ -- Rnn : Interfaces.Integer_{64|128};
+ -- Double_Divide{64|128} (X, Y, Z, Qnn, Rnn, Round);
-- Qnn]
else
@@ -489,18 +496,18 @@ package body Exp_Fixd is
-- Build_Double_Divide_Code --
------------------------------
- -- If the denominator can be computed in 64-bits, we build
+ -- If the denominator can be computed in Max_Integer_Size bits, we build
-- [Nnn : constant typ := typ (X);
-- Dnn : constant typ := typ (Y) * typ (Z)
-- Qnn : constant typ := Nnn / Dnn;
- -- Rnn : constant typ := Nnn / Dnn;
+ -- Rnn : constant typ := Nnn rem Dnn;
- -- If the numerator cannot be computed in 64 bits, we build
+ -- If the denominator cannot be computed in Max_Integer_Size bits, we build
- -- [Qnn : typ;
- -- Rnn : typ;
- -- Double_Divide (X, Y, Z, Qnn, Rnn, Round);]
+ -- [Qnn : Interfaces.Integer_{64|128};
+ -- Rnn : Interfaces.Integer_{64|128};
+ -- Double_Divide{64|128} (X, Y, Z, Qnn, Rnn, Round);]
procedure Build_Double_Divide_Code
(N : Node_Id;
@@ -510,10 +517,12 @@ package body Exp_Fixd is
is
Loc : constant Source_Ptr := Sloc (N);
- X_Size : constant Nat := UI_To_Int (Esize (Etype (X)));
- Y_Size : constant Nat := UI_To_Int (Esize (Etype (Y)));
- Z_Size : constant Nat := UI_To_Int (Esize (Etype (Z)));
+ X_Size : constant Nat := UI_To_Int (RM_Size (Etype (X)));
+ Y_Size : constant Nat := UI_To_Int (RM_Size (Etype (Y)));
+ Z_Size : constant Nat := UI_To_Int (RM_Size (Etype (Z)));
+ M_Size : constant Nat := Nat'Max (X_Size, Nat'Max (Y_Size, Z_Size));
+ QR_Id : RE_Id;
QR_Siz : Nat;
QR_Typ : Entity_Id;
@@ -524,22 +533,36 @@ package body Exp_Fixd is
Rnd : Entity_Id;
begin
- -- Find type that will allow computation of numerator
+ -- Find type that will allow computation of denominator
- QR_Siz := Nat'Max (X_Size, 2 * Nat'Max (Y_Size, Z_Size));
+ QR_Siz := Nat'Max (X_Size, Y_Size + Z_Size);
if QR_Siz <= 16 then
QR_Typ := Standard_Integer_16;
+ QR_Id := RE_Null;
+
elsif QR_Siz <= 32 then
QR_Typ := Standard_Integer_32;
+ QR_Id := RE_Null;
+
elsif QR_Siz <= 64 then
QR_Typ := Standard_Integer_64;
+ QR_Id := RE_Null;
- -- For more than 64, bits, we use the 64-bit integer defined in
- -- Interfaces, so that it can be handled by the runtime routine.
+ -- For backward compatibility reasons, we use a 128-bit divide only
+ -- if one of the operands is already larger than 64 bits.
- else
+ elsif System_Max_Integer_Size < 128 or else M_Size <= 64 then
QR_Typ := RTE (RE_Integer_64);
+ QR_Id := RE_Double_Divide64;
+
+ elsif QR_Siz <= 128 then
+ QR_Typ := Standard_Integer_128;
+ QR_Id := RE_Null;
+
+ else
+ QR_Typ := RTE (RE_Integer_128);
+ QR_Id := RE_Double_Divide128;
end if;
-- Define quotient and remainder, and set their Etypes, so
@@ -551,9 +574,9 @@ package body Exp_Fixd is
Set_Etype (Qnn, QR_Typ);
Set_Etype (Rnn, QR_Typ);
- -- Case that we can compute the denominator in 64 bits
+ -- Case where we can compute the denominator in Max_Integer_Size bits
- if QR_Siz <= 64 then
+ if QR_Id = RE_Null then
-- Create temporaries for numerator and denominator and set Etypes,
-- so that New_Occurrence_Of picks them up for Build_xxx calls.
@@ -569,16 +592,13 @@ package body Exp_Fixd is
Defining_Identifier => Nnn,
Object_Definition => New_Occurrence_Of (QR_Typ, Loc),
Constant_Present => True,
- Expression => Build_Conversion (N, QR_Typ, X)),
+ Expression => Build_Conversion (N, QR_Typ, X)),
Make_Object_Declaration (Loc,
Defining_Identifier => Dnn,
Object_Definition => New_Occurrence_Of (QR_Typ, Loc),
Constant_Present => True,
- Expression =>
- Build_Multiply (N,
- Build_Conversion (N, QR_Typ, Y),
- Build_Conversion (N, QR_Typ, Z))));
+ Expression => Build_Multiply (N, Y, Z)));
Quo :=
Build_Divide (N,
@@ -604,8 +624,8 @@ package body Exp_Fixd is
New_Occurrence_Of (Nnn, Loc),
New_Occurrence_Of (Dnn, Loc))));
- -- Case where denominator does not fit in 64 bits, so we have to
- -- call the runtime routine to compute the quotient and remainder
+ -- Case where denominator does not fit in Max_Integer_Size bits, we have
+ -- to call the runtime routine to compute the quotient and remainder.
else
Rnd := Boolean_Literals (Rounded_Result_Set (N));
@@ -620,7 +640,7 @@ package body Exp_Fixd is
Object_Definition => New_Occurrence_Of (QR_Typ, Loc)),
Make_Procedure_Call_Statement (Loc,
- Name => New_Occurrence_Of (RTE (RE_Double_Divide64), Loc),
+ Name => New_Occurrence_Of (RTE (QR_Id), Loc),
Parameter_Associations => New_List (
Build_Conversion (N, QR_Typ, X),
Build_Conversion (N, QR_Typ, Y),
@@ -674,7 +694,7 @@ package body Exp_Fixd is
-- the effective size of an operand is the RM_Size of the operand.
-- But a special case arises with operands whose size is known at
-- compile time. In this case, we can use the actual value of the
- -- operand to get its size if it would fit signed in 8 or 16 bits.
+ -- operand to get its size if it would fit in signed 8/16/32 bits.
Left_Size := UI_To_Int (RM_Size (Left_Type));
@@ -682,10 +702,12 @@ package body Exp_Fixd is
declare
Val : constant Uint := Expr_Value (L);
begin
- if Val < Int'(2 ** 7) then
+ if Val < Uint_2 ** 7 then
Left_Size := 8;
- elsif Val < Int'(2 ** 15) then
+ elsif Val < Uint_2 ** 15 then
Left_Size := 16;
+ elsif Val < Uint_2 ** 31 then
+ Left_Size := 32;
end if;
end;
end if;
@@ -704,10 +726,10 @@ package body Exp_Fixd is
end;
end if;
- -- Now the result size must be at least twice the longer of
- -- the two sizes, to accommodate all possible results.
+ -- Now the result size must be at least the sum of the two sizes,
+ -- to accommodate all possible results.
- Rsize := 2 * Int'Max (Left_Size, Right_Size);
+ Rsize := Left_Size + Right_Size;
if Rsize <= 8 then
Result_Type := Standard_Integer_8;
@@ -718,8 +740,11 @@ package body Exp_Fixd is
elsif Rsize <= 32 then
Result_Type := Standard_Integer_32;
- else
+ elsif Rsize <= 64 or else System_Max_Integer_Size < 128 then
Result_Type := Standard_Integer_64;
+
+ else
+ Result_Type := Standard_Integer_128;
end if;
Rnode :=
@@ -805,23 +830,29 @@ package body Exp_Fixd is
(N : Node_Id;
X, Y, Z : Node_Id) return Node_Id
is
- X_Size : constant Nat := UI_To_Int (Esize (Etype (X)));
- Y_Size : constant Nat := UI_To_Int (Esize (Etype (Y)));
+ X_Size : constant Nat := UI_To_Int (RM_Size (Etype (X)));
+ Y_Size : constant Nat := UI_To_Int (RM_Size (Etype (Y)));
+ Z_Size : constant Nat := UI_To_Int (RM_Size (Etype (Z)));
+ N_Size : constant Nat := X_Size + Y_Size;
+ M_Size : constant Nat := Nat'Max (X_Size, Nat'Max (Y_Size, Z_Size));
Expr : Node_Id;
begin
- -- If numerator fits in 64 bits, we can build the operations directly
- -- without causing any intermediate overflow, so that's what we do.
+ -- If the numerator fits in Max_Integer_Size bits, we can build the
+ -- operations directly without causing any intermediate overflow. But
+ -- for backward compatibility reasons, we use a 128-bit divide only
+ -- if one of the operands is already larger than 64 bits.
- if Nat'Max (X_Size, Y_Size) <= 32 then
- return
- Build_Divide (N, Build_Multiply (N, X, Y), Z);
+ if N_Size <= System_Max_Integer_Size
+ and then (N_Size <= 64 or else M_Size > 64)
+ then
+ return Build_Divide (N, Build_Multiply (N, X, Y), Z);
-- Otherwise we use the runtime routine
- -- [Qnn : Integer_64,
- -- Rnn : Integer_64;
- -- Scaled_Divide (X, Y, Z, Qnn, Rnn, Round);
+ -- [Qnn : Integer_{64|128},
+ -- Rnn : Integer_{64|128};
+ -- Scaled_Divide{64|128} (X, Y, Z, Qnn, Rnn, Round);
-- Qnn]
else
@@ -850,18 +881,18 @@ package body Exp_Fixd is
-- Build_Scaled_Divide_Code --
------------------------------
- -- If the numerator can be computed in 64-bits, we build
+ -- If the numerator can be computed in Max_Integer_Size bits, we build
-- [Nnn : constant typ := typ (X) * typ (Y);
-- Dnn : constant typ := typ (Z)
-- Qnn : constant typ := Nnn / Dnn;
- -- Rnn : constant typ := Nnn / Dnn;
+ -- Rnn : constant typ := Nnn rem Dnn;
- -- If the numerator cannot be computed in 64 bits, we build
+ -- If the numerator cannot be computed in Max_Integer_Size bits, we build
- -- [Qnn : Interfaces.Integer_64;
- -- Rnn : Interfaces.Integer_64;
- -- Scaled_Divide (X, Y, Z, Qnn, Rnn, Round);]
+ -- [Qnn : Interfaces.Integer_{64|128};
+ -- Rnn : Interfaces.Integer_{64|128};
+ -- Scaled_Divide_{64|128} (X, Y, Z, Qnn, Rnn, Round);]
procedure Build_Scaled_Divide_Code
(N : Node_Id;
@@ -871,10 +902,12 @@ package body Exp_Fixd is
is
Loc : constant Source_Ptr := Sloc (N);
- X_Size : constant Nat := UI_To_Int (Esize (Etype (X)));
- Y_Size : constant Nat := UI_To_Int (Esize (Etype (Y)));
- Z_Size : constant Nat := UI_To_Int (Esize (Etype (Z)));
+ X_Size : constant Nat := UI_To_Int (RM_Size (Etype (X)));
+ Y_Size : constant Nat := UI_To_Int (RM_Size (Etype (Y)));
+ Z_Size : constant Nat := UI_To_Int (RM_Size (Etype (Z)));
+ M_Size : constant Nat := Nat'Max (X_Size, Nat'Max (Y_Size, Z_Size));
+ QR_Id : RE_Id;
QR_Siz : Nat;
QR_Typ : Entity_Id;
@@ -887,20 +920,34 @@ package body Exp_Fixd is
begin
-- Find type that will allow computation of numerator
- QR_Siz := Nat'Max (X_Size, 2 * Nat'Max (Y_Size, Z_Size));
+ QR_Siz := Nat'Max (X_Size + Y_Size, Z_Size);
if QR_Siz <= 16 then
QR_Typ := Standard_Integer_16;
+ QR_Id := RE_Null;
+
elsif QR_Siz <= 32 then
QR_Typ := Standard_Integer_32;
+ QR_Id := RE_Null;
+
elsif QR_Siz <= 64 then
QR_Typ := Standard_Integer_64;
+ QR_Id := RE_Null;
- -- For more than 64, bits, we use the 64-bit integer defined in
- -- Interfaces, so that it can be handled by the runtime routine.
+ -- For backward compatibility reasons, we use a 128-bit divide only
+ -- if one of the operands is already larger than 64 bits.
- else
+ elsif System_Max_Integer_Size < 128 or else M_Size <= 64 then
QR_Typ := RTE (RE_Integer_64);
+ QR_Id := RE_Scaled_Divide64;
+
+ elsif QR_Siz <= 128 then
+ QR_Typ := Standard_Integer_128;
+ QR_Id := RE_Null;
+
+ else
+ QR_Typ := RTE (RE_Integer_128);
+ QR_Id := RE_Scaled_Divide128;
end if;
-- Define quotient and remainder, and set their Etypes, so
@@ -912,9 +959,9 @@ package body Exp_Fixd is
Set_Etype (Qnn, QR_Typ);
Set_Etype (Rnn, QR_Typ);
- -- Case that we can compute the numerator in 64 bits
+ -- Case where we can compute the numerator in Max_Integer_Size bits
- if QR_Siz <= 64 then
+ if QR_Id = RE_Null then
Nnn := Make_Temporary (Loc, 'N');
Dnn := Make_Temporary (Loc, 'D');
@@ -928,16 +975,13 @@ package body Exp_Fixd is
Defining_Identifier => Nnn,
Object_Definition => New_Occurrence_Of (QR_Typ, Loc),
Constant_Present => True,
- Expression =>
- Build_Multiply (N,
- Build_Conversion (N, QR_Typ, X),
- Build_Conversion (N, QR_Typ, Y))),
+ Expression => Build_Multiply (N, X, Y)),
Make_Object_Declaration (Loc,
Defining_Identifier => Dnn,
Object_Definition => New_Occurrence_Of (QR_Typ, Loc),
Constant_Present => True,
- Expression => Build_Conversion (N, QR_Typ, Z)));
+ Expression => Build_Conversion (N, QR_Typ, Z)));
Quo :=
Build_Divide (N,
@@ -961,8 +1005,8 @@ package body Exp_Fixd is
New_Occurrence_Of (Nnn, Loc),
New_Occurrence_Of (Dnn, Loc))));
- -- Case where numerator does not fit in 64 bits, so we have to
- -- call the runtime routine to compute the quotient and remainder
+ -- Case where numerator does not fit in Max_Integer_Size bits, we have
+ -- to call the runtime routine to compute the quotient and remainder.
else
Rnd := Boolean_Literals (Rounded_Result_Set (N));
@@ -977,7 +1021,7 @@ package body Exp_Fixd is
Object_Definition => New_Occurrence_Of (QR_Typ, Loc)),
Make_Procedure_Call_Statement (Loc,
- Name => New_Occurrence_Of (RTE (RE_Scaled_Divide64), Loc),
+ Name => New_Occurrence_Of (RTE (QR_Id), Loc),
Parameter_Associations => New_List (
Build_Conversion (N, QR_Typ, X),
Build_Conversion (N, QR_Typ, Y),
@@ -1374,8 +1418,7 @@ package body Exp_Fixd is
if Present (Lit_Int) then
Set_Result (N,
- Build_Multiply (N, Build_Multiply (N, Left, Right),
- Lit_Int));
+ Build_Multiply (N, Build_Multiply (N, Left, Right), Lit_Int));
return;
end if;
@@ -1546,6 +1589,10 @@ package body Exp_Fixd is
-- If the small ratio is the reciprocal of a sufficiently small integer,
-- then the perfect result set is obtained by a single integer division.
+ -- If the numerator and denominator of the small ratio are sufficiently
+ -- small integers, then the perfect result set is obtained by a scaled
+ -- divide operation.
+
-- In other cases, we obtain the close result set by calculating the
-- result in floating-point.
@@ -1557,7 +1604,8 @@ package body Exp_Fixd is
Small_Ratio : Ureal;
Ratio_Num : Uint;
Ratio_Den : Uint;
- Lit : Node_Id;
+ Lit_Num : Node_Id;
+ Lit_Den : Node_Id;
begin
if Is_OK_Static_Expression (Expr) then
@@ -1575,26 +1623,36 @@ package body Exp_Fixd is
return;
else
- Lit := Integer_Literal (N, Ratio_Num);
+ Lit_Num := Integer_Literal (N, Ratio_Num);
- if Present (Lit) then
- Set_Result (N, Build_Multiply (N, Expr, Lit));
+ if Present (Lit_Num) then
+ Set_Result (N, Build_Multiply (N, Expr, Lit_Num));
return;
end if;
end if;
elsif Ratio_Num = 1 then
- Lit := Integer_Literal (N, Ratio_Den);
+ Lit_Den := Integer_Literal (N, Ratio_Den);
+
+ if Present (Lit_Den) then
+ Set_Result (N, Build_Divide (N, Expr, Lit_Den), Rng_Check);
+ return;
+ end if;
+
+ else
+ Lit_Num := Integer_Literal (N, Ratio_Num);
+ Lit_Den := Integer_Literal (N, Ratio_Den);
- if Present (Lit) then
- Set_Result (N, Build_Divide (N, Expr, Lit), Rng_Check);
+ if Present (Lit_Num) and then Present (Lit_Den) then
+ Set_Result
+ (N, Build_Scaled_Divide (N, Expr, Lit_Num, Lit_Den), Rng_Check);
return;
end if;
end if;
- -- Fall through to use floating-point for the close result set case
- -- either as a result of the small ratio not being an integer or the
- -- reciprocal of an integer, or if the integer is out of range.
+ -- Fall through to use floating-point for the close result set case,
+ -- as a result of the numerator or denominator of the small ratio not
+ -- being a sufficiently small integer.
Set_Result (N,
Build_Multiply (N,
@@ -1650,6 +1708,10 @@ package body Exp_Fixd is
-- If the small value is the reciprocal of a sufficiently small integer,
-- then the perfect result set is obtained by a single integer division.
+ -- If the numerator and denominator of the small value are sufficiently
+ -- small integers, then the perfect result set is obtained by a scaled
+ -- divide operation.
+
-- In other cases, we obtain the close result set by calculating the
-- result in floating-point.
@@ -1660,7 +1722,8 @@ package body Exp_Fixd is
Small : constant Ureal := Small_Value (Source_Type);
Small_Num : constant Uint := Norm_Num (Small);
Small_Den : constant Uint := Norm_Den (Small);
- Lit : Node_Id;
+ Lit_Num : Node_Id;
+ Lit_Den : Node_Id;
begin
if Is_OK_Static_Expression (Expr) then
@@ -1669,25 +1732,35 @@ package body Exp_Fixd is
end if;
if Small_Den = 1 then
- Lit := Integer_Literal (N, Small_Num);
+ Lit_Num := Integer_Literal (N, Small_Num);
- if Present (Lit) then
- Set_Result (N, Build_Multiply (N, Expr, Lit), Rng_Check);
+ if Present (Lit_Num) then
+ Set_Result (N, Build_Multiply (N, Expr, Lit_Num), Rng_Check);
return;
end if;
elsif Small_Num = 1 then
- Lit := Integer_Literal (N, Small_Den);
+ Lit_Den := Integer_Literal (N, Small_Den);
+
+ if Present (Lit_Den) then
+ Set_Result (N, Build_Divide (N, Expr, Lit_Den), Rng_Check);
+ return;
+ end if;
+
+ else
+ Lit_Num := Integer_Literal (N, Small_Num);
+ Lit_Den := Integer_Literal (N, Small_Den);
- if Present (Lit) then
- Set_Result (N, Build_Divide (N, Expr, Lit), Rng_Check);
+ if Present (Lit_Num) and then Present (Lit_Den) then
+ Set_Result
+ (N, Build_Scaled_Divide (N, Expr, Lit_Num, Lit_Den), Rng_Check);
return;
end if;
end if;
- -- Fall through to use floating-point for the close result set case
- -- either as a result of the small value not being an integer or the
- -- reciprocal of an integer, or if the integer is out of range.
+ -- Fall through to use floating-point for the close result set case,
+ -- as a result of the numerator or denominator of the small value not
+ -- being a sufficiently small integer.
Set_Result (N,
Build_Multiply (N,
@@ -1714,11 +1787,9 @@ package body Exp_Fixd is
procedure Expand_Convert_Float_To_Fixed (N : Node_Id) is
Expr : constant Node_Id := Expression (N);
- Orig_N : constant Node_Id := Original_Node (N);
Result_Type : constant Entity_Id := Etype (N);
Rng_Check : constant Boolean := Do_Range_Check (N);
Small : constant Ureal := Small_Value (Result_Type);
- Truncate : Boolean;
begin
-- Optimize small = 1, where we can avoid the multiply completely
@@ -1733,15 +1804,6 @@ package body Exp_Fixd is
-- round.
else
- if Is_Decimal_Fixed_Point_Type (Result_Type) then
- Truncate :=
- Nkind (Orig_N) /= N_Attribute_Reference
- or else Get_Attribute_Id
- (Attribute_Name (Orig_N)) /= Attribute_Round;
- else
- Truncate := False;
- end if;
-
Set_Result
(N => N,
Expr =>
@@ -1750,7 +1812,8 @@ package body Exp_Fixd is
L => Fpt_Value (Expr),
R => Real_Literal (N, Ureal_1 / Small)),
Rchk => Rng_Check,
- Trunc => Truncate);
+ Trunc => Is_Decimal_Fixed_Point_Type (Result_Type)
+ and not Rounded_Result (N));
end if;
end Expand_Convert_Float_To_Fixed;
@@ -1769,6 +1832,10 @@ package body Exp_Fixd is
-- If the small value is the reciprocal of a sufficiently small integer,
-- the perfect result set is obtained by a single integer multiplication.
+ -- If the numerator and denominator of the small value are sufficiently
+ -- small integers, then the perfect result set is obtained by a scaled
+ -- divide operation.
+
-- In other cases, we obtain the close result set by calculating the
-- result in floating-point using a multiplication by the reciprocal
-- of the Result_Small.
@@ -1780,29 +1847,40 @@ package body Exp_Fixd is
Small : constant Ureal := Small_Value (Result_Type);
Small_Num : constant Uint := Norm_Num (Small);
Small_Den : constant Uint := Norm_Den (Small);
- Lit : Node_Id;
+ Lit_Num : Node_Id;
+ Lit_Den : Node_Id;
begin
if Small_Den = 1 then
- Lit := Integer_Literal (N, Small_Num);
+ Lit_Num := Integer_Literal (N, Small_Num);
- if Present (Lit) then
- Set_Result (N, Build_Divide (N, Expr, Lit), Rng_Check);
+ if Present (Lit_Num) then
+ Set_Result (N, Build_Divide (N, Expr, Lit_Num), Rng_Check);
return;
end if;
elsif Small_Num = 1 then
- Lit := Integer_Literal (N, Small_Den);
+ Lit_Den := Integer_Literal (N, Small_Den);
- if Present (Lit) then
- Set_Result (N, Build_Multiply (N, Expr, Lit), Rng_Check);
+ if Present (Lit_Den) then
+ Set_Result (N, Build_Multiply (N, Expr, Lit_Den), Rng_Check);
+ return;
+ end if;
+
+ else
+ Lit_Num := Integer_Literal (N, Small_Num);
+ Lit_Den := Integer_Literal (N, Small_Den);
+
+ if Present (Lit_Num) and then Present (Lit_Den) then
+ Set_Result
+ (N, Build_Scaled_Divide (N, Expr, Lit_Den, Lit_Num), Rng_Check);
return;
end if;
end if;
- -- Fall through to use floating-point for the close result set case
- -- either as a result of the small value not being an integer or the
- -- reciprocal of an integer, or if the integer is out of range.
+ -- Fall through to use floating-point for the close result set case,
+ -- as a result of the numerator or denominator of the small value not
+ -- being a sufficiently small integer.
Set_Result (N,
Build_Multiply (N,
@@ -2014,13 +2092,6 @@ package body Exp_Fixd is
Right : constant Node_Id := Right_Opnd (N);
begin
- -- Suppress expansion of a fixed-by-fixed division if the
- -- operation is supported directly by the target.
-
- if Target_Has_Fixed_Ops (Etype (Left), Etype (Right), Etype (N)) then
- return;
- end if;
-
if Etype (Left) = Universal_Real then
Do_Divide_Universal_Fixed (N);
@@ -2184,13 +2255,6 @@ package body Exp_Fixd is
-- Start of processing for Expand_Multiply_Fixed_By_Fixed_Giving_Fixed
begin
- -- Suppress expansion of a fixed-by-fixed multiplication if the
- -- operation is supported directly by the target.
-
- if Target_Has_Fixed_Ops (Etype (Left), Etype (Right), Etype (N)) then
- return;
- end if;
-
if Etype (Left) = Universal_Real then
if Nkind (Left) = N_Real_Literal then
Do_Multiply_Fixed_Universal (N, Left => Right, Right => Left);
@@ -2380,6 +2444,9 @@ package body Exp_Fixd is
elsif V < Uint_2 ** 63 then
T := Standard_Integer_64;
+ elsif V < Uint_2 ** 127 and then System_Max_Integer_Size = 128 then
+ T := Standard_Integer_128;
+
else
return Empty;
end if;
diff --git a/gcc/ada/exp_imgv.adb b/gcc/ada/exp_imgv.adb
index 40cb514..0cb483b 100644
--- a/gcc/ada/exp_imgv.adb
+++ b/gcc/ada/exp_imgv.adb
@@ -49,11 +49,6 @@ with Urealp; use Urealp;
package body Exp_Imgv is
- function Has_Decimal_Small (E : Entity_Id) return Boolean;
- -- Applies to all entities. True for a Decimal_Fixed_Point_Type, or an
- -- Ordinary_Fixed_Point_Type with a small that is a negative power of ten.
- -- Shouldn't this be in einfo.adb or sem_aux.adb???
-
procedure Rewrite_Object_Image
(N : Node_Id;
Pref : Entity_Id;
@@ -219,21 +214,13 @@ package body Exp_Imgv is
-- xx = Boolean
-- tv = Boolean (Expr)
- -- For signed integer types with size <= Integer'Size
- -- xx = Integer
- -- tv = Integer (Expr)
-
- -- For other signed integer types
- -- xx = Long_Long_Integer
- -- tv = Long_Long_Integer (Expr)
-
- -- For modular types with modulus <= System.Unsigned_Types.Unsigned
- -- xx = Unsigned
- -- tv = System.Unsigned_Types.Unsigned (Expr)
+ -- For signed integer types
+ -- xx = [Long_Long_[Long_]]Integer
+ -- tv = [Long_Long_[Long_]]Integer (Expr)
- -- For other modular integer types
- -- xx = Long_Long_Unsigned
- -- tv = System.Unsigned_Types.Long_Long_Unsigned (Expr)
+ -- For modular types
+ -- xx = [Long_Long_[Long_]]Unsigned
+ -- tv = System.Unsigned_Types.[Long_Long_[Long_]]Unsigned (Expr)
-- For types whose root type is Wide_Character
-- xx = Wide_Character
@@ -249,21 +236,24 @@ package body Exp_Imgv is
-- tv = Long_Long_Float (Expr)
-- pm = typ'Digits (typ = subtype of expression)
- -- For ordinary fixed-point types
+ -- For decimal fixed-point types
+ -- xx = Decimal{32,64,128}
+ -- tv = Integer_{32,64,128} (Expr)? [convert with no scaling]
+ -- pm = typ'Scale (typ = subtype of expression)
+
+ -- For the most common ordinary fixed-point types
+ -- xx = Fixed{32,64,128}
+ -- tv = Integer_{32,64,128} (Expr) [convert with no scaling]
+ -- pm = numerator of typ'Small (typ = subtype of expression)
+ -- denominator of typ'Small
+ -- (Integer_{32,64,128} x typ'Small)'Fore
+ -- typ'Aft
+
+ -- For other ordinary fixed-point types
-- xx = Ordinary_Fixed_Point
-- tv = Long_Long_Float (Expr)
-- pm = typ'Aft (typ = subtype of expression)
- -- For decimal fixed-point types with size = Integer'Size
- -- xx = Decimal
- -- tv = Integer (Expr)
- -- pm = typ'Scale (typ = subtype of expression)
-
- -- For decimal fixed-point types with size > Integer'Size
- -- xx = Long_Long_Decimal
- -- tv = Long_Long_Integer?(Expr) [convert with no scaling]
- -- pm = typ'Scale (typ = subtype of expression)
-
-- For enumeration types other than those declared in package Standard
-- or System, Snn, Pnn, are expanded as above, but the call looks like:
@@ -593,18 +583,58 @@ package body Exp_Imgv is
Tent := RTE (RE_Long_Long_Long_Unsigned);
end if;
- elsif Is_Fixed_Point_Type (Rtyp) and then Has_Decimal_Small (Rtyp) then
- if UI_To_Int (Esize (Rtyp)) <= Standard_Integer_Size then
- Imid := RE_Image_Decimal;
- Tent := Standard_Integer;
+ elsif Is_Decimal_Fixed_Point_Type (Rtyp) then
+ if Esize (Rtyp) <= 32 then
+ Imid := RE_Image_Decimal32;
+ Tent := RTE (RE_Integer_32);
+ elsif Esize (Rtyp) <= 64 then
+ Imid := RE_Image_Decimal64;
+ Tent := RTE (RE_Integer_64);
else
- Imid := RE_Image_Long_Long_Decimal;
- Tent := Standard_Long_Long_Integer;
+ Imid := RE_Image_Decimal128;
+ Tent := RTE (RE_Integer_128);
end if;
elsif Is_Ordinary_Fixed_Point_Type (Rtyp) then
- Imid := RE_Image_Ordinary_Fixed_Point;
- Tent := Standard_Long_Long_Float;
+ declare
+ Num : constant Uint := Norm_Num (Small_Value (Rtyp));
+ Den : constant Uint := Norm_Den (Small_Value (Rtyp));
+ Max : constant Uint := UI_Max (Num, Den);
+ Min : constant Uint := UI_Min (Num, Den);
+ Siz : constant Uint := Esize (Rtyp);
+
+ begin
+ -- Note that we do not use sharp bounds to speed things up
+
+ if Siz <= 32
+ and then Max <= Uint_2 ** 31
+ and then (Min = Uint_1
+ or else (Num < Den and then Den <= Uint_2 ** 27)
+ or else (Den < Num and then Num <= Uint_2 ** 25))
+ then
+ Imid := RE_Image_Fixed32;
+ Tent := RTE (RE_Integer_32);
+ elsif Siz <= 64
+ and then Max <= Uint_2 ** 63
+ and then (Min = Uint_1
+ or else (Num < Den and then Den <= Uint_2 ** 59)
+ or else (Den < Num and then Num <= Uint_2 ** 53))
+ then
+ Imid := RE_Image_Fixed64;
+ Tent := RTE (RE_Integer_64);
+ elsif System_Max_Integer_Size = 128
+ and then Max <= Uint_2 ** 127
+ and then (Min = Uint_1
+ or else (Num < Den and then Den <= Uint_2 ** 123)
+ or else (Den < Num and then Num <= Uint_2 ** 122))
+ then
+ Imid := RE_Image_Fixed128;
+ Tent := RTE (RE_Integer_128);
+ else
+ Imid := RE_Image_Ordinary_Fixed_Point;
+ Tent := Standard_Long_Long_Float;
+ end if;
+ end;
elsif Is_Floating_Point_Type (Rtyp) then
Imid := RE_Image_Floating_Point;
@@ -746,29 +776,45 @@ package body Exp_Imgv is
Prefix => New_Occurrence_Of (Ptyp, Loc),
Attribute_Name => Name_Digits));
- -- For ordinary fixed-point types, append Aft parameter
+ -- For decimal, append Scale and also set to do literal conversion
- elsif Is_Ordinary_Fixed_Point_Type (Rtyp) then
- Append_To (Arg_List,
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Ptyp, Loc),
- Attribute_Name => Name_Aft));
+ elsif Is_Decimal_Fixed_Point_Type (Rtyp) then
+ Set_Conversion_OK (First (Arg_List));
- if Has_Decimal_Small (Rtyp) then
+ Append_To (Arg_List, Make_Integer_Literal (Loc, Scale_Value (Ptyp)));
+
+ -- For ordinary fixed-point types, append Num, Den, Fore, Aft parameters
+ -- and also set to do literal conversion.
+
+ elsif Is_Ordinary_Fixed_Point_Type (Rtyp) then
+ if Imid /= RE_Image_Ordinary_Fixed_Point then
Set_Conversion_OK (First (Arg_List));
- Set_Etype (First (Arg_List), Tent);
- end if;
- -- For decimal, append Scale and also set to do literal conversion
+ Append_To (Arg_List,
+ Make_Integer_Literal (Loc, -Norm_Num (Small_Value (Ptyp))));
- elsif Is_Decimal_Fixed_Point_Type (Rtyp) then
- Append_To (Arg_List,
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Ptyp, Loc),
- Attribute_Name => Name_Scale));
+ Append_To (Arg_List,
+ Make_Integer_Literal (Loc, -Norm_Den (Small_Value (Ptyp))));
- Set_Conversion_OK (First (Arg_List));
- Set_Etype (First (Arg_List), Tent);
+ -- We want to compute the Fore value for the fixed point type
+ -- whose mantissa type is Tent and whose small is typ'Small.
+
+ declare
+ T : Ureal := Uint_2 ** (Esize (Tent) - 1) * Small_Value (Ptyp);
+ F : Nat := 2;
+
+ begin
+ while T >= Ureal_10 loop
+ F := F + 1;
+ T := T / Ureal_10;
+ end loop;
+
+ Append_To (Arg_List,
+ Make_Integer_Literal (Loc, UI_From_Int (F)));
+ end;
+ end if;
+
+ Append_To (Arg_List, Make_Integer_Literal (Loc, Aft_Value (Ptyp)));
-- For Wide_Character, append Ada 2005 indication
@@ -827,20 +873,23 @@ package body Exp_Imgv is
-- For types whose root type is Boolean
-- xx = Boolean
- -- For signed integer types with size <= Integer'Size
- -- xx = Integer
+ -- For signed integer types
+ -- xx = [Long_Long_[Long_]]Integer
+
+ -- For modular types
+ -- xx = [Long_Long_[Long_]]Unsigned
- -- For other signed integer types
- -- xx = Long_Long_Integer
+ -- For floating-point types
+ -- xx = [Long_[Long_]]Float
+
+ -- For decimal fixed-point types, typ'Value (X) expands into
- -- For modular types with modulus <= System.Unsigned_Types.Unsigned
- -- xx = Unsigned
+ -- btyp?(Value_Decimal{32,64,128} (X, typ'Scale));
- -- For other modular integer types
- -- xx = Long_Long_Unsigned
+ -- For the most common ordinary fixed-point types
- -- For floating-point types and ordinary fixed-point types
- -- xx = Real
+ -- 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:
@@ -848,15 +897,6 @@ package body Exp_Imgv is
-- where btyp is the base type of the prefix, and EM is the encoding method
- -- For decimal types with size <= Integer'Size, typ'Value (X)
- -- expands into
-
- -- btyp?(Value_Decimal (X, typ'Scale));
-
- -- For all other decimal types, typ'Value (X) expands into
-
- -- btyp?(Value_Long_Long_Decimal (X, typ'Scale))
-
-- For enumeration types other than those derived from types Boolean,
-- Character, Wide_[Wide_]Character in Standard, typ'Value (X) expands to:
@@ -923,16 +963,15 @@ package body Exp_Imgv is
end if;
elsif Is_Decimal_Fixed_Point_Type (Rtyp) then
- if UI_To_Int (Esize (Rtyp)) <= Standard_Integer_Size then
- Vid := RE_Value_Decimal;
+ if Esize (Rtyp) <= 32 and then abs (Scale_Value (Rtyp)) <= 9 then
+ Vid := RE_Value_Decimal32;
+ elsif Esize (Rtyp) <= 64 and then abs (Scale_Value (Rtyp)) <= 18 then
+ Vid := RE_Value_Decimal64;
else
- Vid := RE_Value_Long_Long_Decimal;
+ Vid := RE_Value_Decimal128;
end if;
- Append_To (Args,
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Typ, Loc),
- Attribute_Name => Name_Scale));
+ Append_To (Args, Make_Integer_Literal (Loc, Scale_Value (Rtyp)));
Rewrite (N,
OK_Convert_To (Btyp,
@@ -944,8 +983,75 @@ package body Exp_Imgv is
Analyze_And_Resolve (N, Btyp);
return;
- elsif Is_Real_Type (Rtyp) then
- Vid := RE_Value_Real;
+ elsif Is_Ordinary_Fixed_Point_Type (Rtyp) then
+ declare
+ Num : constant Uint := Norm_Num (Small_Value (Rtyp));
+ Den : constant Uint := Norm_Den (Small_Value (Rtyp));
+ Max : constant Uint := UI_Max (Num, Den);
+ Min : constant Uint := UI_Min (Num, Den);
+ Siz : constant Uint := Esize (Rtyp);
+
+ begin
+ if Siz <= 32
+ and then Max <= Uint_2 ** 31
+ and then (Min = Uint_1 or else Max <= Uint_2 ** 27)
+ then
+ Vid := RE_Value_Fixed32;
+ elsif Siz <= 64
+ and then Max <= Uint_2 ** 63
+ and then (Min = Uint_1 or else Max <= Uint_2 ** 59)
+ then
+ Vid := RE_Value_Fixed64;
+ elsif System_Max_Integer_Size = 128
+ and then Max <= Uint_2 ** 127
+ and then (Min = Uint_1 or else Max <= Uint_2 ** 123)
+ then
+ Vid := RE_Value_Fixed128;
+ else
+ Vid := RE_Value_Long_Float;
+ end if;
+
+ if Vid /= RE_Value_Long_Float then
+ Append_To (Args,
+ Make_Integer_Literal (Loc, -Norm_Num (Small_Value (Rtyp))));
+
+ Append_To (Args,
+ Make_Integer_Literal (Loc, -Norm_Den (Small_Value (Rtyp))));
+
+ Rewrite (N,
+ OK_Convert_To (Btyp,
+ Make_Function_Call (Loc,
+ Name => New_Occurrence_Of (RTE (Vid), Loc),
+ Parameter_Associations => Args)));
+
+ Set_Etype (N, Btyp);
+ Analyze_And_Resolve (N, Btyp);
+ return;
+ end if;
+ end;
+
+ elsif Is_Floating_Point_Type (Rtyp) then
+ -- Short_Float and Float are the same type for GNAT
+
+ 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
+ Vid := RE_Value_Long_Float;
+
+ elsif Rtyp = Standard_Long_Long_Float then
+ Vid := RE_Value_Long_Long_Float;
+
+ else
+ raise Program_Error;
+ end if;
-- Only other possibility is user-defined enumeration type
@@ -1286,12 +1392,12 @@ package body Exp_Imgv is
-- yy = Boolean
-- For signed integer types
- -- xx = Width_Long_Long_Integer
- -- yy = Long_Long_Integer
+ -- xx = Width_[Long_Long_[Long_]]Integer
+ -- yy = [Long_Long_[Long_]]Integer
-- For modular integer types
- -- xx = Width_Long_Long_Unsigned
- -- yy = Long_Long_Unsigned
+ -- xx = Width_[Long_Long_[Long_]]Unsigned
+ -- yy = [Long_Long_[Long_]]Unsigned
-- For types derived from Wide_Character, typ'Width expands into
@@ -1329,7 +1435,11 @@ package body Exp_Imgv is
-- Wide_Wide_Character (typ'First),
-- Wide_Wide_Character (typ'Last));
- -- For real types, typ'Width and typ'Wide_[Wide_]Width expand into
+ -- For fixed point types, typ'Width and typ'Wide_[Wide_]Width expand into
+
+ -- if Ptyp'First > Ptyp'Last then 0 else Ptyp'Fore + 1 + Ptyp'Aft end if
+
+ -- and for floating point types, they expand into
-- if Ptyp'First > Ptyp'Last then 0 else btyp'Width end if
@@ -1451,9 +1561,41 @@ package body Exp_Imgv is
YY := RTE (RE_Long_Long_Long_Unsigned);
end if;
- -- Real types
+ -- Fixed point types
+
+ elsif Is_Fixed_Point_Type (Rtyp) then
+ Rewrite (N,
+ Make_If_Expression (Loc,
+ Expressions => New_List (
+
+ Make_Op_Gt (Loc,
+ Left_Opnd =>
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Ptyp, Loc),
+ Attribute_Name => Name_First),
+
+ Right_Opnd =>
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Ptyp, Loc),
+ Attribute_Name => Name_Last)),
- elsif Is_Real_Type (Rtyp) then
+ Make_Integer_Literal (Loc, 0),
+
+ Make_Op_Add (Loc,
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Ptyp, Loc),
+ Attribute_Name => Name_Fore),
+
+ Make_Op_Add (Loc,
+ Make_Integer_Literal (Loc, 1),
+ Make_Integer_Literal (Loc, Aft_Value (Ptyp)))))));
+
+ Analyze_And_Resolve (N, Typ);
+ return;
+
+ -- Floating point types
+
+ elsif Is_Floating_Point_Type (Rtyp) then
Rewrite (N,
Make_If_Expression (Loc,
Expressions => New_List (
@@ -1680,18 +1822,6 @@ package body Exp_Imgv is
Analyze_And_Resolve (N, Typ);
end Expand_Width_Attribute;
- -----------------------
- -- Has_Decimal_Small --
- -----------------------
-
- function Has_Decimal_Small (E : Entity_Id) return Boolean is
- begin
- return Is_Decimal_Fixed_Point_Type (E)
- or else
- (Is_Ordinary_Fixed_Point_Type (E)
- and then Ureal_10**Aft_Value (E) * Small_Value (E) = Ureal_1);
- end Has_Decimal_Small;
-
--------------------------
-- Rewrite_Object_Image --
--------------------------
diff --git a/gcc/ada/exp_intr.adb b/gcc/ada/exp_intr.adb
index 78bde89..3be039b 100644
--- a/gcc/ada/exp_intr.adb
+++ b/gcc/ada/exp_intr.adb
@@ -29,7 +29,6 @@ with Einfo; use Einfo;
with Elists; use Elists;
with Expander; use Expander;
with Exp_Atag; use Exp_Atag;
-with Exp_Ch4; use Exp_Ch4;
with Exp_Ch7; use Exp_Ch7;
with Exp_Ch11; use Exp_Ch11;
with Exp_Code; use Exp_Code;
@@ -857,7 +856,7 @@ package body Exp_Intr is
---------------------------
procedure Expand_Unc_Conversion (N : Node_Id; E : Entity_Id) is
- Func : constant Entity_Id := Entity (Name (N));
+ Func : constant Entity_Id := Entity (Name (N));
Conv : Node_Id;
Ftyp : Entity_Id;
Ttyp : Entity_Id;
@@ -908,12 +907,7 @@ package body Exp_Intr is
end if;
Rewrite (N, Unchecked_Convert_To (Ttyp, Conv));
- Set_Etype (N, Ttyp);
- Set_Analyzed (N);
-
- if Nkind (N) = N_Unchecked_Type_Conversion then
- Expand_N_Unchecked_Type_Conversion (N);
- end if;
+ Analyze_And_Resolve (N, Ttyp);
end Expand_Unc_Conversion;
-----------------------------
@@ -1229,9 +1223,8 @@ package body Exp_Intr is
if Is_Class_Wide_Type (Desig_Typ)
or else
- (Is_Array_Type (Desig_Typ)
- and then not Is_Constrained (Desig_Typ)
- and then Is_Packed (Desig_Typ))
+ (Is_Packed_Array (Desig_Typ)
+ and then not Is_Constrained (Desig_Typ))
then
declare
Deref : constant Node_Id :=
diff --git a/gcc/ada/exp_pakd.adb b/gcc/ada/exp_pakd.adb
index 07a05a5..c90409b 100644
--- a/gcc/ada/exp_pakd.adb
+++ b/gcc/ada/exp_pakd.adb
@@ -1256,8 +1256,15 @@ package body Exp_Pakd is
-- array type on Obj to get lost. So we save the type of Obj, and
-- make sure it is reset properly.
- New_Lhs := Duplicate_Subexpr (Obj, Name_Req => True);
- New_Rhs := Duplicate_Subexpr_No_Checks (Obj);
+ declare
+ T : constant Entity_Id := Etype (Obj);
+ begin
+ New_Lhs := Duplicate_Subexpr (Obj, Name_Req => True);
+ New_Rhs := Duplicate_Subexpr_No_Checks (Obj);
+ Set_Etype (Obj, T);
+ Set_Etype (New_Lhs, T);
+ Set_Etype (New_Rhs, T);
+ end;
-- First we deal with the "and"
diff --git a/gcc/ada/exp_prag.adb b/gcc/ada/exp_prag.adb
index 14ccac9..d616fb6 100644
--- a/gcc/ada/exp_prag.adb
+++ b/gcc/ada/exp_prag.adb
@@ -425,7 +425,12 @@ package body Exp_Prag is
-- Generate the appropriate if statement. Note that we consider this to
-- be an explicit conditional in the source, not an implicit if, so we
- -- do not call Make_Implicit_If_Statement.
+ -- do not call Make_Implicit_If_Statement. Note also that we wrap the
+ -- raise statement in a block statement so that, if the condition is
+ -- evaluated at compile time to False, then the rewriting of the if
+ -- statement will not involve the raise but the block statement, and
+ -- thus not leave a dangling reference to the raise statement in the
+ -- Local_Raise_Statements list of the handler.
-- Case where we generate a direct raise
@@ -438,8 +443,14 @@ package body Exp_Prag is
Make_If_Statement (Loc,
Condition => Make_Op_Not (Loc, Right_Opnd => Cond),
Then_Statements => New_List (
- Make_Raise_Statement (Loc,
- Name => New_Occurrence_Of (RTE (RE_Assert_Failure), Loc)))));
+ Make_Block_Statement (Loc,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (
+ Make_Raise_Statement (Loc,
+ Name =>
+ New_Occurrence_Of (RTE (RE_Assert_Failure),
+ Loc))))))));
-- Case where we call the procedure
@@ -778,16 +789,23 @@ package body Exp_Prag is
is
Copy : Entity_Id;
Param : Node_Id;
+ Expr : Node_Id;
begin
Param := First (Params);
while Present (Param) loop
Copy := Make_Temporary (Loc, 'C');
+ if Nkind (Param) = N_Parameter_Association then
+ Expr := Explicit_Actual_Parameter (Param);
+ else
+ Expr := Param;
+ end if;
+
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => Copy,
- Object_Definition => New_Occurrence_Of (Etype (Param), Loc),
- Expression => New_Copy_Tree (Param)));
+ Object_Definition => New_Occurrence_Of (Etype (Expr), Loc),
+ Expression => New_Copy_Tree (Expr)));
Append_Elmt (Copy, Copies);
Next (Param);
@@ -1563,6 +1581,12 @@ package body Exp_Prag is
Expression => Pref));
end if;
+ -- Mark the temporary as coming from a 'Old reference
+
+ if Present (Temp) then
+ Set_Stores_Attribute_Old_Prefix (Temp);
+ end if;
+
-- Ensure that the prefix is valid
if Validity_Checks_On and then Validity_Check_Operands then
diff --git a/gcc/ada/exp_sel.adb b/gcc/ada/exp_sel.adb
index 0fe9d3b..ccf62c6 100644
--- a/gcc/ada/exp_sel.adb
+++ b/gcc/ada/exp_sel.adb
@@ -70,27 +70,11 @@ package body Exp_Sel is
-------------------------------
function Build_Abort_Block_Handler (Loc : Source_Ptr) return Node_Id is
- Stmt : Node_Id;
-
begin
-
- -- With ZCX exceptions, aborts are not defered in handlers. With SJLJ,
- -- they are deferred at the beginning of Abort_Signal handlers.
-
- if ZCX_Exceptions then
- Stmt := Make_Null_Statement (Loc);
-
- else
- Stmt :=
- Make_Procedure_Call_Statement (Loc,
- Name => New_Occurrence_Of (RTE (RE_Abort_Undefer), Loc),
- Parameter_Associations => No_List);
- end if;
-
return Make_Implicit_Exception_Handler (Loc,
Exception_Choices =>
New_List (New_Occurrence_Of (Stand.Abort_Signal, Loc)),
- Statements => New_List (Stmt));
+ Statements => New_List (Make_Null_Statement (Loc)));
end Build_Abort_Block_Handler;
-------------
diff --git a/gcc/ada/exp_sel.ads b/gcc/ada/exp_sel.ads
index 98ac647..f2f2c56 100644
--- a/gcc/ada/exp_sel.ads
+++ b/gcc/ada/exp_sel.ads
@@ -39,21 +39,18 @@ package Exp_Sel is
-- begin
-- Blk
-- exception
- -- when Abort_Signal => Abort_Undefer / null;
+ -- when Abort_Signal => null;
-- end;
-- Abr_Blk_Ent is the name of the generated block, Cln_Blk_Ent is the name
-- of the encapsulated cleanup block, Blk is the actual block name.
-- The exception handler code is built by Build_Abort_Block_Handler.
function Build_Abort_Block_Handler (Loc : Source_Ptr) return Node_Id;
- -- Generate if front-end exception:
- -- when others =>
- -- Abort_Undefer;
- -- or if back-end exception:
+ -- Generate:
-- when others =>
-- null;
-- This is an exception handler to stop propagation of aborts, without
- -- modifying the deferal level.
+ -- modifying the deferral level.
function Build_B
(Loc : Source_Ptr;
diff --git a/gcc/ada/exp_spark.adb b/gcc/ada/exp_spark.adb
index f6ef865..d65136b 100644
--- a/gcc/ada/exp_spark.adb
+++ b/gcc/ada/exp_spark.adb
@@ -52,9 +52,6 @@ package body Exp_SPARK is
-- Local Subprograms --
-----------------------
- procedure Expand_SPARK_N_Aggregate (N : Node_Id);
- -- Perform aggregate-specific expansion
-
procedure Expand_SPARK_N_Attribute_Reference (N : Node_Id);
-- Perform attribute-reference-specific expansion
@@ -105,9 +102,6 @@ package body Exp_SPARK is
=>
Qualify_Entity_Names (N);
- when N_Aggregate =>
- Expand_SPARK_N_Aggregate (N);
-
-- Replace occurrences of System'To_Address by calls to
-- System.Storage_Elements.To_Address.
@@ -227,7 +221,8 @@ package body Exp_SPARK is
if Nkind (Assoc) = N_Iterated_Component_Association then
Push_Scope (Scope (Defining_Identifier (Assoc)));
- Analyze_And_Resolve (Expression (Assoc), Comp_Type);
+ Enter_Name (Defining_Identifier (Assoc));
+ Analyze_And_Resolve (Expr, Comp_Type);
end if;
if Is_Scalar_Type (Comp_Type) then
@@ -240,11 +235,7 @@ package body Exp_SPARK is
End_Scope;
end if;
- Index :=
- First
- (if Nkind (Assoc) = N_Iterated_Component_Association
- then Discrete_Choices (Assoc)
- else Choices (Assoc));
+ Index := First (Choice_List (Assoc));
Index_Typ := First_Index (Typ);
while Present (Index) loop
@@ -366,78 +357,13 @@ package body Exp_SPARK is
-- procedure for it as done during regular expansion for compilation.
if Has_DIC (E) and then Is_Tagged_Type (E) then
- Build_DIC_Procedure_Body (E, For_Freeze => True);
+ -- Why is this needed for DIC, but not for other aspects (such as
+ -- Type_Invariant)???
+
+ Build_DIC_Procedure_Body (E);
end if;
end Expand_SPARK_N_Freeze_Type;
- ------------------------------
- -- Expand_SPARK_N_Aggregate --
- ------------------------------
-
- procedure Expand_SPARK_N_Aggregate (N : Node_Id) is
- Assoc : Node_Id := First (Component_Associations (N));
- begin
- -- For compilation, frontend analyses a copy of the
- -- iterated_component_association's expression for legality checking;
- -- (then the expression is copied again when expanding association into
- -- assignments for the individual choices). For SPARK we analyze the
- -- original expression and apply range checks, if required.
-
- while Present (Assoc) loop
- if Nkind (Assoc) = N_Iterated_Component_Association then
- declare
- Typ : constant Entity_Id := Etype (N);
-
- Comp_Type : constant Entity_Id := Component_Type (Typ);
- Expr : constant Node_Id := Expression (Assoc);
- Index_Typ : constant Entity_Id := First_Index (Typ);
-
- Index : Node_Id;
-
- begin
- -- Analyze expression with index parameter in scope
-
- Push_Scope (Scope (Defining_Identifier (Assoc)));
- Enter_Name (Defining_Identifier (Assoc));
- Analyze_And_Resolve (Expression (Assoc), Comp_Type);
-
- if Is_Scalar_Type (Comp_Type) then
- Apply_Scalar_Range_Check (Expr, Comp_Type);
- end if;
-
- End_Scope;
-
- -- Analyze discrete choices
-
- Index := First (Discrete_Choices (Assoc));
-
- while Present (Index) loop
-
- -- The index denotes a range of elements where range checks
- -- have been already applied.
-
- if Nkind (Index) in N_Others_Choice
- | N_Range
- | N_Subtype_Indication
- then
- null;
-
- -- Otherwise the index denotes a single element (or a
- -- subtype name which doesn't require range checks).
-
- else pragma Assert (Nkind (Index) in N_Subexpr);
- Apply_Scalar_Range_Check (Index, Etype (Index_Typ));
- end if;
-
- Next (Index);
- end loop;
- end;
- end if;
-
- Next (Assoc);
- end loop;
- end Expand_SPARK_N_Aggregate;
-
----------------------------------------
-- Expand_SPARK_N_Attribute_Reference --
----------------------------------------
@@ -451,101 +377,105 @@ package body Exp_SPARK is
Expr : Node_Id;
begin
- if Attr_Id = Attribute_To_Address then
+ case Attr_Id is
+ when Attribute_To_Address =>
- -- Extract and convert argument to expected type for call
+ -- Extract and convert argument to expected type for call
- Expr :=
- Make_Type_Conversion (Loc,
- Subtype_Mark =>
- New_Occurrence_Of (RTE (RE_Integer_Address), Loc),
- Expression => Relocate_Node (First (Expressions (N))));
+ Expr :=
+ Make_Type_Conversion (Loc,
+ Subtype_Mark =>
+ New_Occurrence_Of (RTE (RE_Integer_Address), Loc),
+ Expression => Relocate_Node (First (Expressions (N))));
- -- Replace attribute reference with call
+ -- Replace attribute reference with call
- Rewrite (N,
- Make_Function_Call (Loc,
- Name =>
- New_Occurrence_Of (RTE (RE_To_Address), Loc),
- Parameter_Associations => New_List (Expr)));
- Analyze_And_Resolve (N, Typ);
-
- elsif Attr_Id = Attribute_Object_Size
- or else Attr_Id = Attribute_Size
- or else Attr_Id = Attribute_Value_Size
- or else Attr_Id = Attribute_VADS_Size
- then
- Exp_Attr.Expand_Size_Attribute (N);
-
- -- For attributes which return Universal_Integer, introduce a conversion
- -- to the expected type with the appropriate check flags set.
-
- elsif Attr_Id = Attribute_Alignment
- or else Attr_Id = Attribute_Bit
- or else Attr_Id = Attribute_Bit_Position
- or else Attr_Id = Attribute_Descriptor_Size
- or else Attr_Id = Attribute_First_Bit
- or else Attr_Id = Attribute_Last_Bit
- or else Attr_Id = Attribute_Length
- or else Attr_Id = Attribute_Max_Size_In_Storage_Elements
- or else Attr_Id = Attribute_Pos
- or else Attr_Id = Attribute_Position
- or else Attr_Id = Attribute_Range_Length
- or else Attr_Id = Attribute_Aft
- or else Attr_Id = Attribute_Max_Alignment_For_Allocation
- then
- -- If the expected type is Long_Long_Integer, there will be no check
- -- flag as the compiler assumes attributes always fit in this type.
- -- Since in SPARK_Mode we do not take Storage_Error into account, we
- -- cannot make this assumption and need to produce a check.
- -- ??? It should be enough to add this check for attributes
- -- 'Length, 'Range_Length and 'Pos when the type is as big
- -- as Long_Long_Integer.
-
- declare
- Typ : Entity_Id;
- begin
- if Attr_Id = Attribute_Range_Length
- or else Attr_Id = Attribute_Pos
- then
- Typ := Etype (Prefix (N));
+ Rewrite
+ (N,
+ Make_Function_Call (Loc,
+ Name =>
+ New_Occurrence_Of (RTE (RE_To_Address), Loc),
+ Parameter_Associations => New_List (Expr)));
+ Analyze_And_Resolve (N, Typ);
- elsif Attr_Id = Attribute_Length then
- Typ := Get_Index_Subtype (N);
+ when Attribute_Object_Size
+ | Attribute_Size
+ | Attribute_Value_Size
+ | Attribute_VADS_Size
+ =>
+ Exp_Attr.Expand_Size_Attribute (N);
+
+ -- For attributes which return Universal_Integer, introduce a
+ -- conversion to the expected type with the appropriate check flags
+ -- set.
+
+ when Attribute_Aft
+ | Attribute_Alignment
+ | Attribute_Bit
+ | Attribute_Bit_Position
+ | Attribute_Descriptor_Size
+ | Attribute_First_Bit
+ | Attribute_Last_Bit
+ | Attribute_Length
+ | Attribute_Max_Alignment_For_Allocation
+ | Attribute_Max_Size_In_Storage_Elements
+ | Attribute_Pos
+ | Attribute_Position
+ | Attribute_Range_Length
+ =>
+ -- If the expected type is Long_Long_Integer, there will be no
+ -- check flag as the compiler assumes attributes always fit in
+ -- this type. Since in SPARK_Mode we do not take Storage_Error
+ -- into account, we cannot make this assumption and need to
+ -- produce a check. ??? It should be enough to add this check for
+ -- attributes 'Length, 'Range_Length and 'Pos when the type is as
+ -- big as Long_Long_Integer.
- else
- Typ := Empty;
- end if;
+ declare
+ Typ : Entity_Id;
+ begin
+ if Attr_Id in Attribute_Pos | Attribute_Range_Length then
+ Typ := Etype (Prefix (N));
- Apply_Universal_Integer_Attribute_Checks (N);
+ elsif Attr_Id = Attribute_Length then
+ Typ := Get_Index_Subtype (N);
- if Present (Typ)
- and then RM_Size (Typ) = RM_Size (Standard_Long_Long_Integer)
- then
- -- ??? This should rather be a range check, but this would
- -- crash GNATprove which somehow recovers the proper kind
- -- of check anyway.
- Set_Do_Overflow_Check (N);
- end if;
- end;
+ else
+ Typ := Empty;
+ end if;
+
+ Apply_Universal_Integer_Attribute_Checks (N);
- elsif Attr_Id = Attribute_Constrained then
+ if Present (Typ)
+ and then RM_Size (Typ) = RM_Size (Standard_Long_Long_Integer)
+ then
+ -- ??? This should rather be a range check, but this would
+ -- crash GNATprove which somehow recovers the proper kind
+ -- of check anyway.
+ Set_Do_Overflow_Check (N);
+ end if;
+ end;
- -- If the prefix is an access to object, the attribute applies to
- -- the designated object, so rewrite with an explicit dereference.
+ when Attribute_Constrained =>
- if Is_Access_Type (Etype (Pref))
- and then
- (not Is_Entity_Name (Pref) or else Is_Object (Entity (Pref)))
- then
- Rewrite (Pref,
- Make_Explicit_Dereference (Loc, Relocate_Node (Pref)));
- Analyze_And_Resolve (N, Standard_Boolean);
- end if;
+ -- If the prefix is an access to object, the attribute applies to
+ -- the designated object, so rewrite with an explicit dereference.
- elsif Attr_Id = Attribute_Update then
- Expand_SPARK_Delta_Or_Update (Typ, First (Expressions (N)));
- end if;
+ if Is_Access_Type (Etype (Pref))
+ and then
+ (not Is_Entity_Name (Pref) or else Is_Object (Entity (Pref)))
+ then
+ Rewrite (Pref,
+ Make_Explicit_Dereference (Loc, Relocate_Node (Pref)));
+ Analyze_And_Resolve (N, Standard_Boolean);
+ end if;
+
+ when Attribute_Update =>
+ Expand_SPARK_Delta_Or_Update (Typ, First (Expressions (N)));
+
+ when others =>
+ null;
+ end case;
end Expand_SPARK_N_Attribute_Reference;
------------------------------------
@@ -603,7 +533,7 @@ package body Exp_SPARK is
and then Present (DIC_Procedure (Typ))
and then not Has_Init_Expression (N)
then
- Call := Build_DIC_Call (Loc, Obj_Id, Typ);
+ Call := Build_DIC_Call (Loc, New_Occurrence_Of (Obj_Id, Loc), Typ);
-- Partially insert the call into the tree by setting its parent
-- pointer.
diff --git a/gcc/ada/exp_strm.adb b/gcc/ada/exp_strm.adb
index 6cda955..09bd872 100644
--- a/gcc/ada/exp_strm.adb
+++ b/gcc/ada/exp_strm.adb
@@ -578,8 +578,11 @@ package body Exp_Strm is
elsif P_Size <= Standard_Long_Integer_Size then
Lib_RE := RE_I_LI;
- else
+ elsif P_Size <= Standard_Long_Long_Integer_Size then
Lib_RE := RE_I_LLI;
+
+ else
+ Lib_RE := RE_I_LLLI;
end if;
-- Unsigned integer types, also includes unsigned fixed-point types
@@ -609,8 +612,11 @@ package body Exp_Strm is
elsif P_Size <= Standard_Long_Integer_Size then
Lib_RE := RE_I_LU;
- else
+ elsif P_Size <= Standard_Long_Long_Integer_Size then
Lib_RE := RE_I_LLU;
+
+ else
+ Lib_RE := RE_I_LLLU;
end if;
else pragma Assert (Is_Access_Type (U_Type));
@@ -802,16 +808,24 @@ package body Exp_Strm is
then
if P_Size <= Standard_Short_Short_Integer_Size then
Lib_RE := RE_W_SSI;
+
elsif P_Size <= Standard_Short_Integer_Size then
Lib_RE := RE_W_SI;
+
elsif P_Size = 24 then
Lib_RE := RE_W_I24;
+
elsif P_Size <= Standard_Integer_Size then
Lib_RE := RE_W_I;
+
elsif P_Size <= Standard_Long_Integer_Size then
Lib_RE := RE_W_LI;
- else
+
+ elsif P_Size <= Standard_Long_Long_Integer_Size then
Lib_RE := RE_W_LLI;
+
+ else
+ Lib_RE := RE_W_LLLI;
end if;
-- Unsigned integer types, also includes unsigned fixed-point types
@@ -828,16 +842,24 @@ package body Exp_Strm is
then
if P_Size <= Standard_Short_Short_Integer_Size then
Lib_RE := RE_W_SSU;
+
elsif P_Size <= Standard_Short_Integer_Size then
Lib_RE := RE_W_SU;
+
elsif P_Size = 24 then
Lib_RE := RE_W_U24;
+
elsif P_Size <= Standard_Integer_Size then
Lib_RE := RE_W_U;
+
elsif P_Size <= Standard_Long_Integer_Size then
Lib_RE := RE_W_LU;
- else
+
+ elsif P_Size <= Standard_Long_Long_Integer_Size then
Lib_RE := RE_W_LLU;
+
+ else
+ Lib_RE := RE_W_LLLU;
end if;
else pragma Assert (Is_Access_Type (U_Type));
diff --git a/gcc/ada/exp_tss.adb b/gcc/ada/exp_tss.adb
index 40943fb..c5f167a 100644
--- a/gcc/ada/exp_tss.adb
+++ b/gcc/ada/exp_tss.adb
@@ -522,46 +522,4 @@ package body Exp_Tss is
return Empty;
end TSS;
- function TSS (Typ : Entity_Id; Nam : Name_Id) return Entity_Id is
- FN : constant Node_Id := Freeze_Node (Typ);
- Elmt : Elmt_Id;
- Subp : Entity_Id;
-
- begin
- if No (FN) then
- return Empty;
-
- elsif No (TSS_Elist (FN)) then
- return Empty;
-
- else
- Elmt := First_Elmt (TSS_Elist (FN));
- while Present (Elmt) loop
- if Chars (Node (Elmt)) = Nam then
- Subp := Node (Elmt);
-
- -- For stream subprograms, the TSS entity may be a renaming-
- -- as-body of an already generated entity. Use that one rather
- -- the one introduced by the renaming, which is an artifact of
- -- current stream handling.
-
- if Nkind (Parent (Parent (Subp))) =
- N_Subprogram_Renaming_Declaration
- and then
- Present (Corresponding_Spec (Parent (Parent (Subp))))
- then
- return Corresponding_Spec (Parent (Parent (Subp)));
- else
- return Subp;
- end if;
-
- else
- Next_Elmt (Elmt);
- end if;
- end loop;
- end if;
-
- return Empty;
- end TSS;
-
end Exp_Tss;
diff --git a/gcc/ada/exp_tss.ads b/gcc/ada/exp_tss.ads
index 59234ff..ca35f5a 100644
--- a/gcc/ada/exp_tss.ads
+++ b/gcc/ada/exp_tss.ads
@@ -170,7 +170,6 @@ package Exp_Tss is
-- be explicitly frozen, so the N_Freeze_Entity node always exists).
function TSS (Typ : Entity_Id; Nam : TSS_Name_Type) return Entity_Id;
- function TSS (Typ : Entity_Id; Nam : Name_Id) return Entity_Id;
-- Finds the TSS with the given name associated with the given type.
-- If no such TSS exists, then Empty is returned.
diff --git a/gcc/ada/exp_unst.adb b/gcc/ada/exp_unst.adb
index ffc30c3..ee2cf81 100644
--- a/gcc/ada/exp_unst.adb
+++ b/gcc/ada/exp_unst.adb
@@ -251,13 +251,8 @@ package body Exp_Unst is
-----------------------
function Needs_Fat_Pointer (E : Entity_Id) return Boolean is
- Typ : Entity_Id := Etype (E);
-
+ Typ : constant Entity_Id := Get_Fullest_View (Etype (E));
begin
- if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then
- Typ := Full_View (Typ);
- end if;
-
return Is_Array_Type (Typ) and then not Is_Constrained (Typ);
end Needs_Fat_Pointer;
@@ -882,8 +877,8 @@ package body Exp_Unst is
-- outside the nested structure do not affect us.
if Scope_Within (Ent, Subp)
- and then Is_Subprogram (Ent)
- and then not Is_Imported (Ent)
+ and then Is_Subprogram (Ent)
+ and then not Is_Imported (Ent)
then
Append_Unique_Call ((N, Current_Subprogram, Ent));
end if;
@@ -898,6 +893,8 @@ package body Exp_Unst is
DT : Boolean := False;
Formal : Node_Id;
Subp : Entity_Id;
+ F_Type : Entity_Id;
+ A_Type : Entity_Id;
begin
if Nkind (Name (N)) = N_Explicit_Dereference then
@@ -908,12 +905,16 @@ package body Exp_Unst is
Actual := First_Actual (N);
Formal := First_Formal_With_Extras (Subp);
+
while Present (Actual) loop
- if Is_Array_Type (Etype (Formal))
- and then not Is_Constrained (Etype (Formal))
- and then Is_Constrained (Etype (Actual))
+ F_Type := Get_Fullest_View (Etype (Formal));
+ A_Type := Get_Fullest_View (Etype (Actual));
+
+ if Is_Array_Type (F_Type)
+ and then not Is_Constrained (F_Type)
+ and then Is_Constrained (A_Type)
then
- Check_Static_Type (Etype (Actual), Empty, DT);
+ Check_Static_Type (A_Type, Empty, DT);
end if;
Next_Actual (Actual);
diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb
index 6b474d8..cf4059a 100644
--- a/gcc/ada/exp_util.adb
+++ b/gcc/ada/exp_util.adb
@@ -60,10 +60,8 @@ with Sem_Util; use Sem_Util;
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 Urealp; use Urealp;
with Validsw; use Validsw;
with GNAT.HTable;
@@ -169,6 +167,16 @@ package body Exp_Util is
-- Determine whether pragma Default_Initial_Condition denoted by Prag has
-- an assertion expression that should be verified at run time.
+ function Is_Uninitialized_Aggregate
+ (Exp : Node_Id;
+ T : Entity_Id) return Boolean;
+ -- Determine whether an array aggregate used in an object declaration
+ -- is uninitialized, when the aggregate is declared with a box and
+ -- the component type has no default value. Such an aggregate can be
+ -- optimized away to prevent the copying of uninitialized data, and
+ -- the bounds of the aggregate can be propagated directly to the
+ -- object declaration.
+
function Make_CW_Equivalent_Type
(T : Entity_Id;
E : Node_Id) return Entity_Id;
@@ -471,9 +479,9 @@ package body Exp_Util is
end if;
end Append_Freeze_Actions;
- --------------------------------------
- -- Attr_Constrained_Statically_True --
- --------------------------------------
+ ----------------------------------------
+ -- Attribute_Constrained_Static_Value --
+ ----------------------------------------
function Attribute_Constrained_Static_Value (Pref : Node_Id) return Boolean
is
@@ -535,7 +543,7 @@ package body Exp_Util is
if Is_Entity_Name (Pref) then
declare
- Ent : constant Entity_Id := Entity (Pref);
+ Ent : constant Entity_Id := Entity (Pref);
Res : Boolean;
begin
@@ -1436,21 +1444,27 @@ package body Exp_Util is
--------------------
function Build_DIC_Call
- (Loc : Source_Ptr;
- Obj_Id : Entity_Id;
- Typ : Entity_Id) return Node_Id
+ (Loc : Source_Ptr;
+ Obj_Name : Node_Id;
+ Typ : Entity_Id) return Node_Id
is
Proc_Id : constant Entity_Id := DIC_Procedure (Typ);
Formal_Typ : constant Entity_Id := Etype (First_Formal (Proc_Id));
begin
+ -- The DIC procedure has a null body if assertions are disabled or
+ -- Assertion_Policy Ignore is in effect. In that case, it would be
+ -- nice to generate a null statement instead of a call to the DIC
+ -- procedure, but doing that seems to interfere with the determination
+ -- of ECRs (early call regions) in SPARK. ???
+
return
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 => New_Occurrence_Of (Obj_Id, Loc))));
+ Expression => Obj_Name)));
end Build_DIC_Call;
------------------------------
@@ -1462,9 +1476,13 @@ package body Exp_Util is
-- Ghost mode.
procedure Build_DIC_Procedure_Body
- (Typ : Entity_Id;
- For_Freeze : Boolean := False)
+ (Typ : Entity_Id;
+ Partial_DIC : Boolean := False)
is
+ Pragmas_Seen : Elist_Id := No_Elist;
+ -- This list contains all DIC pragmas processed so far. The list is used
+ -- to avoid redundant Default_Initial_Condition checks.
+
procedure Add_DIC_Check
(DIC_Prag : Node_Id;
DIC_Expr : Node_Id;
@@ -1484,24 +1502,46 @@ package body Exp_Util is
-- pragma. All generated code is added to list Stmts.
procedure Add_Inherited_Tagged_DIC
- (DIC_Prag : Node_Id;
- Par_Typ : Entity_Id;
- Deriv_Typ : Entity_Id;
- Stmts : in out List_Id);
+ (DIC_Prag : Node_Id;
+ Expr : Node_Id;
+ Stmts : in out List_Id);
-- Add a runtime check to verify assertion expression DIC_Expr of
- -- inherited pragma DIC_Prag. This routine applies class-wide pre- and
- -- postcondition-like runtime semantics to the check. Par_Typ is the
- -- parent type whose DIC pragma is being inherited. Deriv_Typ is the
- -- derived type inheriting the DIC pragma. All generated code is added
- -- to list Stmts.
+ -- inherited pragma DIC_Prag. This routine applies class-wide pre-
+ -- and postcondition-like runtime semantics to the check. Expr is
+ -- the assertion expression after substitition has been performed
+ -- (via Replace_References). All generated code is added to list Stmts.
+
+ procedure Add_Inherited_DICs
+ (T : Entity_Id;
+ Priv_Typ : Entity_Id;
+ Full_Typ : Entity_Id;
+ Obj_Id : Entity_Id;
+ Checks : in out List_Id);
+ -- Generate a DIC check for each inherited Default_Initial_Condition
+ -- coming from all parent types of type T. Priv_Typ and Full_Typ denote
+ -- the partial and full view of the parent type. Obj_Id denotes the
+ -- entity of the _object formal parameter of the DIC procedure. All
+ -- created checks are added to list Checks.
procedure Add_Own_DIC
(DIC_Prag : Node_Id;
DIC_Typ : Entity_Id;
+ Obj_Id : Entity_Id;
Stmts : in out List_Id);
-- Add a runtime check to verify the assertion expression of pragma
- -- DIC_Prag. DIC_Typ is the owner of the DIC pragma. All generated code
- -- is added to list Stmts.
+ -- DIC_Prag. DIC_Typ is the owner of the DIC pragma. Obj_Id is the
+ -- object to substitute in the assertion expression for any references
+ -- to the current instance of the type All generated code is added to
+ -- list Stmts.
+
+ procedure Add_Parent_DICs
+ (T : Entity_Id;
+ Obj_Id : Entity_Id;
+ Checks : in out List_Id);
+ -- Generate a Default_Initial_Condition check for each inherited DIC
+ -- aspect coming from all parent types of type T. Obj_Id denotes the
+ -- entity of the _object formal parameter of the DIC procedure. All
+ -- created checks are added to list Checks.
-------------------
-- Add_DIC_Check --
@@ -1539,6 +1579,10 @@ package body Exp_Util is
Make_Pragma_Argument_Association (Loc,
Expression => DIC_Expr))));
end if;
+
+ -- Add the pragma to the list of processed pragmas
+
+ Append_New_Elmt (DIC_Prag, Pragmas_Seen);
end Add_DIC_Check;
-----------------------
@@ -1580,65 +1624,172 @@ package body Exp_Util is
------------------------------
procedure Add_Inherited_Tagged_DIC
- (DIC_Prag : Node_Id;
- Par_Typ : Entity_Id;
- Deriv_Typ : Entity_Id;
- Stmts : in out List_Id)
+ (DIC_Prag : Node_Id;
+ Expr : Node_Id;
+ Stmts : in out List_Id)
is
- Deriv_Proc : constant Entity_Id := DIC_Procedure (Deriv_Typ);
- DIC_Args : constant List_Id :=
- Pragma_Argument_Associations (DIC_Prag);
- DIC_Arg : constant Node_Id := First (DIC_Args);
- DIC_Expr : constant Node_Id := Expression_Copy (DIC_Arg);
- Par_Proc : constant Entity_Id := DIC_Procedure (Par_Typ);
+ begin
+ -- Once the DIC assertion expression is fully processed, add a check
+ -- to the statements of the DIC procedure.
- Expr : Node_Id;
+ Add_DIC_Check
+ (DIC_Prag => DIC_Prag,
+ DIC_Expr => Expr,
+ Stmts => Stmts);
+ end Add_Inherited_Tagged_DIC;
+
+ ------------------------
+ -- Add_Inherited_DICs --
+ ------------------------
+
+ procedure Add_Inherited_DICs
+ (T : Entity_Id;
+ Priv_Typ : Entity_Id;
+ Full_Typ : Entity_Id;
+ Obj_Id : Entity_Id;
+ Checks : in out List_Id)
+ is
+ Deriv_Typ : Entity_Id;
+ Expr : Node_Id;
+ Prag : Node_Id;
+ Prag_Expr : Node_Id;
+ Prag_Expr_Arg : Node_Id;
+ Prag_Typ : Node_Id;
+ Prag_Typ_Arg : Node_Id;
+
+ Par_Proc : Entity_Id;
+ -- The "partial" invariant procedure of Par_Typ
+
+ Par_Typ : Entity_Id;
+ -- The suitable view of the parent type used in the substitution of
+ -- type attributes.
begin
- -- The processing of an inherited DIC assertion expression starts off
- -- with a copy of the original parent expression where all references
- -- to the parent type have already been replaced with references to
- -- the _object formal parameter of the parent type's DIC procedure.
+ if not Present (Priv_Typ) and then not Present (Full_Typ) then
+ return;
+ end if;
- pragma Assert (Present (DIC_Expr));
- Expr := New_Copy_Tree (DIC_Expr);
+ -- When the type inheriting the class-wide invariant is a concurrent
+ -- type, use the corresponding record type because it contains all
+ -- primitive operations of the concurrent type and allows for proper
+ -- substitution.
+
+ if Is_Concurrent_Type (T) then
+ Deriv_Typ := Corresponding_Record_Type (T);
+ else
+ Deriv_Typ := T;
+ end if;
- -- Perform the following substitutions:
+ pragma Assert (Present (Deriv_Typ));
- -- * Replace a reference to the _object parameter of the parent
- -- type's DIC procedure with a reference to the _object parameter
- -- of the derived types' DIC procedure.
+ -- Determine which rep item chain to use. Precedence is given to that
+ -- of the parent type's partial view since it usually carries all the
+ -- class-wide invariants.
- -- * Replace a reference to a discriminant of the parent type with
- -- a suitable value from the point of view of the derived type.
+ if Present (Priv_Typ) then
+ Prag := First_Rep_Item (Priv_Typ);
+ else
+ Prag := First_Rep_Item (Full_Typ);
+ end if;
- -- * Replace a call to an overridden parent primitive with a call
- -- to the overriding derived type primitive.
+ while Present (Prag) loop
+ if Nkind (Prag) = N_Pragma
+ and then Pragma_Name (Prag) = Name_Default_Initial_Condition
+ then
+ -- Nothing to do if the pragma was already processed
- -- * Replace a call to an inherited parent primitive with a call to
- -- the internally-generated inherited derived type primitive.
+ if Contains (Pragmas_Seen, Prag) then
+ return;
+ end if;
- -- Note that primitives defined in the private part are automatically
- -- handled by the overriding/inheritance mechanism and do not require
- -- an extra replacement pass.
+ -- Extract arguments of the Default_Initial_Condition pragma
- pragma Assert (Present (Deriv_Proc) and then Present (Par_Proc));
+ Prag_Expr_Arg := First (Pragma_Argument_Associations (Prag));
+ Prag_Expr := Expression_Copy (Prag_Expr_Arg);
- Replace_References
- (Expr => Expr,
- Par_Typ => Par_Typ,
- Deriv_Typ => Deriv_Typ,
- Par_Obj => First_Formal (Par_Proc),
- Deriv_Obj => First_Formal (Deriv_Proc));
+ -- Pick up the implicit second argument of the pragma, which
+ -- indicates the type that the pragma applies to.
- -- Once the DIC assertion expression is fully processed, add a check
- -- to the statements of the DIC procedure.
+ Prag_Typ_Arg := Next (Prag_Expr_Arg);
+ if Present (Prag_Typ_Arg) then
+ Prag_Typ := Get_Pragma_Arg (Prag_Typ_Arg);
+ else
+ Prag_Typ := Empty;
+ end if;
- Add_DIC_Check
- (DIC_Prag => DIC_Prag,
- DIC_Expr => Expr,
- Stmts => Stmts);
- end Add_Inherited_Tagged_DIC;
+ -- The pragma applies to the partial view of the parent type
+
+ if Present (Priv_Typ)
+ and then Present (Prag_Typ)
+ and then Entity (Prag_Typ) = Priv_Typ
+ then
+ Par_Typ := Priv_Typ;
+
+ -- The pragma applies to the full view of the parent type
+
+ elsif Present (Full_Typ)
+ and then Present (Prag_Typ)
+ and then Entity (Prag_Typ) = Full_Typ
+ then
+ Par_Typ := Full_Typ;
+
+ -- Otherwise the pragma does not belong to the parent type and
+ -- should not be considered.
+
+ else
+ return;
+ end if;
+
+ -- Substitute references in the DIC expression that are related
+ -- to the partial type with corresponding references related to
+ -- the derived type (call to Replace_References below).
+
+ Expr := New_Copy_Tree (Prag_Expr);
+
+ Par_Proc := Partial_DIC_Procedure (Par_Typ);
+
+ -- If there's not a partial DIC procedure (such as when a
+ -- full type doesn't have its own DIC, but is inherited from
+ -- a type with DIC), get the full DIC procedure.
+
+ if not Present (Par_Proc) then
+ Par_Proc := DIC_Procedure (Par_Typ);
+ end if;
+
+ Replace_References
+ (Expr => Expr,
+ Par_Typ => Par_Typ,
+ Deriv_Typ => Deriv_Typ,
+ Par_Obj => First_Formal (Par_Proc),
+ Deriv_Obj => Obj_Id);
+
+ -- Why are there different actions depending on whether T is
+ -- tagged? Can these be unified? ???
+
+ if Is_Tagged_Type (T) then
+ Add_Inherited_Tagged_DIC
+ (DIC_Prag => Prag,
+ Expr => Expr,
+ Stmts => Checks);
+
+ else
+ Add_Inherited_DIC
+ (DIC_Prag => Prag,
+ Par_Typ => Par_Typ,
+ Deriv_Typ => Deriv_Typ,
+ Stmts => Checks);
+ end if;
+
+ -- Leave as soon as we get a DIC pragma, since we'll visit
+ -- the pragmas of the parents, so will get to any "inherited"
+ -- pragmas that way.
+
+ return;
+ end if;
+
+ Next_Rep_Item (Prag);
+ end loop;
+ end Add_Inherited_DICs;
-----------------
-- Add_Own_DIC --
@@ -1647,6 +1798,7 @@ package body Exp_Util is
procedure Add_Own_DIC
(DIC_Prag : Node_Id;
DIC_Typ : Entity_Id;
+ Obj_Id : Entity_Id;
Stmts : in out List_Id)
is
DIC_Args : constant List_Id :=
@@ -1654,8 +1806,6 @@ package body Exp_Util is
DIC_Arg : constant Node_Id := First (DIC_Args);
DIC_Asp : constant Node_Id := Corresponding_Aspect (DIC_Prag);
DIC_Expr : constant Node_Id := Get_Pragma_Arg (DIC_Arg);
- DIC_Proc : constant Entity_Id := DIC_Procedure (DIC_Typ);
- Obj_Id : constant Entity_Id := First_Formal (DIC_Proc);
-- Local variables
@@ -1712,6 +1862,66 @@ package body Exp_Util is
Stmts => Stmts);
end Add_Own_DIC;
+ ---------------------
+ -- Add_Parent_DICs --
+ ---------------------
+
+ procedure Add_Parent_DICs
+ (T : Entity_Id;
+ Obj_Id : Entity_Id;
+ Checks : in out List_Id)
+ is
+ Dummy_1 : Entity_Id;
+ Dummy_2 : Entity_Id;
+
+ Curr_Typ : Entity_Id;
+ -- The entity of the current type being examined
+
+ Full_Typ : Entity_Id;
+ -- The full view of Par_Typ
+
+ Par_Typ : Entity_Id;
+ -- The entity of the parent type
+
+ Priv_Typ : Entity_Id;
+ -- The partial view of Par_Typ
+
+ begin
+ -- Climb the parent type chain
+
+ Curr_Typ := T;
+ loop
+ -- Do not consider subtypes, as they inherit the DICs from their
+ -- base types.
+
+ Par_Typ := Base_Type (Etype (Base_Type (Curr_Typ)));
+
+ -- Stop the climb once the root of the parent chain is
+ -- reached.
+
+ exit when Curr_Typ = Par_Typ;
+
+ -- Process the DICs of the parent type
+
+ Get_Views (Par_Typ, Priv_Typ, Full_Typ, Dummy_1, Dummy_2);
+
+ -- Only try to inherit a DIC pragma from the parent type Par_Typ
+ -- if it Has_Own_DIC pragma. The loop will proceed up the parent
+ -- chain to find all types that have their own DIC.
+
+ if Has_Own_DIC (Par_Typ) then
+ Add_Inherited_DICs
+ (T => T,
+ Priv_Typ => Priv_Typ,
+ Full_Typ => Full_Typ,
+ Obj_Id => Obj_Id,
+ Checks => Checks);
+ end if;
+
+ Curr_Typ := Par_Typ;
+ end loop;
+ end Add_Parent_DICs;
+
-- Local variables
Loc : constant Source_Ptr := Sloc (Typ);
@@ -1730,8 +1940,20 @@ package body Exp_Util is
Proc_Id : Entity_Id;
Stmts : List_Id := No_List;
- Build_Body : Boolean := False;
- -- Flag set when the type requires a DIC procedure body to be built
+ CRec_Typ : Entity_Id := Empty;
+ -- The corresponding record type of Full_Typ
+
+ Full_Typ : Entity_Id := Empty;
+ -- The full view of the working type
+
+ Obj_Id : Entity_Id := Empty;
+ -- The _object formal parameter of the invariant procedure
+
+ Part_Proc : Entity_Id := Empty;
+ -- The entity of the "partial" invariant procedure
+
+ Priv_Typ : Entity_Id := Empty;
+ -- The partial view of the working type
Work_Typ : Entity_Id;
-- The working type
@@ -1795,25 +2017,41 @@ package body Exp_Util is
goto Leave;
end if;
- -- The working type may lack a DIC procedure declaration. This may be
- -- due to several reasons:
+ -- Obtain both views of the type
+
+ Get_Views (Work_Typ, Priv_Typ, Full_Typ, Dummy_1, CRec_Typ);
+
+ -- The caller requests a body for the partial DIC procedure
+
+ if Partial_DIC then
+ Proc_Id := Partial_DIC_Procedure (Work_Typ);
+
+ -- The "full" DIC procedure body was already created
+
+ -- Create a declaration for the "partial" DIC procedure if it
+ -- is not available.
+
+ if No (Proc_Id) then
+ Build_DIC_Procedure_Declaration
+ (Typ => Work_Typ,
+ Partial_DIC => True);
- -- * The working type's own DIC pragma does not contain a verifiable
- -- assertion expression. In this case there is no need to build a
- -- DIC procedure because there is nothing to check.
+ Proc_Id := Partial_DIC_Procedure (Work_Typ);
+ end if;
- -- * The working type derives from a parent type. In this case a DIC
- -- procedure should be built only when the inherited DIC pragma has
- -- a verifiable assertion expression.
+ -- The caller requests a body for the "full" DIC procedure
- Proc_Id := DIC_Procedure (Work_Typ);
+ else
+ Proc_Id := DIC_Procedure (Work_Typ);
+ Part_Proc := Partial_DIC_Procedure (Work_Typ);
- -- Build a DIC procedure declaration when the working type derives from
- -- a parent type.
+ -- Create a declaration for the "full" DIC procedure if it is
+ -- not available.
- if No (Proc_Id) then
- Build_DIC_Procedure_Declaration (Work_Typ);
- Proc_Id := DIC_Procedure (Work_Typ);
+ if No (Proc_Id) then
+ Build_DIC_Procedure_Declaration (Work_Typ);
+ Proc_Id := DIC_Procedure (Work_Typ);
+ end if;
end if;
-- At this point there should be a DIC procedure declaration
@@ -1833,123 +2071,146 @@ package body Exp_Util is
Push_Scope (Proc_Id);
Install_Formals (Proc_Id);
- -- The working type defines its own DIC pragma. Replace the current
- -- instance of the working type with the formal of the DIC procedure.
- -- Note that there is no need to consider inherited DIC pragmas from
- -- parent types because the working type's DIC pragma "hides" all
- -- inherited DIC pragmas.
+ Obj_Id := First_Formal (Proc_Id);
+ pragma Assert (Present (Obj_Id));
- if Has_Own_DIC (Work_Typ) then
- pragma Assert (DIC_Typ = Work_Typ);
+ -- The "partial" DIC procedure verifies the DICs of the partial view
+ -- only.
- Add_Own_DIC
- (DIC_Prag => DIC_Prag,
- DIC_Typ => DIC_Typ,
- Stmts => Stmts);
+ if Partial_DIC then
+ pragma Assert (Present (Priv_Typ));
- Build_Body := True;
+ if Has_Own_DIC (Work_Typ) then -- If we're testing this then maybe
+ Add_Own_DIC -- we shouldn't be calling Find_DIC_Typ above???
+ (DIC_Prag => DIC_Prag,
+ DIC_Typ => DIC_Typ, -- Should this just be Work_Typ???
+ Obj_Id => Obj_Id,
+ Stmts => Stmts);
+ end if;
- -- Otherwise the working type inherits a DIC pragma from a parent type.
- -- This processing is carried out when the type is frozen because the
- -- state of all parent discriminants is known at that point. Note that
- -- it is semantically sound to delay the creation of the DIC procedure
- -- body till the freeze point. If the type has a DIC pragma of its own,
- -- then the DIC procedure body would have already been constructed at
- -- the end of the visible declarations and all parent DIC pragmas are
- -- effectively "hidden" and irrelevant.
+ -- Otherwise the "full" DIC procedure verifies the DICs of the full
+ -- view, well as DICs inherited from parent types. In addition, it
+ -- indirectly verifies the DICs of the partial view by calling the
+ -- "partial" DIC procedure.
- elsif For_Freeze then
- pragma Assert (Has_Inherited_DIC (Work_Typ));
- pragma Assert (DIC_Typ /= Work_Typ);
+ else
+ pragma Assert (Present (Full_Typ));
- -- The working type is tagged. The verification of the assertion
- -- expression is subject to the same semantics as class-wide pre-
- -- and postconditions.
+ -- Check the DIC of the partial view by calling the "partial" DIC
+ -- procedure, unless the partial DIC body is empty. Generate:
- if Is_Tagged_Type (Work_Typ) then
- Add_Inherited_Tagged_DIC
- (DIC_Prag => DIC_Prag,
- Par_Typ => DIC_Typ,
- Deriv_Typ => Work_Typ,
- Stmts => Stmts);
+ -- <Work_Typ>Partial_DIC (_object);
- -- Otherwise the working type is not tagged. Verify the assertion
- -- expression of the inherited DIC pragma by directly calling the
- -- DIC procedure of the parent type.
+ if Present (Part_Proc) and then not Has_Null_Body (Part_Proc) then
+ Append_New_To (Stmts,
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Occurrence_Of (Part_Proc, Loc),
+ Parameter_Associations => New_List (
+ New_Occurrence_Of (Obj_Id, Loc))));
+ end if;
- else
- Add_Inherited_DIC
- (DIC_Prag => DIC_Prag,
- Par_Typ => DIC_Typ,
- Deriv_Typ => Work_Typ,
- Stmts => Stmts);
+ -- Derived subtypes do not have a partial view
+
+ if Present (Priv_Typ) then
+
+ -- The processing of the "full" DIC procedure intentionally
+ -- skips the partial view because a) this may result in changes of
+ -- visibility and b) lead to duplicate checks. However, when the
+ -- full view is the underlying full view of an untagged derived
+ -- type whose parent type is private, partial DICs appear on
+ -- the rep item chain of the partial view only.
+
+ -- package Pack_1 is
+ -- type Root ... is private;
+ -- private
+ -- <full view of Root>
+ -- end Pack_1;
+
+ -- with Pack_1;
+ -- package Pack_2 is
+ -- type Child is new Pack_1.Root with Type_DIC => ...;
+ -- <underlying full view of Child>
+ -- end Pack_2;
+
+ -- As a result, the processing of the full view must also consider
+ -- all DICs of the partial view.
+
+ if Is_Untagged_Private_Derivation (Priv_Typ, Full_Typ) then
+ null;
+
+ -- Otherwise the DICs of the partial view are ignored
+
+ else
+ -- Ignore the DICs of the partial view by eliminating the view
+
+ Priv_Typ := Empty;
+ end if;
end if;
- Build_Body := True;
+ -- Process inherited Default_Initial_Conditions for all parent types
+
+ Add_Parent_DICs (Work_Typ, Obj_Id, Stmts);
end if;
End_Scope;
- if Build_Body then
+ -- Produce an empty completing body in the following cases:
+ -- * Assertions are disabled
+ -- * The DIC Assertion_Policy is Ignore
- -- Produce an empty completing body in the following cases:
- -- * Assertions are disabled
- -- * The DIC Assertion_Policy is Ignore
+ if No (Stmts) then
+ Stmts := New_List (Make_Null_Statement (Loc));
+ end if;
- if No (Stmts) then
- Stmts := New_List (Make_Null_Statement (Loc));
- end if;
+ -- Generate:
+ -- procedure <Work_Typ>DIC (_object : <Work_Typ>) is
+ -- begin
+ -- <Stmts>
+ -- end <Work_Typ>DIC;
- -- Generate:
- -- procedure <Work_Typ>DIC (_object : <Work_Typ>) is
- -- begin
- -- <Stmts>
- -- end <Work_Typ>DIC;
-
- Proc_Body :=
- Make_Subprogram_Body (Loc,
- Specification =>
- Copy_Subprogram_Spec (Parent (Proc_Id)),
- Declarations => Empty_List,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => Stmts));
- Proc_Body_Id := Defining_Entity (Proc_Body);
-
- -- Perform minor decoration in case the body is not analyzed
-
- Set_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));
- Set_SPARK_Pragma_Inherited
- (Proc_Body_Id, SPARK_Pragma_Inherited (Proc_Id));
-
- -- Link both spec and body to avoid generating duplicates
-
- Set_Corresponding_Body (Proc_Decl, Proc_Body_Id);
- Set_Corresponding_Spec (Proc_Body, Proc_Id);
-
- -- The body should not be inserted into the tree when the context
- -- is a generic unit because it is not part of the template.
- -- Note that the body must still be generated in order to resolve the
- -- DIC assertion expression.
-
- if Inside_A_Generic then
- null;
+ Proc_Body :=
+ Make_Subprogram_Body (Loc,
+ Specification =>
+ Copy_Subprogram_Spec (Parent (Proc_Id)),
+ Declarations => Empty_List,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => Stmts));
+ Proc_Body_Id := Defining_Entity (Proc_Body);
- -- Semi-insert the body into the tree for GNATprove by setting its
- -- Parent field. This allows for proper upstream tree traversals.
+ -- Perform minor decoration in case the body is not analyzed
- elsif GNATprove_Mode then
- Set_Parent (Proc_Body, Parent (Declaration_Node (Work_Typ)));
+ Set_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));
+ Set_SPARK_Pragma_Inherited
+ (Proc_Body_Id, SPARK_Pragma_Inherited (Proc_Id));
- -- Otherwise the body is part of the freezing actions of the working
- -- type.
+ -- Link both spec and body to avoid generating duplicates
- else
- Append_Freeze_Action (Work_Typ, Proc_Body);
- end if;
+ Set_Corresponding_Body (Proc_Decl, Proc_Body_Id);
+ Set_Corresponding_Spec (Proc_Body, Proc_Id);
+
+ -- The body should not be inserted into the tree when the context
+ -- is a generic unit because it is not part of the template.
+ -- Note that the body must still be generated in order to resolve the
+ -- DIC assertion expression.
+
+ if Inside_A_Generic then
+ null;
+
+ -- Semi-insert the body into the tree for GNATprove by setting its
+ -- Parent field. This allows for proper upstream tree traversals.
+
+ elsif GNATprove_Mode then
+ Set_Parent (Proc_Body, Parent (Declaration_Node (Work_Typ)));
+
+ -- Otherwise the body is part of the freezing actions of the working
+ -- type.
+
+ else
+ Append_Freeze_Action (Work_Typ, Proc_Body);
end if;
<<Leave>>
@@ -1964,7 +2225,10 @@ package body Exp_Util is
-- replaced by gotos which jump to the end of the routine and restore the
-- Ghost mode.
- procedure Build_DIC_Procedure_Declaration (Typ : Entity_Id) is
+ procedure Build_DIC_Procedure_Declaration
+ (Typ : Entity_Id;
+ Partial_DIC : Boolean := False)
+ is
Loc : constant Source_Ptr := Sloc (Typ);
Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
@@ -1975,6 +2239,7 @@ package body Exp_Util is
DIC_Typ : Entity_Id;
Proc_Decl : Node_Id;
Proc_Id : Entity_Id;
+ Proc_Nam : Name_Id;
Typ_Decl : Node_Id;
CRec_Typ : Entity_Id;
@@ -2050,17 +2315,35 @@ package body Exp_Util is
if not Is_Verifiable_DIC_Pragma (DIC_Prag) then
goto Leave;
+ end if;
+
+ -- Nothing to do if the type already has a "partial" DIC procedure
+
+ if Partial_DIC then
+ if Present (Partial_DIC_Procedure (Work_Typ)) then
+ goto Leave;
+ end if;
- -- Nothing to do if the type already has a DIC procedure
+ -- Nothing to do if the type already has a "full" DIC procedure
elsif Present (DIC_Procedure (Work_Typ)) then
goto Leave;
end if;
+ -- The caller requests the declaration of the "partial" DIC procedure
+
+ if Partial_DIC then
+ Proc_Nam := New_External_Name (Chars (Work_Typ), "Partial_DIC");
+
+ -- Otherwise the caller requests the declaration of the "full" DIC
+ -- procedure.
+
+ else
+ Proc_Nam := New_External_Name (Chars (Work_Typ), "DIC");
+ end if;
+
Proc_Id :=
- Make_Defining_Identifier (Loc,
- Chars =>
- New_External_Name (Chars (Work_Typ), "Default_Initial_Condition"));
+ Make_Defining_Identifier (Loc, Chars => Proc_Nam);
-- Perform minor decoration in case the declaration is not analyzed
@@ -3702,18 +3985,18 @@ package body Exp_Util is
-- Add an extra out parameter to carry the function result
- Name_Len := 6;
- Name_Buffer (1 .. Name_Len) := "RESULT";
Append_To (Proc_Formals,
Make_Parameter_Specification (Loc,
Defining_Identifier =>
- Make_Defining_Identifier (Loc, Chars => Name_Find),
+ Make_Defining_Identifier (Loc, Name_UP_RESULT),
Out_Present => True,
Parameter_Type => New_Occurrence_Of (Etype (Subp), Loc)));
- -- The new procedure declaration is inserted immediately after the
- -- function declaration. The processing in Build_Procedure_Body_Form
- -- relies on this order.
+ -- The new procedure declaration is inserted before the function
+ -- declaration. The processing in Build_Procedure_Body_Form relies on
+ -- this order. Note that we insert before because in the case of a
+ -- function body with no separate spec, we do not want to insert the
+ -- new spec after the body which will later get rewritten.
Proc_Decl :=
Make_Subprogram_Declaration (Loc,
@@ -3723,7 +4006,7 @@ package body Exp_Util is
Make_Defining_Identifier (Loc, Chars (Subp)),
Parameter_Specifications => Proc_Formals));
- Insert_After_And_Analyze (Unit_Declaration_Node (Subp), Proc_Decl);
+ Insert_Before_And_Analyze (Unit_Declaration_Node (Subp), Proc_Decl);
-- Entity of procedure must remain invisible so that it does not
-- overload subsequent references to the original function.
@@ -5337,7 +5620,7 @@ package body Exp_Util is
then
null;
- -- For limited objects initialized with build in place function calls,
+ -- For limited objects initialized with build-in-place function calls,
-- nothing to be done; otherwise we prematurely introduce an N_Reference
-- node in the expression initializing the object, which breaks the
-- circuitry that detects and adds the additional arguments to the
@@ -5346,6 +5629,17 @@ package body Exp_Util is
elsif Is_Build_In_Place_Function_Call (Exp) then
null;
+ -- If the expression is an uninitialized aggregate, no need to build
+ -- a subtype from the expression, because this may require the use of
+ -- dynamic memory to create the object.
+
+ elsif Is_Uninitialized_Aggregate (Exp, Exp_Typ) then
+ Rewrite (Subtype_Indic, New_Occurrence_Of (Etype (Exp), Sloc (N)));
+ if Nkind (N) = N_Object_Declaration then
+ Set_Expression (N, Empty);
+ Set_No_Initialization (N);
+ end if;
+
else
Remove_Side_Effects (Exp);
Rewrite (Subtype_Indic,
@@ -6183,9 +6477,7 @@ package body Exp_Util is
Loc : constant Source_Ptr := Sloc (Var);
Ent : constant Entity_Id := Entity (Var);
- procedure Process_Current_Value_Condition
- (N : Node_Id;
- S : Boolean);
+ procedure Process_Current_Value_Condition (N : Node_Id; S : Boolean);
-- N is an expression which holds either True (S = True) or False (S =
-- False) in the condition. This procedure digs out the expression and
-- if it refers to Ent, sets Op and Val appropriately.
@@ -6246,6 +6538,7 @@ package body Exp_Util is
-- Recursively process AND and AND THEN branches
Process_Current_Value_Condition (Left_Opnd (Cond), True);
+ pragma Assert (Op'Valid);
if Op /= N_Empty then
return;
@@ -6341,6 +6634,17 @@ package body Exp_Util is
return;
end if;
+ -- In GNATprove mode we don't want to use current value optimizer, in
+ -- particular for loop invariant expressions and other assertions that
+ -- act as cut points for proof. The optimizer often folds expressions
+ -- into True/False where they trivially follow from the previous
+ -- assignments, but this deprives proof from the information needed to
+ -- discharge checks that are beyond the scope of the value optimizer.
+
+ if GNATprove_Mode then
+ return;
+ end if;
+
-- Otherwise examine current value
declare
@@ -6567,7 +6871,7 @@ package body Exp_Util is
if Has_Stream_Size_Clause (E) then
return Static_Integer (Expression (Stream_Size_Clause (E)));
- -- Otherwise the Stream_Size if the size of the type
+ -- Otherwise the Stream_Size is the size of the type
else
return Esize (E);
@@ -7594,26 +7898,6 @@ package body Exp_Util is
end if;
end Integer_Type_For;
- ----------------------------
- -- Is_All_Null_Statements --
- ----------------------------
-
- function Is_All_Null_Statements (L : List_Id) return Boolean is
- Stm : Node_Id;
-
- begin
- Stm := First (L);
- while Present (Stm) loop
- if Nkind (Stm) /= N_Null_Statement then
- return False;
- end if;
-
- Next (Stm);
- end loop;
-
- return True;
- end Is_All_Null_Statements;
-
--------------------------------------------------
-- Is_Displacement_Of_Object_Or_Function_Result --
--------------------------------------------------
@@ -7854,6 +8138,10 @@ package body Exp_Util is
-- is in the process of being iterated in the statement list starting
-- from First_Stmt.
+ function Is_Part_Of_BIP_Return_Statement (N : Node_Id) return Boolean;
+ -- Return True if N is directly part of a build-in-place return
+ -- statement.
+
---------------------------
-- Initialized_By_Access --
---------------------------
@@ -8183,6 +8471,35 @@ package body Exp_Util is
return False;
end Is_Iterated_Container;
+ -------------------------------------
+ -- Is_Part_Of_BIP_Return_Statement --
+ -------------------------------------
+
+ function Is_Part_Of_BIP_Return_Statement (N : Node_Id) return Boolean is
+ Subp : constant Entity_Id := Current_Subprogram;
+ Context : Node_Id;
+ begin
+ -- First check if N is part of a BIP function
+
+ if No (Subp)
+ or else not Is_Build_In_Place_Function (Subp)
+ then
+ return False;
+ end if;
+
+ -- Then check whether N is a complete part of a return statement
+ -- Should we consider other node kinds to go up the tree???
+
+ Context := N;
+ loop
+ case Nkind (Context) is
+ when N_Expression_With_Actions => Context := Parent (Context);
+ when N_Simple_Return_Statement => return True;
+ when others => return False;
+ end case;
+ end loop;
+ end Is_Part_Of_BIP_Return_Statement;
+
-- Local variables
Desig : Entity_Id := Obj_Typ;
@@ -8201,6 +8518,7 @@ package body Exp_Util is
and then Needs_Finalization (Desig)
and then Requires_Transient_Scope (Desig)
and then Nkind (Rel_Node) /= N_Simple_Return_Statement
+ and then not Is_Part_Of_BIP_Return_Statement (Rel_Node)
-- Do not consider a transient object that was already processed
@@ -8220,9 +8538,8 @@ package body Exp_Util is
-- initialized by a function that returns a pointer or acts as a
-- renaming of another pointer.
- and then
- (not Is_Access_Type (Obj_Typ)
- or else not Initialized_By_Access (Obj_Id))
+ and then not
+ (Is_Access_Type (Obj_Typ) and then Initialized_By_Access (Obj_Id))
-- Do not consider transient objects which act as indirect aliases
-- of build-in-place function results.
@@ -8761,6 +9078,47 @@ package body Exp_Util is
and then Etype (Expression (Expr)) = RTE (RE_Tag);
end Is_Tag_To_Class_Wide_Conversion;
+ --------------------------------
+ -- Is_Uninitialized_Aggregate --
+ --------------------------------
+
+ function Is_Uninitialized_Aggregate
+ (Exp : Node_Id;
+ T : Entity_Id) return Boolean
+ is
+ Comp : Node_Id;
+ Comp_Type : Entity_Id;
+ Typ : Entity_Id;
+
+ begin
+ if Nkind (Exp) /= N_Aggregate then
+ return False;
+ end if;
+
+ Preanalyze_And_Resolve (Exp, T);
+ Typ := Etype (Exp);
+
+ if No (Typ)
+ or else Ekind (Typ) /= E_Array_Subtype
+ or else Present (Expressions (Exp))
+ or else No (Component_Associations (Exp))
+ then
+ return False;
+ else
+ Comp_Type := Component_Type (Typ);
+ Comp := First (Component_Associations (Exp));
+
+ if not Box_Present (Comp)
+ or else Present (Next (Comp))
+ then
+ return False;
+ end if;
+
+ return Is_Scalar_Type (Comp_Type)
+ and then No (Default_Aspect_Component_Value (Typ));
+ end if;
+ end Is_Uninitialized_Aggregate;
+
----------------------------
-- Is_Untagged_Derivation --
----------------------------
@@ -8804,6 +9162,13 @@ package body Exp_Util is
return
Present (Args)
+
+ -- If there are args, but the first arg is Empty, then treat the
+ -- pragma the same as having no args (there may be a second arg that
+ -- is an implicitly added type arg, and Empty is a placeholder).
+
+ and then Present (Get_Pragma_Arg (First (Args)))
+
and then Nkind (Get_Pragma_Arg (First (Args))) /= N_Null;
end Is_Verifiable_DIC_Pragma;
@@ -9005,25 +9370,6 @@ package body Exp_Util is
end if;
end Kill_Dead_Code;
- ------------------------
- -- Known_Non_Negative --
- ------------------------
-
- function Known_Non_Negative (Opnd : Node_Id) return Boolean is
- begin
- if Is_OK_Static_Expression (Opnd) and then Expr_Value (Opnd) >= 0 then
- return True;
-
- else
- declare
- Lo : constant Node_Id := Type_Low_Bound (Etype (Opnd));
- begin
- return
- Is_OK_Static_Expression (Lo) and then Expr_Value (Lo) >= 0;
- end;
- end if;
- end Known_Non_Negative;
-
-----------------------------
-- Make_CW_Equivalent_Type --
-----------------------------
@@ -10592,20 +10938,6 @@ package body Exp_Util is
return Res;
end New_Class_Wide_Subtype;
- --------------------------------
- -- Non_Limited_Designated_Type --
- ---------------------------------
-
- function Non_Limited_Designated_Type (T : Entity_Id) return Entity_Id is
- Desig : constant Entity_Id := Designated_Type (T);
- begin
- if Has_Non_Limited_View (Desig) then
- return Non_Limited_View (Desig);
- else
- return Desig;
- end if;
- end Non_Limited_Designated_Type;
-
-----------------------------------
-- OK_To_Do_Constant_Replacement --
-----------------------------------
@@ -11091,6 +11423,12 @@ package body Exp_Util is
-- otherwise it generates an internal temporary. The created temporary
-- entity is marked as internal.
+ function Possible_Side_Effect_In_SPARK (Exp : Node_Id) return Boolean;
+ -- Computes whether a side effect is possible in SPARK, which should
+ -- be handled by removing it from the expression for GNATprove. Note
+ -- that other side effects related to volatile variables are handled
+ -- separately.
+
---------------------
-- Build_Temporary --
---------------------
@@ -11126,6 +11464,26 @@ package body Exp_Util is
return Temp_Id;
end Build_Temporary;
+ -----------------------------------
+ -- Possible_Side_Effect_In_SPARK --
+ -----------------------------------
+
+ function Possible_Side_Effect_In_SPARK (Exp : Node_Id) return Boolean is
+ begin
+ -- Side-effect removal in SPARK should only occur when not inside a
+ -- generic and not doing a preanalysis, inside an object renaming or
+ -- a type declaration or a for-loop iteration scheme.
+
+ return not Inside_A_Generic
+ and then Full_Analysis
+ and then Nkind (Enclosing_Declaration (Exp)) in
+ N_Full_Type_Declaration
+ | N_Iterator_Specification
+ | N_Loop_Parameter_Specification
+ | N_Object_Renaming_Declaration
+ | N_Subtype_Declaration;
+ end Possible_Side_Effect_In_SPARK;
+
-- Local variables
Loc : constant Source_Ptr := Sloc (Exp);
@@ -11143,11 +11501,11 @@ package body Exp_Util is
begin
-- Handle cases in which there is nothing to do. In GNATprove mode,
-- removal of side effects is useful for the light expansion of
- -- renamings. This removal should only occur when not inside a
- -- generic and not doing a preanalysis.
+ -- renamings.
if not Expander_Active
- and (Inside_A_Generic or not Full_Analysis or not GNATprove_Mode)
+ and then not
+ (GNATprove_Mode and then Possible_Side_Effect_In_SPARK (Exp))
then
return;
@@ -11185,14 +11543,6 @@ package body Exp_Util is
and then Is_Class_Wide_Type (Etype (Exp))
then
return;
-
- -- An expression which is in SPARK mode is considered side effect free
- -- if the resulting value is captured by a variable or a constant.
-
- elsif GNATprove_Mode
- and then Nkind (Parent (Exp)) = N_Object_Declaration
- then
- return;
end if;
-- The remaining processing is done with all checks suppressed
@@ -11394,8 +11744,8 @@ package body Exp_Util is
-- If this is a packed array component or a selected component with a
-- nonstandard representation, we cannot generate a reference because
-- the component may be unaligned, so we must use a renaming and this
- -- renaming must be handled by the front end, as the back end may balk
- -- at the nonstandard representation (see Exp_Ch2.Expand_Renaming).
+ -- renaming is handled by the front end, as the back end may balk at
+ -- the nonstandard representation (see Evaluation_Required in Exp_Ch8).
elsif Nkind (Exp) in N_Indexed_Component | N_Selected_Component
and then Has_Non_Standard_Rep (Etype (Prefix (Exp)))
@@ -11409,8 +11759,7 @@ package body Exp_Util is
Subtype_Mark => New_Occurrence_Of (Exp_Type, Loc),
Name => Relocate_Node (Exp)));
- -- For an expression that denotes a name, we can use a renaming scheme
- -- that is handled by the back end, instead of the front end as above.
+ -- For an expression that denotes a name, we can use a renaming scheme.
-- This is needed for correctness in the case of a volatile object of
-- a nonvolatile type because the Make_Reference call of the "default"
-- approach would generate an illegal access value (an access value
@@ -11433,8 +11782,6 @@ package body Exp_Util is
Subtype_Mark => New_Occurrence_Of (Exp_Type, Loc),
Name => Relocate_Node (Exp)));
- Set_Is_Renaming_Of_Object (Def_Id, False);
-
-- Avoid generating a variable-sized temporary, by generating the
-- reference just for the function call. The transformation could be
-- refined to apply only when the array component is constrained by a
@@ -11845,8 +12192,7 @@ package body Exp_Util is
-- and view swaps, the parent type is taken from the formal
-- parameter of the subprogram being called.
- if Nkind (Context) in
- N_Function_Call | N_Procedure_Call_Statement
+ if Nkind (Context) in N_Subprogram_Call
and then No (Type_Map.Get (Entity (Name (Context))))
then
New_Ref :=
@@ -12288,8 +12634,7 @@ package body Exp_Util is
if Is_Ignored_Ghost_Entity (Typ) then
null;
- elsif ((Is_Access_Type (Typ)
- and then not Is_Access_Subprogram_Type (Typ)
+ elsif ((Is_Access_Object_Type (Typ)
and then Needs_Finalization
(Available_View (Designated_Type (Typ))))
or else (Is_Type (Typ) and then Needs_Finalization (Typ)))
@@ -13443,88 +13788,6 @@ package body Exp_Util is
end if;
end Small_Integer_Type_For;
- --------------------------
- -- Target_Has_Fixed_Ops --
- --------------------------
-
- Integer_Sized_Small : Ureal;
- -- Set to 2.0 ** -(Integer'Size - 1) the first time that this function is
- -- called (we don't want to compute it more than once).
-
- Long_Integer_Sized_Small : Ureal;
- -- Set to 2.0 ** -(Long_Integer'Size - 1) the first time that this function
- -- is called (we don't want to compute it more than once)
-
- First_Time_For_THFO : Boolean := True;
- -- Set to False after first call (if Fractional_Fixed_Ops_On_Target)
-
- function Target_Has_Fixed_Ops
- (Left_Typ : Entity_Id;
- Right_Typ : Entity_Id;
- Result_Typ : Entity_Id) return Boolean
- is
- function Is_Fractional_Type (Typ : Entity_Id) return Boolean;
- -- Return True if the given type is a fixed-point type with a small
- -- value equal to 2 ** (-(T'Object_Size - 1)) and whose values have
- -- an absolute value less than 1.0. This is currently limited to
- -- fixed-point types that map to Integer or Long_Integer.
-
- ------------------------
- -- Is_Fractional_Type --
- ------------------------
-
- function Is_Fractional_Type (Typ : Entity_Id) return Boolean is
- begin
- if Esize (Typ) = Standard_Integer_Size then
- return Small_Value (Typ) = Integer_Sized_Small;
-
- elsif Esize (Typ) = Standard_Long_Integer_Size then
- return Small_Value (Typ) = Long_Integer_Sized_Small;
-
- else
- return False;
- end if;
- end Is_Fractional_Type;
-
- -- Start of processing for Target_Has_Fixed_Ops
-
- begin
- -- Return False if Fractional_Fixed_Ops_On_Target is false
-
- if not Fractional_Fixed_Ops_On_Target then
- return False;
- end if;
-
- -- Here the target has Fractional_Fixed_Ops, if first time, compute
- -- standard constants used by Is_Fractional_Type.
-
- if First_Time_For_THFO then
- First_Time_For_THFO := False;
-
- Integer_Sized_Small :=
- UR_From_Components
- (Num => Uint_1,
- Den => UI_From_Int (Standard_Integer_Size - 1),
- Rbase => 2);
-
- Long_Integer_Sized_Small :=
- UR_From_Components
- (Num => Uint_1,
- Den => UI_From_Int (Standard_Long_Integer_Size - 1),
- Rbase => 2);
- end if;
-
- -- Return True if target supports fixed-by-fixed multiply/divide for
- -- fractional fixed-point types (see Is_Fractional_Type) and the operand
- -- and result types are equivalent fractional types.
-
- return Is_Fractional_Type (Base_Type (Left_Typ))
- and then Is_Fractional_Type (Base_Type (Right_Typ))
- and then Is_Fractional_Type (Base_Type (Result_Typ))
- and then Esize (Left_Typ) = Esize (Right_Typ)
- and then Esize (Left_Typ) = Esize (Result_Typ);
- end Target_Has_Fixed_Ops;
-
-------------------
-- Type_Map_Hash --
-------------------
diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads
index 37eb86f..96d3894 100644
--- a/gcc/ada/exp_util.ads
+++ b/gcc/ada/exp_util.ads
@@ -293,23 +293,29 @@ package Exp_Util is
-- type is frozen.
function Build_DIC_Call
- (Loc : Source_Ptr;
- Obj_Id : Entity_Id;
- Typ : Entity_Id) return Node_Id;
- -- Build a call to the DIC procedure of type Typ with Obj_Id as the actual
+ (Loc : Source_Ptr;
+ Obj_Name : Node_Id;
+ Typ : Entity_Id) return Node_Id;
+ -- Build a call to the DIC procedure for Typ with Obj_Name as the actual
-- parameter.
procedure Build_DIC_Procedure_Body
- (Typ : Entity_Id;
- For_Freeze : Boolean := False);
+ (Typ : Entity_Id;
+ Partial_DIC : Boolean := False);
-- Create the body of the procedure which verifies the assertion expression
- -- of pragma Default_Initial_Condition at run time. Flag For_Freeze should
- -- be set when the body is constructed as part of the freezing actions for
- -- Typ.
-
- procedure Build_DIC_Procedure_Declaration (Typ : Entity_Id);
+ -- of pragma Default_Initial_Condition at run time. Partial_DIC indicates
+ -- that a partial DIC-checking procedure body should be built, for checking
+ -- a DIC associated with the type's partial view, and which will be called
+ -- by the main DIC procedure.
+
+ procedure Build_DIC_Procedure_Declaration
+ (Typ : Entity_Id;
+ Partial_DIC : Boolean := False);
-- Create the declaration of the procedure which verifies the assertion
- -- expression of pragma Default_Initial_Condition at run time.
+ -- expression of pragma Default_Initial_Condition at run time. Partial_DIC
+ -- indicates that a partial DIC-checking procedure should be declared,
+ -- for checking a DIC associated with the type's partial view, and which
+ -- will be called by the main DIC procedure.
procedure Build_Invariant_Procedure_Body
(Typ : Entity_Id;
@@ -750,11 +756,6 @@ package Exp_Util is
-- Return a suitable standard integer type containing at least S bits and
-- of the signedness given by Uns.
- function Is_All_Null_Statements (L : List_Id) return Boolean;
- -- Return True if all the items of the list are N_Null_Statement nodes.
- -- False otherwise. True for an empty list. It is an error to call this
- -- routine with No_List as the argument.
-
function Is_Displacement_Of_Object_Or_Function_Result
(Obj_Id : Entity_Id) return Boolean;
-- Determine whether Obj_Id is a source entity that has been initialized by
@@ -864,11 +865,6 @@ package Exp_Util is
-- list. If Warn is True, a warning will be output at the start of N
-- indicating the deletion of the code.
- function Known_Non_Negative (Opnd : Node_Id) return Boolean;
- -- Given a node for a subexpression, determines if it represents a value
- -- that cannot possibly be negative, and if so returns True. A value of
- -- False means that it is not known if the value is positive or negative.
-
function Make_Invariant_Call (Expr : Node_Id) return Node_Id;
-- Generate a call to the Invariant_Procedure associated with the type of
-- expression Expr. Expr is passed as an actual parameter in the call.
@@ -949,11 +945,6 @@ package Exp_Util is
-- consist of constants, when the object has a nontrivial initialization
-- or is controlled.
- function Non_Limited_Designated_Type (T : Entity_Id) return Entity_Id;
- -- An anonymous access type may designate a limited view. Check whether
- -- non-limited view is available during expansion, to examine components
- -- or other characteristics of the full type.
-
function OK_To_Do_Constant_Replacement (E : Entity_Id) return Boolean;
-- This function is used when testing whether or not to replace a reference
-- to entity E by a known constant value. Such replacement must be done
@@ -1172,15 +1163,6 @@ package Exp_Util is
-- Return the smallest standard integer type containing at least S bits and
-- of the signedness given by Uns.
- function Target_Has_Fixed_Ops
- (Left_Typ : Entity_Id;
- Right_Typ : Entity_Id;
- Result_Typ : Entity_Id) return Boolean;
- -- Returns True if and only if the target machine has direct support
- -- for fixed-by-fixed multiplications and divisions for the given
- -- operand and result types. This is called in package Exp_Fixd to
- -- determine whether to expand such operations.
-
function Type_May_Have_Bit_Aligned_Components
(Typ : Entity_Id) return Boolean;
-- Determines if Typ is a composite type that has within it (looking down
diff --git a/gcc/ada/expect.c b/gcc/ada/expect.c
index 718886d..30c5b8e 100644
--- a/gcc/ada/expect.c
+++ b/gcc/ada/expect.c
@@ -39,6 +39,7 @@
#include "system.h"
#endif
+#include "adaint.h"
#include <sys/types.h>
#ifdef __MINGW32__
@@ -78,7 +79,6 @@
#include <process.h>
#include <signal.h>
#include <io.h>
-#include "adaint.h"
#include "mingw32.h"
int
@@ -360,7 +360,11 @@ __gnat_pipe (int *fd)
int
__gnat_expect_fork (void)
{
- return fork ();
+ int pid = fork();
+ if (pid == 0) {
+ __gnat_in_child_after_fork = 1;
+ }
+ return pid;
}
void
diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb
index f3abba1..8dc8a22 100644
--- a/gcc/ada/freeze.adb
+++ b/gcc/ada/freeze.adb
@@ -182,12 +182,6 @@ package body Freeze is
-- the designated type. Otherwise freezing the access type does not freeze
-- the designated type.
- function Is_Uninitialized_Aggregate (N : Node_Id) return Boolean;
- -- Determine whether an array aggregate used in an object declaration
- -- is uninitialized, when the aggregate is declared with a box and
- -- the component type has no default value. Such an aggregate can be
- -- optimized away and prevent the copying of uninitialized data.
-
procedure Process_Default_Expressions
(E : Entity_Id;
After : in out Node_Id);
@@ -727,12 +721,6 @@ package body Freeze is
if Present (Init)
and then not Is_Limited_View (Typ)
then
- if Is_Uninitialized_Aggregate (Init) then
- Init := Empty;
- Set_No_Initialization (Decl);
- return;
- end if;
-
-- Capture initialization value at point of declaration, and make
-- explicit assignment legal, because object may be a constant.
@@ -2007,7 +1995,7 @@ package body Freeze is
| N_Task_Body
| N_Body_Stub
and then
- List_Containing (After) = List_Containing (Parent (E))
+ In_Same_List (After, Parent (E))
then
Error_Msg_Sloc := Sloc (Next (After));
Error_Msg_NE
@@ -2606,13 +2594,6 @@ package body Freeze is
and then not GNATprove_Mode
then
Set_Has_Own_Invariants (Arr);
-
- -- The array type is an implementation base type. Propagate the
- -- same property to the first subtype.
-
- if Is_Itype (Arr) then
- Set_Has_Own_Invariants (First_Subtype (Arr));
- end if;
end if;
-- Warn for pragma Pack overriding foreign convention
@@ -5661,7 +5642,7 @@ package body Freeze is
Has_Rep_Pragma (E, Name_Atomic_Components)
then
Error_Msg_N
- ("stand alone atomic constant must be " &
+ ("standalone atomic constant must be " &
"imported (RM C.6(13))", E);
elsif Has_Rep_Pragma (E, Name_Volatile)
@@ -5669,7 +5650,7 @@ package body Freeze is
Has_Rep_Pragma (E, Name_Volatile_Components)
then
Error_Msg_N
- ("stand alone volatile constant must be " &
+ ("standalone volatile constant must be " &
"imported (RM C.6(13))", E);
end if;
end if;
@@ -6358,35 +6339,6 @@ package body Freeze is
if Is_Fixed_Point_Type (E) then
Freeze_Fixed_Point_Type (E);
- -- Some error checks required for ordinary fixed-point type. Defer
- -- these till the freeze-point since we need the small and range
- -- values. We only do these checks for base types
-
- if Is_Ordinary_Fixed_Point_Type (E) and then Is_Base_Type (E) then
- if Small_Value (E) < Ureal_2_M_80 then
- Error_Msg_Name_1 := Name_Small;
- Error_Msg_N
- ("`&''%` too small, minimum allowed is 2.0'*'*(-80)", E);
-
- elsif Small_Value (E) > Ureal_2_80 then
- Error_Msg_Name_1 := Name_Small;
- Error_Msg_N
- ("`&''%` too large, maximum allowed is 2.0'*'*80", E);
- end if;
-
- if Expr_Value_R (Type_Low_Bound (E)) < Ureal_M_10_36 then
- Error_Msg_Name_1 := Name_First;
- Error_Msg_N
- ("`&''%` too small, minimum allowed is -10.0'*'*36", E);
- end if;
-
- if Expr_Value_R (Type_High_Bound (E)) > Ureal_10_36 then
- Error_Msg_Name_1 := Name_Last;
- Error_Msg_N
- ("`&''%` too large, maximum allowed is 10.0'*'*36", E);
- end if;
- end if;
-
elsif Is_Enumeration_Type (E) then
Freeze_Enumeration_Type (E);
@@ -6403,8 +6355,7 @@ package body Freeze is
-- to subprogram and to internal types generated for 'Access
-- references.
- elsif Is_Access_Type (E)
- and then not Is_Access_Subprogram_Type (E)
+ elsif Is_Access_Object_Type (E)
and then Ekind (E) /= E_Access_Attribute_Type
then
-- If a pragma Default_Storage_Pool applies, and this type has no
@@ -7978,7 +7929,16 @@ package body Freeze is
-- Check that a type referenced by an entity can be frozen
if Is_Entity_Name (Node) and then Present (Entity (Node)) then
- Check_And_Freeze_Type (Etype (Entity (Node)));
+ -- The entity itself may be a type, as in a membership test
+ -- or an attribute reference. Freezing its own type would be
+ -- incomplete if the entity is derived or an extension.
+
+ if Is_Type (Entity (Node)) then
+ Check_And_Freeze_Type (Entity (Node));
+
+ else
+ Check_And_Freeze_Type (Etype (Entity (Node)));
+ end if;
-- Check that the enclosing record type can be frozen
@@ -8134,6 +8094,12 @@ package body Freeze is
-- Returns size of type with given bounds. Also leaves these
-- bounds set as the current bounds of the Typ.
+ function Larger (A, B : Ureal) return Boolean;
+ -- Returns true if A > B with a margin of Typ'Small
+
+ function Smaller (A, B : Ureal) return Boolean;
+ -- Returns true if A < B with a margin of Typ'Small
+
-----------
-- Fsize --
-----------
@@ -8145,6 +8111,24 @@ package body Freeze is
return Minimum_Size (Typ);
end Fsize;
+ ------------
+ -- Larger --
+ ------------
+
+ function Larger (A, B : Ureal) return Boolean is
+ begin
+ return A > B and then A - Small > B;
+ end Larger;
+
+ -------------
+ -- Smaller --
+ -------------
+
+ function Smaller (A, B : Ureal) return Boolean is
+ begin
+ return A < B and then A + Small < B;
+ end Smaller;
+
-- Start of processing for Freeze_Fixed_Point_Type
begin
@@ -8166,7 +8150,7 @@ package body Freeze is
if Present (Atype) then
Set_Esize (Typ, Esize (Atype));
else
- Set_Esize (Typ, Esize (Base_Type (Typ)));
+ Set_Esize (Typ, Esize (Btyp));
end if;
end if;
@@ -8446,6 +8430,111 @@ package body Freeze is
Set_Realval (Hi, Actual_Hi);
end Fudge;
+ -- Enforce some limitations for ordinary fixed-point types. They come
+ -- from an exact algorithm used to implement Text_IO.Fixed_IO and the
+ -- Fore, Image and Value attributes. The requirement on the Small is
+ -- to lie in the range 2**(-(Siz - 1)) .. 2**(Siz - 1) for a type of
+ -- Siz bits (Siz=32,64,128) and the requirement on the bounds is to
+ -- be smaller in magnitude than 10.0**N * 2**(Siz - 1), where N is
+ -- given by the formula N = floor ((Siz - 1) * log 2 / log 10).
+
+ -- If the bounds of a 32-bit type are too large, force 64-bit type
+
+ if Actual_Size <= 32
+ and then Small <= Ureal_2_31
+ and then (Smaller (Expr_Value_R (Lo), Ureal_M_2_10_18)
+ or else Larger (Expr_Value_R (Hi), Ureal_2_10_18))
+ then
+ Actual_Size := 33;
+ end if;
+
+ -- If the bounds of a 64-bit type are too large, force 128-bit type
+
+ if System_Max_Integer_Size = 128
+ and then Actual_Size <= 64
+ and then Small <= Ureal_2_63
+ and then (Smaller (Expr_Value_R (Lo), Ureal_M_9_10_36)
+ or else Larger (Expr_Value_R (Hi), Ureal_9_10_36))
+ then
+ Actual_Size := 65;
+ end if;
+
+ -- Give error messages for first subtypes and not base types, as the
+ -- bounds of base types are always maximum for their size, see below.
+
+ if System_Max_Integer_Size < 128 and then Typ /= Btyp then
+
+ -- See the 128-bit case below for the reason why we cannot test
+ -- against the 2**(-63) .. 2**63 range. This quirk should have
+ -- been kludged around as in the 128-bit case below, but it was
+ -- not and we end up with a ludicrous range as a result???
+
+ if Small < Ureal_2_M_80 then
+ Error_Msg_Name_1 := Name_Small;
+ Error_Msg_N
+ ("`&''%` too small, minimum allowed is 2.0'*'*(-80)", Typ);
+
+ elsif Small > Ureal_2_80 then
+ Error_Msg_Name_1 := Name_Small;
+ Error_Msg_N
+ ("`&''%` too large, maximum allowed is 2.0'*'*80", Typ);
+ end if;
+
+ if Smaller (Expr_Value_R (Lo), Ureal_M_9_10_36) then
+ Error_Msg_Name_1 := Name_First;
+ Error_Msg_N
+ ("`&''%` too small, minimum allowed is -9.0E+36", Typ);
+ end if;
+
+ if Larger (Expr_Value_R (Hi), Ureal_9_10_36) then
+ Error_Msg_Name_1 := Name_Last;
+ Error_Msg_N
+ ("`&''%` too large, maximum allowed is 9.0E+36", Typ);
+ end if;
+
+ elsif System_Max_Integer_Size = 128 and then Typ /= Btyp then
+
+ -- ACATS c35902d tests a delta equal to 2**(-(Max_Mantissa + 1))
+ -- but we cannot really support anything smaller than Fine_Delta
+ -- because of the way we implement I/O for fixed point types???
+
+ if Small = Ureal_2_M_128 then
+ null;
+
+ elsif Small < Ureal_2_M_127 then
+ Error_Msg_Name_1 := Name_Small;
+ Error_Msg_N
+ ("`&''%` too small, minimum allowed is 2.0'*'*(-127)", Typ);
+
+ elsif Small > Ureal_2_127 then
+ Error_Msg_Name_1 := Name_Small;
+ Error_Msg_N
+ ("`&''%` too large, maximum allowed is 2.0'*'*127", Typ);
+ end if;
+
+ if Actual_Size > 64
+ and then (Norm_Num (Small) > Uint_2 ** 127
+ or else Norm_Den (Small) > Uint_2 ** 127)
+ and then Small /= Ureal_2_M_128
+ then
+ Error_Msg_Name_1 := Name_Small;
+ Error_Msg_N
+ ("`&''%` not the ratio of two 128-bit integers", Typ);
+ end if;
+
+ if Smaller (Expr_Value_R (Lo), Ureal_M_10_76) then
+ Error_Msg_Name_1 := Name_First;
+ Error_Msg_N
+ ("`&''%` too small, minimum allowed is -1.0E+76", Typ);
+ end if;
+
+ if Larger (Expr_Value_R (Hi), Ureal_10_76) then
+ Error_Msg_Name_1 := Name_Last;
+ Error_Msg_N
+ ("`&''%` too large, maximum allowed is 1.0E+76", Typ);
+ end if;
+ end if;
+
-- For the decimal case, none of this fudging is required, since there
-- are no end-point problems in the decimal case (the end-points are
-- always included).
@@ -8457,12 +8546,13 @@ package body Freeze is
-- At this stage, the actual size has been calculated and the proper
-- required bounds are stored in the low and high bounds.
- if Actual_Size > 64 then
+ if Actual_Size > System_Max_Integer_Size then
Error_Msg_Uint_1 := UI_From_Int (Actual_Size);
+ Error_Msg_Uint_2 := UI_From_Int (System_Max_Integer_Size);
Error_Msg_N
- ("size required (^) for type& too large, maximum allowed is 64",
+ ("size required (^) for type& too large, maximum allowed is ^",
Typ);
- Actual_Size := 64;
+ Actual_Size := System_Max_Integer_Size;
end if;
-- Check size against explicit given size
@@ -8488,8 +8578,10 @@ package body Freeze is
Actual_Size := 16;
elsif Actual_Size <= 32 then
Actual_Size := 32;
- else
+ elsif Actual_Size <= 64 then
Actual_Size := 64;
+ else
+ Actual_Size := 128;
end if;
Init_Esize (Typ, Actual_Size);
@@ -8500,7 +8592,7 @@ package body Freeze is
-- the full width of the allocated size in bits, to avoid junk range
-- checks on intermediate computations.
- if Base_Type (Typ) = Typ then
+ if Typ = Btyp then
Set_Realval (Lo, -(Small * (Uint_2 ** (Actual_Size - 1))));
Set_Realval (Hi, (Small * (Uint_2 ** (Actual_Size - 1) - 1)));
end if;
@@ -9133,10 +9225,12 @@ package body Freeze is
Check_Overriding_Indicator (E, Empty, Is_Primitive (E));
end if;
- if Modify_Tree_For_C
+ Retype := Get_Fullest_View (Etype (E));
+
+ if Transform_Function_Array
and then Nkind (Parent (E)) = N_Function_Specification
- and then Is_Array_Type (Etype (E))
- and then Is_Constrained (Etype (E))
+ and then Is_Array_Type (Retype)
+ and then Is_Constrained (Retype)
and then not Is_Unchecked_Conversion_Instance (E)
and then not Rewritten_For_C (E)
then
@@ -9144,40 +9238,6 @@ package body Freeze is
end if;
end Freeze_Subprogram;
- --------------------------------
- -- Is_Uninitialized_Aggregate --
- --------------------------------
-
- function Is_Uninitialized_Aggregate (N : Node_Id) return Boolean is
- Aggr : constant Node_Id := Original_Node (N);
- Typ : constant Entity_Id := Etype (Aggr);
-
- Comp : Node_Id;
- Comp_Type : Entity_Id;
- begin
- if Nkind (Aggr) /= N_Aggregate
- or else No (Typ)
- or else Ekind (Typ) /= E_Array_Type
- or else Present (Expressions (Aggr))
- or else No (Component_Associations (Aggr))
- then
- return False;
- else
- Comp_Type := Component_Type (Typ);
- Comp := First (Component_Associations (Aggr));
-
- if not Box_Present (Comp)
- or else Present (Next (Comp))
- then
- return False;
- end if;
-
- return Is_Scalar_Type (Comp_Type)
- and then No (Default_Aspect_Component_Value (Typ))
- and then No (Default_Aspect_Value (Comp_Type));
- end if;
- end Is_Uninitialized_Aggregate;
-
----------------------
-- Is_Fully_Defined --
----------------------
diff --git a/gcc/ada/gcc-interface/Make-lang.in b/gcc/ada/gcc-interface/Make-lang.in
index 78fe602..d88c354 100644
--- a/gcc/ada/gcc-interface/Make-lang.in
+++ b/gcc/ada/gcc-interface/Make-lang.in
@@ -42,7 +42,7 @@ MV = mv
MKDIR = mkdir -p
RM = rm -f
RMDIR = rm -rf
-
+
# Extra flags to pass to recursive makes.
COMMON_ADAFLAGS= -gnatpg
@@ -146,6 +146,7 @@ endif
# Define the names for selecting Ada in LANGUAGES.
ada: gnat1$(exeext) gnatbind$(exeext)
+ada.serial = gnat1$(exeext)
# Tell GNU Make to ignore these, if they exist.
.PHONY: ada
@@ -667,10 +668,13 @@ ada/libgnat/s-excmac.adb: $(srcdir)/ada/libgnat/s-excmac__$(EH_MECHANISM).adb
# Needs to be built with CC=gcc
# Since the RTL should be built with the latest compiler, remove the
# stamp target in the parent directory whenever gnat1 is rebuilt
-gnat1$(exeext): $(TARGET_ADA_SRCS) $(GNAT1_OBJS) $(ADA_BACKEND) libcommon-target.a $(LIBDEPS)
+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)
$(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)
@@ -810,7 +814,6 @@ doc/gnat_rm.pdf: ada/gnat_rm.texi $(gcc_docdir)/include/fdl.texi \
doc/gnat-style.pdf: ada/gnat-style.texi $(gcc_docdir)/include/fdl.texi
$(TEXI2PDF) -c -I $(abs_docdir)/include -o $@ $<
-
# Install hooks:
# gnat1 is installed elsewhere as part of $(COMPILERS).
@@ -904,7 +907,7 @@ ada.maintainer-clean:
-$(RM) ada/nmake.ads
-$(RM) ada/treeprs.ads
-$(RM) ada/snames.ads ada/snames.adb ada/snames.h
-
+
# Stage hooks:
# The main makefile has already created stage?/ada
@@ -1001,7 +1004,7 @@ $(check_acats_targets): check-acats%:
touch $$GCC_RUNTEST_PARALLELIZE_DIR/finished
.PHONY: check-acats $(check_acats_targets)
-
+
# Compiling object files from source files.
# Ada language specific files.
diff --git a/gcc/ada/gcc-interface/Makefile.in b/gcc/ada/gcc-interface/Makefile.in
index 6177d75..836fcbe 100644
--- a/gcc/ada/gcc-interface/Makefile.in
+++ b/gcc/ada/gcc-interface/Makefile.in
@@ -110,7 +110,7 @@ NO_INLINE_ADAFLAGS = -fno-inline
NO_OMIT_ADAFLAGS = -fno-omit-frame-pointer
NO_SIBLING_ADAFLAGS = -fno-optimize-sibling-calls
NO_REORDER_ADAFLAGS = -fno-toplevel-reorder
-GNATLIBFLAGS = -W -Wall -gnatpg -nostdinc
+GNATLIBFLAGS = -W -Wall -gnatg -nostdinc
GNATLIBCFLAGS = -g -O2
# Pretend that _Unwind_GetIPInfo is available for the target by default. This
# should be autodetected during the configuration of libada and passed down to
@@ -216,7 +216,7 @@ endif
ifneq ($(xmake_file),)
include $(xmake_file)
endif
-
+
# Now figure out from those variables how to compile and link.
all.indirect: Makefile ../gnat1$(exeext)
@@ -311,7 +311,7 @@ Makefile: ../config.status $(srcdir)/ada/gcc-interface/Makefile.in $(srcdir)/ada
# This tells GNU make version 3 not to export all the variables
# defined in this file into the environment.
.NOEXPORT:
-
+
# Lists of files for various purposes.
GNATLINK_OBJS = gnatlink.o \
@@ -338,7 +338,7 @@ GNATMAKE_OBJS = a-except.o ali.o ali-util.o aspects.o s-casuti.o alloc.o \
# picks up the right files. For a given target this must be coherent
# with MULTILIB_DIRNAMES defined in gcc/config/target/t-*.
-ifeq ($(strip $(filter-out %x86_64, $(target_cpu))),)
+ifeq ($(strip $(filter-out x86_64, $(target_cpu))),)
ifeq ($(strip $(MULTISUBDIR)),/32)
target_cpu:=i686
else
@@ -348,6 +348,11 @@ ifeq ($(strip $(filter-out %x86_64, $(target_cpu))),)
endif
endif
+# The SuSE PowerPC64/Linux compiler is actually a 32-bit PowerPC compiler
+ifeq ($(strip $(filter-out powerpc64 suse linux%, $(target_cpu) $(target_vendor) $(target_os))),)
+ target_cpu:=powerpc
+endif
+
# Configuration of host tools
# Under linux, host tools need to be linked with -ldl
diff --git a/gcc/ada/gcc-interface/decl.c b/gcc/ada/gcc-interface/decl.c
index 4e6dc84..5ea1b16 100644
--- a/gcc/ada/gcc-interface/decl.c
+++ b/gcc/ada/gcc-interface/decl.c
@@ -261,7 +261,7 @@ typedef struct {
} intrin_binding_t;
static bool intrin_profiles_compatible_p (intrin_binding_t *);
-
+
/* Given GNAT_ENTITY, a GNAT defining identifier node, which denotes some Ada
entity, return the equivalent GCC tree for that entity (a ..._DECL node)
and associate the ..._DECL node with the input GNAT defining identifier.
@@ -667,21 +667,24 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
/* If we have a constant that we are not defining, get the expression it
was defined to represent. This is necessary to avoid generating dumb
- elaboration code in simple cases, but we may throw it away later if it
+ elaboration code in simple cases, and we may throw it away later if it
is not a constant. But do not do it for dispatch tables because they
are only referenced indirectly and we need to have a consistent view
of the exported and of the imported declarations of the tables from
external units for them to be properly merged in LTO mode. Moreover
- simply do not retrieve the expression it if it is an allocator since
+ simply do not retrieve the expression if it is an allocator because
the designated type might still be dummy at this point. Note that we
invoke gnat_to_gnu_external and not gnat_to_gnu because the expression
may contain N_Expression_With_Actions nodes and thus declarations of
- objects from other units that we need to discard. */
+ objects from other units that we need to discard. Note also that we
+ need to do it even if we are only annotating types, so as to be able
+ to validate representation clauses using constants. */
if (!definition
&& !No_Initialization (gnat_decl)
&& !Is_Dispatch_Table_Entity (gnat_entity)
&& Present (gnat_temp = Expression (gnat_decl))
- && Nkind (gnat_temp) != N_Allocator)
+ && Nkind (gnat_temp) != N_Allocator
+ && (Is_Elementary_Type (Etype (gnat_entity)) || !type_annotate_only))
gnu_expr = gnat_to_gnu_external (gnat_temp);
/* ... fall through ... */
@@ -1740,24 +1743,12 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
gnu_type = make_signed_type (esize);
- /* Try to decode the scale factor and to save it for the fixed-point
- types debug hook. */
-
- /* There are various ways to describe the scale factor, however there
- are cases where back-end internals cannot hold it. In such cases,
- we output invalid scale factor for such cases (i.e. the 0/0
- rational constant) but we expect GNAT to output GNAT encodings,
- then. Thus, keep this in sync with
- Exp_Dbug.Is_Handled_Scale_Factor. */
-
/* When encoded as 1/2**N or 1/10**N, describe the scale factor as a
binary or decimal scale: it is easier to read for humans. */
if (UI_Eq (Numerator (gnat_small_value), Uint_1)
&& (Rbase (gnat_small_value) == 2
|| Rbase (gnat_small_value) == 10))
{
- /* Given RM restrictions on 'Small values, we assume here that
- the denominator fits in an int. */
tree base
= build_int_cst (integer_type_node, Rbase (gnat_small_value));
tree exponent
@@ -1770,29 +1761,19 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
base, exponent));
}
- /* Default to arbitrary scale factors descriptions. */
+ /* Use the arbitrary scale factor description. Note that we support
+ a Small_Value whose magnitude is larger than 64-bit even on 32-bit
+ platforms, so we unconditionally use a (dummy) 128-bit type. */
else
{
- const Uint num = Norm_Num (gnat_small_value);
- const Uint den = Norm_Den (gnat_small_value);
+ const Uint gnat_num = Norm_Num (gnat_small_value);
+ const Uint gnat_den = Norm_Den (gnat_small_value);
+ tree gnu_small_type = make_unsigned_type (128);
+ tree gnu_num = UI_To_gnu (gnat_num, gnu_small_type);
+ tree gnu_den = UI_To_gnu (gnat_den, gnu_small_type);
- if (UI_Is_In_Int_Range (num) && UI_Is_In_Int_Range (den))
- {
- tree gnu_num
- = build_int_cst (integer_type_node,
- UI_To_Int (Norm_Num (gnat_small_value)));
- tree gnu_den
- = build_int_cst (integer_type_node,
- UI_To_Int (Norm_Den (gnat_small_value)));
- scale_factor = build2 (RDIV_EXPR, integer_type_node,
- gnu_num, gnu_den);
- }
- else
- /* If compiler internals cannot represent arbitrary scale
- factors, output an invalid scale factor so that debugger
- don't try to handle them but so that we still have a type
- in the output. Note that GNAT */
- scale_factor = integer_zero_node;
+ scale_factor
+ = build2 (RDIV_EXPR, gnu_small_type, gnu_num, gnu_den);
}
TYPE_FIXED_POINT_P (gnu_type) = 1;
@@ -6575,7 +6556,7 @@ update_n_elem (tree n_elem, tree min, tree max)
return n_elem;
}
-
+
/* Given GNAT_ENTITY, elaborate all expressions that are required to
be elaborated at the point of its definition, but do nothing else. */
@@ -6632,7 +6613,7 @@ elaborate_entity (Entity_Id gnat_entity)
}
}
-
+
/* Prepend to ATTR_LIST an entry for an attribute with provided TYPE,
NAME, ARGS and ERROR_POINT. */
@@ -6747,7 +6728,7 @@ prepend_attributes (struct attrib **attr_list, Entity_Id gnat_entity)
if (Nkind (gnat_temp) == N_Pragma)
prepend_one_attribute_pragma (attr_list, gnat_temp);
}
-
+
/* Given a GNAT tree GNAT_EXPR, for an expression which is a value within a
type definition (either a bound or a discriminant value) for GNAT_ENTITY,
return the GCC tree to use for that expression. S is the suffix to use
@@ -6954,7 +6935,7 @@ elaborate_reference (tree ref, Entity_Id gnat_entity, bool definition,
struct er_data er = { gnat_entity, definition, 0 };
return gnat_rewrite_reference (ref, elaborate_reference_1, &er, init);
}
-
+
/* Given a GNU tree and a GNAT list of choices, generate an expression to test
the value passed against the list of choices. */
@@ -7051,7 +7032,7 @@ choices_to_gnu (tree gnu_operand, Node_Id gnat_choices)
return gnu_result;
}
-
+
/* Adjust PACKED setting as passed to gnat_to_gnu_field for a field of
type FIELD_TYPE to be placed in RECORD_TYPE. Return the result. */
@@ -7464,7 +7445,7 @@ gnat_to_gnu_field (Entity_Id gnat_field, tree gnu_record_type, int packed,
return gnu_field;
}
-
+
/* Return true if at least one member of COMPONENT_LIST needs strict
alignment. */
@@ -8430,7 +8411,7 @@ components_to_record (Node_Id gnat_component_list, Entity_Id gnat_record_type,
return (gnu_rep_list && !p_gnu_rep_list) || variants_have_rep;
}
-
+
/* Given GNU_SIZE, a GCC tree representing a size, return a Uint to be
placed into an Esize, Component_Bit_Offset, or Component_Size value
in the GNAT tree. */
@@ -8798,7 +8779,7 @@ annotate_rep (Entity_Id gnat_entity, tree gnu_type)
}
}
}
-
+
/* Scan all fields in GNU_TYPE and return a TREE_LIST where TREE_PURPOSE is
the FIELD_DECL and TREE_VALUE a TREE_VEC containing the byte position, the
value to be placed into DECL_OFFSET_ALIGN and the bit position. The list
@@ -8956,7 +8937,7 @@ build_variant_list (tree gnu_qual_union_type, Node_Id gnat_variant_part,
return gnu_list;
}
-
+
/* If SIZE has overflowed, return the maximum valid size, which is the upper
bound of the signed sizetype in bits, rounded down to ALIGN. Otherwise
return SIZE unmodified. */
@@ -9100,7 +9081,7 @@ validate_size (Uint uint_size, tree gnu_type, Entity_Id gnat_object,
return size;
}
-
+
/* Similarly, but both validate and process a value of RM size. This routine
is only called for types. */
@@ -9177,7 +9158,7 @@ set_rm_size (Uint uint_size, tree gnu_type, Entity_Id gnat_entity)
&& !TYPE_FAT_POINTER_P (gnu_type))
SET_TYPE_ADA_SIZE (gnu_type, size);
}
-
+
/* ALIGNMENT is a Uint giving the alignment specified for GNAT_ENTITY,
a type or object whose present alignment is ALIGN. If this alignment is
valid, return it. Otherwise, give an error and return ALIGN. */
@@ -9270,7 +9251,7 @@ validate_alignment (Uint alignment, Entity_Id gnat_entity, unsigned int align)
return align;
}
-
+
/* Promote the alignment of GNU_TYPE corresponding to GNAT_ENTITY. Return
a positive value on success or zero on failure. */
@@ -9317,7 +9298,7 @@ promote_object_alignment (tree gnu_type, Entity_Id gnat_entity)
return align;
}
-
+
/* Verify that TYPE is something we can implement atomically. If not, issue
an error for GNAT_ENTITY. COMPONENT_P is true if we are being called to
process a component type. */
@@ -9385,7 +9366,7 @@ check_ok_for_atomic_type (tree type, Entity_Id gnat_entity, bool component_p)
post_error_ne ("atomic access to & cannot be guaranteed",
gnat_error_point, gnat_entity);
}
-
+
/* Helper for the intrin compatibility checks family. Evaluate whether
two types are definitely incompatible. */
@@ -9540,7 +9521,7 @@ intrin_profiles_compatible_p (intrin_binding_t * inb)
return return_compatible_p && arglists_compatible_p;
}
-
+
/* Return a FIELD_DECL node modeled on OLD_FIELD. FIELD_TYPE is its type
and RECORD_TYPE is the type of the parent. If SIZE is nonzero, it is the
specified size for this field. POS_LIST is a position list describing
@@ -10154,7 +10135,7 @@ associate_original_type_to_packed_array (tree gnu_type, Entity_Id gnat_entity)
return NULL_TREE;
}
}
-
+
/* Given a type T, a FIELD_DECL F, and a replacement value R, return an
equivalent type with adjusted size expressions where all occurrences
of references to F in a PLACEHOLDER_EXPR have been replaced by R.
@@ -10315,7 +10296,7 @@ substitute_in_type (tree t, tree f, tree r)
return t;
}
}
-
+
/* Return the RM size of GNU_TYPE. This is the actual number of bits
needed to represent the object. */
@@ -10344,7 +10325,7 @@ rm_size (tree gnu_type)
/* For other types, this is just the size. */
return TYPE_SIZE (gnu_type);
}
-
+
/* Return the name to be used for GNAT_ENTITY. If a type, create a
fully-qualified name, possibly with type information encoding.
Otherwise, return the name. */
@@ -10372,7 +10353,7 @@ create_concat_name (Entity_Id gnat_entity, const char *suffix)
{
const Entity_Kind kind = Ekind (gnat_entity);
const bool has_suffix = (suffix != NULL);
- String_Template temp = {1, has_suffix ? strlen (suffix) : 0};
+ String_Template temp = {1, has_suffix ? (int) strlen (suffix) : 0};
String_Pointer sp = {suffix, &temp};
Get_External_Name (gnat_entity, has_suffix, sp);
diff --git a/gcc/ada/gcc-interface/gigi.h b/gcc/ada/gcc-interface/gigi.h
index 355178e..328e5f3 100644
--- a/gcc/ada/gcc-interface/gigi.h
+++ b/gcc/ada/gcc-interface/gigi.h
@@ -325,7 +325,7 @@ extern int double_scalar_alignment;
/* True if floating-point arithmetics may use wider intermediate results. */
extern bool fp_arith_may_widen;
-
+
/* Data structures used to represent attributes. */
enum attrib_type
diff --git a/gcc/ada/gcc-interface/misc.c b/gcc/ada/gcc-interface/misc.c
index 781868e..d0867e0 100644
--- a/gcc/ada/gcc-interface/misc.c
+++ b/gcc/ada/gcc-interface/misc.c
@@ -559,7 +559,7 @@ gnat_printable_name (tree decl, int verbosity)
__gnat_decode (coded_name, ada_name, 0);
- if (verbosity == 2 && !DECL_IS_BUILTIN (decl))
+ if (verbosity == 2 && !DECL_IS_UNDECLARED_BUILTIN (decl))
{
Set_Identifier_Casing (ada_name, DECL_SOURCE_FILE (decl));
return ggc_strdup (Name_Buffer);
@@ -628,16 +628,6 @@ gnat_get_fixed_point_type_info (const_tree type,
/* We expect here only a finite set of pattern. See fixed-point types
handling in gnat_to_gnu_entity. */
- /* Put invalid values when compiler internals cannot represent the scale
- factor. */
- if (scale_factor == integer_zero_node)
- {
- info->scale_factor_kind = fixed_point_scale_factor_arbitrary;
- info->scale_factor.arbitrary.numerator = 0;
- info->scale_factor.arbitrary.denominator = 0;
- return true;
- }
-
if (TREE_CODE (scale_factor) == RDIV_EXPR)
{
tree num = TREE_OPERAND (scale_factor, 0);
@@ -677,8 +667,8 @@ gnat_get_fixed_point_type_info (const_tree type,
&& TREE_CODE (den) == INTEGER_CST);
info->scale_factor_kind = fixed_point_scale_factor_arbitrary;
- info->scale_factor.arbitrary.numerator = tree_to_uhwi (num);
- info->scale_factor.arbitrary.denominator = tree_to_shwi (den);
+ info->scale_factor.arbitrary.numerator = num;
+ info->scale_factor.arbitrary.denominator = den;
return true;
}
diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c
index 059e1a4..4ab26d3 100644
--- a/gcc/ada/gcc-interface/trans.c
+++ b/gcc/ada/gcc-interface/trans.c
@@ -255,7 +255,7 @@ static bool maybe_make_gnu_thunk (Entity_Id gnat_thunk, tree gnu_thunk);
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. */
@@ -735,7 +735,7 @@ gigi (Node_Id gnat_root,
/* We cannot track the location of errors past this point. */
Current_Error_Node = Empty;
}
-
+
/* Return a subprogram decl corresponding to __gnat_rcheck_xx for the given
CHECK if KIND is EXCEPTION_SIMPLE, or else to __gnat_rcheck_xx_ext. */
@@ -779,7 +779,7 @@ build_raise_check (int check, enum exception_info_kind kind)
return result;
}
-
+
/* Return a positive value if an lvalue is required for GNAT_NODE, which is
an N_Attribute_Reference. */
@@ -970,6 +970,10 @@ lvalue_for_aggregate_p (Node_Id gnat_node, tree gnu_type)
/* Even if the parameter is by copy, prefer an lvalue. */
return true;
+ case N_Simple_Return_Statement:
+ /* Likewise for a return value. */
+ return true;
+
case N_Indexed_Component:
case N_Selected_Component:
/* If an elementary component is used, take it from the constant. */
@@ -1333,7 +1337,7 @@ Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p)
return gnu_result;
}
-
+
/* Subroutine of gnat_to_gnu to process gnat_node, an N_Pragma. Return
any statements we generate. */
@@ -1599,7 +1603,7 @@ Pragma_to_gnu (Node_Id gnat_node)
return gnu_result;
}
-
+
/* Check the inline status of nested function FNDECL wrt its parent function.
If a non-inline nested function is referenced from an inline external
@@ -1645,7 +1649,7 @@ check_inlining_for_nested_subprog (tree fndecl)
DECL_UNINLINABLE (parent_decl) = 1;
}
}
-
+
/* Return an expression for the length of TYPE, an integral type, computed in
RESULT_TYPE, another integral type.
@@ -2590,7 +2594,7 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute)
*gnu_result_type_p = gnu_result_type;
return gnu_result;
}
-
+
/* Subroutine of gnat_to_gnu to translate gnat_node, an N_Case_Statement,
to a GCC tree, which is returned. */
@@ -2715,7 +2719,7 @@ Case_Statement_to_gnu (Node_Id gnat_node)
return gnu_result;
}
-
+
/* Return true if we are in the body of a loop. */
static inline bool
@@ -2814,38 +2818,6 @@ can_equal_max_val_p (tree val, tree type, bool reverse)
return can_equal_min_or_max_val_p (val, type, !reverse);
}
-/* Return true if VAL1 can be lower than VAL2. */
-
-static bool
-can_be_lower_p (tree val1, tree val2)
-{
- if (TREE_CODE (val1) == NOP_EXPR)
- {
- tree type = TREE_TYPE (TREE_OPERAND (val1, 0));
- if (can_be_lower_p (TYPE_MAX_VALUE (type), TYPE_MIN_VALUE (type)))
- return true;
-
- val1 = TYPE_MIN_VALUE (type);
- }
-
- if (TREE_CODE (val1) != INTEGER_CST)
- return true;
-
- if (TREE_CODE (val2) == NOP_EXPR)
- {
- tree type = TREE_TYPE (TREE_OPERAND (val2, 0));
- if (can_be_lower_p (TYPE_MAX_VALUE (type), TYPE_MIN_VALUE (type)))
- return true;
-
- val2 = TYPE_MAX_VALUE (type);
- }
-
- if (TREE_CODE (val2) != INTEGER_CST)
- return true;
-
- return tree_int_cst_lt (val1, val2);
-}
-
/* Replace EXPR1 and EXPR2 by invariant expressions if possible. Return
true if both expressions have been replaced and false otherwise. */
@@ -3126,19 +3098,16 @@ Regular_Loop_to_gnu (Node_Id gnat_node, tree *gnu_cond_expr_p)
}
/* If we use the BOTTOM_COND, we can turn the test into an inequality
- test but we may have to add ENTRY_COND to protect the empty loop. */
+ test but we have to add ENTRY_COND to protect the empty loop. */
if (LOOP_STMT_BOTTOM_COND_P (gnu_loop_stmt))
{
test_code = NE_EXPR;
- if (can_be_lower_p (gnu_high, gnu_low))
- {
- gnu_cond_expr
- = build3 (COND_EXPR, void_type_node,
- build_binary_op (LE_EXPR, boolean_type_node,
- gnu_low, gnu_high),
- NULL_TREE, alloc_stmt_list ());
- set_expr_location_from_node (gnu_cond_expr, gnat_iter_scheme);
- }
+ gnu_cond_expr
+ = build3 (COND_EXPR, void_type_node,
+ build_binary_op (LE_EXPR, boolean_type_node,
+ gnu_low, gnu_high),
+ NULL_TREE, alloc_stmt_list ());
+ set_expr_location_from_node (gnu_cond_expr, gnat_iter_scheme);
}
/* Open a new nesting level that will surround the loop to declare the
@@ -3363,7 +3332,7 @@ Loop_Statement_to_gnu (Node_Id gnat_node)
return gnu_result;
}
-
+
/* This page implements a form of Named Return Value optimization modeled
on the C++ optimization of the same name. The main difference is that
we disregard any semantical considerations when applying it here, the
@@ -3855,7 +3824,7 @@ build_return_expr (tree ret_obj, tree ret_val)
return build1 (RETURN_EXPR, void_type_node, result_expr);
}
-
+
/* Subroutine of gnat_to_gnu to process gnat_node, an N_Subprogram_Body. We
don't return anything. */
@@ -4179,7 +4148,7 @@ Subprogram_Body_to_gnu (Node_Id gnat_node)
else
rest_of_subprog_body_compilation (gnu_subprog_decl);
}
-
+
/* The type of an atomic access. */
typedef enum { NOT_ATOMIC, SIMPLE_ATOMIC, OUTER_ATOMIC } atomic_acces_t;
@@ -4369,8 +4338,8 @@ not_atomic:
*type = NOT_ATOMIC;
*sync = false;
}
-
- /* Return true if GNAT_NODE requires simple atomic access and, if so, set SYNC
+
+/* Return true if GNAT_NODE requires simple atomic access and, if so, set SYNC
according to the associated synchronization setting. */
static inline bool
@@ -4548,7 +4517,11 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target,
and the return type has variable size, because the gimplifier
doesn't handle these cases.
- 4. There is no target and we have misaligned In Out or Out parameters
+ 4. There is a target which is a bit-field and the function returns an
+ unconstrained record type with default discriminant, because the
+ return may copy more data than the bit-field can contain.
+
+ 5. There is no target and we have misaligned In Out or Out parameters
passed by reference, because we need to preserve the return value
before copying back the parameters. However, in this case, we'll
defer creating the temporary, see below.
@@ -4571,7 +4544,11 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target,
|| (TREE_CODE (TREE_TYPE (gnu_target)) == ARRAY_TYPE
&& TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_target)))
== INTEGER_CST))
- && TREE_CODE (TYPE_SIZE (gnu_result_type)) != INTEGER_CST)))
+ && TREE_CODE (TYPE_SIZE (gnu_result_type)) != INTEGER_CST)
+ || (gnu_target
+ && TREE_CODE (gnu_target) == COMPONENT_REF
+ && DECL_BIT_FIELD (TREE_OPERAND (gnu_target, 1))
+ && type_is_padding_self_referential (gnu_result_type))))
{
gnu_retval = create_temporary ("R", gnu_result_type);
DECL_RETURN_VALUE_P (gnu_retval) = 1;
@@ -5240,7 +5217,7 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target,
return gnu_result;
}
-
+
/* Subroutine of gnat_to_gnu to translate gnat_node, an
N_Handled_Sequence_Of_Statements, to a GCC tree, which is returned. */
@@ -5479,7 +5456,7 @@ Handled_Sequence_Of_Statements_to_gnu (Node_Id gnat_node)
return gnu_result;
}
-
+
/* Subroutine of gnat_to_gnu to translate gnat_node, an N_Exception_Handler,
to a GCC tree, which is returned. This is the variant for front-end sjlj
exception handling. */
@@ -5548,7 +5525,7 @@ Exception_Handler_to_gnu_fe_sjlj (Node_Id gnat_node)
return build3 (COND_EXPR, void_type_node, gnu_choice, gnu_body, NULL_TREE);
}
-
+
/* Return true if no statement in GNAT_LIST can alter the control flow. */
static bool
@@ -5755,7 +5732,7 @@ Exception_Handler_to_gnu_gcc (Node_Id gnat_node)
return
build2 (CATCH_EXPR, void_type_node, gnu_etypes_list, end_stmt_group ());
}
-
+
/* Subroutine of gnat_to_gnu to generate code for an N_Compilation unit. */
static void
@@ -5885,7 +5862,7 @@ Compilation_Unit_to_gnu (Node_Id gnat_node)
/* Force the processing for all nodes that remain in the queue. */
process_deferred_decl_context (true);
}
-
+
/* Mark COND, a boolean expression, as predicating a call to a noreturn
function, i.e. predict that it is very likely false, and return it.
@@ -6099,7 +6076,7 @@ Raise_Error_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p)
return gnu_result;
}
-
+
/* Return true if GNAT_NODE is on the LHS of an assignment or an actual
parameter of a call. */
@@ -7085,6 +7062,8 @@ gnat_to_gnu (Node_Id gnat_node)
if (TREE_CODE (gnu_lhs) == INTEGER_CST && ignore_lhs_overflow)
TREE_OVERFLOW (gnu_lhs) = TREE_OVERFLOW (gnu_old_lhs);
gnu_rhs = convert (gnu_type, gnu_rhs);
+ if (gnu_max_shift)
+ gnu_max_shift = convert (gnu_type, gnu_max_shift);
}
/* For signed integer addition, subtraction and multiplication, do an
@@ -7192,9 +7171,7 @@ gnat_to_gnu (Node_Id gnat_node)
const Entity_Id gnat_desig_type
= Designated_Type (Underlying_Type (Etype (gnat_node)));
- /* The flag is effectively only set on the base types. */
- ignore_init_type
- = Has_Constrained_Partial_View (Base_Type (gnat_desig_type));
+ ignore_init_type = Has_Constrained_Partial_View (gnat_desig_type);
gnu_init = gnat_to_gnu (Expression (gnat_temp));
gnu_init = maybe_unconstrained_array (gnu_init);
@@ -8284,8 +8261,10 @@ gnat_to_gnu (Node_Id gnat_node)
/* Remove padding only if the inner object is of self-referential
size: in that case it must be an object of unconstrained type
with a default discriminant and we want to avoid copying too
- much data. */
- if (type_is_padding_self_referential (TREE_TYPE (gnu_result)))
+ 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))))
gnu_result = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result))),
gnu_result);
}
@@ -8364,7 +8343,7 @@ gnat_to_gnu_external (Node_Id gnat_node)
return gnu_result;
}
-
+
/* Return true if the statement list STMT_LIST is empty. */
static bool
@@ -8408,7 +8387,7 @@ insert_code_for (Node_Id gnat_node)
save_gnu_tree (gnat_node, NULL_TREE, true);
}
-
+
/* Start a new statement group chained to the previous group. */
void
@@ -8680,7 +8659,7 @@ build_stmt_group (List_Id gnat_list, bool binding_p)
return end_stmt_group ();
}
-
+
/* Generate GIMPLE in place for the expression at *EXPR_P. */
int
@@ -8929,7 +8908,7 @@ gnat_gimplify_stmt (tree *stmt_p)
gcc_unreachable ();
}
}
-
+
/* Force a reference to each of the entities in GNAT_PACKAGE recursively.
This routine is exclusively called in type_annotate mode, to compute DDA
@@ -9055,7 +9034,7 @@ elaborate_all_entities (Node_Id gnat_node)
if (Nkind (Unit (gnat_node)) == N_Package_Body)
elaborate_all_entities (Library_Unit (gnat_node));
}
-
+
/* Do the processing of GNAT_NODE, an N_Freeze_Entity. */
static void
@@ -9195,7 +9174,7 @@ process_freeze_entity (Node_Id gnat_node)
used_types_insert (TREE_TYPE (gnu_new));
}
}
-
+
/* Elaborate decls in the lists GNAT_DECLS and GNAT_DECLS2, if present.
We make two passes, one to elaborate anything other than bodies (but
we declare a function if there was no spec). The second pass
@@ -9330,7 +9309,7 @@ process_decls (List_Id gnat_decls, List_Id gnat_decls2,
add_stmt (gnat_to_gnu (gnat_decl));
}
}
-
+
/* Make a unary operation of kind CODE using build_unary_op, but guard
the operation by an overflow check. CODE can be one of NEGATE_EXPR
or ABS_EXPR. GNU_TYPE is the type desired for the result. Usually
@@ -9394,6 +9373,11 @@ build_binary_op_trapv (enum tree_code code, tree gnu_type, tree left,
/* If no operand is a constant, we use the generic implementation. */
if (TREE_CODE (lhs) != INTEGER_CST && TREE_CODE (rhs) != INTEGER_CST)
{
+ /* First convert the operands to the result type like build_binary_op.
+ This is where the bias is made explicit for biased types. */
+ lhs = convert (gnu_type, lhs);
+ rhs = convert (gnu_type, rhs);
+
/* Never inline a 64-bit mult for a 32-bit target, it's way too long. */
if (code == MULT_EXPR && precision == 64 && BITS_PER_WORD < 64)
{
@@ -9573,7 +9557,7 @@ emit_check (tree gnu_cond, tree gnu_expr, int reason, Node_Id gnat_node)
: build_int_cst (TREE_TYPE (gnu_expr), 0)),
gnu_expr);
}
-
+
/* Return an expression that converts GNU_EXPR to GNAT_TYPE, doing overflow
checks if OVERFLOW_P is true. If TRUNCATE_P is true, do a fp-to-integer
conversion with truncation, otherwise round. GNAT_NODE is the GNAT node
@@ -9758,7 +9742,7 @@ convert_with_check (Entity_Id gnat_type, tree gnu_expr, bool overflow_p,
return convert (gnu_type, gnu_result);
}
-
+
/* Return true if GNU_EXPR can be directly addressed. This is the case
unless it is an expression involving computation or if it involves a
reference to a bitfield or to an object not sufficiently aligned for
@@ -9936,7 +9920,7 @@ addressable_p (tree gnu_expr, tree gnu_type)
return false;
}
}
-
+
/* Do the processing for the declaration of a GNAT_ENTITY, a type or subtype.
If a Freeze node exists for the entity, delay the bulk of the processing.
Otherwise make a GCC type for GNAT_ENTITY and set up the correspondence. */
@@ -10020,7 +10004,7 @@ process_type (Entity_Id gnat_entity)
TREE_TYPE (gnu_new));
}
}
-
+
/* Subroutine of assoc_to_constructor: VALUES is a list of field associations,
some of which are from RECORD_TYPE. Return a CONSTRUCTOR consisting of the
associations that are from RECORD_TYPE. If we see an internal record, make
@@ -10174,7 +10158,7 @@ pos_to_constructor (Node_Id gnat_expr, tree gnu_array_type)
return gnat_build_constructor (gnu_array_type, gnu_expr_vec);
}
-
+
/* Process a N_Validate_Unchecked_Conversion node. */
static void
@@ -10233,7 +10217,7 @@ validate_unchecked_conversion (Node_Id gnat_node)
}
}
}
-
+
/* Convert SLOC into LOCUS. Return true if SLOC corresponds to a
source code location and false if it doesn't. If CLEAR_COLUMN is
true, set the column information to 0. If DECL is given and SLOC
@@ -10415,7 +10399,7 @@ set_end_locus_from_node (tree gnu_node, Node_Id gnat_node)
return false;
}
}
-
+
/* Return a colon-separated list of encodings contained in encoded Ada
name. */
@@ -10436,7 +10420,7 @@ decode_name (const char *name)
__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. */
@@ -10746,8 +10730,11 @@ maybe_make_gnu_thunk (Entity_Id gnat_thunk, tree gnu_thunk)
tree gnu_target = gnat_to_gnu_entity (gnat_target, NULL_TREE, false);
- /* Thunk and target must have the same nesting level, if any. */
- gcc_assert (DECL_CONTEXT (gnu_thunk) == DECL_CONTEXT (gnu_target));
+ /* If the target is local, then thunk and target must have the same context
+ because cgraph_node::expand_thunk can only forward the static chain. */
+ if (DECL_STATIC_CHAIN (gnu_target)
+ && DECL_CONTEXT (gnu_thunk) != DECL_CONTEXT (gnu_target))
+ return false;
/* If the target returns by invisible reference and is external, apply the
same transformation as Subprogram_Body_to_gnu here. */
diff --git a/gcc/ada/gcc-interface/utils.c b/gcc/ada/gcc-interface/utils.c
index d50872f..494f60e 100644
--- a/gcc/ada/gcc-interface/utils.c
+++ b/gcc/ada/gcc-interface/utils.c
@@ -357,7 +357,7 @@ add_deferred_decl_context (tree decl, Entity_Id gnat_scope, int force_global);
computed. */
static void add_deferred_type_context (struct deferred_decl_context_node *n,
tree type);
-
+
/* Initialize data structures of the utils.c module. */
void
@@ -397,7 +397,7 @@ destroy_gnat_utils (void)
pad_type_hash_table->empty ();
pad_type_hash_table = NULL;
}
-
+
/* GNAT_ENTITY is a GNAT tree node for an entity. Associate GNU_DECL, a GCC
tree node, with GNAT_ENTITY. If GNU_DECL is not a ..._DECL node, abort.
If NO_CHECK is true, the latter check is suppressed.
@@ -438,7 +438,7 @@ present_gnu_tree (Entity_Id gnat_entity)
{
return PRESENT_GNU_TREE (gnat_entity);
}
-
+
/* Make a dummy type corresponding to GNAT_TYPE. */
tree
@@ -533,7 +533,7 @@ build_dummy_unc_pointer_types (Entity_Id gnat_desig_type, tree gnu_desig_type)
TYPE_REFERENCE_TO (gnu_desig_type) = gnu_fat_type;
TYPE_OBJECT_RECORD_TYPE (gnu_desig_type) = gnu_object_type;
}
-
+
/* Return true if we are in the global binding level. */
bool
@@ -663,7 +663,7 @@ gnat_zaplevel (void)
level->chain = free_binding_level;
free_binding_level = level;
}
-
+
/* Set the context of TYPE and its parallel types (if any) to CONTEXT. */
static void
@@ -935,7 +935,7 @@ gnat_pushdecl (tree decl, Node_Id gnat_node)
}
}
}
-
+
/* Create a record type that contains a SIZE bytes long field of TYPE with a
starting bit position so that it is aligned to ALIGN bits, and leaving at
least ROOM bytes free before the field. BASE_ALIGN is the alignment the
@@ -1772,7 +1772,7 @@ set_reverse_storage_order_on_pad_type (tree type)
TYPE_REVERSE_STORAGE_ORDER (type) = 1;
return canonicalize_pad_type (type);
}
-
+
/* Relate the alias sets of GNU_NEW_TYPE and GNU_OLD_TYPE according to OP.
If this is a multi-dimensional array type, do this recursively.
@@ -1847,7 +1847,7 @@ relate_alias_sets (tree gnu_new_type, tree gnu_old_type, enum alias_set_op op)
record_component_aliases (gnu_new_type);
}
-
+
/* Record TYPE as a builtin type for Ada. NAME is the name of the type.
ARTIFICIAL_P is true if the type was generated by the compiler. */
@@ -1863,7 +1863,7 @@ record_builtin_type (const char *name, tree type, bool artificial_p)
if (debug_hooks->type_decl)
debug_hooks->type_decl (type_decl, false);
}
-
+
/* Finish constructing the character type CHAR_TYPE.
In Ada character types are enumeration types and, as a consequence, are
@@ -2558,7 +2558,7 @@ split_plus (tree in, tree *pvar)
else
return bitsize_zero_node;
}
-
+
/* Return a copy of TYPE but safe to modify in any way. */
tree
@@ -2595,7 +2595,7 @@ copy_type (tree type)
return new_type;
}
-
+
/* Return a subtype of sizetype with range MIN to MAX and whose
TYPE_INDEX_TYPE is INDEX. GNAT_NODE is used for the position
of the associated TYPE_DECL. */
@@ -2634,8 +2634,8 @@ create_range_type (tree type, tree min, tree max)
return range_type;
}
-
- /* Return an extra subtype of TYPE with range MIN to MAX. */
+
+/* Return an extra subtype of TYPE with range MIN to MAX. */
tree
create_extra_subtype (tree type, tree min, tree max)
@@ -2652,7 +2652,7 @@ create_extra_subtype (tree type, tree min, tree max)
return subtype;
}
-
+
/* Return a TYPE_DECL node suitable for the TYPE_STUB_DECL field of TYPE.
NAME gives the name of the type to be used in the declaration. */
@@ -2718,7 +2718,7 @@ create_type_decl (tree name, tree type, bool artificial_p, bool debug_info_p,
return type_decl;
}
-
+
/* Return a VAR_DECL or CONST_DECL node.
NAME gives the name of the variable. ASM_NAME is its assembler name
@@ -2886,7 +2886,7 @@ create_var_decl (tree name, tree asm_name, tree type, tree init,
return var_decl;
}
-
+
/* Return true if TYPE, an aggregate type, contains (or is) an array.
If SELF_REFERENTIAL is true, then an additional requirement on the
array is that it be self-referential. */
@@ -3097,7 +3097,7 @@ create_field_decl (tree name, tree type, tree record_type, tree size, tree pos,
return field_decl;
}
-
+
/* Return a PARM_DECL node with NAME and TYPE. */
tree
@@ -3131,7 +3131,7 @@ create_param_decl (tree name, tree type)
DECL_ARG_TYPE (param_decl) = type;
return param_decl;
}
-
+
/* Process the attributes in ATTR_LIST for NODE, which is either a DECL or
a TYPE. If IN_PLACE is true, the tree pointed to by NODE should not be
changed. GNAT_NODE is used for the position of error messages. */
@@ -3420,7 +3420,7 @@ create_label_decl (tree name, Node_Id gnat_node)
return label_decl;
}
-
+
/* Return a FUNCTION_DECL node. NAME is the name of the subprogram, ASM_NAME
its assembler name, TYPE its type (a FUNCTION_TYPE or METHOD_TYPE node),
PARAM_DECL_LIST the list of its parameters (a list of PARM_DECL nodes
@@ -3558,7 +3558,7 @@ finish_subprog_decl (tree decl, tree asm_name, tree type)
DECL_NAME (decl) = main_identifier_node;
}
}
-
+
/* Set up the framework for generating code for SUBPROG_DECL, a subprogram
body. This routine needs to be invoked before processing the declarations
appearing in the subprogram. */
@@ -3830,7 +3830,7 @@ fntype_same_flags_p (const_tree t, tree cico_list, bool return_unconstrained_p,
&& TYPE_RETURN_BY_DIRECT_REF_P (t) == return_by_direct_ref_p
&& TREE_ADDRESSABLE (t) == return_by_invisi_ref_p;
}
-
+
/* EXP is an expression for the size of an object. If this size contains
discriminant references, replace them with the maximum (if MAX_P) or
minimum (if !MAX_P) possible value of the discriminant.
@@ -4042,7 +4042,7 @@ max_size (tree exp, bool max_p)
gcc_unreachable ();
}
-
+
/* Build a template of type TEMPLATE_TYPE from the array bounds of ARRAY_TYPE.
EXPR is an expression that we can use to locate any PLACEHOLDER_EXPRs.
Return a constructor for the template. */
@@ -4108,7 +4108,7 @@ build_template (tree template_type, tree array_type, tree expr)
return gnat_build_constructor (template_type, template_elts);
}
-
+
/* Return true if TYPE is suitable for the element type of a vector. */
static bool
@@ -4198,7 +4198,7 @@ build_vector_type_for_array (tree array_type, tree attribute)
TYPE_REPRESENTATIVE_ARRAY (vector_type) = array_type;
return vector_type;
}
-
+
/* Build a type to be used to represent an aliased object whose nominal type
is an unconstrained array. This consists of a RECORD_TYPE containing a
field of TEMPLATE_TYPE and a field of OBJECT_TYPE, which is an ARRAY_TYPE.
@@ -4248,7 +4248,7 @@ build_unc_object_type_from_ptr (tree thin_fat_ptr_type, tree object_type,
return
build_unc_object_type (template_type, object_type, name, debug_info_p);
}
-
+
/* Update anything previously pointing to OLD_TYPE to point to NEW_TYPE.
In the normal case this is just two adjustments, but we have more to
do if NEW_TYPE is an UNCONSTRAINED_ARRAY_TYPE. */
@@ -4379,7 +4379,7 @@ update_pointer_to (tree old_type, tree new_type)
TYPE_REFERENCE_TO (old_type) = NULL_TREE;
}
}
-
+
/* Convert EXPR, a pointer to a constrained array, into a pointer to an
unconstrained one. This involves making or finding a template. */
@@ -4483,7 +4483,7 @@ convert_to_fat_pointer (tree type, tree expr)
CONSTRUCTOR_APPEND_ELT (v, DECL_CHAIN (TYPE_FIELDS (type)), template_addr);
return gnat_build_constructor (type, v);
}
-
+
/* Create an expression whose value is that of EXPR,
converted to type TYPE. The TREE_TYPE of the value
is always TYPE. This function implements all reasonable
@@ -4930,10 +4930,6 @@ convert (tree type, tree expr)
convert (TREE_TYPE (type),
TYPE_MIN_VALUE (type))));
- /* ... fall through ... */
-
- case ENUMERAL_TYPE:
- case BOOLEAN_TYPE:
/* If we are converting an additive expression to an integer type
with lower precision, be wary of the optimization that can be
applied by convert_to_integer. There are 2 problematic cases:
@@ -4945,8 +4941,7 @@ convert (tree type, tree expr)
intermediate conversion that changes the sign could
be inserted and thus introduce an artificial overflow
at compile time when the placeholder is substituted. */
- if (code == INTEGER_TYPE
- && ecode == INTEGER_TYPE
+ if (ecode == INTEGER_TYPE
&& TYPE_PRECISION (type) < TYPE_PRECISION (etype)
&& (TREE_CODE (expr) == PLUS_EXPR || TREE_CODE (expr) == MINUS_EXPR))
{
@@ -4955,11 +4950,18 @@ convert (tree type, tree expr)
if ((TREE_CODE (TREE_TYPE (op0)) == INTEGER_TYPE
&& TYPE_BIASED_REPRESENTATION_P (TREE_TYPE (op0)))
|| CONTAINS_PLACEHOLDER_P (expr))
- return build1 (NOP_EXPR, type, expr);
+ return fold_convert (type, expr);
}
+ /* ... fall through ... */
+
+ case ENUMERAL_TYPE:
return fold (convert_to_integer (type, expr));
+ case BOOLEAN_TYPE:
+ /* Do not use convert_to_integer with boolean types. */
+ return fold_convert_loc (EXPR_LOCATION (expr), type, expr);
+
case POINTER_TYPE:
case REFERENCE_TYPE:
/* If converting between two thin pointers, adjust if needed to account
@@ -5170,7 +5172,7 @@ convert_to_index_type (tree expr)
return convert (sizetype, expr);
}
-
+
/* Remove all conversions that are done in EXP. This includes converting
from a padded type or to a justified modular type. If TRUE_ADDRESS
is true, always return the address of the containing object even if
@@ -5205,7 +5207,7 @@ remove_conversions (tree exp, bool true_address)
return exp;
}
-
+
/* If EXP's type is an UNCONSTRAINED_ARRAY_TYPE, return an expression that
refers to the underlying array. If it has TYPE_CONTAINS_TEMPLATE_P,
likewise return an expression pointing to the underlying array. */
@@ -5293,7 +5295,7 @@ maybe_unconstrained_array (tree exp)
return exp;
}
-
+
/* Return true if EXPR is an expression that can be folded as an operand
of a VIEW_CONVERT_EXPR. See ada-tree.h for a complete rationale. */
@@ -5687,7 +5689,7 @@ unchecked_convert (tree type, tree expr, bool notrunc_p)
return expr;
}
-
+
/* Return the appropriate GCC tree code for the specified GNAT_TYPE,
the latter being a record type as predicated by Is_Record_Type. */
@@ -5837,7 +5839,7 @@ can_materialize_object_renaming_p (Node_Id expr)
{
expr = Original_Node (expr);
- switch Nkind (expr)
+ switch (Nkind (expr))
{
case N_Identifier:
case N_Expanded_Name:
@@ -5901,7 +5903,7 @@ gnat_write_global_declarations (void)
struct varpool_node *node;
char *label;
- ASM_FORMAT_PRIVATE_NAME (label, first_global_object_name, 0);
+ ASM_FORMAT_PRIVATE_NAME (label, first_global_object_name, ULONG_MAX);
dummy_global
= build_decl (BUILTINS_LOCATION, VAR_DECL, get_identifier (label),
void_type_node);
diff --git a/gcc/ada/gcc-interface/utils2.c b/gcc/ada/gcc-interface/utils2.c
index c8a2d7c..316033b 100644
--- a/gcc/ada/gcc-interface/utils2.c
+++ b/gcc/ada/gcc-interface/utils2.c
@@ -73,7 +73,7 @@ get_base_type (tree type)
return type;
}
-
+
/* EXP is a GCC tree representing an address. See if we can find how strictly
the object at this address is aligned and, if so, return the alignment of
the object in bits. Otherwise return 0. */
@@ -203,7 +203,7 @@ known_alignment (tree exp)
return this_alignment;
}
-
+
/* We have a comparison or assignment operation on two types, T1 and T2, which
are either both array types or both record types. T1 is assumed to be for
the left hand side operand, and T2 for the right hand side. Return the
@@ -271,7 +271,7 @@ find_common_type (tree t1, tree t2)
could cause a bad self-referential reference. */
return NULL_TREE;
}
-
+
/* Return an expression tree representing an equality comparison of A1 and A2,
two objects of type ARRAY_TYPE. The result should be of type RESULT_TYPE.
@@ -533,7 +533,7 @@ compare_fat_pointers (location_t loc, tree result_type, tree p1, tree p2)
build_binary_op (TRUTH_ORIF_EXPR, result_type,
p1_array_is_null, same_bounds));
}
-
+
/* Compute the result of applying OP_CODE to LHS and RHS, where both are of
type TYPE. We know that TYPE is a modular type with a nonbinary
modulus. */
@@ -629,7 +629,7 @@ nonbinary_modular_operation (enum tree_code op_code, tree type, tree lhs,
return convert (type, result);
}
-
+
/* This page contains routines that implement the Ada semantics with regard
to atomic objects. They are fully piggybacked on the middle-end support
for atomic loads and stores.
@@ -828,7 +828,7 @@ build_load_modify_store (tree dest, tree src, Node_Id gnat_node)
/* Something went wrong earlier if we have not found the atomic load. */
gcc_unreachable ();
}
-
+
/* Make a binary operation of kind OP_CODE. RESULT_TYPE is the type
desired for the result. Usually the operation is to be performed
in that type. For INIT_EXPR and MODIFY_EXPR, RESULT_TYPE must be
@@ -1323,7 +1323,7 @@ build_binary_op (enum tree_code op_code, tree result_type,
return result;
}
-
+
/* Similar, but for unary operations. */
tree
@@ -1683,7 +1683,7 @@ build_unary_op (enum tree_code op_code, tree result_type, tree operand)
return result;
}
-
+
/* Similar, but for COND_EXPR. */
tree
@@ -1758,7 +1758,7 @@ build_compound_expr (tree result_type, tree stmt_operand, tree expr_operand)
return result;
}
-
+
/* Conveniently construct a function call expression. FNDECL names the
function to be called, N is the number of arguments, and the "..."
parameters are the argument expressions. Unlike build_call_expr
@@ -1776,7 +1776,7 @@ build_call_n_expr (tree fndecl, int n, ...)
va_end (ap);
return fn;
}
-
+
/* Build a goto to LABEL for a raise, with an optional call to Local_Raise.
MSG gives the exception's identity for the call to Local_Raise, if any. */
@@ -1924,7 +1924,7 @@ build_call_raise_range (int msg, Node_Id gnat_node, char kind,
convert (integer_type_node, first),
convert (integer_type_node, last));
}
-
+
/* qsort comparer for the bit positions of two constructor elements
for record components. */
@@ -1987,7 +1987,7 @@ gnat_build_constructor (tree type, vec<constructor_elt, va_gc> *v)
TREE_READONLY (result) = TYPE_READONLY (type) || read_only || allconstant;
return result;
}
-
+
/* Return a COMPONENT_REF to access FIELD in RECORD, or NULL_TREE if the field
is not found in the record. Don't fold the result if NO_FOLD is true. */
@@ -2113,7 +2113,7 @@ build_component_ref (tree record, tree field, bool no_fold)
build_call_raise (CE_Discriminant_Check_Failed, Empty,
N_Raise_Constraint_Error));
}
-
+
/* Helper for build_call_alloc_dealloc, with arguments to be interpreted
identically. Process the case where a GNAT_PROC to call is provided. */
@@ -2326,7 +2326,7 @@ build_call_alloc_dealloc (tree gnu_obj, tree gnu_size, tree gnu_type,
return maybe_wrap_malloc (gnu_size, gnu_type, gnat_node);
}
}
-
+
/* Build a GCC tree that corresponds to allocating an object of TYPE whose
initial value is INIT, if INIT is nonzero. Convert the expression to
RESULT_TYPE, which must be some pointer type, and return the result.
@@ -2457,7 +2457,7 @@ build_allocator (tree type, tree init, tree result_type, Entity_Id gnat_proc,
return storage;
}
-
+
/* Indicate that we need to take the address of T and that it therefore
should not be allocated in a register. Return true if successful. */
@@ -2505,7 +2505,7 @@ gnat_mark_addressable (tree t)
return true;
}
}
-
+
/* Return true if EXP is a stable expression for the purpose of the functions
below and, therefore, can be returned unmodified by them. We accept things
that are actual constants or that have already been handled. */
diff --git a/gcc/ada/get_targ.adb b/gcc/ada/get_targ.adb
index 8b35b1c..881c06c 100644
--- a/gcc/ada/get_targ.adb
+++ b/gcc/ada/get_targ.adb
@@ -278,22 +278,6 @@ package body Get_Targ is
return null;
end Get_Back_End_Config_File;
- ----------------------
- -- Digits_From_Size --
- ----------------------
-
- function Digits_From_Size (Size : Pos) return Pos is
- begin
- case Size is
- when 32 => return 6;
- when 48 => return 9;
- when 64 => return 15;
- when 96 => return 18;
- when 128 => return 18;
- when others => raise Program_Error;
- end case;
- end Digits_From_Size;
-
-----------------------------
-- Get_Max_Unaligned_Field --
-----------------------------
@@ -314,20 +298,4 @@ package body Get_Targ is
Enumerate_Modes (Call_Back);
end Register_Back_End_Types;
- ---------------------
- -- Width_From_Size --
- ---------------------
-
- function Width_From_Size (Size : Pos) return Pos is
- begin
- case Size is
- when 8 => return 4;
- when 16 => return 6;
- when 32 => return 11;
- when 64 => return 21;
- when 128 => return 40;
- when others => raise Program_Error;
- end case;
- end Width_From_Size;
-
end Get_Targ;
diff --git a/gcc/ada/get_targ.ads b/gcc/ada/get_targ.ads
index 676e117..5315292 100644
--- a/gcc/ada/get_targ.ads
+++ b/gcc/ada/get_targ.ads
@@ -115,10 +115,6 @@ package Get_Targ is
-- Returns the maximum supported size in bits for a field that is
-- not aligned on a storage unit boundary.
- function Width_From_Size (Size : Pos) return Pos;
- function Digits_From_Size (Size : Pos) return Pos;
- -- Calculate values for 'Width or 'Digits from 'Size
-
type C_String is array (0 .. 255) of aliased Character;
pragma Convention (C, C_String);
diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb
index 180a140..0318194 100644
--- a/gcc/ada/gnat1drv.adb
+++ b/gcc/ada/gnat1drv.adb
@@ -167,6 +167,7 @@ procedure Gnat1drv is
if Debug_Flag_Dot_U then
Modify_Tree_For_C := True;
+ Transform_Function_Array := True;
end if;
-- -gnatd_A disables generation of ALI files
@@ -179,6 +180,7 @@ procedure Gnat1drv is
if Generate_C_Code then
Modify_Tree_For_C := True;
+ Transform_Function_Array := True;
Unnest_Subprogram_Mode := True;
Building_Static_Dispatch_Tables := False;
Minimize_Expression_With_Actions := True;
@@ -246,9 +248,10 @@ procedure Gnat1drv is
-- this way when we are doing CodePeer tests on existing test suites
-- that may have -gnateg set, to avoid the need for special casing.
- Modify_Tree_For_C := False;
- Generate_C_Code := False;
- Unnest_Subprogram_Mode := False;
+ Modify_Tree_For_C := False;
+ Transform_Function_Array := False;
+ Generate_C_Code := False;
+ Unnest_Subprogram_Mode := False;
-- Turn off inlining, confuses CodePeer output and gains nothing
@@ -454,9 +457,10 @@ procedure Gnat1drv is
-- this way when we are doing GNATprove tests on existing test suites
-- that may have -gnateg set, to avoid the need for special casing.
- Modify_Tree_For_C := False;
- Generate_C_Code := False;
- Unnest_Subprogram_Mode := False;
+ Modify_Tree_For_C := False;
+ Transform_Function_Array := False;
+ Generate_C_Code := False;
+ Unnest_Subprogram_Mode := False;
-- Turn off inlining, which would confuse formal verification output
-- and gain nothing.
@@ -809,8 +813,6 @@ procedure Gnat1drv is
Ttypes.Standard_Long_Long_Long_Integer_Size :=
Ttypes.Standard_Long_Long_Integer_Size;
- Ttypes.Standard_Long_Long_Long_Integer_Width :=
- Ttypes.Standard_Long_Long_Integer_Width;
Ttypes.System_Max_Integer_Size :=
Ttypes.Standard_Long_Long_Integer_Size;
Ttypes.System_Max_Binary_Modulus_Power :=
@@ -1018,15 +1020,6 @@ procedure Gnat1drv is
-- by the backend where possible).
Sem_Ch13.Validate_Address_Clauses;
-
- -- Validate independence pragmas (again using values annotated by the
- -- back end for component layout where possible) but only for non-GCC
- -- back ends, as this is done a priori for GCC back ends.
- -- ??? We use to test for AAMP_On_Target which is now gone, consider
- --
- -- if AAMP_On_Target then
- -- Sem_Ch13.Validate_Independence;
- -- end if;
end Post_Compilation_Validation_Checks;
-----------------------------------
diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi
index e1a5568..02e8219 100644
--- a/gcc/ada/gnat_rm.texi
+++ b/gcc/ada/gnat_rm.texi
@@ -21,7 +21,7 @@
@copying
@quotation
-GNAT Reference Manual , Sep 29, 2020
+GNAT Reference Manual , Dec 11, 2020
AdaCore
@@ -394,6 +394,7 @@ Implementation Defined Attributes
* Attribute From_Any::
* Attribute Has_Access_Values::
* Attribute Has_Discriminants::
+* Attribute Has_Tagged_Values::
* Attribute Img::
* Attribute Initialized::
* Attribute Integer_Value::
@@ -422,6 +423,8 @@ Implementation Defined Attributes
* Attribute Scalar_Storage_Order::
* Attribute Simple_Storage_Pool::
* Attribute Small::
+* Attribute Small_Denominator::
+* Attribute Small_Numerator::
* Attribute Storage_Unit::
* Attribute Stub_Type::
* Attribute System_Allocator_Alignment::
@@ -1806,15 +1809,16 @@ pragma Assertion_Policy (
ASSERTION_KIND ::= RM_ASSERTION_KIND | ID_ASSERTION_KIND
-RM_ASSERTION_KIND ::= Assert |
- Static_Predicate |
- Dynamic_Predicate |
- Pre |
- Pre'Class |
- Post |
- Post'Class |
- Type_Invariant |
- Type_Invariant'Class
+RM_ASSERTION_KIND ::= Assert |
+ Static_Predicate |
+ Dynamic_Predicate |
+ Pre |
+ Pre'Class |
+ Post |
+ Post'Class |
+ Type_Invariant |
+ Type_Invariant'Class |
+ Default_Initial_Condition
ID_ASSERTION_KIND ::= Assertions |
Assert_And_Cut |
@@ -1822,6 +1826,7 @@ ID_ASSERTION_KIND ::= Assertions |
Contract_Cases |
Debug |
Ghost |
+ Initial_Condition |
Invariant |
Invariant'Class |
Loop_Invariant |
@@ -1830,7 +1835,8 @@ ID_ASSERTION_KIND ::= Assertions |
Precondition |
Predicate |
Refined_Post |
- Statement_Assertions
+ Statement_Assertions |
+ Subprogram_Variant
POLICY_IDENTIFIER ::= Check | Disable | Ignore | Suppressible
@end example
@@ -6536,7 +6542,7 @@ See Ada 2012 Reference Manual for details.
Syntax:
@example
-pragma Profile (Ravenscar | Restricted | Rational |
+pragma Profile (Ravenscar | Restricted | Rational | Jorvik |
GNAT_Extended_Ravenscar | GNAT_Ravenscar_EDF );
@end example
@@ -6544,10 +6550,12 @@ This pragma is standard in Ada 2005, but is available in all earlier
versions of Ada as an implementation-defined pragma. This is a
configuration pragma that establishes a set of configuration pragmas
that depend on the argument. @code{Ravenscar} is standard in Ada 2005.
+@code{Jorvik} is standard in Ada 202x.
The other possibilities (@code{Restricted}, @code{Rational},
@code{GNAT_Extended_Ravenscar}, @code{GNAT_Ravenscar_EDF})
-are implementation-defined. The set of configuration pragmas
-is defined in the following sections.
+are implementation-defined. @code{GNAT_Extended_Ravenscar} is an alias for @code{Jorvik}.
+
+The set of configuration pragmas is defined in the following sections.
@itemize *
@@ -6647,7 +6655,7 @@ No rendezvous statements are allowed.
@end itemize
The Ravenscar profile also includes the following restrictions that specify
-that there are no semantic dependences on the corresponding predefined
+that there are no semantic dependencies on the corresponding predefined
packages:
@@ -6699,12 +6707,10 @@ automatically causes the use of a simplified,
more efficient version of the tasking run-time library.
@item
-Pragma Profile (GNAT_Extended_Ravenscar)
+Pragma Profile (Jorvik)
-This profile corresponds to a GNAT specific extension of the
-Ravenscar profile. The profile may change in the future although
-only in a compatible way: some restrictions may be removed or
-relaxed. It is defined as a variation of the Ravenscar profile.
+@code{Jorvik} is the new profile added to the Ada 202x draft standard,
+previously implemented under the name @code{GNAT_Extended_Ravenscar}.
The @code{No_Implicit_Heap_Allocations} restriction has been replaced
by @code{No_Implicit_Task_Allocations} and
@@ -6716,6 +6722,11 @@ The @code{Simple_Barriers} restriction has been replaced by
The @code{Max_Protected_Entries}, @code{Max_Entry_Queue_Length}, and
@code{No_Relative_Delay} restrictions have been removed.
+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,
+Number 10300.
+
@item
Pragma Profile (GNAT_Ravenscar_EDF)
@@ -8148,8 +8159,8 @@ package Math_Functions is
function Sqrt (Arg : Float) return Float;
pragma Test_Case (Name => "Test 1",
Mode => Nominal,
- Requires => Arg < 10000,
- Ensures => Sqrt'Result < 10);
+ Requires => Arg < 10000.0,
+ Ensures => Sqrt'Result < 10.0);
...
end Math_Functions;
@end example
@@ -9933,7 +9944,7 @@ This boolean aspect is equivalent to @ref{10b,,pragma Unmodified}.
This boolean aspect is equivalent to @ref{10c,,pragma Unreferenced}.
-When using the @code{-gnatX} switch, this aspect is also supported on formal
+When using the @code{-gnat2020} switch, this aspect is also supported on formal
parameters, which is in particular the only form possible for expression
functions.
@@ -10038,6 +10049,7 @@ consideration, you should minimize the use of these attributes.
* Attribute From_Any::
* Attribute Has_Access_Values::
* Attribute Has_Discriminants::
+* Attribute Has_Tagged_Values::
* Attribute Img::
* Attribute Initialized::
* Attribute Integer_Value::
@@ -10066,6 +10078,8 @@ consideration, you should minimize the use of these attributes.
* Attribute Scalar_Storage_Order::
* Attribute Simple_Storage_Pool::
* Attribute Small::
+* Attribute Small_Denominator::
+* Attribute Small_Numerator::
* Attribute Storage_Unit::
* Attribute Stub_Type::
* Attribute System_Allocator_Alignment::
@@ -10617,7 +10631,7 @@ The intended use of this attribute is in conjunction with generic
definitions. If the attribute is applied to a generic private type, it
indicates whether or not the corresponding actual type has access values.
-@node Attribute Has_Discriminants,Attribute Img,Attribute Has_Access_Values,Implementation Defined Attributes
+@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}
@section Attribute Has_Discriminants
@@ -10633,8 +10647,25 @@ otherwise. The intended use of this attribute is in conjunction with generic
definitions. If the attribute is applied to a generic private type, it
indicates whether or not the corresponding actual type has discriminants.
-@node Attribute Img,Attribute Initialized,Attribute Has_Discriminants,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-img}@anchor{184}
+@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}
+@section Attribute Has_Tagged_Values
+
+
+@geindex Tagged values
+@geindex testing for
+
+@geindex Has_Tagged_Values
+
+The prefix of the @code{Has_Tagged_Values} attribute is a type. The result is a
+Boolean value which is True if the type is a composite type (array or record)
+that is either a tagged type or has a subcomponent that is tagged, and is False
+otherwise. The intended use of this attribute is in conjunction with generic
+definitions. If the attribute is applied to a generic private type, it
+indicates whether or not the corresponding actual type has access values.
+
+@node Attribute Img,Attribute Initialized,Attribute Has_Tagged_Values,Implementation Defined Attributes
+@anchor{gnat_rm/implementation_defined_attributes attribute-img}@anchor{185}
@section Attribute Img
@@ -10664,7 +10695,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{185}
+@anchor{gnat_rm/implementation_defined_attributes attribute-initialized}@anchor{186}
@section Attribute Initialized
@@ -10674,7 +10705,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{186}
+@anchor{gnat_rm/implementation_defined_attributes attribute-integer-value}@anchor{187}
@section Attribute Integer_Value
@@ -10702,7 +10733,7 @@ This attribute is primarily intended for use in implementation of the
standard input-output functions for fixed-point values.
@node Attribute Invalid_Value,Attribute Iterable,Attribute Integer_Value,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-invalid-value}@anchor{187}
+@anchor{gnat_rm/implementation_defined_attributes attribute-invalid-value}@anchor{188}
@section Attribute Invalid_Value
@@ -10716,7 +10747,7 @@ including the ability to modify the value with the binder -Sxx flag and
relevant environment variables at run time.
@node Attribute Iterable,Attribute Large,Attribute Invalid_Value,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-iterable}@anchor{188}
+@anchor{gnat_rm/implementation_defined_attributes attribute-iterable}@anchor{189}
@section Attribute Iterable
@@ -10725,7 +10756,7 @@ relevant environment variables at run time.
Equivalent to Aspect Iterable.
@node Attribute Large,Attribute Library_Level,Attribute Iterable,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-large}@anchor{189}
+@anchor{gnat_rm/implementation_defined_attributes attribute-large}@anchor{18a}
@section Attribute Large
@@ -10738,7 +10769,7 @@ the Ada 83 reference manual for an exact description of the semantics of
this attribute.
@node Attribute Library_Level,Attribute Lock_Free,Attribute Large,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-library-level}@anchor{18a}
+@anchor{gnat_rm/implementation_defined_attributes attribute-library-level}@anchor{18b}
@section Attribute Library_Level
@@ -10764,7 +10795,7 @@ end Gen;
@end example
@node Attribute Lock_Free,Attribute Loop_Entry,Attribute Library_Level,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-lock-free}@anchor{18b}
+@anchor{gnat_rm/implementation_defined_attributes attribute-lock-free}@anchor{18c}
@section Attribute Lock_Free
@@ -10774,7 +10805,7 @@ end Gen;
pragma @code{Lock_Free} applies to P.
@node Attribute Loop_Entry,Attribute Machine_Size,Attribute Lock_Free,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-loop-entry}@anchor{18c}
+@anchor{gnat_rm/implementation_defined_attributes attribute-loop-entry}@anchor{18d}
@section Attribute Loop_Entry
@@ -10804,7 +10835,7 @@ entry. This copy is not performed if the loop is not entered, or if the
corresponding pragmas are ignored or disabled.
@node Attribute Machine_Size,Attribute Mantissa,Attribute Loop_Entry,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-machine-size}@anchor{18d}
+@anchor{gnat_rm/implementation_defined_attributes attribute-machine-size}@anchor{18e}
@section Attribute Machine_Size
@@ -10814,7 +10845,7 @@ This attribute is identical to the @code{Object_Size} attribute. It is
provided for compatibility with the DEC Ada 83 attribute of this name.
@node Attribute Mantissa,Attribute Maximum_Alignment,Attribute Machine_Size,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-mantissa}@anchor{18e}
+@anchor{gnat_rm/implementation_defined_attributes attribute-mantissa}@anchor{18f}
@section Attribute Mantissa
@@ -10827,7 +10858,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{18f}@anchor{gnat_rm/implementation_defined_attributes id2}@anchor{190}
+@anchor{gnat_rm/implementation_defined_attributes attribute-maximum-alignment}@anchor{190}@anchor{gnat_rm/implementation_defined_attributes id2}@anchor{191}
@section Attribute Maximum_Alignment
@@ -10843,7 +10874,7 @@ 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{191}
+@anchor{gnat_rm/implementation_defined_attributes attribute-max-integer-size}@anchor{192}
@section Attribute Max_Integer_Size
@@ -10854,7 +10885,7 @@ 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{192}
+@anchor{gnat_rm/implementation_defined_attributes attribute-mechanism-code}@anchor{193}
@section Attribute Mechanism_Code
@@ -10885,7 +10916,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{193}
+@anchor{gnat_rm/implementation_defined_attributes attribute-null-parameter}@anchor{194}
@section Attribute Null_Parameter
@@ -10910,7 +10941,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{194}
+@anchor{gnat_rm/implementation_defined_attributes attribute-object-size}@anchor{143}@anchor{gnat_rm/implementation_defined_attributes id3}@anchor{195}
@section Attribute Object_Size
@@ -10980,7 +11011,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{195}
+@anchor{gnat_rm/implementation_defined_attributes attribute-old}@anchor{196}
@section Attribute Old
@@ -10995,7 +11026,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{196}
+@anchor{gnat_rm/implementation_defined_attributes attribute-passed-by-reference}@anchor{197}
@section Attribute Passed_By_Reference
@@ -11011,13 +11042,10 @@ 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{197}
+@anchor{gnat_rm/implementation_defined_attributes attribute-pool-address}@anchor{198}
@section Attribute Pool_Address
-@geindex Parameters
-@geindex when passed by reference
-
@geindex Pool_Address
@code{X'Pool_Address} for any object @code{X} returns the address
@@ -11036,7 +11064,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{198}
+@anchor{gnat_rm/implementation_defined_attributes attribute-range-length}@anchor{199}
@section Attribute Range_Length
@@ -11049,7 +11077,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{199}
+@anchor{gnat_rm/implementation_defined_attributes attribute-restriction-set}@anchor{19a}
@section Attribute Restriction_Set
@@ -11119,7 +11147,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{19a}
+@anchor{gnat_rm/implementation_defined_attributes attribute-result}@anchor{19b}
@section Attribute Result
@@ -11132,7 +11160,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{19b}
+@anchor{gnat_rm/implementation_defined_attributes attribute-safe-emax}@anchor{19c}
@section Attribute Safe_Emax
@@ -11145,7 +11173,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{19c}
+@anchor{gnat_rm/implementation_defined_attributes attribute-safe-large}@anchor{19d}
@section Attribute Safe_Large
@@ -11158,7 +11186,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{19d}
+@anchor{gnat_rm/implementation_defined_attributes attribute-safe-small}@anchor{19e}
@section Attribute Safe_Small
@@ -11171,7 +11199,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{19e}@anchor{gnat_rm/implementation_defined_attributes attribute-scalar-storage-order}@anchor{151}
+@anchor{gnat_rm/implementation_defined_attributes id4}@anchor{19f}@anchor{gnat_rm/implementation_defined_attributes attribute-scalar-storage-order}@anchor{151}
@section Attribute Scalar_Storage_Order
@@ -11294,7 +11322,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{19f}
+@anchor{gnat_rm/implementation_defined_attributes attribute-simple-storage-pool}@anchor{e5}@anchor{gnat_rm/implementation_defined_attributes id5}@anchor{1a0}
@section Attribute Simple_Storage_Pool
@@ -11356,8 +11384,8 @@ parameter. The detailed semantics of such unchecked deallocations is the same
as defined in section 13.11.2 of the Ada Reference Manual, except that the
term @emph{simple storage pool} is substituted for @emph{storage pool}.
-@node Attribute Small,Attribute Storage_Unit,Attribute Simple_Storage_Pool,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-small}@anchor{1a0}
+@node Attribute Small,Attribute Small_Denominator,Attribute Simple_Storage_Pool,Implementation Defined Attributes
+@anchor{gnat_rm/implementation_defined_attributes attribute-small}@anchor{1a1}
@section Attribute Small
@@ -11372,8 +11400,34 @@ for compatibility with Ada 83. See
the Ada 83 reference manual for an exact description of the semantics of
this attribute when applied to floating-point types.
-@node Attribute Storage_Unit,Attribute Stub_Type,Attribute Small,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-storage-unit}@anchor{1a1}
+@node Attribute Small_Denominator,Attribute Small_Numerator,Attribute Small,Implementation Defined Attributes
+@anchor{gnat_rm/implementation_defined_attributes attribute-small-denominator}@anchor{1a2}
+@section Attribute Small_Denominator
+
+
+@geindex Small
+
+@geindex Small_Denominator
+
+@code{typ'Small_Denominator} for any fixed-point subtype @cite{typ} yields the
+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}
+@section Attribute Small_Numerator
+
+
+@geindex Small
+
+@geindex Small_Numerator
+
+@code{typ'Small_Numerator} for any fixed-point subtype @cite{typ} yields the
+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}
@section Attribute Storage_Unit
@@ -11383,7 +11437,7 @@ this attribute when applied to floating-point types.
prefix) provides the same value as @code{System.Storage_Unit}.
@node Attribute Stub_Type,Attribute System_Allocator_Alignment,Attribute Storage_Unit,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-stub-type}@anchor{1a2}
+@anchor{gnat_rm/implementation_defined_attributes attribute-stub-type}@anchor{1a5}
@section Attribute Stub_Type
@@ -11407,7 +11461,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{1a3}
+@anchor{gnat_rm/implementation_defined_attributes attribute-system-allocator-alignment}@anchor{1a6}
@section Attribute System_Allocator_Alignment
@@ -11424,7 +11478,7 @@ with alignment too large or to enable a realignment circuitry if the
alignment request is larger than this value.
@node Attribute Target_Name,Attribute To_Address,Attribute System_Allocator_Alignment,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-target-name}@anchor{1a4}
+@anchor{gnat_rm/implementation_defined_attributes attribute-target-name}@anchor{1a7}
@section Attribute Target_Name
@@ -11437,7 +11491,7 @@ standard gcc target name without the terminating slash (for
example, GNAT 5.0 on windows yields "i586-pc-mingw32msv").
@node Attribute To_Address,Attribute To_Any,Attribute Target_Name,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-to-address}@anchor{1a5}
+@anchor{gnat_rm/implementation_defined_attributes attribute-to-address}@anchor{1a8}
@section Attribute To_Address
@@ -11460,7 +11514,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{1a6}
+@anchor{gnat_rm/implementation_defined_attributes attribute-to-any}@anchor{1a9}
@section Attribute To_Any
@@ -11470,7 +11524,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{1a7}
+@anchor{gnat_rm/implementation_defined_attributes attribute-type-class}@anchor{1aa}
@section Attribute Type_Class
@@ -11500,7 +11554,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{1a8}
+@anchor{gnat_rm/implementation_defined_attributes attribute-type-key}@anchor{1ab}
@section Attribute Type_Key
@@ -11512,7 +11566,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{1a9}
+@anchor{gnat_rm/implementation_defined_attributes attribute-typecode}@anchor{1ac}
@section Attribute TypeCode
@@ -11522,7 +11576,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{1aa}
+@anchor{gnat_rm/implementation_defined_attributes attribute-unconstrained-array}@anchor{1ad}
@section Attribute Unconstrained_Array
@@ -11536,7 +11590,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{1ab}
+@anchor{gnat_rm/implementation_defined_attributes attribute-universal-literal-string}@anchor{1ae}
@section Attribute Universal_Literal_String
@@ -11564,7 +11618,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{1ac}
+@anchor{gnat_rm/implementation_defined_attributes attribute-unrestricted-access}@anchor{1af}
@section Attribute Unrestricted_Access
@@ -11751,7 +11805,7 @@ In general this is a risky approach. It may appear to "work" but such uses of
of GNAT to another, so are best avoided if possible.
@node Attribute Update,Attribute Valid_Scalars,Attribute Unrestricted_Access,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-update}@anchor{1ad}
+@anchor{gnat_rm/implementation_defined_attributes attribute-update}@anchor{1b0}
@section Attribute Update
@@ -11832,7 +11886,7 @@ A := A'Update ((1, 2) => 20, (3, 4) => 30);
which changes element (1,2) to 20 and (3,4) to 30.
@node Attribute Valid_Scalars,Attribute VADS_Size,Attribute Update,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-valid-scalars}@anchor{1ae}
+@anchor{gnat_rm/implementation_defined_attributes attribute-valid-scalars}@anchor{1b1}
@section Attribute Valid_Scalars
@@ -11866,7 +11920,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{1af}
+@anchor{gnat_rm/implementation_defined_attributes attribute-vads-size}@anchor{1b2}
@section Attribute VADS_Size
@@ -11886,7 +11940,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{1b0}@anchor{gnat_rm/implementation_defined_attributes attribute-value-size}@anchor{160}
+@anchor{gnat_rm/implementation_defined_attributes id6}@anchor{1b3}@anchor{gnat_rm/implementation_defined_attributes attribute-value-size}@anchor{160}
@section Attribute Value_Size
@@ -11900,7 +11954,7 @@ a value of the given subtype. It is the same as @code{type'Size},
but, unlike @code{Size}, may be set for non-first subtypes.
@node Attribute Wchar_T_Size,Attribute Word_Size,Attribute Value_Size,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-wchar-t-size}@anchor{1b1}
+@anchor{gnat_rm/implementation_defined_attributes attribute-wchar-t-size}@anchor{1b4}
@section Attribute Wchar_T_Size
@@ -11912,7 +11966,7 @@ primarily for constructing the definition of this type in
package @code{Interfaces.C}. The result is a static constant.
@node Attribute Word_Size,,Attribute Wchar_T_Size,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-word-size}@anchor{1b2}
+@anchor{gnat_rm/implementation_defined_attributes attribute-word-size}@anchor{1b5}
@section Attribute Word_Size
@@ -11923,7 +11977,7 @@ prefix) provides the value @code{System.Word_Size}. The result is
a static constant.
@node Standard and Implementation Defined Restrictions,Implementation Advice,Implementation Defined Attributes,Top
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions standard-and-implementation-defined-restrictions}@anchor{9}@anchor{gnat_rm/standard_and_implementation_defined_restrictions doc}@anchor{1b3}@anchor{gnat_rm/standard_and_implementation_defined_restrictions id1}@anchor{1b4}
+@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}
@chapter Standard and Implementation Defined Restrictions
@@ -11952,7 +12006,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{1b5}@anchor{gnat_rm/standard_and_implementation_defined_restrictions id2}@anchor{1b6}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions partition-wide-restrictions}@anchor{1b8}@anchor{gnat_rm/standard_and_implementation_defined_restrictions id2}@anchor{1b9}
@section Partition-Wide Restrictions
@@ -12041,7 +12095,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{1b7}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions immediate-reclamation}@anchor{1ba}
@subsection Immediate_Reclamation
@@ -12053,7 +12107,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{1b8}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-asynchronous-select-nesting}@anchor{1bb}
@subsection Max_Asynchronous_Select_Nesting
@@ -12065,7 +12119,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{1b9}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-entry-queue-length}@anchor{1bc}
@subsection Max_Entry_Queue_Length
@@ -12086,7 +12140,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{1ba}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-protected-entries}@anchor{1bd}
@subsection Max_Protected_Entries
@@ -12097,7 +12151,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{1bb}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-select-alternatives}@anchor{1be}
@subsection Max_Select_Alternatives
@@ -12106,7 +12160,7 @@ defined by a discriminant of a subtype whose corresponding bound is static.
[RM D.7] Specifies the maximum number of alternatives in a selective accept.
@node Max_Storage_At_Blocking,Max_Task_Entries,Max_Select_Alternatives,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-storage-at-blocking}@anchor{1bc}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-storage-at-blocking}@anchor{1bf}
@subsection Max_Storage_At_Blocking
@@ -12117,7 +12171,7 @@ Storage_Size that can be retained by a blocked task. A violation of this
restriction causes Storage_Error to be raised.
@node Max_Task_Entries,Max_Tasks,Max_Storage_At_Blocking,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-task-entries}@anchor{1bd}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-task-entries}@anchor{1c0}
@subsection Max_Task_Entries
@@ -12130,7 +12184,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{1be}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-tasks}@anchor{1c1}
@subsection Max_Tasks
@@ -12143,7 +12197,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{1bf}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-abort-statements}@anchor{1c2}
@subsection No_Abort_Statements
@@ -12153,7 +12207,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{1c0}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-access-parameter-allocators}@anchor{1c3}
@subsection No_Access_Parameter_Allocators
@@ -12164,7 +12218,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{1c1}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-access-subprograms}@anchor{1c4}
@subsection No_Access_Subprograms
@@ -12174,7 +12228,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{1c2}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-allocators}@anchor{1c5}
@subsection No_Allocators
@@ -12184,7 +12238,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{1c3}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-anonymous-allocators}@anchor{1c6}
@subsection No_Anonymous_Allocators
@@ -12194,7 +12248,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{1c4}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-asynchronous-control}@anchor{1c7}
@subsection No_Asynchronous_Control
@@ -12204,7 +12258,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{1c5}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-calendar}@anchor{1c8}
@subsection No_Calendar
@@ -12214,7 +12268,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{1c6}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-coextensions}@anchor{1c9}
@subsection No_Coextensions
@@ -12224,7 +12278,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{1c7}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-default-initialization}@anchor{1ca}
@subsection No_Default_Initialization
@@ -12241,7 +12295,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{1c8}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-delay}@anchor{1cb}
@subsection No_Delay
@@ -12251,7 +12305,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{1c9}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dependence}@anchor{1cc}
@subsection No_Dependence
@@ -12261,7 +12315,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{1ca}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-direct-boolean-operators}@anchor{1cd}
@subsection No_Direct_Boolean_Operators
@@ -12274,7 +12328,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{1cb}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dispatch}@anchor{1ce}
@subsection No_Dispatch
@@ -12284,7 +12338,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{1cc}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dispatching-calls}@anchor{1cf}
@subsection No_Dispatching_Calls
@@ -12345,7 +12399,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{1cd}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dynamic-attachment}@anchor{1d0}
@subsection No_Dynamic_Attachment
@@ -12364,7 +12418,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{1ce}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dynamic-priorities}@anchor{1d1}
@subsection No_Dynamic_Priorities
@@ -12373,7 +12427,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{1cf}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-entry-calls-in-elaboration-code}@anchor{1d2}
@subsection No_Entry_Calls_In_Elaboration_Code
@@ -12385,7 +12439,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{1d0}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-enumeration-maps}@anchor{1d3}
@subsection No_Enumeration_Maps
@@ -12396,7 +12450,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{1d1}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-exception-handlers}@anchor{1d4}
@subsection No_Exception_Handlers
@@ -12421,7 +12475,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{1d2}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-exception-propagation}@anchor{1d5}
@subsection No_Exception_Propagation
@@ -12438,7 +12492,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{1d3}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-exception-registration}@anchor{1d6}
@subsection No_Exception_Registration
@@ -12452,7 +12506,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{1d4}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-exceptions}@anchor{1d7}
@subsection No_Exceptions
@@ -12463,7 +12517,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{1d5}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-finalization}@anchor{1d8}
@subsection No_Finalization
@@ -12504,7 +12558,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{1d6}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-fixed-point}@anchor{1d9}
@subsection No_Fixed_Point
@@ -12514,7 +12568,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{1d7}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-floating-point}@anchor{1da}
@subsection No_Floating_Point
@@ -12524,7 +12578,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{1d8}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-conditionals}@anchor{1db}
@subsection No_Implicit_Conditionals
@@ -12540,7 +12594,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{1d9}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-dynamic-code}@anchor{1dc}
@subsection No_Implicit_Dynamic_Code
@@ -12570,7 +12624,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{1da}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-heap-allocations}@anchor{1dd}
@subsection No_Implicit_Heap_Allocations
@@ -12579,7 +12633,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{1db}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-protected-object-allocations}@anchor{1de}
@subsection No_Implicit_Protected_Object_Allocations
@@ -12589,7 +12643,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{1dc}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-task-allocations}@anchor{1df}
@subsection No_Implicit_Task_Allocations
@@ -12598,7 +12652,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{1dd}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-initialize-scalars}@anchor{1e0}
@subsection No_Initialize_Scalars
@@ -12610,7 +12664,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{1de}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-io}@anchor{1e1}
@subsection No_IO
@@ -12621,7 +12675,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{1df}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-local-allocators}@anchor{1e2}
@subsection No_Local_Allocators
@@ -12632,7 +12686,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{1e0}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-local-protected-objects}@anchor{1e3}
@subsection No_Local_Protected_Objects
@@ -12642,7 +12696,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{1e1}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-local-timing-events}@anchor{1e4}
@subsection No_Local_Timing_Events
@@ -12652,7 +12706,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{1e2}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-long-long-integers}@anchor{1e5}
@subsection No_Long_Long_Integers
@@ -12664,7 +12718,7 @@ implicit base type is Long_Long_Integer, and modular types whose size exceeds
Long_Integer'Size.
@node No_Multiple_Elaboration,No_Nested_Finalization,No_Long_Long_Integers,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-multiple-elaboration}@anchor{1e3}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-multiple-elaboration}@anchor{1e6}
@subsection No_Multiple_Elaboration
@@ -12680,7 +12734,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{1e4}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-nested-finalization}@anchor{1e7}
@subsection No_Nested_Finalization
@@ -12689,7 +12743,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{1e5}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-protected-type-allocators}@anchor{1e8}
@subsection No_Protected_Type_Allocators
@@ -12699,7 +12753,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{1e6}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-protected-types}@anchor{1e9}
@subsection No_Protected_Types
@@ -12709,7 +12763,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{1e7}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-recursion}@anchor{1ea}
@subsection No_Recursion
@@ -12719,7 +12773,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{1e8}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-reentrancy}@anchor{1eb}
@subsection No_Reentrancy
@@ -12729,7 +12783,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{1e9}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-relative-delay}@anchor{1ec}
@subsection No_Relative_Delay
@@ -12740,7 +12794,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{1ea}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-requeue-statements}@anchor{1ed}
@subsection No_Requeue_Statements
@@ -12758,7 +12812,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{1eb}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-secondary-stack}@anchor{1ee}
@subsection No_Secondary_Stack
@@ -12771,7 +12825,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{1ec}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-select-statements}@anchor{1ef}
@subsection No_Select_Statements
@@ -12781,7 +12835,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{1ed}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-specific-termination-handlers}@anchor{1f0}
@subsection No_Specific_Termination_Handlers
@@ -12791,7 +12845,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{1ee}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-specification-of-aspect}@anchor{1f1}
@subsection No_Specification_of_Aspect
@@ -12802,7 +12856,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{1ef}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-standard-allocators-after-elaboration}@anchor{1f2}
@subsection No_Standard_Allocators_After_Elaboration
@@ -12814,7 +12868,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{1f0}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-standard-storage-pools}@anchor{1f3}
@subsection No_Standard_Storage_Pools
@@ -12826,7 +12880,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{1f1}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-stream-optimizations}@anchor{1f4}
@subsection No_Stream_Optimizations
@@ -12839,7 +12893,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{1f2}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-streams}@anchor{1f5}
@subsection No_Streams
@@ -12860,7 +12914,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{1f3}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-task-allocators}@anchor{1f6}
@subsection No_Task_Allocators
@@ -12870,7 +12924,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{1f4}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-task-at-interrupt-priority}@anchor{1f7}
@subsection No_Task_At_Interrupt_Priority
@@ -12882,7 +12936,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{1f5}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-task-attributes-package}@anchor{1f8}
@subsection No_Task_Attributes_Package
@@ -12899,7 +12953,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{1f6}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-task-hierarchy}@anchor{1f9}
@subsection No_Task_Hierarchy
@@ -12909,7 +12963,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{1f7}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-task-termination}@anchor{1fa}
@subsection No_Task_Termination
@@ -12918,7 +12972,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{1f8}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-tasking}@anchor{1fb}
@subsection No_Tasking
@@ -12931,7 +12985,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{1f9}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-terminate-alternatives}@anchor{1fc}
@subsection No_Terminate_Alternatives
@@ -12940,7 +12994,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{1fa}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-unchecked-access}@anchor{1fd}
@subsection No_Unchecked_Access
@@ -12950,7 +13004,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{1fb}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-unchecked-conversion}@anchor{1fe}
@subsection No_Unchecked_Conversion
@@ -12960,7 +13014,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{1fc}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-unchecked-deallocation}@anchor{1ff}
@subsection No_Unchecked_Deallocation
@@ -12970,7 +13024,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{1fd}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-use-of-entity}@anchor{200}
@subsection No_Use_Of_Entity
@@ -12990,7 +13044,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{1fe}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions pure-barriers}@anchor{201}
@subsection Pure_Barriers
@@ -13041,7 +13095,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{1ff}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions simple-barriers}@anchor{202}
@subsection Simple_Barriers
@@ -13060,7 +13114,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{200}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions static-priorities}@anchor{203}
@subsection Static_Priorities
@@ -13071,7 +13125,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{201}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions static-storage-size}@anchor{204}
@subsection Static_Storage_Size
@@ -13081,7 +13135,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{202}@anchor{gnat_rm/standard_and_implementation_defined_restrictions id3}@anchor{203}
+@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}
@section Program Unit Level Restrictions
@@ -13111,7 +13165,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{204}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-elaboration-code}@anchor{207}
@subsection No_Elaboration_Code
@@ -13167,7 +13221,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{205}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dynamic-sized-objects}@anchor{208}
@subsection No_Dynamic_Sized_Objects
@@ -13185,7 +13239,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{206}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-entry-queue}@anchor{209}
@subsection No_Entry_Queue
@@ -13198,7 +13252,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{207}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-aspect-specifications}@anchor{20a}
@subsection No_Implementation_Aspect_Specifications
@@ -13209,7 +13263,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{208}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-attributes}@anchor{20b}
@subsection No_Implementation_Attributes
@@ -13221,7 +13275,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{209}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-identifiers}@anchor{20c}
@subsection No_Implementation_Identifiers
@@ -13232,7 +13286,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{20a}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-pragmas}@anchor{20d}
@subsection No_Implementation_Pragmas
@@ -13243,7 +13297,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{20b}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-restrictions}@anchor{20e}
@subsection No_Implementation_Restrictions
@@ -13255,7 +13309,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{20c}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-units}@anchor{20f}
@subsection No_Implementation_Units
@@ -13266,7 +13320,7 @@ mention in the context clause of any implementation-defined descendants
of packages Ada, Interfaces, or System.
@node No_Implicit_Aliasing,No_Implicit_Loops,No_Implementation_Units,Program Unit Level Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-aliasing}@anchor{20d}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-aliasing}@anchor{210}
@subsection No_Implicit_Aliasing
@@ -13281,7 +13335,7 @@ to be aliased, and in such cases, it can always be replaced by
the standard attribute Unchecked_Access which is preferable.
@node No_Implicit_Loops,No_Obsolescent_Features,No_Implicit_Aliasing,Program Unit Level Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-loops}@anchor{20e}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-loops}@anchor{211}
@subsection No_Implicit_Loops
@@ -13298,7 +13352,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{20f}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-obsolescent-features}@anchor{212}
@subsection No_Obsolescent_Features
@@ -13308,7 +13362,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{210}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-wide-characters}@anchor{213}
@subsection No_Wide_Characters
@@ -13322,7 +13376,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{211}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions static-dispatch-tables}@anchor{214}
@subsection Static_Dispatch_Tables
@@ -13332,7 +13386,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{212}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions spark-05}@anchor{215}
@subsection SPARK_05
@@ -13355,7 +13409,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{213}@anchor{gnat_rm/implementation_advice implementation-advice}@anchor{a}@anchor{gnat_rm/implementation_advice id1}@anchor{214}
+@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}
@chapter Implementation Advice
@@ -13452,7 +13506,7 @@ case the text describes what GNAT does and why.
@end menu
@node RM 1 1 3 20 Error Detection,RM 1 1 3 31 Child Units,,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-1-1-3-20-error-detection}@anchor{215}
+@anchor{gnat_rm/implementation_advice rm-1-1-3-20-error-detection}@anchor{218}
@section RM 1.1.3(20): Error Detection
@@ -13469,7 +13523,7 @@ or diagnosed at compile time.
@geindex Child Units
@node RM 1 1 3 31 Child Units,RM 1 1 5 12 Bounded Errors,RM 1 1 3 20 Error Detection,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-1-1-3-31-child-units}@anchor{216}
+@anchor{gnat_rm/implementation_advice rm-1-1-3-31-child-units}@anchor{219}
@section RM 1.1.3(31): Child Units
@@ -13485,7 +13539,7 @@ Followed.
@geindex Bounded errors
@node RM 1 1 5 12 Bounded Errors,RM 2 8 16 Pragmas,RM 1 1 3 31 Child Units,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-1-1-5-12-bounded-errors}@anchor{217}
+@anchor{gnat_rm/implementation_advice rm-1-1-5-12-bounded-errors}@anchor{21a}
@section RM 1.1.5(12): Bounded Errors
@@ -13502,7 +13556,7 @@ runtime.
@geindex Pragmas
@node RM 2 8 16 Pragmas,RM 2 8 17-19 Pragmas,RM 1 1 5 12 Bounded Errors,Implementation Advice
-@anchor{gnat_rm/implementation_advice id2}@anchor{218}@anchor{gnat_rm/implementation_advice rm-2-8-16-pragmas}@anchor{219}
+@anchor{gnat_rm/implementation_advice id2}@anchor{21b}@anchor{gnat_rm/implementation_advice rm-2-8-16-pragmas}@anchor{21c}
@section RM 2.8(16): Pragmas
@@ -13615,7 +13669,7 @@ that this advice not be followed. For details see
@ref{7,,Implementation Defined Pragmas}.
@node RM 2 8 17-19 Pragmas,RM 3 5 2 5 Alternative Character Sets,RM 2 8 16 Pragmas,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-2-8-17-19-pragmas}@anchor{21a}
+@anchor{gnat_rm/implementation_advice rm-2-8-17-19-pragmas}@anchor{21d}
@section RM 2.8(17-19): Pragmas
@@ -13636,14 +13690,14 @@ replacing @code{library_items}."
@end itemize
@end quotation
-See @ref{219,,RM 2.8(16); Pragmas}.
+See @ref{21c,,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{21b}
+@anchor{gnat_rm/implementation_advice rm-3-5-2-5-alternative-character-sets}@anchor{21e}
@section RM 3.5.2(5): Alternative Character Sets
@@ -13671,7 +13725,7 @@ there is no such restriction.
@geindex Integer types
@node RM 3 5 4 28 Integer Types,RM 3 5 4 29 Integer Types,RM 3 5 2 5 Alternative Character Sets,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-3-5-4-28-integer-types}@anchor{21c}
+@anchor{gnat_rm/implementation_advice rm-3-5-4-28-integer-types}@anchor{21f}
@section RM 3.5.4(28): Integer Types
@@ -13690,7 +13744,7 @@ are supported for convenient interface to C, and so that all hardware
types of the machine are easily available.
@node RM 3 5 4 29 Integer Types,RM 3 5 5 8 Enumeration Values,RM 3 5 4 28 Integer Types,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-3-5-4-29-integer-types}@anchor{21d}
+@anchor{gnat_rm/implementation_advice rm-3-5-4-29-integer-types}@anchor{220}
@section RM 3.5.4(29): Integer Types
@@ -13706,7 +13760,7 @@ Followed.
@geindex Enumeration values
@node RM 3 5 5 8 Enumeration Values,RM 3 5 7 17 Float Types,RM 3 5 4 29 Integer Types,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-3-5-5-8-enumeration-values}@anchor{21e}
+@anchor{gnat_rm/implementation_advice rm-3-5-5-8-enumeration-values}@anchor{221}
@section RM 3.5.5(8): Enumeration Values
@@ -13726,7 +13780,7 @@ Followed.
@geindex Float types
@node RM 3 5 7 17 Float Types,RM 3 6 2 11 Multidimensional Arrays,RM 3 5 5 8 Enumeration Values,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-3-5-7-17-float-types}@anchor{21f}
+@anchor{gnat_rm/implementation_advice rm-3-5-7-17-float-types}@anchor{222}
@section RM 3.5.7(17): Float Types
@@ -13756,7 +13810,7 @@ is a software rather than a hardware format.
@geindex multidimensional
@node RM 3 6 2 11 Multidimensional Arrays,RM 9 6 30-31 Duration'Small,RM 3 5 7 17 Float Types,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-3-6-2-11-multidimensional-arrays}@anchor{220}
+@anchor{gnat_rm/implementation_advice rm-3-6-2-11-multidimensional-arrays}@anchor{223}
@section RM 3.6.2(11): Multidimensional Arrays
@@ -13774,7 +13828,7 @@ Followed.
@geindex Duration'Small
@node RM 9 6 30-31 Duration'Small,RM 10 2 1 12 Consistent Representation,RM 3 6 2 11 Multidimensional Arrays,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-9-6-30-31-duration-small}@anchor{221}
+@anchor{gnat_rm/implementation_advice rm-9-6-30-31-duration-small}@anchor{224}
@section RM 9.6(30-31): Duration'Small
@@ -13795,7 +13849,7 @@ it need not be the same time base as used for @code{Calendar.Clock}."
Followed.
@node RM 10 2 1 12 Consistent Representation,RM 11 4 1 19 Exception Information,RM 9 6 30-31 Duration'Small,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-10-2-1-12-consistent-representation}@anchor{222}
+@anchor{gnat_rm/implementation_advice rm-10-2-1-12-consistent-representation}@anchor{225}
@section RM 10.2.1(12): Consistent Representation
@@ -13817,7 +13871,7 @@ advice without severely impacting efficiency of execution.
@geindex Exception information
@node RM 11 4 1 19 Exception Information,RM 11 5 28 Suppression of Checks,RM 10 2 1 12 Consistent Representation,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-11-4-1-19-exception-information}@anchor{223}
+@anchor{gnat_rm/implementation_advice rm-11-4-1-19-exception-information}@anchor{226}
@section RM 11.4.1(19): Exception Information
@@ -13848,7 +13902,7 @@ Pragma @code{Discard_Names}.
@geindex suppression of
@node RM 11 5 28 Suppression of Checks,RM 13 1 21-24 Representation Clauses,RM 11 4 1 19 Exception Information,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-11-5-28-suppression-of-checks}@anchor{224}
+@anchor{gnat_rm/implementation_advice rm-11-5-28-suppression-of-checks}@anchor{227}
@section RM 11.5(28): Suppression of Checks
@@ -13863,7 +13917,7 @@ Followed.
@geindex Representation clauses
@node RM 13 1 21-24 Representation Clauses,RM 13 2 6-8 Packed Types,RM 11 5 28 Suppression of Checks,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-13-1-21-24-representation-clauses}@anchor{225}
+@anchor{gnat_rm/implementation_advice rm-13-1-21-24-representation-clauses}@anchor{228}
@section RM 13.1 (21-24): Representation Clauses
@@ -13912,7 +13966,7 @@ Followed.
@geindex Packed types
@node RM 13 2 6-8 Packed Types,RM 13 3 14-19 Address Clauses,RM 13 1 21-24 Representation Clauses,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-13-2-6-8-packed-types}@anchor{226}
+@anchor{gnat_rm/implementation_advice rm-13-2-6-8-packed-types}@anchor{229}
@section RM 13.2(6-8): Packed Types
@@ -13951,7 +14005,7 @@ Followed.
@geindex Address clauses
@node RM 13 3 14-19 Address Clauses,RM 13 3 29-35 Alignment Clauses,RM 13 2 6-8 Packed Types,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-13-3-14-19-address-clauses}@anchor{227}
+@anchor{gnat_rm/implementation_advice rm-13-3-14-19-address-clauses}@anchor{22a}
@section RM 13.3(14-19): Address Clauses
@@ -14004,7 +14058,7 @@ Followed.
@geindex Alignment clauses
@node RM 13 3 29-35 Alignment Clauses,RM 13 3 42-43 Size Clauses,RM 13 3 14-19 Address Clauses,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-13-3-29-35-alignment-clauses}@anchor{228}
+@anchor{gnat_rm/implementation_advice rm-13-3-29-35-alignment-clauses}@anchor{22b}
@section RM 13.3(29-35): Alignment Clauses
@@ -14061,7 +14115,7 @@ Followed.
@geindex Size clauses
@node RM 13 3 42-43 Size Clauses,RM 13 3 50-56 Size Clauses,RM 13 3 29-35 Alignment Clauses,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-13-3-42-43-size-clauses}@anchor{229}
+@anchor{gnat_rm/implementation_advice rm-13-3-42-43-size-clauses}@anchor{22c}
@section RM 13.3(42-43): Size Clauses
@@ -14079,7 +14133,7 @@ object's @code{Alignment} (if the @code{Alignment} is nonzero)."
Followed.
@node RM 13 3 50-56 Size Clauses,RM 13 3 71-73 Component Size Clauses,RM 13 3 42-43 Size Clauses,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-13-3-50-56-size-clauses}@anchor{22a}
+@anchor{gnat_rm/implementation_advice rm-13-3-50-56-size-clauses}@anchor{22d}
@section RM 13.3(50-56): Size Clauses
@@ -14130,7 +14184,7 @@ Followed.
@geindex Component_Size clauses
@node RM 13 3 71-73 Component Size Clauses,RM 13 4 9-10 Enumeration Representation Clauses,RM 13 3 50-56 Size Clauses,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-13-3-71-73-component-size-clauses}@anchor{22b}
+@anchor{gnat_rm/implementation_advice rm-13-3-71-73-component-size-clauses}@anchor{22e}
@section RM 13.3(71-73): Component Size Clauses
@@ -14164,7 +14218,7 @@ Followed.
@geindex enumeration
@node RM 13 4 9-10 Enumeration Representation Clauses,RM 13 5 1 17-22 Record Representation Clauses,RM 13 3 71-73 Component Size Clauses,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-13-4-9-10-enumeration-representation-clauses}@anchor{22c}
+@anchor{gnat_rm/implementation_advice rm-13-4-9-10-enumeration-representation-clauses}@anchor{22f}
@section RM 13.4(9-10): Enumeration Representation Clauses
@@ -14186,7 +14240,7 @@ Followed.
@geindex records
@node RM 13 5 1 17-22 Record Representation Clauses,RM 13 5 2 5 Storage Place Attributes,RM 13 4 9-10 Enumeration Representation Clauses,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-13-5-1-17-22-record-representation-clauses}@anchor{22d}
+@anchor{gnat_rm/implementation_advice rm-13-5-1-17-22-record-representation-clauses}@anchor{230}
@section RM 13.5.1(17-22): Record Representation Clauses
@@ -14246,7 +14300,7 @@ and all mentioned features are implemented.
@geindex Storage place attributes
@node RM 13 5 2 5 Storage Place Attributes,RM 13 5 3 7-8 Bit Ordering,RM 13 5 1 17-22 Record Representation Clauses,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-13-5-2-5-storage-place-attributes}@anchor{22e}
+@anchor{gnat_rm/implementation_advice rm-13-5-2-5-storage-place-attributes}@anchor{231}
@section RM 13.5.2(5): Storage Place Attributes
@@ -14266,7 +14320,7 @@ Followed. There are no such components in GNAT.
@geindex Bit ordering
@node RM 13 5 3 7-8 Bit Ordering,RM 13 7 37 Address as Private,RM 13 5 2 5 Storage Place Attributes,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-13-5-3-7-8-bit-ordering}@anchor{22f}
+@anchor{gnat_rm/implementation_advice rm-13-5-3-7-8-bit-ordering}@anchor{232}
@section RM 13.5.3(7-8): Bit Ordering
@@ -14286,7 +14340,7 @@ Thus non-default bit ordering is not supported.
@geindex as private type
@node RM 13 7 37 Address as Private,RM 13 7 1 16 Address Operations,RM 13 5 3 7-8 Bit Ordering,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-13-7-37-address-as-private}@anchor{230}
+@anchor{gnat_rm/implementation_advice rm-13-7-37-address-as-private}@anchor{233}
@section RM 13.7(37): Address as Private
@@ -14304,7 +14358,7 @@ Followed.
@geindex operations of
@node RM 13 7 1 16 Address Operations,RM 13 9 14-17 Unchecked Conversion,RM 13 7 37 Address as Private,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-13-7-1-16-address-operations}@anchor{231}
+@anchor{gnat_rm/implementation_advice rm-13-7-1-16-address-operations}@anchor{234}
@section RM 13.7.1(16): Address Operations
@@ -14322,7 +14376,7 @@ operation raises @code{Program_Error}, since all operations make sense.
@geindex Unchecked conversion
@node RM 13 9 14-17 Unchecked Conversion,RM 13 11 23-25 Implicit Heap Usage,RM 13 7 1 16 Address Operations,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-13-9-14-17-unchecked-conversion}@anchor{232}
+@anchor{gnat_rm/implementation_advice rm-13-9-14-17-unchecked-conversion}@anchor{235}
@section RM 13.9(14-17): Unchecked Conversion
@@ -14366,7 +14420,7 @@ Followed.
@geindex implicit
@node RM 13 11 23-25 Implicit Heap Usage,RM 13 11 2 17 Unchecked Deallocation,RM 13 9 14-17 Unchecked Conversion,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-13-11-23-25-implicit-heap-usage}@anchor{233}
+@anchor{gnat_rm/implementation_advice rm-13-11-23-25-implicit-heap-usage}@anchor{236}
@section RM 13.11(23-25): Implicit Heap Usage
@@ -14417,7 +14471,7 @@ Followed.
@geindex Unchecked deallocation
@node RM 13 11 2 17 Unchecked Deallocation,RM 13 13 2 1 6 Stream Oriented Attributes,RM 13 11 23-25 Implicit Heap Usage,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-13-11-2-17-unchecked-deallocation}@anchor{234}
+@anchor{gnat_rm/implementation_advice rm-13-11-2-17-unchecked-deallocation}@anchor{237}
@section RM 13.11.2(17): Unchecked Deallocation
@@ -14432,7 +14486,7 @@ Followed.
@geindex Stream oriented attributes
@node RM 13 13 2 1 6 Stream Oriented Attributes,RM A 1 52 Names of Predefined Numeric Types,RM 13 11 2 17 Unchecked Deallocation,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-13-13-2-1-6-stream-oriented-attributes}@anchor{235}
+@anchor{gnat_rm/implementation_advice rm-13-13-2-1-6-stream-oriented-attributes}@anchor{238}
@section RM 13.13.2(1.6): Stream Oriented Attributes
@@ -14463,7 +14517,7 @@ 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{236}
+@anchor{gnat_rm/implementation_advice rm-a-1-52-names-of-predefined-numeric-types}@anchor{239}
@section RM A.1(52): Names of Predefined Numeric Types
@@ -14481,7 +14535,7 @@ Followed.
@geindex Ada.Characters.Handling
@node RM A 3 2 49 Ada Characters Handling,RM A 4 4 106 Bounded-Length String Handling,RM A 1 52 Names of Predefined Numeric Types,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-a-3-2-49-ada-characters-handling}@anchor{237}
+@anchor{gnat_rm/implementation_advice rm-a-3-2-49-ada-characters-handling}@anchor{23a}
@section RM A.3.2(49): @code{Ada.Characters.Handling}
@@ -14498,7 +14552,7 @@ Followed. GNAT provides no such localized definitions.
@geindex Bounded-length strings
@node RM A 4 4 106 Bounded-Length String Handling,RM A 5 2 46-47 Random Number Generation,RM A 3 2 49 Ada Characters Handling,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-a-4-4-106-bounded-length-string-handling}@anchor{238}
+@anchor{gnat_rm/implementation_advice rm-a-4-4-106-bounded-length-string-handling}@anchor{23b}
@section RM A.4.4(106): Bounded-Length String Handling
@@ -14513,7 +14567,7 @@ Followed. No implicit pointers or dynamic allocation are used.
@geindex Random number generation
@node RM A 5 2 46-47 Random Number Generation,RM A 10 7 23 Get_Immediate,RM A 4 4 106 Bounded-Length String Handling,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-a-5-2-46-47-random-number-generation}@anchor{239}
+@anchor{gnat_rm/implementation_advice rm-a-5-2-46-47-random-number-generation}@anchor{23c}
@section RM A.5.2(46-47): Random Number Generation
@@ -14542,7 +14596,7 @@ condition here to hold true.
@geindex Get_Immediate
@node RM A 10 7 23 Get_Immediate,RM B 1 39-41 Pragma Export,RM A 5 2 46-47 Random Number Generation,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-a-10-7-23-get-immediate}@anchor{23a}
+@anchor{gnat_rm/implementation_advice rm-a-10-7-23-get-immediate}@anchor{23d}
@section RM A.10.7(23): @code{Get_Immediate}
@@ -14566,7 +14620,7 @@ this functionality.
@geindex Export
@node RM B 1 39-41 Pragma Export,RM B 2 12-13 Package Interfaces,RM A 10 7 23 Get_Immediate,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-b-1-39-41-pragma-export}@anchor{23b}
+@anchor{gnat_rm/implementation_advice rm-b-1-39-41-pragma-export}@anchor{23e}
@section RM B.1(39-41): Pragma @code{Export}
@@ -14614,7 +14668,7 @@ Followed.
@geindex Interfaces
@node RM B 2 12-13 Package Interfaces,RM B 3 63-71 Interfacing with C,RM B 1 39-41 Pragma Export,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-b-2-12-13-package-interfaces}@anchor{23c}
+@anchor{gnat_rm/implementation_advice rm-b-2-12-13-package-interfaces}@anchor{23f}
@section RM B.2(12-13): Package @code{Interfaces}
@@ -14644,7 +14698,7 @@ Followed. GNAT provides all the packages described in this section.
@geindex interfacing with
@node RM B 3 63-71 Interfacing with C,RM B 4 95-98 Interfacing with COBOL,RM B 2 12-13 Package Interfaces,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-b-3-63-71-interfacing-with-c}@anchor{23d}
+@anchor{gnat_rm/implementation_advice rm-b-3-63-71-interfacing-with-c}@anchor{240}
@section RM B.3(63-71): Interfacing with C
@@ -14732,7 +14786,7 @@ Followed.
@geindex interfacing with
@node RM B 4 95-98 Interfacing with COBOL,RM B 5 22-26 Interfacing with Fortran,RM B 3 63-71 Interfacing with C,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-b-4-95-98-interfacing-with-cobol}@anchor{23e}
+@anchor{gnat_rm/implementation_advice rm-b-4-95-98-interfacing-with-cobol}@anchor{241}
@section RM B.4(95-98): Interfacing with COBOL
@@ -14773,7 +14827,7 @@ Followed.
@geindex interfacing with
@node RM B 5 22-26 Interfacing with Fortran,RM C 1 3-5 Access to Machine Operations,RM B 4 95-98 Interfacing with COBOL,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-b-5-22-26-interfacing-with-fortran}@anchor{23f}
+@anchor{gnat_rm/implementation_advice rm-b-5-22-26-interfacing-with-fortran}@anchor{242}
@section RM B.5(22-26): Interfacing with Fortran
@@ -14824,7 +14878,7 @@ Followed.
@geindex Machine operations
@node RM C 1 3-5 Access to Machine Operations,RM C 1 10-16 Access to Machine Operations,RM B 5 22-26 Interfacing with Fortran,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-c-1-3-5-access-to-machine-operations}@anchor{240}
+@anchor{gnat_rm/implementation_advice rm-c-1-3-5-access-to-machine-operations}@anchor{243}
@section RM C.1(3-5): Access to Machine Operations
@@ -14859,7 +14913,7 @@ object that is specified as exported."
Followed.
@node RM C 1 10-16 Access to Machine Operations,RM C 3 28 Interrupt Support,RM C 1 3-5 Access to Machine Operations,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-c-1-10-16-access-to-machine-operations}@anchor{241}
+@anchor{gnat_rm/implementation_advice rm-c-1-10-16-access-to-machine-operations}@anchor{244}
@section RM C.1(10-16): Access to Machine Operations
@@ -14920,7 +14974,7 @@ Followed on any target supporting such operations.
@geindex Interrupt support
@node RM C 3 28 Interrupt Support,RM C 3 1 20-21 Protected Procedure Handlers,RM C 1 10-16 Access to Machine Operations,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-c-3-28-interrupt-support}@anchor{242}
+@anchor{gnat_rm/implementation_advice rm-c-3-28-interrupt-support}@anchor{245}
@section RM C.3(28): Interrupt Support
@@ -14938,7 +14992,7 @@ of interrupt blocking.
@geindex Protected procedure handlers
@node RM C 3 1 20-21 Protected Procedure Handlers,RM C 3 2 25 Package Interrupts,RM C 3 28 Interrupt Support,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-c-3-1-20-21-protected-procedure-handlers}@anchor{243}
+@anchor{gnat_rm/implementation_advice rm-c-3-1-20-21-protected-procedure-handlers}@anchor{246}
@section RM C.3.1(20-21): Protected Procedure Handlers
@@ -14964,7 +15018,7 @@ Followed. Compile time warnings are given when possible.
@geindex Interrupts
@node RM C 3 2 25 Package Interrupts,RM C 4 14 Pre-elaboration Requirements,RM C 3 1 20-21 Protected Procedure Handlers,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-c-3-2-25-package-interrupts}@anchor{244}
+@anchor{gnat_rm/implementation_advice rm-c-3-2-25-package-interrupts}@anchor{247}
@section RM C.3.2(25): Package @code{Interrupts}
@@ -14982,7 +15036,7 @@ Followed.
@geindex Pre-elaboration requirements
@node RM C 4 14 Pre-elaboration Requirements,RM C 5 8 Pragma Discard_Names,RM C 3 2 25 Package Interrupts,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-c-4-14-pre-elaboration-requirements}@anchor{245}
+@anchor{gnat_rm/implementation_advice rm-c-4-14-pre-elaboration-requirements}@anchor{248}
@section RM C.4(14): Pre-elaboration Requirements
@@ -14998,7 +15052,7 @@ Followed. Executable code is generated in some cases, e.g., loops
to initialize large arrays.
@node RM C 5 8 Pragma Discard_Names,RM C 7 2 30 The Package Task_Attributes,RM C 4 14 Pre-elaboration Requirements,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-c-5-8-pragma-discard-names}@anchor{246}
+@anchor{gnat_rm/implementation_advice rm-c-5-8-pragma-discard-names}@anchor{249}
@section RM C.5(8): Pragma @code{Discard_Names}
@@ -15016,7 +15070,7 @@ Followed.
@geindex Task_Attributes
@node RM C 7 2 30 The Package Task_Attributes,RM D 3 17 Locking Policies,RM C 5 8 Pragma Discard_Names,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-c-7-2-30-the-package-task-attributes}@anchor{247}
+@anchor{gnat_rm/implementation_advice rm-c-7-2-30-the-package-task-attributes}@anchor{24a}
@section RM C.7.2(30): The Package Task_Attributes
@@ -15037,7 +15091,7 @@ Not followed. This implementation is not targeted to such a domain.
@geindex Locking Policies
@node RM D 3 17 Locking Policies,RM D 4 16 Entry Queuing Policies,RM C 7 2 30 The Package Task_Attributes,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-d-3-17-locking-policies}@anchor{248}
+@anchor{gnat_rm/implementation_advice rm-d-3-17-locking-policies}@anchor{24b}
@section RM D.3(17): Locking Policies
@@ -15054,7 +15108,7 @@ whose names (@code{Inheritance_Locking} and
@geindex Entry queuing policies
@node RM D 4 16 Entry Queuing Policies,RM D 6 9-10 Preemptive Abort,RM D 3 17 Locking Policies,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-d-4-16-entry-queuing-policies}@anchor{249}
+@anchor{gnat_rm/implementation_advice rm-d-4-16-entry-queuing-policies}@anchor{24c}
@section RM D.4(16): Entry Queuing Policies
@@ -15069,7 +15123,7 @@ Followed. No such implementation-defined queuing policies exist.
@geindex Preemptive abort
@node RM D 6 9-10 Preemptive Abort,RM D 7 21 Tasking Restrictions,RM D 4 16 Entry Queuing Policies,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-d-6-9-10-preemptive-abort}@anchor{24a}
+@anchor{gnat_rm/implementation_advice rm-d-6-9-10-preemptive-abort}@anchor{24d}
@section RM D.6(9-10): Preemptive Abort
@@ -15095,7 +15149,7 @@ Followed.
@geindex Tasking restrictions
@node RM D 7 21 Tasking Restrictions,RM D 8 47-49 Monotonic Time,RM D 6 9-10 Preemptive Abort,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-d-7-21-tasking-restrictions}@anchor{24b}
+@anchor{gnat_rm/implementation_advice rm-d-7-21-tasking-restrictions}@anchor{24e}
@section RM D.7(21): Tasking Restrictions
@@ -15114,7 +15168,7 @@ pragma @code{Profile (Restricted)} for more details.
@geindex monotonic
@node RM D 8 47-49 Monotonic Time,RM E 5 28-29 Partition Communication Subsystem,RM D 7 21 Tasking Restrictions,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-d-8-47-49-monotonic-time}@anchor{24c}
+@anchor{gnat_rm/implementation_advice rm-d-8-47-49-monotonic-time}@anchor{24f}
@section RM D.8(47-49): Monotonic Time
@@ -15149,7 +15203,7 @@ Followed.
@geindex PCS
@node RM E 5 28-29 Partition Communication Subsystem,RM F 7 COBOL Support,RM D 8 47-49 Monotonic Time,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-e-5-28-29-partition-communication-subsystem}@anchor{24d}
+@anchor{gnat_rm/implementation_advice rm-e-5-28-29-partition-communication-subsystem}@anchor{250}
@section RM E.5(28-29): Partition Communication Subsystem
@@ -15177,7 +15231,7 @@ GNAT.
@geindex COBOL support
@node RM F 7 COBOL Support,RM F 1 2 Decimal Radix Support,RM E 5 28-29 Partition Communication Subsystem,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-f-7-cobol-support}@anchor{24e}
+@anchor{gnat_rm/implementation_advice rm-f-7-cobol-support}@anchor{251}
@section RM F(7): COBOL Support
@@ -15197,7 +15251,7 @@ Followed.
@geindex Decimal radix support
@node RM F 1 2 Decimal Radix Support,RM G Numerics,RM F 7 COBOL Support,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-f-1-2-decimal-radix-support}@anchor{24f}
+@anchor{gnat_rm/implementation_advice rm-f-1-2-decimal-radix-support}@anchor{252}
@section RM F.1(2): Decimal Radix Support
@@ -15213,7 +15267,7 @@ representations.
@geindex Numerics
@node RM G Numerics,RM G 1 1 56-58 Complex Types,RM F 1 2 Decimal Radix Support,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-g-numerics}@anchor{250}
+@anchor{gnat_rm/implementation_advice rm-g-numerics}@anchor{253}
@section RM G: Numerics
@@ -15233,7 +15287,7 @@ Followed.
@geindex Complex types
@node RM G 1 1 56-58 Complex Types,RM G 1 2 49 Complex Elementary Functions,RM G Numerics,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-g-1-1-56-58-complex-types}@anchor{251}
+@anchor{gnat_rm/implementation_advice rm-g-1-1-56-58-complex-types}@anchor{254}
@section RM G.1.1(56-58): Complex Types
@@ -15295,7 +15349,7 @@ Followed.
@geindex Complex elementary functions
@node RM G 1 2 49 Complex Elementary Functions,RM G 2 4 19 Accuracy Requirements,RM G 1 1 56-58 Complex Types,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-g-1-2-49-complex-elementary-functions}@anchor{252}
+@anchor{gnat_rm/implementation_advice rm-g-1-2-49-complex-elementary-functions}@anchor{255}
@section RM G.1.2(49): Complex Elementary Functions
@@ -15317,7 +15371,7 @@ Followed.
@geindex Accuracy requirements
@node RM G 2 4 19 Accuracy Requirements,RM G 2 6 15 Complex Arithmetic Accuracy,RM G 1 2 49 Complex Elementary Functions,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-g-2-4-19-accuracy-requirements}@anchor{253}
+@anchor{gnat_rm/implementation_advice rm-g-2-4-19-accuracy-requirements}@anchor{256}
@section RM G.2.4(19): Accuracy Requirements
@@ -15341,7 +15395,7 @@ Followed.
@geindex complex arithmetic
@node RM G 2 6 15 Complex Arithmetic Accuracy,RM H 6 15/2 Pragma Partition_Elaboration_Policy,RM G 2 4 19 Accuracy Requirements,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-g-2-6-15-complex-arithmetic-accuracy}@anchor{254}
+@anchor{gnat_rm/implementation_advice rm-g-2-6-15-complex-arithmetic-accuracy}@anchor{257}
@section RM G.2.6(15): Complex Arithmetic Accuracy
@@ -15359,7 +15413,7 @@ Followed.
@geindex Sequential elaboration policy
@node RM H 6 15/2 Pragma Partition_Elaboration_Policy,,RM G 2 6 15 Complex Arithmetic Accuracy,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-h-6-15-2-pragma-partition-elaboration-policy}@anchor{255}
+@anchor{gnat_rm/implementation_advice rm-h-6-15-2-pragma-partition-elaboration-policy}@anchor{258}
@section RM H.6(15/2): Pragma Partition_Elaboration_Policy
@@ -15374,7 +15428,7 @@ immediately terminated."
Not followed.
@node Implementation Defined Characteristics,Intrinsic Subprograms,Implementation Advice,Top
-@anchor{gnat_rm/implementation_defined_characteristics implementation-defined-characteristics}@anchor{b}@anchor{gnat_rm/implementation_defined_characteristics doc}@anchor{256}@anchor{gnat_rm/implementation_defined_characteristics id1}@anchor{257}
+@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}
@chapter Implementation Defined Characteristics
@@ -15675,7 +15729,7 @@ Representation
"The small of an ordinary fixed point type. See 3.5.9(8)."
@end itemize
-@code{Fine_Delta} is 2**(-63)
+The small is the largest power of two that does not exceed the delta.
@itemize *
@@ -15685,12 +15739,27 @@ Representation
supported for fixed point types. See 3.5.9(10)."
@end itemize
-Any combinations are permitted that do not result in a small less than
-@code{Fine_Delta} and do not result in a mantissa larger than 63 bits.
-If the mantissa is larger than 53 bits on machines where Long_Long_Float
-is 64 bits (true of all architectures except x86), then the output from
-Text_IO is accurate to only 53 bits, rather than the full mantissa. This
-is because floating-point conversions are used to convert fixed point.
+For an ordinary fixed point type, on 32-bit platforms, the small must lie in
+2.0**(-80) .. 2.0**80 and the range in -9.0E+36 .. 9.0E+36; any combination
+is permitted that does not result in a mantissa larger than 63 bits.
+
+On 64-bit platforms, the small must lie in 2.0**(-127) .. 2.0**127 and the
+range in -1.0E+76 .. 1.0E+76; any combination is permitted that does not
+result in a mantissa larger than 63 bits, and any combination is permitted
+that results in a mantissa between 64 and 127 bits if the small is the
+ratio of two integers that lie in 1 .. 2.0**127.
+
+If the small is the ratio of two integers with 64-bit magnitude on 32-bit
+platforms and 128-bit magnitude on 64-bit platforms, which is the case if
+no @code{small} clause is provided, then the operations of the fixed point
+type are entirely implemented by means of integer instructions. In the
+other cases, some operations, in particular input and output, may be
+implemented by means of floating-point instructions and may be affected
+by accuracy issues on architectures other than x86.
+
+For a decimal fixed point type, on 32-bit platforms, the small must lie in
+1.0E-18 .. 1.0E+18 and the digits in 1 .. 18. On 64-bit platforms, the
+small must lie in 1.0E-38 .. 1.0E+38 and the digits in 1 .. 38.
@itemize *
@@ -16578,7 +16647,7 @@ When the @code{Pattern} parameter is not the null string, it is interpreted
according to the syntax of regular expressions as defined in the
@code{GNAT.Regexp} package.
-See @ref{258,,GNAT.Regexp (g-regexp.ads)}.
+See @ref{25b,,GNAT.Regexp (g-regexp.ads)}.
@itemize *
@@ -17626,7 +17695,7 @@ H.4(27)."
There are no restrictions on pragma @code{Restrictions}.
@node Intrinsic Subprograms,Representation Clauses and Pragmas,Implementation Defined Characteristics,Top
-@anchor{gnat_rm/intrinsic_subprograms doc}@anchor{259}@anchor{gnat_rm/intrinsic_subprograms intrinsic-subprograms}@anchor{c}@anchor{gnat_rm/intrinsic_subprograms id1}@anchor{25a}
+@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}
@chapter Intrinsic Subprograms
@@ -17664,7 +17733,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{25b}@anchor{gnat_rm/intrinsic_subprograms intrinsic-operators}@anchor{25c}
+@anchor{gnat_rm/intrinsic_subprograms id2}@anchor{25e}@anchor{gnat_rm/intrinsic_subprograms intrinsic-operators}@anchor{25f}
@section Intrinsic Operators
@@ -17695,7 +17764,7 @@ It is also possible to specify such operators for private types, if the
full views are appropriate arithmetic types.
@node Compilation_ISO_Date,Compilation_Date,Intrinsic Operators,Intrinsic Subprograms
-@anchor{gnat_rm/intrinsic_subprograms id3}@anchor{25d}@anchor{gnat_rm/intrinsic_subprograms compilation-iso-date}@anchor{25e}
+@anchor{gnat_rm/intrinsic_subprograms id3}@anchor{260}@anchor{gnat_rm/intrinsic_subprograms compilation-iso-date}@anchor{261}
@section Compilation_ISO_Date
@@ -17709,7 +17778,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{25f}@anchor{gnat_rm/intrinsic_subprograms id4}@anchor{260}
+@anchor{gnat_rm/intrinsic_subprograms compilation-date}@anchor{262}@anchor{gnat_rm/intrinsic_subprograms id4}@anchor{263}
@section Compilation_Date
@@ -17719,7 +17788,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{261}@anchor{gnat_rm/intrinsic_subprograms id5}@anchor{262}
+@anchor{gnat_rm/intrinsic_subprograms compilation-time}@anchor{264}@anchor{gnat_rm/intrinsic_subprograms id5}@anchor{265}
@section Compilation_Time
@@ -17733,7 +17802,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{263}@anchor{gnat_rm/intrinsic_subprograms enclosing-entity}@anchor{264}
+@anchor{gnat_rm/intrinsic_subprograms id6}@anchor{266}@anchor{gnat_rm/intrinsic_subprograms enclosing-entity}@anchor{267}
@section Enclosing_Entity
@@ -17747,7 +17816,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{265}@anchor{gnat_rm/intrinsic_subprograms exception-information}@anchor{266}
+@anchor{gnat_rm/intrinsic_subprograms id7}@anchor{268}@anchor{gnat_rm/intrinsic_subprograms exception-information}@anchor{269}
@section Exception_Information
@@ -17761,7 +17830,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{267}@anchor{gnat_rm/intrinsic_subprograms id8}@anchor{268}
+@anchor{gnat_rm/intrinsic_subprograms exception-message}@anchor{26a}@anchor{gnat_rm/intrinsic_subprograms id8}@anchor{26b}
@section Exception_Message
@@ -17775,7 +17844,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{269}@anchor{gnat_rm/intrinsic_subprograms id9}@anchor{26a}
+@anchor{gnat_rm/intrinsic_subprograms exception-name}@anchor{26c}@anchor{gnat_rm/intrinsic_subprograms id9}@anchor{26d}
@section Exception_Name
@@ -17789,7 +17858,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{26b}@anchor{gnat_rm/intrinsic_subprograms file}@anchor{26c}
+@anchor{gnat_rm/intrinsic_subprograms id10}@anchor{26e}@anchor{gnat_rm/intrinsic_subprograms file}@anchor{26f}
@section File
@@ -17803,7 +17872,7 @@ application program should simply call the function
file.
@node Line,Shifts and Rotates,File,Intrinsic Subprograms
-@anchor{gnat_rm/intrinsic_subprograms id11}@anchor{26d}@anchor{gnat_rm/intrinsic_subprograms line}@anchor{26e}
+@anchor{gnat_rm/intrinsic_subprograms id11}@anchor{270}@anchor{gnat_rm/intrinsic_subprograms line}@anchor{271}
@section Line
@@ -17817,7 +17886,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{26f}@anchor{gnat_rm/intrinsic_subprograms id12}@anchor{270}
+@anchor{gnat_rm/intrinsic_subprograms shifts-and-rotates}@anchor{272}@anchor{gnat_rm/intrinsic_subprograms id12}@anchor{273}
@section Shifts and Rotates
@@ -17853,10 +17922,12 @@ 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.
+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.
@node Source_Location,,Shifts and Rotates,Intrinsic Subprograms
-@anchor{gnat_rm/intrinsic_subprograms source-location}@anchor{271}@anchor{gnat_rm/intrinsic_subprograms id13}@anchor{272}
+@anchor{gnat_rm/intrinsic_subprograms source-location}@anchor{274}@anchor{gnat_rm/intrinsic_subprograms id13}@anchor{275}
@section Source_Location
@@ -17870,7 +17941,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{273}@anchor{gnat_rm/representation_clauses_and_pragmas id1}@anchor{274}
+@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}
@chapter Representation Clauses and Pragmas
@@ -17916,7 +17987,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{275}@anchor{gnat_rm/representation_clauses_and_pragmas alignment-clauses}@anchor{276}
+@anchor{gnat_rm/representation_clauses_and_pragmas id2}@anchor{278}@anchor{gnat_rm/representation_clauses_and_pragmas alignment-clauses}@anchor{279}
@section Alignment Clauses
@@ -17938,7 +18009,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{18f,,Attribute Maximum_Alignment}.)
+@code{Standard'Maximum_Alignment}; see @ref{190,,Attribute Maximum_Alignment}.)
@geindex Maximum_Alignment attribute
@@ -18047,7 +18118,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{277}@anchor{gnat_rm/representation_clauses_and_pragmas size-clauses}@anchor{278}
+@anchor{gnat_rm/representation_clauses_and_pragmas id3}@anchor{27a}@anchor{gnat_rm/representation_clauses_and_pragmas size-clauses}@anchor{27b}
@section Size Clauses
@@ -18124,7 +18195,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{279}@anchor{gnat_rm/representation_clauses_and_pragmas id4}@anchor{27a}
+@anchor{gnat_rm/representation_clauses_and_pragmas storage-size-clauses}@anchor{27c}@anchor{gnat_rm/representation_clauses_and_pragmas id4}@anchor{27d}
@section Storage_Size Clauses
@@ -18197,7 +18268,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{27b}@anchor{gnat_rm/representation_clauses_and_pragmas size-of-variant-record-objects}@anchor{27c}
+@anchor{gnat_rm/representation_clauses_and_pragmas id5}@anchor{27e}@anchor{gnat_rm/representation_clauses_and_pragmas size-of-variant-record-objects}@anchor{27f}
@section Size of Variant Record Objects
@@ -18307,7 +18378,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{27d}@anchor{gnat_rm/representation_clauses_and_pragmas biased-representation}@anchor{27e}
+@anchor{gnat_rm/representation_clauses_and_pragmas id6}@anchor{280}@anchor{gnat_rm/representation_clauses_and_pragmas biased-representation}@anchor{281}
@section Biased Representation
@@ -18345,7 +18416,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{27f}@anchor{gnat_rm/representation_clauses_and_pragmas value-size-and-object-size-clauses}@anchor{280}
+@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}
@section Value_Size and Object_Size Clauses
@@ -18661,7 +18732,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{281}@anchor{gnat_rm/representation_clauses_and_pragmas component-size-clauses}@anchor{282}
+@anchor{gnat_rm/representation_clauses_and_pragmas id8}@anchor{284}@anchor{gnat_rm/representation_clauses_and_pragmas component-size-clauses}@anchor{285}
@section Component_Size Clauses
@@ -18709,7 +18780,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{283}@anchor{gnat_rm/representation_clauses_and_pragmas id9}@anchor{284}
+@anchor{gnat_rm/representation_clauses_and_pragmas bit-order-clauses}@anchor{286}@anchor{gnat_rm/representation_clauses_and_pragmas id9}@anchor{287}
@section Bit_Order Clauses
@@ -18815,7 +18886,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{285}@anchor{gnat_rm/representation_clauses_and_pragmas effect-of-bit-order-on-byte-ordering}@anchor{286}
+@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}
@section Effect of Bit_Order on Byte Ordering
@@ -19072,7 +19143,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{287}@anchor{gnat_rm/representation_clauses_and_pragmas id11}@anchor{288}
+@anchor{gnat_rm/representation_clauses_and_pragmas pragma-pack-for-arrays}@anchor{28a}@anchor{gnat_rm/representation_clauses_and_pragmas id11}@anchor{28b}
@section Pragma Pack for Arrays
@@ -19192,7 +19263,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{289}@anchor{gnat_rm/representation_clauses_and_pragmas id12}@anchor{28a}
+@anchor{gnat_rm/representation_clauses_and_pragmas pragma-pack-for-records}@anchor{28c}@anchor{gnat_rm/representation_clauses_and_pragmas id12}@anchor{28d}
@section Pragma Pack for Records
@@ -19276,7 +19347,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{28b}@anchor{gnat_rm/representation_clauses_and_pragmas record-representation-clauses}@anchor{28c}
+@anchor{gnat_rm/representation_clauses_and_pragmas id13}@anchor{28e}@anchor{gnat_rm/representation_clauses_and_pragmas record-representation-clauses}@anchor{28f}
@section Record Representation Clauses
@@ -19355,7 +19426,7 @@ end record;
@end example
@node Handling of Records with Holes,Enumeration Clauses,Record Representation Clauses,Representation Clauses and Pragmas
-@anchor{gnat_rm/representation_clauses_and_pragmas handling-of-records-with-holes}@anchor{28d}@anchor{gnat_rm/representation_clauses_and_pragmas id14}@anchor{28e}
+@anchor{gnat_rm/representation_clauses_and_pragmas handling-of-records-with-holes}@anchor{290}@anchor{gnat_rm/representation_clauses_and_pragmas id14}@anchor{291}
@section Handling of Records with Holes
@@ -19431,7 +19502,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{28f}@anchor{gnat_rm/representation_clauses_and_pragmas id15}@anchor{290}
+@anchor{gnat_rm/representation_clauses_and_pragmas enumeration-clauses}@anchor{292}@anchor{gnat_rm/representation_clauses_and_pragmas id15}@anchor{293}
@section Enumeration Clauses
@@ -19474,7 +19545,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{291}@anchor{gnat_rm/representation_clauses_and_pragmas address-clauses}@anchor{292}
+@anchor{gnat_rm/representation_clauses_and_pragmas id16}@anchor{294}@anchor{gnat_rm/representation_clauses_and_pragmas address-clauses}@anchor{295}
@section Address Clauses
@@ -19803,7 +19874,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{293}@anchor{gnat_rm/representation_clauses_and_pragmas use-of-address-clauses-for-memory-mapped-i-o}@anchor{294}
+@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}
@section Use of Address Clauses for Memory-Mapped I/O
@@ -19861,7 +19932,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{295}@anchor{gnat_rm/representation_clauses_and_pragmas effect-of-convention-on-representation}@anchor{296}
+@anchor{gnat_rm/representation_clauses_and_pragmas id18}@anchor{298}@anchor{gnat_rm/representation_clauses_and_pragmas effect-of-convention-on-representation}@anchor{299}
@section Effect of Convention on Representation
@@ -19939,7 +20010,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{297}@anchor{gnat_rm/representation_clauses_and_pragmas id19}@anchor{298}
+@anchor{gnat_rm/representation_clauses_and_pragmas conventions-and-anonymous-access-types}@anchor{29a}@anchor{gnat_rm/representation_clauses_and_pragmas id19}@anchor{29b}
@section Conventions and Anonymous Access Types
@@ -20015,7 +20086,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{299}@anchor{gnat_rm/representation_clauses_and_pragmas determining-the-representations-chosen-by-gnat}@anchor{29a}
+@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}
@section Determining the Representations chosen by GNAT
@@ -20167,7 +20238,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{29b}@anchor{gnat_rm/standard_library_routines id1}@anchor{29c}
+@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}
@chapter Standard Library Routines
@@ -20991,7 +21062,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{29d}@anchor{gnat_rm/the_implementation_of_standard_i_o id1}@anchor{29e}
+@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}
@chapter The Implementation of Standard I/O
@@ -21043,7 +21114,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{29f}@anchor{gnat_rm/the_implementation_of_standard_i_o id2}@anchor{2a0}
+@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}
@section Standard I/O Packages
@@ -21114,7 +21185,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{2a1}@anchor{gnat_rm/the_implementation_of_standard_i_o id3}@anchor{2a2}
+@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}
@section FORM Strings
@@ -21140,7 +21211,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{2a3}@anchor{gnat_rm/the_implementation_of_standard_i_o id4}@anchor{2a4}
+@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}
@section Direct_IO
@@ -21160,7 +21231,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{2a5}@anchor{gnat_rm/the_implementation_of_standard_i_o id5}@anchor{2a6}
+@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}
@section Sequential_IO
@@ -21207,7 +21278,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{2a7}@anchor{gnat_rm/the_implementation_of_standard_i_o text-io}@anchor{2a8}
+@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}
@section Text_IO
@@ -21290,7 +21361,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{2a9}@anchor{gnat_rm/the_implementation_of_standard_i_o stream-pointer-positioning}@anchor{2aa}
+@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}
@subsection Stream Pointer Positioning
@@ -21326,7 +21397,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{2ab}@anchor{gnat_rm/the_implementation_of_standard_i_o id8}@anchor{2ac}
+@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}
@subsection Reading and Writing Non-Regular Files
@@ -21377,7 +21448,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{2ad}@anchor{gnat_rm/the_implementation_of_standard_i_o id9}@anchor{2ae}
+@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}
@subsection Get_Immediate
@@ -21395,7 +21466,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{2af}@anchor{gnat_rm/the_implementation_of_standard_i_o treating-text-io-files-as-streams}@anchor{2b0}
+@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}
@subsection Treating Text_IO Files as Streams
@@ -21411,7 +21482,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{2b1}@anchor{gnat_rm/the_implementation_of_standard_i_o text-io-extensions}@anchor{2b2}
+@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}
@subsection Text_IO Extensions
@@ -21439,7 +21510,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{2b3}@anchor{gnat_rm/the_implementation_of_standard_i_o id12}@anchor{2b4}
+@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}
@subsection Text_IO Facilities for Unbounded Strings
@@ -21487,7 +21558,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{2b5}@anchor{gnat_rm/the_implementation_of_standard_i_o id13}@anchor{2b6}
+@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}
@section Wide_Text_IO
@@ -21734,12 +21805,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{2b7}@anchor{gnat_rm/the_implementation_of_standard_i_o id14}@anchor{2b8}
+@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}
@subsection Stream Pointer Positioning
@code{Ada.Wide_Text_IO} is similar to @code{Ada.Text_IO} in its handling
-of stream pointer positioning (@ref{2a8,,Text_IO}). There is one additional
+of stream pointer positioning (@ref{2ab,,Text_IO}). There is one additional
case:
If @code{Ada.Wide_Text_IO.Look_Ahead} reads a character outside the
@@ -21758,7 +21829,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{2b9}@anchor{gnat_rm/the_implementation_of_standard_i_o id15}@anchor{2ba}
+@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}
@subsection Reading and Writing Non-Regular Files
@@ -21769,7 +21840,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{2bb}@anchor{gnat_rm/the_implementation_of_standard_i_o wide-wide-text-io}@anchor{2bc}
+@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}
@section Wide_Wide_Text_IO
@@ -21938,12 +22009,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{2bd}@anchor{gnat_rm/the_implementation_of_standard_i_o id17}@anchor{2be}
+@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}
@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{2a8,,Text_IO}). There is one additional
+of stream pointer positioning (@ref{2ab,,Text_IO}). There is one additional
case:
If @code{Ada.Wide_Wide_Text_IO.Look_Ahead} reads a character outside the
@@ -21962,7 +22033,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{2bf}@anchor{gnat_rm/the_implementation_of_standard_i_o reading-and-writing-non-regular-files-2}@anchor{2c0}
+@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}
@subsection Reading and Writing Non-Regular Files
@@ -21973,7 +22044,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{2c1}@anchor{gnat_rm/the_implementation_of_standard_i_o stream-io}@anchor{2c2}
+@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}
@section Stream_IO
@@ -21995,7 +22066,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{2c3}@anchor{gnat_rm/the_implementation_of_standard_i_o text-translation}@anchor{2c4}
+@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}
@section Text Translation
@@ -22029,7 +22100,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{2c5}@anchor{gnat_rm/the_implementation_of_standard_i_o shared-files}@anchor{2c6}
+@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}
@section Shared Files
@@ -22092,7 +22163,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{2c7}@anchor{gnat_rm/the_implementation_of_standard_i_o id22}@anchor{2c8}
+@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}
@section Filenames encoding
@@ -22132,7 +22203,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{2c9}@anchor{gnat_rm/the_implementation_of_standard_i_o id23}@anchor{2ca}
+@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}
@section File content encoding
@@ -22165,7 +22236,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{2cb}@anchor{gnat_rm/the_implementation_of_standard_i_o id24}@anchor{2cc}
+@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}
@section Open Modes
@@ -22268,7 +22339,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{2cd}@anchor{gnat_rm/the_implementation_of_standard_i_o id25}@anchor{2ce}
+@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}
@section Operations on C Streams
@@ -22428,7 +22499,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{2cf}@anchor{gnat_rm/the_implementation_of_standard_i_o id26}@anchor{2d0}
+@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}
@section Interfacing to C Streams
@@ -22521,7 +22592,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{2d1}@anchor{gnat_rm/the_gnat_library id1}@anchor{2d2}
+@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}
@chapter The GNAT Library
@@ -22715,7 +22786,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{2d3}@anchor{gnat_rm/the_gnat_library ada-characters-latin-9-a-chlat9-ads}@anchor{2d4}
+@anchor{gnat_rm/the_gnat_library id2}@anchor{2d6}@anchor{gnat_rm/the_gnat_library ada-characters-latin-9-a-chlat9-ads}@anchor{2d7}
@section @code{Ada.Characters.Latin_9} (@code{a-chlat9.ads})
@@ -22732,7 +22803,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{2d5}@anchor{gnat_rm/the_gnat_library id3}@anchor{2d6}
+@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}
@section @code{Ada.Characters.Wide_Latin_1} (@code{a-cwila1.ads})
@@ -22749,7 +22820,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{2d7}@anchor{gnat_rm/the_gnat_library ada-characters-wide-latin-9-a-cwila1-ads}@anchor{2d8}
+@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}
@section @code{Ada.Characters.Wide_Latin_9} (@code{a-cwila1.ads})
@@ -22766,7 +22837,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{2d9}@anchor{gnat_rm/the_gnat_library id5}@anchor{2da}
+@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}
@section @code{Ada.Characters.Wide_Wide_Latin_1} (@code{a-chzla1.ads})
@@ -22783,7 +22854,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{2db}@anchor{gnat_rm/the_gnat_library id6}@anchor{2dc}
+@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}
@section @code{Ada.Characters.Wide_Wide_Latin_9} (@code{a-chzla9.ads})
@@ -22800,7 +22871,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{2dd}@anchor{gnat_rm/the_gnat_library ada-containers-formal-doubly-linked-lists-a-cfdlli-ads}@anchor{2de}
+@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}
@section @code{Ada.Containers.Formal_Doubly_Linked_Lists} (@code{a-cfdlli.ads})
@@ -22819,7 +22890,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{2df}@anchor{gnat_rm/the_gnat_library ada-containers-formal-hashed-maps-a-cfhama-ads}@anchor{2e0}
+@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}
@section @code{Ada.Containers.Formal_Hashed_Maps} (@code{a-cfhama.ads})
@@ -22838,7 +22909,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{2e1}@anchor{gnat_rm/the_gnat_library ada-containers-formal-hashed-sets-a-cfhase-ads}@anchor{2e2}
+@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}
@section @code{Ada.Containers.Formal_Hashed_Sets} (@code{a-cfhase.ads})
@@ -22857,7 +22928,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{2e3}@anchor{gnat_rm/the_gnat_library ada-containers-formal-ordered-maps-a-cforma-ads}@anchor{2e4}
+@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}
@section @code{Ada.Containers.Formal_Ordered_Maps} (@code{a-cforma.ads})
@@ -22876,7 +22947,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{2e5}@anchor{gnat_rm/the_gnat_library id11}@anchor{2e6}
+@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}
@section @code{Ada.Containers.Formal_Ordered_Sets} (@code{a-cforse.ads})
@@ -22895,7 +22966,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{2e7}@anchor{gnat_rm/the_gnat_library ada-containers-formal-vectors-a-cofove-ads}@anchor{2e8}
+@anchor{gnat_rm/the_gnat_library id12}@anchor{2ea}@anchor{gnat_rm/the_gnat_library ada-containers-formal-vectors-a-cofove-ads}@anchor{2eb}
@section @code{Ada.Containers.Formal_Vectors} (@code{a-cofove.ads})
@@ -22914,7 +22985,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{2e9}@anchor{gnat_rm/the_gnat_library ada-containers-formal-indefinite-vectors-a-cfinve-ads}@anchor{2ea}
+@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}
@section @code{Ada.Containers.Formal_Indefinite_Vectors} (@code{a-cfinve.ads})
@@ -22933,7 +23004,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{2eb}@anchor{gnat_rm/the_gnat_library ada-containers-functional-vectors-a-cofuve-ads}@anchor{2ec}
+@anchor{gnat_rm/the_gnat_library id14}@anchor{2ee}@anchor{gnat_rm/the_gnat_library ada-containers-functional-vectors-a-cofuve-ads}@anchor{2ef}
@section @code{Ada.Containers.Functional_Vectors} (@code{a-cofuve.ads})
@@ -22955,7 +23026,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{2ed}@anchor{gnat_rm/the_gnat_library id15}@anchor{2ee}
+@anchor{gnat_rm/the_gnat_library ada-containers-functional-sets-a-cofuse-ads}@anchor{2f0}@anchor{gnat_rm/the_gnat_library id15}@anchor{2f1}
@section @code{Ada.Containers.Functional_Sets} (@code{a-cofuse.ads})
@@ -22977,7 +23048,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{2ef}@anchor{gnat_rm/the_gnat_library ada-containers-functional-maps-a-cofuma-ads}@anchor{2f0}
+@anchor{gnat_rm/the_gnat_library id16}@anchor{2f2}@anchor{gnat_rm/the_gnat_library ada-containers-functional-maps-a-cofuma-ads}@anchor{2f3}
@section @code{Ada.Containers.Functional_Maps} (@code{a-cofuma.ads})
@@ -22999,7 +23070,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{2f1}@anchor{gnat_rm/the_gnat_library id17}@anchor{2f2}
+@anchor{gnat_rm/the_gnat_library ada-containers-bounded-holders-a-coboho-ads}@anchor{2f4}@anchor{gnat_rm/the_gnat_library id17}@anchor{2f5}
@section @code{Ada.Containers.Bounded_Holders} (@code{a-coboho.ads})
@@ -23011,7 +23082,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{2f3}@anchor{gnat_rm/the_gnat_library id18}@anchor{2f4}
+@anchor{gnat_rm/the_gnat_library ada-command-line-environment-a-colien-ads}@anchor{2f6}@anchor{gnat_rm/the_gnat_library id18}@anchor{2f7}
@section @code{Ada.Command_Line.Environment} (@code{a-colien.ads})
@@ -23024,7 +23095,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{2f5}@anchor{gnat_rm/the_gnat_library ada-command-line-remove-a-colire-ads}@anchor{2f6}
+@anchor{gnat_rm/the_gnat_library id19}@anchor{2f8}@anchor{gnat_rm/the_gnat_library ada-command-line-remove-a-colire-ads}@anchor{2f9}
@section @code{Ada.Command_Line.Remove} (@code{a-colire.ads})
@@ -23042,7 +23113,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{2f7}@anchor{gnat_rm/the_gnat_library ada-command-line-response-file-a-clrefi-ads}@anchor{2f8}
+@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}
@section @code{Ada.Command_Line.Response_File} (@code{a-clrefi.ads})
@@ -23062,7 +23133,7 @@ Using a response file allow passing a set of arguments to an executable longer
than the maximum allowed by the system on the command line.
@node Ada Direct_IO C_Streams a-diocst ads,Ada Exceptions Is_Null_Occurrence a-einuoc ads,Ada Command_Line Response_File a-clrefi ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id21}@anchor{2f9}@anchor{gnat_rm/the_gnat_library ada-direct-io-c-streams-a-diocst-ads}@anchor{2fa}
+@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}
@section @code{Ada.Direct_IO.C_Streams} (@code{a-diocst.ads})
@@ -23077,7 +23148,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{2fb}@anchor{gnat_rm/the_gnat_library ada-exceptions-is-null-occurrence-a-einuoc-ads}@anchor{2fc}
+@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}
@section @code{Ada.Exceptions.Is_Null_Occurrence} (@code{a-einuoc.ads})
@@ -23091,7 +23162,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{2fd}@anchor{gnat_rm/the_gnat_library ada-exceptions-last-chance-handler-a-elchha-ads}@anchor{2fe}
+@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}
@section @code{Ada.Exceptions.Last_Chance_Handler} (@code{a-elchha.ads})
@@ -23105,7 +23176,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{2ff}@anchor{gnat_rm/the_gnat_library id24}@anchor{300}
+@anchor{gnat_rm/the_gnat_library ada-exceptions-traceback-a-exctra-ads}@anchor{302}@anchor{gnat_rm/the_gnat_library id24}@anchor{303}
@section @code{Ada.Exceptions.Traceback} (@code{a-exctra.ads})
@@ -23118,7 +23189,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{301}@anchor{gnat_rm/the_gnat_library id25}@anchor{302}
+@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}
@section @code{Ada.Sequential_IO.C_Streams} (@code{a-siocst.ads})
@@ -23133,7 +23204,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{303}@anchor{gnat_rm/the_gnat_library ada-streams-stream-io-c-streams-a-ssicst-ads}@anchor{304}
+@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}
@section @code{Ada.Streams.Stream_IO.C_Streams} (@code{a-ssicst.ads})
@@ -23148,7 +23219,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{305}@anchor{gnat_rm/the_gnat_library id27}@anchor{306}
+@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}
@section @code{Ada.Strings.Unbounded.Text_IO} (@code{a-suteio.ads})
@@ -23165,7 +23236,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{307}@anchor{gnat_rm/the_gnat_library ada-strings-wide-unbounded-wide-text-io-a-swuwti-ads}@anchor{308}
+@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}
@section @code{Ada.Strings.Wide_Unbounded.Wide_Text_IO} (@code{a-swuwti.ads})
@@ -23182,7 +23253,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{309}@anchor{gnat_rm/the_gnat_library ada-strings-wide-wide-unbounded-wide-wide-text-io-a-szuzti-ads}@anchor{30a}
+@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}
@section @code{Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO} (@code{a-szuzti.ads})
@@ -23199,7 +23270,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{30b}@anchor{gnat_rm/the_gnat_library id30}@anchor{30c}
+@anchor{gnat_rm/the_gnat_library ada-task-initialization-a-tasini-ads}@anchor{30e}@anchor{gnat_rm/the_gnat_library id30}@anchor{30f}
@section @code{Ada.Task_Initialization} (@code{a-tasini.ads})
@@ -23211,7 +23282,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{30d}@anchor{gnat_rm/the_gnat_library id31}@anchor{30e}
+@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}
@section @code{Ada.Text_IO.C_Streams} (@code{a-tiocst.ads})
@@ -23226,7 +23297,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{30f}@anchor{gnat_rm/the_gnat_library id32}@anchor{310}
+@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}
@section @code{Ada.Text_IO.Reset_Standard_Files} (@code{a-tirsfi.ads})
@@ -23241,7 +23312,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{311}@anchor{gnat_rm/the_gnat_library ada-wide-characters-unicode-a-wichun-ads}@anchor{312}
+@anchor{gnat_rm/the_gnat_library id33}@anchor{314}@anchor{gnat_rm/the_gnat_library ada-wide-characters-unicode-a-wichun-ads}@anchor{315}
@section @code{Ada.Wide_Characters.Unicode} (@code{a-wichun.ads})
@@ -23254,7 +23325,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{313}@anchor{gnat_rm/the_gnat_library ada-wide-text-io-c-streams-a-wtcstr-ads}@anchor{314}
+@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}
@section @code{Ada.Wide_Text_IO.C_Streams} (@code{a-wtcstr.ads})
@@ -23269,7 +23340,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{315}@anchor{gnat_rm/the_gnat_library id35}@anchor{316}
+@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}
@section @code{Ada.Wide_Text_IO.Reset_Standard_Files} (@code{a-wrstfi.ads})
@@ -23284,7 +23355,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{317}@anchor{gnat_rm/the_gnat_library ada-wide-wide-characters-unicode-a-zchuni-ads}@anchor{318}
+@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}
@section @code{Ada.Wide_Wide_Characters.Unicode} (@code{a-zchuni.ads})
@@ -23297,7 +23368,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{319}@anchor{gnat_rm/the_gnat_library ada-wide-wide-text-io-c-streams-a-ztcstr-ads}@anchor{31a}
+@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}
@section @code{Ada.Wide_Wide_Text_IO.C_Streams} (@code{a-ztcstr.ads})
@@ -23312,7 +23383,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{31b}@anchor{gnat_rm/the_gnat_library id38}@anchor{31c}
+@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}
@section @code{Ada.Wide_Wide_Text_IO.Reset_Standard_Files} (@code{a-zrstfi.ads})
@@ -23327,7 +23398,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{31d}@anchor{gnat_rm/the_gnat_library id39}@anchor{31e}
+@anchor{gnat_rm/the_gnat_library gnat-altivec-g-altive-ads}@anchor{320}@anchor{gnat_rm/the_gnat_library id39}@anchor{321}
@section @code{GNAT.Altivec} (@code{g-altive.ads})
@@ -23340,7 +23411,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{31f}@anchor{gnat_rm/the_gnat_library id40}@anchor{320}
+@anchor{gnat_rm/the_gnat_library gnat-altivec-conversions-g-altcon-ads}@anchor{322}@anchor{gnat_rm/the_gnat_library id40}@anchor{323}
@section @code{GNAT.Altivec.Conversions} (@code{g-altcon.ads})
@@ -23351,7 +23422,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{321}@anchor{gnat_rm/the_gnat_library gnat-altivec-vector-operations-g-alveop-ads}@anchor{322}
+@anchor{gnat_rm/the_gnat_library id41}@anchor{324}@anchor{gnat_rm/the_gnat_library gnat-altivec-vector-operations-g-alveop-ads}@anchor{325}
@section @code{GNAT.Altivec.Vector_Operations} (@code{g-alveop.ads})
@@ -23365,7 +23436,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{323}@anchor{gnat_rm/the_gnat_library id42}@anchor{324}
+@anchor{gnat_rm/the_gnat_library gnat-altivec-vector-types-g-alvety-ads}@anchor{326}@anchor{gnat_rm/the_gnat_library id42}@anchor{327}
@section @code{GNAT.Altivec.Vector_Types} (@code{g-alvety.ads})
@@ -23377,7 +23448,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{325}@anchor{gnat_rm/the_gnat_library id43}@anchor{326}
+@anchor{gnat_rm/the_gnat_library gnat-altivec-vector-views-g-alvevi-ads}@anchor{328}@anchor{gnat_rm/the_gnat_library id43}@anchor{329}
@section @code{GNAT.Altivec.Vector_Views} (@code{g-alvevi.ads})
@@ -23392,7 +23463,7 @@ vector elements and provides a simple way to initialize vector
objects.
@node GNAT Array_Split g-arrspl ads,GNAT AWK g-awk ads,GNAT Altivec Vector_Views g-alvevi ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-array-split-g-arrspl-ads}@anchor{327}@anchor{gnat_rm/the_gnat_library id44}@anchor{328}
+@anchor{gnat_rm/the_gnat_library gnat-array-split-g-arrspl-ads}@anchor{32a}@anchor{gnat_rm/the_gnat_library id44}@anchor{32b}
@section @code{GNAT.Array_Split} (@code{g-arrspl.ads})
@@ -23405,7 +23476,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{329}@anchor{gnat_rm/the_gnat_library gnat-awk-g-awk-ads}@anchor{32a}
+@anchor{gnat_rm/the_gnat_library id45}@anchor{32c}@anchor{gnat_rm/the_gnat_library gnat-awk-g-awk-ads}@anchor{32d}
@section @code{GNAT.AWK} (@code{g-awk.ads})
@@ -23420,7 +23491,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{32b}@anchor{gnat_rm/the_gnat_library gnat-bind-environment-g-binenv-ads}@anchor{32c}
+@anchor{gnat_rm/the_gnat_library id46}@anchor{32e}@anchor{gnat_rm/the_gnat_library gnat-bind-environment-g-binenv-ads}@anchor{32f}
@section @code{GNAT.Bind_Environment} (@code{g-binenv.ads})
@@ -23433,7 +23504,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{32d}@anchor{gnat_rm/the_gnat_library gnat-branch-prediction-g-brapre-ads}@anchor{32e}
+@anchor{gnat_rm/the_gnat_library id47}@anchor{330}@anchor{gnat_rm/the_gnat_library gnat-branch-prediction-g-brapre-ads}@anchor{331}
@section @code{GNAT.Branch_Prediction} (@code{g-brapre.ads})
@@ -23444,7 +23515,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{32f}@anchor{gnat_rm/the_gnat_library id48}@anchor{330}
+@anchor{gnat_rm/the_gnat_library gnat-bounded-buffers-g-boubuf-ads}@anchor{332}@anchor{gnat_rm/the_gnat_library id48}@anchor{333}
@section @code{GNAT.Bounded_Buffers} (@code{g-boubuf.ads})
@@ -23459,7 +23530,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{331}@anchor{gnat_rm/the_gnat_library id49}@anchor{332}
+@anchor{gnat_rm/the_gnat_library gnat-bounded-mailboxes-g-boumai-ads}@anchor{334}@anchor{gnat_rm/the_gnat_library id49}@anchor{335}
@section @code{GNAT.Bounded_Mailboxes} (@code{g-boumai.ads})
@@ -23472,7 +23543,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{333}@anchor{gnat_rm/the_gnat_library id50}@anchor{334}
+@anchor{gnat_rm/the_gnat_library gnat-bubble-sort-g-bubsor-ads}@anchor{336}@anchor{gnat_rm/the_gnat_library id50}@anchor{337}
@section @code{GNAT.Bubble_Sort} (@code{g-bubsor.ads})
@@ -23487,7 +23558,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{335}@anchor{gnat_rm/the_gnat_library gnat-bubble-sort-a-g-busora-ads}@anchor{336}
+@anchor{gnat_rm/the_gnat_library id51}@anchor{338}@anchor{gnat_rm/the_gnat_library gnat-bubble-sort-a-g-busora-ads}@anchor{339}
@section @code{GNAT.Bubble_Sort_A} (@code{g-busora.ads})
@@ -23503,7 +23574,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{337}@anchor{gnat_rm/the_gnat_library id52}@anchor{338}
+@anchor{gnat_rm/the_gnat_library gnat-bubble-sort-g-g-busorg-ads}@anchor{33a}@anchor{gnat_rm/the_gnat_library id52}@anchor{33b}
@section @code{GNAT.Bubble_Sort_G} (@code{g-busorg.ads})
@@ -23519,7 +23590,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{339}@anchor{gnat_rm/the_gnat_library id53}@anchor{33a}
+@anchor{gnat_rm/the_gnat_library gnat-byte-order-mark-g-byorma-ads}@anchor{33c}@anchor{gnat_rm/the_gnat_library id53}@anchor{33d}
@section @code{GNAT.Byte_Order_Mark} (@code{g-byorma.ads})
@@ -23535,7 +23606,7 @@ the encoding of the string. The routine includes detection of special XML
sequences for various UCS input formats.
@node GNAT Byte_Swapping g-bytswa ads,GNAT Calendar g-calend ads,GNAT Byte_Order_Mark g-byorma ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-byte-swapping-g-bytswa-ads}@anchor{33b}@anchor{gnat_rm/the_gnat_library id54}@anchor{33c}
+@anchor{gnat_rm/the_gnat_library gnat-byte-swapping-g-bytswa-ads}@anchor{33e}@anchor{gnat_rm/the_gnat_library id54}@anchor{33f}
@section @code{GNAT.Byte_Swapping} (@code{g-bytswa.ads})
@@ -23549,7 +23620,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{33d}@anchor{gnat_rm/the_gnat_library gnat-calendar-g-calend-ads}@anchor{33e}
+@anchor{gnat_rm/the_gnat_library id55}@anchor{340}@anchor{gnat_rm/the_gnat_library gnat-calendar-g-calend-ads}@anchor{341}
@section @code{GNAT.Calendar} (@code{g-calend.ads})
@@ -23563,7 +23634,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{33f}@anchor{gnat_rm/the_gnat_library gnat-calendar-time-io-g-catiio-ads}@anchor{340}
+@anchor{gnat_rm/the_gnat_library id56}@anchor{342}@anchor{gnat_rm/the_gnat_library gnat-calendar-time-io-g-catiio-ads}@anchor{343}
@section @code{GNAT.Calendar.Time_IO} (@code{g-catiio.ads})
@@ -23574,7 +23645,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{341}@anchor{gnat_rm/the_gnat_library gnat-crc32-g-crc32-ads}@anchor{342}
+@anchor{gnat_rm/the_gnat_library id57}@anchor{344}@anchor{gnat_rm/the_gnat_library gnat-crc32-g-crc32-ads}@anchor{345}
@section @code{GNAT.CRC32} (@code{g-crc32.ads})
@@ -23591,7 +23662,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{343}@anchor{gnat_rm/the_gnat_library gnat-case-util-g-casuti-ads}@anchor{344}
+@anchor{gnat_rm/the_gnat_library id58}@anchor{346}@anchor{gnat_rm/the_gnat_library gnat-case-util-g-casuti-ads}@anchor{347}
@section @code{GNAT.Case_Util} (@code{g-casuti.ads})
@@ -23606,7 +23677,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{345}@anchor{gnat_rm/the_gnat_library gnat-cgi-g-cgi-ads}@anchor{346}
+@anchor{gnat_rm/the_gnat_library id59}@anchor{348}@anchor{gnat_rm/the_gnat_library gnat-cgi-g-cgi-ads}@anchor{349}
@section @code{GNAT.CGI} (@code{g-cgi.ads})
@@ -23621,7 +23692,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{347}@anchor{gnat_rm/the_gnat_library id60}@anchor{348}
+@anchor{gnat_rm/the_gnat_library gnat-cgi-cookie-g-cgicoo-ads}@anchor{34a}@anchor{gnat_rm/the_gnat_library id60}@anchor{34b}
@section @code{GNAT.CGI.Cookie} (@code{g-cgicoo.ads})
@@ -23636,7 +23707,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{349}@anchor{gnat_rm/the_gnat_library id61}@anchor{34a}
+@anchor{gnat_rm/the_gnat_library gnat-cgi-debug-g-cgideb-ads}@anchor{34c}@anchor{gnat_rm/the_gnat_library id61}@anchor{34d}
@section @code{GNAT.CGI.Debug} (@code{g-cgideb.ads})
@@ -23648,7 +23719,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{34b}@anchor{gnat_rm/the_gnat_library gnat-command-line-g-comlin-ads}@anchor{34c}
+@anchor{gnat_rm/the_gnat_library id62}@anchor{34e}@anchor{gnat_rm/the_gnat_library gnat-command-line-g-comlin-ads}@anchor{34f}
@section @code{GNAT.Command_Line} (@code{g-comlin.ads})
@@ -23661,7 +23732,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{34d}@anchor{gnat_rm/the_gnat_library id63}@anchor{34e}
+@anchor{gnat_rm/the_gnat_library gnat-compiler-version-g-comver-ads}@anchor{350}@anchor{gnat_rm/the_gnat_library id63}@anchor{351}
@section @code{GNAT.Compiler_Version} (@code{g-comver.ads})
@@ -23679,7 +23750,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{34f}@anchor{gnat_rm/the_gnat_library gnat-ctrl-c-g-ctrl-c-ads}@anchor{350}
+@anchor{gnat_rm/the_gnat_library id64}@anchor{352}@anchor{gnat_rm/the_gnat_library gnat-ctrl-c-g-ctrl-c-ads}@anchor{353}
@section @code{GNAT.Ctrl_C} (@code{g-ctrl_c.ads})
@@ -23690,7 +23761,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{351}@anchor{gnat_rm/the_gnat_library gnat-current-exception-g-curexc-ads}@anchor{352}
+@anchor{gnat_rm/the_gnat_library id65}@anchor{354}@anchor{gnat_rm/the_gnat_library gnat-current-exception-g-curexc-ads}@anchor{355}
@section @code{GNAT.Current_Exception} (@code{g-curexc.ads})
@@ -23707,7 +23778,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{353}@anchor{gnat_rm/the_gnat_library id66}@anchor{354}
+@anchor{gnat_rm/the_gnat_library gnat-debug-pools-g-debpoo-ads}@anchor{356}@anchor{gnat_rm/the_gnat_library id66}@anchor{357}
@section @code{GNAT.Debug_Pools} (@code{g-debpoo.ads})
@@ -23724,7 +23795,7 @@ problems.
See @code{The GNAT Debug_Pool Facility} section in the @cite{GNAT User's Guide}.
@node GNAT Debug_Utilities g-debuti ads,GNAT Decode_String g-decstr ads,GNAT Debug_Pools g-debpoo ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-debug-utilities-g-debuti-ads}@anchor{355}@anchor{gnat_rm/the_gnat_library id67}@anchor{356}
+@anchor{gnat_rm/the_gnat_library gnat-debug-utilities-g-debuti-ads}@anchor{358}@anchor{gnat_rm/the_gnat_library id67}@anchor{359}
@section @code{GNAT.Debug_Utilities} (@code{g-debuti.ads})
@@ -23737,7 +23808,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{357}@anchor{gnat_rm/the_gnat_library id68}@anchor{358}
+@anchor{gnat_rm/the_gnat_library gnat-decode-string-g-decstr-ads}@anchor{35a}@anchor{gnat_rm/the_gnat_library id68}@anchor{35b}
@section @code{GNAT.Decode_String} (@code{g-decstr.ads})
@@ -23761,7 +23832,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{359}@anchor{gnat_rm/the_gnat_library id69}@anchor{35a}
+@anchor{gnat_rm/the_gnat_library gnat-decode-utf8-string-g-deutst-ads}@anchor{35c}@anchor{gnat_rm/the_gnat_library id69}@anchor{35d}
@section @code{GNAT.Decode_UTF8_String} (@code{g-deutst.ads})
@@ -23782,7 +23853,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{35b}@anchor{gnat_rm/the_gnat_library gnat-directory-operations-g-dirope-ads}@anchor{35c}
+@anchor{gnat_rm/the_gnat_library id70}@anchor{35e}@anchor{gnat_rm/the_gnat_library gnat-directory-operations-g-dirope-ads}@anchor{35f}
@section @code{GNAT.Directory_Operations} (@code{g-dirope.ads})
@@ -23795,7 +23866,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{35d}@anchor{gnat_rm/the_gnat_library gnat-directory-operations-iteration-g-diopit-ads}@anchor{35e}
+@anchor{gnat_rm/the_gnat_library id71}@anchor{360}@anchor{gnat_rm/the_gnat_library gnat-directory-operations-iteration-g-diopit-ads}@anchor{361}
@section @code{GNAT.Directory_Operations.Iteration} (@code{g-diopit.ads})
@@ -23807,7 +23878,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{35f}@anchor{gnat_rm/the_gnat_library gnat-dynamic-htables-g-dynhta-ads}@anchor{360}
+@anchor{gnat_rm/the_gnat_library id72}@anchor{362}@anchor{gnat_rm/the_gnat_library gnat-dynamic-htables-g-dynhta-ads}@anchor{363}
@section @code{GNAT.Dynamic_HTables} (@code{g-dynhta.ads})
@@ -23825,7 +23896,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{361}@anchor{gnat_rm/the_gnat_library id73}@anchor{362}
+@anchor{gnat_rm/the_gnat_library gnat-dynamic-tables-g-dyntab-ads}@anchor{364}@anchor{gnat_rm/the_gnat_library id73}@anchor{365}
@section @code{GNAT.Dynamic_Tables} (@code{g-dyntab.ads})
@@ -23845,7 +23916,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{363}@anchor{gnat_rm/the_gnat_library gnat-encode-string-g-encstr-ads}@anchor{364}
+@anchor{gnat_rm/the_gnat_library id74}@anchor{366}@anchor{gnat_rm/the_gnat_library gnat-encode-string-g-encstr-ads}@anchor{367}
@section @code{GNAT.Encode_String} (@code{g-encstr.ads})
@@ -23867,7 +23938,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{365}@anchor{gnat_rm/the_gnat_library id75}@anchor{366}
+@anchor{gnat_rm/the_gnat_library gnat-encode-utf8-string-g-enutst-ads}@anchor{368}@anchor{gnat_rm/the_gnat_library id75}@anchor{369}
@section @code{GNAT.Encode_UTF8_String} (@code{g-enutst.ads})
@@ -23888,7 +23959,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{367}@anchor{gnat_rm/the_gnat_library id76}@anchor{368}
+@anchor{gnat_rm/the_gnat_library gnat-exception-actions-g-excact-ads}@anchor{36a}@anchor{gnat_rm/the_gnat_library id76}@anchor{36b}
@section @code{GNAT.Exception_Actions} (@code{g-excact.ads})
@@ -23901,7 +23972,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{369}@anchor{gnat_rm/the_gnat_library id77}@anchor{36a}
+@anchor{gnat_rm/the_gnat_library gnat-exception-traces-g-exctra-ads}@anchor{36c}@anchor{gnat_rm/the_gnat_library id77}@anchor{36d}
@section @code{GNAT.Exception_Traces} (@code{g-exctra.ads})
@@ -23915,7 +23986,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{36b}@anchor{gnat_rm/the_gnat_library gnat-exceptions-g-except-ads}@anchor{36c}
+@anchor{gnat_rm/the_gnat_library id78}@anchor{36e}@anchor{gnat_rm/the_gnat_library gnat-exceptions-g-except-ads}@anchor{36f}
@section @code{GNAT.Exceptions} (@code{g-except.ads})
@@ -23936,7 +24007,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{36d}@anchor{gnat_rm/the_gnat_library gnat-expect-g-expect-ads}@anchor{36e}
+@anchor{gnat_rm/the_gnat_library id79}@anchor{370}@anchor{gnat_rm/the_gnat_library gnat-expect-g-expect-ads}@anchor{371}
@section @code{GNAT.Expect} (@code{g-expect.ads})
@@ -23952,7 +24023,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{36f}@anchor{gnat_rm/the_gnat_library gnat-expect-tty-g-exptty-ads}@anchor{370}
+@anchor{gnat_rm/the_gnat_library id80}@anchor{372}@anchor{gnat_rm/the_gnat_library gnat-expect-tty-g-exptty-ads}@anchor{373}
@section @code{GNAT.Expect.TTY} (@code{g-exptty.ads})
@@ -23964,7 +24035,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{371}@anchor{gnat_rm/the_gnat_library gnat-float-control-g-flocon-ads}@anchor{372}
+@anchor{gnat_rm/the_gnat_library id81}@anchor{374}@anchor{gnat_rm/the_gnat_library gnat-float-control-g-flocon-ads}@anchor{375}
@section @code{GNAT.Float_Control} (@code{g-flocon.ads})
@@ -23978,7 +24049,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{373}@anchor{gnat_rm/the_gnat_library gnat-formatted-string-g-forstr-ads}@anchor{374}
+@anchor{gnat_rm/the_gnat_library id82}@anchor{376}@anchor{gnat_rm/the_gnat_library gnat-formatted-string-g-forstr-ads}@anchor{377}
@section @code{GNAT.Formatted_String} (@code{g-forstr.ads})
@@ -23993,7 +24064,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{375}@anchor{gnat_rm/the_gnat_library gnat-heap-sort-g-heasor-ads}@anchor{376}
+@anchor{gnat_rm/the_gnat_library id83}@anchor{378}@anchor{gnat_rm/the_gnat_library gnat-heap-sort-g-heasor-ads}@anchor{379}
@section @code{GNAT.Heap_Sort} (@code{g-heasor.ads})
@@ -24007,7 +24078,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{377}@anchor{gnat_rm/the_gnat_library id84}@anchor{378}
+@anchor{gnat_rm/the_gnat_library gnat-heap-sort-a-g-hesora-ads}@anchor{37a}@anchor{gnat_rm/the_gnat_library id84}@anchor{37b}
@section @code{GNAT.Heap_Sort_A} (@code{g-hesora.ads})
@@ -24023,7 +24094,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{379}@anchor{gnat_rm/the_gnat_library gnat-heap-sort-g-g-hesorg-ads}@anchor{37a}
+@anchor{gnat_rm/the_gnat_library id85}@anchor{37c}@anchor{gnat_rm/the_gnat_library gnat-heap-sort-g-g-hesorg-ads}@anchor{37d}
@section @code{GNAT.Heap_Sort_G} (@code{g-hesorg.ads})
@@ -24037,7 +24108,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{37b}@anchor{gnat_rm/the_gnat_library gnat-htable-g-htable-ads}@anchor{37c}
+@anchor{gnat_rm/the_gnat_library id86}@anchor{37e}@anchor{gnat_rm/the_gnat_library gnat-htable-g-htable-ads}@anchor{37f}
@section @code{GNAT.HTable} (@code{g-htable.ads})
@@ -24050,7 +24121,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{37d}@anchor{gnat_rm/the_gnat_library gnat-io-g-io-ads}@anchor{37e}
+@anchor{gnat_rm/the_gnat_library id87}@anchor{380}@anchor{gnat_rm/the_gnat_library gnat-io-g-io-ads}@anchor{381}
@section @code{GNAT.IO} (@code{g-io.ads})
@@ -24066,7 +24137,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{37f}@anchor{gnat_rm/the_gnat_library gnat-io-aux-g-io-aux-ads}@anchor{380}
+@anchor{gnat_rm/the_gnat_library id88}@anchor{382}@anchor{gnat_rm/the_gnat_library gnat-io-aux-g-io-aux-ads}@anchor{383}
@section @code{GNAT.IO_Aux} (@code{g-io_aux.ads})
@@ -24080,7 +24151,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{381}@anchor{gnat_rm/the_gnat_library gnat-lock-files-g-locfil-ads}@anchor{382}
+@anchor{gnat_rm/the_gnat_library id89}@anchor{384}@anchor{gnat_rm/the_gnat_library gnat-lock-files-g-locfil-ads}@anchor{385}
@section @code{GNAT.Lock_Files} (@code{g-locfil.ads})
@@ -24094,7 +24165,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{383}@anchor{gnat_rm/the_gnat_library gnat-mbbs-discrete-random-g-mbdira-ads}@anchor{384}
+@anchor{gnat_rm/the_gnat_library id90}@anchor{386}@anchor{gnat_rm/the_gnat_library gnat-mbbs-discrete-random-g-mbdira-ads}@anchor{387}
@section @code{GNAT.MBBS_Discrete_Random} (@code{g-mbdira.ads})
@@ -24106,7 +24177,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{385}@anchor{gnat_rm/the_gnat_library gnat-mbbs-float-random-g-mbflra-ads}@anchor{386}
+@anchor{gnat_rm/the_gnat_library id91}@anchor{388}@anchor{gnat_rm/the_gnat_library gnat-mbbs-float-random-g-mbflra-ads}@anchor{389}
@section @code{GNAT.MBBS_Float_Random} (@code{g-mbflra.ads})
@@ -24118,7 +24189,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{387}@anchor{gnat_rm/the_gnat_library gnat-md5-g-md5-ads}@anchor{388}
+@anchor{gnat_rm/the_gnat_library id92}@anchor{38a}@anchor{gnat_rm/the_gnat_library gnat-md5-g-md5-ads}@anchor{38b}
@section @code{GNAT.MD5} (@code{g-md5.ads})
@@ -24131,7 +24202,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{389}@anchor{gnat_rm/the_gnat_library gnat-memory-dump-g-memdum-ads}@anchor{38a}
+@anchor{gnat_rm/the_gnat_library id93}@anchor{38c}@anchor{gnat_rm/the_gnat_library gnat-memory-dump-g-memdum-ads}@anchor{38d}
@section @code{GNAT.Memory_Dump} (@code{g-memdum.ads})
@@ -24144,7 +24215,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{38b}@anchor{gnat_rm/the_gnat_library id94}@anchor{38c}
+@anchor{gnat_rm/the_gnat_library gnat-most-recent-exception-g-moreex-ads}@anchor{38e}@anchor{gnat_rm/the_gnat_library id94}@anchor{38f}
@section @code{GNAT.Most_Recent_Exception} (@code{g-moreex.ads})
@@ -24158,7 +24229,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{38d}@anchor{gnat_rm/the_gnat_library id95}@anchor{38e}
+@anchor{gnat_rm/the_gnat_library gnat-os-lib-g-os-lib-ads}@anchor{390}@anchor{gnat_rm/the_gnat_library id95}@anchor{391}
@section @code{GNAT.OS_Lib} (@code{g-os_lib.ads})
@@ -24174,7 +24245,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{38f}@anchor{gnat_rm/the_gnat_library id96}@anchor{390}
+@anchor{gnat_rm/the_gnat_library gnat-perfect-hash-generators-g-pehage-ads}@anchor{392}@anchor{gnat_rm/the_gnat_library id96}@anchor{393}
@section @code{GNAT.Perfect_Hash_Generators} (@code{g-pehage.ads})
@@ -24192,7 +24263,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{391}@anchor{gnat_rm/the_gnat_library id97}@anchor{392}
+@anchor{gnat_rm/the_gnat_library gnat-random-numbers-g-rannum-ads}@anchor{394}@anchor{gnat_rm/the_gnat_library id97}@anchor{395}
@section @code{GNAT.Random_Numbers} (@code{g-rannum.ads})
@@ -24204,7 +24275,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{393}@anchor{gnat_rm/the_gnat_library gnat-regexp-g-regexp-ads}@anchor{258}
+@anchor{gnat_rm/the_gnat_library id98}@anchor{396}@anchor{gnat_rm/the_gnat_library gnat-regexp-g-regexp-ads}@anchor{25b}
@section @code{GNAT.Regexp} (@code{g-regexp.ads})
@@ -24220,7 +24291,7 @@ simplest of the three pattern matching packages provided, and is particularly
suitable for 'file globbing' applications.
@node GNAT Registry g-regist ads,GNAT Regpat g-regpat ads,GNAT Regexp g-regexp ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id99}@anchor{394}@anchor{gnat_rm/the_gnat_library gnat-registry-g-regist-ads}@anchor{395}
+@anchor{gnat_rm/the_gnat_library id99}@anchor{397}@anchor{gnat_rm/the_gnat_library gnat-registry-g-regist-ads}@anchor{398}
@section @code{GNAT.Registry} (@code{g-regist.ads})
@@ -24234,7 +24305,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{396}@anchor{gnat_rm/the_gnat_library gnat-regpat-g-regpat-ads}@anchor{397}
+@anchor{gnat_rm/the_gnat_library id100}@anchor{399}@anchor{gnat_rm/the_gnat_library gnat-regpat-g-regpat-ads}@anchor{39a}
@section @code{GNAT.Regpat} (@code{g-regpat.ads})
@@ -24249,7 +24320,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{398}@anchor{gnat_rm/the_gnat_library gnat-rewrite-data-g-rewdat-ads}@anchor{399}
+@anchor{gnat_rm/the_gnat_library id101}@anchor{39b}@anchor{gnat_rm/the_gnat_library gnat-rewrite-data-g-rewdat-ads}@anchor{39c}
@section @code{GNAT.Rewrite_Data} (@code{g-rewdat.ads})
@@ -24263,7 +24334,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{39a}@anchor{gnat_rm/the_gnat_library id102}@anchor{39b}
+@anchor{gnat_rm/the_gnat_library gnat-secondary-stack-info-g-sestin-ads}@anchor{39d}@anchor{gnat_rm/the_gnat_library id102}@anchor{39e}
@section @code{GNAT.Secondary_Stack_Info} (@code{g-sestin.ads})
@@ -24275,7 +24346,7 @@ Provide the capability to query the high water mark of the current task's
secondary stack.
@node GNAT Semaphores g-semaph ads,GNAT Serial_Communications g-sercom ads,GNAT Secondary_Stack_Info g-sestin ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id103}@anchor{39c}@anchor{gnat_rm/the_gnat_library gnat-semaphores-g-semaph-ads}@anchor{39d}
+@anchor{gnat_rm/the_gnat_library id103}@anchor{39f}@anchor{gnat_rm/the_gnat_library gnat-semaphores-g-semaph-ads}@anchor{3a0}
@section @code{GNAT.Semaphores} (@code{g-semaph.ads})
@@ -24286,7 +24357,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{39e}@anchor{gnat_rm/the_gnat_library id104}@anchor{39f}
+@anchor{gnat_rm/the_gnat_library gnat-serial-communications-g-sercom-ads}@anchor{3a1}@anchor{gnat_rm/the_gnat_library id104}@anchor{3a2}
@section @code{GNAT.Serial_Communications} (@code{g-sercom.ads})
@@ -24298,7 +24369,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{3a0}@anchor{gnat_rm/the_gnat_library id105}@anchor{3a1}
+@anchor{gnat_rm/the_gnat_library gnat-sha1-g-sha1-ads}@anchor{3a3}@anchor{gnat_rm/the_gnat_library id105}@anchor{3a4}
@section @code{GNAT.SHA1} (@code{g-sha1.ads})
@@ -24311,7 +24382,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{3a2}@anchor{gnat_rm/the_gnat_library id106}@anchor{3a3}
+@anchor{gnat_rm/the_gnat_library gnat-sha224-g-sha224-ads}@anchor{3a5}@anchor{gnat_rm/the_gnat_library id106}@anchor{3a6}
@section @code{GNAT.SHA224} (@code{g-sha224.ads})
@@ -24324,7 +24395,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{3a4}@anchor{gnat_rm/the_gnat_library id107}@anchor{3a5}
+@anchor{gnat_rm/the_gnat_library gnat-sha256-g-sha256-ads}@anchor{3a7}@anchor{gnat_rm/the_gnat_library id107}@anchor{3a8}
@section @code{GNAT.SHA256} (@code{g-sha256.ads})
@@ -24337,7 +24408,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{3a6}@anchor{gnat_rm/the_gnat_library gnat-sha384-g-sha384-ads}@anchor{3a7}
+@anchor{gnat_rm/the_gnat_library id108}@anchor{3a9}@anchor{gnat_rm/the_gnat_library gnat-sha384-g-sha384-ads}@anchor{3aa}
@section @code{GNAT.SHA384} (@code{g-sha384.ads})
@@ -24350,7 +24421,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{3a8}@anchor{gnat_rm/the_gnat_library gnat-sha512-g-sha512-ads}@anchor{3a9}
+@anchor{gnat_rm/the_gnat_library id109}@anchor{3ab}@anchor{gnat_rm/the_gnat_library gnat-sha512-g-sha512-ads}@anchor{3ac}
@section @code{GNAT.SHA512} (@code{g-sha512.ads})
@@ -24363,7 +24434,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{3aa}@anchor{gnat_rm/the_gnat_library id110}@anchor{3ab}
+@anchor{gnat_rm/the_gnat_library gnat-signals-g-signal-ads}@anchor{3ad}@anchor{gnat_rm/the_gnat_library id110}@anchor{3ae}
@section @code{GNAT.Signals} (@code{g-signal.ads})
@@ -24375,7 +24446,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{3ac}@anchor{gnat_rm/the_gnat_library id111}@anchor{3ad}
+@anchor{gnat_rm/the_gnat_library gnat-sockets-g-socket-ads}@anchor{3af}@anchor{gnat_rm/the_gnat_library id111}@anchor{3b0}
@section @code{GNAT.Sockets} (@code{g-socket.ads})
@@ -24390,7 +24461,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{3ae}@anchor{gnat_rm/the_gnat_library id112}@anchor{3af}
+@anchor{gnat_rm/the_gnat_library gnat-source-info-g-souinf-ads}@anchor{3b1}@anchor{gnat_rm/the_gnat_library id112}@anchor{3b2}
@section @code{GNAT.Source_Info} (@code{g-souinf.ads})
@@ -24404,7 +24475,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{3b0}@anchor{gnat_rm/the_gnat_library id113}@anchor{3b1}
+@anchor{gnat_rm/the_gnat_library gnat-spelling-checker-g-speche-ads}@anchor{3b3}@anchor{gnat_rm/the_gnat_library id113}@anchor{3b4}
@section @code{GNAT.Spelling_Checker} (@code{g-speche.ads})
@@ -24416,7 +24487,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{3b2}@anchor{gnat_rm/the_gnat_library id114}@anchor{3b3}
+@anchor{gnat_rm/the_gnat_library gnat-spelling-checker-generic-g-spchge-ads}@anchor{3b5}@anchor{gnat_rm/the_gnat_library id114}@anchor{3b6}
@section @code{GNAT.Spelling_Checker_Generic} (@code{g-spchge.ads})
@@ -24429,7 +24500,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{3b4}@anchor{gnat_rm/the_gnat_library id115}@anchor{3b5}
+@anchor{gnat_rm/the_gnat_library gnat-spitbol-patterns-g-spipat-ads}@anchor{3b7}@anchor{gnat_rm/the_gnat_library id115}@anchor{3b8}
@section @code{GNAT.Spitbol.Patterns} (@code{g-spipat.ads})
@@ -24445,7 +24516,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{3b6}@anchor{gnat_rm/the_gnat_library gnat-spitbol-g-spitbo-ads}@anchor{3b7}
+@anchor{gnat_rm/the_gnat_library id116}@anchor{3b9}@anchor{gnat_rm/the_gnat_library gnat-spitbol-g-spitbo-ads}@anchor{3ba}
@section @code{GNAT.Spitbol} (@code{g-spitbo.ads})
@@ -24460,7 +24531,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{3b8}@anchor{gnat_rm/the_gnat_library id117}@anchor{3b9}
+@anchor{gnat_rm/the_gnat_library gnat-spitbol-table-boolean-g-sptabo-ads}@anchor{3bb}@anchor{gnat_rm/the_gnat_library id117}@anchor{3bc}
@section @code{GNAT.Spitbol.Table_Boolean} (@code{g-sptabo.ads})
@@ -24475,7 +24546,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{3ba}@anchor{gnat_rm/the_gnat_library id118}@anchor{3bb}
+@anchor{gnat_rm/the_gnat_library gnat-spitbol-table-integer-g-sptain-ads}@anchor{3bd}@anchor{gnat_rm/the_gnat_library id118}@anchor{3be}
@section @code{GNAT.Spitbol.Table_Integer} (@code{g-sptain.ads})
@@ -24492,7 +24563,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{3bc}@anchor{gnat_rm/the_gnat_library gnat-spitbol-table-vstring-g-sptavs-ads}@anchor{3bd}
+@anchor{gnat_rm/the_gnat_library id119}@anchor{3bf}@anchor{gnat_rm/the_gnat_library gnat-spitbol-table-vstring-g-sptavs-ads}@anchor{3c0}
@section @code{GNAT.Spitbol.Table_VString} (@code{g-sptavs.ads})
@@ -24509,7 +24580,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{3be}@anchor{gnat_rm/the_gnat_library gnat-sse-g-sse-ads}@anchor{3bf}
+@anchor{gnat_rm/the_gnat_library id120}@anchor{3c1}@anchor{gnat_rm/the_gnat_library gnat-sse-g-sse-ads}@anchor{3c2}
@section @code{GNAT.SSE} (@code{g-sse.ads})
@@ -24521,7 +24592,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{3c0}@anchor{gnat_rm/the_gnat_library id121}@anchor{3c1}
+@anchor{gnat_rm/the_gnat_library gnat-sse-vector-types-g-ssvety-ads}@anchor{3c3}@anchor{gnat_rm/the_gnat_library id121}@anchor{3c4}
@section @code{GNAT.SSE.Vector_Types} (@code{g-ssvety.ads})
@@ -24530,7 +24601,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{3c2}@anchor{gnat_rm/the_gnat_library id122}@anchor{3c3}
+@anchor{gnat_rm/the_gnat_library gnat-string-hash-g-strhas-ads}@anchor{3c5}@anchor{gnat_rm/the_gnat_library id122}@anchor{3c6}
@section @code{GNAT.String_Hash} (@code{g-strhas.ads})
@@ -24542,7 +24613,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{3c4}@anchor{gnat_rm/the_gnat_library gnat-strings-g-string-ads}@anchor{3c5}
+@anchor{gnat_rm/the_gnat_library id123}@anchor{3c7}@anchor{gnat_rm/the_gnat_library gnat-strings-g-string-ads}@anchor{3c8}
@section @code{GNAT.Strings} (@code{g-string.ads})
@@ -24552,7 +24623,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{3c6}@anchor{gnat_rm/the_gnat_library id124}@anchor{3c7}
+@anchor{gnat_rm/the_gnat_library gnat-string-split-g-strspl-ads}@anchor{3c9}@anchor{gnat_rm/the_gnat_library id124}@anchor{3ca}
@section @code{GNAT.String_Split} (@code{g-strspl.ads})
@@ -24566,7 +24637,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{3c8}@anchor{gnat_rm/the_gnat_library gnat-table-g-table-ads}@anchor{3c9}
+@anchor{gnat_rm/the_gnat_library id125}@anchor{3cb}@anchor{gnat_rm/the_gnat_library gnat-table-g-table-ads}@anchor{3cc}
@section @code{GNAT.Table} (@code{g-table.ads})
@@ -24586,7 +24657,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{3ca}@anchor{gnat_rm/the_gnat_library gnat-task-lock-g-tasloc-ads}@anchor{3cb}
+@anchor{gnat_rm/the_gnat_library id126}@anchor{3cd}@anchor{gnat_rm/the_gnat_library gnat-task-lock-g-tasloc-ads}@anchor{3ce}
@section @code{GNAT.Task_Lock} (@code{g-tasloc.ads})
@@ -24603,7 +24674,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{3cc}@anchor{gnat_rm/the_gnat_library gnat-time-stamp-g-timsta-ads}@anchor{3cd}
+@anchor{gnat_rm/the_gnat_library id127}@anchor{3cf}@anchor{gnat_rm/the_gnat_library gnat-time-stamp-g-timsta-ads}@anchor{3d0}
@section @code{GNAT.Time_Stamp} (@code{g-timsta.ads})
@@ -24618,7 +24689,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{3ce}@anchor{gnat_rm/the_gnat_library id128}@anchor{3cf}
+@anchor{gnat_rm/the_gnat_library gnat-threads-g-thread-ads}@anchor{3d1}@anchor{gnat_rm/the_gnat_library id128}@anchor{3d2}
@section @code{GNAT.Threads} (@code{g-thread.ads})
@@ -24635,7 +24706,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{3d0}@anchor{gnat_rm/the_gnat_library gnat-traceback-g-traceb-ads}@anchor{3d1}
+@anchor{gnat_rm/the_gnat_library id129}@anchor{3d3}@anchor{gnat_rm/the_gnat_library gnat-traceback-g-traceb-ads}@anchor{3d4}
@section @code{GNAT.Traceback} (@code{g-traceb.ads})
@@ -24647,7 +24718,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{3d2}@anchor{gnat_rm/the_gnat_library gnat-traceback-symbolic-g-trasym-ads}@anchor{3d3}
+@anchor{gnat_rm/the_gnat_library id130}@anchor{3d5}@anchor{gnat_rm/the_gnat_library gnat-traceback-symbolic-g-trasym-ads}@anchor{3d6}
@section @code{GNAT.Traceback.Symbolic} (@code{g-trasym.ads})
@@ -24656,7 +24727,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{3d4}@anchor{gnat_rm/the_gnat_library gnat-utf-32-g-table-ads}@anchor{3d5}
+@anchor{gnat_rm/the_gnat_library id131}@anchor{3d7}@anchor{gnat_rm/the_gnat_library gnat-utf-32-g-table-ads}@anchor{3d8}
@section @code{GNAT.UTF_32} (@code{g-table.ads})
@@ -24675,7 +24746,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{3d6}@anchor{gnat_rm/the_gnat_library id132}@anchor{3d7}
+@anchor{gnat_rm/the_gnat_library gnat-wide-spelling-checker-g-u3spch-ads}@anchor{3d9}@anchor{gnat_rm/the_gnat_library id132}@anchor{3da}
@section @code{GNAT.Wide_Spelling_Checker} (@code{g-u3spch.ads})
@@ -24688,7 +24759,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{3d8}@anchor{gnat_rm/the_gnat_library id133}@anchor{3d9}
+@anchor{gnat_rm/the_gnat_library gnat-wide-spelling-checker-g-wispch-ads}@anchor{3db}@anchor{gnat_rm/the_gnat_library id133}@anchor{3dc}
@section @code{GNAT.Wide_Spelling_Checker} (@code{g-wispch.ads})
@@ -24700,7 +24771,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{3da}@anchor{gnat_rm/the_gnat_library gnat-wide-string-split-g-wistsp-ads}@anchor{3db}
+@anchor{gnat_rm/the_gnat_library id134}@anchor{3dd}@anchor{gnat_rm/the_gnat_library gnat-wide-string-split-g-wistsp-ads}@anchor{3de}
@section @code{GNAT.Wide_String_Split} (@code{g-wistsp.ads})
@@ -24714,7 +24785,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{3dc}@anchor{gnat_rm/the_gnat_library id135}@anchor{3dd}
+@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}
@section @code{GNAT.Wide_Wide_Spelling_Checker} (@code{g-zspche.ads})
@@ -24726,7 +24797,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{3de}@anchor{gnat_rm/the_gnat_library id136}@anchor{3df}
+@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}
@section @code{GNAT.Wide_Wide_String_Split} (@code{g-zistsp.ads})
@@ -24740,7 +24811,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{3e0}@anchor{gnat_rm/the_gnat_library id137}@anchor{3e1}
+@anchor{gnat_rm/the_gnat_library interfaces-c-extensions-i-cexten-ads}@anchor{3e3}@anchor{gnat_rm/the_gnat_library id137}@anchor{3e4}
@section @code{Interfaces.C.Extensions} (@code{i-cexten.ads})
@@ -24751,7 +24822,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{3e2}@anchor{gnat_rm/the_gnat_library interfaces-c-streams-i-cstrea-ads}@anchor{3e3}
+@anchor{gnat_rm/the_gnat_library id138}@anchor{3e5}@anchor{gnat_rm/the_gnat_library interfaces-c-streams-i-cstrea-ads}@anchor{3e6}
@section @code{Interfaces.C.Streams} (@code{i-cstrea.ads})
@@ -24764,7 +24835,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{3e4}@anchor{gnat_rm/the_gnat_library id139}@anchor{3e5}
+@anchor{gnat_rm/the_gnat_library interfaces-packed-decimal-i-pacdec-ads}@anchor{3e7}@anchor{gnat_rm/the_gnat_library id139}@anchor{3e8}
@section @code{Interfaces.Packed_Decimal} (@code{i-pacdec.ads})
@@ -24779,7 +24850,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{3e6}@anchor{gnat_rm/the_gnat_library id140}@anchor{3e7}
+@anchor{gnat_rm/the_gnat_library interfaces-vxworks-i-vxwork-ads}@anchor{3e9}@anchor{gnat_rm/the_gnat_library id140}@anchor{3ea}
@section @code{Interfaces.VxWorks} (@code{i-vxwork.ads})
@@ -24795,7 +24866,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{3e8}@anchor{gnat_rm/the_gnat_library id141}@anchor{3e9}
+@anchor{gnat_rm/the_gnat_library interfaces-vxworks-int-connection-i-vxinco-ads}@anchor{3eb}@anchor{gnat_rm/the_gnat_library id141}@anchor{3ec}
@section @code{Interfaces.VxWorks.Int_Connection} (@code{i-vxinco.ads})
@@ -24811,7 +24882,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{3ea}@anchor{gnat_rm/the_gnat_library id142}@anchor{3eb}
+@anchor{gnat_rm/the_gnat_library interfaces-vxworks-io-i-vxwoio-ads}@anchor{3ed}@anchor{gnat_rm/the_gnat_library id142}@anchor{3ee}
@section @code{Interfaces.VxWorks.IO} (@code{i-vxwoio.ads})
@@ -24834,7 +24905,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{3ec}@anchor{gnat_rm/the_gnat_library id143}@anchor{3ed}
+@anchor{gnat_rm/the_gnat_library system-address-image-s-addima-ads}@anchor{3ef}@anchor{gnat_rm/the_gnat_library id143}@anchor{3f0}
@section @code{System.Address_Image} (@code{s-addima.ads})
@@ -24850,7 +24921,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{3ee}@anchor{gnat_rm/the_gnat_library system-assertions-s-assert-ads}@anchor{3ef}
+@anchor{gnat_rm/the_gnat_library id144}@anchor{3f1}@anchor{gnat_rm/the_gnat_library system-assertions-s-assert-ads}@anchor{3f2}
@section @code{System.Assertions} (@code{s-assert.ads})
@@ -24866,7 +24937,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{3f0}@anchor{gnat_rm/the_gnat_library system-atomic-counters-s-atocou-ads}@anchor{3f1}
+@anchor{gnat_rm/the_gnat_library id145}@anchor{3f3}@anchor{gnat_rm/the_gnat_library system-atomic-counters-s-atocou-ads}@anchor{3f4}
@section @code{System.Atomic_Counters} (@code{s-atocou.ads})
@@ -24880,7 +24951,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{3f2}@anchor{gnat_rm/the_gnat_library id146}@anchor{3f3}
+@anchor{gnat_rm/the_gnat_library system-memory-s-memory-ads}@anchor{3f5}@anchor{gnat_rm/the_gnat_library id146}@anchor{3f6}
@section @code{System.Memory} (@code{s-memory.ads})
@@ -24898,7 +24969,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{3f4}@anchor{gnat_rm/the_gnat_library system-multiprocessors-s-multip-ads}@anchor{3f5}
+@anchor{gnat_rm/the_gnat_library id147}@anchor{3f7}@anchor{gnat_rm/the_gnat_library system-multiprocessors-s-multip-ads}@anchor{3f8}
@section @code{System.Multiprocessors} (@code{s-multip.ads})
@@ -24911,7 +24982,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{3f6}@anchor{gnat_rm/the_gnat_library id148}@anchor{3f7}
+@anchor{gnat_rm/the_gnat_library system-multiprocessors-dispatching-domains-s-mudido-ads}@anchor{3f9}@anchor{gnat_rm/the_gnat_library id148}@anchor{3fa}
@section @code{System.Multiprocessors.Dispatching_Domains} (@code{s-mudido.ads})
@@ -24924,7 +24995,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{3f8}@anchor{gnat_rm/the_gnat_library system-partition-interface-s-parint-ads}@anchor{3f9}
+@anchor{gnat_rm/the_gnat_library id149}@anchor{3fb}@anchor{gnat_rm/the_gnat_library system-partition-interface-s-parint-ads}@anchor{3fc}
@section @code{System.Partition_Interface} (@code{s-parint.ads})
@@ -24937,7 +25008,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{3fa}@anchor{gnat_rm/the_gnat_library system-pool-global-s-pooglo-ads}@anchor{3fb}
+@anchor{gnat_rm/the_gnat_library id150}@anchor{3fd}@anchor{gnat_rm/the_gnat_library system-pool-global-s-pooglo-ads}@anchor{3fe}
@section @code{System.Pool_Global} (@code{s-pooglo.ads})
@@ -24954,7 +25025,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{3fc}@anchor{gnat_rm/the_gnat_library id151}@anchor{3fd}
+@anchor{gnat_rm/the_gnat_library system-pool-local-s-pooloc-ads}@anchor{3ff}@anchor{gnat_rm/the_gnat_library id151}@anchor{400}
@section @code{System.Pool_Local} (@code{s-pooloc.ads})
@@ -24971,7 +25042,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{3fe}@anchor{gnat_rm/the_gnat_library system-restrictions-s-restri-ads}@anchor{3ff}
+@anchor{gnat_rm/the_gnat_library id152}@anchor{401}@anchor{gnat_rm/the_gnat_library system-restrictions-s-restri-ads}@anchor{402}
@section @code{System.Restrictions} (@code{s-restri.ads})
@@ -24987,7 +25058,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{400}@anchor{gnat_rm/the_gnat_library id153}@anchor{401}
+@anchor{gnat_rm/the_gnat_library system-rident-s-rident-ads}@anchor{403}@anchor{gnat_rm/the_gnat_library id153}@anchor{404}
@section @code{System.Rident} (@code{s-rident.ads})
@@ -25003,7 +25074,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{402}@anchor{gnat_rm/the_gnat_library system-strings-stream-ops-s-ststop-ads}@anchor{403}
+@anchor{gnat_rm/the_gnat_library id154}@anchor{405}@anchor{gnat_rm/the_gnat_library system-strings-stream-ops-s-ststop-ads}@anchor{406}
@section @code{System.Strings.Stream_Ops} (@code{s-ststop.ads})
@@ -25019,7 +25090,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{404}@anchor{gnat_rm/the_gnat_library id155}@anchor{405}
+@anchor{gnat_rm/the_gnat_library system-unsigned-types-s-unstyp-ads}@anchor{407}@anchor{gnat_rm/the_gnat_library id155}@anchor{408}
@section @code{System.Unsigned_Types} (@code{s-unstyp.ads})
@@ -25032,7 +25103,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{406}@anchor{gnat_rm/the_gnat_library id156}@anchor{407}
+@anchor{gnat_rm/the_gnat_library system-wch-cnv-s-wchcnv-ads}@anchor{409}@anchor{gnat_rm/the_gnat_library id156}@anchor{40a}
@section @code{System.Wch_Cnv} (@code{s-wchcnv.ads})
@@ -25053,7 +25124,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{408}@anchor{gnat_rm/the_gnat_library system-wch-con-s-wchcon-ads}@anchor{409}
+@anchor{gnat_rm/the_gnat_library id157}@anchor{40b}@anchor{gnat_rm/the_gnat_library system-wch-con-s-wchcon-ads}@anchor{40c}
@section @code{System.Wch_Con} (@code{s-wchcon.ads})
@@ -25065,7 +25136,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{40a}@anchor{gnat_rm/interfacing_to_other_languages id1}@anchor{40b}
+@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}
@chapter Interfacing to Other Languages
@@ -25083,7 +25154,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{40c}@anchor{gnat_rm/interfacing_to_other_languages id2}@anchor{40d}
+@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-c}@anchor{40f}@anchor{gnat_rm/interfacing_to_other_languages id2}@anchor{410}
@section Interfacing to C
@@ -25223,7 +25294,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{40e}@anchor{gnat_rm/interfacing_to_other_languages id3}@anchor{47}
+@anchor{gnat_rm/interfacing_to_other_languages id4}@anchor{411}@anchor{gnat_rm/interfacing_to_other_languages id3}@anchor{47}
@section Interfacing to C++
@@ -25280,7 +25351,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{40f}@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-cobol}@anchor{410}
+@anchor{gnat_rm/interfacing_to_other_languages id5}@anchor{412}@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-cobol}@anchor{413}
@section Interfacing to COBOL
@@ -25288,7 +25359,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{411}@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-fortran}@anchor{412}
+@anchor{gnat_rm/interfacing_to_other_languages id6}@anchor{414}@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-fortran}@anchor{415}
@section Interfacing to Fortran
@@ -25298,7 +25369,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{413}@anchor{gnat_rm/interfacing_to_other_languages id7}@anchor{414}
+@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}
@section Interfacing to non-GNAT Ada code
@@ -25322,7 +25393,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{415}@anchor{gnat_rm/specialized_needs_annexes id1}@anchor{416}
+@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}
@chapter Specialized Needs Annexes
@@ -25363,7 +25434,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{417}@anchor{gnat_rm/implementation_of_specific_ada_features id1}@anchor{418}
+@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}
@chapter Implementation of Specific Ada Features
@@ -25381,7 +25452,7 @@ facilities.
@end menu
@node Machine Code Insertions,GNAT Implementation of Tasking,,Implementation of Specific Ada Features
-@anchor{gnat_rm/implementation_of_specific_ada_features machine-code-insertions}@anchor{169}@anchor{gnat_rm/implementation_of_specific_ada_features id2}@anchor{419}
+@anchor{gnat_rm/implementation_of_specific_ada_features machine-code-insertions}@anchor{169}@anchor{gnat_rm/implementation_of_specific_ada_features id2}@anchor{41c}
@section Machine Code Insertions
@@ -25549,7 +25620,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{41a}@anchor{gnat_rm/implementation_of_specific_ada_features gnat-implementation-of-tasking}@anchor{41b}
+@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}
@section GNAT Implementation of Tasking
@@ -25565,7 +25636,7 @@ to compliance with the Real-Time Systems Annex.
@end menu
@node Mapping Ada Tasks onto the Underlying Kernel Threads,Ensuring Compliance with the Real-Time Annex,,GNAT Implementation of Tasking
-@anchor{gnat_rm/implementation_of_specific_ada_features mapping-ada-tasks-onto-the-underlying-kernel-threads}@anchor{41c}@anchor{gnat_rm/implementation_of_specific_ada_features id4}@anchor{41d}
+@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}
@subsection Mapping Ada Tasks onto the Underlying Kernel Threads
@@ -25634,7 +25705,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{41e}@anchor{gnat_rm/implementation_of_specific_ada_features ensuring-compliance-with-the-real-time-annex}@anchor{41f}
+@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}
@subsection Ensuring Compliance with the Real-Time Annex
@@ -25685,7 +25756,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{420}
+@anchor{gnat_rm/implementation_of_specific_ada_features support-for-locking-policies}@anchor{423}
@subsection Support for Locking Policies
@@ -25719,7 +25790,7 @@ then ceiling locking is used.
Otherwise, the @code{Ceiling_Locking} policy is ignored.
@node GNAT Implementation of Shared Passive Packages,Code Generation for Array Aggregates,GNAT Implementation of Tasking,Implementation of Specific Ada Features
-@anchor{gnat_rm/implementation_of_specific_ada_features id6}@anchor{421}@anchor{gnat_rm/implementation_of_specific_ada_features gnat-implementation-of-shared-passive-packages}@anchor{422}
+@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}
@section GNAT Implementation of Shared Passive Packages
@@ -25817,7 +25888,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{423}@anchor{gnat_rm/implementation_of_specific_ada_features id7}@anchor{424}
+@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}
@section Code Generation for Array Aggregates
@@ -25848,7 +25919,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{425}@anchor{gnat_rm/implementation_of_specific_ada_features id8}@anchor{426}
+@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}
@subsection Static constant aggregates with static bounds
@@ -25895,7 +25966,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{427}@anchor{gnat_rm/implementation_of_specific_ada_features id9}@anchor{428}
+@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}
@subsection Constant aggregates with unconstrained nominal types
@@ -25910,7 +25981,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{429}@anchor{gnat_rm/implementation_of_specific_ada_features aggregates-with-static-bounds}@anchor{42a}
+@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}
@subsection Aggregates with static bounds
@@ -25938,7 +26009,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{42b}@anchor{gnat_rm/implementation_of_specific_ada_features aggregates-with-nonstatic-bounds}@anchor{42c}
+@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}
@subsection Aggregates with nonstatic bounds
@@ -25949,7 +26020,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{42d}@anchor{gnat_rm/implementation_of_specific_ada_features aggregates-in-assignment-statements}@anchor{42e}
+@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}
@subsection Aggregates in assignment statements
@@ -25991,7 +26062,7 @@ a temporary (created either by the front-end or the code generator) and then
that temporary will be copied onto the target.
@node The Size of Discriminated Records with Default Discriminants,Strict Conformance to the Ada Reference Manual,Code Generation for Array Aggregates,Implementation of Specific Ada Features
-@anchor{gnat_rm/implementation_of_specific_ada_features id13}@anchor{42f}@anchor{gnat_rm/implementation_of_specific_ada_features the-size-of-discriminated-records-with-default-discriminants}@anchor{430}
+@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}
@section The Size of Discriminated Records with Default Discriminants
@@ -26071,7 +26142,7 @@ say) must be consistent, so it is imperative that the object, once created,
remain invariant.
@node Strict Conformance to the Ada Reference Manual,,The Size of Discriminated Records with Default Discriminants,Implementation of Specific Ada Features
-@anchor{gnat_rm/implementation_of_specific_ada_features strict-conformance-to-the-ada-reference-manual}@anchor{431}@anchor{gnat_rm/implementation_of_specific_ada_features id14}@anchor{432}
+@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}
@section Strict Conformance to the Ada Reference Manual
@@ -26098,7 +26169,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{433}@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{434}
+@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}
@chapter Implementation of Ada 2012 Features
@@ -28264,7 +28335,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{435}@anchor{gnat_rm/obsolescent_features doc}@anchor{436}@anchor{gnat_rm/obsolescent_features obsolescent-features}@anchor{15}
+@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}
@chapter Obsolescent Features
@@ -28283,7 +28354,7 @@ compatibility purposes.
@end menu
@node pragma No_Run_Time,pragma Ravenscar,,Obsolescent Features
-@anchor{gnat_rm/obsolescent_features id2}@anchor{437}@anchor{gnat_rm/obsolescent_features pragma-no-run-time}@anchor{438}
+@anchor{gnat_rm/obsolescent_features id2}@anchor{43a}@anchor{gnat_rm/obsolescent_features pragma-no-run-time}@anchor{43b}
@section pragma No_Run_Time
@@ -28296,7 +28367,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{439}@anchor{gnat_rm/obsolescent_features pragma-ravenscar}@anchor{43a}
+@anchor{gnat_rm/obsolescent_features id3}@anchor{43c}@anchor{gnat_rm/obsolescent_features pragma-ravenscar}@anchor{43d}
@section pragma Ravenscar
@@ -28305,7 +28376,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{43b}@anchor{gnat_rm/obsolescent_features id4}@anchor{43c}
+@anchor{gnat_rm/obsolescent_features pragma-restricted-run-time}@anchor{43e}@anchor{gnat_rm/obsolescent_features id4}@anchor{43f}
@section pragma Restricted_Run_Time
@@ -28315,7 +28386,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{43d}@anchor{gnat_rm/obsolescent_features id5}@anchor{43e}
+@anchor{gnat_rm/obsolescent_features pragma-task-info}@anchor{440}@anchor{gnat_rm/obsolescent_features id5}@anchor{441}
@section pragma Task_Info
@@ -28341,7 +28412,7 @@ in the spec of package System.Task_Info in the runtime
library.
@node package System Task_Info s-tasinf ads,,pragma Task_Info,Obsolescent Features
-@anchor{gnat_rm/obsolescent_features package-system-task-info}@anchor{43f}@anchor{gnat_rm/obsolescent_features package-system-task-info-s-tasinf-ads}@anchor{440}
+@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}
@section package System.Task_Info (@code{s-tasinf.ads})
@@ -28351,7 +28422,7 @@ to support the @code{Task_Info} pragma. The predefined Ada package
standard replacement for GNAT's @code{Task_Info} functionality.
@node Compatibility and Porting Guide,GNU Free Documentation License,Obsolescent Features,Top
-@anchor{gnat_rm/compatibility_and_porting_guide compatibility-and-porting-guide}@anchor{16}@anchor{gnat_rm/compatibility_and_porting_guide doc}@anchor{441}@anchor{gnat_rm/compatibility_and_porting_guide id1}@anchor{442}
+@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}
@chapter Compatibility and Porting Guide
@@ -28373,7 +28444,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{443}@anchor{gnat_rm/compatibility_and_porting_guide writing-portable-fixed-point-declarations}@anchor{444}
+@anchor{gnat_rm/compatibility_and_porting_guide id2}@anchor{446}@anchor{gnat_rm/compatibility_and_porting_guide writing-portable-fixed-point-declarations}@anchor{447}
@section Writing Portable Fixed-Point Declarations
@@ -28495,7 +28566,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{445}@anchor{gnat_rm/compatibility_and_porting_guide id3}@anchor{446}
+@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-ada-83}@anchor{448}@anchor{gnat_rm/compatibility_and_porting_guide id3}@anchor{449}
@section Compatibility with Ada 83
@@ -28523,7 +28594,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{447}@anchor{gnat_rm/compatibility_and_porting_guide legal-ada-83-programs-that-are-illegal-in-ada-95}@anchor{448}
+@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}
@subsection Legal Ada 83 programs that are illegal in Ada 95
@@ -28623,7 +28694,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{449}@anchor{gnat_rm/compatibility_and_porting_guide id5}@anchor{44a}
+@anchor{gnat_rm/compatibility_and_porting_guide more-deterministic-semantics}@anchor{44c}@anchor{gnat_rm/compatibility_and_porting_guide id5}@anchor{44d}
@subsection More deterministic semantics
@@ -28651,7 +28722,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{44b}@anchor{gnat_rm/compatibility_and_porting_guide changed-semantics}@anchor{44c}
+@anchor{gnat_rm/compatibility_and_porting_guide id6}@anchor{44e}@anchor{gnat_rm/compatibility_and_porting_guide changed-semantics}@anchor{44f}
@subsection Changed semantics
@@ -28693,7 +28764,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{44d}@anchor{gnat_rm/compatibility_and_porting_guide id7}@anchor{44e}
+@anchor{gnat_rm/compatibility_and_porting_guide other-language-compatibility-issues}@anchor{450}@anchor{gnat_rm/compatibility_and_porting_guide id7}@anchor{451}
@subsection Other language compatibility issues
@@ -28726,7 +28797,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{44f}@anchor{gnat_rm/compatibility_and_porting_guide id8}@anchor{450}
+@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}
@section Compatibility between Ada 95 and Ada 2005
@@ -28798,7 +28869,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{451}@anchor{gnat_rm/compatibility_and_porting_guide id9}@anchor{452}
+@anchor{gnat_rm/compatibility_and_porting_guide implementation-dependent-characteristics}@anchor{454}@anchor{gnat_rm/compatibility_and_porting_guide id9}@anchor{455}
@section Implementation-dependent characteristics
@@ -28821,7 +28892,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{453}@anchor{gnat_rm/compatibility_and_porting_guide id10}@anchor{454}
+@anchor{gnat_rm/compatibility_and_porting_guide implementation-defined-pragmas}@anchor{456}@anchor{gnat_rm/compatibility_and_porting_guide id10}@anchor{457}
@subsection Implementation-defined pragmas
@@ -28843,7 +28914,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{455}@anchor{gnat_rm/compatibility_and_porting_guide implementation-defined-attributes}@anchor{456}
+@anchor{gnat_rm/compatibility_and_porting_guide id11}@anchor{458}@anchor{gnat_rm/compatibility_and_porting_guide implementation-defined-attributes}@anchor{459}
@subsection Implementation-defined attributes
@@ -28857,7 +28928,7 @@ Ada 83, GNAT supplies the attributes @code{Bit}, @code{Machine_Size} and
@code{Type_Class}.
@node Libraries,Elaboration order,Implementation-defined attributes,Implementation-dependent characteristics
-@anchor{gnat_rm/compatibility_and_porting_guide libraries}@anchor{457}@anchor{gnat_rm/compatibility_and_porting_guide id12}@anchor{458}
+@anchor{gnat_rm/compatibility_and_porting_guide libraries}@anchor{45a}@anchor{gnat_rm/compatibility_and_porting_guide id12}@anchor{45b}
@subsection Libraries
@@ -28886,7 +28957,7 @@ be preferable to retrofit the application using modular types.
@end itemize
@node Elaboration order,Target-specific aspects,Libraries,Implementation-dependent characteristics
-@anchor{gnat_rm/compatibility_and_porting_guide elaboration-order}@anchor{459}@anchor{gnat_rm/compatibility_and_porting_guide id13}@anchor{45a}
+@anchor{gnat_rm/compatibility_and_porting_guide elaboration-order}@anchor{45c}@anchor{gnat_rm/compatibility_and_porting_guide id13}@anchor{45d}
@subsection Elaboration order
@@ -28922,7 +28993,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{45b}@anchor{gnat_rm/compatibility_and_porting_guide id14}@anchor{45c}
+@anchor{gnat_rm/compatibility_and_porting_guide target-specific-aspects}@anchor{45e}@anchor{gnat_rm/compatibility_and_porting_guide id14}@anchor{45f}
@subsection Target-specific aspects
@@ -28935,10 +29006,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{45d,,Representation Clauses}.
+GNAT's approach to these issues is described in @ref{460,,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{45e}@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-other-ada-systems}@anchor{45f}
+@anchor{gnat_rm/compatibility_and_porting_guide id15}@anchor{461}@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-other-ada-systems}@anchor{462}
@section Compatibility with Other Ada Systems
@@ -28981,7 +29052,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{45d}@anchor{gnat_rm/compatibility_and_porting_guide id16}@anchor{460}
+@anchor{gnat_rm/compatibility_and_porting_guide representation-clauses}@anchor{460}@anchor{gnat_rm/compatibility_and_porting_guide id16}@anchor{463}
@section Representation Clauses
@@ -29074,7 +29145,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{461}@anchor{gnat_rm/compatibility_and_porting_guide id17}@anchor{462}
+@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-hp-ada-83}@anchor{464}@anchor{gnat_rm/compatibility_and_porting_guide id17}@anchor{465}
@section Compatibility with HP Ada 83
@@ -29104,7 +29175,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{463}@anchor{share/gnu_free_documentation_license gnu-free-documentation-license}@anchor{464}
+@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}
@chapter GNU Free Documentation License
diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi
index 47618f6..2efa06f 100644
--- a/gcc/ada/gnat_ugn.texi
+++ b/gcc/ada/gnat_ugn.texi
@@ -21,7 +21,7 @@
@copying
@quotation
-GNAT User's Guide for Native Platforms , Sep 29, 2020
+GNAT User's Guide for Native Platforms , Dec 11, 2020
AdaCore
@@ -381,7 +381,7 @@ Performance Considerations
* Optimization Levels::
* Debugging Optimized Code::
* Inlining of Subprograms::
-* Floating_Point_Operations::
+* Floating Point Operations::
* Vectorization of loops::
* Other Optimization Switches::
* Optimization and Strict Aliasing::
@@ -2970,6 +2970,10 @@ 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}.
+By default, configuration pragma files are stored by their absolute paths in
+ALI files. You can use the @code{-gnateb} switch in order to store them by
+their basename instead.
+
If you are using project file, a separate mechanism is provided using
project attributes.
@@ -8968,6 +8972,19 @@ an exception because @code{Self(Obj)} produces an anonymous object which does
not share the memory location of @code{Obj}.
@end table
+@geindex -gnateb (gcc)
+
+
+@table @asis
+
+@item @code{-gnateb}
+
+Store configuration files by their basename in ALI files. This switch is
+used for instance by gprbuild for distributed builds in order to prevent
+issues where machine-specific absolute paths could end up being stored in
+ALI files.
+@end table
+
@geindex -gnatec (gcc)
@@ -11490,7 +11507,7 @@ not included in this check.
@emph{Suppress warnings on redefinition of names in standard.}
-This switch activates warnings for declarations that declare a name that
+This switch disables warnings for declarations that declare a name that
is defined in package Standard.
@end table
@@ -13464,7 +13481,8 @@ but not @code{in} on its own.
All keywords must be in lower case (with the exception of keywords
such as @code{digits} used as attribute names to which this check
-does not apply).
+does not apply). A single error is reported for each line breaking
+this rule even if multiple casing issues exist on a same line.
@end table
@geindex -gnatyl (gcc)
@@ -15918,6 +15936,9 @@ Exclude source files (check object consistency only).
Use the target-independent XDR protocol for stream oriented attributes
instead of the default implementation which is based on direct binary
representations and is therefore target-and endianness-dependent.
+However it does not support 128-bit integer types and the exception
+@code{Ada.IO_Exceptions.Device_Error} is raised if any attempt is made
+at streaming 128-bit integer types with it.
@geindex -Xnnn (gnatbind)
@@ -19631,7 +19652,7 @@ some guidelines on debugging optimized code.
* Optimization Levels::
* Debugging Optimized Code::
* Inlining of Subprograms::
-* Floating_Point_Operations::
+* Floating Point Operations::
* Vectorization of loops::
* Other Optimization Switches::
* Optimization and Strict Aliasing::
@@ -19980,7 +20001,7 @@ Note that if you use @code{-g} you can then use the @code{strip} program
on the resulting executable,
which removes both debugging information and global symbols.
-@node Inlining of Subprograms,Floating_Point_Operations,Debugging Optimized Code,Performance Considerations
+@node Inlining of Subprograms,Floating Point Operations,Debugging Optimized Code,Performance Considerations
@anchor{gnat_ugn/gnat_and_program_execution id32}@anchor{185}@anchor{gnat_ugn/gnat_and_program_execution inlining-of-subprograms}@anchor{100}
@subsubsection Inlining of Subprograms
@@ -20119,9 +20140,9 @@ automatically assume that @code{-O3} is better than @code{-O2}, and
indeed you should use @code{-O3} only if tests show that it actually
improves performance for your program.
-@node Floating_Point_Operations,Vectorization of loops,Inlining of Subprograms,Performance Considerations
+@node Floating Point Operations,Vectorization of loops,Inlining of Subprograms,Performance Considerations
@anchor{gnat_ugn/gnat_and_program_execution floating-point-operations}@anchor{186}@anchor{gnat_ugn/gnat_and_program_execution id33}@anchor{187}
-@subsubsection Floating_Point_Operations
+@subsubsection Floating Point Operations
@geindex Floating-Point Operations
@@ -20167,7 +20188,7 @@ Note that the ABI has the same form for both floating-point models,
so it is permissible to mix units compiled with and without these
switches.
-@node Vectorization of loops,Other Optimization Switches,Floating_Point_Operations,Performance Considerations
+@node Vectorization of loops,Other Optimization Switches,Floating Point Operations,Performance Considerations
@anchor{gnat_ugn/gnat_and_program_execution id34}@anchor{188}@anchor{gnat_ugn/gnat_and_program_execution vectorization-of-loops}@anchor{189}
@subsubsection Vectorization of loops
diff --git a/gcc/ada/impunit.adb b/gcc/ada/impunit.adb
index 2cde430..e7262cd 100644
--- a/gcc/ada/impunit.adb
+++ b/gcc/ada/impunit.adb
@@ -999,7 +999,7 @@ package body Impunit is
for J in Non_Imp_File_Names_12'Range loop
if Name_Buffer (1 .. 8) = Non_Imp_File_Names_12 (J).Fname then
- return Non_Imp_File_Names_95 (J).RMdef
+ return Non_Imp_File_Names_12 (J).RMdef
and then Ada_Version >= Ada_2012;
end if;
end loop;
diff --git a/gcc/ada/inline.adb b/gcc/ada/inline.adb
index b4d56b6..bb4d97c 100644
--- a/gcc/ada/inline.adb
+++ b/gcc/ada/inline.adb
@@ -1945,10 +1945,11 @@ package body Inline is
-------------------
procedure Cannot_Inline
- (Msg : String;
- N : Node_Id;
- Subp : Entity_Id;
- Is_Serious : Boolean := False)
+ (Msg : String;
+ N : Node_Id;
+ Subp : Entity_Id;
+ Is_Serious : Boolean := False;
+ Suppress_Info : Boolean := False)
is
begin
-- In GNATprove mode, inlining is the technical means by which the
@@ -1971,7 +1972,7 @@ package body Inline is
New_Msg (1 .. Len2) := "info: no contextual analysis of";
New_Msg (Len2 + 1 .. Msg'Length + Len2 - Len1) :=
Msg (Msg'First + Len1 .. Msg'Last);
- Cannot_Inline (New_Msg, N, Subp, Is_Serious);
+ Cannot_Inline (New_Msg, N, Subp, Is_Serious, Suppress_Info);
return;
end;
end if;
@@ -1992,14 +1993,14 @@ package body Inline is
then
null;
- -- In GNATprove mode, issue a warning when -gnatd_f is set, and
- -- indicate that the subprogram is not always inlined by setting
- -- flag Is_Inlined_Always to False.
+ -- In GNATprove mode, issue an info message when -gnatd_f is set and
+ -- Suppress_Info is False, and indicate that the subprogram is not
+ -- always inlined by setting flag Is_Inlined_Always to False.
elsif GNATprove_Mode then
Set_Is_Inlined_Always (Subp, False);
- if Debug_Flag_Underscore_F then
+ if Debug_Flag_Underscore_F and not Suppress_Info then
Error_Msg_NE (Msg, N, Subp);
end if;
@@ -2022,14 +2023,14 @@ package body Inline is
Error_Msg_NE (Msg (Msg'First .. Msg'Last - 1), N, Subp);
- -- In GNATprove mode, issue a warning when -gnatd_f is set, and
- -- indicate that the subprogram is not always inlined by setting
- -- flag Is_Inlined_Always to False.
+ -- In GNATprove mode, issue an info message when -gnatd_f is set and
+ -- Suppress_Info is False, and indicate that the subprogram is not
+ -- always inlined by setting flag Is_Inlined_Always to False.
elsif GNATprove_Mode then
Set_Is_Inlined_Always (Subp, False);
- if Debug_Flag_Underscore_F then
+ if Debug_Flag_Underscore_F and not Suppress_Info then
Error_Msg_NE (Msg, N, Subp);
end if;
@@ -2917,7 +2918,24 @@ package body Inline is
-- formal in the inlined code.
if Is_Entity_Name (A) and then Ekind (F) /= E_In_Parameter then
- Set_Last_Assignment (Entity (A), Empty);
+
+ -- In GNATprove mode a protected component acting as an actual
+ -- subprogram parameter will appear as inlined-for-proof. However,
+ -- its E_Component entity is not an assignable object, so the
+ -- assertion in Set_Last_Assignment will fail. We just omit the
+ -- call to Set_Last_Assignment, because GNATprove flags useless
+ -- assignments with its own flow analysis.
+ --
+ -- In GNAT mode such a problem does not occur, because protected
+ -- components are inlined via object renamings whose entity kind
+ -- E_Variable is assignable.
+
+ if Is_Assignable (Entity (A)) then
+ Set_Last_Assignment (Entity (A), Empty);
+ else
+ pragma Assert
+ (GNATprove_Mode and then Is_Protected_Component (Entity (A)));
+ end if;
end if;
-- If the argument may be a controlling argument in a call within
diff --git a/gcc/ada/inline.ads b/gcc/ada/inline.ads
index 51eab9c..6790f15 100644
--- a/gcc/ada/inline.ads
+++ b/gcc/ada/inline.ads
@@ -154,15 +154,17 @@ package Inline is
-- its treatment of the subprogram.
procedure Cannot_Inline
- (Msg : String;
- N : Node_Id;
- Subp : Entity_Id;
- Is_Serious : Boolean := False);
+ (Msg : String;
+ N : Node_Id;
+ Subp : Entity_Id;
+ Is_Serious : Boolean := False;
+ Suppress_Info : Boolean := False);
-- This procedure is called if the node N, an instance of a call to
-- subprogram Subp, cannot be inlined. Msg is the message to be issued,
-- which ends with ? (it does not end with ?p?, this routine takes care of
- -- the need to change ? to ?p?). The behavior of this routine depends on
- -- the value of Back_End_Inlining:
+ -- the need to change ? to ?p?). Suppress_Info is set to True to prevent
+ -- issuing an info message in GNATprove mode. The behavior of this routine
+ -- depends on the value of Back_End_Inlining:
--
-- * If Back_End_Inlining is not set (ie. legacy frontend inlining model)
-- then if Subp has a pragma Always_Inlined, then an error message is
diff --git a/gcc/ada/lib-load.adb b/gcc/ada/lib-load.adb
index 2598285..f8d632a 100644
--- a/gcc/ada/lib-load.adb
+++ b/gcc/ada/lib-load.adb
@@ -551,7 +551,7 @@ package body Lib.Load is
-- Note: Unit_Name (Main_Unit) is not set if we are parsing gnat.adc.
if Present (Error_Node)
- and then Unit_Name (Main_Unit) /= No_Unit_Name
+ and then Present (Unit_Name (Main_Unit))
then
-- It seems like In_Extended_Main_Source_Unit (Error_Node) would
-- do the trick here, but that's wrong, it is much too early to
@@ -646,7 +646,7 @@ package body Lib.Load is
else
Error_Msg_File_1 := Fname;
Error_Msg_Unit_1 := Uname_Actual;
- Error_Msg ("File{ does not contain unit$", Load_Msg_Sloc);
+ Error_Msg ("file{ does not contain unit$", Load_Msg_Sloc);
end if;
Write_Dependency_Chain;
diff --git a/gcc/ada/lib-writ.adb b/gcc/ada/lib-writ.adb
index 6a63b8f..16449e8 100644
--- a/gcc/ada/lib-writ.adb
+++ b/gcc/ada/lib-writ.adb
@@ -837,7 +837,7 @@ package body Lib.Writ is
-- preprocessing data and definition files, there is no Unit_Name,
-- check for that first.
- if Unit_Name (J) /= No_Unit_Name
+ if Present (Unit_Name (J))
and then (With_Flags (J) or else Unit_Name (J) = Pname)
then
Num_Withs := Num_Withs + 1;
@@ -1125,9 +1125,7 @@ package body Lib.Writ is
if Nkind (U) = N_Subprogram_Body
and then Present (Corresponding_Spec (U))
- and then
- Ekind (Corresponding_Spec (U)) in E_Generic_Procedure
- | E_Generic_Function
+ and then Is_Generic_Subprogram (Corresponding_Spec (U))
then
null;
@@ -1478,11 +1476,8 @@ package body Lib.Writ is
-- Normal case of a unit entry with a source index
if Sind > No_Source_File then
- -- We never want directory information in ALI files
- -- ???But back out this change temporarily until
- -- gprbuild is fixed.
- if False then
+ if Config_Files_Store_Basename then
Fname := Strip_Directory (File_Name (Sind));
else
Fname := File_Name (Sind);
@@ -1729,7 +1724,7 @@ package body Lib.Writ is
-- scope
- Write_Info_Name (Scope (IS_Id));
+ Write_Info_Name (IS_Scope (IS_Id));
Write_Info_Char (' ');
-- line
diff --git a/gcc/ada/lib-xref.adb b/gcc/ada/lib-xref.adb
index 64b9683..0869906 100644
--- a/gcc/ada/lib-xref.adb
+++ b/gcc/ada/lib-xref.adb
@@ -819,7 +819,7 @@ package body Lib.Xref is
end if;
-- For the left hand of an assignment case, we do nothing here.
- -- The processing for Analyze_Assignment_Statement will set the
+ -- The processing for Analyze_Assignment will set the
-- Referenced_As_LHS flag.
else
diff --git a/gcc/ada/lib.adb b/gcc/ada/lib.adb
index 49a352a..d298267 100644
--- a/gcc/ada/lib.adb
+++ b/gcc/ada/lib.adb
@@ -275,7 +275,7 @@ package body Lib is
begin
-- First unregister the old name, if any
- if Old_N /= No_Unit_Name and then Unit_Names.Get (Old_N) = U then
+ if Present (Old_N) and then Unit_Names.Get (Old_N) = U then
Unit_Names.Set (Old_N, No_Unit);
end if;
diff --git a/gcc/ada/libgnarl/s-osinte__solaris.ads b/gcc/ada/libgnarl/s-osinte__solaris.ads
index b3faa10..b9d6b88 100644
--- a/gcc/ada/libgnarl/s-osinte__solaris.ads
+++ b/gcc/ada/libgnarl/s-osinte__solaris.ads
@@ -45,9 +45,6 @@ with Ada.Unchecked_Conversion;
package System.OS_Interface is
pragma Preelaborate;
- pragma Linker_Options ("-lposix4");
- pragma Linker_Options ("-lthread");
-
subtype int is Interfaces.C.int;
subtype short is Interfaces.C.short;
subtype long is Interfaces.C.long;
diff --git a/gcc/ada/libgnarl/s-tasren.adb b/gcc/ada/libgnarl/s-tasren.adb
index 567b955..b7ee865 100644
--- a/gcc/ada/libgnarl/s-tasren.adb
+++ b/gcc/ada/libgnarl/s-tasren.adb
@@ -473,19 +473,7 @@ package body System.Tasking.Rendezvous is
pragma Debug
(Debug.Trace (Self_Id, "Local_Complete_Rendezvous", 'R'));
- if Ex = Ada.Exceptions.Null_Id then
-
- -- The call came from normal end-of-rendezvous, so abort is not yet
- -- deferred.
-
- Initialization.Defer_Abort (Self_Id);
-
- elsif ZCX_By_Default then
-
- -- With ZCX, aborts are not automatically deferred in handlers
-
- Initialization.Defer_Abort (Self_Id);
- end if;
+ Initialization.Defer_Abort (Self_Id);
-- We need to clean up any accepts which Self may have been serving when
-- it was aborted.
diff --git a/gcc/ada/libgnarl/s-tassta.adb b/gcc/ada/libgnarl/s-tassta.adb
index aada734..900b3b7 100644
--- a/gcc/ada/libgnarl/s-tassta.adb
+++ b/gcc/ada/libgnarl/s-tassta.adb
@@ -1096,11 +1096,10 @@ package body System.Tasking.Stages is
-- stack analysis.
Big_Overflow_Guard : constant := 64 * 1024 + 8 * 1024;
- Small_Stack_Limit : constant := 64 * 1024;
- -- ??? These three values are experimental, and seem to work on
- -- most platforms. They still need to be analyzed further. They
- -- also need documentation, what are they and why does the logic
- -- differ depending on whether the stack is large or small???
+ -- These two values are experimental, and seem to work on most
+ -- platforms. They still need to be analyzed further. They also
+ -- need documentation, what are they and why does the logic differ
+ -- depending on whether the stack is large or small???
Pattern_Size : Natural :=
Natural (Self_ID.Common.
@@ -1123,7 +1122,7 @@ package body System.Tasking.Stages is
-- Adjustments for inner frames
Pattern_Size := Pattern_Size -
- (if Pattern_Size < Small_Stack_Limit
+ (if Pattern_Size < Big_Overflow_Guard
then Small_Overflow_Guard
else Big_Overflow_Guard);
else
diff --git a/gcc/ada/libgnarl/s-tpobop.adb b/gcc/ada/libgnarl/s-tpobop.adb
index 5537c1a..b123c19 100644
--- a/gcc/ada/libgnarl/s-tpobop.adb
+++ b/gcc/ada/libgnarl/s-tpobop.adb
@@ -246,17 +246,7 @@ package body System.Tasking.Protected_Objects.Operations is
Entry_Call.Exception_To_Raise := Ex;
if Ex /= Ada.Exceptions.Null_Id then
-
- -- An exception was raised and abort was deferred, so adjust
- -- before propagating, otherwise the task will stay with deferral
- -- enabled for its remaining life.
-
Self_Id := STPO.Self;
-
- if not ZCX_By_Default then
- Initialization.Undefer_Abort_Nestable (Self_Id);
- end if;
-
Transfer_Occurrence
(Entry_Call.Self.Common.Compiler_Data.Current_Excep'Access,
Self_Id.Common.Compiler_Data.Current_Excep);
diff --git a/gcc/ada/libgnarl/s-tporft.adb b/gcc/ada/libgnarl/s-tporft.adb
index 9d99eac..634eae6 100644
--- a/gcc/ada/libgnarl/s-tporft.adb
+++ b/gcc/ada/libgnarl/s-tporft.adb
@@ -53,6 +53,7 @@ begin
Local_ATCB.Common.LL.Thread := Thread;
Local_ATCB.Common.Current_Priority := System.Priority'First;
+ Local_ATCB.Common.Global_Task_Lock_Nesting := 0;
Specific.Set (Local_ATCB'Unchecked_Access);
-- It is now safe to use an allocator
diff --git a/gcc/ada/libgnat/a-cbdlli.adb b/gcc/ada/libgnat/a-cbdlli.adb
index a0c356d..948b706 100644
--- a/gcc/ada/libgnat/a-cbdlli.adb
+++ b/gcc/ada/libgnat/a-cbdlli.adb
@@ -199,23 +199,19 @@ is
procedure Append
(Container : in out List;
New_Item : Element_Type;
- Count : Count_Type := 1)
+ Count : Count_Type)
is
begin
Insert (Container, No_Element, New_Item, Count);
end Append;
- ---------------
- -- Append_One --
- ---------------
-
- procedure Append_One
+ procedure Append
(Container : in out List;
New_Item : Element_Type)
is
begin
Insert (Container, No_Element, New_Item, 1);
- end Append_One;
+ end Append;
------------
-- Assign --
diff --git a/gcc/ada/libgnat/a-cbdlli.ads b/gcc/ada/libgnat/a-cbdlli.ads
index 183c01e..4574aa6 100644
--- a/gcc/ada/libgnat/a-cbdlli.ads
+++ b/gcc/ada/libgnat/a-cbdlli.ads
@@ -57,7 +57,7 @@ is
Default_Iterator => Iterate,
Iterator_Element => Element_Type,
Aggregate => (Empty => Empty,
- Add_Unnamed => Append_One);
+ Add_Unnamed => Append);
pragma Preelaborable_Initialization (List);
type Cursor is private;
@@ -151,9 +151,9 @@ is
procedure Append
(Container : in out List;
New_Item : Element_Type;
- Count : Count_Type := 1);
+ Count : Count_Type);
- procedure Append_One
+ procedure Append
(Container : in out List;
New_Item : Element_Type);
diff --git a/gcc/ada/libgnat/a-cbhase.adb b/gcc/ada/libgnat/a-cbhase.adb
index 293d722..75b9667 100644
--- a/gcc/ada/libgnat/a-cbhase.adb
+++ b/gcc/ada/libgnat/a-cbhase.adb
@@ -1783,7 +1783,7 @@ is
-- Read --
----------
- procedure Read
+ procedure Read
(Stream : not null access Root_Stream_Type'Class;
Item : out Reference_Type)
is
diff --git a/gcc/ada/libgnat/a-cbmutr.ads b/gcc/ada/libgnat/a-cbmutr.ads
index a9fb55a..d9a4a9a 100644
--- a/gcc/ada/libgnat/a-cbmutr.ads
+++ b/gcc/ada/libgnat/a-cbmutr.ads
@@ -333,7 +333,7 @@ private
Node : Count_Type'Base := No_Node;
end record;
- procedure Read
+ procedure Read
(Stream : not null access Root_Stream_Type'Class;
Position : out Cursor);
for Cursor'Read use Read;
diff --git a/gcc/ada/libgnat/a-cborse.adb b/gcc/ada/libgnat/a-cborse.adb
index e4a2de8..41f0859 100644
--- a/gcc/ada/libgnat/a-cborse.adb
+++ b/gcc/ada/libgnat/a-cborse.adb
@@ -908,7 +908,7 @@ is
-- Read --
----------
- procedure Read
+ procedure Read
(Stream : not null access Root_Stream_Type'Class;
Item : out Reference_Type)
is
diff --git a/gcc/ada/libgnat/a-cbsyqu.ads b/gcc/ada/libgnat/a-cbsyqu.ads
index 225db21..4037d84 100644
--- a/gcc/ada/libgnat/a-cbsyqu.ads
+++ b/gcc/ada/libgnat/a-cbsyqu.ads
@@ -71,6 +71,14 @@ is
-- Need proper heap data structure here ???
+ -- We suppress warnings here, which might otherwise be triggered
+ -- by the box initialization of the Elements array below. This
+ -- initialization is needed to preserve constraints, such as
+ -- discriminant values, that the actual for Element_Type might
+ -- carry.
+
+ pragma Warnings (Off);
+
type Element_Array is
array (Count_Type range <>) of Queue_Interfaces.Element_Type;
@@ -78,7 +86,7 @@ is
First, Last : Count_Type := 0;
Length : Count_Type := 0;
Max_Length : Count_Type := 0;
- Elements : Element_Array (1 .. Capacity);
+ Elements : Element_Array (1 .. Capacity) := (others => <>);
end record;
end Implementation;
diff --git a/gcc/ada/libgnat/a-cdlili.adb b/gcc/ada/libgnat/a-cdlili.adb
index f07190e..08c29f2 100644
--- a/gcc/ada/libgnat/a-cdlili.adb
+++ b/gcc/ada/libgnat/a-cdlili.adb
@@ -158,23 +158,19 @@ is
procedure Append
(Container : in out List;
New_Item : Element_Type;
- Count : Count_Type := 1)
+ Count : Count_Type)
is
begin
Insert (Container, No_Element, New_Item, Count);
end Append;
- ---------------
- -- Append_One --
- ---------------
-
- procedure Append_One
+ procedure Append
(Container : in out List;
New_Item : Element_Type)
is
begin
Insert (Container, No_Element, New_Item, 1);
- end Append_One;
+ end Append;
------------
-- Assign --
diff --git a/gcc/ada/libgnat/a-cdlili.ads b/gcc/ada/libgnat/a-cdlili.ads
index 35c4352..53de78b 100644
--- a/gcc/ada/libgnat/a-cdlili.ads
+++ b/gcc/ada/libgnat/a-cdlili.ads
@@ -58,7 +58,7 @@ is
Default_Iterator => Iterate,
Iterator_Element => Element_Type,
Aggregate => (Empty => Empty,
- Add_Unnamed => Append_One);
+ Add_Unnamed => Append);
pragma Preelaborable_Initialization (List);
@@ -154,9 +154,9 @@ is
procedure Append
(Container : in out List;
New_Item : Element_Type;
- Count : Count_Type := 1);
+ Count : Count_Type);
- procedure Append_One
+ procedure Append
(Container : in out List;
New_Item : Element_Type);
diff --git a/gcc/ada/libgnat/a-cidlli.adb b/gcc/ada/libgnat/a-cidlli.adb
index a62338f..79df5a9 100644
--- a/gcc/ada/libgnat/a-cidlli.adb
+++ b/gcc/ada/libgnat/a-cidlli.adb
@@ -179,23 +179,19 @@ is
procedure Append
(Container : in out List;
New_Item : Element_Type;
- Count : Count_Type := 1)
+ Count : Count_Type)
is
begin
Insert (Container, No_Element, New_Item, Count);
end Append;
- ---------------
- -- Append_One --
- ---------------
-
- procedure Append_One
+ procedure Append
(Container : in out List;
New_Item : Element_Type)
is
begin
Insert (Container, No_Element, New_Item, 1);
- end Append_One;
+ end Append;
------------
-- Assign --
diff --git a/gcc/ada/libgnat/a-cidlli.ads b/gcc/ada/libgnat/a-cidlli.ads
index 5e63cf2..c75e5af 100644
--- a/gcc/ada/libgnat/a-cidlli.ads
+++ b/gcc/ada/libgnat/a-cidlli.ads
@@ -57,7 +57,7 @@ is
Default_Iterator => Iterate,
Iterator_Element => Element_Type,
Aggregate => (Empty => Empty,
- Add_Unnamed => Append_One);
+ Add_Unnamed => Append);
pragma Preelaborable_Initialization (List);
@@ -147,9 +147,9 @@ is
procedure Append
(Container : in out List;
New_Item : Element_Type;
- Count : Count_Type := 1);
+ Count : Count_Type);
- procedure Append_One
+ procedure Append
(Container : in out List;
New_Item : Element_Type);
diff --git a/gcc/ada/libgnat/a-cihama.adb b/gcc/ada/libgnat/a-cihama.adb
index 64f662f..7a490d5 100644
--- a/gcc/ada/libgnat/a-cihama.adb
+++ b/gcc/ada/libgnat/a-cihama.adb
@@ -349,6 +349,8 @@ is
Free (Position.Node);
Position.Container := null;
+ Position.Position := No_Element.Position;
+ pragma Assert (Position = No_Element);
end Delete;
-------------
diff --git a/gcc/ada/libgnat/a-cobove.adb b/gcc/ada/libgnat/a-cobove.adb
index 0408741..8a8b279 100644
--- a/gcc/ada/libgnat/a-cobove.adb
+++ b/gcc/ada/libgnat/a-cobove.adb
@@ -321,9 +321,13 @@ package body Ada.Containers.Bounded_Vectors is
-- Append --
------------
- procedure Append (Container : in out Vector; New_Item : Vector) is
+ procedure Append
+ (Container : in out Vector;
+ New_Item : Element_Type;
+ Count : Count_Type)
+ is
begin
- if New_Item.Is_Empty then
+ if Count = 0 then
return;
end if;
@@ -331,16 +335,16 @@ package body Ada.Containers.Bounded_Vectors is
raise Constraint_Error with "vector is already at its maximum length";
end if;
- Container.Insert (Container.Last + 1, New_Item);
+ Container.Insert (Container.Last + 1, New_Item, Count);
end Append;
- procedure Append
- (Container : in out Vector;
- New_Item : Element_Type;
- Count : Count_Type := 1)
- is
+ -------------------
+ -- Append_Vector --
+ -------------------
+
+ procedure Append_Vector (Container : in out Vector; New_Item : Vector) is
begin
- if Count = 0 then
+ if New_Item.Is_Empty then
return;
end if;
@@ -348,19 +352,19 @@ package body Ada.Containers.Bounded_Vectors is
raise Constraint_Error with "vector is already at its maximum length";
end if;
- Container.Insert (Container.Last + 1, New_Item, Count);
- end Append;
+ Container.Insert_Vector (Container.Last + 1, New_Item);
+ end Append_Vector;
- ----------------
- -- Append_One --
- ----------------
+ ------------
+ -- Append --
+ ------------
- procedure Append_One (Container : in out Vector;
- New_Item : Element_Type)
+ procedure Append (Container : in out Vector;
+ New_Item : Element_Type)
is
begin
Insert (Container, Last_Index (Container) + 1, New_Item, 1);
- end Append_One;
+ end Append;
--------------
-- Capacity --
@@ -1243,7 +1247,7 @@ package body Ada.Containers.Bounded_Vectors is
end if;
end Insert;
- procedure Insert
+ procedure Insert_Vector
(Container : in out Vector;
Before : Extended_Index;
New_Item : Vector)
@@ -1309,9 +1313,9 @@ package body Ada.Containers.Bounded_Vectors is
Container.Elements (B + N - Src'Length .. B + N - 1) := Src;
end;
- end Insert;
+ end Insert_Vector;
- procedure Insert
+ procedure Insert_Vector
(Container : in out Vector;
Before : Cursor;
New_Item : Vector)
@@ -1343,10 +1347,10 @@ package body Ada.Containers.Bounded_Vectors is
Index := Before.Index;
end if;
- Insert (Container, Index, New_Item);
- end Insert;
+ Insert_Vector (Container, Index, New_Item);
+ end Insert_Vector;
- procedure Insert
+ procedure Insert_Vector
(Container : in out Vector;
Before : Cursor;
New_Item : Vector;
@@ -1387,10 +1391,10 @@ package body Ada.Containers.Bounded_Vectors is
Index := Before.Index;
end if;
- Insert (Container, Index, New_Item);
+ Insert_Vector (Container, Index, New_Item);
Position := Cursor'(Container'Unchecked_Access, Index);
- end Insert;
+ end Insert_Vector;
procedure Insert
(Container : in out Vector;
@@ -2028,23 +2032,24 @@ package body Ada.Containers.Bounded_Vectors is
-- Prepend --
-------------
- procedure Prepend (Container : in out Vector; New_Item : Vector) is
- begin
- Insert (Container, Index_Type'First, New_Item);
- end Prepend;
-
procedure Prepend
(Container : in out Vector;
New_Item : Element_Type;
Count : Count_Type := 1)
is
begin
- Insert (Container,
- Index_Type'First,
- New_Item,
- Count);
+ Insert (Container, Index_Type'First, New_Item, Count);
end Prepend;
+ --------------------
+ -- Prepend_Vector --
+ --------------------
+
+ procedure Prepend_Vector (Container : in out Vector; New_Item : Vector) is
+ begin
+ Insert_Vector (Container, Index_Type'First, New_Item);
+ end Prepend_Vector;
+
--------------
-- Previous --
--------------
diff --git a/gcc/ada/libgnat/a-cobove.ads b/gcc/ada/libgnat/a-cobove.ads
index ab4ce4e..324ca84 100644
--- a/gcc/ada/libgnat/a-cobove.ads
+++ b/gcc/ada/libgnat/a-cobove.ads
@@ -61,7 +61,7 @@ package Ada.Containers.Bounded_Vectors is
Default_Iterator => Iterate,
Iterator_Element => Element_Type,
Aggregate => (Empty => Empty,
- Add_Unnamed => Append_One,
+ Add_Unnamed => Append,
New_Indexed => New_Vector,
Assign_Indexed => Replace_Element);
@@ -190,24 +190,43 @@ package Ada.Containers.Bounded_Vectors is
procedure Move (Target : in out Vector; Source : in out Vector);
- procedure Insert
+ procedure Insert_Vector
(Container : in out Vector;
Before : Extended_Index;
New_Item : Vector);
procedure Insert
(Container : in out Vector;
+ Before : Extended_Index;
+ New_Item : Vector) renames Insert_Vector;
+ -- Retained for now for compatibility; AI12-0400 will remove this.
+
+ procedure Insert_Vector
+ (Container : in out Vector;
Before : Cursor;
New_Item : Vector);
procedure Insert
(Container : in out Vector;
Before : Cursor;
+ New_Item : Vector) renames Insert_Vector;
+ -- Retained for now for compatibility; AI12-0400 will remove this.
+
+ procedure Insert_Vector
+ (Container : in out Vector;
+ Before : Cursor;
New_Item : Vector;
Position : out Cursor);
procedure Insert
(Container : in out Vector;
+ Before : Cursor;
+ New_Item : Vector;
+ Position : out Cursor) renames Insert_Vector;
+ -- Retained for now for compatibility; AI12-0400 will remove this.
+
+ procedure Insert
+ (Container : in out Vector;
Before : Extended_Index;
New_Item : Element_Type;
Count : Count_Type := 1);
@@ -236,27 +255,36 @@ package Ada.Containers.Bounded_Vectors is
Position : out Cursor;
Count : Count_Type := 1);
- procedure Prepend
+ procedure Prepend_Vector
(Container : in out Vector;
New_Item : Vector);
procedure Prepend
(Container : in out Vector;
+ New_Item : Vector) renames Prepend_Vector;
+ -- Retained for now for compatibility; AI12-0400 will remove this.
+
+ procedure Prepend
+ (Container : in out Vector;
New_Item : Element_Type;
Count : Count_Type := 1);
- procedure Append
+ procedure Append_Vector
(Container : in out Vector;
New_Item : Vector);
procedure Append
(Container : in out Vector;
+ New_Item : Vector) renames Append_Vector;
+ -- Retained for now for compatibility; AI12-0400 will remove this.
+
+ procedure Append
+ (Container : in out Vector;
New_Item : Element_Type;
- Count : Count_Type := 1);
+ Count : Count_Type);
- procedure Append_One (Container : in out Vector;
- New_Item : Element_Type);
- -- Ada_2020 aggregate operation.
+ procedure Append (Container : in out Vector;
+ New_Item : Element_Type);
procedure Insert_Space
(Container : in out Vector;
diff --git a/gcc/ada/libgnat/a-cohama.adb b/gcc/ada/libgnat/a-cohama.adb
index 1475330..9c4e51a 100644
--- a/gcc/ada/libgnat/a-cohama.adb
+++ b/gcc/ada/libgnat/a-cohama.adb
@@ -336,6 +336,8 @@ is
Free (Position.Node);
Position.Container := null;
+ Position.Position := No_Element.Position;
+ pragma Assert (Position = No_Element);
end Delete;
-------------
diff --git a/gcc/ada/libgnat/a-cohase.adb b/gcc/ada/libgnat/a-cohase.adb
index 63e44e1..0131f73 100644
--- a/gcc/ada/libgnat/a-cohase.adb
+++ b/gcc/ada/libgnat/a-cohase.adb
@@ -319,6 +319,8 @@ is
Free (Position.Node);
Position.Container := null;
+ Position.Position := No_Element.Position;
+ pragma Assert (Position = No_Element);
end Delete;
----------------
diff --git a/gcc/ada/libgnat/a-coinve.adb b/gcc/ada/libgnat/a-coinve.adb
index 10711ff..051aa71 100644
--- a/gcc/ada/libgnat/a-coinve.adb
+++ b/gcc/ada/libgnat/a-coinve.adb
@@ -67,8 +67,8 @@ is
begin
return Result : Vector do
Reserve_Capacity (Result, Length (Left) + Length (Right));
- Append (Result, Left);
- Append (Result, Right);
+ Append_Vector (Result, Left);
+ Append_Vector (Result, Right);
end return;
end "&";
@@ -76,7 +76,7 @@ is
begin
return Result : Vector do
Reserve_Capacity (Result, Length (Left) + 1);
- Append (Result, Left);
+ Append_Vector (Result, Left);
Append (Result, Right);
end return;
end "&";
@@ -86,7 +86,7 @@ is
return Result : Vector do
Reserve_Capacity (Result, 1 + Length (Right));
Append (Result, Left);
- Append (Result, Right);
+ Append_Vector (Result, Right);
end return;
end "&";
@@ -176,25 +176,25 @@ is
end;
end Adjust;
- ------------
- -- Append --
- ------------
+ -------------------
+ -- Append_Vector --
+ -------------------
- procedure Append (Container : in out Vector; New_Item : Vector) is
+ procedure Append_Vector (Container : in out Vector; New_Item : Vector) is
begin
if Is_Empty (New_Item) then
return;
elsif Checks and then Container.Last = Index_Type'Last then
raise Constraint_Error with "vector is already at its maximum length";
else
- Insert (Container, Container.Last + 1, New_Item);
+ Insert_Vector (Container, Container.Last + 1, New_Item);
end if;
- end Append;
+ end Append_Vector;
procedure Append
(Container : in out Vector;
New_Item : Element_Type;
- Count : Count_Type := 1)
+ Count : Count_Type)
is
begin
-- In the general case, we pass the buck to Insert, but for efficiency,
@@ -229,16 +229,16 @@ is
end if;
end Append;
- ----------------
- -- Append_One --
- ----------------
+ ------------
+ -- Append --
+ ------------
- procedure Append_One (Container : in out Vector;
+ procedure Append (Container : in out Vector;
New_Item : Element_Type)
is
begin
Insert (Container, Last_Index (Container) + 1, New_Item, 1);
- end Append_One;
+ end Append;
----------------------
-- Append_Slow_Path --
@@ -269,7 +269,7 @@ is
return;
else
Target.Clear;
- Target.Append (Source);
+ Target.Append_Vector (Source);
end if;
end Assign;
@@ -1619,7 +1619,7 @@ is
end;
end Insert;
- procedure Insert
+ procedure Insert_Vector
(Container : in out Vector;
Before : Extended_Index;
New_Item : Vector)
@@ -1766,9 +1766,9 @@ is
Dst_Index := Dst_Index + 1;
end loop;
end;
- end Insert;
+ end Insert_Vector;
- procedure Insert
+ procedure Insert_Vector
(Container : in out Vector;
Before : Cursor;
New_Item : Vector)
@@ -1798,10 +1798,10 @@ is
Index := Before.Index;
end if;
- Insert (Container, Index, New_Item);
- end Insert;
+ Insert_Vector (Container, Index, New_Item);
+ end Insert_Vector;
- procedure Insert
+ procedure Insert_Vector
(Container : in out Vector;
Before : Cursor;
New_Item : Vector;
@@ -1838,10 +1838,10 @@ is
Index := Before.Index;
end if;
- Insert (Container, Index, New_Item);
+ Insert_Vector (Container, Index, New_Item);
Position := (Container'Unrestricted_Access, Index);
- end Insert;
+ end Insert_Vector;
procedure Insert
(Container : in out Vector;
@@ -2559,11 +2559,6 @@ is
-- Prepend --
-------------
- procedure Prepend (Container : in out Vector; New_Item : Vector) is
- begin
- Insert (Container, Index_Type'First, New_Item);
- end Prepend;
-
procedure Prepend
(Container : in out Vector;
New_Item : Element_Type;
@@ -2573,6 +2568,15 @@ is
Insert (Container, Index_Type'First, New_Item, Count);
end Prepend;
+ -------------
+ -- Prepend_Vector --
+ -------------
+
+ procedure Prepend_Vector (Container : in out Vector; New_Item : Vector) is
+ begin
+ Insert_Vector (Container, Index_Type'First, New_Item);
+ end Prepend_Vector;
+
--------------
-- Previous --
--------------
diff --git a/gcc/ada/libgnat/a-coinve.ads b/gcc/ada/libgnat/a-coinve.ads
index 593b63e..c9364c7 100644
--- a/gcc/ada/libgnat/a-coinve.ads
+++ b/gcc/ada/libgnat/a-coinve.ads
@@ -64,7 +64,7 @@ is
Default_Iterator => Iterate,
Iterator_Element => Element_Type,
Aggregate => (Empty => Empty_Vector,
- Add_Unnamed => Append_One,
+ Add_Unnamed => Append,
New_Indexed => New_Vector,
Assign_Indexed => Replace_Element);
@@ -195,24 +195,43 @@ is
procedure Move (Target : in out Vector; Source : in out Vector);
- procedure Insert
+ procedure Insert_Vector
(Container : in out Vector;
Before : Extended_Index;
New_Item : Vector);
procedure Insert
(Container : in out Vector;
+ Before : Extended_Index;
+ New_Item : Vector) renames Insert_Vector;
+ -- Retained for now for compatibility; AI12-0400 will remove this.
+
+ procedure Insert_Vector
+ (Container : in out Vector;
Before : Cursor;
New_Item : Vector);
procedure Insert
(Container : in out Vector;
Before : Cursor;
+ New_Item : Vector) renames Insert_Vector;
+ -- Retained for now for compatibility; AI12-0400 will remove this.
+
+ procedure Insert_Vector
+ (Container : in out Vector;
+ Before : Cursor;
New_Item : Vector;
Position : out Cursor);
procedure Insert
(Container : in out Vector;
+ Before : Cursor;
+ New_Item : Vector;
+ Position : out Cursor) renames Insert_Vector;
+ -- Retained for now for compatibility; AI12-0400 will remove this.
+
+ procedure Insert
+ (Container : in out Vector;
Before : Extended_Index;
New_Item : Element_Type;
Count : Count_Type := 1);
@@ -230,26 +249,36 @@ is
Position : out Cursor;
Count : Count_Type := 1);
- procedure Prepend
+ procedure Prepend_Vector
(Container : in out Vector;
New_Item : Vector);
procedure Prepend
(Container : in out Vector;
+ New_Item : Vector) renames Prepend_Vector;
+ -- Retained for now for compatibility; AI12-0400 will remove this.
+
+ procedure Prepend
+ (Container : in out Vector;
New_Item : Element_Type;
Count : Count_Type := 1);
- procedure Append
+ procedure Append_Vector
(Container : in out Vector;
New_Item : Vector);
procedure Append
(Container : in out Vector;
+ New_Item : Vector) renames Append_Vector;
+ -- Retained for now for compatibility; AI12-0400 will remove this.
+
+ procedure Append
+ (Container : in out Vector;
New_Item : Element_Type;
- Count : Count_Type := 1);
+ Count : Count_Type);
- procedure Append_One (Container : in out Vector;
- New_Item : Element_Type);
+ procedure Append (Container : in out Vector;
+ New_Item : Element_Type);
procedure Insert_Space
(Container : in out Vector;
diff --git a/gcc/ada/libgnat/a-convec.adb b/gcc/ada/libgnat/a-convec.adb
index a43be97..fec72cc 100644
--- a/gcc/ada/libgnat/a-convec.adb
+++ b/gcc/ada/libgnat/a-convec.adb
@@ -64,8 +64,8 @@ is
begin
return Result : Vector do
Reserve_Capacity (Result, Length (Left) + Length (Right));
- Append (Result, Left);
- Append (Result, Right);
+ Append_Vector (Result, Left);
+ Append_Vector (Result, Right);
end return;
end "&";
@@ -73,7 +73,7 @@ is
begin
return Result : Vector do
Reserve_Capacity (Result, Length (Left) + 1);
- Append (Result, Left);
+ Append_Vector (Result, Left);
Append (Result, Right);
end return;
end "&";
@@ -83,7 +83,7 @@ is
return Result : Vector do
Reserve_Capacity (Result, 1 + Length (Right));
Append (Result, Left);
- Append (Result, Right);
+ Append_Vector (Result, Right);
end return;
end "&";
@@ -167,21 +167,10 @@ is
-- Append --
------------
- procedure Append (Container : in out Vector; New_Item : Vector) is
- begin
- if Is_Empty (New_Item) then
- return;
- elsif Checks and then Container.Last = Index_Type'Last then
- raise Constraint_Error with "vector is already at its maximum length";
- else
- Insert (Container, Container.Last + 1, New_Item);
- end if;
- end Append;
-
procedure Append
(Container : in out Vector;
New_Item : Element_Type;
- Count : Count_Type := 1)
+ Count : Count_Type)
is
begin
-- In the general case, we pass the buck to Insert, but for efficiency,
@@ -210,16 +199,31 @@ is
end if;
end Append;
- ----------------
- -- Append_One --
- ----------------
+ -------------------
+ -- Append_Vector --
+ -------------------
+
+ procedure Append_Vector (Container : in out Vector; New_Item : Vector) is
+ begin
+ if Is_Empty (New_Item) then
+ return;
+ elsif Checks and then Container.Last = Index_Type'Last then
+ raise Constraint_Error with "vector is already at its maximum length";
+ else
+ Insert_Vector (Container, Container.Last + 1, New_Item);
+ end if;
+ end Append_Vector;
+
+ ------------
+ -- Append --
+ ------------
- procedure Append_One (Container : in out Vector;
- New_Item : Element_Type)
+ procedure Append (Container : in out Vector;
+ New_Item : Element_Type)
is
begin
Insert (Container, Last_Index (Container) + 1, New_Item, 1);
- end Append_One;
+ end Append;
----------------------
-- Append_Slow_Path --
@@ -250,7 +254,7 @@ is
return;
else
Target.Clear;
- Target.Append (Source);
+ Target.Append_Vector (Source);
end if;
end Assign;
@@ -1310,7 +1314,7 @@ is
end;
end Insert;
- procedure Insert
+ procedure Insert_Vector
(Container : in out Vector;
Before : Extended_Index;
New_Item : Vector)
@@ -1429,9 +1433,9 @@ is
Container.Elements.EA (K .. J) := Src;
end;
- end Insert;
+ end Insert_Vector;
- procedure Insert
+ procedure Insert_Vector
(Container : in out Vector;
Before : Cursor;
New_Item : Vector)
@@ -1461,10 +1465,10 @@ is
Index := Before.Index;
end if;
- Insert (Container, Index, New_Item);
- end Insert;
+ Insert_Vector (Container, Index, New_Item);
+ end Insert_Vector;
- procedure Insert
+ procedure Insert_Vector
(Container : in out Vector;
Before : Cursor;
New_Item : Vector;
@@ -1501,10 +1505,10 @@ is
Index := Before.Index;
end if;
- Insert (Container, Index, New_Item);
+ Insert_Vector (Container, Index, New_Item);
Position := (Container'Unrestricted_Access, Index);
- end Insert;
+ end Insert_Vector;
procedure Insert
(Container : in out Vector;
@@ -2266,11 +2270,6 @@ is
-- Prepend --
-------------
- procedure Prepend (Container : in out Vector; New_Item : Vector) is
- begin
- Insert (Container, Index_Type'First, New_Item);
- end Prepend;
-
procedure Prepend
(Container : in out Vector;
New_Item : Element_Type;
@@ -2280,6 +2279,15 @@ is
Insert (Container, Index_Type'First, New_Item, Count);
end Prepend;
+ --------------------
+ -- Prepend_Vector --
+ --------------------
+
+ procedure Prepend_Vector (Container : in out Vector; New_Item : Vector) is
+ begin
+ Insert_Vector (Container, Index_Type'First, New_Item);
+ end Prepend_Vector;
+
--------------
-- Previous --
--------------
diff --git a/gcc/ada/libgnat/a-convec.ads b/gcc/ada/libgnat/a-convec.ads
index f969e6f..1d257a0 100644
--- a/gcc/ada/libgnat/a-convec.ads
+++ b/gcc/ada/libgnat/a-convec.ads
@@ -95,7 +95,7 @@ is
Default_Iterator => Iterate,
Iterator_Element => Element_Type,
Aggregate => (Empty => Empty,
- Add_Unnamed => Append_One,
+ Add_Unnamed => Append,
New_Indexed => New_Vector,
Assign_Indexed => Replace_Element);
@@ -334,59 +334,80 @@ is
with Pre => First = Index_Type'First;
-- Ada_2020 aggregate operation.
- procedure Insert
+ procedure Insert_Vector
(Container : in out Vector;
Before : Extended_Index;
New_Item : Vector);
-- If Before is not in the range First_Index (Container) .. Last_Index
-- (Container) + 1, then Constraint_Error is propagated. If
- -- Length(New_Item) is 0, then Insert does nothing. Otherwise, it computes
- -- the new length NL as the sum of the current length and Length
+ -- Length(New_Item) is 0, then Insert_Vector does nothing. Otherwise, it
+ -- computes the new length NL as the sum of the current length and Length
-- (New_Item); if the value of Last appropriate for length NL would be
-- greater than Index_Type'Last then Constraint_Error is propagated.
--
-- If the current vector capacity is less than NL, Reserve_Capacity
- -- (Container, NL) is called to increase the vector capacity. Then Insert
- -- slides the elements in the range Before .. Last_Index (Container) up by
- -- Length(New_Item) positions, and then copies the elements of New_Item to
- -- the positions starting at Before. Any exception raised during the
- -- copying is propagated.
+ -- (Container, NL) is called to increase the vector capacity. Then
+ -- Insert_Vector slides the elements in the range Before .. Last_Index
+ -- (Container) up by Length(New_Item) positions, and then copies the
+ -- elements of New_Item to the positions starting at Before. Any exception
+ -- raised during the copying is propagated.
procedure Insert
(Container : in out Vector;
+ Before : Extended_Index;
+ New_Item : Vector) renames Insert_Vector;
+ -- Retained for now for compatibility; AI12-0400 will remove this.
+
+ procedure Insert_Vector
+ (Container : in out Vector;
Before : Cursor;
New_Item : Vector);
-- If Before is not No_Element, and does not designate an element in
-- Container, then Program_Error is propagated. Otherwise, if
- -- Length(New_Item) is 0, then Insert does nothing. If Before is
- -- No_Element, then the call is equivalent to Insert (Container, Last_Index
- -- (Container) + 1, New_Item); otherwise the call is equivalent to Insert
- -- (Container, To_Index (Before), New_Item);
+ -- Length(New_Item) is 0, then Insert_Vector does nothing. If Before is
+ -- No_Element, then the call is equivalent to Insert_Vector (Container,
+ -- Last_Index (Container) + 1, New_Item); otherwise the call is equivalent
+ -- to Insert_Vector (Container, To_Index (Before), New_Item);
procedure Insert
(Container : in out Vector;
Before : Cursor;
+ New_Item : Vector) renames Insert_Vector;
+ -- Retained for now for compatibility; AI12-0400 will remove this.
+
+ procedure Insert_Vector
+ (Container : in out Vector;
+ Before : Cursor;
New_Item : Vector;
Position : out Cursor);
-- If Before is not No_Element, and does not designate an element in
-- Container, then Program_Error is propagated. If Before equals
-- No_Element, then let T be Last_Index (Container) + 1; otherwise, let T
- -- be To_Index (Before). Insert (Container, T, New_Item) is called, and
- -- then Position is set to To_Cursor (Container, T).
+ -- be To_Index (Before). Insert_Vector (Container, T, New_Item) is called,
+ -- and then Position is set to To_Cursor (Container, T).
+
+ procedure Insert
+ (Container : in out Vector;
+ Before : Cursor;
+ New_Item : Vector;
+ Position : out Cursor) renames Insert_Vector;
+ -- Retained for now for compatibility; AI12-0400 will remove this.
procedure Insert
(Container : in out Vector;
Before : Extended_Index;
New_Item : Element_Type;
Count : Count_Type := 1);
- -- Equivalent to Insert (Container, Before, To_Vector (New_Item, Count));
+ -- Equivalent to:
+ -- Insert_Vector (Container, Before, To_Vector (New_Item, Count));
procedure Insert
(Container : in out Vector;
Before : Cursor;
New_Item : Element_Type;
Count : Count_Type := 1);
- -- Equivalent to Insert (Container, Before, To_Vector (New_Item, Count));
+ -- Equivalent to:
+ -- Insert_Vector (Container, Before, To_Vector (New_Item, Count));
procedure Insert
(Container : in out Vector;
@@ -395,7 +416,7 @@ is
Position : out Cursor;
Count : Count_Type := 1);
-- Equivalent to
- -- Insert (Container, Before, To_Vector (New_Item, Count), Position);
+ -- Insert_Vector (Container, Before, To_Vector (New_Item, Count), Position)
procedure Insert
(Container : in out Vector;
@@ -425,33 +446,42 @@ is
-- be To_Index (Before). Insert (Container, T, Count) is called, and then
-- Position is set to To_Cursor (Container, T).
- procedure Prepend
+ procedure Prepend_Vector
(Container : in out Vector;
New_Item : Vector);
-- Equivalent to Insert (Container, First_Index (Container), New_Item).
procedure Prepend
(Container : in out Vector;
+ New_Item : Vector) renames Prepend_Vector;
+ -- Retained for now for compatibility; AI12-0400 will remove this.
+
+ procedure Prepend
+ (Container : in out Vector;
New_Item : Element_Type;
Count : Count_Type := 1);
-- Equivalent to Insert (Container, First_Index (Container), New_Item,
-- Count).
- procedure Append
+ procedure Append_Vector
(Container : in out Vector;
New_Item : Vector);
-- Equivalent to Insert (Container, Last_Index (Container) + 1, New_Item).
procedure Append
(Container : in out Vector;
+ New_Item : Vector) renames Append_Vector;
+ -- Retained for now for compatibility; AI12-0400 will remove this.
+
+ procedure Append
+ (Container : in out Vector;
New_Item : Element_Type;
- Count : Count_Type := 1);
+ Count : Count_Type);
-- Equivalent to Insert (Container, Last_Index (Container) + 1, New_Item,
-- Count).
- procedure Append_One (Container : in out Vector;
- New_Item : Element_Type);
- -- Ada_2020 aggregate operation.
+ procedure Append (Container : in out Vector;
+ New_Item : Element_Type);
procedure Insert_Space
(Container : in out Vector;
diff --git a/gcc/ada/libgnat/a-decima__128.ads b/gcc/ada/libgnat/a-decima__128.ads
new file mode 100644
index 0000000..b29b010
--- /dev/null
+++ b/gcc/ada/libgnat/a-decima__128.ads
@@ -0,0 +1,69 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . D E C I M A L --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT. The copyright notice above, and the license provisions that follow --
+-- apply solely to the contents of the part following the private keyword. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the 128-bit version of this package
+
+package Ada.Decimal is
+ pragma Pure;
+
+ -- The compiler makes a number of assumptions based on the following five
+ -- constants (e.g. there is an assumption that decimal values can always
+ -- be represented in 128-bit signed binary form), so code modifications are
+ -- required to increase these constants.
+
+ Max_Scale : constant := +38;
+ Min_Scale : constant := -38;
+
+ Min_Delta : constant := 1.0E-38;
+ Max_Delta : constant := 1.0E+38;
+
+ Max_Decimal_Digits : constant := 38;
+
+ generic
+ type Dividend_Type is delta <> digits <>;
+ type Divisor_Type is delta <> digits <>;
+ type Quotient_Type is delta <> digits <>;
+ type Remainder_Type is delta <> digits <>;
+
+ procedure Divide
+ (Dividend : Dividend_Type;
+ Divisor : Divisor_Type;
+ Quotient : out Quotient_Type;
+ Remainder : out Remainder_Type);
+
+private
+ pragma Inline (Divide);
+
+end Ada.Decimal;
diff --git a/gcc/ada/libgnat/a-except.adb b/gcc/ada/libgnat/a-except.adb
index 52e716f..f7fd5bb 100644
--- a/gcc/ada/libgnat/a-except.adb
+++ b/gcc/ada/libgnat/a-except.adb
@@ -957,11 +957,6 @@ package body Ada.Exceptions is
begin
Exception_Data.Set_Exception_Msg (X, E, Message);
-
- if not ZCX_By_Default then
- Abort_Defer.all;
- end if;
-
Complete_And_Propagate_Occurrence (X);
end Raise_Exception_Always;
@@ -1041,11 +1036,6 @@ package body Ada.Exceptions is
begin
Exception_Data.Set_Exception_C_Msg (X, E, M);
-
- if not ZCX_By_Default then
- Abort_Defer.all;
- end if;
-
Complete_Occurrence (X);
return X;
end Create_Occurrence_From_Signal_Handler;
@@ -1141,11 +1131,6 @@ package body Ada.Exceptions is
X : constant EOA := Exception_Propagation.Allocate_Occurrence;
begin
Exception_Data.Set_Exception_C_Msg (X, E, F, L, C, M);
-
- if not ZCX_By_Default then
- Abort_Defer.all;
- end if;
-
Complete_And_Propagate_Occurrence (X);
end Raise_With_Location_And_Msg;
@@ -1168,13 +1153,6 @@ package body Ada.Exceptions is
Excep.Msg_Length := Ex.Msg_Length;
Excep.Msg (1 .. Excep.Msg_Length) := Ex.Msg (1 .. Ex.Msg_Length);
- -- The following is a common pattern, should be abstracted
- -- into a procedure call ???
-
- if not ZCX_By_Default then
- Abort_Defer.all;
- end if;
-
Complete_And_Propagate_Occurrence (Excep);
end Raise_With_Msg;
@@ -1507,10 +1485,6 @@ package body Ada.Exceptions is
Saved_MO : constant System.Address := Excep.Machine_Occurrence;
begin
- if not ZCX_By_Default then
- Abort_Defer.all;
- end if;
-
Save_Occurrence (Excep.all, Get_Current_Excep.all.all);
Excep.Machine_Occurrence := Saved_MO;
Complete_And_Propagate_Occurrence (Excep);
@@ -1556,10 +1530,6 @@ package body Ada.Exceptions is
procedure Reraise_Occurrence_Always (X : Exception_Occurrence) is
begin
- if not ZCX_By_Default then
- Abort_Defer.all;
- end if;
-
Reraise_Occurrence_No_Defer (X);
end Reraise_Occurrence_Always;
diff --git a/gcc/ada/libgnat/a-nbnbin.adb b/gcc/ada/libgnat/a-nbnbin.adb
index 70df2c2..9e051d3 100644
--- a/gcc/ada/libgnat/a-nbnbin.adb
+++ b/gcc/ada/libgnat/a-nbnbin.adb
@@ -177,7 +177,7 @@ package body Ada.Numerics.Big_Numbers.Big_Integers is
function To_Big_Integer (Arg : Int) return Valid_Big_Integer is
Result : Big_Integer;
begin
- Set_Bignum (Result, To_Bignum (Long_Long_Integer (Arg)));
+ Set_Bignum (Result, To_Bignum (Long_Long_Long_Integer (Arg)));
return Result;
end To_Big_Integer;
@@ -205,7 +205,7 @@ package body Ada.Numerics.Big_Numbers.Big_Integers is
function To_Big_Integer (Arg : Int) return Valid_Big_Integer is
Result : Big_Integer;
begin
- Set_Bignum (Result, To_Bignum (Unsigned_64 (Arg)));
+ Set_Bignum (Result, To_Bignum (Unsigned_128 (Arg)));
return Result;
end To_Big_Integer;
@@ -235,12 +235,197 @@ package body Ada.Numerics.Big_Numbers.Big_Integers is
-- From_String --
-----------------
- function From_String (Arg : String) return Big_Integer is
+ function From_String (Arg : String) return Valid_Big_Integer is
+ procedure Scan_Decimal
+ (Arg : String; J : in out Natural; Result : out Big_Integer);
+ -- Scan decimal value starting at Arg (J). Store value in Result if
+ -- successful, raise Constraint_Error if not. On exit, J points to the
+ -- first index past the decimal value.
+
+ ------------------
+ -- Scan_Decimal --
+ ------------------
+
+ procedure Scan_Decimal
+ (Arg : String; J : in out Natural; Result : out Big_Integer)
+ is
+ Initial_J : constant Natural := J;
+ Ten : constant Big_Integer := To_Big_Integer (10);
+ begin
+ Result := To_Big_Integer (0);
+
+ while J <= Arg'Last loop
+ if Arg (J) in '0' .. '9' then
+ Result :=
+ Result * Ten + To_Big_Integer (Character'Pos (Arg (J))
+ - Character'Pos ('0'));
+
+ elsif Arg (J) = '_' then
+ if J in Initial_J | Arg'Last
+ or else Arg (J - 1) not in '0' .. '9'
+ or else Arg (J + 1) not in '0' .. '9'
+ then
+ raise Constraint_Error with "invalid integer value: " & Arg;
+ end if;
+ else
+ exit;
+ end if;
+
+ J := J + 1;
+ end loop;
+ end Scan_Decimal;
+
Result : Big_Integer;
+
begin
- -- ??? only support Long_Long_Long_Integer, good enough for now
+ -- First try the fast path via Long_Long_Long_Integer'Value
+
Set_Bignum (Result, To_Bignum (Long_Long_Long_Integer'Value (Arg)));
return Result;
+
+ exception
+ when Constraint_Error =>
+ -- Then try the slow path
+
+ declare
+ Neg : Boolean := False;
+ Base_Found : Boolean := False;
+ Base_Int : Positive := 10;
+ J : Natural := Arg'First;
+ Val : Natural;
+ Base : Big_Integer;
+ Exp : Big_Integer;
+
+ begin
+ -- Scan past leading blanks
+
+ while J <= Arg'Last and then Arg (J) = ' ' loop
+ J := J + 1;
+ end loop;
+
+ if J > Arg'Last then
+ raise;
+ end if;
+
+ -- Scan and store negative sign if found
+
+ if Arg (J) = '-' then
+ Neg := True;
+ J := J + 1;
+ end if;
+
+ -- Scan decimal value: either the result itself, or the base
+ -- value if followed by a '#'.
+
+ Scan_Decimal (Arg, J, Result);
+
+ -- Scan explicit base if requested
+
+ if J <= Arg'Last and then Arg (J) = '#' then
+ Base_Int := To_Integer (Result);
+
+ if Base_Int not in 2 .. 16 then
+ raise;
+ end if;
+
+ Base_Found := True;
+ Base := Result;
+ Result := To_Big_Integer (0);
+ J := J + 1;
+
+ while J <= Arg'Last loop
+ case Arg (J) is
+ when '0' .. '9' =>
+ Val := Character'Pos (Arg (J)) - Character'Pos ('0');
+
+ if Val >= Base_Int then
+ raise;
+ end if;
+
+ Result := Result * Base + To_Big_Integer (Val);
+
+ when 'a' .. 'f' =>
+ Val :=
+ 10 + Character'Pos (Arg (J)) - Character'Pos ('a');
+
+ if Val >= Base_Int then
+ raise;
+ end if;
+
+ Result := Result * Base + To_Big_Integer (Val);
+
+ when 'A' .. 'F' =>
+ Val :=
+ 10 + Character'Pos (Arg (J)) - Character'Pos ('A');
+
+ if Val >= Base_Int then
+ raise;
+ end if;
+
+ Result := Result * Base + To_Big_Integer (Val);
+
+ when '_' =>
+
+ -- We only allow _ preceded and followed by a valid
+ -- number and not any other character.
+
+ if J in Arg'First | Arg'Last
+ or else Arg (J - 1) in '_' | '#'
+ or else Arg (J + 1) = '#'
+ then
+ raise;
+ end if;
+
+ when '#' =>
+ J := J + 1;
+ exit;
+
+ when others =>
+ raise;
+ end case;
+
+ J := J + 1;
+ end loop;
+ else
+ Base := To_Big_Integer (10);
+ end if;
+
+ if Base_Found and then Arg (J - 1) /= '#' then
+ raise;
+ end if;
+
+ if J <= Arg'Last then
+
+ -- Scan exponent
+
+ if Arg (J) in 'e' | 'E' then
+ J := J + 1;
+
+ if Arg (J) = '+' then
+ J := J + 1;
+ end if;
+
+ Scan_Decimal (Arg, J, Exp);
+ Result := Result * (Base ** To_Integer (Exp));
+ end if;
+
+ -- Scan past trailing blanks
+
+ while J <= Arg'Last and then Arg (J) = ' ' loop
+ J := J + 1;
+ end loop;
+
+ if J <= Arg'Last then
+ raise;
+ end if;
+ end if;
+
+ if Neg then
+ return -Result;
+ else
+ return Result;
+ end if;
+ end;
end From_String;
---------------
diff --git a/gcc/ada/libgnat/a-nbnbin.ads b/gcc/ada/libgnat/a-nbnbin.ads
index 7b4974a..668da8d 100644
--- a/gcc/ada/libgnat/a-nbnbin.ads
+++ b/gcc/ada/libgnat/a-nbnbin.ads
@@ -113,7 +113,7 @@ is
Post => To_String'Result'First = 1,
Global => null;
- function From_String (Arg : String) return Big_Integer
+ function From_String (Arg : String) return Valid_Big_Integer
with Global => null;
procedure Put_Image (S : in out Sink'Class; V : Big_Integer);
diff --git a/gcc/ada/libgnat/a-nbnbre.adb b/gcc/ada/libgnat/a-nbnbre.adb
index d61668d..4ff5b35 100644
--- a/gcc/ada/libgnat/a-nbnbre.adb
+++ b/gcc/ada/libgnat/a-nbnbre.adb
@@ -29,9 +29,8 @@
-- --
------------------------------------------------------------------------------
--- This is the default version of this package, based on Big_Integers only.
-
with Ada.Strings.Text_Output.Utils;
+with System.Unsigned_Types; use System.Unsigned_Types;
package body Ada.Numerics.Big_Numbers.Big_Reals is
@@ -84,14 +83,16 @@ package body Ada.Numerics.Big_Numbers.Big_Reals is
---------
function "=" (L, R : Valid_Big_Real) return Boolean is
- (abs L.Num = abs R.Num and then L.Den = R.Den);
+ (L.Num = R.Num and then L.Den = R.Den);
---------
-- "<" --
---------
function "<" (L, R : Valid_Big_Real) return Boolean is
- (abs L.Num * R.Den < abs R.Num * L.Den);
+ (L.Num * R.Den < R.Num * L.Den);
+ -- The denominator is guaranteed to be positive since Normalized is
+ -- always called when constructing a Valid_Big_Real
----------
-- "<=" --
@@ -117,22 +118,185 @@ package body Ada.Numerics.Big_Numbers.Big_Reals is
package body Float_Conversions is
+ package Conv is new
+ Big_Integers.Unsigned_Conversions (Long_Long_Unsigned);
+
-----------------
-- To_Big_Real --
-----------------
+ -- We get the fractional representation of the floating-point number by
+ -- multiplying Num'Fraction by 2.0**M, with M the size of the mantissa,
+ -- which gives zero or a number in the range [2.0**(M-1)..2.0**M), which
+ -- means that it is an integer N of M bits. The floating-point number is
+ -- thus equal to N / 2**(M-E) where E is its Num'Exponent.
+
function To_Big_Real (Arg : Num) return Valid_Big_Real is
+
+ A : constant Num'Base := abs (Arg);
+ E : constant Integer := Num'Exponent (A);
+ F : constant Num'Base := Num'Fraction (A);
+ M : constant Natural := Num'Machine_Mantissa;
+
+ N, D : Big_Integer;
+
begin
- return From_String (Arg'Image);
+ pragma Assert (Num'Machine_Radix = 2);
+ -- This implementation does not handle radix 16
+
+ pragma Assert (M <= 64);
+ -- This implementation handles only 80-bit IEEE Extended or smaller
+
+ N := Conv.To_Big_Integer (Long_Long_Unsigned (F * 2.0**M));
+
+ -- If E is smaller than M, the denominator is 2**(M-E)
+
+ if E < M then
+ D := To_Big_Integer (2) ** (M - E);
+
+ -- Or else, if E is larger than M, multiply the numerator by 2**(E-M)
+
+ elsif E > M then
+ N := N * To_Big_Integer (2) ** (E - M);
+ D := To_Big_Integer (1);
+
+ -- Otherwise E is equal to M and the result is just N
+
+ else
+ D := To_Big_Integer (1);
+ end if;
+
+ return (if Arg >= 0.0 then N / D else -N / D);
end To_Big_Real;
-------------------
-- From_Big_Real --
-------------------
+ -- We get the (Frac, Exp) representation of the real number by finding
+ -- the exponent E such that it lies in the range [2.0**(E-1)..2.0**E),
+ -- multiplying the number by 2.0**(M-E) with M the size of the mantissa,
+ -- and converting the result to integer N in the range [2**(M-1)..2**M)
+ -- with rounding to nearest, ties to even, and finally call Num'Compose.
+ -- This does not apply to the zero, for which we return 0.0 early.
+
function From_Big_Real (Arg : Big_Real) return Num is
+
+ M : constant Natural := Num'Machine_Mantissa;
+ One : constant Big_Real := To_Real (1);
+ Two : constant Big_Real := To_Real (2);
+ Half : constant Big_Real := One / Two;
+ TwoI : constant Big_Integer := To_Big_Integer (2);
+
+ function Log2_Estimate (V : Big_Real) return Natural;
+ -- Return an integer not larger than Log2 (V) for V >= 1.0
+
+ function Minus_Log2_Estimate (V : Big_Real) return Natural;
+ -- Return an integer not larger than -Log2 (V) for V < 1.0
+
+ -------------------
+ -- Log2_Estimate --
+ -------------------
+
+ function Log2_Estimate (V : Big_Real) return Natural is
+ Log : Natural := 1;
+ Pow : Big_Real := Two;
+
+ begin
+ while V >= Pow loop
+ Pow := Pow * Pow;
+ Log := Log + Log;
+ end loop;
+
+ return Log / 2;
+ end Log2_Estimate;
+
+ -------------------------
+ -- Minus_Log2_Estimate --
+ -------------------------
+
+ function Minus_Log2_Estimate (V : Big_Real) return Natural is
+ Log : Natural := 1;
+ Pow : Big_Real := Half;
+
+ begin
+ while V <= Pow loop
+ Pow := Pow * Pow;
+ Log := Log + Log;
+ end loop;
+
+ return Log / 2;
+ end Minus_Log2_Estimate;
+
+ -- Local variables
+
+ V : Big_Real := abs (Arg);
+ E : Integer := 0;
+ L : Integer;
+
+ A, B, Q, X : Big_Integer;
+ N : Long_Long_Unsigned;
+ R : Num'Base;
+
begin
- return Num'Value (To_String (Arg));
+ pragma Assert (Num'Machine_Radix = 2);
+ -- This implementation does not handle radix 16
+
+ pragma Assert (M <= 64);
+ -- This implementation handles only 80-bit IEEE Extended or smaller
+
+ -- Protect from degenerate case
+
+ if Numerator (V) = To_Big_Integer (0) then
+ return 0.0;
+ end if;
+
+ -- Use a binary search to compute exponent E
+
+ while V < Half loop
+ L := Minus_Log2_Estimate (V);
+ V := V * (Two ** L);
+ E := E - L;
+ end loop;
+
+ -- The dissymetry with above is expected since we go below 2
+
+ while V >= One loop
+ L := Log2_Estimate (V) + 1;
+ V := V / (Two ** L);
+ E := E + L;
+ end loop;
+
+ -- The multiplication by 2.0**(-E) has already been done in the loops
+
+ V := V * To_Big_Real (TwoI ** M);
+
+ -- Now go into the integer domain and divide
+
+ A := Numerator (V);
+ B := Denominator (V);
+
+ Q := A / B;
+ N := Conv.From_Big_Integer (Q);
+
+ -- Round to nearest, ties to even, by comparing twice the remainder
+
+ X := (A - Q * B) * TwoI;
+
+ if X > B or else (X = B and then (N mod 2) = 1) then
+ N := N + 1;
+
+ -- If the adjusted quotient overflows the mantissa, scale up
+
+ if N = 2**M then
+ N := 1;
+ E := E + 1;
+ end if;
+ end if;
+
+ R := Num'Compose (Num'Base (N), E);
+
+ return (if Numerator (Arg) >= To_Big_Integer (0) then R else -R);
end From_Big_Real;
end Float_Conversions;
@@ -143,22 +307,78 @@ package body Ada.Numerics.Big_Numbers.Big_Reals is
package body Fixed_Conversions is
+ package Float_Aux is new Float_Conversions (Long_Long_Float);
+
+ subtype LLLI is Long_Long_Long_Integer;
+ subtype LLLU is Long_Long_Long_Unsigned;
+
+ Too_Large : constant Boolean :=
+ 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.
+
+ package Conv_I is new Big_Integers.Signed_Conversions (LLLI);
+ package Conv_U is new Big_Integers.Unsigned_Conversions (LLLU);
+
-----------------
-- To_Big_Real --
-----------------
+ -- We just compute V * N / D where V is the mantissa value of the fixed
+ -- point number, and N resp. D is the numerator resp. the denominator of
+ -- the Small of the fixed-point type.
+
function To_Big_Real (Arg : Num) return Valid_Big_Real is
+ N, D, V : Big_Integer;
+
begin
- return From_String (Arg'Image);
+ if Too_Large then
+ return Float_Aux.To_Big_Real (Long_Long_Float (Arg));
+ end if;
+
+ N := Conv_U.To_Big_Integer (Num'Small_Numerator);
+ D := Conv_U.To_Big_Integer (Num'Small_Denominator);
+ V := Conv_I.To_Big_Integer (LLLI'Integer_Value (Arg));
+
+ return V * N / D;
end To_Big_Real;
-------------------
-- From_Big_Real --
-------------------
+ -- We first compute A / B = Arg * D / N where N resp. D is the numerator
+ -- resp. the denominator of the Small of the fixed-point type. Then we
+ -- divide A by B and convert the result to the mantissa value.
+
function From_Big_Real (Arg : Big_Real) return Num is
+ N, D, A, B, Q, X : Big_Integer;
+
begin
- return Num'Value (To_String (Arg));
+ if Too_Large then
+ return Num (Float_Aux.From_Big_Real (Arg));
+ end if;
+
+ N := Conv_U.To_Big_Integer (Num'Small_Numerator);
+ D := Conv_U.To_Big_Integer (Num'Small_Denominator);
+ A := Numerator (Arg) * D;
+ B := Denominator (Arg) * N;
+
+ Q := A / B;
+
+ -- Round to nearest, ties to away, by comparing twice the remainder
+
+ X := (A - Q * B) * To_Big_Integer (2);
+
+ if X >= B then
+ Q := Q + To_Big_Integer (1);
+
+ elsif X <= -B then
+ Q := Q - To_Big_Integer (1);
+ end if;
+
+ return Num'Fixed_Value (Conv_I.From_Big_Integer (Q));
end From_Big_Real;
end Fixed_Conversions;
@@ -318,7 +538,7 @@ package body Ada.Numerics.Big_Numbers.Big_Reals is
-- From_String --
-----------------
- function From_String (Arg : String) return Big_Real is
+ function From_String (Arg : String) return Valid_Big_Real is
Ten : constant Big_Integer := To_Big_Integer (10);
Frac : Big_Integer;
Exp : Integer := 0;
@@ -340,7 +560,7 @@ package body Ada.Numerics.Big_Numbers.Big_Reals is
elsif Arg (J) = '.' then
Index := J - 1;
exit;
- else
+ elsif Arg (J) /= '_' then
Pow := Pow + 1;
end if;
end loop;
@@ -373,6 +593,13 @@ 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 --
--------------------------
diff --git a/gcc/ada/libgnat/a-nbnbre.ads b/gcc/ada/libgnat/a-nbnbre.ads
index 5a8ebb9..ee5636f 100644
--- a/gcc/ada/libgnat/a-nbnbre.ads
+++ b/gcc/ada/libgnat/a-nbnbre.ads
@@ -120,7 +120,9 @@ is
Post => To_String'Result'First = 1,
Global => null;
- function From_String (Arg : String) return Big_Real
+ 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 To_Quotient_String (Arg : Big_Real) return String is
diff --git a/gcc/ada/libgnat/a-strfix.ads b/gcc/ada/libgnat/a-strfix.ads
index 7d6e121..4214157 100644
--- a/gcc/ada/libgnat/a-strfix.ads
+++ b/gcc/ada/libgnat/a-strfix.ads
@@ -108,10 +108,57 @@ package Ada.Strings.Fixed with SPARK_Mode is
Going : Direction := Forward;
Mapping : Maps.Character_Mapping_Function) return Natural
with
- Pre =>
+ Pre =>
Pattern'Length /= 0
and then (if Source'Length /= 0 then From in Source'Range),
- Global => null;
+
+ Post => Index'Result in 0 | Source'Range,
+ Contract_Cases =>
+
+ -- If no slice in the considered range of Source matches Pattern,
+ -- then 0 is returned.
+
+ ((for all J in Source'Range =>
+ (if (if Going = Forward
+ then J in From .. Source'Last - Pattern'Length + 1
+ else J <= From - Pattern'Length + 1)
+ then Translate (Source (J .. J - 1 + Pattern'Length), Mapping)
+ /= Pattern))
+ =>
+ Index'Result = 0,
+
+ -- Otherwise, a valid index is returned
+
+ others
+ =>
+
+ -- The result is in the considered range of Source
+
+ (if Going = Forward
+ then Index'Result in From .. Source'Last - Pattern'Length + 1
+ else Index'Result in Source'First .. From - Pattern'Length + 1)
+
+ -- The slice beginning at the returned index matches Pattern
+
+ and then
+ Translate (Source (Index'Result
+ .. Index'Result - 1 + Pattern'Length),
+ Mapping)
+ = Pattern
+
+ -- The result is the smallest or largest index which satisfies the
+ -- matching, respectively when Going = Forward and
+ -- Going = Backwards.
+
+ and then
+ (for all J in Source'Range =>
+ (if (if Going = Forward
+ then J in From .. Index'Result - 1
+ else J - 1 in Index'Result .. From - Pattern'Length)
+ then Translate (Source (J .. J - 1 + Pattern'Length),
+ Mapping)
+ /= Pattern))),
+ Global => null;
pragma Ada_05 (Index);
function Index
@@ -121,10 +168,57 @@ package Ada.Strings.Fixed with SPARK_Mode is
Going : Direction := Forward;
Mapping : Maps.Character_Mapping := Maps.Identity) return Natural
with
- Pre =>
+ Pre =>
Pattern'Length /= 0
and then (if Source'Length /= 0 then From in Source'Range),
- Global => null;
+
+ Post => Index'Result in 0 | Source'Range,
+ Contract_Cases =>
+
+ -- If no slice in the considered range of Source matches Pattern,
+ -- then 0 is returned.
+
+ ((for all J in Source'Range =>
+ (if (if Going = Forward
+ then J in From .. Source'Last - Pattern'Length + 1
+ else J <= From - Pattern'Length + 1)
+ then Translate (Source (J .. J - 1 + Pattern'Length), Mapping)
+ /= Pattern))
+ =>
+ Index'Result = 0,
+
+ -- Otherwise, a valid index is returned
+
+ others
+ =>
+
+ -- The result is in the considered range of Source
+
+ (if Going = Forward
+ then Index'Result in From .. Source'Last - Pattern'Length + 1
+ else Index'Result in Source'First .. From - Pattern'Length + 1)
+
+ -- The slice beginning at the returned index matches Pattern
+
+ and then
+ Translate (Source (Index'Result
+ .. Index'Result - 1 + Pattern'Length),
+ Mapping)
+ = Pattern
+
+ -- The result is the smallest or largest index which satisfies the
+ -- matching, respectively when Going = Forward and
+ -- Going = Backwards.
+
+ and then
+ (for all J in Source'Range =>
+ (if (if Going = Forward
+ then J in From .. Index'Result - 1
+ else J - 1 in Index'Result .. From - Pattern'Length)
+ then Translate (Source (J .. J - 1 + Pattern'Length),
+ Mapping)
+ /= Pattern))),
+ Global => null;
pragma Ada_05 (Index);
-- Each Index function searches, starting from From, for a slice of
@@ -146,8 +240,53 @@ package Ada.Strings.Fixed with SPARK_Mode is
Going : Direction := Forward;
Mapping : Maps.Character_Mapping := Maps.Identity) return Natural
with
- Pre => Pattern'Length > 0,
- Global => null;
+ Pre => Pattern'Length > 0,
+
+ Post => Index'Result in 0 | Source'Range,
+ Contract_Cases =>
+
+ -- If Source is empty, or if no slice of Source matches Pattern, then
+ -- 0 is returned.
+
+ (Source'Length = 0
+ or else
+ (for all J in Source'First .. Source'Last - Pattern'Length + 1 =>
+ Translate (Source (J .. J - 1 + Pattern'Length), Mapping)
+ /= Pattern)
+ =>
+ Index'Result = 0,
+
+ -- Otherwise, a valid index is returned
+
+ others
+ =>
+
+ -- The result is in the considered range of Source
+
+ Index'Result in Source'First .. Source'Last - Pattern'Length + 1
+
+ -- The slice beginning at the returned index matches Pattern
+
+ and then
+ Translate (Source (Index'Result
+ .. Index'Result - 1 + Pattern'Length),
+ Mapping)
+ = Pattern
+
+ -- The result is the smallest or largest index which satisfies the
+ -- matching, respectively when Going = Forward and
+ -- Going = Backwards.
+
+ and then
+ (for all J in Source'Range =>
+ (if (if Going = Forward
+ then J <= Index'Result - 1
+ else J - 1 in Index'Result
+ .. Source'Last - Pattern'Length)
+ then Translate (Source (J .. J - 1 + Pattern'Length),
+ Mapping)
+ /= Pattern))),
+ Global => null;
function Index
(Source : String;
@@ -155,8 +294,53 @@ package Ada.Strings.Fixed with SPARK_Mode is
Going : Direction := Forward;
Mapping : Maps.Character_Mapping_Function) return Natural
with
- Pre => Pattern'Length /= 0,
- Global => null;
+ Pre => Pattern'Length > 0,
+
+ Post => Index'Result in 0 | Source'Range,
+ Contract_Cases =>
+
+ -- If Source is empty, or if no slice of Source matches Pattern, then
+ -- 0 is returned.
+
+ (Source'Length = 0
+ or else
+ (for all J in Source'First .. Source'Last - Pattern'Length + 1 =>
+ Translate (Source (J .. J - 1 + Pattern'Length), Mapping)
+ /= Pattern)
+ =>
+ Index'Result = 0,
+
+ -- Otherwise, a valid index is returned
+
+ others
+ =>
+
+ -- The result is in the considered range of Source
+
+ Index'Result in Source'First .. Source'Last - Pattern'Length + 1
+
+ -- The slice beginning at the returned index matches Pattern
+
+ and then
+ Translate (Source (Index'Result
+ .. Index'Result - 1 + Pattern'Length),
+ Mapping)
+ = Pattern
+
+ -- The result is the smallest or largest index which satisfies the
+ -- matching, respectively when Going = Forward and
+ -- Going = Backwards.
+
+ and then
+ (for all J in Source'Range =>
+ (if (if Going = Forward
+ then J <= Index'Result - 1
+ else J - 1 in Index'Result
+ .. Source'Last - Pattern'Length)
+ then Translate (Source (J .. J - 1 + Pattern'Length),
+ Mapping)
+ /= Pattern))),
+ Global => null;
-- If Going = Forward, returns:
--
@@ -172,7 +356,44 @@ package Ada.Strings.Fixed with SPARK_Mode is
Test : Membership := Inside;
Going : Direction := Forward) return Natural
with
- Global => null;
+ Post => Index'Result in 0 | Source'Range,
+ Contract_Cases =>
+
+ -- If no character of Source satisfies the property Test on Set, then
+ -- 0 is returned.
+
+ ((for all C of Source =>
+ (Test = Inside) /= Ada.Strings.Maps.Is_In (C, Set))
+ =>
+ Index'Result = 0,
+
+ -- Otherwise, a index in the range of Source is returned
+
+ others
+ =>
+
+ -- The result is in the range of Source
+
+ Index'Result in Source'Range
+
+ -- The character at the returned index satisfies the property
+ -- Test on Set
+
+ and then
+ (Test = Inside)
+ = Ada.Strings.Maps.Is_In (Source (Index'Result), Set)
+
+ -- The result is the smallest or largest index which satisfies the
+ -- property, respectively when Going = Forward and
+ -- Going = Backwards.
+
+ and then
+ (for all J in Source'Range =>
+ (if J /= Index'Result
+ and then (J < Index'Result) = (Going = Forward)
+ then (Test = Inside)
+ /= Ada.Strings.Maps.Is_In (Source (J), Set)))),
+ Global => null;
function Index
(Source : String;
@@ -181,8 +402,53 @@ package Ada.Strings.Fixed with SPARK_Mode is
Test : Membership := Inside;
Going : Direction := Forward) return Natural
with
- Pre => (if Source'Length /= 0 then From in Source'Range),
- Global => null;
+ Pre => (if Source'Length /= 0 then From in Source'Range),
+
+ Post => Index'Result in 0 | Source'Range,
+ Contract_Cases =>
+
+ -- If no character in the considered slice of Source satisfies the
+ -- property Test on Set, then 0 is returned.
+
+ ((for all I in Source'Range =>
+ (if I = From
+ or else (I > From) = (Going = Forward)
+ then (Test = Inside) /= Ada.Strings.Maps.Is_In (Source (I), Set)))
+ =>
+ Index'Result = 0,
+
+ -- Otherwise, an index in the range of Source is returned
+
+ others
+ =>
+
+ -- The result is in the considered range of Source
+
+ Index'Result in Source'Range
+ and then (Index'Result = From
+ or else (Index'Result > From) = (Going = Forward))
+
+ -- The character at the returned index satisfies the property
+ -- Test on Set.
+
+ and then
+ (Test = Inside)
+ = Ada.Strings.Maps.Is_In (Source (Index'Result), Set)
+
+ -- The result is the smallest or largest index which satisfies the
+ -- property, respectively when Going = Forward and
+ -- Going = Backwards.
+
+ and then
+ (for all J in Source'Range =>
+ (if J /= Index'Result
+ and then (J < Index'Result) = (Going = Forward)
+ and then (J = From
+ or else (J > From) = (Going = Forward))
+ then
+ (Test = Inside)
+ /= Ada.Strings.Maps.Is_In (Source (J), Set)))),
+ Global => null;
pragma Ada_05 (Index);
-- Index searches for the first or last occurrence of any of a set of
-- characters (when Test=Inside), or any of the complement of a set of
@@ -198,8 +464,49 @@ package Ada.Strings.Fixed with SPARK_Mode is
From : Positive;
Going : Direction := Forward) return Natural
with
- Pre => (if Source'Length /= 0 then From in Source'Range),
- Global => null;
+ Pre => (if Source'Length /= 0 then From in Source'Range),
+
+ Post => Index_Non_Blank'Result in 0 | Source'Range,
+ Contract_Cases =>
+
+ -- If all characters in the considered slice of Source are Space
+ -- characters, then 0 is returned.
+
+ ((for all J in Source'Range =>
+ (if J = From or else (J > From) = (Going = Forward)
+ then Source (J) = ' '))
+ =>
+ Index_Non_Blank'Result = 0,
+
+ -- Otherwise, a valid index is returned
+
+ others
+ =>
+
+ -- The result is in the considered range of Source
+
+ Index_Non_Blank'Result in Source'Range
+ and then (Index_Non_Blank'Result = From
+ or else (Index_Non_Blank'Result > From)
+ = (Going = Forward))
+
+ -- The character at the returned index is not a Space character
+
+ and then Source (Index_Non_Blank'Result) /= ' '
+
+ -- The result is the smallest or largest index which is not a
+ -- Space character, respectively when Going = Forward and
+ -- Going = Backwards.
+
+ and then
+ (for all J in Source'Range =>
+ (if J /= Index_Non_Blank'Result
+ and then (J < Index_Non_Blank'Result)
+ = (Going = Forward)
+ and then (J = From or else (J > From)
+ = (Going = Forward))
+ then Source (J) = ' '))),
+ Global => null;
pragma Ada_05 (Index_Non_Blank);
-- Returns Index (Source, Maps.To_Set(Space), From, Outside, Going)
@@ -207,7 +514,37 @@ package Ada.Strings.Fixed with SPARK_Mode is
(Source : String;
Going : Direction := Forward) return Natural
with
- Global => null;
+ Post => Index_Non_Blank'Result in 0 | Source'Range,
+ Contract_Cases =>
+
+ -- If all characters of Source are Space characters, then 0 is
+ -- returned.
+
+ ((for all C of Source => C = ' ') => Index_Non_Blank'Result = 0,
+
+ -- Otherwise, a valid index is returned
+
+ others =>
+
+ -- The result is in the range of Source
+
+ Index_Non_Blank'Result in Source'Range
+
+ -- The character at the returned index is not a Space character
+
+ and then Source (Index_Non_Blank'Result) /= ' '
+
+ -- The result is the smallest or largest index which is not a
+ -- Space character, respectively when Going = Forward and
+ -- Going = Backwards.
+
+ and then
+ (for all J in Source'Range =>
+ (if J /= Index_Non_Blank'Result
+ and then (J < Index_Non_Blank'Result)
+ = (Going = Forward)
+ then Source (J) = ' '))),
+ Global => null;
-- Returns Index (Source, Maps.To_Set(Space), Outside, Going)
function Count
@@ -246,8 +583,53 @@ package Ada.Strings.Fixed with SPARK_Mode is
First : out Positive;
Last : out Natural)
with
- Pre => (if Source'Length /= 0 then From in Source'Range),
- Global => null;
+ Pre => (if Source'Length /= 0 then From in Source'Range),
+ Contract_Cases =>
+
+ -- If Source is the empty string, or if no character of the considered
+ -- slice of Source satisfies the property Test on Set, then First is
+ -- set to From and Last is set to 0.
+
+ (Source'Length = 0
+ or else
+ (for all C of Source (From .. Source'Last) =>
+ (Test = Inside) /= Ada.Strings.Maps.Is_In (C, Set))
+ =>
+ First = From and then Last = 0,
+
+ -- Otherwise, First and Last are set to valid indexes
+
+ others
+ =>
+
+ -- First and Last are in the considered range of Source
+
+ First in From .. Source'Last
+ and then Last in First .. Source'Last
+
+ -- No character between From and First satisfies the property Test
+ -- on Set.
+
+ and then
+ (for all C of Source (From .. First - 1) =>
+ (Test = Inside) /= Ada.Strings.Maps.Is_In (C, Set))
+
+ -- All characters between First and Last satisfy the property Test
+ -- on Set.
+
+ and then
+ (for all C of Source (First .. Last) =>
+ (Test = Inside) = Ada.Strings.Maps.Is_In (C, Set))
+
+ -- If Last is not Source'Last, then the character at position
+ -- Last + 1 does not satify the property Test on Set.
+
+ and then
+ (if Last < Source'Last
+ then
+ (Test = Inside)
+ /= Ada.Strings.Maps.Is_In (Source (Last + 1), Set))),
+ Global => null;
pragma Ada_2012 (Find_Token);
-- If Source is not the null string and From is not in Source'Range, then
-- Index_Error is raised. Otherwise, First is set to the index of the first
@@ -264,6 +646,50 @@ package Ada.Strings.Fixed with SPARK_Mode is
First : out Positive;
Last : out Natural)
with
+ Contract_Cases =>
+
+ -- If Source is the empty string, or if no character of Source
+ -- satisfies the property Test on Set, then First is set to From and
+ -- Last is set to 0.
+
+ (Source'Length = 0
+ or else
+ (for all C of Source =>
+ (Test = Inside) /= Ada.Strings.Maps.Is_In (C, Set))
+ =>
+ First = Source'First and then Last = 0,
+
+ -- Otherwise, First and Last are set to valid indexes
+
+ others
+ =>
+
+ -- First and Last are in the considered range of Source
+
+ First in Source'Range
+ and then Last in First .. Source'Last
+
+ -- No character before First satisfies the property Test on Set
+
+ and then
+ (for all C of Source (Source'First .. First - 1) =>
+ (Test = Inside) /= Ada.Strings.Maps.Is_In (C, Set))
+
+ -- All characters between First and Last satisfy the property Test
+ -- on Set.
+
+ and then
+ (for all C of Source (First .. Last) =>
+ (Test = Inside) = Ada.Strings.Maps.Is_In (C, Set))
+
+ -- If Last is not Source'Last, then the character at position
+ -- Last + 1 does not satify the property Test on Set.
+
+ and then
+ (if Last < Source'Last
+ then
+ (Test = Inside)
+ /= Ada.Strings.Maps.Is_In (Source (Last + 1), Set))),
Global => null;
-- Equivalent to Find_Token (Source, Set, Source'First, Test, First, Last)
@@ -275,14 +701,46 @@ package Ada.Strings.Fixed with SPARK_Mode is
(Source : String;
Mapping : Maps.Character_Mapping_Function) return String
with
- Post => Translate'Result'Length = Source'Length,
+ Post =>
+
+ -- Lower bound of the returned string is 1
+
+ Translate'Result'First = 1
+
+ -- The returned string has the same length as Source
+
+ and then Translate'Result'Last = Source'Length
+
+ -- Each character in the returned string is the translation of the
+ -- character at the same position in Source through Mapping.
+
+ and then
+ (for all J in Source'Range =>
+ Translate'Result (J - Source'First + 1)
+ = Mapping (Source (J))),
Global => null;
function Translate
(Source : String;
Mapping : Maps.Character_Mapping) return String
with
- Post => Translate'Result'Length = Source'Length,
+ Post =>
+
+ -- Lower bound of the returned string is 1
+
+ Translate'Result'First = 1
+
+ -- The returned string has the same length as Source
+
+ and then Translate'Result'Last = Source'Length
+
+ -- Each character in the returned string is the translation of the
+ -- character at the same position in Source through Mapping.
+
+ and then
+ (for all J in Source'Range =>
+ Translate'Result (J - Source'First + 1)
+ = Ada.Strings.Maps.Value (Mapping, Source (J))),
Global => null;
-- Returns the string S whose length is Source'Length and such that S (I)
@@ -293,12 +751,25 @@ package Ada.Strings.Fixed with SPARK_Mode is
(Source : in out String;
Mapping : Maps.Character_Mapping_Function)
with
+ Post =>
+
+ -- Each character in Source after the call is the translation of
+ -- the character at the same position before the call, through Mapping.
+
+ (for all J in Source'Range => Source (J) = Mapping (Source'Old (J))),
Global => null;
procedure Translate
(Source : in out String;
Mapping : Maps.Character_Mapping)
with
+ Post =>
+
+ -- Each character in Source after the call is the translation of
+ -- the character at the same position before the call, through Mapping.
+
+ (for all J in Source'Range =>
+ Source (J) = Ada.Strings.Maps.Value (Mapping, Source'Old (J))),
Global => null;
-- Equivalent to Source := Translate(Source, Mapping)
@@ -344,17 +815,80 @@ package Ada.Strings.Fixed with SPARK_Mode is
and then High >= Source'First - 1
and then (if High >= Low
then Natural'Max (0, Low - Source'First)
- <= Natural'Last - By'Length
- - Natural'Max (Source'Last - High, 0)
+ <= Natural'Last
+ - By'Length
+ - Natural'Max (Source'Last - High, 0)
else Source'Length <= Natural'Last - By'Length),
+
+ -- Lower bound of the returned string is 1
+
+ Post => Replace_Slice'Result'First = 1,
Contract_Cases =>
+
+ -- If High >= Low, then the returned string comprises
+ -- Source (Source'First .. Low - 1) & By
+ -- & Source(High + 1 .. Source'Last).
+
(High >= Low =>
+
+ -- Length of the returned string
+
Replace_Slice'Result'Length
- = Natural'Max (0, Low - Source'First)
- + By'Length
- + Natural'Max (Source'Last - High, 0),
+ = Natural'Max (0, Low - Source'First)
+ + By'Length
+ + Natural'Max (Source'Last - High, 0)
+
+ -- Elements starting at Low are replaced by elements of By
+
+ and then
+ Replace_Slice'Result (1 .. Natural'Max (0, Low - Source'First))
+ = Source (Source'First .. Low - 1)
+ and then
+ Replace_Slice'Result
+ (Natural'Max (0, Low - Source'First) + 1
+ .. Natural'Max (0, Low - Source'First) + By'Length)
+ = By
+
+ -- When there are remaining characters after the replaced slice,
+ -- they are appended to the result.
+
+ and then
+ (if High < Source'Last
+ then
+ Replace_Slice'Result
+ (Natural'Max (0, Low - Source'First) + By'Length + 1
+ .. Replace_Slice'Result'Last)
+ = Source (High + 1 .. Source'Last)),
+
+ -- If High < Low, then the returned string is
+ -- Insert (Source, Before => Low, New_Item => By).
+
others =>
- Replace_Slice'Result'Length = Source'Length + By'Length),
+
+ -- Length of the returned string
+
+ Replace_Slice'Result'Length = Source'Length + By'Length
+
+ -- Elements of By are inserted after the element at Low
+
+ and then
+ Replace_Slice'Result (1 .. Low - Source'First)
+ = Source (Source'First .. Low - 1)
+ and then
+ Replace_Slice'Result
+ (Low - Source'First + 1 .. Low - Source'First + By'Length)
+ = By
+
+ -- When there are remaining characters after Low in Source, they
+ -- are appended to the result.
+
+ and then
+ (if Low < Source'Last
+ then
+ Replace_Slice'Result
+ (Low - Source'First + By'Length + 1
+ .. Replace_Slice'Result'Last)
+ = Source (Low .. Source'Last))),
Global => null;
-- Equivalent to:
--
@@ -369,7 +903,38 @@ package Ada.Strings.Fixed with SPARK_Mode is
Pre =>
Before - 1 in Source'First - 1 .. Source'Last
and then Source'Length <= Natural'Last - New_Item'Length,
- Post => Insert'Result'Length = Source'Length + New_Item'Length,
+
+ Post =>
+
+ -- Lower bound of the returned string is 1
+
+ Insert'Result'First = 1
+
+ -- Length of the returned string
+
+ and then Insert'Result'Length = Source'Length + New_Item'Length
+
+ -- Elements of New_Item are inserted after element at Before
+
+ and then
+ Insert'Result (1 .. Before - Source'First)
+ = Source (Source'First .. Before - 1)
+ and then
+ Insert'Result
+ (Before - Source'First + 1
+ .. Before - Source'First + New_Item'Length)
+ = New_Item
+
+ -- When there are remaining characters after Before in Source, they
+ -- are appended to the returned string.
+
+ and then
+ (if Before - 1 < Source'Last
+ then
+ Insert'Result
+ (Before - Source'First + New_Item'Length + 1
+ .. Insert'Result'Last)
+ = Source (Before .. Source'Last)),
Global => null;
-- Propagates Index_Error if Before is not in
-- Source'First .. Source'Last+1; otherwise, returns
@@ -397,12 +962,44 @@ package Ada.Strings.Fixed with SPARK_Mode is
Pre =>
Position - 1 in Source'First - 1 .. Source'Last
and then
- (if Position - Source'First >= Source'Length - New_Item'Length
- then Position - Source'First <= Natural'Last - New_Item'Length),
+ (if Position - Source'First >= Source'Length - New_Item'Length
+ then Position - Source'First <= Natural'Last - New_Item'Length),
+
Post =>
- Overwrite'Result'Length
- = Integer'Max (Source'Length,
- Position - Source'First + New_Item'Length),
+
+ -- Lower bound of the returned string is 1
+
+ Overwrite'Result'First = 1
+
+ -- Length of the returned string
+
+ and then
+ Overwrite'Result'Length
+ = Integer'Max (Source'Length,
+ Position - Source'First + New_Item'Length)
+
+ -- Elements after Position are replaced by elements of New_Item
+
+ and then
+ Overwrite'Result (1 .. Position - Source'First)
+ = Source (Source'First .. Position - 1)
+ and then
+ Overwrite'Result
+ (Position - Source'First + 1
+ .. Position - Source'First + New_Item'Length)
+ = New_Item
+
+ -- If the end of Source is reached before the characters in New_Item
+ -- are exhausted, the remaining characters from New_Item are appended
+ -- to the string.
+
+ and then
+ (if Position <= Source'Last - New_Item'Length
+ then
+ Overwrite'Result
+ (Position - Source'First + New_Item'Length + 1
+ .. Overwrite'Result'Last)
+ = Source (Position + New_Item'Length .. Source'Last)),
Global => null;
-- Propagates Index_Error if Position is not in
-- Source'First .. Source'Last + 1; otherwise, returns the string obtained
@@ -429,15 +1026,47 @@ package Ada.Strings.Fixed with SPARK_Mode is
From : Positive;
Through : Natural) return String
with
- Pre => (if From <= Through
- then (From in Source'Range
- and then Through <= Source'Last)),
- Post =>
- Delete'Result'Length
- = Source'Length - (if From <= Through
- then Through - From + 1
- else 0),
- Global => null;
+ Pre => (if From <= Through
+ then (From in Source'Range
+ and then Through <= Source'Last)),
+
+ -- Lower bound of the returned string is 1
+
+ Post =>
+ Delete'Result'First = 1,
+
+ Contract_Cases =>
+
+ -- If From <= Through, the characters between From and Through are
+ -- removed.
+
+ (From <= Through =>
+
+ -- Length of the returned string
+
+ Delete'Result'Length = Source'Length - (Through - From + 1)
+
+ -- Elements before From are preserved
+
+ and then
+ Delete'Result (1 .. From - Source'First)
+ = Source (Source'First .. From - 1)
+
+ -- If there are remaining characters after Through, they are
+ -- appended to the returned string.
+
+ and then
+ (if Through < Source'Last
+ then Delete'Result
+ (From - Source'First + 1 .. Delete'Result'Last)
+ = Source (Through + 1 .. Source'Last)),
+
+ -- Otherwise, the returned string is Source with lower bound 1
+
+ others =>
+ Delete'Result'Length = Source'Length
+ and then Delete'Result = Source),
+ Global => null;
-- If From <= Through, the returned string is
-- Replace_Slice(Source, From, Through, ""); otherwise, it is Source with
-- lower bound 1.
@@ -469,7 +1098,47 @@ package Ada.Strings.Fixed with SPARK_Mode is
(Source : String;
Side : Trim_End) return String
with
- Post => Trim'Result'Length <= Source'Length,
+ Post =>
+
+ -- Lower bound of the returned string is 1
+
+ Trim'Result'First = 1
+
+ -- If all characters in Source are Space, the returned string is
+ -- empty.
+
+ and then
+ (if (for all J in Source'Range => Source (J) = ' ')
+ then Trim'Result = ""
+
+ -- Otherwise, the returned string is a slice of Source
+
+ else
+ (for some Low in Source'Range =>
+ (for some High in Source'Range =>
+
+ -- Trim returns the slice of Source between Low and High
+
+ Trim'Result = Source (Low .. High)
+
+ -- Values of Low and High and the characters at their
+ -- position depend on Side.
+
+ and then
+ (if Side = Left then High = Source'Last
+ else Source (High) /= ' ')
+ and then
+ (if Side = Right then Low = Source'First
+ else Source (Low) /= ' ')
+
+ -- All characters outside range Low .. High are
+ -- Space characters.
+
+ and then
+ (for all J in Source'Range =>
+ (if J < Low then Source (J) = ' ')
+ and then
+ (if J > High then Source (J) = ' '))))),
Global => null;
-- Returns the string obtained by removing from Source all leading Space
-- characters (if Side = Left), all trailing Space characters (if
@@ -495,7 +1164,50 @@ package Ada.Strings.Fixed with SPARK_Mode is
Left : Maps.Character_Set;
Right : Maps.Character_Set) return String
with
- Post => Trim'Result'Length <= Source'Length,
+ Post =>
+
+ -- Lower bound of the returned string is 1
+
+ Trim'Result'First = 1
+
+ -- If all characters are contained in one of the sets Left and Right,
+ -- then the returned string is empty.
+
+ and then
+ (if (for all K in Source'Range =>
+ Ada.Strings.Maps.Is_In (Source (K), Left))
+ or
+ (for all K in Source'Range =>
+ Ada.Strings.Maps.Is_In (Source (K), Right))
+ then Trim'Result = ""
+
+ -- Otherwise, the returned string is a slice of Source
+
+ else
+ (for some Low in Source'Range =>
+ (for some High in Source'Range =>
+
+ -- Trim returns the slice of Source between Low and High
+
+ Trim'Result = Source (Low .. High)
+
+ -- Characters at the bounds of the returned string are
+ -- not contained in Left or Right.
+
+ and then not Ada.Strings.Maps.Is_In (Source (Low), Left)
+ and then not Ada.Strings.Maps.Is_In (Source (High), Right)
+
+ -- All characters before Low are contained in Left.
+ -- All characters after High are contained in Right.
+
+ and then
+ (for all K in Source'Range =>
+ (if K < Low
+ then
+ Ada.Strings.Maps.Is_In (Source (K), Left))
+ and then
+ (if K > High then
+ Ada.Strings.Maps.Is_In (Source (K), Right)))))),
Global => null;
-- Returns the string obtained by removing from Source all leading
-- characters in Left and all trailing characters in Right.
@@ -521,8 +1233,33 @@ package Ada.Strings.Fixed with SPARK_Mode is
Count : Natural;
Pad : Character := Space) return String
with
- Post => Head'Result'Length = Count,
- Global => null;
+ Post =>
+
+ -- Lower bound of the returned string is 1
+
+ Head'Result'First = 1
+
+ -- Length of the returned string is Count.
+
+ and then Head'Result'Length = Count,
+
+ Contract_Cases =>
+
+ -- If Count <= Source'Length, then the first Count characters of
+ -- Source are returned.
+
+ (Count <= Source'Length =>
+ Head'Result = Source (Source'First .. Source'First - 1 + Count),
+
+ -- Otherwise, the returned string is Source concatenated with
+ -- Count - Source'Length Pad characters.
+
+ others =>
+ Head'Result (1 .. Source'Length) = Source
+ and then
+ Head'Result (Source'Length + 1 .. Count)
+ = (1 .. Count - Source'Length => Pad)),
+ Global => null;
-- Returns a string of length Count. If Count <= Source'Length, the string
-- comprises the first Count characters of Source. Otherwise, its contents
-- are Source concatenated with Count - Source'Length Pad characters.
@@ -547,7 +1284,44 @@ package Ada.Strings.Fixed with SPARK_Mode is
Count : Natural;
Pad : Character := Space) return String
with
- Post => Tail'Result'Length = Count,
+ Post =>
+
+ -- Lower bound of the returned string is 1
+
+ Tail'Result'First = 1
+
+ -- Length of the returned string is Count
+
+ and then Tail'Result'Length = Count,
+ Contract_Cases =>
+
+ -- If Count is zero, then the returned string is empty
+
+ (Count = 0 =>
+ Tail'Result = "",
+
+ -- Otherwise, if Count <= Source'Length, then the last Count
+ -- characters of Source are returned.
+
+ (Count in 1 .. Source'Length) =>
+ Tail'Result = Source (Source'Last - Count + 1 .. Source'Last),
+
+ -- Otherwise, the returned string is Count - Source'Length Pad
+ -- characters concatenated with Source.
+
+ others =>
+
+ -- If Source is empty, then the returned string is Count Pad
+ -- characters.
+
+ (if Source'Length = 0
+ then Tail'Result = (1 .. Count => Pad)
+ else
+ Tail'Result (1 .. Count - Source'Length)
+ = (1 .. Count - Source'Length => Pad)
+ and then
+ Tail'Result (Count - Source'Length + 1 .. Tail'Result'Last)
+ = Source)),
Global => null;
-- Returns a string of length Count. If Count <= Source'Length, the string
-- comprises the last Count characters of Source. Otherwise, its contents
@@ -576,7 +1350,19 @@ package Ada.Strings.Fixed with SPARK_Mode is
(Left : Natural;
Right : Character) return String
with
- Post => "*"'Result'Length = Left,
+ Post =>
+
+ -- Lower bound of the returned string is 1
+
+ "*"'Result'First = 1
+
+ -- Length of the returned string
+
+ and then "*"'Result'Length = Left
+
+ -- All characters of the returned string are Right
+
+ and then (for all C of "*"'Result => C = Right),
Global => null;
function "*"
@@ -584,7 +1370,23 @@ package Ada.Strings.Fixed with SPARK_Mode is
Right : String) return String
with
Pre => (if Right'Length /= 0 then Left <= Natural'Last / Right'Length),
- Post => "*"'Result'Length = Left * Right'Length,
+
+ Post =>
+
+ -- Lower bound of the returned string is 1
+
+ "*"'Result'First = 1
+
+ -- Length of the returned string
+
+ and then "*"'Result'Length = Left * Right'Length
+
+ -- Content of the string is Right concatenated with itself Left times
+
+ and then
+ (for all J in 0 .. Left - 1 =>
+ "*"'Result (J * Right'Length + 1 .. (J + 1) * Right'Length)
+ = Right),
Global => null;
-- These functions replicate a character or string a specified number of
diff --git a/gcc/ada/libgnat/a-strmap.ads b/gcc/ada/libgnat/a-strmap.ads
index ab59402..c922f4e 100644
--- a/gcc/ada/libgnat/a-strmap.ads
+++ b/gcc/ada/libgnat/a-strmap.ads
@@ -33,6 +33,12 @@
-- --
------------------------------------------------------------------------------
+-- Preconditions in this unit are meant for analysis only, not for run-time
+-- checking, so that the expected exceptions are raised. This is enforced by
+-- setting the corresponding assertion policy to Ignore.
+
+pragma Assertion_Policy (Pre => Ignore);
+
with Ada.Characters.Latin_1;
package Ada.Strings.Maps is
@@ -61,23 +67,85 @@ package Ada.Strings.Maps is
type Character_Ranges is array (Positive range <>) of Character_Range;
- function To_Set (Ranges : Character_Ranges) return Character_Set;
-
- function To_Set (Span : Character_Range) return Character_Set;
-
- function To_Ranges (Set : Character_Set) return Character_Ranges;
+ function To_Set (Ranges : Character_Ranges) return Character_Set with
+ Post =>
+ (if Ranges'Length = 0 then To_Set'Result = Null_Set)
+ and then
+ (for all Char in Character =>
+ (if Is_In (Char, To_Set'Result)
+ then (for some Span of Ranges => Char in Span.Low .. Span.High)))
+ and then
+ (for all Span of Ranges =>
+ (for all Char in Span.Low .. Span.High =>
+ Is_In (Char, To_Set'Result)));
+
+ function To_Set (Span : Character_Range) return Character_Set with
+ Post =>
+ (if Span.High < Span.Low then To_Set'Result = Null_Set)
+ and then
+ (for all Char in Character =>
+ (if Is_In (Char, To_Set'Result) then Char in Span.Low .. Span.High))
+ and then
+ (for all Char in Span.Low .. Span.High => Is_In (Char, To_Set'Result));
+
+ function To_Ranges (Set : Character_Set) return Character_Ranges with
+ Post =>
+ (if Set = Null_Set then To_Ranges'Result'Length = 0)
+ and then
+ (for all Char in Character =>
+ (if Is_In (Char, Set)
+ then
+ (for some Span of To_Ranges'Result =>
+ Char in Span.Low .. Span.High)))
+ and then
+ (for all Span of To_Ranges'Result =>
+ (for all Char in Span.Low .. Span.High => Is_In (Char, Set)));
----------------------------------
-- Operations on Character Sets --
----------------------------------
- function "=" (Left, Right : Character_Set) return Boolean;
-
- function "not" (Right : Character_Set) return Character_Set;
- function "and" (Left, Right : Character_Set) return Character_Set;
- function "or" (Left, Right : Character_Set) return Character_Set;
- function "xor" (Left, Right : Character_Set) return Character_Set;
- function "-" (Left, Right : Character_Set) return Character_Set;
+ function "=" (Left, Right : Character_Set) return Boolean with
+ Post =>
+ "="'Result
+ =
+ (for all Char in Character =>
+ (Is_In (Char, Left) = Is_In (Char, Right)));
+
+ function "not" (Right : Character_Set) return Character_Set with
+ Post =>
+ (for all Char in Character =>
+ (Is_In (Char, "not"'Result)
+ =
+ not Is_In (Char, Right)));
+
+ function "and" (Left, Right : Character_Set) return Character_Set with
+ Post =>
+ (for all Char in Character =>
+ (Is_In (Char, "and"'Result)
+ =
+ (Is_In (Char, Left) and Is_In (Char, Right))));
+
+ function "or" (Left, Right : Character_Set) return Character_Set with
+ Post =>
+ (for all Char in Character =>
+ (Is_In (Char, "or"'Result)
+ =
+ (Is_In (Char, Left) or Is_In (Char, Right))));
+
+ function "xor" (Left, Right : Character_Set) return Character_Set with
+ Post =>
+ (for all Char in Character =>
+ (Is_In (Char, "xor"'Result)
+ =
+ (Is_In (Char, Left) xor Is_In (Char, Right))));
+
+ function "-" (Left, Right : Character_Set) return Character_Set with
+ Post =>
+ (for all Char in Character =>
+ (Is_In (Char, "-"'Result)
+ =
+ (Is_In (Char, Left) and not Is_In (Char, Right))));
function Is_In
(Element : Character;
@@ -85,20 +153,54 @@ package Ada.Strings.Maps is
function Is_Subset
(Elements : Character_Set;
- Set : Character_Set) return Boolean;
+ Set : Character_Set) return Boolean
+ with
+ Post =>
+ Is_Subset'Result
+ =
+ (for all Char in Character =>
+ (if Is_In (Char, Elements) then Is_In (Char, Set)));
function "<="
(Left : Character_Set;
- Right : Character_Set) return Boolean
+ Right : Character_Set) return Boolean
renames Is_Subset;
subtype Character_Sequence is String;
-- Alternative representation for a set of character values
- function To_Set (Sequence : Character_Sequence) return Character_Set;
- function To_Set (Singleton : Character) return Character_Set;
-
- function To_Sequence (Set : Character_Set) return Character_Sequence;
+ function To_Set (Sequence : Character_Sequence) return Character_Set with
+ Post =>
+ (if Sequence'Length = 0 then To_Set'Result = Null_Set)
+ and then
+ (for all Char in Character =>
+ (if Is_In (Char, To_Set'Result)
+ then (for some X of Sequence => Char = X)))
+ and then
+ (for all Char of Sequence => Is_In (Char, To_Set'Result));
+
+ function To_Set (Singleton : Character) return Character_Set with
+ Post =>
+ Is_In (Singleton, To_Set'Result)
+ and then
+ (for all Char in Character =>
+ (if Char /= Singleton
+ then not Is_In (Char, To_Set'Result)));
+
+ function To_Sequence (Set : Character_Set) return Character_Sequence with
+ Post =>
+ (if Set = Null_Set then To_Sequence'Result'Length = 0)
+ and then
+ (for all Char in Character =>
+ (if Is_In (Char, Set)
+ then (for some X of To_Sequence'Result => Char = X)))
+ and then
+ (for all Char of To_Sequence'Result => Is_In (Char, Set))
+ and then
+ (for all J in To_Sequence'Result'Range =>
+ (for all K in To_Sequence'Result'Range =>
+ (if J /= K
+ then To_Sequence'Result (J) /= To_Sequence'Result (K))));
------------------------------------
-- Character Mapping Declarations --
@@ -119,13 +221,48 @@ package Ada.Strings.Maps is
----------------------------
function To_Mapping
- (From, To : Character_Sequence) return Character_Mapping;
+ (From, To : Character_Sequence) return Character_Mapping
+ with
+ Pre =>
+ From'Length = To'Length
+ and then
+ (for all J in From'Range =>
+ (for all K in From'Range =>
+ (if J /= K then From (J) /= From (K)))),
+ Post =>
+ (if From = To then To_Mapping'Result = Identity)
+ and then
+ (for all Char in Character =>
+ ((for all J in From'Range =>
+ (if From (J) = Char
+ then Value (To_Mapping'Result, Char)
+ = To (J - From'First + To'First)))
+ and then
+ (if (for all X of From => Char /= X)
+ then Value (To_Mapping'Result, Char) = Char)));
function To_Domain
- (Map : Character_Mapping) return Character_Sequence;
+ (Map : Character_Mapping) return Character_Sequence with
+ Post =>
+ (if Map = Identity then To_Domain'Result'Length = 0)
+ and then
+ To_Domain'Result'First = 1
+ and then
+ (for all Char in Character =>
+ (if (for all X of To_Domain'Result => X /= Char)
+ then Value (Map, Char) = Char))
+ and then
+ (for all Char of To_Domain'Result => Value (Map, Char) /= Char);
function To_Range
- (Map : Character_Mapping) return Character_Sequence;
+ (Map : Character_Mapping) return Character_Sequence with
+ Post =>
+ To_Range'Result'First = 1
+ and then
+ To_Range'Result'Last = To_Domain (Map)'Last
+ and then
+ (for all J in To_Range'Result'Range =>
+ To_Range'Result (J) = Value (Map, To_Domain (Map) (J)));
type Character_Mapping_Function is
access function (From : Character) return Character;
diff --git a/gcc/ada/libgnat/a-stzhas.adb b/gcc/ada/libgnat/a-stzhas.adb
index 43abb80..c055de6 100644
--- a/gcc/ada/libgnat/a-stzhas.adb
+++ b/gcc/ada/libgnat/a-stzhas.adb
@@ -29,8 +29,14 @@
-- --
------------------------------------------------------------------------------
--- 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.
+with System.String_Hash;
-pragma No_Body;
+function Ada.Strings.Wide_Wide_Hash
+ (Key : Wide_Wide_String) return Containers.Hash_Type
+is
+ use Ada.Containers;
+ function Hash_Fun is new System.String_Hash.Hash
+ (Wide_Wide_Character, Wide_Wide_String, Hash_Type);
+begin
+ return Hash_Fun (Key);
+end Ada.Strings.Wide_Wide_Hash;
diff --git a/gcc/ada/libgnat/a-stzhas.ads b/gcc/ada/libgnat/a-stzhas.ads
index 0c87672..dea0ff1 100644
--- a/gcc/ada/libgnat/a-stzhas.ads
+++ b/gcc/ada/libgnat/a-stzhas.ads
@@ -13,13 +13,9 @@
-- --
------------------------------------------------------------------------------
--- Is this really an RM unit? Doc needed???
-
with Ada.Containers;
-with System.String_Hash;
function Ada.Strings.Wide_Wide_Hash
-is new System.String_Hash.Hash
- (Wide_Wide_Character, Wide_Wide_String, Containers.Hash_Type);
+ (Key : Wide_Wide_String) return Containers.Hash_Type;
pragma Pure (Ada.Strings.Wide_Wide_Hash);
diff --git a/gcc/ada/libgnat/a-tags.adb b/gcc/ada/libgnat/a-tags.adb
index 798780a..7138f76 100644
--- a/gcc/ada/libgnat/a-tags.adb
+++ b/gcc/ada/libgnat/a-tags.adb
@@ -30,7 +30,6 @@
------------------------------------------------------------------------------
with Ada.Exceptions;
-with Ada.Unchecked_Conversion;
with System.HTable;
with System.Storage_Elements; use System.Storage_Elements;
@@ -96,12 +95,6 @@ package body Ada.Tags is
function To_Tag is
new Unchecked_Conversion (Integer_Address, Tag);
- function To_Addr_Ptr is
- new Ada.Unchecked_Conversion (System.Address, Addr_Ptr);
-
- function To_Address is
- new Ada.Unchecked_Conversion (Tag, System.Address);
-
function To_Dispatch_Table_Ptr is
new Ada.Unchecked_Conversion (Tag, Dispatch_Table_Ptr);
@@ -114,9 +107,6 @@ package body Ada.Tags is
function To_Tag_Ptr is
new Ada.Unchecked_Conversion (System.Address, Tag_Ptr);
- function To_Type_Specific_Data_Ptr is
- new Ada.Unchecked_Conversion (System.Address, Type_Specific_Data_Ptr);
-
-------------------------------
-- Inline_Always Subprograms --
-------------------------------
@@ -125,40 +115,6 @@ package body Ada.Tags is
-- avoid defeating the frontend inlining mechanism and thus ensure the
-- generation of their correct debug info.
- -------------------
- -- CW_Membership --
- -------------------
-
- -- Canonical implementation of Classwide Membership corresponding to:
-
- -- Obj in Typ'Class
-
- -- Each dispatch table contains a reference to a table of ancestors (stored
- -- in the first part of the Tags_Table) and a count of the level of
- -- inheritance "Idepth".
-
- -- Obj is in Typ'Class if Typ'Tag is in the table of ancestors that are
- -- contained in the dispatch table referenced by Obj'Tag . Knowing the
- -- level of inheritance of both types, this can be computed in constant
- -- time by the formula:
-
- -- TSD (Obj'tag).Tags_Table (TSD (Obj'tag).Idepth - TSD (Typ'tag).Idepth)
- -- = Typ'tag
-
- function CW_Membership (Obj_Tag : Tag; Typ_Tag : Tag) return Boolean is
- Obj_TSD_Ptr : constant Addr_Ptr :=
- To_Addr_Ptr (To_Address (Obj_Tag) - DT_Typeinfo_Ptr_Size);
- Typ_TSD_Ptr : constant Addr_Ptr :=
- To_Addr_Ptr (To_Address (Typ_Tag) - DT_Typeinfo_Ptr_Size);
- Obj_TSD : constant Type_Specific_Data_Ptr :=
- To_Type_Specific_Data_Ptr (Obj_TSD_Ptr.all);
- Typ_TSD : constant Type_Specific_Data_Ptr :=
- To_Type_Specific_Data_Ptr (Typ_TSD_Ptr.all);
- Pos : constant Integer := Obj_TSD.Idepth - Typ_TSD.Idepth;
- begin
- return Pos >= 0 and then Obj_TSD.Tags_Table (Pos) = Typ_Tag;
- end CW_Membership;
-
----------------------
-- Get_External_Tag --
----------------------
diff --git a/gcc/ada/libgnat/a-tags.ads b/gcc/ada/libgnat/a-tags.ads
index fb386c3..203f7ca 100644
--- a/gcc/ada/libgnat/a-tags.ads
+++ b/gcc/ada/libgnat/a-tags.ads
@@ -65,6 +65,7 @@
-- length depends on the number of interfaces covered by a tagged type.
with System.Storage_Elements;
+with Ada.Unchecked_Conversion;
package Ada.Tags is
pragma Preelaborate;
@@ -501,10 +502,6 @@ private
-- dispatch table, return the tagged kind of a type in the context of
-- concurrency and limitedness.
- function CW_Membership (Obj_Tag : Tag; Typ_Tag : Tag) return Boolean;
- -- Given the tag of an object and the tag associated to a type, return
- -- true if Obj is in Typ'Class.
-
function IW_Membership (This : System.Address; T : Tag) return Boolean;
-- Ada 2005 (AI-251): General routine that checks if a given object
-- implements a tagged type. Its common usage is to check if Obj is in
@@ -623,4 +620,49 @@ private
-- This type is used by the frontend to generate the code that handles
-- dispatch table slots of types declared at the local level.
+ -------------------
+ -- CW_Membership --
+ -------------------
+
+ function To_Address is
+ new Ada.Unchecked_Conversion (Tag, System.Address);
+
+ function To_Addr_Ptr is
+ new Ada.Unchecked_Conversion (System.Address, Addr_Ptr);
+
+ function To_Type_Specific_Data_Ptr is
+ new Ada.Unchecked_Conversion (System.Address, Type_Specific_Data_Ptr);
+
+ -- Canonical implementation of Classwide Membership corresponding to:
+
+ -- Obj in Typ'Class
+
+ -- Each dispatch table contains a reference to a table of ancestors (stored
+ -- in the first part of the Tags_Table) and a count of the level of
+ -- inheritance "Idepth".
+
+ -- Obj is in Typ'Class if Typ'Tag is in the table of ancestors that are
+ -- contained in the dispatch table referenced by Obj'Tag . Knowing the
+ -- level of inheritance of both types, this can be computed in constant
+ -- time by the formula:
+
+ -- TSD (Obj'tag).Tags_Table (TSD (Obj'tag).Idepth - TSD (Typ'tag).Idepth)
+ -- = Typ'tag
+
+ function CW_Membership (Obj_Tag : Tag; Typ_Tag : Tag) return Boolean is
+ (declare
+ Obj_TSD_Ptr : constant Addr_Ptr :=
+ To_Addr_Ptr (To_Address (Obj_Tag) - DT_Typeinfo_Ptr_Size);
+ Typ_TSD_Ptr : constant Addr_Ptr :=
+ To_Addr_Ptr (To_Address (Typ_Tag) - DT_Typeinfo_Ptr_Size);
+ Obj_TSD : constant Type_Specific_Data_Ptr :=
+ To_Type_Specific_Data_Ptr (Obj_TSD_Ptr.all);
+ Typ_TSD : constant Type_Specific_Data_Ptr :=
+ To_Type_Specific_Data_Ptr (Typ_TSD_Ptr.all);
+ Pos : constant Integer := Obj_TSD.Idepth - Typ_TSD.Idepth;
+ begin
+ Pos >= 0 and then Obj_TSD.Tags_Table (Pos) = Typ_Tag);
+ -- Given the tag of an object and the tag associated to a type, return
+ -- true if Obj is in Typ'Class.
+
end Ada.Tags;
diff --git a/gcc/ada/libgnat/a-ticoau.adb b/gcc/ada/libgnat/a-ticoau.adb
index e4f56dd..cf94305 100644
--- a/gcc/ada/libgnat/a-ticoau.adb
+++ b/gcc/ada/libgnat/a-ticoau.adb
@@ -30,22 +30,19 @@
------------------------------------------------------------------------------
with Ada.Text_IO.Generic_Aux; use Ada.Text_IO.Generic_Aux;
-with Ada.Text_IO.Float_Aux;
with System.Img_Real; use System.Img_Real;
package body Ada.Text_IO.Complex_Aux is
- package Aux renames Ada.Text_IO.Float_Aux;
-
---------
-- Get --
---------
procedure Get
(File : File_Type;
- ItemR : out Long_Long_Float;
- ItemI : out Long_Long_Float;
+ ItemR : out Num;
+ ItemI : out Num;
Width : Field)
is
Buf : String (1 .. Field'Last);
@@ -95,8 +92,8 @@ package body Ada.Text_IO.Complex_Aux is
procedure Gets
(From : String;
- ItemR : out Long_Long_Float;
- ItemI : out Long_Long_Float;
+ ItemR : out Num;
+ ItemI : out Num;
Last : out Positive)
is
Paren : Boolean;
@@ -139,8 +136,8 @@ package body Ada.Text_IO.Complex_Aux is
procedure Put
(File : File_Type;
- ItemR : Long_Long_Float;
- ItemI : Long_Long_Float;
+ ItemR : Num;
+ ItemI : Num;
Fore : Field;
Aft : Field;
Exp : Field)
@@ -159,8 +156,8 @@ package body Ada.Text_IO.Complex_Aux is
procedure Puts
(To : out String;
- ItemR : Long_Long_Float;
- ItemI : Long_Long_Float;
+ ItemR : Num;
+ ItemI : Num;
Aft : Field;
Exp : Field)
is
@@ -174,9 +171,9 @@ package body Ada.Text_IO.Complex_Aux is
-- Both parts are initially converted with a Fore of 0
Rptr := 0;
- Set_Image_Real (ItemR, R_String, Rptr, 0, Aft, Exp);
+ Set_Image_Real (Long_Long_Float (ItemR), R_String, Rptr, 0, Aft, Exp);
Iptr := 0;
- Set_Image_Real (ItemI, I_String, Iptr, 0, Aft, Exp);
+ Set_Image_Real (Long_Long_Float (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 739dce8..22555cf 100644
--- a/gcc/ada/libgnat/a-ticoau.ads
+++ b/gcc/ada/libgnat/a-ticoau.ads
@@ -30,39 +30,46 @@
------------------------------------------------------------------------------
-- This package contains the routines for Ada.Text_IO.Complex_IO that are
--- shared among separate instantiations of this package. The routines in
--- this package are identical semantically to those in Complex_IO itself,
--- except that the generic parameter Complex has been replaced by separate
--- real and imaginary values of type Long_Long_Float, and default parameters
--- have been removed because they are supplied explicitly by the calls from
--- within the generic template.
+-- shared among separate instantiations of this package. The routines in this
+-- package are identical semantically to those in Complex_IO, except that the
+-- generic parameter Complex has been replaced by separate real and imaginary
+-- parameters, and default parameters have been removed because they are
+-- supplied explicitly by the calls from within the generic template.
+
+with Ada.Text_IO.Float_Aux;
+
+private generic
+
+ type Num is digits <>;
+
+ with package Aux is new Ada.Text_IO.Float_Aux (Num, <>);
package Ada.Text_IO.Complex_Aux is
procedure Get
(File : File_Type;
- ItemR : out Long_Long_Float;
- ItemI : out Long_Long_Float;
+ ItemR : out Num;
+ ItemI : out Num;
Width : Field);
procedure Put
(File : File_Type;
- ItemR : Long_Long_Float;
- ItemI : Long_Long_Float;
+ ItemR : Num;
+ ItemI : Num;
Fore : Field;
Aft : Field;
Exp : Field);
procedure Gets
(From : String;
- ItemR : out Long_Long_Float;
- ItemI : out Long_Long_Float;
+ ItemR : out Num;
+ ItemI : out Num;
Last : out Positive);
procedure Puts
(To : out String;
- ItemR : Long_Long_Float;
- ItemI : Long_Long_Float;
+ ItemR : Num;
+ ItemI : Num;
Aft : Field;
Exp : Field);
diff --git a/gcc/ada/libgnat/a-ticoio.adb b/gcc/ada/libgnat/a-ticoio.adb
index fa52b60..e35a745 100644
--- a/gcc/ada/libgnat/a-ticoio.adb
+++ b/gcc/ada/libgnat/a-ticoio.adb
@@ -29,18 +29,42 @@
-- --
------------------------------------------------------------------------------
-with Ada.Text_IO;
-
with Ada.Text_IO.Complex_Aux;
+with Ada.Text_IO.Float_Aux;
+with System.Val_Flt; use System.Val_Flt;
+with System.Val_LFlt; use System.Val_LFlt;
+with System.Val_LLF; use System.Val_LLF;
package body Ada.Text_IO.Complex_IO is
use Complex_Types;
- package Aux renames Ada.Text_IO.Complex_Aux;
+ package Scalar_Float is new
+ Ada.Text_IO.Float_Aux (Float, Scan_Float);
+
+ package Scalar_Long_Float is new
+ Ada.Text_IO.Float_Aux (Long_Float, Scan_Long_Float);
+
+ package Scalar_Long_Long_Float is new
+ Ada.Text_IO.Float_Aux (Long_Long_Float, Scan_Long_Long_Float);
+
+ package Aux_Float is new
+ Ada.Text_IO.Complex_Aux (Float, Scalar_Float);
+
+ package Aux_Long_Float is new
+ Ada.Text_IO.Complex_Aux (Long_Float, Scalar_Long_Float);
- subtype LLF is Long_Long_Float;
- -- Type used for calls to routines in Aux
+ package Aux_Long_Long_Float is new
+ 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
+ -- is needed. These boolean constants are used to test for this, such that
+ -- only code for the relevant case is included in the instance.
+
+ OK_Float : constant Boolean := Real'Base'Digits <= Float'Digits;
+
+ OK_Long_Float : constant Boolean := Real'Base'Digits <= Long_Float'Digits;
---------
-- Get --
@@ -48,14 +72,24 @@ package body Ada.Text_IO.Complex_IO is
procedure Get
(File : File_Type;
- Item : out Complex_Types.Complex;
+ Item : out Complex;
Width : Field := 0)
is
Real_Item : Real'Base;
Imag_Item : Real'Base;
begin
- Aux.Get (File, LLF (Real_Item), LLF (Imag_Item), Width);
+ if OK_Float then
+ Aux_Float.Get (File, Float (Real_Item), Float (Imag_Item), Width);
+ elsif OK_Long_Float then
+ Aux_Long_Float.Get
+ (File, Long_Float (Real_Item), Long_Float (Imag_Item), Width);
+ else
+ Aux_Long_Long_Float.Get
+ (File, Long_Long_Float (Real_Item), Long_Long_Float (Imag_Item),
+ Width);
+ end if;
+
Item := (Real_Item, Imag_Item);
exception
@@ -67,7 +101,7 @@ package body Ada.Text_IO.Complex_IO is
---------
procedure Get
- (Item : out Complex_Types.Complex;
+ (Item : out Complex;
Width : Field := 0)
is
begin
@@ -80,14 +114,24 @@ package body Ada.Text_IO.Complex_IO is
procedure Get
(From : String;
- Item : out Complex_Types.Complex;
+ Item : out Complex;
Last : out Positive)
is
Real_Item : Real'Base;
Imag_Item : Real'Base;
begin
- Aux.Gets (From, LLF (Real_Item), LLF (Imag_Item), Last);
+ if OK_Float then
+ Aux_Float.Gets (From, Float (Real_Item), Float (Imag_Item), Last);
+ elsif OK_Long_Float then
+ Aux_Long_Float.Gets
+ (From, Long_Float (Real_Item), Long_Float (Imag_Item), Last);
+ else
+ Aux_Long_Long_Float.Gets
+ (From, Long_Long_Float (Real_Item), Long_Long_Float (Imag_Item),
+ Last);
+ end if;
+
Item := (Real_Item, Imag_Item);
exception
@@ -100,13 +144,24 @@ package body Ada.Text_IO.Complex_IO is
procedure Put
(File : File_Type;
- Item : Complex_Types.Complex;
+ Item : Complex;
Fore : Field := Default_Fore;
Aft : Field := Default_Aft;
Exp : Field := Default_Exp)
is
begin
- Aux.Put (File, LLF (Re (Item)), LLF (Im (Item)), Fore, Aft, Exp);
+ if OK_Float then
+ Aux_Float.Put
+ (File, Float (Re (Item)), Float (Im (Item)), Fore, Aft, Exp);
+ elsif OK_Long_Float then
+ Aux_Long_Float.Put
+ (File, Long_Float (Re (Item)), Long_Float (Im (Item)), Fore, Aft,
+ Exp);
+ else
+ Aux_Long_Long_Float.Put
+ (File, Long_Long_Float (Re (Item)), Long_Long_Float (Im (Item)),
+ Fore, Aft, Exp);
+ end if;
end Put;
---------
@@ -114,7 +169,7 @@ package body Ada.Text_IO.Complex_IO is
---------
procedure Put
- (Item : Complex_Types.Complex;
+ (Item : Complex;
Fore : Field := Default_Fore;
Aft : Field := Default_Aft;
Exp : Field := Default_Exp)
@@ -129,12 +184,21 @@ package body Ada.Text_IO.Complex_IO is
procedure Put
(To : out String;
- Item : Complex_Types.Complex;
+ Item : Complex;
Aft : Field := Default_Aft;
Exp : Field := Default_Exp)
is
begin
- Aux.Puts (To, LLF (Re (Item)), LLF (Im (Item)), Aft, Exp);
+ if OK_Float then
+ Aux_Float.Puts (To, Float (Re (Item)), Float (Im (Item)), Aft, Exp);
+ elsif OK_Long_Float then
+ Aux_Long_Float.Puts
+ (To, Long_Float (Re (Item)), Long_Float (Im (Item)), Aft, Exp);
+ else
+ Aux_Long_Long_Float.Puts
+ (To, Long_Long_Float (Re (Item)), Long_Long_Float (Im (Item)),
+ Aft, Exp);
+ end if;
end Put;
end Ada.Text_IO.Complex_IO;
diff --git a/gcc/ada/libgnat/a-tideau.adb b/gcc/ada/libgnat/a-tideau.adb
index caf77e3..ac751c1 100644
--- a/gcc/ada/libgnat/a-tideau.adb
+++ b/gcc/ada/libgnat/a-tideau.adb
@@ -30,28 +30,22 @@
------------------------------------------------------------------------------
with Ada.Text_IO.Generic_Aux; use Ada.Text_IO.Generic_Aux;
-with Ada.Text_IO.Float_Aux; use Ada.Text_IO.Float_Aux;
-
-with System.Img_Dec; use System.Img_Dec;
-with System.Img_LLD; use System.Img_LLD;
-with System.Val_Dec; use System.Val_Dec;
-with System.Val_LLD; use System.Val_LLD;
package body Ada.Text_IO.Decimal_Aux is
- -------------
- -- Get_Dec --
- -------------
+ ---------
+ -- Get --
+ ---------
- function Get_Dec
+ function Get
(File : File_Type;
Width : Field;
- Scale : Integer) return Integer
+ Scale : Integer) return Int
is
Buf : String (1 .. Field'Last);
Ptr : aliased Integer;
Stop : Integer := 0;
- Item : Integer;
+ Item : Int;
begin
if Width /= 0 then
@@ -62,114 +56,42 @@ package body Ada.Text_IO.Decimal_Aux is
Ptr := 1;
end if;
- Item := Scan_Decimal (Buf, Ptr'Access, Stop, Scale);
+ Item := Scan (Buf, Ptr'Access, Stop, Scale);
Check_End_Of_Field (Buf, Stop, Ptr, Width);
return Item;
- end Get_Dec;
-
- -------------
- -- Get_LLD --
- -------------
-
- function Get_LLD
- (File : File_Type;
- Width : Field;
- Scale : Integer) return Long_Long_Integer
- is
- Buf : String (1 .. Field'Last);
- Ptr : aliased Integer;
- Stop : Integer := 0;
- Item : Long_Long_Integer;
+ end Get;
- begin
- if Width /= 0 then
- Load_Width (File, Width, Buf, Stop);
- String_Skip (Buf, Ptr);
- else
- Load_Real (File, Buf, Stop);
- Ptr := 1;
- end if;
+ ----------
+ -- Gets --
+ ----------
- Item := Scan_Long_Long_Decimal (Buf, Ptr'Access, Stop, Scale);
- Check_End_Of_Field (Buf, Stop, Ptr, Width);
- return Item;
- end Get_LLD;
-
- --------------
- -- Gets_Dec --
- --------------
-
- function Gets_Dec
+ function Gets
(From : String;
- Last : not null access Positive;
- Scale : Integer) return Integer
+ Last : out Positive;
+ Scale : Integer) return Int
is
Pos : aliased Integer;
- Item : Integer;
+ Item : Int;
begin
String_Skip (From, Pos);
- Item := Scan_Decimal (From, Pos'Access, From'Last, Scale);
- Last.all := Pos - 1;
+ Item := Scan (From, Pos'Access, From'Last, Scale);
+ Last := Pos - 1;
return Item;
exception
when Constraint_Error =>
- Last.all := Pos - 1;
+ Last := Pos - 1;
raise Data_Error;
- end Gets_Dec;
-
- --------------
- -- Gets_LLD --
- --------------
-
- function Gets_LLD
- (From : String;
- Last : not null access Positive;
- Scale : Integer) return Long_Long_Integer
- is
- Pos : aliased Integer;
- Item : Long_Long_Integer;
-
- begin
- String_Skip (From, Pos);
- Item := Scan_Long_Long_Decimal (From, Pos'Access, From'Last, Scale);
- Last.all := Pos - 1;
- return Item;
-
- exception
- when Constraint_Error =>
- Last.all := Pos - 1;
- raise Data_Error;
- end Gets_LLD;
-
- -------------
- -- Put_Dec --
- -------------
+ end Gets;
- procedure Put_Dec
- (File : File_Type;
- Item : Integer;
- Fore : Field;
- Aft : Field;
- Exp : Field;
- Scale : Integer)
- is
- Buf : String (1 .. Field'Last);
- Ptr : Natural := 0;
-
- begin
- Set_Image_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp);
- Put_Item (File, Buf (1 .. Ptr));
- end Put_Dec;
-
- -------------
- -- Put_LLD --
- -------------
+ ---------
+ -- Put --
+ ---------
- procedure Put_LLD
+ procedure Put
(File : File_Type;
- Item : Long_Long_Integer;
+ Item : Int;
Fore : Field;
Aft : Field;
Exp : Field;
@@ -179,83 +101,51 @@ package body Ada.Text_IO.Decimal_Aux is
Ptr : Natural := 0;
begin
- Set_Image_Long_Long_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp);
+ Set_Image (Item, Buf, Ptr, Scale, Fore, Aft, Exp);
Put_Item (File, Buf (1 .. Ptr));
- end Put_LLD;
+ end Put;
- --------------
- -- Puts_Dec --
- --------------
+ ----------
+ -- Puts --
+ ----------
- procedure Puts_Dec
+ procedure Puts
(To : out String;
- Item : Integer;
+ Item : Int;
Aft : Field;
Exp : Field;
Scale : Integer)
is
- Buf : String (1 .. Field'Last);
+ Buf : String (1 .. Positive'Max (Field'Last, To'Length));
Fore : Integer;
Ptr : Natural := 0;
begin
- -- Compute Fore, allowing for Aft digits and the decimal dot
+ -- Compute Fore, allowing for the decimal dot and Aft digits
- Fore := To'Length - Field'Max (1, Aft) - 1;
+ Fore := To'Length - 1 - Field'Max (1, Aft);
- -- Allow for Exp and two more for E+ or E- if exponent present
+ -- Allow for Exp and one more for E if exponent present
if Exp /= 0 then
- Fore := Fore - 2 - Exp;
+ Fore := Fore - 1 - Field'Max (2, Exp);
end if;
-- Make sure we have enough room
- if Fore < 1 then
+ if Fore < 1 + Boolean'Pos (Item < 0) then
raise Layout_Error;
end if;
-- Do the conversion and check length of result
- Set_Image_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp);
-
- if Ptr > To'Length then
- raise Layout_Error;
- else
- To := Buf (1 .. Ptr);
- end if;
- end Puts_Dec;
-
- --------------
- -- Puts_LLD --
- --------------
-
- procedure Puts_LLD
- (To : out String;
- Item : Long_Long_Integer;
- Aft : Field;
- Exp : Field;
- Scale : Integer)
- is
- Buf : String (1 .. Field'Last);
- Fore : Integer;
- Ptr : Natural := 0;
-
- begin
- Fore :=
- (if Exp = 0 then To'Length - 1 - Aft else To'Length - 2 - Aft - Exp);
-
- if Fore < 1 then
- raise Layout_Error;
- end if;
-
- Set_Image_Long_Long_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp);
+ Set_Image (Item, Buf, Ptr, Scale, Fore, Aft, Exp);
if Ptr > To'Length then
raise Layout_Error;
else
To := Buf (1 .. Ptr);
end if;
- end Puts_LLD;
+ end Puts;
end Ada.Text_IO.Decimal_Aux;
diff --git a/gcc/ada/libgnat/a-tideau.ads b/gcc/ada/libgnat/a-tideau.ads
index e7d7f44..522e351 100644
--- a/gcc/ada/libgnat/a-tideau.ads
+++ b/gcc/ada/libgnat/a-tideau.ads
@@ -29,62 +29,54 @@
-- --
------------------------------------------------------------------------------
--- This package contains the routines for Ada.Text_IO.Decimal_IO that are
--- shared among separate instantiations of this package. The routines in
--- the package are identical semantically to those declared in Text_IO,
--- except that default values have been supplied by the generic, and the
--- Num parameter has been replaced by Integer or Long_Long_Integer, with
--- an additional Scale parameter giving the value of Num'Scale. In addition
--- the Get routines return the value rather than store it in an Out parameter.
+-- This package contains the implementation for Ada.Text_IO.Decimal_IO. The
+-- routines in this package are identical semantically to those in Decimal_IO,
+-- except that the default parameters have been removed because they are
+-- supplied explicitly by the calls from within these units, and there is an
+-- additional Scale parameter giving the value of Num'Scale. In addition the
+-- Get routines return the value rather than store it in an Out parameter.
-private package Ada.Text_IO.Decimal_Aux is
+private generic
+ type Int is range <>;
- function Get_Dec
- (File : File_Type;
- Width : Field;
- Scale : Integer) return Integer;
+ with function Scan
+ (Str : String;
+ Ptr : not null access Integer;
+ Max : Integer;
+ Scale : Integer) return Int;
- function Get_LLD
- (File : File_Type;
- Width : Field;
- Scale : Integer) return Long_Long_Integer;
+ with procedure Set_Image
+ (V : Int;
+ S : in out String;
+ P : in out Natural;
+ Scale : Integer;
+ Fore : Natural;
+ Aft : Natural;
+ Exp : Natural);
+
+package Ada.Text_IO.Decimal_Aux is
- procedure Put_Dec
+ function Get
(File : File_Type;
- Item : Integer;
- Fore : Field;
- Aft : Field;
- Exp : Field;
- Scale : Integer);
+ Width : Field;
+ Scale : Integer) return Int;
- procedure Put_LLD
+ procedure Put
(File : File_Type;
- Item : Long_Long_Integer;
+ Item : Int;
Fore : Field;
Aft : Field;
Exp : Field;
Scale : Integer);
- function Gets_Dec
- (From : String;
- Last : not null access Positive;
- Scale : Integer) return Integer;
-
- function Gets_LLD
+ function Gets
(From : String;
- Last : not null access Positive;
- Scale : Integer) return Long_Long_Integer;
-
- procedure Puts_Dec
- (To : out String;
- Item : Integer;
- Aft : Field;
- Exp : Field;
- Scale : Integer);
+ Last : out Positive;
+ Scale : Integer) return Int;
- procedure Puts_LLD
+ procedure Puts
(To : out String;
- Item : Long_Long_Integer;
+ Item : Int;
Aft : Field;
Exp : Field;
Scale : Integer);
diff --git a/gcc/ada/libgnat/a-tideio.adb b/gcc/ada/libgnat/a-tideio.adb
index 0624c2c..f71cf2d 100644
--- a/gcc/ada/libgnat/a-tideio.adb
+++ b/gcc/ada/libgnat/a-tideio.adb
@@ -29,11 +29,35 @@
-- --
------------------------------------------------------------------------------
+with Interfaces;
with Ada.Text_IO.Decimal_Aux;
+with System.Img_Decimal_32; use System.Img_Decimal_32;
+with System.Img_Decimal_64; use System.Img_Decimal_64;
+with System.Val_Decimal_32; use System.Val_Decimal_32;
+with System.Val_Decimal_64; use System.Val_Decimal_64;
package body Ada.Text_IO.Decimal_IO is
- package Aux renames Ada.Text_IO.Decimal_Aux;
+ subtype Int32 is Interfaces.Integer_32;
+ subtype Int64 is Interfaces.Integer_64;
+
+ package Aux32 is new
+ Ada.Text_IO.Decimal_Aux
+ (Int32,
+ Scan_Decimal32,
+ Set_Image_Decimal32);
+
+ package Aux64 is new
+ Ada.Text_IO.Decimal_Aux
+ (Int64,
+ Scan_Decimal64,
+ Set_Image_Decimal64);
+
+ Need64 : constant Boolean := Num'Size > 32;
+ -- Throughout this generic body, we distinguish between the case where type
+ -- Int32 is acceptable and where type Int64 is needed. This Boolean is used
+ -- to test for these cases and since it is a constant, only code for the
+ -- relevant case will be included in the instance.
Scale : constant Integer := Num'Scale;
@@ -49,10 +73,10 @@ package body Ada.Text_IO.Decimal_IO is
pragma Unsuppress (Range_Check);
begin
- if Num'Size > Integer'Size then
- Item := Num'Fixed_Value (Aux.Get_LLD (File, Width, Scale));
+ if Need64 then
+ Item := Num'Fixed_Value (Aux64.Get (File, Width, Scale));
else
- Item := Num'Fixed_Value (Aux.Get_Dec (File, Width, Scale));
+ Item := Num'Fixed_Value (Aux32.Get (File, Width, Scale));
end if;
exception
@@ -75,12 +99,10 @@ package body Ada.Text_IO.Decimal_IO is
pragma Unsuppress (Range_Check);
begin
- if Num'Size > Integer'Size then
- Item := Num'Fixed_Value
- (Aux.Gets_LLD (From, Last'Unrestricted_Access, Scale));
+ if Need64 then
+ Item := Num'Fixed_Value (Aux64.Gets (From, Last, Scale));
else
- Item := Num'Fixed_Value
- (Aux.Gets_Dec (From, Last'Unrestricted_Access, Scale));
+ Item := Num'Fixed_Value (Aux32.Gets (From, Last, Scale));
end if;
exception
@@ -99,13 +121,12 @@ package body Ada.Text_IO.Decimal_IO is
Exp : Field := Default_Exp)
is
begin
- if Num'Size > Integer'Size then
- Aux.Put_LLD
- (File, Long_Long_Integer'Integer_Value (Item),
- Fore, Aft, Exp, Scale);
+ if Need64 then
+ Aux64.Put
+ (File, Int64'Integer_Value (Item), Fore, Aft, Exp, Scale);
else
- Aux.Put_Dec
- (File, Integer'Integer_Value (Item), Fore, Aft, Exp, Scale);
+ Aux32.Put
+ (File, Int32'Integer_Value (Item), Fore, Aft, Exp, Scale);
end if;
end Put;
@@ -126,11 +147,10 @@ package body Ada.Text_IO.Decimal_IO is
Exp : Field := Default_Exp)
is
begin
- if Num'Size > Integer'Size then
- Aux.Puts_LLD
- (To, Long_Long_Integer'Integer_Value (Item), Aft, Exp, Scale);
+ if Need64 then
+ Aux64.Puts (To, Int64'Integer_Value (Item), Aft, Exp, Scale);
else
- Aux.Puts_Dec (To, Integer'Integer_Value (Item), Aft, Exp, Scale);
+ Aux32.Puts (To, Int32'Integer_Value (Item), Aft, Exp, Scale);
end if;
end Put;
diff --git a/gcc/ada/libgnat/a-tideio__128.adb b/gcc/ada/libgnat/a-tideio__128.adb
new file mode 100644
index 0000000..a8cdf9f
--- /dev/null
+++ b/gcc/ada/libgnat/a-tideio__128.adb
@@ -0,0 +1,177 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . T E X T _ I O . D E C I M A L _ I O --
+-- --
+-- 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 Interfaces;
+with Ada.Text_IO.Decimal_Aux;
+with System.Img_Decimal_32; use System.Img_Decimal_32;
+with System.Img_Decimal_64; use System.Img_Decimal_64;
+with System.Img_Decimal_128; use System.Img_Decimal_128;
+with System.Val_Decimal_32; use System.Val_Decimal_32;
+with System.Val_Decimal_64; use System.Val_Decimal_64;
+with System.Val_Decimal_128; use System.Val_Decimal_128;
+
+package body Ada.Text_IO.Decimal_IO is
+
+ subtype Int32 is Interfaces.Integer_32;
+ subtype Int64 is Interfaces.Integer_64;
+ subtype Int128 is Interfaces.Integer_128;
+
+ package Aux32 is new
+ Ada.Text_IO.Decimal_Aux
+ (Int32,
+ Scan_Decimal32,
+ Set_Image_Decimal32);
+
+ package Aux64 is new
+ Ada.Text_IO.Decimal_Aux
+ (Int64,
+ Scan_Decimal64,
+ Set_Image_Decimal64);
+
+ package Aux128 is new
+ Ada.Text_IO.Decimal_Aux
+ (Int128,
+ Scan_Decimal128,
+ Set_Image_Decimal128);
+
+ Need64 : constant Boolean := Num'Size > 32;
+ Need128 : constant Boolean := Num'Size > 64;
+ -- Throughout this generic body, we distinguish between the case where type
+ -- Int32 is acceptable, where type Int64 is acceptable and where an Int128
+ -- is needed. These boolean constants are used to test for these cases and
+ -- since it is a constant, only code for the relevant case will be included
+ -- in the instance.
+
+ Scale : constant Integer := Num'Scale;
+
+ ---------
+ -- Get --
+ ---------
+
+ procedure Get
+ (File : File_Type;
+ Item : out Num;
+ Width : Field := 0)
+ is
+ pragma Unsuppress (Range_Check);
+
+ begin
+ if Need128 then
+ Item := Num'Fixed_Value (Aux128.Get (File, Width, Scale));
+ elsif Need64 then
+ Item := Num'Fixed_Value (Aux64.Get (File, Width, Scale));
+ else
+ Item := Num'Fixed_Value (Aux32.Get (File, Width, Scale));
+ end if;
+
+ exception
+ when Constraint_Error => raise Data_Error;
+ end Get;
+
+ procedure Get
+ (Item : out Num;
+ Width : Field := 0)
+ is
+ begin
+ Get (Current_In, Item, Width);
+ end Get;
+
+ procedure Get
+ (From : String;
+ Item : out Num;
+ Last : out Positive)
+ is
+ pragma Unsuppress (Range_Check);
+
+ begin
+ if Need128 then
+ Item := Num'Fixed_Value (Aux128.Gets (From, Last, Scale));
+ elsif Need64 then
+ Item := Num'Fixed_Value (Aux64.Gets (From, Last, Scale));
+ else
+ Item := Num'Fixed_Value (Aux32.Gets (From, Last, Scale));
+ end if;
+
+ exception
+ when Constraint_Error => raise Data_Error;
+ end Get;
+
+ ---------
+ -- Put --
+ ---------
+
+ procedure Put
+ (File : File_Type;
+ Item : Num;
+ Fore : Field := Default_Fore;
+ Aft : Field := Default_Aft;
+ Exp : Field := Default_Exp)
+ is
+ begin
+ if Need128 then
+ Aux128.Put
+ (File, Int128'Integer_Value (Item), Fore, Aft, Exp, Scale);
+ elsif Need64 then
+ Aux64.Put
+ (File, Int64'Integer_Value (Item), Fore, Aft, Exp, Scale);
+ else
+ Aux32.Put
+ (File, Int32'Integer_Value (Item), Fore, Aft, Exp, Scale);
+ end if;
+ end Put;
+
+ procedure Put
+ (Item : Num;
+ Fore : Field := Default_Fore;
+ Aft : Field := Default_Aft;
+ Exp : Field := Default_Exp)
+ is
+ begin
+ Put (Current_Out, Item, Fore, Aft, Exp);
+ end Put;
+
+ procedure Put
+ (To : out String;
+ Item : Num;
+ Aft : Field := Default_Aft;
+ Exp : Field := Default_Exp)
+ is
+ begin
+ if Need128 then
+ Aux128.Puts (To, Int128'Integer_Value (Item), Aft, Exp, Scale);
+ elsif Need64 then
+ Aux64.Puts (To, Int64'Integer_Value (Item), Aft, Exp, Scale);
+ else
+ Aux32.Puts (To, Int32'Integer_Value (Item), Aft, Exp, Scale);
+ end if;
+ end Put;
+
+end Ada.Text_IO.Decimal_IO;
diff --git a/gcc/ada/libgnat/a-tifiau.adb b/gcc/ada/libgnat/a-tifiau.adb
new file mode 100644
index 0000000..c6f4430
--- /dev/null
+++ b/gcc/ada/libgnat/a-tifiau.adb
@@ -0,0 +1,159 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . T E X T _ I O . F I X E D _ A U X --
+-- --
+-- 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.Text_IO.Generic_Aux; use Ada.Text_IO.Generic_Aux;
+
+package body Ada.Text_IO.Fixed_Aux is
+
+ ---------
+ -- Get --
+ ---------
+
+ function Get
+ (File : File_Type;
+ Width : Field;
+ Num : Int;
+ Den : Int) return Int
+ is
+ Buf : String (1 .. Field'Last);
+ Ptr : aliased Integer;
+ Stop : Integer := 0;
+ Item : Int;
+
+ begin
+ if Width /= 0 then
+ Load_Width (File, Width, Buf, Stop);
+ String_Skip (Buf, Ptr);
+ else
+ Load_Real (File, Buf, Stop);
+ Ptr := 1;
+ end if;
+
+ Item := Scan (Buf, Ptr'Access, Stop, Num, Den);
+ Check_End_Of_Field (Buf, Stop, Ptr, Width);
+ return Item;
+ end Get;
+
+ ----------
+ -- Gets --
+ ----------
+
+ function Gets
+ (From : String;
+ Last : out Positive;
+ Num : Int;
+ Den : Int) return Int
+ is
+ Pos : aliased Integer;
+ Item : Int;
+
+ begin
+ String_Skip (From, Pos);
+ Item := Scan (From, Pos'Access, From'Last, Num, Den);
+ Last := Pos - 1;
+ return Item;
+
+ exception
+ when Constraint_Error =>
+ Last := Pos - 1;
+ raise Data_Error;
+ end Gets;
+
+ ---------
+ -- Put --
+ ---------
+
+ procedure Put
+ (File : File_Type;
+ Item : Int;
+ Fore : Field;
+ Aft : Field;
+ Exp : Natural;
+ Num : Int;
+ Den : Int;
+ For0 : Natural;
+ Aft0 : Natural)
+ is
+ Buf : String (1 .. Field'Last);
+ Ptr : Natural := 0;
+
+ begin
+ Set_Image (Item, Buf, Ptr, Num, Den, For0, Aft0, Fore, Aft, Exp);
+ Put_Item (File, Buf (1 .. Ptr));
+ end Put;
+
+ ----------
+ -- Puts --
+ ----------
+
+ procedure Puts
+ (To : out String;
+ Item : Int;
+ Aft : Field;
+ Exp : Natural;
+ Num : Int;
+ Den : Int;
+ For0 : Natural;
+ Aft0 : Natural)
+ is
+ Buf : String (1 .. Positive'Max (Field'Last, To'Length));
+ Fore : Integer;
+ Ptr : Natural := 0;
+
+ begin
+ -- Compute Fore, allowing for the decimal dot and Aft digits
+
+ Fore := To'Length - 1 - Field'Max (1, Aft);
+
+ -- Allow for Exp and one more for E if exponent present
+
+ if Exp /= 0 then
+ Fore := Fore - 1 - Field'Max (2, Exp);
+ end if;
+
+ -- Make sure we have enough room
+
+ if Fore < 1 + Boolean'Pos (Item < 0) then
+ raise Layout_Error;
+ end if;
+
+ -- Do the conversion and check length of result
+
+ Set_Image (Item, Buf, Ptr, Num, Den, For0, Aft0, Fore, Aft, Exp);
+
+ if Ptr > To'Length then
+ raise Layout_Error;
+ else
+ To := Buf (1 .. Ptr);
+ end if;
+ end Puts;
+
+end Ada.Text_IO.Fixed_Aux;
diff --git a/gcc/ada/libgnat/a-tifiau.ads b/gcc/ada/libgnat/a-tifiau.ads
new file mode 100644
index 0000000..32701c5
--- /dev/null
+++ b/gcc/ada/libgnat/a-tifiau.ads
@@ -0,0 +1,97 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . T E X T _ I O . F I X E D _ A U X --
+-- --
+-- 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. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains the implementation for Ada.Text_IO.Fixed_IO. The
+-- routines in this package are identical semantically to those in Fixed_IO,
+-- except that the default parameters have been removed because they are
+-- supplied explicitly by the calls from within these units, and there are
+-- additional Num and Den parameters giving the value of Num'Small, as well
+-- as For0 and Aft0 giving some properties of Num'Small. In addition the Get
+-- routines return the value rather than store it in an Out parameter.
+
+private generic
+ type Int is range <>;
+
+ with function Scan
+ (Str : String;
+ Ptr : not null access Integer;
+ Max : Integer;
+ Num : Int;
+ Den : Int) return Int;
+
+ with procedure Set_Image
+ (V : Int;
+ S : in out String;
+ P : in out Natural;
+ Num : Int;
+ Den : Int;
+ For0 : Natural;
+ Aft0 : Natural;
+ Fore : Natural;
+ Aft : Natural;
+ Exp : Natural);
+
+package Ada.Text_IO.Fixed_Aux is
+
+ function Get
+ (File : File_Type;
+ Width : Field;
+ Num : Int;
+ Den : Int) return Int;
+
+ procedure Put
+ (File : File_Type;
+ Item : Int;
+ Fore : Field;
+ Aft : Field;
+ Exp : Natural;
+ Num : Int;
+ Den : Int;
+ For0 : Natural;
+ Aft0 : Natural);
+
+ function Gets
+ (From : String;
+ Last : out Positive;
+ Num : Int;
+ Den : Int) return Int;
+
+ procedure Puts
+ (To : out String;
+ Item : Int;
+ Aft : Field;
+ Exp : Natural;
+ Num : Int;
+ Den : Int;
+ For0 : Natural;
+ Aft0 : Natural);
+
+end Ada.Text_IO.Fixed_Aux;
diff --git a/gcc/ada/libgnat/a-tifiio.adb b/gcc/ada/libgnat/a-tifiio.adb
index 440a77d..412740e 100644
--- a/gcc/ada/libgnat/a-tifiio.adb
+++ b/gcc/ada/libgnat/a-tifiio.adb
@@ -29,18 +29,19 @@
-- --
------------------------------------------------------------------------------
--- Fixed point I/O
--- ---------------
+-- -------------------
+-- - Fixed point I/O -
+-- -------------------
--- The following documents implementation details of the fixed point
--- input/output routines in the GNAT run time. The first part describes
--- general properties of fixed point types as defined by the Ada 95 standard,
+-- The following text documents implementation details of the fixed point
+-- input/output routines in the GNAT runtime. The first part describes the
+-- general properties of fixed point types as defined by the Ada standard,
-- including the Information Systems Annex.
-- Subsequently these are reduced to implementation constraints and the impact
--- of these constraints on a few possible approaches to I/O are given.
+-- of these constraints on a few possible approaches to input/output is given.
-- Based on this analysis, a specific implementation is selected for use in
--- the GNAT run time. Finally, the chosen algorithm is analyzed numerically in
+-- the GNAT runtime. Finally the chosen algorithms are analyzed numerically in
-- order to provide user-level documentation on limits for range and precision
-- of fixed point types as well as accuracy of input/output conversions.
@@ -48,29 +49,27 @@
-- - General Properties of Fixed Point Types -
-- -------------------------------------------
--- Operations on fixed point values, other than input and output, are not
--- important for the purposes of this document. Only the set of values that a
--- fixed point type can represent and the input and output operations are
--- significant.
+-- Operations on fixed point types, other than input/output, are not important
+-- for the purpose of this document. Only the set of values that a fixed point
+-- type can represent and the input/output operations are significant.
-- Values
-- ------
--- Set set of values of a fixed point type comprise the integral
--- multiples of a number called the small of the type. The small can
--- either be a power of ten, a power of two or (if the implementation
--- allows) an arbitrary strictly positive real value.
+-- The set of values of a fixed point type comprise the integral multiples of
+-- a number called the small of the type. The small can be either a power of
+-- two, a power of ten or (if the implementation allows) an arbitrary strictly
+-- positive real value.
--- Implementations need to support fixed-point types with a precision
--- of at least 24 bits, and (in order to comply with the Information
--- Systems Annex) decimal types need to support at least digits 18.
--- For the rest, however, no requirements exist for the minimal small
--- and range that need to be supported.
+-- Implementations need to support ordinary fixed point types with a precision
+-- of at least 24 bits, and (in order to comply with the Information Systems
+-- Annex) decimal fixed point types with at least 18 digits. For the rest, no
+-- requirements exist for the minimal small and range that must be supported.
-- Operations
-- ----------
--- 'Image and 'Wide_Image (see RM 3.5(34))
+-- [Wide_[Wide_]]Image attribute (see RM 3.5(27.1/2))
-- These attributes return a decimal real literal best approximating
-- the value (rounded away from zero if halfway between) with a
@@ -90,7 +89,7 @@
-- attributes, although it would be nice to be able to output more
-- than S'Aft digits after the decimal point for values of subtype S.
--- 'Value and 'Wide_Value attribute (RM 3.5(40-55))
+-- [Wide_[Wide_]]Value attribute (RM 3.5(39.1/2))
-- Since the input can be given in any base in the range 2..16,
-- accurate conversion to a fixed point number may require
@@ -112,202 +111,154 @@
-- Implementation Strategies
-- -------------------------
--- * Float arithmetic
+-- * Floating point arithmetic
-- * Arbitrary-precision integer arithmetic
-- * Fixed-precision integer arithmetic
--- Although it seems convenient to convert fixed point numbers to floating-
+-- Although it seems convenient to convert fixed point numbers to floating
-- point and then print them, this leads to a number of restrictions.
-- The first one is precision. The widest floating-point type generally
-- available has 53 bits of mantissa. This means that Fine_Delta cannot
-- be less than 2.0**(-53).
--- In GNAT, Fine_Delta is 2.0**(-63), and Duration for example is a
--- 64-bit type. It would still be possible to use multi-precision
--- floating-point to perform calculations using longer mantissas,
--- but this is a much harder approach.
+-- In GNAT, Fine_Delta is 2.0**(-63), and Duration for example is a 64-bit
+-- type. This means that a floating-point type with 64 bits of mantissa needs
+-- to be used, which is only generally available on the x86 architecture. It
+-- would still be possible to use multi-precision floating point to perform
+-- calculations using longer mantissas, but this is a much harder approach.
--- The base conversions needed for input and output of (non-decimal)
--- fixed point types can be seen as pairs of integer multiplications
--- and divisions.
+-- The base conversions needed for input/output of (non-decimal) fixed point
+-- types can be seen as pairs of integer multiplications and divisions.
--- Arbitrary-precision integer arithmetic would be suitable for the job
--- at hand, but has the draw-back that it is very heavy implementation-wise.
+-- Arbitrary-precision integer arithmetic would be suitable for the job at
+-- hand, but has the drawback that it is very heavy implementation-wise.
-- Especially in embedded systems, where fixed point types are often used,
-- it may not be desirable to require large amounts of storage and time
-- for fixed I/O operations.
-- Fixed-precision integer arithmetic has the advantage of simplicity and
-- speed. For the most common fixed point types this would be a perfect
--- solution. The downside however may be a too limited set of acceptable
+-- solution. The downside however may be a restricted set of acceptable
-- fixed point types.
--- Extra Precision
--- ---------------
-
--- Using a scaled divide which truncates and returns a remainder R,
--- another E trailing digits can be calculated by computing the value
--- (R * (10.0**E)) / Z using another scaled divide. This procedure
--- can be repeated to compute an arbitrary number of digits in linear
--- time and storage. The last scaled divide should be rounded, with
--- a possible carry propagating to the more significant digits, to
--- ensure correct rounding of the unit in the last place.
-
--- An extension of this technique is to limit the value of Q to 9 decimal
--- digits, since 32-bit integers can be much more efficient than 64-bit
--- integers to output.
-
-with Interfaces; use Interfaces;
-with System.Arith_64; use System.Arith_64;
-with System.Img_Real; use System.Img_Real;
-with Ada.Text_IO; use Ada.Text_IO;
-with Ada.Text_IO.Float_Aux;
-with Ada.Text_IO.Generic_Aux;
-
-package body Ada.Text_IO.Fixed_IO is
-
- -- Note: we still use the floating-point I/O routines for input of
- -- ordinary fixed-point and output using exponent format. This will
- -- result in inaccuracies for fixed point types with a small that is
- -- not a power of two, and for types that require more precision than
- -- is available in Long_Long_Float.
-
- package Aux renames Ada.Text_IO.Float_Aux;
-
- Extra_Layout_Space : constant Field := 5 + Num'Fore;
- -- Extra space that may be needed for output of sign, decimal point,
- -- exponent indication and mandatory decimals after and before the
- -- decimal point. A string with length
-
- -- Fore + Aft + Exp + Extra_Layout_Space
-
- -- is always long enough for formatting any fixed point number
-
- -- Implementation of Put routines
-
- -- The following section describes a specific implementation choice for
- -- performing base conversions needed for output of values of a fixed
- -- point type T with small T'Small. The goal is to be able to output
- -- all values of types with a precision of 64 bits and a delta of at
- -- least 2.0**(-63), as these are current GNAT limitations already.
-
- -- The chosen algorithm uses fixed precision integer arithmetic for
- -- reasons of simplicity and efficiency. It is important to understand
- -- in what ways the most simple and accurate approach to fixed point I/O
- -- is limiting, before considering more complicated schemes.
-
- -- Without loss of generality assume T has a range (-2.0**63) * T'Small
- -- .. (2.0**63 - 1) * T'Small, and is output with Aft digits after the
- -- decimal point and T'Fore - 1 before. If T'Small is integer, or
- -- 1.0 / T'Small is integer, let S = T'Small and E = 0. For other T'Small,
- -- let S and E be integers such that S / 10**E best approximates T'Small
- -- and S is in the range 10**17 .. 10**18 - 1. The extra decimal scaling
- -- factor 10**E can be trivially handled during final output, by adjusting
- -- the decimal point or exponent.
-
- -- Convert a value X * S of type T to a 64-bit integer value Q equal
- -- to 10.0**D * (X * S) rounded to the nearest integer.
- -- This conversion is a scaled integer divide of the form
-
- -- Q := (X * Y) / Z,
-
- -- where all variables are 64-bit signed integers using 2's complement,
- -- and both the multiplication and division are done using full
- -- intermediate precision. The final decimal value to be output is
-
- -- Q * 10**(E-D)
-
- -- This value can be written to the output file or to the result string
- -- according to the format described in RM A.3.10. The details of this
- -- operation are omitted here.
-
- -- A 64-bit value can contain all integers with 18 decimal digits, but
- -- not all with 19 decimal digits. If the total number of requested output
- -- digits (Fore - 1) + Aft is greater than 18, for purposes of the
- -- conversion Aft is adjusted to 18 - (Fore - 1). In that case, or
- -- when Fore > 19, trailing zeros can complete the output after writing
- -- the first 18 significant digits, or the technique described in the
- -- next section can be used.
-
- -- The final expression for D is
-
- -- D := Integer'Max (-18, Integer'Min (Aft, 18 - (Fore - 1)));
-
- -- For Y and Z the following expressions can be derived:
-
- -- Q / (10.0**D) = X * S
-
- -- Q = X * S * (10.0**D) = (X * Y) / Z
-
- -- S * 10.0**D = Y / Z;
-
- -- If S is an integer greater than or equal to one, then Fore must be at
- -- least 20 in order to print T'First, which is at most -2.0**63.
- -- This means D < 0, so use
-
- -- (1) Y = -S and Z = -10**(-D)
-
- -- If 1.0 / S is an integer greater than one, use
-
- -- (2) Y = -10**D and Z = -(1.0 / S), for D >= 0
-
- -- or
-
- -- (3) Y = 1 and Z = (1.0 / S) * 10**(-D), for D < 0
-
- -- Negative values are used for nominator Y and denominator Z, so that S
- -- can have a maximum value of 2.0**63 and a minimum of 2.0**(-63).
- -- For Z in -1 .. -9, Fore will still be 20, and D will be negative, as
- -- (-2.0**63) / -9 is greater than 10**18. In these cases there is room
- -- in the denominator for the extra decimal scaling required, so case (3)
- -- will not overflow.
-
- pragma Assert (System.Fine_Delta >= 2.0**(-63));
- pragma Assert (Num'Small in 2.0**(-63) .. 2.0**63);
- pragma Assert (Num'Fore <= 37);
- -- These assertions need to be relaxed to allow for a Small of
- -- 2.0**(-64) at least, since there is an ACATS test for this ???
+-- Implementation Choices
+-- ----------------------
- Max_Digits : constant := 18;
- -- Maximum number of decimal digits that can be represented in a
- -- 64-bit signed number, see above
+-- The current implementation in the GNAT runtime uses fixed-precision integer
+-- arithmetic for fixed point types whose Small is the ratio of two integers
+-- whose magnitude is bounded relatively to the size of the mantissa, with a
+-- two-tiered approach for 32-bit and 64-bit fixed point types. For the other
+-- fixed point types, the implementation uses floating-point arithmetic.
- -- The constants E0 .. E5 implement a binary search for the appropriate
- -- power of ten to scale the small so that it has one digit before the
- -- decimal point.
+-- The exact requirements of the algorithms are analyzed and documented along
+-- with the implementation in their respective units.
- subtype Int is Integer;
- E0 : constant Int := -(20 * Boolean'Pos (Num'Small >= 1.0E1));
- E1 : constant Int := E0 + 10 * Boolean'Pos (Num'Small * 10.0**E0 < 1.0E-10);
- E2 : constant Int := E1 + 5 * Boolean'Pos (Num'Small * 10.0**E1 < 1.0E-5);
- E3 : constant Int := E2 + 3 * Boolean'Pos (Num'Small * 10.0**E2 < 1.0E-3);
- E4 : constant Int := E3 + 2 * Boolean'Pos (Num'Small * 10.0**E3 < 1.0E-1);
- E5 : constant Int := E4 + 1 * Boolean'Pos (Num'Small * 10.0**E4 < 1.0E-0);
-
- Scale : constant Integer := E5;
-
- pragma Assert (Num'Small * 10.0**Scale >= 1.0
- and then Num'Small * 10.0**Scale < 10.0);
-
- Exact : constant Boolean :=
- Float'Floor (Num'Small) = Float'Ceiling (Num'Small)
- or else Float'Floor (1.0 / Num'Small) = Float'Ceiling (1.0 / Num'Small)
- or else Num'Small >= 10.0**Max_Digits;
- -- True iff a numerator and denominator can be calculated such that
- -- their ratio exactly represents the small of Num.
-
- procedure Put
- (To : out String;
- Last : out Natural;
- Item : Num;
- Fore : Integer;
- Aft : Field;
- Exp : Field);
- -- Actual output function, used internally by all other Put routines.
- -- The formal Fore is an Integer, not a Field, because the routine is
- -- also called from the version of Put that performs I/O to a string,
- -- where the starting position depends on the size of the String, and
- -- bears no relation to the bounds of Field.
+with Interfaces;
+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.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;
+
+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.
+
+ subtype Int32 is Interfaces.Integer_32; use type Int32;
+ subtype Int64 is Interfaces.Integer_64; use type Int64;
+
+ package Aux32 is new
+ Ada.Text_IO.Fixed_Aux (Int32, Scan_Fixed32, Set_Image_Fixed32);
+
+ 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);
+
+ -- 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
+ -- to test for this, such that only code for the relevant case is included
+ -- in the instance; that's why the computation of their value must be fully
+ -- static (although it is not a static expressions in the RM sense).
+
+ OK_Get_32 : constant Boolean :=
+ Num'Base'Object_Size <= 32
+ and then
+ ((Num'Small_Numerator = 1 and then Num'Small_Denominator <= 2**31)
+ or else
+ (Num'Small_Denominator = 1 and then Num'Small_Numerator <= 2**31)
+ or else
+ (Num'Small_Numerator <= 2**27
+ and then Num'Small_Denominator <= 2**27));
+ -- These conditions are derived from the prerequisites of System.Value_F
+
+ OK_Put_32 : constant Boolean :=
+ Num'Base'Object_Size <= 32
+ and then
+ ((Num'Small_Numerator = 1 and then Num'Small_Denominator <= 2**31)
+ or else
+ (Num'Small_Denominator = 1 and then Num'Small_Numerator <= 2**31)
+ or else
+ (Num'Small_Numerator < Num'Small_Denominator
+ and then Num'Small_Denominator <= 2**27)
+ or else
+ (Num'Small_Denominator < Num'Small_Numerator
+ and then Num'Small_Numerator <= 2**25));
+ -- These conditions are derived from the prerequisites of System.Image_F
+
+ OK_Get_64 : constant Boolean :=
+ Num'Base'Object_Size <= 64
+ and then
+ ((Num'Small_Numerator = 1 and then Num'Small_Denominator <= 2**63)
+ or else
+ (Num'Small_Denominator = 1 and then Num'Small_Numerator <= 2**63)
+ or else
+ (Num'Small_Numerator <= 2**59
+ and then Num'Small_Denominator <= 2**59));
+ -- These conditions are derived from the prerequisites of System.Value_F
+
+ OK_Put_64 : constant Boolean :=
+ Num'Base'Object_Size <= 64
+ and then
+ ((Num'Small_Numerator = 1 and then Num'Small_Denominator <= 2**63)
+ or else
+ (Num'Small_Denominator = 1 and then Num'Small_Numerator <= 2**63)
+ or else
+ (Num'Small_Numerator < Num'Small_Denominator
+ and then Num'Small_Denominator <= 2**59)
+ or else
+ (Num'Small_Denominator < Num'Small_Numerator
+ and then Num'Small_Numerator <= 2**53));
+ -- These conditions are derived from the prerequisites of System.Image_F
+
+ E : constant Natural := 63 - 32 * Boolean'Pos (OK_Put_32);
+ -- T'Size - 1 for the selected Int{32,64}
+
+ F0 : constant Natural := 0;
+ F1 : constant Natural :=
+ F0 + 18 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F0) >= 1.0E+18);
+ F2 : constant Natural :=
+ F1 + 9 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F1) >= 1.0E+9);
+ F3 : constant Natural :=
+ F2 + 5 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F2) >= 1.0E+5);
+ F4 : constant Natural :=
+ F3 + 3 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F3) >= 1.0E+3);
+ F5 : constant Natural :=
+ F4 + 2 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F4) >= 1.0E+2);
+ F6 : constant Natural :=
+ F5 + 1 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F5) >= 1.0E+1);
+ -- Binary search for the number of digits - 1 before the decimal point of
+ -- the product 2.0**E * Num'Small.
+
+ For0 : constant Natural := 2 + F6;
+ -- Fore value for the fixed point type whose mantissa is Int{32,64} and
+ -- whose small is Num'Small.
---------
-- Get --
@@ -319,8 +270,22 @@ package body Ada.Text_IO.Fixed_IO is
Width : Field := 0)
is
pragma Unsuppress (Range_Check);
+
begin
- Aux.Get (File, Long_Long_Float (Item), Width);
+ if OK_Get_32 then
+ Item := Num'Fixed_Value
+ (Aux32.Get (File, Width,
+ -Num'Small_Numerator,
+ -Num'Small_Denominator));
+ elsif OK_Get_64 then
+ Item := Num'Fixed_Value
+ (Aux64.Get (File, Width,
+ -Num'Small_Numerator,
+ -Num'Small_Denominator));
+ else
+ Aux_Long_Long_Float.Get (File, Long_Long_Float (Item), Width);
+ end if;
+
exception
when Constraint_Error => raise Data_Error;
end Get;
@@ -329,11 +294,8 @@ package body Ada.Text_IO.Fixed_IO is
(Item : out Num;
Width : Field := 0)
is
- pragma Unsuppress (Range_Check);
begin
- Aux.Get (Current_In, Long_Long_Float (Item), Width);
- exception
- when Constraint_Error => raise Data_Error;
+ Get (Current_In, Item, Width);
end Get;
procedure Get
@@ -342,8 +304,22 @@ package body Ada.Text_IO.Fixed_IO is
Last : out Positive)
is
pragma Unsuppress (Range_Check);
+
begin
- Aux.Gets (From, Long_Long_Float (Item), Last);
+ if OK_Get_32 then
+ Item := Num'Fixed_Value
+ (Aux32.Gets (From, Last,
+ -Num'Small_Numerator,
+ -Num'Small_Denominator));
+ elsif OK_Get_64 then
+ Item := Num'Fixed_Value
+ (Aux64.Gets (From, Last,
+ -Num'Small_Numerator,
+ -Num'Small_Denominator));
+ else
+ Aux_Long_Long_Float.Gets (From, Long_Long_Float (Item), Last);
+ end if;
+
exception
when Constraint_Error => raise Data_Error;
end Get;
@@ -359,11 +335,19 @@ package body Ada.Text_IO.Fixed_IO is
Aft : Field := Default_Aft;
Exp : Field := Default_Exp)
is
- S : String (1 .. Fore + Aft + Exp + Extra_Layout_Space);
- Last : Natural;
begin
- Put (S, Last, Item, Fore, Aft, Exp);
- Generic_Aux.Put_Item (File, S (1 .. Last));
+ if OK_Put_32 then
+ Aux32.Put (File, Int32'Integer_Value (Item), Fore, Aft, Exp,
+ -Num'Small_Numerator, -Num'Small_Denominator,
+ For0, Num'Aft);
+ elsif OK_Put_64 then
+ Aux64.Put (File, Int64'Integer_Value (Item), Fore, Aft, Exp,
+ -Num'Small_Numerator, -Num'Small_Denominator,
+ For0, Num'Aft);
+ else
+ Aux_Long_Long_Float.Put
+ (File, Long_Long_Float (Item), Fore, Aft, Exp);
+ end if;
end Put;
procedure Put
@@ -372,11 +356,8 @@ package body Ada.Text_IO.Fixed_IO is
Aft : Field := Default_Aft;
Exp : Field := Default_Exp)
is
- S : String (1 .. Fore + Aft + Exp + Extra_Layout_Space);
- Last : Natural;
begin
- Put (S, Last, Item, Fore, Aft, Exp);
- Generic_Aux.Put_Item (Text_IO.Current_Out, S (1 .. Last));
+ Put (Current_Out, Item, Fore, Aft, Exp);
end Put;
procedure Put
@@ -385,332 +366,18 @@ package body Ada.Text_IO.Fixed_IO is
Aft : Field := Default_Aft;
Exp : Field := Default_Exp)
is
- Fore : constant Integer :=
- To'Length
- - 1 -- Decimal point
- - Field'Max (1, Aft) -- Decimal part
- - Boolean'Pos (Exp /= 0) -- Exponent indicator
- - Exp; -- Exponent
-
- Last : Natural;
-
begin
- if Fore - Boolean'Pos (Item < 0.0) < 1 then
- raise Layout_Error;
- end if;
-
- Put (To, Last, Item, Fore, Aft, Exp);
-
- if Last /= To'Last then
- raise Layout_Error;
+ if OK_Put_32 then
+ Aux32.Puts (To, Int32'Integer_Value (Item), Aft, Exp,
+ -Num'Small_Numerator, -Num'Small_Denominator,
+ For0, Num'Aft);
+ elsif OK_Put_64 then
+ Aux64.Puts (To, Int64'Integer_Value (Item), Aft, Exp,
+ -Num'Small_Numerator, -Num'Small_Denominator,
+ For0, Num'Aft);
+ else
+ Aux_Long_Long_Float.Puts (To, Long_Long_Float (Item), Aft, Exp);
end if;
end Put;
- procedure Put
- (To : out String;
- Last : out Natural;
- Item : Num;
- Fore : Integer;
- Aft : Field;
- Exp : Field)
- is
- subtype Digit is Int64 range 0 .. 9;
-
- X : constant Int64 := Int64'Integer_Value (Item);
- A : constant Field := Field'Max (Aft, 1);
- Neg : constant Boolean := (Item < 0.0);
- Pos : Integer := 0; -- Next digit X has value X * 10.0**Pos;
-
- procedure Put_Character (C : Character);
- pragma Inline (Put_Character);
- -- Add C to the output string To, updating Last
-
- procedure Put_Digit (X : Digit);
- -- Add digit X to the output string (going from left to right), updating
- -- Last and Pos, and inserting the sign, leading zeros or a decimal
- -- point when necessary. After outputting the first digit, Pos must not
- -- be changed outside Put_Digit anymore.
-
- procedure Put_Int64 (X : Int64; Scale : Integer);
- -- Output the decimal number abs X * 10**Scale
-
- procedure Put_Scaled
- (X, Y, Z : Int64;
- A : Field;
- E : Integer);
- -- Output the decimal number (X * Y / Z) * 10**E, producing A digits
- -- after the decimal point and rounding the final digit. The value
- -- X * Y / Z is computed with full precision, but must be in the
- -- range of Int64.
-
- -------------------
- -- Put_Character --
- -------------------
-
- procedure Put_Character (C : Character) is
- begin
- Last := Last + 1;
-
- -- Never put a character outside of string To. Exception Layout_Error
- -- will be raised later if Last is greater than To'Last.
-
- if Last <= To'Last then
- To (Last) := C;
- end if;
- end Put_Character;
-
- ---------------
- -- Put_Digit --
- ---------------
-
- procedure Put_Digit (X : Digit) is
- Digs : constant array (Digit) of Character := "0123456789";
-
- begin
- if Last = To'First - 1 then
- if X /= 0 or else Pos <= 0 then
-
- -- Before outputting first digit, include leading space,
- -- possible minus sign and, if the first digit is fractional,
- -- decimal seperator and leading zeros.
-
- -- The Fore part has Pos + 1 + Boolean'Pos (Neg) characters,
- -- if Pos >= 0 and otherwise has a single zero digit plus minus
- -- sign if negative. Add leading space if necessary.
-
- for J in Integer'Max (0, Pos) + 2 + Boolean'Pos (Neg) .. Fore
- loop
- Put_Character (' ');
- end loop;
-
- -- Output minus sign, if number is negative
-
- if Neg then
- Put_Character ('-');
- end if;
-
- -- If starting with fractional digit, output leading zeros
-
- if Pos < 0 then
- Put_Character ('0');
- Put_Character ('.');
-
- for J in Pos .. -2 loop
- Put_Character ('0');
- end loop;
- end if;
-
- Put_Character (Digs (X));
- end if;
-
- else
- -- This is not the first digit to be output, so the only
- -- special handling is that for the decimal point
-
- if Pos = -1 then
- Put_Character ('.');
- end if;
-
- Put_Character (Digs (X));
- end if;
-
- Pos := Pos - 1;
- end Put_Digit;
-
- ---------------
- -- Put_Int64 --
- ---------------
-
- procedure Put_Int64 (X : Int64; Scale : Integer) is
- begin
- if X = 0 then
- return;
- end if;
-
- if X not in -9 .. 9 then
- Put_Int64 (X / 10, Scale + 1);
- end if;
-
- -- Use Put_Digit to advance Pos. This fixes a case where the second
- -- or later Scaled_Divide would omit leading zeroes, resulting in
- -- too few digits produced and a Layout_Error as result.
-
- while Pos > Scale loop
- Put_Digit (0);
- end loop;
-
- -- If and only if more than one digit is output before the decimal
- -- point, pos will be unequal to scale when outputting the first
- -- digit.
-
- pragma Assert (Pos = Scale or else Last = To'First - 1);
-
- Pos := Scale;
-
- Put_Digit (abs (X rem 10));
- end Put_Int64;
-
- ----------------
- -- Put_Scaled --
- ----------------
-
- procedure Put_Scaled
- (X, Y, Z : Int64;
- A : Field;
- E : Integer)
- is
- pragma Assert (E >= -Max_Digits);
- AA : constant Field := Integer'Max (E + A, 0);
- N : constant Natural := (AA + Max_Digits - 1) / Max_Digits + 1;
-
- Q : array (0 .. N - 1) of Int64 := (others => 0);
- -- Each element of Q has Max_Digits decimal digits, except the
- -- last, which has eAA rem Max_Digits. Only Q (Q'First) may have an
- -- absolute value equal to or larger than 10**Max_Digits. Only the
- -- absolute value of the elements is not significant, not the sign.
-
- XX : Int64 := X;
- YY : Int64 := Y;
-
- begin
- for J in Q'Range loop
- exit when XX = 0;
-
- if J > 0 then
- YY := 10**(Integer'Min (Max_Digits, AA - (J - 1) * Max_Digits));
- end if;
-
- Scaled_Divide64 (XX, YY, Z, Q (J), R => XX, Round => False);
- end loop;
-
- if -E > A then
- pragma Assert (N = 1);
-
- Discard_Extra_Digits : declare
- Factor : constant Int64 := 10**(-E - A);
-
- begin
- -- The scaling factors were such that the first division
- -- produced more digits than requested. So divide away extra
- -- digits and compute new remainder for later rounding.
-
- if abs (Q (0) rem Factor) >= Factor / 2 then
- Q (0) := abs (Q (0) / Factor) + 1;
- else
- Q (0) := Q (0) / Factor;
- end if;
-
- XX := 0;
- end Discard_Extra_Digits;
- end if;
-
- -- At this point XX is a remainder and we need to determine if the
- -- quotient in Q must be rounded away from zero.
-
- -- As XX is less than the divisor, it is safe to take its absolute
- -- without chance of overflow. The check to see if XX is at least
- -- half the absolute value of the divisor must be done carefully to
- -- avoid overflow or lose precision.
-
- XX := abs XX;
-
- if XX >= 2**62
- or else (Z < 0 and then (-XX) * 2 <= Z)
- or else (Z >= 0 and then XX * 2 >= Z)
- then
- -- OK, rounding is necessary. As the sign is not significant,
- -- take advantage of the fact that an extra negative value will
- -- always be available when propagating the carry.
-
- Q (Q'Last) := -abs Q (Q'Last) - 1;
-
- Propagate_Carry :
- for J in reverse 1 .. Q'Last loop
- if Q (J) = YY or else Q (J) = -YY then
- Q (J) := 0;
- Q (J - 1) := -abs Q (J - 1) - 1;
-
- else
- exit Propagate_Carry;
- end if;
- end loop Propagate_Carry;
- end if;
-
- for J in Q'First .. Q'Last - 1 loop
- Put_Int64 (Q (J), E - J * Max_Digits);
- end loop;
-
- Put_Int64 (Q (Q'Last), -A);
- end Put_Scaled;
-
- -- Start of processing for Put
-
- begin
- Last := To'First - 1;
-
- if Exp /= 0 then
-
- -- With the Exp format, it is not known how many output digits to
- -- generate, as leading zeros must be ignored. Computing too many
- -- digits and then truncating the output will not give the closest
- -- output, it is necessary to round at the correct digit.
-
- -- The general approach is as follows: as long as no digits have
- -- been generated, compute the Aft next digits (without rounding).
- -- Once a non-zero digit is generated, determine the exact number
- -- of digits remaining and compute them with rounding.
-
- -- Since a large number of iterations might be necessary in case
- -- of Aft = 1, the following optimization would be desirable.
-
- -- Count the number Z of leading zero bits in the integer
- -- representation of X, and start with producing Aft + Z * 1000 /
- -- 3322 digits in the first scaled division.
-
- -- However, the floating-point routines are still used now ???
-
- System.Img_Real.Set_Image_Real (Long_Long_Float (Item), To, Last,
- Fore, Aft, Exp);
- return;
- end if;
-
- if Exact then
- declare
- D : constant Integer := Integer'Min (A, Max_Digits
- - (Num'Fore - 1));
- Y : constant Int64 := Int64'Min (Int64 (-Num'Small), -1)
- * 10**Integer'Max (0, D);
- Z : constant Int64 := Int64'Min (Int64 (-(1.0 / Num'Small)), -1)
- * 10**Integer'Max (0, -D);
- begin
- Put_Scaled (X, Y, Z, A, -D);
- end;
-
- else -- not Exact
- declare
- E : constant Integer := Max_Digits - 1 + Scale;
- D : constant Integer := Scale - 1;
- Y : constant Int64 := Int64 (-Num'Small * 10.0**E);
- Z : constant Int64 := -10**Max_Digits;
- begin
- Put_Scaled (X, Y, Z, A, -D);
- end;
- end if;
-
- -- If only zero digits encountered, unit digit has not been output yet
-
- if Last < To'First then
- Pos := 0;
-
- elsif Last > To'Last then
- raise Layout_Error; -- Not enough room in the output variable
- end if;
-
- -- Always output digits up to the first one after the decimal point
-
- while Pos >= -A loop
- Put_Digit (0);
- end loop;
- end Put;
-
end Ada.Text_IO.Fixed_IO;
diff --git a/gcc/ada/libgnat/a-tifiio.ads b/gcc/ada/libgnat/a-tifiio.ads
index 1acf67a..8a3886d 100644
--- a/gcc/ada/libgnat/a-tifiio.ads
+++ b/gcc/ada/libgnat/a-tifiio.ads
@@ -23,7 +23,7 @@
private generic
type Num is delta <>;
-package Ada.Text_IO.Fixed_IO is
+package Ada.Text_IO.Fixed_IO with SPARK_Mode => On is
Default_Fore : Field := Num'Fore;
Default_Aft : Field := Num'Aft;
diff --git a/gcc/ada/libgnat/a-tifiio__128.adb b/gcc/ada/libgnat/a-tifiio__128.adb
new file mode 100644
index 0000000..f50e4c9
--- /dev/null
+++ b/gcc/ada/libgnat/a-tifiio__128.adb
@@ -0,0 +1,436 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . T E X T _ I O . F I X E D _ I O --
+-- --
+-- 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. --
+-- --
+------------------------------------------------------------------------------
+
+-- -------------------
+-- - Fixed point I/O -
+-- -------------------
+
+-- The following text documents implementation details of the fixed point
+-- input/output routines in the GNAT runtime. The first part describes the
+-- general properties of fixed point types as defined by the Ada standard,
+-- including the Information Systems Annex.
+
+-- Subsequently these are reduced to implementation constraints and the impact
+-- of these constraints on a few possible approaches to input/output is given.
+-- Based on this analysis, a specific implementation is selected for use in
+-- the GNAT runtime. Finally the chosen algorithms are analyzed numerically in
+-- order to provide user-level documentation on limits for range and precision
+-- of fixed point types as well as accuracy of input/output conversions.
+
+-- -------------------------------------------
+-- - General Properties of Fixed Point Types -
+-- -------------------------------------------
+
+-- Operations on fixed point types, other than input/output, are not important
+-- for the purpose of this document. Only the set of values that a fixed point
+-- type can represent and the input/output operations are significant.
+
+-- Values
+-- ------
+
+-- The set of values of a fixed point type comprise the integral multiples of
+-- a number called the small of the type. The small can be either a power of
+-- two, a power of ten or (if the implementation allows) an arbitrary strictly
+-- positive real value.
+
+-- Implementations need to support ordinary fixed point types with a precision
+-- of at least 24 bits, and (in order to comply with the Information Systems
+-- Annex) decimal fixed point types with at least 18 digits. For the rest, no
+-- requirements exist for the minimal small and range that must be supported.
+
+-- Operations
+-- ----------
+
+-- [Wide_[Wide_]]Image attribute (see RM 3.5(27.1/2))
+
+-- These attributes return a decimal real literal best approximating
+-- the value (rounded away from zero if halfway between) with a
+-- single leading character that is either a minus sign or a space,
+-- one or more digits before the decimal point (with no redundant
+-- leading zeros), a decimal point, and N digits after the decimal
+-- point. For a subtype S, the value of N is S'Aft, the smallest
+-- positive integer such that (10**N)*S'Delta is greater or equal to
+-- one, see RM 3.5.10(5).
+
+-- For an arbitrary small, this means large number arithmetic needs
+-- to be performed.
+
+-- Put (see RM A.10.9(22-26))
+
+-- The requirements for Put add no extra constraints over the image
+-- attributes, although it would be nice to be able to output more
+-- than S'Aft digits after the decimal point for values of subtype S.
+
+-- [Wide_[Wide_]]Value attribute (RM 3.5(39.1/2))
+
+-- Since the input can be given in any base in the range 2..16,
+-- accurate conversion to a fixed point number may require
+-- arbitrary precision arithmetic if there is no limit on the
+-- magnitude of the small of the fixed point type.
+
+-- Get (see RM A.10.9(12-21))
+
+-- The requirements for Get are identical to those of the Value
+-- attribute.
+
+-- ------------------------------
+-- - Implementation Constraints -
+-- ------------------------------
+
+-- The requirements listed above for the input/output operations lead to
+-- significant complexity, if no constraints are put on supported smalls.
+
+-- Implementation Strategies
+-- -------------------------
+
+-- * Floating point arithmetic
+-- * Arbitrary-precision integer arithmetic
+-- * Fixed-precision integer arithmetic
+
+-- Although it seems convenient to convert fixed point numbers to floating
+-- point and then print them, this leads to a number of restrictions.
+-- The first one is precision. The widest floating-point type generally
+-- available has 53 bits of mantissa. This means that Fine_Delta cannot
+-- be less than 2.0**(-53).
+
+-- In GNAT, Fine_Delta is 2.0**(-127), and Duration for example is a 64-bit
+-- type. This means that a floating-point type with 128 bits of mantissa needs
+-- to be used, which currently does not exist in any common architecture. It
+-- would still be possible to use multi-precision floating point to perform
+-- calculations using longer mantissas, but this is a much harder approach.
+
+-- The base conversions needed for input/output of (non-decimal) fixed point
+-- types can be seen as pairs of integer multiplications and divisions.
+
+-- Arbitrary-precision integer arithmetic would be suitable for the job at
+-- hand, but has the drawback that it is very heavy implementation-wise.
+-- Especially in embedded systems, where fixed point types are often used,
+-- it may not be desirable to require large amounts of storage and time
+-- for fixed I/O operations.
+
+-- Fixed-precision integer arithmetic has the advantage of simplicity and
+-- speed. For the most common fixed point types this would be a perfect
+-- solution. The downside however may be a restricted set of acceptable
+-- fixed point types.
+
+-- Implementation Choices
+-- ----------------------
+
+-- The current implementation in the GNAT runtime uses fixed-precision integer
+-- arithmetic for fixed point types whose Small is the ratio of two integers
+-- whose magnitude is bounded relatively to the size of the mantissa, with a
+-- three-tiered approach for 32-bit, 64-bit and 128-bit fixed point types. For
+-- other fixed point types, the implementation uses floating-point arithmetic.
+
+-- The exact requirements of the algorithms are analyzed and documented along
+-- with the implementation in their respective units.
+
+with Interfaces;
+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_Fixed_128; use System.Img_Fixed_128;
+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;
+
+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.
+
+ subtype Int32 is Interfaces.Integer_32; use type Int32;
+ subtype Int64 is Interfaces.Integer_64; use type Int64;
+ subtype Int128 is Interfaces.Integer_128; use type Int128;
+
+ package Aux32 is new
+ Ada.Text_IO.Fixed_Aux (Int32, Scan_Fixed32, Set_Image_Fixed32);
+
+ package Aux64 is new
+ Ada.Text_IO.Fixed_Aux (Int64, Scan_Fixed64, Set_Image_Fixed64);
+
+ 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);
+
+ -- 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
+ -- boolean constants are used to test for this, such that only code for the
+ -- relevant case is included in the instance; that's why the computation of
+ -- their value must be fully static (although it is not a static expression
+ -- in the RM sense).
+
+ OK_Get_32 : constant Boolean :=
+ Num'Base'Object_Size <= 32
+ and then
+ ((Num'Small_Numerator = 1 and then Num'Small_Denominator <= 2**31)
+ or else
+ (Num'Small_Denominator = 1 and then Num'Small_Numerator <= 2**31)
+ or else
+ (Num'Small_Numerator <= 2**27
+ and then Num'Small_Denominator <= 2**27));
+ -- These conditions are derived from the prerequisites of System.Value_F
+
+ OK_Put_32 : constant Boolean :=
+ Num'Base'Object_Size <= 32
+ and then
+ ((Num'Small_Numerator = 1 and then Num'Small_Denominator <= 2**31)
+ or else
+ (Num'Small_Denominator = 1 and then Num'Small_Numerator <= 2**31)
+ or else
+ (Num'Small_Numerator < Num'Small_Denominator
+ and then Num'Small_Denominator <= 2**27)
+ or else
+ (Num'Small_Denominator < Num'Small_Numerator
+ and then Num'Small_Numerator <= 2**25));
+ -- These conditions are derived from the prerequisites of System.Image_F
+
+ OK_Get_64 : constant Boolean :=
+ Num'Base'Object_Size <= 64
+ and then
+ ((Num'Small_Numerator = 1 and then Num'Small_Denominator <= 2**63)
+ or else
+ (Num'Small_Denominator = 1 and then Num'Small_Numerator <= 2**63)
+ or else
+ (Num'Small_Numerator <= 2**59
+ and then Num'Small_Denominator <= 2**59));
+ -- These conditions are derived from the prerequisites of System.Value_F
+
+ OK_Put_64 : constant Boolean :=
+ Num'Base'Object_Size <= 64
+ and then
+ ((Num'Small_Numerator = 1 and then Num'Small_Denominator <= 2**63)
+ or else
+ (Num'Small_Denominator = 1 and then Num'Small_Numerator <= 2**63)
+ or else
+ (Num'Small_Numerator < Num'Small_Denominator
+ and then Num'Small_Denominator <= 2**59)
+ or else
+ (Num'Small_Denominator < Num'Small_Numerator
+ and then Num'Small_Numerator <= 2**53));
+ -- These conditions are derived from the prerequisites of System.Image_F
+
+ OK_Get_128 : constant Boolean :=
+ Num'Base'Object_Size <= 128
+ and then
+ ((Num'Small_Numerator = 1 and then Num'Small_Denominator <= 2**127)
+ or else
+ (Num'Small_Denominator = 1 and then Num'Small_Numerator <= 2**127)
+ or else
+ (Num'Small_Numerator <= 2**123
+ and then Num'Small_Denominator <= 2**123));
+ -- These conditions are derived from the prerequisites of System.Value_F
+
+ OK_Put_128 : constant Boolean :=
+ Num'Base'Object_Size <= 128
+ and then
+ ((Num'Small_Numerator = 1 and then Num'Small_Denominator <= 2**127)
+ or else
+ (Num'Small_Denominator = 1 and then Num'Small_Numerator <= 2**127)
+ or else
+ (Num'Small_Numerator < Num'Small_Denominator
+ and then Num'Small_Denominator <= 2**123)
+ or else
+ (Num'Small_Denominator < Num'Small_Numerator
+ and then Num'Small_Numerator <= 2**122));
+ -- These conditions are derived from the prerequisites of System.Image_F
+
+ E : constant Natural :=
+ 127 - 64 * Boolean'Pos (OK_Put_64) - 32 * Boolean'Pos (OK_Put_32);
+ -- T'Size - 1 for the selected Int{32,64,128}
+
+ F0 : constant Natural := 0;
+ F1 : constant Natural :=
+ F0 + 38 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F0) >= 1.0E+38);
+ F2 : constant Natural :=
+ F1 + 19 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F1) >= 1.0E+19);
+ F3 : constant Natural :=
+ F2 + 9 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F2) >= 1.0E+9);
+ F4 : constant Natural :=
+ F3 + 5 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F3) >= 1.0E+5);
+ F5 : constant Natural :=
+ F4 + 3 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F4) >= 1.0E+3);
+ F6 : constant Natural :=
+ F5 + 2 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F5) >= 1.0E+2);
+ F7 : constant Natural :=
+ F6 + 1 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F6) >= 1.0E+1);
+ -- Binary search for the number of digits - 1 before the decimal point of
+ -- the product 2.0**E * Num'Small.
+
+ For0 : constant Natural := 2 + F7;
+ -- Fore value for the fixed point type whose mantissa is Int{32,64,128} and
+ -- whose small is Num'Small.
+
+ ---------
+ -- Get --
+ ---------
+
+ procedure Get
+ (File : File_Type;
+ Item : out Num;
+ Width : Field := 0)
+ is
+ pragma Unsuppress (Range_Check);
+
+ begin
+ if OK_Get_32 then
+ Item := Num'Fixed_Value
+ (Aux32.Get (File, Width,
+ -Num'Small_Numerator,
+ -Num'Small_Denominator));
+ elsif OK_Get_64 then
+ Item := Num'Fixed_Value
+ (Aux64.Get (File, Width,
+ -Num'Small_Numerator,
+ -Num'Small_Denominator));
+ elsif OK_Get_128 then
+ Item := Num'Fixed_Value
+ (Aux128.Get (File, Width,
+ -Num'Small_Numerator,
+ -Num'Small_Denominator));
+ else
+ Aux_Long_Long_Float.Get (File, Long_Long_Float (Item), Width);
+ end if;
+
+ exception
+ when Constraint_Error => raise Data_Error;
+ end Get;
+
+ procedure Get
+ (Item : out Num;
+ Width : Field := 0)
+ is
+ begin
+ Get (Current_In, Item, Width);
+ end Get;
+
+ procedure Get
+ (From : String;
+ Item : out Num;
+ Last : out Positive)
+ is
+ pragma Unsuppress (Range_Check);
+
+ begin
+ if OK_Get_32 then
+ Item := Num'Fixed_Value
+ (Aux32.Gets (From, Last,
+ -Num'Small_Numerator,
+ -Num'Small_Denominator));
+ elsif OK_Get_64 then
+ Item := Num'Fixed_Value
+ (Aux64.Gets (From, Last,
+ -Num'Small_Numerator,
+ -Num'Small_Denominator));
+ elsif OK_Get_128 then
+ Item := Num'Fixed_Value
+ (Aux128.Gets (From, Last,
+ -Num'Small_Numerator,
+ -Num'Small_Denominator));
+ else
+ Aux_Long_Long_Float.Gets (From, Long_Long_Float (Item), Last);
+ end if;
+
+ exception
+ when Constraint_Error => raise Data_Error;
+ end Get;
+
+ ---------
+ -- Put --
+ ---------
+
+ procedure Put
+ (File : File_Type;
+ Item : Num;
+ Fore : Field := Default_Fore;
+ Aft : Field := Default_Aft;
+ Exp : Field := Default_Exp)
+ is
+ begin
+ if OK_Put_32 then
+ Aux32.Put (File, Int32'Integer_Value (Item), Fore, Aft, Exp,
+ -Num'Small_Numerator, -Num'Small_Denominator,
+ For0, Num'Aft);
+ elsif OK_Put_64 then
+ Aux64.Put (File, Int64'Integer_Value (Item), Fore, Aft, Exp,
+ -Num'Small_Numerator, -Num'Small_Denominator,
+ For0, Num'Aft);
+ elsif OK_Put_128 then
+ Aux128.Put (File, Int128'Integer_Value (Item), Fore, Aft, Exp,
+ -Num'Small_Numerator, -Num'Small_Denominator,
+ For0, Num'Aft);
+ else
+ Aux_Long_Long_Float.Put
+ (File, Long_Long_Float (Item), Fore, Aft, Exp);
+ end if;
+ end Put;
+
+ procedure Put
+ (Item : Num;
+ Fore : Field := Default_Fore;
+ Aft : Field := Default_Aft;
+ Exp : Field := Default_Exp)
+ is
+ begin
+ Put (Current_Out, Item, Fore, Aft, Exp);
+ end Put;
+
+ procedure Put
+ (To : out String;
+ Item : Num;
+ Aft : Field := Default_Aft;
+ Exp : Field := Default_Exp)
+ is
+ begin
+ if OK_Put_32 then
+ Aux32.Puts (To, Int32'Integer_Value (Item), Aft, Exp,
+ -Num'Small_Numerator, -Num'Small_Denominator,
+ For0, Num'Aft);
+ elsif OK_Put_64 then
+ Aux64.Puts (To, Int64'Integer_Value (Item), Aft, Exp,
+ -Num'Small_Numerator, -Num'Small_Denominator,
+ For0, Num'Aft);
+ elsif OK_Put_128 then
+ Aux128.Puts (To, Int128'Integer_Value (Item), Aft, Exp,
+ -Num'Small_Numerator, -Num'Small_Denominator,
+ For0, Num'Aft);
+ else
+ Aux_Long_Long_Float.Puts (To, Long_Long_Float (Item), Aft, Exp);
+ end if;
+ end Put;
+
+end Ada.Text_IO.Fixed_IO;
diff --git a/gcc/ada/libgnat/a-tiflau.adb b/gcc/ada/libgnat/a-tiflau.adb
index 214b5c8..4955a99 100644
--- a/gcc/ada/libgnat/a-tiflau.adb
+++ b/gcc/ada/libgnat/a-tiflau.adb
@@ -32,7 +32,6 @@
with Ada.Text_IO.Generic_Aux; use Ada.Text_IO.Generic_Aux;
with System.Img_Real; use System.Img_Real;
-with System.Val_Real; use System.Val_Real;
package body Ada.Text_IO.Float_Aux is
@@ -42,12 +41,12 @@ package body Ada.Text_IO.Float_Aux is
procedure Get
(File : File_Type;
- Item : out Long_Long_Float;
+ Item : out Num;
Width : Field)
is
Buf : String (1 .. Field'Last);
Stop : Integer := 0;
- Ptr : aliased Integer := 1;
+ Ptr : aliased Integer;
begin
if Width /= 0 then
@@ -55,10 +54,10 @@ package body Ada.Text_IO.Float_Aux is
String_Skip (Buf, Ptr);
else
Load_Real (File, Buf, Stop);
+ Ptr := 1;
end if;
- Item := Scan_Real (Buf, Ptr'Access, Stop);
-
+ Item := Scan (Buf, Ptr'Access, Stop);
Check_End_Of_Field (Buf, Stop, Ptr, Width);
end Get;
@@ -68,128 +67,27 @@ package body Ada.Text_IO.Float_Aux is
procedure Gets
(From : String;
- Item : out Long_Long_Float;
+ Item : out Num;
Last : out Positive)
is
Pos : aliased Integer;
begin
String_Skip (From, Pos);
- Item := Scan_Real (From, Pos'Access, From'Last);
+ Item := Scan (From, Pos'Access, From'Last);
Last := Pos - 1;
exception
- when Constraint_Error =>
- raise Data_Error;
+ when Constraint_Error => raise Data_Error;
end Gets;
- ---------------
- -- Load_Real --
- ---------------
-
- procedure Load_Real
- (File : File_Type;
- Buf : out String;
- Ptr : in out Natural)
- is
- Loaded : Boolean;
-
- begin
- -- Skip initial blanks, and load possible sign
-
- Load_Skip (File);
- Load (File, Buf, Ptr, '+', '-');
-
- -- Case of .nnnn
-
- Load (File, Buf, Ptr, '.', Loaded);
-
- if Loaded then
- Load_Digits (File, Buf, Ptr, Loaded);
-
- -- Hopeless junk if no digits loaded
-
- if not Loaded then
- return;
- end if;
-
- -- Otherwise must have digits to start
-
- else
- Load_Digits (File, Buf, Ptr, Loaded);
-
- -- Hopeless junk if no digits loaded
-
- if not Loaded then
- return;
- end if;
-
- -- Based cases. We recognize either the standard '#' or the
- -- allowed alternative replacement ':' (see RM J.2(3)).
-
- Load (File, Buf, Ptr, '#', ':', Loaded);
-
- if Loaded then
-
- -- Case of nnn#.xxx#
-
- Load (File, Buf, Ptr, '.', Loaded);
-
- if Loaded then
- Load_Extended_Digits (File, Buf, Ptr);
- Load (File, Buf, Ptr, '#', ':');
-
- -- Case of nnn#xxx.[xxx]# or nnn#xxx#
-
- else
- Load_Extended_Digits (File, Buf, Ptr);
- Load (File, Buf, Ptr, '.', Loaded);
-
- if Loaded then
- Load_Extended_Digits (File, Buf, Ptr);
- end if;
-
- -- As usual, it seems strange to allow mixed base characters,
- -- but that is what ACVC tests expect, see CE3804M, case (3).
-
- Load (File, Buf, Ptr, '#', ':');
- end if;
-
- -- Case of nnn.[nnn] or nnn
-
- else
- -- Prevent the potential processing of '.' in cases where the
- -- initial digits have a trailing underscore.
-
- if Buf (Ptr) = '_' then
- return;
- end if;
-
- Load (File, Buf, Ptr, '.', Loaded);
-
- if Loaded then
- Load_Digits (File, Buf, Ptr);
- end if;
- end if;
- end if;
-
- -- Deal with exponent
-
- Load (File, Buf, Ptr, 'E', 'e', Loaded);
-
- if Loaded then
- Load (File, Buf, Ptr, '+', '-');
- Load_Digits (File, Buf, Ptr);
- end if;
- end Load_Real;
-
---------
-- Put --
---------
procedure Put
(File : File_Type;
- Item : Long_Long_Float;
+ Item : Num;
Fore : Field;
Aft : Field;
Exp : Field)
@@ -198,7 +96,7 @@ package body Ada.Text_IO.Float_Aux is
Ptr : Natural := 0;
begin
- Set_Image_Real (Item, Buf, Ptr, Fore, Aft, Exp);
+ Set_Image_Real (Long_Long_Float (Item), Buf, Ptr, Fore, Aft, Exp);
Put_Item (File, Buf (1 .. Ptr));
end Put;
@@ -208,7 +106,7 @@ package body Ada.Text_IO.Float_Aux is
procedure Puts
(To : out String;
- Item : Long_Long_Float;
+ Item : Num;
Aft : Field;
Exp : Field)
is
@@ -216,7 +114,8 @@ package body Ada.Text_IO.Float_Aux is
Ptr : Natural := 0;
begin
- Set_Image_Real (Item, Buf, Ptr, Fore => 1, Aft => Aft, Exp => Exp);
+ Set_Image_Real
+ (Long_Long_Float (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 68ac9eb..2dfe76d 100644
--- a/gcc/ada/libgnat/a-tiflau.ads
+++ b/gcc/ada/libgnat/a-tiflau.ads
@@ -31,41 +31,42 @@
-- This package contains the routines for Ada.Text_IO.Float_IO that are
-- shared among separate instantiations of this package. The routines in
--- this package are identical semantically to those in Float_IO itself,
--- except that generic parameter Num has been replaced by Long_Long_Float,
--- and the default parameters have been removed because they are supplied
+-- this package are identical semantically to those in Float_IO, except
+-- that the default parameters have been removed because they are supplied
-- explicitly by the calls from within the generic template. This package
--- is also used by Ada.Text_IO.Fixed_IO, and Ada.Text_IO.Decimal_IO.
+-- is also used by Ada.Text_IO.Fixed_IO and Ada.Text_IO.Decimal_IO.
-private package Ada.Text_IO.Float_Aux is
+private generic
- procedure Load_Real
- (File : File_Type;
- Buf : out String;
- Ptr : in out Natural);
- -- This is an auxiliary routine that is used to load a possibly signed
- -- real literal value from the input file into Buf, starting at Ptr + 1.
+ type Num is digits <>;
+
+ with function Scan
+ (Str : String;
+ Ptr : not null access Integer;
+ Max : Integer) return Num;
+
+package Ada.Text_IO.Float_Aux is
procedure Get
(File : File_Type;
- Item : out Long_Long_Float;
+ Item : out Num;
Width : Field);
procedure Put
(File : File_Type;
- Item : Long_Long_Float;
+ Item : Num;
Fore : Field;
Aft : Field;
Exp : Field);
procedure Gets
(From : String;
- Item : out Long_Long_Float;
+ Item : out Num;
Last : out Positive);
procedure Puts
(To : out String;
- Item : Long_Long_Float;
+ Item : Num;
Aft : Field;
Exp : Field);
diff --git a/gcc/ada/libgnat/a-tiflio.adb b/gcc/ada/libgnat/a-tiflio.adb
index 0daa044..db1cea2 100644
--- a/gcc/ada/libgnat/a-tiflio.adb
+++ b/gcc/ada/libgnat/a-tiflio.adb
@@ -30,10 +30,29 @@
------------------------------------------------------------------------------
with Ada.Text_IO.Float_Aux;
+with System.Val_Flt; use System.Val_Flt;
+with System.Val_LFlt; use System.Val_LFlt;
+with System.Val_LLF; use System.Val_LLF;
-package body Ada.Text_IO.Float_IO is
+package body Ada.Text_IO.Float_IO with SPARK_Mode => Off is
- package Aux renames Ada.Text_IO.Float_Aux;
+ package Aux_Float is new
+ Ada.Text_IO.Float_Aux (Float, Scan_Float);
+
+ package Aux_Long_Float is new
+ Ada.Text_IO.Float_Aux (Long_Float, Scan_Long_Float);
+
+ package Aux_Long_Long_Float is new
+ Ada.Text_IO.Float_Aux (Long_Long_Float, Scan_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
+ -- is needed. These boolean constants are used to test for this, such that
+ -- only code for the relevant case is included in the instance.
+
+ OK_Float : constant Boolean := Num'Base'Digits <= Float'Digits;
+
+ OK_Long_Float : constant Boolean := Num'Base'Digits <= Long_Float'Digits;
---------
-- Get --
@@ -47,7 +66,13 @@ package body Ada.Text_IO.Float_IO is
pragma Unsuppress (Range_Check);
begin
- Aux.Get (File, Long_Long_Float (Item), Width);
+ if OK_Float then
+ Aux_Float.Get (File, Float (Item), Width);
+ elsif OK_Long_Float then
+ Aux_Long_Float.Get (File, Long_Float (Item), Width);
+ else
+ Aux_Long_Long_Float.Get (File, Long_Long_Float (Item), Width);
+ end if;
-- In the case where the type is unconstrained (e.g. Standard'Float),
-- the above conversion may result in an infinite value, which is
@@ -66,22 +91,8 @@ package body Ada.Text_IO.Float_IO is
(Item : out Num;
Width : Field := 0)
is
- pragma Unsuppress (Range_Check);
-
begin
- Aux.Get (Current_In, Long_Long_Float (Item), Width);
-
- -- In the case where the type is unconstrained (e.g. Standard'Float),
- -- the above conversion may result in an infinite value, which is
- -- normally fine for a conversion, but in this case, we want to treat
- -- that as a data error.
-
- if not Item'Valid then
- raise Data_Error;
- end if;
-
- exception
- when Constraint_Error => raise Data_Error;
+ Get (Current_In, Item, Width);
end Get;
procedure Get
@@ -92,7 +103,13 @@ package body Ada.Text_IO.Float_IO is
pragma Unsuppress (Range_Check);
begin
- Aux.Gets (From, Long_Long_Float (Item), Last);
+ if OK_Float then
+ Aux_Float.Gets (From, Float (Item), Last);
+ elsif OK_Long_Float then
+ Aux_Long_Float.Gets (From, Long_Float (Item), Last);
+ else
+ Aux_Long_Long_Float.Gets (From, Long_Long_Float (Item), Last);
+ end if;
-- In the case where the type is unconstrained (e.g. Standard'Float),
-- the above conversion may result in an infinite value, which is
@@ -119,7 +136,14 @@ package body Ada.Text_IO.Float_IO is
Exp : Field := Default_Exp)
is
begin
- Aux.Put (File, Long_Long_Float (Item), Fore, Aft, Exp);
+ if OK_Float then
+ Aux_Float.Put (File, Float (Item), Fore, Aft, Exp);
+ elsif OK_Long_Float then
+ Aux_Long_Float.Put (File, Long_Float (Item), Fore, Aft, Exp);
+ else
+ Aux_Long_Long_Float.Put
+ (File, Long_Long_Float (Item), Fore, Aft, Exp);
+ end if;
end Put;
procedure Put
@@ -129,7 +153,7 @@ package body Ada.Text_IO.Float_IO is
Exp : Field := Default_Exp)
is
begin
- Aux.Put (Current_Out, Long_Long_Float (Item), Fore, Aft, Exp);
+ Put (Current_Out, Item, Fore, Aft, Exp);
end Put;
procedure Put
@@ -139,7 +163,13 @@ package body Ada.Text_IO.Float_IO is
Exp : Field := Default_Exp)
is
begin
- Aux.Puts (To, Long_Long_Float (Item), Aft, Exp);
+ if OK_Float then
+ Aux_Float.Puts (To, Float (Item), Aft, Exp);
+ elsif OK_Long_Float then
+ Aux_Long_Float.Puts (To, Long_Float (Item), Aft, Exp);
+ else
+ Aux_Long_Long_Float.Puts (To, Long_Long_Float (Item), Aft, Exp);
+ end if;
end Put;
end Ada.Text_IO.Float_IO;
diff --git a/gcc/ada/libgnat/a-tiflio.ads b/gcc/ada/libgnat/a-tiflio.ads
index bd4c64f64..d61b9e7 100644
--- a/gcc/ada/libgnat/a-tiflio.ads
+++ b/gcc/ada/libgnat/a-tiflio.ads
@@ -43,7 +43,7 @@
private generic
type Num is digits <>;
-package Ada.Text_IO.Float_IO is
+package Ada.Text_IO.Float_IO with SPARK_Mode => On is
Default_Fore : Field := 2;
Default_Aft : Field := Num'Digits - 1;
diff --git a/gcc/ada/libgnat/a-tigeau.adb b/gcc/ada/libgnat/a-tigeau.adb
index f1ba60a..5e13dae 100644
--- a/gcc/ada/libgnat/a-tigeau.adb
+++ b/gcc/ada/libgnat/a-tigeau.adb
@@ -377,6 +377,106 @@ package body Ada.Text_IO.Generic_Aux is
end Load_Integer;
---------------
+ -- Load_Real --
+ ---------------
+
+ procedure Load_Real
+ (File : File_Type;
+ Buf : out String;
+ Ptr : in out Natural)
+ is
+ Loaded : Boolean;
+
+ begin
+ -- Skip initial blanks, and load possible sign
+
+ Load_Skip (File);
+ Load (File, Buf, Ptr, '+', '-');
+
+ -- Case of .nnnn
+
+ Load (File, Buf, Ptr, '.', Loaded);
+
+ if Loaded then
+ Load_Digits (File, Buf, Ptr, Loaded);
+
+ -- Hopeless junk if no digits loaded
+
+ if not Loaded then
+ return;
+ end if;
+
+ -- Otherwise must have digits to start
+
+ else
+ Load_Digits (File, Buf, Ptr, Loaded);
+
+ -- Hopeless junk if no digits loaded
+
+ if not Loaded then
+ return;
+ end if;
+
+ -- Based cases. We recognize either the standard '#' or the
+ -- allowed alternative replacement ':' (see RM J.2(3)).
+
+ Load (File, Buf, Ptr, '#', ':', Loaded);
+
+ if Loaded then
+
+ -- Case of nnn#.xxx#
+
+ Load (File, Buf, Ptr, '.', Loaded);
+
+ if Loaded then
+ Load_Extended_Digits (File, Buf, Ptr);
+ Load (File, Buf, Ptr, '#', ':');
+
+ -- Case of nnn#xxx.[xxx]# or nnn#xxx#
+
+ else
+ Load_Extended_Digits (File, Buf, Ptr);
+ Load (File, Buf, Ptr, '.', Loaded);
+
+ if Loaded then
+ Load_Extended_Digits (File, Buf, Ptr);
+ end if;
+
+ -- As usual, it seems strange to allow mixed base characters,
+ -- but that is what ACVC tests expect, see CE3804M, case (3).
+
+ Load (File, Buf, Ptr, '#', ':');
+ end if;
+
+ -- Case of nnn.[nnn] or nnn
+
+ else
+ -- Prevent the potential processing of '.' in cases where the
+ -- initial digits have a trailing underscore.
+
+ if Buf (Ptr) = '_' then
+ return;
+ end if;
+
+ Load (File, Buf, Ptr, '.', Loaded);
+
+ if Loaded then
+ Load_Digits (File, Buf, Ptr);
+ end if;
+ end if;
+ end if;
+
+ -- Deal with exponent
+
+ Load (File, Buf, Ptr, 'E', 'e', Loaded);
+
+ if Loaded then
+ Load (File, Buf, Ptr, '+', '-');
+ Load_Digits (File, Buf, Ptr);
+ end if;
+ end Load_Real;
+
+ ---------------
-- Load_Skip --
---------------
diff --git a/gcc/ada/libgnat/a-tigeau.ads b/gcc/ada/libgnat/a-tigeau.ads
index 09334b3..d6acd8d 100644
--- a/gcc/ada/libgnat/a-tigeau.ads
+++ b/gcc/ada/libgnat/a-tigeau.ads
@@ -156,6 +156,12 @@ private package Ada.Text_IO.Generic_Aux is
Ptr : in out Natural);
-- Loads a possibly signed integer literal value
+ procedure Load_Real
+ (File : File_Type;
+ Buf : out String;
+ Ptr : in out Natural);
+ -- Loads a possibly signed real literal value
+
function Nextc (File : File_Type) return Integer;
-- Like Getc, but includes a call to Ungetc, so that the file
-- pointer is not moved by the call.
diff --git a/gcc/ada/libgnat/a-wtcoau.adb b/gcc/ada/libgnat/a-wtcoau.adb
index a60336b..05a6d9d 100644
--- a/gcc/ada/libgnat/a-wtcoau.adb
+++ b/gcc/ada/libgnat/a-wtcoau.adb
@@ -30,22 +30,19 @@
------------------------------------------------------------------------------
with Ada.Wide_Text_IO.Generic_Aux; use Ada.Wide_Text_IO.Generic_Aux;
-with Ada.Wide_Text_IO.Float_Aux;
with System.Img_Real; use System.Img_Real;
package body Ada.Wide_Text_IO.Complex_Aux is
- package Aux renames Ada.Wide_Text_IO.Float_Aux;
-
---------
-- Get --
---------
procedure Get
(File : File_Type;
- ItemR : out Long_Long_Float;
- ItemI : out Long_Long_Float;
+ ItemR : out Num;
+ ItemI : out Num;
Width : Field)
is
Buf : String (1 .. Field'Last);
@@ -95,8 +92,8 @@ package body Ada.Wide_Text_IO.Complex_Aux is
procedure Gets
(From : String;
- ItemR : out Long_Long_Float;
- ItemI : out Long_Long_Float;
+ ItemR : out Num;
+ ItemI : out Num;
Last : out Positive)
is
Paren : Boolean;
@@ -139,8 +136,8 @@ package body Ada.Wide_Text_IO.Complex_Aux is
procedure Put
(File : File_Type;
- ItemR : Long_Long_Float;
- ItemI : Long_Long_Float;
+ ItemR : Num;
+ ItemI : Num;
Fore : Field;
Aft : Field;
Exp : Field)
@@ -159,8 +156,8 @@ package body Ada.Wide_Text_IO.Complex_Aux is
procedure Puts
(To : out String;
- ItemR : Long_Long_Float;
- ItemI : Long_Long_Float;
+ ItemR : Num;
+ ItemI : Num;
Aft : Field;
Exp : Field)
is
@@ -174,9 +171,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 (ItemR, R_String, Rptr, 0, Aft, Exp);
+ Set_Image_Real (Long_Long_Float (ItemR), R_String, Rptr, 0, Aft, Exp);
Iptr := 0;
- Set_Image_Real (ItemI, I_String, Iptr, 0, Aft, Exp);
+ Set_Image_Real (Long_Long_Float (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 781dd8d..affb969 100644
--- a/gcc/ada/libgnat/a-wtcoau.ads
+++ b/gcc/ada/libgnat/a-wtcoau.ads
@@ -29,40 +29,47 @@
-- --
------------------------------------------------------------------------------
--- This package contains the routines for Ada.Wide_Text_IO.Complex_IO that
--- are shared among separate instantiations of this package. The routines
--- in this package are identical semantically to those in Complex_IO itself,
--- except that the generic parameter Complex has been replaced by separate
--- real and imaginary values of type Long_Long_Float, and default parameters
--- have been removed because they are supplied explicitly by the calls from
--- within the generic template.
+-- This package contains the routines for Ada.Wide_Text_IO.Complex_IO that are
+-- shared among separate instantiations of this package. The routines in this
+-- package are identical semantically to those in Complex_IO, except that the
+-- generic parameter Complex has been replaced by separate real and imaginary
+-- parameters, and default parameters have been removed because they are
+-- supplied explicitly by the calls from within the generic template.
+
+with Ada.Wide_Text_IO.Float_Aux;
+
+private generic
+
+ type Num is digits <>;
+
+ with package Aux is new Ada.Wide_Text_IO.Float_Aux (Num, <>);
package Ada.Wide_Text_IO.Complex_Aux is
procedure Get
(File : File_Type;
- ItemR : out Long_Long_Float;
- ItemI : out Long_Long_Float;
+ ItemR : out Num;
+ ItemI : out Num;
Width : Field);
- procedure Gets
- (From : String;
- ItemR : out Long_Long_Float;
- ItemI : out Long_Long_Float;
- Last : out Positive);
-
procedure Put
(File : File_Type;
- ItemR : Long_Long_Float;
- ItemI : Long_Long_Float;
+ ItemR : Num;
+ ItemI : Num;
Fore : Field;
Aft : Field;
Exp : Field);
+ procedure Gets
+ (From : String;
+ ItemR : out Num;
+ ItemI : out Num;
+ Last : out Positive);
+
procedure Puts
(To : out String;
- ItemR : Long_Long_Float;
- ItemI : Long_Long_Float;
+ ItemR : Num;
+ ItemI : Num;
Aft : Field;
Exp : Field);
diff --git a/gcc/ada/libgnat/a-wtcoio.adb b/gcc/ada/libgnat/a-wtcoio.adb
index c1c3b94..8e9ff7a 100644
--- a/gcc/ada/libgnat/a-wtcoio.adb
+++ b/gcc/ada/libgnat/a-wtcoio.adb
@@ -30,24 +30,43 @@
------------------------------------------------------------------------------
with Ada.Wide_Text_IO.Complex_Aux;
+with Ada.Wide_Text_IO.Float_Aux;
+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 System.WCh_Con; use System.WCh_Con;
-with System.WCh_WtS; use System.WCh_WtS;
+package body Ada.Wide_Text_IO.Complex_IO is
-with Ada.Unchecked_Conversion;
+ use Complex_Types;
-package body Ada.Wide_Text_IO.Complex_IO is
+ package Scalar_Float is new
+ Ada.Wide_Text_IO.Float_Aux (Float, Scan_Float);
+
+ package Scalar_Long_Float is new
+ Ada.Wide_Text_IO.Float_Aux (Long_Float, Scan_Long_Float);
+
+ package Scalar_Long_Long_Float is new
+ Ada.Wide_Text_IO.Float_Aux (Long_Long_Float, Scan_Long_Long_Float);
+
+ package Aux_Float is new
+ Ada.Wide_Text_IO.Complex_Aux (Float, Scalar_Float);
- package Aux renames Ada.Wide_Text_IO.Complex_Aux;
+ package Aux_Long_Float is new
+ Ada.Wide_Text_IO.Complex_Aux (Long_Float, Scalar_Long_Float);
- subtype LLF is Long_Long_Float;
- -- Type used for calls to routines in Aux
+ package Aux_Long_Long_Float is new
+ Ada.Wide_Text_IO.Complex_Aux (Long_Long_Float, Scalar_Long_Long_Float);
- function TFT is new
- Ada.Unchecked_Conversion (File_Type, Ada.Wide_Text_IO.File_Type);
- -- This unchecked conversion is to get around a visibility bug in
- -- GNAT version 2.04w. It should be possible to simply use the
- -- subtype declared above and do normal checked conversions.
+ -- 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
+ -- is needed. These boolean constants are used to test for this, such that
+ -- only code for the relevant case is included in the instance.
+
+ OK_Float : constant Boolean := Real'Base'Digits <= Float'Digits;
+
+ OK_Long_Float : constant Boolean := Real'Base'Digits <= Long_Float'Digits;
---------
-- Get --
@@ -62,7 +81,17 @@ package body Ada.Wide_Text_IO.Complex_IO is
Imag_Item : Real'Base;
begin
- Aux.Get (TFT (File), LLF (Real_Item), LLF (Imag_Item), Width);
+ if OK_Float then
+ Aux_Float.Get (File, Float (Real_Item), Float (Imag_Item), Width);
+ elsif OK_Long_Float then
+ Aux_Long_Float.Get
+ (File, Long_Float (Real_Item), Long_Float (Imag_Item), Width);
+ else
+ Aux_Long_Long_Float.Get
+ (File, Long_Long_Float (Real_Item), Long_Long_Float (Imag_Item),
+ Width);
+ end if;
+
Item := (Real_Item, Imag_Item);
exception
@@ -78,7 +107,7 @@ package body Ada.Wide_Text_IO.Complex_IO is
Width : Field := 0)
is
begin
- Get (Current_Input, Item, Width);
+ Get (Current_In, Item, Width);
end Get;
---------
@@ -100,7 +129,17 @@ package body Ada.Wide_Text_IO.Complex_IO is
-- Aux.Gets will raise Data_Error in any case.
begin
- Aux.Gets (S, LLF (Real_Item), LLF (Imag_Item), Last);
+ if OK_Float then
+ Aux_Float.Gets (S, Float (Real_Item), Float (Imag_Item), Last);
+ elsif OK_Long_Float then
+ Aux_Long_Float.Gets
+ (S, Long_Float (Real_Item), Long_Float (Imag_Item), Last);
+ else
+ Aux_Long_Long_Float.Gets
+ (S, Long_Long_Float (Real_Item), Long_Long_Float (Imag_Item),
+ Last);
+ end if;
+
Item := (Real_Item, Imag_Item);
exception
@@ -119,7 +158,18 @@ package body Ada.Wide_Text_IO.Complex_IO is
Exp : Field := Default_Exp)
is
begin
- Aux.Put (TFT (File), LLF (Re (Item)), LLF (Im (Item)), Fore, Aft, Exp);
+ if OK_Float then
+ Aux_Float.Put
+ (File, Float (Re (Item)), Float (Im (Item)), Fore, Aft, Exp);
+ elsif OK_Long_Float then
+ Aux_Long_Float.Put
+ (File, Long_Float (Re (Item)), Long_Float (Im (Item)), Fore, Aft,
+ Exp);
+ else
+ Aux_Long_Long_Float.Put
+ (File, Long_Long_Float (Re (Item)), Long_Long_Float (Im (Item)),
+ Fore, Aft, Exp);
+ end if;
end Put;
---------
@@ -133,7 +183,7 @@ package body Ada.Wide_Text_IO.Complex_IO is
Exp : Field := Default_Exp)
is
begin
- Put (Current_Output, Item, Fore, Aft, Exp);
+ Put (Current_Out, Item, Fore, Aft, Exp);
end Put;
---------
@@ -149,7 +199,16 @@ package body Ada.Wide_Text_IO.Complex_IO is
S : String (To'First .. To'Last);
begin
- Aux.Puts (S, LLF (Re (Item)), LLF (Im (Item)), Aft, Exp);
+ if OK_Float then
+ Aux_Float.Puts (S, Float (Re (Item)), Float (Im (Item)), Aft, Exp);
+ elsif OK_Long_Float then
+ Aux_Long_Float.Puts
+ (S, Long_Float (Re (Item)), Long_Float (Im (Item)), Aft, Exp);
+ else
+ Aux_Long_Long_Float.Puts
+ (S, Long_Long_Float (Re (Item)), Long_Long_Float (Im (Item)),
+ Aft, Exp);
+ end if;
for J in S'Range loop
To (J) := Wide_Character'Val (Character'Pos (S (J)));
diff --git a/gcc/ada/libgnat/a-wtcoio.ads b/gcc/ada/libgnat/a-wtcoio.ads
index 31fab2b..f80a5b9 100644
--- a/gcc/ada/libgnat/a-wtcoio.ads
+++ b/gcc/ada/libgnat/a-wtcoio.ads
@@ -20,42 +20,40 @@ generic
package Ada.Wide_Text_IO.Complex_IO is
- use Complex_Types;
-
Default_Fore : Field := 2;
- Default_Aft : Field := Real'Digits - 1;
+ Default_Aft : Field := Complex_Types.Real'Digits - 1;
Default_Exp : Field := 3;
procedure Get
(File : File_Type;
- Item : out Complex;
+ Item : out Complex_Types.Complex;
Width : Field := 0);
procedure Get
- (Item : out Complex;
+ (Item : out Complex_Types.Complex;
Width : Field := 0);
procedure Put
(File : File_Type;
- Item : Complex;
+ Item : Complex_Types.Complex;
Fore : Field := Default_Fore;
Aft : Field := Default_Aft;
Exp : Field := Default_Exp);
procedure Put
- (Item : Complex;
+ (Item : Complex_Types.Complex;
Fore : Field := Default_Fore;
Aft : Field := Default_Aft;
Exp : Field := Default_Exp);
procedure Get
(From : Wide_String;
- Item : out Complex;
+ Item : out Complex_Types.Complex;
Last : out Positive);
procedure Put
(To : out Wide_String;
- Item : Complex;
+ Item : Complex_Types.Complex;
Aft : Field := Default_Aft;
Exp : Field := Default_Exp);
diff --git a/gcc/ada/libgnat/a-wtdeau.adb b/gcc/ada/libgnat/a-wtdeau.adb
index 7bfc613..57fcc92 100644
--- a/gcc/ada/libgnat/a-wtdeau.adb
+++ b/gcc/ada/libgnat/a-wtdeau.adb
@@ -30,56 +30,22 @@
------------------------------------------------------------------------------
with Ada.Wide_Text_IO.Generic_Aux; use Ada.Wide_Text_IO.Generic_Aux;
-with Ada.Wide_Text_IO.Float_Aux; use Ada.Wide_Text_IO.Float_Aux;
-
-with System.Img_Dec; use System.Img_Dec;
-with System.Img_LLD; use System.Img_LLD;
-with System.Val_Dec; use System.Val_Dec;
-with System.Val_LLD; use System.Val_LLD;
package body Ada.Wide_Text_IO.Decimal_Aux is
- -------------
- -- Get_Dec --
- -------------
-
- function Get_Dec
- (File : File_Type;
- Width : Field;
- Scale : Integer) return Integer
- is
- Buf : String (1 .. Field'Last);
- Ptr : aliased Integer;
- Stop : Integer := 0;
- Item : Integer;
-
- begin
- if Width /= 0 then
- Load_Width (File, Width, Buf, Stop);
- String_Skip (Buf, Ptr);
- else
- Load_Real (File, Buf, Stop);
- Ptr := 1;
- end if;
-
- Item := Scan_Decimal (Buf, Ptr'Access, Stop, Scale);
- Check_End_Of_Field (Buf, Stop, Ptr, Width);
- return Item;
- end Get_Dec;
-
- -------------
- -- Get_LLD --
- -------------
+ ---------
+ -- Get --
+ ---------
- function Get_LLD
+ function Get
(File : File_Type;
Width : Field;
- Scale : Integer) return Long_Long_Integer
+ Scale : Integer) return Int
is
Buf : String (1 .. Field'Last);
Ptr : aliased Integer;
Stop : Integer := 0;
- Item : Long_Long_Integer;
+ Item : Int;
begin
if Width /= 0 then
@@ -90,68 +56,42 @@ package body Ada.Wide_Text_IO.Decimal_Aux is
Ptr := 1;
end if;
- Item := Scan_Long_Long_Decimal (Buf, Ptr'Access, Stop, Scale);
+ Item := Scan (Buf, Ptr'Access, Stop, Scale);
Check_End_Of_Field (Buf, Stop, Ptr, Width);
return Item;
- end Get_LLD;
-
- --------------
- -- Gets_Dec --
- --------------
-
- function Gets_Dec
- (From : String;
- Last : not null access Positive;
- Scale : Integer) return Integer
- is
- Pos : aliased Integer;
- Item : Integer;
-
- begin
- String_Skip (From, Pos);
- Item := Scan_Decimal (From, Pos'Access, From'Last, Scale);
- Last.all := Pos - 1;
- return Item;
+ end Get;
- exception
- when Constraint_Error =>
- Last.all := Pos - 1;
- raise Data_Error;
-
- end Gets_Dec;
+ ----------
+ -- Gets --
+ ----------
- --------------
- -- Gets_LLD --
- --------------
-
- function Gets_LLD
+ function Gets
(From : String;
- Last : not null access Positive;
- Scale : Integer) return Long_Long_Integer
+ Last : out Positive;
+ Scale : Integer) return Int
is
Pos : aliased Integer;
- Item : Long_Long_Integer;
+ Item : Int;
begin
String_Skip (From, Pos);
- Item := Scan_Long_Long_Decimal (From, Pos'Access, From'Last, Scale);
- Last.all := Pos - 1;
+ Item := Scan (From, Pos'Access, From'Last, Scale);
+ Last := Pos - 1;
return Item;
exception
when Constraint_Error =>
- Last.all := Pos - 1;
+ Last := Pos - 1;
raise Data_Error;
+ end Gets;
- end Gets_LLD;
-
- -------------
- -- Put_Dec --
- -------------
+ ---------
+ -- Put --
+ ---------
- procedure Put_Dec
+ procedure Put
(File : File_Type;
- Item : Integer;
+ Item : Int;
Fore : Field;
Aft : Field;
Exp : Field;
@@ -161,105 +101,51 @@ package body Ada.Wide_Text_IO.Decimal_Aux is
Ptr : Natural := 0;
begin
- Set_Image_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp);
+ Set_Image (Item, Buf, Ptr, Scale, Fore, Aft, Exp);
Put_Item (File, Buf (1 .. Ptr));
- end Put_Dec;
+ end Put;
- -------------
- -- Put_LLD --
- -------------
+ ----------
+ -- Puts --
+ ----------
- procedure Put_LLD
- (File : File_Type;
- Item : Long_Long_Integer;
- Fore : Field;
- Aft : Field;
- Exp : Field;
- Scale : Integer)
- is
- Buf : String (1 .. Field'Last);
- Ptr : Natural := 0;
-
- begin
- Set_Image_Long_Long_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp);
- Put_Item (File, Buf (1 .. Ptr));
- end Put_LLD;
-
- --------------
- -- Puts_Dec --
- --------------
-
- procedure Puts_Dec
+ procedure Puts
(To : out String;
- Item : Integer;
+ Item : Int;
Aft : Field;
Exp : Field;
Scale : Integer)
is
- Buf : String (1 .. Field'Last);
+ Buf : String (1 .. Positive'Max (Field'Last, To'Length));
Fore : Integer;
Ptr : Natural := 0;
begin
- -- Compute Fore, allowing for Aft digits and the decimal dot
+ -- Compute Fore, allowing for the decimal dot and Aft digits
- Fore := To'Length - Field'Max (1, Aft) - 1;
+ Fore := To'Length - 1 - Field'Max (1, Aft);
- -- Allow for Exp and two more for E+ or E- if exponent present
+ -- Allow for Exp and one more for E if exponent present
if Exp /= 0 then
- Fore := Fore - 2 - Exp;
+ Fore := Fore - 1 - Field'Max (2, Exp);
end if;
-- Make sure we have enough room
- if Fore < 1 then
+ if Fore < 1 + Boolean'Pos (Item < 0) then
raise Layout_Error;
end if;
-- Do the conversion and check length of result
- Set_Image_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp);
-
- if Ptr > To'Length then
- raise Layout_Error;
- else
- To := Buf (1 .. Ptr);
- end if;
- end Puts_Dec;
-
- --------------
- -- Puts_LLD --
- --------------
-
- procedure Puts_LLD
- (To : out String;
- Item : Long_Long_Integer;
- Aft : Field;
- Exp : Field;
- Scale : Integer)
- is
- Buf : String (1 .. Field'Last);
- Fore : Integer;
- Ptr : Natural := 0;
-
- begin
- Fore :=
- (if Exp = 0
- then To'Length - 1 - Aft
- else To'Length - 2 - Aft - Exp);
-
- if Fore < 1 then
- raise Layout_Error;
- end if;
-
- Set_Image_Long_Long_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp);
+ Set_Image (Item, Buf, Ptr, Scale, Fore, Aft, Exp);
if Ptr > To'Length then
raise Layout_Error;
else
To := Buf (1 .. Ptr);
end if;
- end Puts_LLD;
+ end Puts;
end Ada.Wide_Text_IO.Decimal_Aux;
diff --git a/gcc/ada/libgnat/a-wtdeau.ads b/gcc/ada/libgnat/a-wtdeau.ads
index 0465455..5c0c4d6 100644
--- a/gcc/ada/libgnat/a-wtdeau.ads
+++ b/gcc/ada/libgnat/a-wtdeau.ads
@@ -29,63 +29,54 @@
-- --
------------------------------------------------------------------------------
--- This package contains the routines for Ada.Wide_Text_IO.Decimal_IO
--- that are shared among separate instantiations of this package. The
--- routines in the package are identical semantically to those declared
--- in Wide_Text_IO, except that default values have been supplied by the
--- generic, and the Num parameter has been replaced by Integer or
--- Long_Long_Integer, with an additional Scale parameter giving the
--- value of Num'Scale. In addition the Get routines return the value
--- rather than store it in an Out parameter.
+-- This package contains the implementation for Ada.Wide_Text_IO.Decimal_IO.
+-- Routines in this package are identical semantically to those in Decimal_IO,
+-- except that the default parameters have been removed because they are
+-- supplied explicitly by the calls from within these units, and there is an
+-- additional Scale parameter giving the value of Num'Scale. In addition the
+-- Get routines return the value rather than store it in an Out parameter.
-private package Ada.Wide_Text_IO.Decimal_Aux is
+private generic
+ type Int is range <>;
- function Get_Dec
- (File : File_Type;
- Width : Field;
- Scale : Integer) return Integer;
+ with function Scan
+ (Str : String;
+ Ptr : not null access Integer;
+ Max : Integer;
+ Scale : Integer) return Int;
- function Get_LLD
- (File : File_Type;
- Width : Field;
- Scale : Integer) return Long_Long_Integer;
+ with procedure Set_Image
+ (V : Int;
+ S : in out String;
+ P : in out Natural;
+ Scale : Integer;
+ Fore : Natural;
+ Aft : Natural;
+ Exp : Natural);
- function Gets_Dec
- (From : String;
- Last : not null access Positive;
- Scale : Integer) return Integer;
+package Ada.Wide_Text_IO.Decimal_Aux is
- function Gets_LLD
- (From : String;
- Last : not null access Positive;
- Scale : Integer) return Long_Long_Integer;
-
- procedure Put_Dec
+ function Get
(File : File_Type;
- Item : Integer;
- Fore : Field;
- Aft : Field;
- Exp : Field;
- Scale : Integer);
+ Width : Field;
+ Scale : Integer) return Int;
- procedure Put_LLD
+ procedure Put
(File : File_Type;
- Item : Long_Long_Integer;
+ Item : Int;
Fore : Field;
Aft : Field;
Exp : Field;
Scale : Integer);
- procedure Puts_Dec
- (To : out String;
- Item : Integer;
- Aft : Field;
- Exp : Field;
- Scale : Integer);
+ function Gets
+ (From : String;
+ Last : out Positive;
+ Scale : Integer) return Int;
- procedure Puts_LLD
+ procedure Puts
(To : out String;
- Item : Long_Long_Integer;
+ Item : Int;
Aft : Field;
Exp : Field;
Scale : Integer);
diff --git a/gcc/ada/libgnat/a-wtdeio.adb b/gcc/ada/libgnat/a-wtdeio.adb
index 845a217..c503a20 100644
--- a/gcc/ada/libgnat/a-wtdeio.adb
+++ b/gcc/ada/libgnat/a-wtdeio.adb
@@ -30,16 +30,35 @@
------------------------------------------------------------------------------
with Ada.Wide_Text_IO.Decimal_Aux;
-
+with System.Img_Decimal_32; use System.Img_Decimal_32;
+with System.Img_Decimal_64; use System.Img_Decimal_64;
+with System.Val_Decimal_32; use System.Val_Decimal_32;
+with System.Val_Decimal_64; use System.Val_Decimal_64;
with System.WCh_Con; use System.WCh_Con;
with System.WCh_WtS; use System.WCh_WtS;
package body Ada.Wide_Text_IO.Decimal_IO is
- subtype TFT is Ada.Wide_Text_IO.File_Type;
- -- File type required for calls to routines in Aux
+ subtype Int32 is Interfaces.Integer_32;
+ subtype Int64 is Interfaces.Integer_64;
+
+ package Aux32 is new
+ Ada.Wide_Text_IO.Decimal_Aux
+ (Int32,
+ Scan_Decimal32,
+ Set_Image_Decimal32);
- package Aux renames Ada.Wide_Text_IO.Decimal_Aux;
+ package Aux64 is new
+ Ada.Wide_Text_IO.Decimal_Aux
+ (Int64,
+ Scan_Decimal64,
+ Set_Image_Decimal64);
+
+ Need64 : constant Boolean := Num'Size > 32;
+ -- Throughout this generic body, we distinguish between the case where type
+ -- Int32 is acceptable and where type Int64 is needed. This Boolean is used
+ -- to test for these cases and since it is a constant, only code for the
+ -- relevant case will be included in the instance.
Scale : constant Integer := Num'Scale;
@@ -52,12 +71,15 @@ package body Ada.Wide_Text_IO.Decimal_IO is
Item : out Num;
Width : Field := 0)
is
+ pragma Unsuppress (Range_Check);
+
begin
- if Num'Size > Integer'Size then
- Item := Num'Fixed_Value (Aux.Get_LLD (TFT (File), Width, Scale));
+ if Need64 then
+ Item := Num'Fixed_Value (Aux64.Get (File, Width, Scale));
else
- Item := Num'Fixed_Value (Aux.Get_Dec (TFT (File), Width, Scale));
+ Item := Num'Fixed_Value (Aux32.Get (File, Width, Scale));
end if;
+
exception
when Constraint_Error => raise Data_Error;
end Get;
@@ -67,7 +89,7 @@ package body Ada.Wide_Text_IO.Decimal_IO is
Width : Field := 0)
is
begin
- Get (Current_Input, Item, Width);
+ Get (Current_In, Item, Width);
end Get;
procedure Get
@@ -75,6 +97,8 @@ package body Ada.Wide_Text_IO.Decimal_IO is
Item : out Num;
Last : out Positive)
is
+ pragma Unsuppress (Range_Check);
+
S : constant String := Wide_String_To_String (From, WCEM_Upper);
-- String on which we do the actual conversion. Note that the method
-- used for wide character encoding is irrelevant, since if there is
@@ -82,16 +106,10 @@ package body Ada.Wide_Text_IO.Decimal_IO is
-- Aux.Gets will raise Data_Error in any case.
begin
- if Num'Size > Integer'Size then
- -- Item := Num'Fixed_Value
- -- should write above, but gets assert error ???
- Item := Num
- (Aux.Gets_LLD (S, Last'Unrestricted_Access, Scale));
+ if Need64 then
+ Item := Num'Fixed_Value (Aux64.Gets (S, Last, Scale));
else
- -- Item := Num'Fixed_Value
- -- should write above, but gets assert error ???
- Item := Num
- (Aux.Gets_Dec (S, Last'Unrestricted_Access, Scale));
+ Item := Num'Fixed_Value (Aux32.Gets (S, Last, Scale));
end if;
exception
@@ -110,13 +128,12 @@ package body Ada.Wide_Text_IO.Decimal_IO is
Exp : Field := Default_Exp)
is
begin
- if Num'Size > Integer'Size then
- Aux.Put_LLD
- (TFT (File), Long_Long_Integer'Integer_Value (Item),
- Fore, Aft, Exp, Scale);
+ if Need64 then
+ Aux64.Put
+ (File, Int64'Integer_Value (Item), Fore, Aft, Exp, Scale);
else
- Aux.Put_Dec
- (TFT (File), Integer'Integer_Value (Item), Fore, Aft, Exp, Scale);
+ Aux32.Put
+ (File, Int32'Integer_Value (Item), Fore, Aft, Exp, Scale);
end if;
end Put;
@@ -127,7 +144,7 @@ package body Ada.Wide_Text_IO.Decimal_IO is
Exp : Field := Default_Exp)
is
begin
- Put (Current_Output, Item, Fore, Aft, Exp);
+ Put (Current_Out, Item, Fore, Aft, Exp);
end Put;
procedure Put
@@ -139,12 +156,10 @@ package body Ada.Wide_Text_IO.Decimal_IO is
S : String (To'First .. To'Last);
begin
- if Num'Size > Integer'Size then
- Aux.Puts_LLD
- (S, Long_Long_Integer'Integer_Value (Item), Aft, Exp, Scale);
-
+ if Need64 then
+ Aux64.Puts (S, Int64'Integer_Value (Item), Aft, Exp, Scale);
else
- Aux.Puts_Dec (S, Integer'Integer_Value (Item), Aft, Exp, Scale);
+ Aux32.Puts (S, Int32'Integer_Value (Item), Aft, Exp, Scale);
end if;
for J in S'Range loop
diff --git a/gcc/ada/libgnat/a-wtdeio__128.adb b/gcc/ada/libgnat/a-wtdeio__128.adb
new file mode 100644
index 0000000..796c724
--- /dev/null
+++ b/gcc/ada/libgnat/a-wtdeio__128.adb
@@ -0,0 +1,190 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . W I D E _ T E X T _ I O . D E C I M A L _ I O --
+-- --
+-- 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.Wide_Text_IO.Decimal_Aux;
+with System.Img_Decimal_32; use System.Img_Decimal_32;
+with System.Img_Decimal_64; use System.Img_Decimal_64;
+with System.Img_Decimal_128; use System.Img_Decimal_128;
+with System.Val_Decimal_32; use System.Val_Decimal_32;
+with System.Val_Decimal_64; use System.Val_Decimal_64;
+with System.Val_Decimal_128; use System.Val_Decimal_128;
+with System.WCh_Con; use System.WCh_Con;
+with System.WCh_WtS; use System.WCh_WtS;
+
+package body Ada.Wide_Text_IO.Decimal_IO is
+
+ subtype Int32 is Interfaces.Integer_32;
+ subtype Int64 is Interfaces.Integer_64;
+ subtype Int128 is Interfaces.Integer_128;
+
+ package Aux32 is new
+ Ada.Wide_Text_IO.Decimal_Aux
+ (Int32,
+ Scan_Decimal32,
+ Set_Image_Decimal32);
+
+ package Aux64 is new
+ Ada.Wide_Text_IO.Decimal_Aux
+ (Int64,
+ Scan_Decimal64,
+ Set_Image_Decimal64);
+
+ package Aux128 is new
+ Ada.Wide_Text_IO.Decimal_Aux
+ (Int128,
+ Scan_Decimal128,
+ Set_Image_Decimal128);
+
+ Need64 : constant Boolean := Num'Size > 32;
+ Need128 : constant Boolean := Num'Size > 64;
+ -- Throughout this generic body, we distinguish between the case where type
+ -- Int32 is acceptable, where type Int64 is acceptable and where an Int128
+ -- is needed. These boolean constants are used to test for these cases and
+ -- since it is a constant, only code for the relevant case will be included
+ -- in the instance.
+
+ Scale : constant Integer := Num'Scale;
+
+ ---------
+ -- Get --
+ ---------
+
+ procedure Get
+ (File : File_Type;
+ Item : out Num;
+ Width : Field := 0)
+ is
+ pragma Unsuppress (Range_Check);
+
+ begin
+ if Need128 then
+ Item := Num'Fixed_Value (Aux128.Get (File, Width, Scale));
+ elsif Need64 then
+ Item := Num'Fixed_Value (Aux64.Get (File, Width, Scale));
+ else
+ Item := Num'Fixed_Value (Aux32.Get (File, Width, Scale));
+ end if;
+
+ exception
+ when Constraint_Error => raise Data_Error;
+ end Get;
+
+ procedure Get
+ (Item : out Num;
+ Width : Field := 0)
+ is
+ begin
+ Get (Current_In, Item, Width);
+ end Get;
+
+ procedure Get
+ (From : Wide_String;
+ Item : out Num;
+ Last : out Positive)
+ is
+ pragma Unsuppress (Range_Check);
+
+ S : constant String := Wide_String_To_String (From, WCEM_Upper);
+ -- String on which we do the actual conversion. Note that the method
+ -- used for wide character encoding is irrelevant, since if there is
+ -- a character outside the Standard.Character range then the call to
+ -- Aux.Gets will raise Data_Error in any case.
+
+ begin
+ if Need128 then
+ Item := Num'Fixed_Value (Aux128.Gets (S, Last, Scale));
+ elsif Need64 then
+ Item := Num'Fixed_Value (Aux64.Gets (S, Last, Scale));
+ else
+ Item := Num'Fixed_Value (Aux32.Gets (S, Last, Scale));
+ end if;
+
+ exception
+ when Constraint_Error => raise Data_Error;
+ end Get;
+
+ ---------
+ -- Put --
+ ---------
+
+ procedure Put
+ (File : File_Type;
+ Item : Num;
+ Fore : Field := Default_Fore;
+ Aft : Field := Default_Aft;
+ Exp : Field := Default_Exp)
+ is
+ begin
+ if Need128 then
+ Aux128.Put
+ (File, Int128'Integer_Value (Item), Fore, Aft, Exp, Scale);
+ elsif Need64 then
+ Aux64.Put
+ (File, Int64'Integer_Value (Item), Fore, Aft, Exp, Scale);
+ else
+ Aux32.Put
+ (File, Int32'Integer_Value (Item), Fore, Aft, Exp, Scale);
+ end if;
+ end Put;
+
+ procedure Put
+ (Item : Num;
+ Fore : Field := Default_Fore;
+ Aft : Field := Default_Aft;
+ Exp : Field := Default_Exp)
+ is
+ begin
+ Put (Current_Out, Item, Fore, Aft, Exp);
+ end Put;
+
+ procedure Put
+ (To : out Wide_String;
+ Item : Num;
+ Aft : Field := Default_Aft;
+ Exp : Field := Default_Exp)
+ is
+ S : String (To'First .. To'Last);
+
+ begin
+ if Need128 then
+ Aux128.Puts (S, Int128'Integer_Value (Item), Aft, Exp, Scale);
+ elsif Need64 then
+ Aux64.Puts (S, Int64'Integer_Value (Item), Aft, Exp, Scale);
+ else
+ Aux32.Puts (S, Int32'Integer_Value (Item), Aft, Exp, Scale);
+ end if;
+
+ for J in S'Range loop
+ To (J) := Wide_Character'Val (Character'Pos (S (J)));
+ end loop;
+ end Put;
+
+end Ada.Wide_Text_IO.Decimal_IO;
diff --git a/gcc/ada/libgnat/a-wtenau.adb b/gcc/ada/libgnat/a-wtenau.adb
index 3fb6f76..6dcda30 100644
--- a/gcc/ada/libgnat/a-wtenau.adb
+++ b/gcc/ada/libgnat/a-wtenau.adb
@@ -36,9 +36,6 @@ with System.WCh_Con; use System.WCh_Con;
package body Ada.Wide_Text_IO.Enumeration_Aux is
- subtype TFT is Ada.Wide_Text_IO.File_Type;
- -- File type required for calls to routines in Aux
-
-----------------------
-- Local Subprograms --
-----------------------
@@ -69,8 +66,8 @@ package body Ada.Wide_Text_IO.Enumeration_Aux is
begin
Buflen := 0;
- Load_Skip (TFT (File));
- ch := Nextc (TFT (File));
+ Load_Skip (File);
+ ch := Nextc (File);
-- Character literal case. If the initial character is a quote, then
-- we read as far as we can without backup (see ACVC test CE3905L)
@@ -79,7 +76,7 @@ package body Ada.Wide_Text_IO.Enumeration_Aux is
Get (File, WC);
Store_Char (WC, Buf, Buflen);
- ch := Nextc (TFT (File));
+ ch := Nextc (File);
if ch = LM or else ch = EOF then
return;
@@ -88,7 +85,7 @@ package body Ada.Wide_Text_IO.Enumeration_Aux is
Get (File, WC);
Store_Char (WC, Buf, Buflen);
- ch := Nextc (TFT (File));
+ ch := Nextc (File);
if ch /= Character'Pos (''') then
return;
@@ -117,7 +114,7 @@ package body Ada.Wide_Text_IO.Enumeration_Aux is
Get (File, WC);
Store_Char (WC, Buf, Buflen);
- ch := Nextc (TFT (File));
+ ch := Nextc (File);
exit when ch = EOF;
@@ -155,7 +152,7 @@ package body Ada.Wide_Text_IO.Enumeration_Aux is
Integer'Max (Integer (Width), Item'Length);
begin
- Check_On_One_Line (TFT (File), Actual_Width);
+ Check_On_One_Line (File, Actual_Width);
if Set = Lower_Case and then Item (Item'First) /= ''' then
declare
diff --git a/gcc/ada/libgnat/a-wtenio.adb b/gcc/ada/libgnat/a-wtenio.adb
index ee500f9..f89359c 100644
--- a/gcc/ada/libgnat/a-wtenio.adb
+++ b/gcc/ada/libgnat/a-wtenio.adb
@@ -51,7 +51,7 @@ package body Ada.Wide_Text_IO.Enumeration_IO is
procedure Get (Item : out Enum) is
begin
- Get (Current_Input, Item);
+ Get (Current_In, Item);
end Get;
procedure Get
@@ -88,7 +88,7 @@ package body Ada.Wide_Text_IO.Enumeration_IO is
Set : Type_Set := Default_Setting)
is
begin
- Put (Current_Output, Item, Width, Set);
+ Put (Current_Out, Item, Width, Set);
end Put;
procedure Put
diff --git a/gcc/ada/libgnat/a-wtfiau.adb b/gcc/ada/libgnat/a-wtfiau.adb
new file mode 100644
index 0000000..611b76d
--- /dev/null
+++ b/gcc/ada/libgnat/a-wtfiau.adb
@@ -0,0 +1,159 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . W I D E _ T E X T _ I O . F I X E D _ I O --
+-- --
+-- 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.Wide_Text_IO.Generic_Aux; use Ada.Wide_Text_IO.Generic_Aux;
+
+package body Ada.Wide_Text_IO.Fixed_Aux is
+
+ ---------
+ -- Get --
+ ---------
+
+ function Get
+ (File : File_Type;
+ Width : Field;
+ Num : Int;
+ Den : Int) return Int
+ is
+ Buf : String (1 .. Field'Last);
+ Ptr : aliased Integer;
+ Stop : Integer := 0;
+ Item : Int;
+
+ begin
+ if Width /= 0 then
+ Load_Width (File, Width, Buf, Stop);
+ String_Skip (Buf, Ptr);
+ else
+ Load_Real (File, Buf, Stop);
+ Ptr := 1;
+ end if;
+
+ Item := Scan (Buf, Ptr'Access, Stop, Num, Den);
+ Check_End_Of_Field (Buf, Stop, Ptr, Width);
+ return Item;
+ end Get;
+
+ ----------
+ -- Gets --
+ ----------
+
+ function Gets
+ (From : String;
+ Last : out Positive;
+ Num : Int;
+ Den : Int) return Int
+ is
+ Pos : aliased Integer;
+ Item : Int;
+
+ begin
+ String_Skip (From, Pos);
+ Item := Scan (From, Pos'Access, From'Last, Num, Den);
+ Last := Pos - 1;
+ return Item;
+
+ exception
+ when Constraint_Error =>
+ Last := Pos - 1;
+ raise Data_Error;
+ end Gets;
+
+ ---------
+ -- Put --
+ ---------
+
+ procedure Put
+ (File : File_Type;
+ Item : Int;
+ Fore : Field;
+ Aft : Field;
+ Exp : Natural;
+ Num : Int;
+ Den : Int;
+ For0 : Natural;
+ Aft0 : Natural)
+ is
+ Buf : String (1 .. Field'Last);
+ Ptr : Natural := 0;
+
+ begin
+ Set_Image (Item, Buf, Ptr, Num, Den, For0, Aft0, Fore, Aft, Exp);
+ Put_Item (File, Buf (1 .. Ptr));
+ end Put;
+
+ ----------
+ -- Puts --
+ ----------
+
+ procedure Puts
+ (To : out String;
+ Item : Int;
+ Aft : Field;
+ Exp : Natural;
+ Num : Int;
+ Den : Int;
+ For0 : Natural;
+ Aft0 : Natural)
+ is
+ Buf : String (1 .. Positive'Max (Field'Last, To'Length));
+ Fore : Integer;
+ Ptr : Natural := 0;
+
+ begin
+ -- Compute Fore, allowing for the decimal dot and Aft digits
+
+ Fore := To'Length - 1 - Field'Max (1, Aft);
+
+ -- Allow for Exp and one more for E if exponent present
+
+ if Exp /= 0 then
+ Fore := Fore - 1 - Field'Max (2, Exp);
+ end if;
+
+ -- Make sure we have enough room
+
+ if Fore < 1 + Boolean'Pos (Item < 0) then
+ raise Layout_Error;
+ end if;
+
+ -- Do the conversion and check length of result
+
+ Set_Image (Item, Buf, Ptr, Num, Den, For0, Aft0, Fore, Aft, Exp);
+
+ if Ptr > To'Length then
+ raise Layout_Error;
+ else
+ To := Buf (1 .. Ptr);
+ end if;
+ end Puts;
+
+end Ada.Wide_Text_IO.Fixed_Aux;
diff --git a/gcc/ada/libgnat/a-wtfiau.ads b/gcc/ada/libgnat/a-wtfiau.ads
new file mode 100644
index 0000000..f487931
--- /dev/null
+++ b/gcc/ada/libgnat/a-wtfiau.ads
@@ -0,0 +1,97 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . W I D E _ T E X T _ I O . F I X E D _ I O --
+-- --
+-- 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. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains the implementation for Ada.Wide_Text_IO.Fixed_IO.
+-- Routines in this package are identical semantically to those in Fixed_IO,
+-- except that the default parameters have been removed because they are
+-- supplied explicitly by the calls from within these units, and there are
+-- additional Num and Den parameters giving the value of Num'Small, as well
+-- as For0 and Aft0 giving some properties of Num'Small. In addition the Get
+-- routines return the value rather than store it in an Out parameter.
+
+private generic
+ type Int is range <>;
+
+ with function Scan
+ (Str : String;
+ Ptr : not null access Integer;
+ Max : Integer;
+ Num : Int;
+ Den : Int) return Int;
+
+ with procedure Set_Image
+ (V : Int;
+ S : in out String;
+ P : in out Natural;
+ Num : Int;
+ Den : Int;
+ For0 : Natural;
+ Aft0 : Natural;
+ Fore : Natural;
+ Aft : Natural;
+ Exp : Natural);
+
+package Ada.Wide_Text_IO.Fixed_Aux is
+
+ function Get
+ (File : File_Type;
+ Width : Field;
+ Num : Int;
+ Den : Int) return Int;
+
+ procedure Put
+ (File : File_Type;
+ Item : Int;
+ Fore : Field;
+ Aft : Field;
+ Exp : Natural;
+ Num : Int;
+ Den : Int;
+ For0 : Natural;
+ Aft0 : Natural);
+
+ function Gets
+ (From : String;
+ Last : out Positive;
+ Num : Int;
+ Den : Int) return Int;
+
+ procedure Puts
+ (To : out String;
+ Item : Int;
+ Aft : Field;
+ Exp : Natural;
+ Num : Int;
+ Den : Int;
+ For0 : Natural;
+ Aft0 : Natural);
+
+end Ada.Wide_Text_IO.Fixed_Aux;
diff --git a/gcc/ada/libgnat/a-wtfiio.adb b/gcc/ada/libgnat/a-wtfiio.adb
index f70c8e4..e2537ae 100644
--- a/gcc/ada/libgnat/a-wtfiio.adb
+++ b/gcc/ada/libgnat/a-wtfiio.adb
@@ -2,7 +2,7 @@
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
--- A D A . T E X T _ I O . W I D E _ T E X T _ I O . F I X E D _ I O --
+-- A D A . W I D E _ T E X T _ I O . F I X E D _ I O --
-- --
-- B o d y --
-- --
@@ -29,16 +29,114 @@
-- --
------------------------------------------------------------------------------
+with Interfaces;
+with Ada.Wide_Text_IO.Fixed_Aux;
with Ada.Wide_Text_IO.Float_Aux;
-with System.WCh_Con; use System.WCh_Con;
-with System.WCh_WtS; use System.WCh_WtS;
+with System.Img_Fixed_32; use System.Img_Fixed_32;
+with System.Img_Fixed_64; use System.Img_Fixed_64;
+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.WCh_Con; use System.WCh_Con;
+with System.WCh_WtS; use System.WCh_WtS;
package body Ada.Wide_Text_IO.Fixed_IO is
- subtype TFT is Ada.Wide_Text_IO.File_Type;
- -- File type required for calls to routines in Aux
+ -- 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.
- package Aux renames Ada.Wide_Text_IO.Float_Aux;
+ subtype Int32 is Interfaces.Integer_32; use type Int32;
+ subtype Int64 is Interfaces.Integer_64; use type Int64;
+
+ package Aux32 is new
+ Ada.Wide_Text_IO.Fixed_Aux (Int32, Scan_Fixed32, Set_Image_Fixed32);
+
+ 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);
+
+ -- 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
+ -- to test for this, such that only code for the relevant case is included
+ -- in the instance; that's why the computation of their value must be fully
+ -- static (although it is not a static expressions in the RM sense).
+
+ OK_Get_32 : constant Boolean :=
+ Num'Base'Object_Size <= 32
+ and then
+ ((Num'Small_Numerator = 1 and then Num'Small_Denominator <= 2**31)
+ or else
+ (Num'Small_Denominator = 1 and then Num'Small_Numerator <= 2**31)
+ or else
+ (Num'Small_Numerator <= 2**27
+ and then Num'Small_Denominator <= 2**27));
+ -- These conditions are derived from the prerequisites of System.Value_F
+
+ OK_Put_32 : constant Boolean :=
+ Num'Base'Object_Size <= 32
+ and then
+ ((Num'Small_Numerator = 1 and then Num'Small_Denominator <= 2**31)
+ or else
+ (Num'Small_Denominator = 1 and then Num'Small_Numerator <= 2**31)
+ or else
+ (Num'Small_Numerator < Num'Small_Denominator
+ and then Num'Small_Denominator <= 2**27)
+ or else
+ (Num'Small_Denominator < Num'Small_Numerator
+ and then Num'Small_Numerator <= 2**25));
+ -- These conditions are derived from the prerequisites of System.Image_F
+
+ OK_Get_64 : constant Boolean :=
+ Num'Base'Object_Size <= 64
+ and then
+ ((Num'Small_Numerator = 1 and then Num'Small_Denominator <= 2**63)
+ or else
+ (Num'Small_Denominator = 1 and then Num'Small_Numerator <= 2**63)
+ or else
+ (Num'Small_Numerator <= 2**59
+ and then Num'Small_Denominator <= 2**59));
+ -- These conditions are derived from the prerequisites of System.Value_F
+
+ OK_Put_64 : constant Boolean :=
+ Num'Base'Object_Size <= 64
+ and then
+ ((Num'Small_Numerator = 1 and then Num'Small_Denominator <= 2**63)
+ or else
+ (Num'Small_Denominator = 1 and then Num'Small_Numerator <= 2**63)
+ or else
+ (Num'Small_Numerator < Num'Small_Denominator
+ and then Num'Small_Denominator <= 2**59)
+ or else
+ (Num'Small_Denominator < Num'Small_Numerator
+ and then Num'Small_Numerator <= 2**53));
+ -- These conditions are derived from the prerequisites of System.Image_F
+
+ E : constant Natural := 63 - 32 * Boolean'Pos (OK_Put_32);
+ -- T'Size - 1 for the selected Int{32,64}
+
+ F0 : constant Natural := 0;
+ F1 : constant Natural :=
+ F0 + 18 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F0) >= 1.0E+18);
+ F2 : constant Natural :=
+ F1 + 9 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F1) >= 1.0E+9);
+ F3 : constant Natural :=
+ F2 + 5 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F2) >= 1.0E+5);
+ F4 : constant Natural :=
+ F3 + 3 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F3) >= 1.0E+3);
+ F5 : constant Natural :=
+ F4 + 2 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F4) >= 1.0E+2);
+ F6 : constant Natural :=
+ F5 + 1 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F5) >= 1.0E+1);
+ -- Binary search for the number of digits - 1 before the decimal point of
+ -- the product 2.0**E * Num'Small.
+
+ For0 : constant Natural := 2 + F6;
+ -- Fore value for the fixed point type whose mantissa is Int{32,64} and
+ -- whose small is Num'Small.
---------
-- Get --
@@ -49,8 +147,22 @@ package body Ada.Wide_Text_IO.Fixed_IO is
Item : out Num;
Width : Field := 0)
is
+ pragma Unsuppress (Range_Check);
+
begin
- Aux.Get (TFT (File), Long_Long_Float (Item), Width);
+ if OK_Get_32 then
+ Item := Num'Fixed_Value
+ (Aux32.Get (File, Width,
+ -Num'Small_Numerator,
+ -Num'Small_Denominator));
+ elsif OK_Get_64 then
+ Item := Num'Fixed_Value
+ (Aux64.Get (File, Width,
+ -Num'Small_Numerator,
+ -Num'Small_Denominator));
+ else
+ Aux_Long_Long_Float.Get (File, Long_Long_Float (Item), Width);
+ end if;
exception
when Constraint_Error => raise Data_Error;
@@ -61,7 +173,7 @@ package body Ada.Wide_Text_IO.Fixed_IO is
Width : Field := 0)
is
begin
- Get (Current_Input, Item, Width);
+ Get (Current_In, Item, Width);
end Get;
procedure Get
@@ -69,6 +181,8 @@ package body Ada.Wide_Text_IO.Fixed_IO is
Item : out Num;
Last : out Positive)
is
+ pragma Unsuppress (Range_Check);
+
S : constant String := Wide_String_To_String (From, WCEM_Upper);
-- String on which we do the actual conversion. Note that the method
-- used for wide character encoding is irrelevant, since if there is
@@ -76,7 +190,19 @@ package body Ada.Wide_Text_IO.Fixed_IO is
-- Aux.Gets will raise Data_Error in any case.
begin
- Aux.Gets (S, Long_Long_Float (Item), Last);
+ if OK_Get_32 then
+ Item := Num'Fixed_Value
+ (Aux32.Gets (S, Last,
+ -Num'Small_Numerator,
+ -Num'Small_Denominator));
+ elsif OK_Get_64 then
+ Item := Num'Fixed_Value
+ (Aux64.Gets (S, Last,
+ -Num'Small_Numerator,
+ -Num'Small_Denominator));
+ else
+ Aux_Long_Long_Float.Gets (S, Long_Long_Float (Item), Last);
+ end if;
exception
when Constraint_Error => raise Data_Error;
@@ -94,7 +220,18 @@ package body Ada.Wide_Text_IO.Fixed_IO is
Exp : Field := Default_Exp)
is
begin
- Aux.Put (TFT (File), Long_Long_Float (Item), Fore, Aft, Exp);
+ if OK_Put_32 then
+ Aux32.Put (File, Int32'Integer_Value (Item), Fore, Aft, Exp,
+ -Num'Small_Numerator, -Num'Small_Denominator,
+ For0, Num'Aft);
+ elsif OK_Put_64 then
+ Aux64.Put (File, Int64'Integer_Value (Item), Fore, Aft, Exp,
+ -Num'Small_Numerator, -Num'Small_Denominator,
+ For0, Num'Aft);
+ else
+ Aux_Long_Long_Float.Put
+ (File, Long_Long_Float (Item), Fore, Aft, Exp);
+ end if;
end Put;
procedure Put
@@ -104,7 +241,7 @@ package body Ada.Wide_Text_IO.Fixed_IO is
Exp : Field := Default_Exp)
is
begin
- Put (Current_Output, Item, Fore, Aft, Exp);
+ Put (Current_Out, Item, Fore, Aft, Exp);
end Put;
procedure Put
@@ -116,7 +253,17 @@ package body Ada.Wide_Text_IO.Fixed_IO is
S : String (To'First .. To'Last);
begin
- Aux.Puts (S, Long_Long_Float (Item), Aft, Exp);
+ if OK_Put_32 then
+ Aux32.Puts (S, Int32'Integer_Value (Item), Aft, Exp,
+ -Num'Small_Numerator, -Num'Small_Denominator,
+ For0, Num'Aft);
+ elsif OK_Put_64 then
+ Aux64.Puts (S, Int64'Integer_Value (Item), Aft, Exp,
+ -Num'Small_Numerator, -Num'Small_Denominator,
+ For0, Num'Aft);
+ else
+ Aux_Long_Long_Float.Puts (S, Long_Long_Float (Item), Aft, Exp);
+ end if;
for J in S'Range loop
To (J) := Wide_Character'Val (Character'Pos (S (J)));
diff --git a/gcc/ada/libgnat/a-wtfiio__128.adb b/gcc/ada/libgnat/a-wtfiio__128.adb
new file mode 100644
index 0000000..a5801be
--- /dev/null
+++ b/gcc/ada/libgnat/a-wtfiio__128.adb
@@ -0,0 +1,326 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . W I D E _ T E X T _ I O . F I X E D _ I O --
+-- --
+-- 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 Interfaces;
+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_Fixed_128; use System.Img_Fixed_128;
+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.WCh_Con; use System.WCh_Con;
+with System.WCh_WtS; use System.WCh_WtS;
+
+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.
+
+ subtype Int32 is Interfaces.Integer_32; use type Int32;
+ subtype Int64 is Interfaces.Integer_64; use type Int64;
+ subtype Int128 is Interfaces.Integer_128; use type Int128;
+
+ package Aux32 is new
+ Ada.Wide_Text_IO.Fixed_Aux (Int32, Scan_Fixed32, Set_Image_Fixed32);
+
+ package Aux64 is new
+ Ada.Wide_Text_IO.Fixed_Aux (Int64, Scan_Fixed64, Set_Image_Fixed64);
+
+ 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);
+
+ -- 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
+ -- boolean constants are used to test for this, such that only code for the
+ -- relevant case is included in the instance; that's why the computation of
+ -- their value must be fully static (although it is not a static expression
+ -- in the RM sense).
+
+ OK_Get_32 : constant Boolean :=
+ Num'Base'Object_Size <= 32
+ and then
+ ((Num'Small_Numerator = 1 and then Num'Small_Denominator <= 2**31)
+ or else
+ (Num'Small_Denominator = 1 and then Num'Small_Numerator <= 2**31)
+ or else
+ (Num'Small_Numerator <= 2**27
+ and then Num'Small_Denominator <= 2**27));
+ -- These conditions are derived from the prerequisites of System.Value_F
+
+ OK_Put_32 : constant Boolean :=
+ Num'Base'Object_Size <= 32
+ and then
+ ((Num'Small_Numerator = 1 and then Num'Small_Denominator <= 2**31)
+ or else
+ (Num'Small_Denominator = 1 and then Num'Small_Numerator <= 2**31)
+ or else
+ (Num'Small_Numerator < Num'Small_Denominator
+ and then Num'Small_Denominator <= 2**27)
+ or else
+ (Num'Small_Denominator < Num'Small_Numerator
+ and then Num'Small_Numerator <= 2**25));
+ -- These conditions are derived from the prerequisites of System.Image_F
+
+ OK_Get_64 : constant Boolean :=
+ Num'Base'Object_Size <= 64
+ and then
+ ((Num'Small_Numerator = 1 and then Num'Small_Denominator <= 2**63)
+ or else
+ (Num'Small_Denominator = 1 and then Num'Small_Numerator <= 2**63)
+ or else
+ (Num'Small_Numerator <= 2**59
+ and then Num'Small_Denominator <= 2**59));
+ -- These conditions are derived from the prerequisites of System.Value_F
+
+ OK_Put_64 : constant Boolean :=
+ Num'Base'Object_Size <= 64
+ and then
+ ((Num'Small_Numerator = 1 and then Num'Small_Denominator <= 2**63)
+ or else
+ (Num'Small_Denominator = 1 and then Num'Small_Numerator <= 2**63)
+ or else
+ (Num'Small_Numerator < Num'Small_Denominator
+ and then Num'Small_Denominator <= 2**59)
+ or else
+ (Num'Small_Denominator < Num'Small_Numerator
+ and then Num'Small_Numerator <= 2**53));
+ -- These conditions are derived from the prerequisites of System.Image_F
+
+ OK_Get_128 : constant Boolean :=
+ Num'Base'Object_Size <= 128
+ and then
+ ((Num'Small_Numerator = 1 and then Num'Small_Denominator <= 2**127)
+ or else
+ (Num'Small_Denominator = 1 and then Num'Small_Numerator <= 2**127)
+ or else
+ (Num'Small_Numerator <= 2**123
+ and then Num'Small_Denominator <= 2**123));
+ -- These conditions are derived from the prerequisites of System.Value_F
+
+ OK_Put_128 : constant Boolean :=
+ Num'Base'Object_Size <= 128
+ and then
+ ((Num'Small_Numerator = 1 and then Num'Small_Denominator <= 2**127)
+ or else
+ (Num'Small_Denominator = 1 and then Num'Small_Numerator <= 2**127)
+ or else
+ (Num'Small_Numerator < Num'Small_Denominator
+ and then Num'Small_Denominator <= 2**123)
+ or else
+ (Num'Small_Denominator < Num'Small_Numerator
+ and then Num'Small_Numerator <= 2**122));
+ -- These conditions are derived from the prerequisites of System.Image_F
+
+ E : constant Natural :=
+ 127 - 64 * Boolean'Pos (OK_Put_64) - 32 * Boolean'Pos (OK_Put_32);
+ -- T'Size - 1 for the selected Int{32,64,128}
+
+ F0 : constant Natural := 0;
+ F1 : constant Natural :=
+ F0 + 38 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F0) >= 1.0E+38);
+ F2 : constant Natural :=
+ F1 + 19 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F1) >= 1.0E+19);
+ F3 : constant Natural :=
+ F2 + 9 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F2) >= 1.0E+9);
+ F4 : constant Natural :=
+ F3 + 5 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F3) >= 1.0E+5);
+ F5 : constant Natural :=
+ F4 + 3 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F4) >= 1.0E+3);
+ F6 : constant Natural :=
+ F5 + 2 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F5) >= 1.0E+2);
+ F7 : constant Natural :=
+ F6 + 1 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F6) >= 1.0E+1);
+ -- Binary search for the number of digits - 1 before the decimal point of
+ -- the product 2.0**E * Num'Small.
+
+ For0 : constant Natural := 2 + F7;
+ -- Fore value for the fixed point type whose mantissa is Int{32,64,128} and
+ -- whose small is Num'Small.
+
+ ---------
+ -- Get --
+ ---------
+
+ procedure Get
+ (File : File_Type;
+ Item : out Num;
+ Width : Field := 0)
+ is
+ pragma Unsuppress (Range_Check);
+
+ begin
+ if OK_Get_32 then
+ Item := Num'Fixed_Value
+ (Aux32.Get (File, Width,
+ -Num'Small_Numerator,
+ -Num'Small_Denominator));
+ elsif OK_Get_64 then
+ Item := Num'Fixed_Value
+ (Aux64.Get (File, Width,
+ -Num'Small_Numerator,
+ -Num'Small_Denominator));
+ elsif OK_Get_128 then
+ Item := Num'Fixed_Value
+ (Aux128.Get (File, Width,
+ -Num'Small_Numerator,
+ -Num'Small_Denominator));
+ else
+ Aux_Long_Long_Float.Get (File, Long_Long_Float (Item), Width);
+ end if;
+
+ exception
+ when Constraint_Error => raise Data_Error;
+ end Get;
+
+ procedure Get
+ (Item : out Num;
+ Width : Field := 0)
+ is
+ begin
+ Get (Current_In, Item, Width);
+ end Get;
+
+ procedure Get
+ (From : Wide_String;
+ Item : out Num;
+ Last : out Positive)
+ is
+ pragma Unsuppress (Range_Check);
+
+ S : constant String := Wide_String_To_String (From, WCEM_Upper);
+ -- String on which we do the actual conversion. Note that the method
+ -- used for wide character encoding is irrelevant, since if there is
+ -- a character outside the Standard.Character range then the call to
+ -- Aux.Gets will raise Data_Error in any case.
+
+ begin
+ if OK_Get_32 then
+ Item := Num'Fixed_Value
+ (Aux32.Gets (S, Last,
+ -Num'Small_Numerator,
+ -Num'Small_Denominator));
+ elsif OK_Get_64 then
+ Item := Num'Fixed_Value
+ (Aux64.Gets (S, Last,
+ -Num'Small_Numerator,
+ -Num'Small_Denominator));
+ elsif OK_Get_128 then
+ Item := Num'Fixed_Value
+ (Aux128.Gets (S, Last,
+ -Num'Small_Numerator,
+ -Num'Small_Denominator));
+ else
+ Aux_Long_Long_Float.Gets (S, Long_Long_Float (Item), Last);
+ end if;
+
+ exception
+ when Constraint_Error => raise Data_Error;
+ end Get;
+
+ ---------
+ -- Put --
+ ---------
+
+ procedure Put
+ (File : File_Type;
+ Item : Num;
+ Fore : Field := Default_Fore;
+ Aft : Field := Default_Aft;
+ Exp : Field := Default_Exp)
+ is
+ begin
+ if OK_Put_32 then
+ Aux32.Put (File, Int32'Integer_Value (Item), Fore, Aft, Exp,
+ -Num'Small_Numerator, -Num'Small_Denominator,
+ For0, Num'Aft);
+ elsif OK_Put_64 then
+ Aux64.Put (File, Int64'Integer_Value (Item), Fore, Aft, Exp,
+ -Num'Small_Numerator, -Num'Small_Denominator,
+ For0, Num'Aft);
+ elsif OK_Put_128 then
+ Aux128.Put (File, Int128'Integer_Value (Item), Fore, Aft, Exp,
+ -Num'Small_Numerator, -Num'Small_Denominator,
+ For0, Num'Aft);
+ else
+ Aux_Long_Long_Float.Put
+ (File, Long_Long_Float (Item), Fore, Aft, Exp);
+ end if;
+ end Put;
+
+ procedure Put
+ (Item : Num;
+ Fore : Field := Default_Fore;
+ Aft : Field := Default_Aft;
+ Exp : Field := Default_Exp)
+ is
+ begin
+ Put (Current_Out, Item, Fore, Aft, Exp);
+ end Put;
+
+ procedure Put
+ (To : out Wide_String;
+ Item : Num;
+ Aft : Field := Default_Aft;
+ Exp : Field := Default_Exp)
+ is
+ S : String (To'First .. To'Last);
+
+ begin
+ if OK_Put_32 then
+ Aux32.Puts (S, Int32'Integer_Value (Item), Aft, Exp,
+ -Num'Small_Numerator, -Num'Small_Denominator,
+ For0, Num'Aft);
+ elsif OK_Put_64 then
+ Aux64.Puts (S, Int64'Integer_Value (Item), Aft, Exp,
+ -Num'Small_Numerator, -Num'Small_Denominator,
+ For0, Num'Aft);
+ elsif OK_Put_128 then
+ Aux128.Puts (S, Int128'Integer_Value (Item), Aft, Exp,
+ -Num'Small_Numerator, -Num'Small_Denominator,
+ For0, Num'Aft);
+ else
+ Aux_Long_Long_Float.Puts (S, Long_Long_Float (Item), Aft, Exp);
+ end if;
+
+ for J in S'Range loop
+ To (J) := Wide_Character'Val (Character'Pos (S (J)));
+ end loop;
+ end Put;
+
+end Ada.Wide_Text_IO.Fixed_IO;
diff --git a/gcc/ada/libgnat/a-wtflau.adb b/gcc/ada/libgnat/a-wtflau.adb
index fd9ff1a..7db1b78 100644
--- a/gcc/ada/libgnat/a-wtflau.adb
+++ b/gcc/ada/libgnat/a-wtflau.adb
@@ -31,8 +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.Val_Real; use System.Val_Real;
+with System.Img_Real; use System.Img_Real;
package body Ada.Wide_Text_IO.Float_Aux is
@@ -42,12 +41,12 @@ package body Ada.Wide_Text_IO.Float_Aux is
procedure Get
(File : File_Type;
- Item : out Long_Long_Float;
+ Item : out Num;
Width : Field)
is
Buf : String (1 .. Field'Last);
Stop : Integer := 0;
- Ptr : aliased Integer := 1;
+ Ptr : aliased Integer;
begin
if Width /= 0 then
@@ -55,10 +54,10 @@ package body Ada.Wide_Text_IO.Float_Aux is
String_Skip (Buf, Ptr);
else
Load_Real (File, Buf, Stop);
+ Ptr := 1;
end if;
- Item := Scan_Real (Buf, Ptr'Access, Stop);
-
+ Item := Scan (Buf, Ptr'Access, Stop);
Check_End_Of_Field (Buf, Stop, Ptr, Width);
end Get;
@@ -68,137 +67,36 @@ package body Ada.Wide_Text_IO.Float_Aux is
procedure Gets
(From : String;
- Item : out Long_Long_Float;
+ Item : out Num;
Last : out Positive)
is
Pos : aliased Integer;
begin
String_Skip (From, Pos);
- Item := Scan_Real (From, Pos'Access, From'Last);
+ Item := Scan (From, Pos'Access, From'Last);
Last := Pos - 1;
exception
- when Constraint_Error =>
- raise Data_Error;
+ when Constraint_Error => raise Data_Error;
end Gets;
- ---------------
- -- Load_Real --
- ---------------
-
- procedure Load_Real
- (File : File_Type;
- Buf : out String;
- Ptr : in out Natural)
- is
- Loaded : Boolean;
-
- begin
- -- Skip initial blanks and load possible sign
-
- Load_Skip (File);
- Load (File, Buf, Ptr, '+', '-');
-
- -- Case of .nnnn
-
- Load (File, Buf, Ptr, '.', Loaded);
-
- if Loaded then
- Load_Digits (File, Buf, Ptr, Loaded);
-
- -- Hopeless junk if no digits loaded
-
- if not Loaded then
- return;
- end if;
-
- -- Otherwise must have digits to start
-
- else
- Load_Digits (File, Buf, Ptr, Loaded);
-
- -- Hopeless junk if no digits loaded
-
- if not Loaded then
- return;
- end if;
-
- -- Deal with based case. We recognize either the standard '#' or the
- -- allowed alternative replacement ':' (see RM J.2(3)).
-
- Load (File, Buf, Ptr, '#', ':', Loaded);
-
- if Loaded then
-
- -- Case of nnn#.xxx#
-
- Load (File, Buf, Ptr, '.', Loaded);
-
- if Loaded then
- Load_Extended_Digits (File, Buf, Ptr);
- Load (File, Buf, Ptr, '#', ':');
-
- -- Case of nnn#xxx.[xxx]# or nnn#xxx#
-
- else
- Load_Extended_Digits (File, Buf, Ptr);
- Load (File, Buf, Ptr, '.', Loaded);
-
- if Loaded then
- Load_Extended_Digits (File, Buf, Ptr);
- end if;
-
- -- As usual, it seems strange to allow mixed base characters,
- -- but that is what ACVC tests expect, see CE3804M, case (3).
-
- Load (File, Buf, Ptr, '#', ':');
- end if;
-
- -- Case of nnn.[nnn] or nnn
-
- else
- -- Prevent the potential processing of '.' in cases where the
- -- initial digits have a trailing underscore.
-
- if Buf (Ptr) = '_' then
- return;
- end if;
-
- Load (File, Buf, Ptr, '.', Loaded);
-
- if Loaded then
- Load_Digits (File, Buf, Ptr);
- end if;
- end if;
- end if;
-
- -- Deal with exponent
-
- Load (File, Buf, Ptr, 'E', 'e', Loaded);
-
- if Loaded then
- Load (File, Buf, Ptr, '+', '-');
- Load_Digits (File, Buf, Ptr);
- end if;
- end Load_Real;
-
---------
-- Put --
---------
procedure Put
(File : File_Type;
- Item : Long_Long_Float;
+ Item : Num;
Fore : Field;
Aft : Field;
Exp : Field)
is
- Buf : String (1 .. Field'Last);
+ Buf : String (1 .. Max_Real_Image_Length);
Ptr : Natural := 0;
begin
- Set_Image_Real (Item, Buf, Ptr, Fore, Aft, Exp);
+ Set_Image_Real (Long_Long_Float (Item), Buf, Ptr, Fore, Aft, Exp);
Put_Item (File, Buf (1 .. Ptr));
end Put;
@@ -208,15 +106,16 @@ package body Ada.Wide_Text_IO.Float_Aux is
procedure Puts
(To : out String;
- Item : Long_Long_Float;
+ Item : Num;
Aft : Field;
Exp : Field)
is
- Buf : String (1 .. Field'Last);
+ Buf : String (1 .. Max_Real_Image_Length);
Ptr : Natural := 0;
begin
- Set_Image_Real (Item, Buf, Ptr, Fore => 1, Aft => Aft, Exp => Exp);
+ Set_Image_Real
+ (Long_Long_Float (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 3598f77..82ace79 100644
--- a/gcc/ada/libgnat/a-wtflau.ads
+++ b/gcc/ada/libgnat/a-wtflau.ads
@@ -31,41 +31,42 @@
-- This package contains the routines for Ada.Wide_Text_IO.Float_IO that
-- are shared among separate instantiations of this package. The routines
--- in this package are identical semantically to those in Float_IO itself,
--- except that generic parameter Num has been replaced by Long_Long_Float,
--- and the default parameters have been removed because they are supplied
+-- in this package are identical semantically to those in Float_IO, except
+-- that the default parameters have been removed because they are supplied
-- explicitly by the calls from within the generic template. This package
--- is also used by Ada.Wide_Text_IO.Fixed_IO, Ada.Wide_Text_IO.Decimal_IO.
+-- is also used by Ada.Wide_Text_IO.Fixed_IO and Ada.Wide_Text_IO.Decimal_IO.
-private package Ada.Wide_Text_IO.Float_Aux is
+private generic
- procedure Load_Real
- (File : File_Type;
- Buf : out String;
- Ptr : in out Natural);
- -- This is an auxiliary routine that is used to load a possibly signed
- -- real literal value from the input file into Buf, starting at Ptr + 1.
+ type Num is digits <>;
+
+ with function Scan
+ (Str : String;
+ Ptr : not null access Integer;
+ Max : Integer) return Num;
+
+package Ada.Wide_Text_IO.Float_Aux is
procedure Get
(File : File_Type;
- Item : out Long_Long_Float;
+ Item : out Num;
Width : Field);
- procedure Gets
- (From : String;
- Item : out Long_Long_Float;
- Last : out Positive);
-
procedure Put
(File : File_Type;
- Item : Long_Long_Float;
+ Item : Num;
Fore : Field;
Aft : Field;
Exp : Field);
+ procedure Gets
+ (From : String;
+ Item : out Num;
+ Last : out Positive);
+
procedure Puts
(To : out String;
- Item : Long_Long_Float;
+ Item : Num;
Aft : Field;
Exp : Field);
diff --git a/gcc/ada/libgnat/a-wtflio.adb b/gcc/ada/libgnat/a-wtflio.adb
index 5a36d88..3691786 100644
--- a/gcc/ada/libgnat/a-wtflio.adb
+++ b/gcc/ada/libgnat/a-wtflio.adb
@@ -30,16 +30,31 @@
------------------------------------------------------------------------------
with Ada.Wide_Text_IO.Float_Aux;
-
-with System.WCh_Con; use System.WCh_Con;
-with System.WCh_WtS; use System.WCh_WtS;
+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;
package body Ada.Wide_Text_IO.Float_IO is
- subtype TFT is Ada.Wide_Text_IO.File_Type;
- -- File type required for calls to routines in Aux
+ package Aux_Float is new
+ Ada.Wide_Text_IO.Float_Aux (Float, Scan_Float);
+
+ package Aux_Long_Float is new
+ Ada.Wide_Text_IO.Float_Aux (Long_Float, Scan_Long_Float);
+
+ package Aux_Long_Long_Float is new
+ Ada.Wide_Text_IO.Float_Aux (Long_Long_Float, Scan_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
+ -- is needed. These boolean constants are used to test for this, such that
+ -- only code for the relevant case is included in the instance.
- package Aux renames Ada.Wide_Text_IO.Float_Aux;
+ OK_Float : constant Boolean := Num'Base'Digits <= Float'Digits;
+
+ OK_Long_Float : constant Boolean := Num'Base'Digits <= Long_Float'Digits;
---------
-- Get --
@@ -50,8 +65,25 @@ package body Ada.Wide_Text_IO.Float_IO is
Item : out Num;
Width : Field := 0)
is
+ pragma Unsuppress (Range_Check);
+
begin
- Aux.Get (TFT (File), Long_Long_Float (Item), Width);
+ if OK_Float then
+ Aux_Float.Get (File, Float (Item), Width);
+ elsif OK_Long_Float then
+ Aux_Long_Float.Get (File, Long_Float (Item), Width);
+ else
+ Aux_Long_Long_Float.Get (File, Long_Long_Float (Item), Width);
+ end if;
+
+ -- In the case where the type is unconstrained (e.g. Standard'Float),
+ -- the above conversion may result in an infinite value, which is
+ -- normally fine for a conversion, but in this case, we want to treat
+ -- that as a data error.
+
+ if not Item'Valid then
+ raise Data_Error;
+ end if;
exception
when Constraint_Error => raise Data_Error;
@@ -62,7 +94,7 @@ package body Ada.Wide_Text_IO.Float_IO is
Width : Field := 0)
is
begin
- Get (Current_Input, Item, Width);
+ Get (Current_In, Item, Width);
end Get;
procedure Get
@@ -70,6 +102,8 @@ package body Ada.Wide_Text_IO.Float_IO is
Item : out Num;
Last : out Positive)
is
+ pragma Unsuppress (Range_Check);
+
S : constant String := Wide_String_To_String (From, WCEM_Upper);
-- String on which we do the actual conversion. Note that the method
-- used for wide character encoding is irrelevant, since if there is
@@ -77,7 +111,22 @@ package body Ada.Wide_Text_IO.Float_IO is
-- Aux.Gets will raise Data_Error in any case.
begin
- Aux.Gets (S, Long_Long_Float (Item), Last);
+ if OK_Float then
+ Aux_Float.Gets (S, Float (Item), Last);
+ elsif OK_Long_Float then
+ Aux_Long_Float.Gets (S, Long_Float (Item), Last);
+ else
+ Aux_Long_Long_Float.Gets (S, Long_Long_Float (Item), Last);
+ end if;
+
+ -- In the case where the type is unconstrained (e.g. Standard'Float),
+ -- the above conversion may result in an infinite value, which is
+ -- normally fine for a conversion, but in this case, we want to treat
+ -- that as a data error.
+
+ if not Item'Valid then
+ raise Data_Error;
+ end if;
exception
when Constraint_Error => raise Data_Error;
@@ -95,7 +144,14 @@ package body Ada.Wide_Text_IO.Float_IO is
Exp : Field := Default_Exp)
is
begin
- Aux.Put (TFT (File), Long_Long_Float (Item), Fore, Aft, Exp);
+ if OK_Float then
+ Aux_Float.Put (File, Float (Item), Fore, Aft, Exp);
+ elsif OK_Long_Float then
+ Aux_Long_Float.Put (File, Long_Float (Item), Fore, Aft, Exp);
+ else
+ Aux_Long_Long_Float.Put
+ (File, Long_Long_Float (Item), Fore, Aft, Exp);
+ end if;
end Put;
procedure Put
@@ -105,7 +161,7 @@ package body Ada.Wide_Text_IO.Float_IO is
Exp : Field := Default_Exp)
is
begin
- Put (Current_Output, Item, Fore, Aft, Exp);
+ Put (Current_Out, Item, Fore, Aft, Exp);
end Put;
procedure Put
@@ -117,7 +173,13 @@ package body Ada.Wide_Text_IO.Float_IO is
S : String (To'First .. To'Last);
begin
- Aux.Puts (S, Long_Long_Float (Item), Aft, Exp);
+ if OK_Float then
+ Aux_Float.Puts (S, Float (Item), Aft, Exp);
+ elsif OK_Long_Float then
+ Aux_Long_Float.Puts (S, Long_Float (Item), Aft, Exp);
+ else
+ Aux_Long_Long_Float.Puts (S, Long_Long_Float (Item), Aft, Exp);
+ end if;
for J in S'Range loop
To (J) := Wide_Character'Val (Character'Pos (S (J)));
diff --git a/gcc/ada/libgnat/a-wtgeau.adb b/gcc/ada/libgnat/a-wtgeau.adb
index 9d24070..bc9b459 100644
--- a/gcc/ada/libgnat/a-wtgeau.adb
+++ b/gcc/ada/libgnat/a-wtgeau.adb
@@ -403,6 +403,106 @@ package body Ada.Wide_Text_IO.Generic_Aux is
end Load_Integer;
---------------
+ -- Load_Real --
+ ---------------
+
+ procedure Load_Real
+ (File : File_Type;
+ Buf : out String;
+ Ptr : in out Natural)
+ is
+ Loaded : Boolean;
+
+ begin
+ -- Skip initial blanks and load possible sign
+
+ Load_Skip (File);
+ Load (File, Buf, Ptr, '+', '-');
+
+ -- Case of .nnnn
+
+ Load (File, Buf, Ptr, '.', Loaded);
+
+ if Loaded then
+ Load_Digits (File, Buf, Ptr, Loaded);
+
+ -- Hopeless junk if no digits loaded
+
+ if not Loaded then
+ return;
+ end if;
+
+ -- Otherwise must have digits to start
+
+ else
+ Load_Digits (File, Buf, Ptr, Loaded);
+
+ -- Hopeless junk if no digits loaded
+
+ if not Loaded then
+ return;
+ end if;
+
+ -- Deal with based case. We recognize either the standard '#' or the
+ -- allowed alternative replacement ':' (see RM J.2(3)).
+
+ Load (File, Buf, Ptr, '#', ':', Loaded);
+
+ if Loaded then
+
+ -- Case of nnn#.xxx#
+
+ Load (File, Buf, Ptr, '.', Loaded);
+
+ if Loaded then
+ Load_Extended_Digits (File, Buf, Ptr);
+ Load (File, Buf, Ptr, '#', ':');
+
+ -- Case of nnn#xxx.[xxx]# or nnn#xxx#
+
+ else
+ Load_Extended_Digits (File, Buf, Ptr);
+ Load (File, Buf, Ptr, '.', Loaded);
+
+ if Loaded then
+ Load_Extended_Digits (File, Buf, Ptr);
+ end if;
+
+ -- As usual, it seems strange to allow mixed base characters,
+ -- but that is what ACVC tests expect, see CE3804M, case (3).
+
+ Load (File, Buf, Ptr, '#', ':');
+ end if;
+
+ -- Case of nnn.[nnn] or nnn
+
+ else
+ -- Prevent the potential processing of '.' in cases where the
+ -- initial digits have a trailing underscore.
+
+ if Buf (Ptr) = '_' then
+ return;
+ end if;
+
+ Load (File, Buf, Ptr, '.', Loaded);
+
+ if Loaded then
+ Load_Digits (File, Buf, Ptr);
+ end if;
+ end if;
+ end if;
+
+ -- Deal with exponent
+
+ Load (File, Buf, Ptr, 'E', 'e', Loaded);
+
+ if Loaded then
+ Load (File, Buf, Ptr, '+', '-');
+ Load_Digits (File, Buf, Ptr);
+ end if;
+ end Load_Real;
+
+ ---------------
-- Load_Skip --
---------------
diff --git a/gcc/ada/libgnat/a-wtgeau.ads b/gcc/ada/libgnat/a-wtgeau.ads
index 9577ac2..7c89971 100644
--- a/gcc/ada/libgnat/a-wtgeau.ads
+++ b/gcc/ada/libgnat/a-wtgeau.ads
@@ -155,6 +155,12 @@ package Ada.Wide_Text_IO.Generic_Aux is
Ptr : in out Natural);
-- Loads a possibly signed integer literal value
+ procedure Load_Real
+ (File : File_Type;
+ Buf : out String;
+ Ptr : in out Natural);
+ -- Loads a possibly signed real literal value
+
procedure Put_Item (File : File_Type; Str : String);
-- This routine is like Wide_Text_IO.Put, except that it checks for
-- overflow of bounded lines, as described in (RM A.10.6(8)). It is used
diff --git a/gcc/ada/libgnat/a-wtinio.adb b/gcc/ada/libgnat/a-wtinio.adb
index a3f666e..b322433 100644
--- a/gcc/ada/libgnat/a-wtinio.adb
+++ b/gcc/ada/libgnat/a-wtinio.adb
@@ -65,9 +65,6 @@ package body Ada.Wide_Text_IO.Integer_IO is
-- Boolean is used to test for these cases and since it is a constant, only
-- code for the relevant case will be included in the instance.
- subtype TFT is Ada.Wide_Text_IO.File_Type;
- -- File type required for calls to routines in Aux
-
---------
-- Get --
---------
@@ -84,9 +81,9 @@ package body Ada.Wide_Text_IO.Integer_IO is
begin
if Need_LLI then
- Aux_LLI.Get (TFT (File), Long_Long_Integer (Item), Width);
+ Aux_LLI.Get (File, Long_Long_Integer (Item), Width);
else
- Aux_Int.Get (TFT (File), Integer (Item), Width);
+ Aux_Int.Get (File, Integer (Item), Width);
end if;
exception
@@ -98,7 +95,7 @@ package body Ada.Wide_Text_IO.Integer_IO is
Width : Field := 0)
is
begin
- Get (Current_Input, Item, Width);
+ Get (Current_In, Item, Width);
end Get;
procedure Get
@@ -140,9 +137,9 @@ package body Ada.Wide_Text_IO.Integer_IO is
is
begin
if Need_LLI then
- Aux_LLI.Put (TFT (File), Long_Long_Integer (Item), Width, Base);
+ Aux_LLI.Put (File, Long_Long_Integer (Item), Width, Base);
else
- Aux_Int.Put (TFT (File), Integer (Item), Width, Base);
+ Aux_Int.Put (File, Integer (Item), Width, Base);
end if;
end Put;
@@ -152,7 +149,7 @@ package body Ada.Wide_Text_IO.Integer_IO is
Base : Number_Base := Default_Base)
is
begin
- Put (Current_Output, Item, Width, Base);
+ Put (Current_Out, Item, Width, Base);
end Put;
procedure Put
diff --git a/gcc/ada/libgnat/a-wtinio__128.adb b/gcc/ada/libgnat/a-wtinio__128.adb
index edc78c3..0eea7b5 100644
--- a/gcc/ada/libgnat/a-wtinio__128.adb
+++ b/gcc/ada/libgnat/a-wtinio__128.adb
@@ -79,9 +79,6 @@ package body Ada.Wide_Text_IO.Integer_IO is
-- are used to test for these cases and since they are constant, only code
-- for the relevant case will be included in the instance.
- subtype TFT is Ada.Wide_Text_IO.File_Type;
- -- File type required for calls to routines in Aux
-
---------
-- Get --
---------
@@ -98,11 +95,11 @@ package body Ada.Wide_Text_IO.Integer_IO is
begin
if Need_LLLI then
- Aux_LLLI.Get (TFT (File), Long_Long_Long_Integer (Item), Width);
+ Aux_LLLI.Get (File, Long_Long_Long_Integer (Item), Width);
elsif Need_LLI then
- Aux_LLI.Get (TFT (File), Long_Long_Integer (Item), Width);
+ Aux_LLI.Get (File, Long_Long_Integer (Item), Width);
else
- Aux_Int.Get (TFT (File), Integer (Item), Width);
+ Aux_Int.Get (File, Integer (Item), Width);
end if;
exception
@@ -114,7 +111,7 @@ package body Ada.Wide_Text_IO.Integer_IO is
Width : Field := 0)
is
begin
- Get (Current_Input, Item, Width);
+ Get (Current_In, Item, Width);
end Get;
procedure Get
@@ -158,11 +155,11 @@ package body Ada.Wide_Text_IO.Integer_IO is
is
begin
if Need_LLLI then
- Aux_LLLI.Put (TFT (File), Long_Long_Long_Integer (Item), Width, Base);
+ Aux_LLLI.Put (File, Long_Long_Long_Integer (Item), Width, Base);
elsif Need_LLI then
- Aux_LLI.Put (TFT (File), Long_Long_Integer (Item), Width, Base);
+ Aux_LLI.Put (File, Long_Long_Integer (Item), Width, Base);
else
- Aux_Int.Put (TFT (File), Integer (Item), Width, Base);
+ Aux_Int.Put (File, Integer (Item), Width, Base);
end if;
end Put;
@@ -172,7 +169,7 @@ package body Ada.Wide_Text_IO.Integer_IO is
Base : Number_Base := Default_Base)
is
begin
- Put (Current_Output, Item, Width, Base);
+ Put (Current_Out, Item, Width, Base);
end Put;
procedure Put
diff --git a/gcc/ada/libgnat/a-wtmoio.adb b/gcc/ada/libgnat/a-wtmoio.adb
index 702dcbb..efab035 100644
--- a/gcc/ada/libgnat/a-wtmoio.adb
+++ b/gcc/ada/libgnat/a-wtmoio.adb
@@ -65,9 +65,6 @@ package body Ada.Wide_Text_IO.Modular_IO is
-- Boolean is used to test for these cases and since it is a constant, only
-- code for the relevant case will be included in the instance.
- subtype TFT is Ada.Wide_Text_IO.File_Type;
- -- File type required for calls to routines in Aux
-
---------
-- Get --
---------
@@ -83,9 +80,9 @@ package body Ada.Wide_Text_IO.Modular_IO is
begin
if Need_LLU then
- Aux_LLU.Get (TFT (File), Long_Long_Unsigned (Item), Width);
+ Aux_LLU.Get (File, Long_Long_Unsigned (Item), Width);
else
- Aux_Uns.Get (TFT (File), Unsigned (Item), Width);
+ Aux_Uns.Get (File, Unsigned (Item), Width);
end if;
exception
@@ -97,7 +94,7 @@ package body Ada.Wide_Text_IO.Modular_IO is
Width : Field := 0)
is
begin
- Get (Current_Input, Item, Width);
+ Get (Current_In, Item, Width);
end Get;
procedure Get
@@ -138,9 +135,9 @@ package body Ada.Wide_Text_IO.Modular_IO is
is
begin
if Need_LLU then
- Aux_LLU.Put (TFT (File), Long_Long_Unsigned (Item), Width, Base);
+ Aux_LLU.Put (File, Long_Long_Unsigned (Item), Width, Base);
else
- Aux_Uns.Put (TFT (File), Unsigned (Item), Width, Base);
+ Aux_Uns.Put (File, Unsigned (Item), Width, Base);
end if;
end Put;
@@ -150,7 +147,7 @@ package body Ada.Wide_Text_IO.Modular_IO is
Base : Number_Base := Default_Base)
is
begin
- Put (Current_Output, Item, Width, Base);
+ Put (Current_Out, Item, Width, Base);
end Put;
procedure Put
diff --git a/gcc/ada/libgnat/a-wtmoio__128.adb b/gcc/ada/libgnat/a-wtmoio__128.adb
index 661faec..a32eaf2 100644
--- a/gcc/ada/libgnat/a-wtmoio__128.adb
+++ b/gcc/ada/libgnat/a-wtmoio__128.adb
@@ -79,9 +79,6 @@ package body Ada.Wide_Text_IO.Modular_IO is
-- are used to test for these cases and since they are constant, only code
-- for the relevant case will be included in the instance.
- subtype TFT is Ada.Wide_Text_IO.File_Type;
- -- File type required for calls to routines in Aux
-
---------
-- Get --
---------
@@ -99,9 +96,9 @@ package body Ada.Wide_Text_IO.Modular_IO is
if Need_LLLU then
Aux_LLLU.Get (File, Long_Long_Long_Unsigned (Item), Width);
elsif Need_LLU then
- Aux_LLU.Get (TFT (File), Long_Long_Unsigned (Item), Width);
+ Aux_LLU.Get (File, Long_Long_Unsigned (Item), Width);
else
- Aux_Uns.Get (TFT (File), Unsigned (Item), Width);
+ Aux_Uns.Get (File, Unsigned (Item), Width);
end if;
exception
@@ -113,7 +110,7 @@ package body Ada.Wide_Text_IO.Modular_IO is
Width : Field := 0)
is
begin
- Get (Current_Input, Item, Width);
+ Get (Current_In, Item, Width);
end Get;
procedure Get
@@ -158,9 +155,9 @@ package body Ada.Wide_Text_IO.Modular_IO is
if Need_LLLU then
Aux_LLLU.Put (File, Long_Long_Long_Unsigned (Item), Width, Base);
elsif Need_LLU then
- Aux_LLU.Put (TFT (File), Long_Long_Unsigned (Item), Width, Base);
+ Aux_LLU.Put (File, Long_Long_Unsigned (Item), Width, Base);
else
- Aux_Uns.Put (TFT (File), Unsigned (Item), Width, Base);
+ Aux_Uns.Put (File, Unsigned (Item), Width, Base);
end if;
end Put;
@@ -170,7 +167,7 @@ package body Ada.Wide_Text_IO.Modular_IO is
Base : Number_Base := Default_Base)
is
begin
- Put (Current_Output, Item, Width, Base);
+ Put (Current_Out, Item, Width, Base);
end Put;
procedure Put
diff --git a/gcc/ada/libgnat/a-ztcoau.adb b/gcc/ada/libgnat/a-ztcoau.adb
index ffe0a90..bb33680 100644
--- a/gcc/ada/libgnat/a-ztcoau.adb
+++ b/gcc/ada/libgnat/a-ztcoau.adb
@@ -30,22 +30,19 @@
------------------------------------------------------------------------------
with Ada.Wide_Wide_Text_IO.Generic_Aux; use Ada.Wide_Wide_Text_IO.Generic_Aux;
-with Ada.Wide_Wide_Text_IO.Float_Aux;
with System.Img_Real; use System.Img_Real;
package body Ada.Wide_Wide_Text_IO.Complex_Aux is
- package Aux renames Ada.Wide_Wide_Text_IO.Float_Aux;
-
---------
-- Get --
---------
procedure Get
(File : File_Type;
- ItemR : out Long_Long_Float;
- ItemI : out Long_Long_Float;
+ ItemR : out Num;
+ ItemI : out Num;
Width : Field)
is
Buf : String (1 .. Field'Last);
@@ -95,8 +92,8 @@ package body Ada.Wide_Wide_Text_IO.Complex_Aux is
procedure Gets
(From : String;
- ItemR : out Long_Long_Float;
- ItemI : out Long_Long_Float;
+ ItemR : out Num;
+ ItemI : out Num;
Last : out Positive)
is
Paren : Boolean;
@@ -139,8 +136,8 @@ package body Ada.Wide_Wide_Text_IO.Complex_Aux is
procedure Put
(File : File_Type;
- ItemR : Long_Long_Float;
- ItemI : Long_Long_Float;
+ ItemR : Num;
+ ItemI : Num;
Fore : Field;
Aft : Field;
Exp : Field)
@@ -159,8 +156,8 @@ package body Ada.Wide_Wide_Text_IO.Complex_Aux is
procedure Puts
(To : out String;
- ItemR : Long_Long_Float;
- ItemI : Long_Long_Float;
+ ItemR : Num;
+ ItemI : Num;
Aft : Field;
Exp : Field)
is
@@ -174,9 +171,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 (ItemR, R_String, Rptr, 0, Aft, Exp);
+ Set_Image_Real (Long_Long_Float (ItemR), R_String, Rptr, 0, Aft, Exp);
Iptr := 0;
- Set_Image_Real (ItemI, I_String, Iptr, 0, Aft, Exp);
+ Set_Image_Real (Long_Long_Float (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 b68c38b..43546d8 100644
--- a/gcc/ada/libgnat/a-ztcoau.ads
+++ b/gcc/ada/libgnat/a-ztcoau.ads
@@ -15,38 +15,45 @@
-- This package contains the routines for Ada.Wide_Wide_Text_IO.Complex_IO
-- that are shared among separate instantiations of this package. The routines
--- in this package are identical semantically to those in Complex_IO itself,
--- except that the generic parameter Complex has been replaced by separate
--- real and imaginary values of type Long_Long_Float, and default parameters
--- have been removed because they are supplied explicitly by the calls from
--- within the generic template.
+-- in this package are identical semantically to those in Complex_IO, except
+-- that the generic parameter Complex has been replaced by separate real and
+-- imaginary parameters, and default parameters have been removed because they
+-- are supplied explicitly by the calls from within the generic template.
+
+with Ada.Wide_Wide_Text_IO.Float_Aux;
+
+private generic
+
+ type Num is digits <>;
+
+ with package Aux is new Ada.Wide_Wide_Text_IO.Float_Aux (Num, <>);
package Ada.Wide_Wide_Text_IO.Complex_Aux is
procedure Get
(File : File_Type;
- ItemR : out Long_Long_Float;
- ItemI : out Long_Long_Float;
+ ItemR : out Num;
+ ItemI : out Num;
Width : Field);
- procedure Gets
- (From : String;
- ItemR : out Long_Long_Float;
- ItemI : out Long_Long_Float;
- Last : out Positive);
-
procedure Put
(File : File_Type;
- ItemR : Long_Long_Float;
- ItemI : Long_Long_Float;
+ ItemR : Num;
+ ItemI : Num;
Fore : Field;
Aft : Field;
Exp : Field);
+ procedure Gets
+ (From : String;
+ ItemR : out Num;
+ ItemI : out Num;
+ Last : out Positive);
+
procedure Puts
(To : out String;
- ItemR : Long_Long_Float;
- ItemI : Long_Long_Float;
+ ItemR : Num;
+ ItemI : Num;
Aft : Field;
Exp : Field);
diff --git a/gcc/ada/libgnat/a-ztcoio.adb b/gcc/ada/libgnat/a-ztcoio.adb
index ead1234..5103191 100644
--- a/gcc/ada/libgnat/a-ztcoio.adb
+++ b/gcc/ada/libgnat/a-ztcoio.adb
@@ -30,24 +30,46 @@
------------------------------------------------------------------------------
with Ada.Wide_Wide_Text_IO.Complex_Aux;
-
-with System.WCh_Con; use System.WCh_Con;
-with System.WCh_WtS; use System.WCh_WtS;
+with Ada.Wide_Wide_Text_IO.Float_Aux;
+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
- package Aux renames Ada.Wide_Wide_Text_IO.Complex_Aux;
+ use Complex_Types;
+
+ package Scalar_Float is new
+ Ada.Wide_Wide_Text_IO.Float_Aux (Float, Scan_Float);
+
+ package Scalar_Long_Float is new
+ Ada.Wide_Wide_Text_IO.Float_Aux (Long_Float, Scan_Long_Float);
+
+ package Scalar_Long_Long_Float is new
+ Ada.Wide_Wide_Text_IO.Float_Aux (Long_Long_Float, Scan_Long_Long_Float);
+
+ package Aux_Float is new
+ Ada.Wide_Wide_Text_IO.Complex_Aux (Float, Scalar_Float);
- subtype LLF is Long_Long_Float;
- -- Type used for calls to routines in Aux
+ package Aux_Long_Float is new
+ Ada.Wide_Wide_Text_IO.Complex_Aux (Long_Float, Scalar_Long_Float);
- function TFT is new
- Ada.Unchecked_Conversion (File_Type, Ada.Wide_Wide_Text_IO.File_Type);
- -- This unchecked conversion is to get around a visibility bug in
- -- GNAT version 2.04w. It should be possible to simply use the
- -- subtype declared above and do normal checked conversions.
+ package Aux_Long_Long_Float is new
+ 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
+ -- is needed. These boolean constants are used to test for this, such that
+ -- only code for the relevant case is included in the instance.
+
+ OK_Float : constant Boolean := Real'Base'Digits <= Float'Digits;
+
+ OK_Long_Float : constant Boolean := Real'Base'Digits <= Long_Float'Digits;
---------
-- Get --
@@ -62,7 +84,17 @@ package body Ada.Wide_Wide_Text_IO.Complex_IO is
Imag_Item : Real'Base;
begin
- Aux.Get (TFT (File), LLF (Real_Item), LLF (Imag_Item), Width);
+ if OK_Float then
+ Aux_Float.Get (File, Float (Real_Item), Float (Imag_Item), Width);
+ elsif OK_Long_Float then
+ Aux_Long_Float.Get
+ (File, Long_Float (Real_Item), Long_Float (Imag_Item), Width);
+ else
+ Aux_Long_Long_Float.Get
+ (File, Long_Long_Float (Real_Item), Long_Long_Float (Imag_Item),
+ Width);
+ end if;
+
Item := (Real_Item, Imag_Item);
exception
@@ -78,7 +110,7 @@ package body Ada.Wide_Wide_Text_IO.Complex_IO is
Width : Field := 0)
is
begin
- Get (Current_Input, Item, Width);
+ Get (Current_In, Item, Width);
end Get;
---------
@@ -100,7 +132,17 @@ package body Ada.Wide_Wide_Text_IO.Complex_IO is
-- Aux.Gets will raise Data_Error in any case.
begin
- Aux.Gets (S, LLF (Real_Item), LLF (Imag_Item), Last);
+ if OK_Float then
+ Aux_Float.Gets (S, Float (Real_Item), Float (Imag_Item), Last);
+ elsif OK_Long_Float then
+ Aux_Long_Float.Gets
+ (S, Long_Float (Real_Item), Long_Float (Imag_Item), Last);
+ else
+ Aux_Long_Long_Float.Gets
+ (S, Long_Long_Float (Real_Item), Long_Long_Float (Imag_Item),
+ Last);
+ end if;
+
Item := (Real_Item, Imag_Item);
exception
@@ -119,7 +161,18 @@ package body Ada.Wide_Wide_Text_IO.Complex_IO is
Exp : Field := Default_Exp)
is
begin
- Aux.Put (TFT (File), LLF (Re (Item)), LLF (Im (Item)), Fore, Aft, Exp);
+ if OK_Float then
+ Aux_Float.Put
+ (File, Float (Re (Item)), Float (Im (Item)), Fore, Aft, Exp);
+ elsif OK_Long_Float then
+ Aux_Long_Float.Put
+ (File, Long_Float (Re (Item)), Long_Float (Im (Item)), Fore, Aft,
+ Exp);
+ else
+ Aux_Long_Long_Float.Put
+ (File, Long_Long_Float (Re (Item)), Long_Long_Float (Im (Item)),
+ Fore, Aft, Exp);
+ end if;
end Put;
---------
@@ -133,7 +186,7 @@ package body Ada.Wide_Wide_Text_IO.Complex_IO is
Exp : Field := Default_Exp)
is
begin
- Put (Current_Output, Item, Fore, Aft, Exp);
+ Put (Current_Out, Item, Fore, Aft, Exp);
end Put;
---------
@@ -149,7 +202,16 @@ package body Ada.Wide_Wide_Text_IO.Complex_IO is
S : String (To'First .. To'Last);
begin
- Aux.Puts (S, LLF (Re (Item)), LLF (Im (Item)), Aft, Exp);
+ if OK_Float then
+ Aux_Float.Puts (S, Float (Re (Item)), Float (Im (Item)), Aft, Exp);
+ elsif OK_Long_Float then
+ Aux_Long_Float.Puts
+ (S, Long_Float (Re (Item)), Long_Float (Im (Item)), Aft, Exp);
+ else
+ Aux_Long_Long_Float.Puts
+ (S, Long_Long_Float (Re (Item)), Long_Long_Float (Im (Item)),
+ Aft, Exp);
+ end if;
for J in S'Range loop
To (J) := Wide_Wide_Character'Val (Character'Pos (S (J)));
diff --git a/gcc/ada/libgnat/a-ztcoio.ads b/gcc/ada/libgnat/a-ztcoio.ads
index 866fd87..2a08153 100644
--- a/gcc/ada/libgnat/a-ztcoio.ads
+++ b/gcc/ada/libgnat/a-ztcoio.ads
@@ -23,39 +23,39 @@ package Ada.Wide_Wide_Text_IO.Complex_IO is
use Complex_Types;
Default_Fore : Field := 2;
- Default_Aft : Field := Real'Digits - 1;
+ Default_Aft : Field := Complex_Types.Real'Digits - 1;
Default_Exp : Field := 3;
procedure Get
(File : File_Type;
- Item : out Complex;
+ Item : out Complex_Types.Complex;
Width : Field := 0);
procedure Get
- (Item : out Complex;
+ (Item : out Complex_Types.Complex;
Width : Field := 0);
procedure Put
(File : File_Type;
- Item : Complex;
+ Item : Complex_Types.Complex;
Fore : Field := Default_Fore;
Aft : Field := Default_Aft;
Exp : Field := Default_Exp);
procedure Put
- (Item : Complex;
+ (Item : Complex_Types.Complex;
Fore : Field := Default_Fore;
Aft : Field := Default_Aft;
Exp : Field := Default_Exp);
procedure Get
(From : Wide_Wide_String;
- Item : out Complex;
+ Item : out Complex_Types.Complex;
Last : out Positive);
procedure Put
(To : out Wide_Wide_String;
- Item : Complex;
+ Item : Complex_Types.Complex;
Aft : Field := Default_Aft;
Exp : Field := Default_Exp);
diff --git a/gcc/ada/libgnat/a-ztdeau.adb b/gcc/ada/libgnat/a-ztdeau.adb
index 3daff0f..ec6431b 100644
--- a/gcc/ada/libgnat/a-ztdeau.adb
+++ b/gcc/ada/libgnat/a-ztdeau.adb
@@ -30,56 +30,22 @@
------------------------------------------------------------------------------
with Ada.Wide_Wide_Text_IO.Generic_Aux; use Ada.Wide_Wide_Text_IO.Generic_Aux;
-with Ada.Wide_Wide_Text_IO.Float_Aux; use Ada.Wide_Wide_Text_IO.Float_Aux;
-
-with System.Img_Dec; use System.Img_Dec;
-with System.Img_LLD; use System.Img_LLD;
-with System.Val_Dec; use System.Val_Dec;
-with System.Val_LLD; use System.Val_LLD;
package body Ada.Wide_Wide_Text_IO.Decimal_Aux is
- -------------
- -- Get_Dec --
- -------------
-
- function Get_Dec
- (File : File_Type;
- Width : Field;
- Scale : Integer) return Integer
- is
- Buf : String (1 .. Field'Last);
- Ptr : aliased Integer;
- Stop : Integer := 0;
- Item : Integer;
-
- begin
- if Width /= 0 then
- Load_Width (File, Width, Buf, Stop);
- String_Skip (Buf, Ptr);
- else
- Load_Real (File, Buf, Stop);
- Ptr := 1;
- end if;
-
- Item := Scan_Decimal (Buf, Ptr'Access, Stop, Scale);
- Check_End_Of_Field (Buf, Stop, Ptr, Width);
- return Item;
- end Get_Dec;
-
- -------------
- -- Get_LLD --
- -------------
+ ---------
+ -- Get --
+ ---------
- function Get_LLD
+ function Get
(File : File_Type;
Width : Field;
- Scale : Integer) return Long_Long_Integer
+ Scale : Integer) return Int
is
Buf : String (1 .. Field'Last);
Ptr : aliased Integer;
Stop : Integer := 0;
- Item : Long_Long_Integer;
+ Item : Int;
begin
if Width /= 0 then
@@ -90,68 +56,42 @@ package body Ada.Wide_Wide_Text_IO.Decimal_Aux is
Ptr := 1;
end if;
- Item := Scan_Long_Long_Decimal (Buf, Ptr'Access, Stop, Scale);
+ Item := Scan (Buf, Ptr'Access, Stop, Scale);
Check_End_Of_Field (Buf, Stop, Ptr, Width);
return Item;
- end Get_LLD;
-
- --------------
- -- Gets_Dec --
- --------------
-
- function Gets_Dec
- (From : String;
- Last : not null access Positive;
- Scale : Integer) return Integer
- is
- Pos : aliased Integer;
- Item : Integer;
-
- begin
- String_Skip (From, Pos);
- Item := Scan_Decimal (From, Pos'Access, From'Last, Scale);
- Last.all := Pos - 1;
- return Item;
+ end Get;
- exception
- when Constraint_Error =>
- Last.all := Pos - 1;
- raise Data_Error;
-
- end Gets_Dec;
+ ----------
+ -- Gets --
+ ----------
- --------------
- -- Gets_LLD --
- --------------
-
- function Gets_LLD
+ function Gets
(From : String;
- Last : not null access Positive;
- Scale : Integer) return Long_Long_Integer
+ Last : out Positive;
+ Scale : Integer) return Int
is
Pos : aliased Integer;
- Item : Long_Long_Integer;
+ Item : Int;
begin
String_Skip (From, Pos);
- Item := Scan_Long_Long_Decimal (From, Pos'Access, From'Last, Scale);
- Last.all := Pos - 1;
+ Item := Scan (From, Pos'Access, From'Last, Scale);
+ Last := Pos - 1;
return Item;
exception
when Constraint_Error =>
- Last.all := Pos - 1;
+ Last := Pos - 1;
raise Data_Error;
+ end Gets;
- end Gets_LLD;
-
- -------------
- -- Put_Dec --
- -------------
+ ---------
+ -- Put --
+ ---------
- procedure Put_Dec
+ procedure Put
(File : File_Type;
- Item : Integer;
+ Item : Int;
Fore : Field;
Aft : Field;
Exp : Field;
@@ -161,103 +101,51 @@ package body Ada.Wide_Wide_Text_IO.Decimal_Aux is
Ptr : Natural := 0;
begin
- Set_Image_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp);
+ Set_Image (Item, Buf, Ptr, Scale, Fore, Aft, Exp);
Put_Item (File, Buf (1 .. Ptr));
- end Put_Dec;
+ end Put;
- -------------
- -- Put_LLD --
- -------------
+ ----------
+ -- Puts --
+ ----------
- procedure Put_LLD
- (File : File_Type;
- Item : Long_Long_Integer;
- Fore : Field;
- Aft : Field;
- Exp : Field;
- Scale : Integer)
- is
- Buf : String (1 .. Field'Last);
- Ptr : Natural := 0;
-
- begin
- Set_Image_Long_Long_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp);
- Put_Item (File, Buf (1 .. Ptr));
- end Put_LLD;
-
- --------------
- -- Puts_Dec --
- --------------
-
- procedure Puts_Dec
+ procedure Puts
(To : out String;
- Item : Integer;
+ Item : Int;
Aft : Field;
Exp : Field;
Scale : Integer)
is
- Buf : String (1 .. Field'Last);
+ Buf : String (1 .. Positive'Max (Field'Last, To'Length));
Fore : Integer;
Ptr : Natural := 0;
begin
- -- Compute Fore, allowing for Aft digits and the decimal dot
+ -- Compute Fore, allowing for the decimal dot and Aft digits
- Fore := To'Length - Field'Max (1, Aft) - 1;
+ Fore := To'Length - 1 - Field'Max (1, Aft);
- -- Allow for Exp and two more for E+ or E- if exponent present
+ -- Allow for Exp and one more for E if exponent present
if Exp /= 0 then
- Fore := Fore - 2 - Exp;
+ Fore := Fore - 1 - Field'Max (2, Exp);
end if;
-- Make sure we have enough room
- if Fore < 1 then
+ if Fore < 1 + Boolean'Pos (Item < 0) then
raise Layout_Error;
end if;
-- Do the conversion and check length of result
- Set_Image_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp);
-
- if Ptr > To'Length then
- raise Layout_Error;
- else
- To := Buf (1 .. Ptr);
- end if;
- end Puts_Dec;
-
- --------------
- -- Puts_LLD --
- --------------
-
- procedure Puts_LLD
- (To : out String;
- Item : Long_Long_Integer;
- Aft : Field;
- Exp : Field;
- Scale : Integer)
- is
- Buf : String (1 .. Field'Last);
- Fore : Integer;
- Ptr : Natural := 0;
-
- begin
- Fore :=
- (if Exp = 0 then To'Length - 1 - Aft else To'Length - 2 - Aft - Exp);
-
- if Fore < 1 then
- raise Layout_Error;
- end if;
-
- Set_Image_Long_Long_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp);
+ Set_Image (Item, Buf, Ptr, Scale, Fore, Aft, Exp);
if Ptr > To'Length then
raise Layout_Error;
else
To := Buf (1 .. Ptr);
end if;
- end Puts_LLD;
+ end Puts;
end Ada.Wide_Wide_Text_IO.Decimal_Aux;
diff --git a/gcc/ada/libgnat/a-ztdeau.ads b/gcc/ada/libgnat/a-ztdeau.ads
index b493b80..962f479 100644
--- a/gcc/ada/libgnat/a-ztdeau.ads
+++ b/gcc/ada/libgnat/a-ztdeau.ads
@@ -29,63 +29,54 @@
-- --
------------------------------------------------------------------------------
--- This package contains the routines for Ada.Wide_Wide_Text_IO.Decimal_IO
--- that are shared among separate instantiations of this package. The
--- routines in the package are identical semantically to those declared
--- in Wide_Wide_Text_IO, except that default values have been supplied by the
--- generic, and the Num parameter has been replaced by Integer or
--- Long_Long_Integer, with an additional Scale parameter giving the
--- value of Num'Scale. In addition the Get routines return the value
--- rather than store it in an Out parameter.
+-- This package contains implementation for Ada.Wide_Wide_Text_IO.Decimal_IO
+-- Routines in this package are identical semantically to those in Decimal_IO,
+-- except that the default parameters have been removed because they are
+-- supplied explicitly by the calls from within these units, and there is an
+-- additional Scale parameter giving the value of Num'Scale. In addition the
+-- Get routines return the value rather than store it in an Out parameter.
-private package Ada.Wide_Wide_Text_IO.Decimal_Aux is
+private generic
+ type Int is range <>;
- function Get_Dec
- (File : File_Type;
- Width : Field;
- Scale : Integer) return Integer;
+ with function Scan
+ (Str : String;
+ Ptr : not null access Integer;
+ Max : Integer;
+ Scale : Integer) return Int;
- function Get_LLD
- (File : File_Type;
- Width : Field;
- Scale : Integer) return Long_Long_Integer;
+ with procedure Set_Image
+ (V : Int;
+ S : in out String;
+ P : in out Natural;
+ Scale : Integer;
+ Fore : Natural;
+ Aft : Natural;
+ Exp : Natural);
- function Gets_Dec
- (From : String;
- Last : not null access Positive;
- Scale : Integer) return Integer;
+package Ada.Wide_Wide_Text_IO.Decimal_Aux is
- function Gets_LLD
- (From : String;
- Last : not null access Positive;
- Scale : Integer) return Long_Long_Integer;
-
- procedure Put_Dec
+ function Get
(File : File_Type;
- Item : Integer;
- Fore : Field;
- Aft : Field;
- Exp : Field;
- Scale : Integer);
+ Width : Field;
+ Scale : Integer) return Int;
- procedure Put_LLD
+ procedure Put
(File : File_Type;
- Item : Long_Long_Integer;
+ Item : Int;
Fore : Field;
Aft : Field;
Exp : Field;
Scale : Integer);
- procedure Puts_Dec
- (To : out String;
- Item : Integer;
- Aft : Field;
- Exp : Field;
- Scale : Integer);
+ function Gets
+ (From : String;
+ Last : out Positive;
+ Scale : Integer) return Int;
- procedure Puts_LLD
+ procedure Puts
(To : out String;
- Item : Long_Long_Integer;
+ Item : Int;
Aft : Field;
Exp : Field;
Scale : Integer);
diff --git a/gcc/ada/libgnat/a-ztdeio.adb b/gcc/ada/libgnat/a-ztdeio.adb
index 3655386..1d9f5d8 100644
--- a/gcc/ada/libgnat/a-ztdeio.adb
+++ b/gcc/ada/libgnat/a-ztdeio.adb
@@ -30,16 +30,35 @@
------------------------------------------------------------------------------
with Ada.Wide_Wide_Text_IO.Decimal_Aux;
-
+with System.Img_Decimal_32; use System.Img_Decimal_32;
+with System.Img_Decimal_64; use System.Img_Decimal_64;
+with System.Val_Decimal_32; use System.Val_Decimal_32;
+with System.Val_Decimal_64; use System.Val_Decimal_64;
with System.WCh_Con; use System.WCh_Con;
with System.WCh_WtS; use System.WCh_WtS;
package body Ada.Wide_Wide_Text_IO.Decimal_IO is
- subtype TFT is Ada.Wide_Wide_Text_IO.File_Type;
- -- File type required for calls to routines in Aux
+ subtype Int32 is Interfaces.Integer_32;
+ subtype Int64 is Interfaces.Integer_64;
+
+ package Aux32 is new
+ Ada.Wide_Wide_Text_IO.Decimal_Aux
+ (Int32,
+ Scan_Decimal32,
+ Set_Image_Decimal32);
- package Aux renames Ada.Wide_Wide_Text_IO.Decimal_Aux;
+ package Aux64 is new
+ Ada.Wide_Wide_Text_IO.Decimal_Aux
+ (Int64,
+ Scan_Decimal64,
+ Set_Image_Decimal64);
+
+ Need64 : constant Boolean := Num'Size > 32;
+ -- Throughout this generic body, we distinguish between the case where type
+ -- Int32 is acceptable and where type Int64 is needed. This Boolean is used
+ -- to test for these cases and since it is a constant, only code for the
+ -- relevant case will be included in the instance.
Scale : constant Integer := Num'Scale;
@@ -52,12 +71,15 @@ package body Ada.Wide_Wide_Text_IO.Decimal_IO is
Item : out Num;
Width : Field := 0)
is
+ pragma Unsuppress (Range_Check);
+
begin
- if Num'Size > Integer'Size then
- Item := Num'Fixed_Value (Aux.Get_LLD (TFT (File), Width, Scale));
+ if Need64 then
+ Item := Num'Fixed_Value (Aux64.Get (File, Width, Scale));
else
- Item := Num'Fixed_Value (Aux.Get_Dec (TFT (File), Width, Scale));
+ Item := Num'Fixed_Value (Aux32.Get (File, Width, Scale));
end if;
+
exception
when Constraint_Error => raise Data_Error;
end Get;
@@ -67,7 +89,7 @@ package body Ada.Wide_Wide_Text_IO.Decimal_IO is
Width : Field := 0)
is
begin
- Get (Current_Input, Item, Width);
+ Get (Current_In, Item, Width);
end Get;
procedure Get
@@ -75,6 +97,8 @@ package body Ada.Wide_Wide_Text_IO.Decimal_IO is
Item : out Num;
Last : out Positive)
is
+ pragma Unsuppress (Range_Check);
+
S : constant String := Wide_Wide_String_To_String (From, WCEM_Upper);
-- String on which we do the actual conversion. Note that the method
-- used for wide character encoding is irrelevant, since if there is
@@ -82,16 +106,10 @@ package body Ada.Wide_Wide_Text_IO.Decimal_IO is
-- Aux.Gets will raise Data_Error in any case.
begin
- if Num'Size > Integer'Size then
- -- Item := Num'Fixed_Value
- -- should write above, but gets assert error ???
- Item := Num
- (Aux.Gets_LLD (S, Last'Unrestricted_Access, Scale));
+ if Need64 then
+ Item := Num'Fixed_Value (Aux64.Gets (S, Last, Scale));
else
- -- Item := Num'Fixed_Value
- -- should write above, but gets assert error ???
- Item := Num
- (Aux.Gets_Dec (S, Last'Unrestricted_Access, Scale));
+ Item := Num'Fixed_Value (Aux32.Gets (S, Last, Scale));
end if;
exception
@@ -110,18 +128,12 @@ package body Ada.Wide_Wide_Text_IO.Decimal_IO is
Exp : Field := Default_Exp)
is
begin
- if Num'Size > Integer'Size then
- Aux.Put_LLD
--- (TFT (File), Long_Long_Integer'Integer_Value (Item),
--- ???
- (TFT (File), Long_Long_Integer (Item),
- Fore, Aft, Exp, Scale);
+ if Need64 then
+ Aux64.Put
+ (File, Int64'Integer_Value (Item), Fore, Aft, Exp, Scale);
else
- Aux.Put_Dec
--- (TFT (File), Integer'Integer_Value (Item), Fore, Aft, Exp, Scale);
--- ???
- (TFT (File), Integer (Item), Fore, Aft, Exp, Scale);
-
+ Aux32.Put
+ (File, Int32'Integer_Value (Item), Fore, Aft, Exp, Scale);
end if;
end Put;
@@ -132,7 +144,7 @@ package body Ada.Wide_Wide_Text_IO.Decimal_IO is
Exp : Field := Default_Exp)
is
begin
- Put (Current_Output, Item, Fore, Aft, Exp);
+ Put (Current_Out, Item, Fore, Aft, Exp);
end Put;
procedure Put
@@ -144,16 +156,10 @@ package body Ada.Wide_Wide_Text_IO.Decimal_IO is
S : String (To'First .. To'Last);
begin
- if Num'Size > Integer'Size then
--- Aux.Puts_LLD
--- (S, Long_Long_Integer'Integer_Value (Item), Aft, Exp, Scale);
--- ???
- Aux.Puts_LLD
- (S, Long_Long_Integer (Item), Aft, Exp, Scale);
+ if Need64 then
+ Aux64.Puts (S, Int64'Integer_Value (Item), Aft, Exp, Scale);
else
--- Aux.Puts_Dec (S, Integer'Integer_Value (Item), Aft, Exp, Scale);
--- ???
- Aux.Puts_Dec (S, Integer (Item), Aft, Exp, Scale);
+ Aux32.Puts (S, Int32'Integer_Value (Item), Aft, Exp, Scale);
end if;
for J in S'Range loop
diff --git a/gcc/ada/libgnat/a-ztdeio__128.adb b/gcc/ada/libgnat/a-ztdeio__128.adb
new file mode 100644
index 0000000..156a66d
--- /dev/null
+++ b/gcc/ada/libgnat/a-ztdeio__128.adb
@@ -0,0 +1,190 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . W I D E _ W I D E _ T E X T _ I O . D E C I M A L _ I O --
+-- --
+-- 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.Wide_Wide_Text_IO.Decimal_Aux;
+with System.Img_Decimal_32; use System.Img_Decimal_32;
+with System.Img_Decimal_64; use System.Img_Decimal_64;
+with System.Img_Decimal_128; use System.Img_Decimal_128;
+with System.Val_Decimal_32; use System.Val_Decimal_32;
+with System.Val_Decimal_64; use System.Val_Decimal_64;
+with System.Val_Decimal_128; use System.Val_Decimal_128;
+with System.WCh_Con; use System.WCh_Con;
+with System.WCh_WtS; use System.WCh_WtS;
+
+package body Ada.Wide_Wide_Text_IO.Decimal_IO is
+
+ subtype Int32 is Interfaces.Integer_32;
+ subtype Int64 is Interfaces.Integer_64;
+ subtype Int128 is Interfaces.Integer_128;
+
+ package Aux32 is new
+ Ada.Wide_Wide_Text_IO.Decimal_Aux
+ (Int32,
+ Scan_Decimal32,
+ Set_Image_Decimal32);
+
+ package Aux64 is new
+ Ada.Wide_Wide_Text_IO.Decimal_Aux
+ (Int64,
+ Scan_Decimal64,
+ Set_Image_Decimal64);
+
+ package Aux128 is new
+ Ada.Wide_Wide_Text_IO.Decimal_Aux
+ (Int128,
+ Scan_Decimal128,
+ Set_Image_Decimal128);
+
+ Need64 : constant Boolean := Num'Size > 32;
+ Need128 : constant Boolean := Num'Size > 64;
+ -- Throughout this generic body, we distinguish between the case where type
+ -- Int32 is acceptable, where type Int64 is acceptable and where an Int128
+ -- is needed. These boolean constants are used to test for these cases and
+ -- since it is a constant, only code for the relevant case will be included
+ -- in the instance.
+
+ Scale : constant Integer := Num'Scale;
+
+ ---------
+ -- Get --
+ ---------
+
+ procedure Get
+ (File : File_Type;
+ Item : out Num;
+ Width : Field := 0)
+ is
+ pragma Unsuppress (Range_Check);
+
+ begin
+ if Need128 then
+ Item := Num'Fixed_Value (Aux128.Get (File, Width, Scale));
+ elsif Need64 then
+ Item := Num'Fixed_Value (Aux64.Get (File, Width, Scale));
+ else
+ Item := Num'Fixed_Value (Aux32.Get (File, Width, Scale));
+ end if;
+
+ exception
+ when Constraint_Error => raise Data_Error;
+ end Get;
+
+ procedure Get
+ (Item : out Num;
+ Width : Field := 0)
+ is
+ begin
+ Get (Current_In, Item, Width);
+ end Get;
+
+ procedure Get
+ (From : Wide_Wide_String;
+ Item : out Num;
+ Last : out Positive)
+ is
+ pragma Unsuppress (Range_Check);
+
+ S : constant String := Wide_Wide_String_To_String (From, WCEM_Upper);
+ -- String on which we do the actual conversion. Note that the method
+ -- used for wide character encoding is irrelevant, since if there is
+ -- a character outside the Standard.Character range then the call to
+ -- Aux.Gets will raise Data_Error in any case.
+
+ begin
+ if Need128 then
+ Item := Num'Fixed_Value (Aux128.Gets (S, Last, Scale));
+ elsif Need64 then
+ Item := Num'Fixed_Value (Aux64.Gets (S, Last, Scale));
+ else
+ Item := Num'Fixed_Value (Aux32.Gets (S, Last, Scale));
+ end if;
+
+ exception
+ when Constraint_Error => raise Data_Error;
+ end Get;
+
+ ---------
+ -- Put --
+ ---------
+
+ procedure Put
+ (File : File_Type;
+ Item : Num;
+ Fore : Field := Default_Fore;
+ Aft : Field := Default_Aft;
+ Exp : Field := Default_Exp)
+ is
+ begin
+ if Need128 then
+ Aux128.Put
+ (File, Int128'Integer_Value (Item), Fore, Aft, Exp, Scale);
+ elsif Need64 then
+ Aux64.Put
+ (File, Int64'Integer_Value (Item), Fore, Aft, Exp, Scale);
+ else
+ Aux32.Put
+ (File, Int32'Integer_Value (Item), Fore, Aft, Exp, Scale);
+ end if;
+ end Put;
+
+ procedure Put
+ (Item : Num;
+ Fore : Field := Default_Fore;
+ Aft : Field := Default_Aft;
+ Exp : Field := Default_Exp)
+ is
+ begin
+ Put (Current_Out, Item, Fore, Aft, Exp);
+ end Put;
+
+ procedure Put
+ (To : out Wide_Wide_String;
+ Item : Num;
+ Aft : Field := Default_Aft;
+ Exp : Field := Default_Exp)
+ is
+ S : String (To'First .. To'Last);
+
+ begin
+ if Need128 then
+ Aux128.Puts (S, Int128'Integer_Value (Item), Aft, Exp, Scale);
+ elsif Need64 then
+ Aux64.Puts (S, Int64'Integer_Value (Item), Aft, Exp, Scale);
+ else
+ Aux32.Puts (S, Int32'Integer_Value (Item), Aft, Exp, Scale);
+ end if;
+
+ for J in S'Range loop
+ To (J) := Wide_Wide_Character'Val (Character'Pos (S (J)));
+ end loop;
+ end Put;
+
+end Ada.Wide_Wide_Text_IO.Decimal_IO;
diff --git a/gcc/ada/libgnat/a-ztenau.adb b/gcc/ada/libgnat/a-ztenau.adb
index f985d52d..f3b11af 100644
--- a/gcc/ada/libgnat/a-ztenau.adb
+++ b/gcc/ada/libgnat/a-ztenau.adb
@@ -37,9 +37,6 @@ with System.WCh_Con; use System.WCh_Con;
package body Ada.Wide_Wide_Text_IO.Enumeration_Aux is
- subtype TFT is Ada.Wide_Wide_Text_IO.File_Type;
- -- File type required for calls to routines in Aux
-
-----------------------
-- Local Subprograms --
-----------------------
@@ -70,8 +67,8 @@ package body Ada.Wide_Wide_Text_IO.Enumeration_Aux is
begin
Buflen := 0;
- Load_Skip (TFT (File));
- ch := Nextc (TFT (File));
+ Load_Skip (File);
+ ch := Nextc (File);
-- Character literal case. If the initial character is a quote, then
-- we read as far as we can without backup (see ACVC test CE3905L)
@@ -80,7 +77,7 @@ package body Ada.Wide_Wide_Text_IO.Enumeration_Aux is
Get (File, WC);
Store_Char (WC, Buf, Buflen);
- ch := Nextc (TFT (File));
+ ch := Nextc (File);
if ch = LM or else ch = EOF then
return;
@@ -89,7 +86,7 @@ package body Ada.Wide_Wide_Text_IO.Enumeration_Aux is
Get (File, WC);
Store_Char (WC, Buf, Buflen);
- ch := Nextc (TFT (File));
+ ch := Nextc (File);
if ch /= Character'Pos (''') then
return;
@@ -118,7 +115,7 @@ package body Ada.Wide_Wide_Text_IO.Enumeration_Aux is
Get (File, WC);
Store_Char (WC, Buf, Buflen);
- ch := Nextc (TFT (File));
+ ch := Nextc (File);
exit when ch = EOF;
@@ -156,7 +153,7 @@ package body Ada.Wide_Wide_Text_IO.Enumeration_Aux is
Integer'Max (Integer (Width), Item'Length);
begin
- Check_On_One_Line (TFT (File), Actual_Width);
+ Check_On_One_Line (File, Actual_Width);
if Set = Lower_Case and then Item (Item'First) /= ''' then
declare
diff --git a/gcc/ada/libgnat/a-ztenio.adb b/gcc/ada/libgnat/a-ztenio.adb
index 5a61874..6c35b9f 100644
--- a/gcc/ada/libgnat/a-ztenio.adb
+++ b/gcc/ada/libgnat/a-ztenio.adb
@@ -51,7 +51,7 @@ package body Ada.Wide_Wide_Text_IO.Enumeration_IO is
procedure Get (Item : out Enum) is
begin
- Get (Current_Input, Item);
+ Get (Current_In, Item);
end Get;
procedure Get
@@ -88,7 +88,7 @@ package body Ada.Wide_Wide_Text_IO.Enumeration_IO is
Set : Type_Set := Default_Setting)
is
begin
- Put (Current_Output, Item, Width, Set);
+ Put (Current_Out, Item, Width, Set);
end Put;
procedure Put
diff --git a/gcc/ada/libgnat/a-ztfiau.adb b/gcc/ada/libgnat/a-ztfiau.adb
new file mode 100644
index 0000000..1e94fef
--- /dev/null
+++ b/gcc/ada/libgnat/a-ztfiau.adb
@@ -0,0 +1,159 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . W I D E _ W I D E _ T E X T _ I O . F I X E D _ I O --
+-- --
+-- 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.Wide_Wide_Text_IO.Generic_Aux; use Ada.Wide_Wide_Text_IO.Generic_Aux;
+
+package body Ada.Wide_Wide_Text_IO.Fixed_Aux is
+
+ ---------
+ -- Get --
+ ---------
+
+ function Get
+ (File : File_Type;
+ Width : Field;
+ Num : Int;
+ Den : Int) return Int
+ is
+ Buf : String (1 .. Field'Last);
+ Ptr : aliased Integer;
+ Stop : Integer := 0;
+ Item : Int;
+
+ begin
+ if Width /= 0 then
+ Load_Width (File, Width, Buf, Stop);
+ String_Skip (Buf, Ptr);
+ else
+ Load_Real (File, Buf, Stop);
+ Ptr := 1;
+ end if;
+
+ Item := Scan (Buf, Ptr'Access, Stop, Num, Den);
+ Check_End_Of_Field (Buf, Stop, Ptr, Width);
+ return Item;
+ end Get;
+
+ ----------
+ -- Gets --
+ ----------
+
+ function Gets
+ (From : String;
+ Last : out Positive;
+ Num : Int;
+ Den : Int) return Int
+ is
+ Pos : aliased Integer;
+ Item : Int;
+
+ begin
+ String_Skip (From, Pos);
+ Item := Scan (From, Pos'Access, From'Last, Num, Den);
+ Last := Pos - 1;
+ return Item;
+
+ exception
+ when Constraint_Error =>
+ Last := Pos - 1;
+ raise Data_Error;
+ end Gets;
+
+ ---------
+ -- Put --
+ ---------
+
+ procedure Put
+ (File : File_Type;
+ Item : Int;
+ Fore : Field;
+ Aft : Field;
+ Exp : Natural;
+ Num : Int;
+ Den : Int;
+ For0 : Natural;
+ Aft0 : Natural)
+ is
+ Buf : String (1 .. Field'Last);
+ Ptr : Natural := 0;
+
+ begin
+ Set_Image (Item, Buf, Ptr, Num, Den, For0, Aft0, Fore, Aft, Exp);
+ Put_Item (File, Buf (1 .. Ptr));
+ end Put;
+
+ ----------
+ -- Puts --
+ ----------
+
+ procedure Puts
+ (To : out String;
+ Item : Int;
+ Aft : Field;
+ Exp : Natural;
+ Num : Int;
+ Den : Int;
+ For0 : Natural;
+ Aft0 : Natural)
+ is
+ Buf : String (1 .. Positive'Max (Field'Last, To'Length));
+ Fore : Integer;
+ Ptr : Natural := 0;
+
+ begin
+ -- Compute Fore, allowing for the decimal dot and Aft digits
+
+ Fore := To'Length - 1 - Field'Max (1, Aft);
+
+ -- Allow for Exp and one more for E if exponent present
+
+ if Exp /= 0 then
+ Fore := Fore - 1 - Field'Max (2, Exp);
+ end if;
+
+ -- Make sure we have enough room
+
+ if Fore < 1 + Boolean'Pos (Item < 0) then
+ raise Layout_Error;
+ end if;
+
+ -- Do the conversion and check length of result
+
+ Set_Image (Item, Buf, Ptr, Num, Den, For0, Aft0, Fore, Aft, Exp);
+
+ if Ptr > To'Length then
+ raise Layout_Error;
+ else
+ To := Buf (1 .. Ptr);
+ end if;
+ end Puts;
+
+end Ada.Wide_Wide_Text_IO.Fixed_Aux;
diff --git a/gcc/ada/libgnat/a-ztfiau.ads b/gcc/ada/libgnat/a-ztfiau.ads
new file mode 100644
index 0000000..aac4e42
--- /dev/null
+++ b/gcc/ada/libgnat/a-ztfiau.ads
@@ -0,0 +1,97 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . W I D E _ W I D E _ T E X T _ I O . F I X E D _ I O --
+-- --
+-- 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. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains the implementation for Ada.Wide_Wide_Text_IO.Fixed_IO
+-- Routines in this package are identical semantically to those in Fixed_IO,
+-- except that the default parameters have been removed because they are
+-- supplied explicitly by the calls from within these units, and there are
+-- additional Num and Den parameters giving the value of Num'Small, as well
+-- as For0 and Aft0 giving some properties of Num'Small. In addition the Get
+-- routines return the value rather than store it in an Out parameter.
+
+private generic
+ type Int is range <>;
+
+ with function Scan
+ (Str : String;
+ Ptr : not null access Integer;
+ Max : Integer;
+ Num : Int;
+ Den : Int) return Int;
+
+ with procedure Set_Image
+ (V : Int;
+ S : in out String;
+ P : in out Natural;
+ Num : Int;
+ Den : Int;
+ For0 : Natural;
+ Aft0 : Natural;
+ Fore : Natural;
+ Aft : Natural;
+ Exp : Natural);
+
+package Ada.Wide_Wide_Text_IO.Fixed_Aux is
+
+ function Get
+ (File : File_Type;
+ Width : Field;
+ Num : Int;
+ Den : Int) return Int;
+
+ procedure Put
+ (File : File_Type;
+ Item : Int;
+ Fore : Field;
+ Aft : Field;
+ Exp : Natural;
+ Num : Int;
+ Den : Int;
+ For0 : Natural;
+ Aft0 : Natural);
+
+ function Gets
+ (From : String;
+ Last : out Positive;
+ Num : Int;
+ Den : Int) return Int;
+
+ procedure Puts
+ (To : out String;
+ Item : Int;
+ Aft : Field;
+ Exp : Natural;
+ Num : Int;
+ Den : Int;
+ For0 : Natural;
+ Aft0 : Natural);
+
+end Ada.Wide_Wide_Text_IO.Fixed_Aux;
diff --git a/gcc/ada/libgnat/a-ztfiio.adb b/gcc/ada/libgnat/a-ztfiio.adb
index 7c0c95d..53ed45b 100644
--- a/gcc/ada/libgnat/a-ztfiio.adb
+++ b/gcc/ada/libgnat/a-ztfiio.adb
@@ -2,7 +2,7 @@
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
--- A D A . T E X T _ I O . W I D E _ T E X T _ I O . F I X E D _ I O --
+-- A D A . W I D E _ W I D E _ T E X T _ I O . F I X E D _ I O --
-- --
-- B o d y --
-- --
@@ -29,16 +29,114 @@
-- --
------------------------------------------------------------------------------
+with Interfaces;
+with Ada.Wide_Wide_Text_IO.Fixed_Aux;
with Ada.Wide_Wide_Text_IO.Float_Aux;
-with System.WCh_Con; use System.WCh_Con;
-with System.WCh_WtS; use System.WCh_WtS;
+with System.Img_Fixed_32; use System.Img_Fixed_32;
+with System.Img_Fixed_64; use System.Img_Fixed_64;
+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.WCh_Con; use System.WCh_Con;
+with System.WCh_WtS; use System.WCh_WtS;
package body Ada.Wide_Wide_Text_IO.Fixed_IO is
- subtype TFT is Ada.Wide_Wide_Text_IO.File_Type;
- -- File type required for calls to routines in Aux
+ -- 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.
- package Aux renames Ada.Wide_Wide_Text_IO.Float_Aux;
+ subtype Int32 is Interfaces.Integer_32; use type Int32;
+ subtype Int64 is Interfaces.Integer_64; use type Int64;
+
+ package Aux32 is new
+ Ada.Wide_Wide_Text_IO.Fixed_Aux (Int32, Scan_Fixed32, Set_Image_Fixed32);
+
+ 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);
+
+ -- 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
+ -- to test for this, such that only code for the relevant case is included
+ -- in the instance; that's why the computation of their value must be fully
+ -- static (although it is not a static expressions in the RM sense).
+
+ OK_Get_32 : constant Boolean :=
+ Num'Base'Object_Size <= 32
+ and then
+ ((Num'Small_Numerator = 1 and then Num'Small_Denominator <= 2**31)
+ or else
+ (Num'Small_Denominator = 1 and then Num'Small_Numerator <= 2**31)
+ or else
+ (Num'Small_Numerator <= 2**27
+ and then Num'Small_Denominator <= 2**27));
+ -- These conditions are derived from the prerequisites of System.Value_F
+
+ OK_Put_32 : constant Boolean :=
+ Num'Base'Object_Size <= 32
+ and then
+ ((Num'Small_Numerator = 1 and then Num'Small_Denominator <= 2**31)
+ or else
+ (Num'Small_Denominator = 1 and then Num'Small_Numerator <= 2**31)
+ or else
+ (Num'Small_Numerator < Num'Small_Denominator
+ and then Num'Small_Denominator <= 2**27)
+ or else
+ (Num'Small_Denominator < Num'Small_Numerator
+ and then Num'Small_Numerator <= 2**25));
+ -- These conditions are derived from the prerequisites of System.Image_F
+
+ OK_Get_64 : constant Boolean :=
+ Num'Base'Object_Size <= 64
+ and then
+ ((Num'Small_Numerator = 1 and then Num'Small_Denominator <= 2**63)
+ or else
+ (Num'Small_Denominator = 1 and then Num'Small_Numerator <= 2**63)
+ or else
+ (Num'Small_Numerator <= 2**59
+ and then Num'Small_Denominator <= 2**59));
+ -- These conditions are derived from the prerequisites of System.Value_F
+
+ OK_Put_64 : constant Boolean :=
+ Num'Base'Object_Size <= 64
+ and then
+ ((Num'Small_Numerator = 1 and then Num'Small_Denominator <= 2**63)
+ or else
+ (Num'Small_Denominator = 1 and then Num'Small_Numerator <= 2**63)
+ or else
+ (Num'Small_Numerator < Num'Small_Denominator
+ and then Num'Small_Denominator <= 2**59)
+ or else
+ (Num'Small_Denominator < Num'Small_Numerator
+ and then Num'Small_Numerator <= 2**53));
+ -- These conditions are derived from the prerequisites of System.Image_F
+
+ E : constant Natural := 63 - 32 * Boolean'Pos (OK_Put_32);
+ -- T'Size - 1 for the selected Int{32,64}
+
+ F0 : constant Natural := 0;
+ F1 : constant Natural :=
+ F0 + 18 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F0) >= 1.0E+18);
+ F2 : constant Natural :=
+ F1 + 9 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F1) >= 1.0E+9);
+ F3 : constant Natural :=
+ F2 + 5 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F2) >= 1.0E+5);
+ F4 : constant Natural :=
+ F3 + 3 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F3) >= 1.0E+3);
+ F5 : constant Natural :=
+ F4 + 2 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F4) >= 1.0E+2);
+ F6 : constant Natural :=
+ F5 + 1 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F5) >= 1.0E+1);
+ -- Binary search for the number of digits - 1 before the decimal point of
+ -- the product 2.0**E * Num'Small.
+
+ For0 : constant Natural := 2 + F6;
+ -- Fore value for the fixed point type whose mantissa is Int{32,64} and
+ -- whose small is Num'Small.
---------
-- Get --
@@ -49,8 +147,22 @@ package body Ada.Wide_Wide_Text_IO.Fixed_IO is
Item : out Num;
Width : Field := 0)
is
+ pragma Unsuppress (Range_Check);
+
begin
- Aux.Get (TFT (File), Long_Long_Float (Item), Width);
+ if OK_Get_32 then
+ Item := Num'Fixed_Value
+ (Aux32.Get (File, Width,
+ -Num'Small_Numerator,
+ -Num'Small_Denominator));
+ elsif OK_Get_64 then
+ Item := Num'Fixed_Value
+ (Aux64.Get (File, Width,
+ -Num'Small_Numerator,
+ -Num'Small_Denominator));
+ else
+ Aux_Long_Long_Float.Get (File, Long_Long_Float (Item), Width);
+ end if;
exception
when Constraint_Error => raise Data_Error;
@@ -61,7 +173,7 @@ package body Ada.Wide_Wide_Text_IO.Fixed_IO is
Width : Field := 0)
is
begin
- Get (Current_Input, Item, Width);
+ Get (Current_In, Item, Width);
end Get;
procedure Get
@@ -69,6 +181,8 @@ package body Ada.Wide_Wide_Text_IO.Fixed_IO is
Item : out Num;
Last : out Positive)
is
+ pragma Unsuppress (Range_Check);
+
S : constant String := Wide_Wide_String_To_String (From, WCEM_Upper);
-- String on which we do the actual conversion. Note that the method
-- used for wide character encoding is irrelevant, since if there is
@@ -76,7 +190,19 @@ package body Ada.Wide_Wide_Text_IO.Fixed_IO is
-- Aux.Gets will raise Data_Error in any case.
begin
- Aux.Gets (S, Long_Long_Float (Item), Last);
+ if OK_Get_32 then
+ Item := Num'Fixed_Value
+ (Aux32.Gets (S, Last,
+ -Num'Small_Numerator,
+ -Num'Small_Denominator));
+ elsif OK_Get_64 then
+ Item := Num'Fixed_Value
+ (Aux64.Gets (S, Last,
+ -Num'Small_Numerator,
+ -Num'Small_Denominator));
+ else
+ Aux_Long_Long_Float.Gets (S, Long_Long_Float (Item), Last);
+ end if;
exception
when Constraint_Error => raise Data_Error;
@@ -94,7 +220,18 @@ package body Ada.Wide_Wide_Text_IO.Fixed_IO is
Exp : Field := Default_Exp)
is
begin
- Aux.Put (TFT (File), Long_Long_Float (Item), Fore, Aft, Exp);
+ if OK_Put_32 then
+ Aux32.Put (File, Int32'Integer_Value (Item), Fore, Aft, Exp,
+ -Num'Small_Numerator, -Num'Small_Denominator,
+ For0, Num'Aft);
+ elsif OK_Put_64 then
+ Aux64.Put (File, Int64'Integer_Value (Item), Fore, Aft, Exp,
+ -Num'Small_Numerator, -Num'Small_Denominator,
+ For0, Num'Aft);
+ else
+ Aux_Long_Long_Float.Put
+ (File, Long_Long_Float (Item), Fore, Aft, Exp);
+ end if;
end Put;
procedure Put
@@ -104,7 +241,7 @@ package body Ada.Wide_Wide_Text_IO.Fixed_IO is
Exp : Field := Default_Exp)
is
begin
- Put (Current_Output, Item, Fore, Aft, Exp);
+ Put (Current_Out, Item, Fore, Aft, Exp);
end Put;
procedure Put
@@ -116,7 +253,17 @@ package body Ada.Wide_Wide_Text_IO.Fixed_IO is
S : String (To'First .. To'Last);
begin
- Aux.Puts (S, Long_Long_Float (Item), Aft, Exp);
+ if OK_Put_32 then
+ Aux32.Puts (S, Int32'Integer_Value (Item), Aft, Exp,
+ -Num'Small_Numerator, -Num'Small_Denominator,
+ For0, Num'Aft);
+ elsif OK_Put_64 then
+ Aux64.Puts (S, Int64'Integer_Value (Item), Aft, Exp,
+ -Num'Small_Numerator, -Num'Small_Denominator,
+ For0, Num'Aft);
+ else
+ Aux_Long_Long_Float.Puts (S, Long_Long_Float (Item), Aft, Exp);
+ end if;
for J in S'Range loop
To (J) := Wide_Wide_Character'Val (Character'Pos (S (J)));
diff --git a/gcc/ada/libgnat/a-ztfiio__128.adb b/gcc/ada/libgnat/a-ztfiio__128.adb
new file mode 100644
index 0000000..13ed410
--- /dev/null
+++ b/gcc/ada/libgnat/a-ztfiio__128.adb
@@ -0,0 +1,327 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . W I D E _ W I D E _ T E X T _ I O . F I X E D _ I O --
+-- --
+-- 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 Interfaces;
+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_Fixed_128; use System.Img_Fixed_128;
+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.WCh_Con; use System.WCh_Con;
+with System.WCh_WtS; use System.WCh_WtS;
+
+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.
+
+ subtype Int32 is Interfaces.Integer_32; use type Int32;
+ subtype Int64 is Interfaces.Integer_64; use type Int64;
+ subtype Int128 is Interfaces.Integer_128; use type Int128;
+
+ package Aux32 is new
+ Ada.Wide_Wide_Text_IO.Fixed_Aux (Int32, Scan_Fixed32, Set_Image_Fixed32);
+
+ package Aux64 is new
+ Ada.Wide_Wide_Text_IO.Fixed_Aux (Int64, Scan_Fixed64, Set_Image_Fixed64);
+
+ package Aux128 is new
+ 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);
+
+ -- 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
+ -- boolean constants are used to test for this, such that only code for the
+ -- relevant case is included in the instance; that's why the computation of
+ -- their value must be fully static (although it is not a static expression
+ -- in the RM sense).
+
+ OK_Get_32 : constant Boolean :=
+ Num'Base'Object_Size <= 32
+ and then
+ ((Num'Small_Numerator = 1 and then Num'Small_Denominator <= 2**31)
+ or else
+ (Num'Small_Denominator = 1 and then Num'Small_Numerator <= 2**31)
+ or else
+ (Num'Small_Numerator <= 2**27
+ and then Num'Small_Denominator <= 2**27));
+ -- These conditions are derived from the prerequisites of System.Value_F
+
+ OK_Put_32 : constant Boolean :=
+ Num'Base'Object_Size <= 32
+ and then
+ ((Num'Small_Numerator = 1 and then Num'Small_Denominator <= 2**31)
+ or else
+ (Num'Small_Denominator = 1 and then Num'Small_Numerator <= 2**31)
+ or else
+ (Num'Small_Numerator < Num'Small_Denominator
+ and then Num'Small_Denominator <= 2**27)
+ or else
+ (Num'Small_Denominator < Num'Small_Numerator
+ and then Num'Small_Numerator <= 2**25));
+ -- These conditions are derived from the prerequisites of System.Image_F
+
+ OK_Get_64 : constant Boolean :=
+ Num'Base'Object_Size <= 64
+ and then
+ ((Num'Small_Numerator = 1 and then Num'Small_Denominator <= 2**63)
+ or else
+ (Num'Small_Denominator = 1 and then Num'Small_Numerator <= 2**63)
+ or else
+ (Num'Small_Numerator <= 2**59
+ and then Num'Small_Denominator <= 2**59));
+ -- These conditions are derived from the prerequisites of System.Value_F
+
+ OK_Put_64 : constant Boolean :=
+ Num'Base'Object_Size <= 64
+ and then
+ ((Num'Small_Numerator = 1 and then Num'Small_Denominator <= 2**63)
+ or else
+ (Num'Small_Denominator = 1 and then Num'Small_Numerator <= 2**63)
+ or else
+ (Num'Small_Numerator < Num'Small_Denominator
+ and then Num'Small_Denominator <= 2**59)
+ or else
+ (Num'Small_Denominator < Num'Small_Numerator
+ and then Num'Small_Numerator <= 2**53));
+ -- These conditions are derived from the prerequisites of System.Image_F
+
+ OK_Get_128 : constant Boolean :=
+ Num'Base'Object_Size <= 128
+ and then
+ ((Num'Small_Numerator = 1 and then Num'Small_Denominator <= 2**127)
+ or else
+ (Num'Small_Denominator = 1 and then Num'Small_Numerator <= 2**127)
+ or else
+ (Num'Small_Numerator <= 2**123
+ and then Num'Small_Denominator <= 2**123));
+ -- These conditions are derived from the prerequisites of System.Value_F
+
+ OK_Put_128 : constant Boolean :=
+ Num'Base'Object_Size <= 128
+ and then
+ ((Num'Small_Numerator = 1 and then Num'Small_Denominator <= 2**127)
+ or else
+ (Num'Small_Denominator = 1 and then Num'Small_Numerator <= 2**127)
+ or else
+ (Num'Small_Numerator < Num'Small_Denominator
+ and then Num'Small_Denominator <= 2**123)
+ or else
+ (Num'Small_Denominator < Num'Small_Numerator
+ and then Num'Small_Numerator <= 2**122));
+ -- These conditions are derived from the prerequisites of System.Image_F
+
+ E : constant Natural :=
+ 127 - 64 * Boolean'Pos (OK_Put_64) - 32 * Boolean'Pos (OK_Put_32);
+ -- T'Size - 1 for the selected Int{32,64,128}
+
+ F0 : constant Natural := 0;
+ F1 : constant Natural :=
+ F0 + 38 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F0) >= 1.0E+38);
+ F2 : constant Natural :=
+ F1 + 19 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F1) >= 1.0E+19);
+ F3 : constant Natural :=
+ F2 + 9 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F2) >= 1.0E+9);
+ F4 : constant Natural :=
+ F3 + 5 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F3) >= 1.0E+5);
+ F5 : constant Natural :=
+ F4 + 3 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F4) >= 1.0E+3);
+ F6 : constant Natural :=
+ F5 + 2 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F5) >= 1.0E+2);
+ F7 : constant Natural :=
+ F6 + 1 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F6) >= 1.0E+1);
+ -- Binary search for the number of digits - 1 before the decimal point of
+ -- the product 2.0**E * Num'Small.
+
+ For0 : constant Natural := 2 + F7;
+ -- Fore value for the fixed point type whose mantissa is Int{32,64,128} and
+ -- whose small is Num'Small.
+
+ ---------
+ -- Get --
+ ---------
+
+ procedure Get
+ (File : File_Type;
+ Item : out Num;
+ Width : Field := 0)
+ is
+ pragma Unsuppress (Range_Check);
+
+ begin
+ if OK_Get_32 then
+ Item := Num'Fixed_Value
+ (Aux32.Get (File, Width,
+ -Num'Small_Numerator,
+ -Num'Small_Denominator));
+ elsif OK_Get_64 then
+ Item := Num'Fixed_Value
+ (Aux64.Get (File, Width,
+ -Num'Small_Numerator,
+ -Num'Small_Denominator));
+ elsif OK_Get_128 then
+ Item := Num'Fixed_Value
+ (Aux128.Get (File, Width,
+ -Num'Small_Numerator,
+ -Num'Small_Denominator));
+ else
+ Aux_Long_Long_Float.Get (File, Long_Long_Float (Item), Width);
+ end if;
+
+ exception
+ when Constraint_Error => raise Data_Error;
+ end Get;
+
+ procedure Get
+ (Item : out Num;
+ Width : Field := 0)
+ is
+ begin
+ Get (Current_In, Item, Width);
+ end Get;
+
+ procedure Get
+ (From : Wide_Wide_String;
+ Item : out Num;
+ Last : out Positive)
+ is
+ pragma Unsuppress (Range_Check);
+
+ S : constant String := Wide_Wide_String_To_String (From, WCEM_Upper);
+ -- String on which we do the actual conversion. Note that the method
+ -- used for wide character encoding is irrelevant, since if there is
+ -- a character outside the Standard.Character range then the call to
+ -- Aux.Gets will raise Data_Error in any case.
+
+ begin
+ if OK_Get_32 then
+ Item := Num'Fixed_Value
+ (Aux32.Gets (S, Last,
+ -Num'Small_Numerator,
+ -Num'Small_Denominator));
+ elsif OK_Get_64 then
+ Item := Num'Fixed_Value
+ (Aux64.Gets (S, Last,
+ -Num'Small_Numerator,
+ -Num'Small_Denominator));
+ elsif OK_Get_128 then
+ Item := Num'Fixed_Value
+ (Aux128.Gets (S, Last,
+ -Num'Small_Numerator,
+ -Num'Small_Denominator));
+ else
+ Aux_Long_Long_Float.Gets (S, Long_Long_Float (Item), Last);
+ end if;
+
+ exception
+ when Constraint_Error => raise Data_Error;
+ end Get;
+
+ ---------
+ -- Put --
+ ---------
+
+ procedure Put
+ (File : File_Type;
+ Item : Num;
+ Fore : Field := Default_Fore;
+ Aft : Field := Default_Aft;
+ Exp : Field := Default_Exp)
+ is
+ begin
+ if OK_Put_32 then
+ Aux32.Put (File, Int32'Integer_Value (Item), Fore, Aft, Exp,
+ -Num'Small_Numerator, -Num'Small_Denominator,
+ For0, Num'Aft);
+ elsif OK_Put_64 then
+ Aux64.Put (File, Int64'Integer_Value (Item), Fore, Aft, Exp,
+ -Num'Small_Numerator, -Num'Small_Denominator,
+ For0, Num'Aft);
+ elsif OK_Put_128 then
+ Aux128.Put (File, Int128'Integer_Value (Item), Fore, Aft, Exp,
+ -Num'Small_Numerator, -Num'Small_Denominator,
+ For0, Num'Aft);
+ else
+ Aux_Long_Long_Float.Put
+ (File, Long_Long_Float (Item), Fore, Aft, Exp);
+ end if;
+ end Put;
+
+ procedure Put
+ (Item : Num;
+ Fore : Field := Default_Fore;
+ Aft : Field := Default_Aft;
+ Exp : Field := Default_Exp)
+ is
+ begin
+ Put (Current_Out, Item, Fore, Aft, Exp);
+ end Put;
+
+ procedure Put
+ (To : out Wide_Wide_String;
+ Item : Num;
+ Aft : Field := Default_Aft;
+ Exp : Field := Default_Exp)
+ is
+ S : String (To'First .. To'Last);
+
+ begin
+ if OK_Put_32 then
+ Aux32.Puts (S, Int32'Integer_Value (Item), Aft, Exp,
+ -Num'Small_Numerator, -Num'Small_Denominator,
+ For0, Num'Aft);
+ elsif OK_Put_64 then
+ Aux64.Puts (S, Int64'Integer_Value (Item), Aft, Exp,
+ -Num'Small_Numerator, -Num'Small_Denominator,
+ For0, Num'Aft);
+ elsif OK_Put_128 then
+ Aux128.Puts (S, Int128'Integer_Value (Item), Aft, Exp,
+ -Num'Small_Numerator, -Num'Small_Denominator,
+ For0, Num'Aft);
+ else
+ Aux_Long_Long_Float.Puts (S, Long_Long_Float (Item), Aft, Exp);
+ end if;
+
+ for J in S'Range loop
+ To (J) := Wide_Wide_Character'Val (Character'Pos (S (J)));
+ end loop;
+ end Put;
+
+end Ada.Wide_Wide_Text_IO.Fixed_IO;
diff --git a/gcc/ada/libgnat/a-ztflau.adb b/gcc/ada/libgnat/a-ztflau.adb
index c0c55ba..1bddcd8 100644
--- a/gcc/ada/libgnat/a-ztflau.adb
+++ b/gcc/ada/libgnat/a-ztflau.adb
@@ -31,8 +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.Val_Real; use System.Val_Real;
+with System.Img_Real; use System.Img_Real;
package body Ada.Wide_Wide_Text_IO.Float_Aux is
@@ -42,12 +41,12 @@ package body Ada.Wide_Wide_Text_IO.Float_Aux is
procedure Get
(File : File_Type;
- Item : out Long_Long_Float;
+ Item : out Num;
Width : Field)
is
Buf : String (1 .. Field'Last);
Stop : Integer := 0;
- Ptr : aliased Integer := 1;
+ Ptr : aliased Integer;
begin
if Width /= 0 then
@@ -55,10 +54,10 @@ package body Ada.Wide_Wide_Text_IO.Float_Aux is
String_Skip (Buf, Ptr);
else
Load_Real (File, Buf, Stop);
+ Ptr := 1;
end if;
- Item := Scan_Real (Buf, Ptr'Access, Stop);
-
+ Item := Scan (Buf, Ptr'Access, Stop);
Check_End_Of_Field (Buf, Stop, Ptr, Width);
end Get;
@@ -68,137 +67,36 @@ package body Ada.Wide_Wide_Text_IO.Float_Aux is
procedure Gets
(From : String;
- Item : out Long_Long_Float;
+ Item : out Num;
Last : out Positive)
is
Pos : aliased Integer;
begin
String_Skip (From, Pos);
- Item := Scan_Real (From, Pos'Access, From'Last);
+ Item := Scan (From, Pos'Access, From'Last);
Last := Pos - 1;
exception
- when Constraint_Error =>
- raise Data_Error;
+ when Constraint_Error => raise Data_Error;
end Gets;
- ---------------
- -- Load_Real --
- ---------------
-
- procedure Load_Real
- (File : File_Type;
- Buf : out String;
- Ptr : in out Natural)
- is
- Loaded : Boolean;
-
- begin
- -- Skip initial blanks and load possible sign
-
- Load_Skip (File);
- Load (File, Buf, Ptr, '+', '-');
-
- -- Case of .nnnn
-
- Load (File, Buf, Ptr, '.', Loaded);
-
- if Loaded then
- Load_Digits (File, Buf, Ptr, Loaded);
-
- -- Hopeless junk if no digits loaded
-
- if not Loaded then
- return;
- end if;
-
- -- Otherwise must have digits to start
-
- else
- Load_Digits (File, Buf, Ptr, Loaded);
-
- -- Hopeless junk if no digits loaded
-
- if not Loaded then
- return;
- end if;
-
- -- Deal with based case. We recognize either the standard '#' or the
- -- allowed alternative replacement ':' (see RM J.2(3)).
-
- Load (File, Buf, Ptr, '#', ':', Loaded);
-
- if Loaded then
-
- -- Case of nnn#.xxx#
-
- Load (File, Buf, Ptr, '.', Loaded);
-
- if Loaded then
- Load_Extended_Digits (File, Buf, Ptr);
- Load (File, Buf, Ptr, '#', ':');
-
- -- Case of nnn#xxx.[xxx]# or nnn#xxx#
-
- else
- Load_Extended_Digits (File, Buf, Ptr);
- Load (File, Buf, Ptr, '.', Loaded);
-
- if Loaded then
- Load_Extended_Digits (File, Buf, Ptr);
- end if;
-
- -- As usual, it seems strange to allow mixed base characters,
- -- but that is what ACVC tests expect, see CE3804M, case (3).
-
- Load (File, Buf, Ptr, '#', ':');
- end if;
-
- -- Case of nnn.[nnn] or nnn
-
- else
- -- Prevent the potential processing of '.' in cases where the
- -- initial digits have a trailing underscore.
-
- if Buf (Ptr) = '_' then
- return;
- end if;
-
- Load (File, Buf, Ptr, '.', Loaded);
-
- if Loaded then
- Load_Digits (File, Buf, Ptr);
- end if;
- end if;
- end if;
-
- -- Deal with exponent
-
- Load (File, Buf, Ptr, 'E', 'e', Loaded);
-
- if Loaded then
- Load (File, Buf, Ptr, '+', '-');
- Load_Digits (File, Buf, Ptr);
- end if;
- end Load_Real;
-
---------
-- Put --
---------
procedure Put
(File : File_Type;
- Item : Long_Long_Float;
+ Item : Num;
Fore : Field;
Aft : Field;
Exp : Field)
is
- Buf : String (1 .. Field'Last);
+ Buf : String (1 .. Max_Real_Image_Length);
Ptr : Natural := 0;
begin
- Set_Image_Real (Item, Buf, Ptr, Fore, Aft, Exp);
+ Set_Image_Real (Long_Long_Float (Item), Buf, Ptr, Fore, Aft, Exp);
Put_Item (File, Buf (1 .. Ptr));
end Put;
@@ -208,15 +106,16 @@ package body Ada.Wide_Wide_Text_IO.Float_Aux is
procedure Puts
(To : out String;
- Item : Long_Long_Float;
+ Item : Num;
Aft : Field;
Exp : Field)
is
- Buf : String (1 .. Field'Last);
- Ptr : Natural := 0;
+ Buf : String (1 .. Max_Real_Image_Length);
+ Ptr : Natural := 0;
begin
- Set_Image_Real (Item, Buf, Ptr, Fore => 1, Aft => Aft, Exp => Exp);
+ Set_Image_Real
+ (Long_Long_Float (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 dc24682..48fba82 100644
--- a/gcc/ada/libgnat/a-ztflau.ads
+++ b/gcc/ada/libgnat/a-ztflau.ads
@@ -31,41 +31,42 @@
-- This package contains the routines for Ada.Wide_Wide_Text_IO.Float_IO that
-- are shared among separate instantiations of this package. The routines
--- in this package are identical semantically to those in Float_IO itself,
--- except that generic parameter Num has been replaced by Long_Long_Float,
--- and the default parameters have been removed because they are supplied
+-- in this package are identical semantically to those in Float_IO, except
+-- that the default parameters have been removed because they are supplied
-- explicitly by the calls from within the generic template. Also used by
--- Ada.Wide_Wide_Text_IO.Fixed_IO, and by Ada.Wide_Wide_Text_IO.Decimal_IO.
+-- Ada.Wide_Wide_Text_IO.Fixed_IO and by Ada.Wide_Wide_Text_IO.Decimal_IO.
-private package Ada.Wide_Wide_Text_IO.Float_Aux is
+private generic
- procedure Load_Real
- (File : File_Type;
- Buf : out String;
- Ptr : in out Natural);
- -- This is an auxiliary routine that is used to load a possibly signed
- -- real literal value from the input file into Buf, starting at Ptr + 1.
+ type Num is digits <>;
+
+ with function Scan
+ (Str : String;
+ Ptr : not null access Integer;
+ Max : Integer) return Num;
+
+package Ada.Wide_Wide_Text_IO.Float_Aux is
procedure Get
(File : File_Type;
- Item : out Long_Long_Float;
+ Item : out Num;
Width : Field);
- procedure Gets
- (From : String;
- Item : out Long_Long_Float;
- Last : out Positive);
-
procedure Put
(File : File_Type;
- Item : Long_Long_Float;
+ Item : Num;
Fore : Field;
Aft : Field;
Exp : Field);
+ procedure Gets
+ (From : String;
+ Item : out Num;
+ Last : out Positive);
+
procedure Puts
(To : out String;
- Item : Long_Long_Float;
+ Item : Num;
Aft : Field;
Exp : Field);
diff --git a/gcc/ada/libgnat/a-ztflio.adb b/gcc/ada/libgnat/a-ztflio.adb
index fd6bf52..e491e62 100644
--- a/gcc/ada/libgnat/a-ztflio.adb
+++ b/gcc/ada/libgnat/a-ztflio.adb
@@ -30,15 +30,31 @@
------------------------------------------------------------------------------
with Ada.Wide_Wide_Text_IO.Float_Aux;
-with System.WCh_Con; use System.WCh_Con;
-with System.WCh_WtS; use System.WCh_WtS;
+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;
package body Ada.Wide_Wide_Text_IO.Float_IO is
- subtype TFT is Ada.Wide_Wide_Text_IO.File_Type;
- -- File type required for calls to routines in Aux
+ package Aux_Float is new
+ Ada.Wide_Wide_Text_IO.Float_Aux (Float, Scan_Float);
- package Aux renames Ada.Wide_Wide_Text_IO.Float_Aux;
+ package Aux_Long_Float is new
+ Ada.Wide_Wide_Text_IO.Float_Aux (Long_Float, Scan_Long_Float);
+
+ package Aux_Long_Long_Float is new
+ Ada.Wide_Wide_Text_IO.Float_Aux (Long_Long_Float, Scan_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
+ -- is needed. These boolean constants are used to test for this, such that
+ -- only code for the relevant case is included in the instance.
+
+ OK_Float : constant Boolean := Num'Base'Digits <= Float'Digits;
+
+ OK_Long_Float : constant Boolean := Num'Base'Digits <= Long_Float'Digits;
---------
-- Get --
@@ -49,8 +65,25 @@ package body Ada.Wide_Wide_Text_IO.Float_IO is
Item : out Num;
Width : Field := 0)
is
+ pragma Unsuppress (Range_Check);
+
begin
- Aux.Get (TFT (File), Long_Long_Float (Item), Width);
+ if OK_Float then
+ Aux_Float.Get (File, Float (Item), Width);
+ elsif OK_Long_Float then
+ Aux_Long_Float.Get (File, Long_Float (Item), Width);
+ else
+ Aux_Long_Long_Float.Get (File, Long_Long_Float (Item), Width);
+ end if;
+
+ -- In the case where the type is unconstrained (e.g. Standard'Float),
+ -- the above conversion may result in an infinite value, which is
+ -- normally fine for a conversion, but in this case, we want to treat
+ -- that as a data error.
+
+ if not Item'Valid then
+ raise Data_Error;
+ end if;
exception
when Constraint_Error => raise Data_Error;
@@ -61,7 +94,7 @@ package body Ada.Wide_Wide_Text_IO.Float_IO is
Width : Field := 0)
is
begin
- Get (Current_Input, Item, Width);
+ Get (Current_In, Item, Width);
end Get;
procedure Get
@@ -69,6 +102,8 @@ package body Ada.Wide_Wide_Text_IO.Float_IO is
Item : out Num;
Last : out Positive)
is
+ pragma Unsuppress (Range_Check);
+
S : constant String := Wide_Wide_String_To_String (From, WCEM_Upper);
-- String on which we do the actual conversion. Note that the method
-- used for wide character encoding is irrelevant, since if there is
@@ -76,7 +111,22 @@ package body Ada.Wide_Wide_Text_IO.Float_IO is
-- Aux.Gets will raise Data_Error in any case.
begin
- Aux.Gets (S, Long_Long_Float (Item), Last);
+ if OK_Float then
+ Aux_Float.Gets (S, Float (Item), Last);
+ elsif OK_Long_Float then
+ Aux_Long_Float.Gets (S, Long_Float (Item), Last);
+ else
+ Aux_Long_Long_Float.Gets (S, Long_Long_Float (Item), Last);
+ end if;
+
+ -- In the case where the type is unconstrained (e.g. Standard'Float),
+ -- the above conversion may result in an infinite value, which is
+ -- normally fine for a conversion, but in this case, we want to treat
+ -- that as a data error.
+
+ if not Item'Valid then
+ raise Data_Error;
+ end if;
exception
when Constraint_Error => raise Data_Error;
@@ -94,7 +144,14 @@ package body Ada.Wide_Wide_Text_IO.Float_IO is
Exp : Field := Default_Exp)
is
begin
- Aux.Put (TFT (File), Long_Long_Float (Item), Fore, Aft, Exp);
+ if OK_Float then
+ Aux_Float.Put (File, Float (Item), Fore, Aft, Exp);
+ elsif OK_Long_Float then
+ Aux_Long_Float.Put (File, Long_Float (Item), Fore, Aft, Exp);
+ else
+ Aux_Long_Long_Float.Put
+ (File, Long_Long_Float (Item), Fore, Aft, Exp);
+ end if;
end Put;
procedure Put
@@ -104,7 +161,7 @@ package body Ada.Wide_Wide_Text_IO.Float_IO is
Exp : Field := Default_Exp)
is
begin
- Put (Current_Output, Item, Fore, Aft, Exp);
+ Put (Current_Out, Item, Fore, Aft, Exp);
end Put;
procedure Put
@@ -116,7 +173,13 @@ package body Ada.Wide_Wide_Text_IO.Float_IO is
S : String (To'First .. To'Last);
begin
- Aux.Puts (S, Long_Long_Float (Item), Aft, Exp);
+ if OK_Float then
+ Aux_Float.Puts (S, Float (Item), Aft, Exp);
+ elsif OK_Long_Float then
+ Aux_Long_Float.Puts (S, Long_Float (Item), Aft, Exp);
+ else
+ Aux_Long_Long_Float.Puts (S, Long_Long_Float (Item), Aft, Exp);
+ end if;
for J in S'Range loop
To (J) := Wide_Wide_Character'Val (Character'Pos (S (J)));
diff --git a/gcc/ada/libgnat/a-ztgeau.adb b/gcc/ada/libgnat/a-ztgeau.adb
index be7aecc..6b5e4c5 100644
--- a/gcc/ada/libgnat/a-ztgeau.adb
+++ b/gcc/ada/libgnat/a-ztgeau.adb
@@ -403,6 +403,106 @@ package body Ada.Wide_Wide_Text_IO.Generic_Aux is
end Load_Integer;
---------------
+ -- Load_Real --
+ ---------------
+
+ procedure Load_Real
+ (File : File_Type;
+ Buf : out String;
+ Ptr : in out Natural)
+ is
+ Loaded : Boolean;
+
+ begin
+ -- Skip initial blanks and load possible sign
+
+ Load_Skip (File);
+ Load (File, Buf, Ptr, '+', '-');
+
+ -- Case of .nnnn
+
+ Load (File, Buf, Ptr, '.', Loaded);
+
+ if Loaded then
+ Load_Digits (File, Buf, Ptr, Loaded);
+
+ -- Hopeless junk if no digits loaded
+
+ if not Loaded then
+ return;
+ end if;
+
+ -- Otherwise must have digits to start
+
+ else
+ Load_Digits (File, Buf, Ptr, Loaded);
+
+ -- Hopeless junk if no digits loaded
+
+ if not Loaded then
+ return;
+ end if;
+
+ -- Deal with based case. We recognize either the standard '#' or the
+ -- allowed alternative replacement ':' (see RM J.2(3)).
+
+ Load (File, Buf, Ptr, '#', ':', Loaded);
+
+ if Loaded then
+
+ -- Case of nnn#.xxx#
+
+ Load (File, Buf, Ptr, '.', Loaded);
+
+ if Loaded then
+ Load_Extended_Digits (File, Buf, Ptr);
+ Load (File, Buf, Ptr, '#', ':');
+
+ -- Case of nnn#xxx.[xxx]# or nnn#xxx#
+
+ else
+ Load_Extended_Digits (File, Buf, Ptr);
+ Load (File, Buf, Ptr, '.', Loaded);
+
+ if Loaded then
+ Load_Extended_Digits (File, Buf, Ptr);
+ end if;
+
+ -- As usual, it seems strange to allow mixed base characters,
+ -- but that is what ACVC tests expect, see CE3804M, case (3).
+
+ Load (File, Buf, Ptr, '#', ':');
+ end if;
+
+ -- Case of nnn.[nnn] or nnn
+
+ else
+ -- Prevent the potential processing of '.' in cases where the
+ -- initial digits have a trailing underscore.
+
+ if Buf (Ptr) = '_' then
+ return;
+ end if;
+
+ Load (File, Buf, Ptr, '.', Loaded);
+
+ if Loaded then
+ Load_Digits (File, Buf, Ptr);
+ end if;
+ end if;
+ end if;
+
+ -- Deal with exponent
+
+ Load (File, Buf, Ptr, 'E', 'e', Loaded);
+
+ if Loaded then
+ Load (File, Buf, Ptr, '+', '-');
+ Load_Digits (File, Buf, Ptr);
+ end if;
+ end Load_Real;
+
+ ---------------
-- Load_Skip --
---------------
diff --git a/gcc/ada/libgnat/a-ztgeau.ads b/gcc/ada/libgnat/a-ztgeau.ads
index 68d4a33..6b80ed4 100644
--- a/gcc/ada/libgnat/a-ztgeau.ads
+++ b/gcc/ada/libgnat/a-ztgeau.ads
@@ -155,6 +155,12 @@ package Ada.Wide_Wide_Text_IO.Generic_Aux is
Ptr : in out Natural);
-- Loads a possibly signed integer literal value
+ procedure Load_Real
+ (File : File_Type;
+ Buf : out String;
+ Ptr : in out Natural);
+ -- Loads a possibly signed real literal value
+
procedure Put_Item (File : File_Type; Str : String);
-- This routine is like Wide_Wide_Text_IO.Put, except that it checks for
-- overflow of bounded lines, as described in (RM A.10.6(8)). It is used
diff --git a/gcc/ada/libgnat/a-ztinio.adb b/gcc/ada/libgnat/a-ztinio.adb
index ab8741e..c19c8a6 100644
--- a/gcc/ada/libgnat/a-ztinio.adb
+++ b/gcc/ada/libgnat/a-ztinio.adb
@@ -65,9 +65,6 @@ package body Ada.Wide_Wide_Text_IO.Integer_IO is
-- Boolean is used to test for these cases and since it is a constant, only
-- code for the relevant case will be included in the instance.
- subtype TFT is Ada.Wide_Wide_Text_IO.File_Type;
- -- File type required for calls to routines in Aux
-
---------
-- Get --
---------
@@ -84,9 +81,9 @@ package body Ada.Wide_Wide_Text_IO.Integer_IO is
begin
if Need_LLI then
- Aux_LLI.Get (TFT (File), Long_Long_Integer (Item), Width);
+ Aux_LLI.Get (File, Long_Long_Integer (Item), Width);
else
- Aux_Int.Get (TFT (File), Integer (Item), Width);
+ Aux_Int.Get (File, Integer (Item), Width);
end if;
exception
@@ -98,7 +95,7 @@ package body Ada.Wide_Wide_Text_IO.Integer_IO is
Width : Field := 0)
is
begin
- Get (Current_Input, Item, Width);
+ Get (Current_In, Item, Width);
end Get;
procedure Get
@@ -140,9 +137,9 @@ package body Ada.Wide_Wide_Text_IO.Integer_IO is
is
begin
if Need_LLI then
- Aux_LLI.Put (TFT (File), Long_Long_Integer (Item), Width, Base);
+ Aux_LLI.Put (File, Long_Long_Integer (Item), Width, Base);
else
- Aux_Int.Put (TFT (File), Integer (Item), Width, Base);
+ Aux_Int.Put (File, Integer (Item), Width, Base);
end if;
end Put;
@@ -152,7 +149,7 @@ package body Ada.Wide_Wide_Text_IO.Integer_IO is
Base : Number_Base := Default_Base)
is
begin
- Put (Current_Output, Item, Width, Base);
+ Put (Current_Out, Item, Width, Base);
end Put;
procedure Put
diff --git a/gcc/ada/libgnat/a-ztinio__128.adb b/gcc/ada/libgnat/a-ztinio__128.adb
index c809eeb..19dcc34 100644
--- a/gcc/ada/libgnat/a-ztinio__128.adb
+++ b/gcc/ada/libgnat/a-ztinio__128.adb
@@ -79,9 +79,6 @@ package body Ada.Wide_Wide_Text_IO.Integer_IO is
-- are used to test for these cases and since they are constant, only code
-- for the relevant case will be included in the instance.
- subtype TFT is Ada.Wide_Wide_Text_IO.File_Type;
- -- File type required for calls to routines in Aux
-
---------
-- Get --
---------
@@ -98,11 +95,11 @@ package body Ada.Wide_Wide_Text_IO.Integer_IO is
begin
if Need_LLLI then
- Aux_LLLI.Get (TFT (File), Long_Long_Long_Integer (Item), Width);
+ Aux_LLLI.Get (File, Long_Long_Long_Integer (Item), Width);
elsif Need_LLI then
- Aux_LLI.Get (TFT (File), Long_Long_Integer (Item), Width);
+ Aux_LLI.Get (File, Long_Long_Integer (Item), Width);
else
- Aux_Int.Get (TFT (File), Integer (Item), Width);
+ Aux_Int.Get (File, Integer (Item), Width);
end if;
exception
@@ -114,7 +111,7 @@ package body Ada.Wide_Wide_Text_IO.Integer_IO is
Width : Field := 0)
is
begin
- Get (Current_Input, Item, Width);
+ Get (Current_In, Item, Width);
end Get;
procedure Get
@@ -158,11 +155,11 @@ package body Ada.Wide_Wide_Text_IO.Integer_IO is
is
begin
if Need_LLLI then
- Aux_LLLI.Put (TFT (File), Long_Long_Long_Integer (Item), Width, Base);
+ Aux_LLLI.Put (File, Long_Long_Long_Integer (Item), Width, Base);
elsif Need_LLI then
- Aux_LLI.Put (TFT (File), Long_Long_Integer (Item), Width, Base);
+ Aux_LLI.Put (File, Long_Long_Integer (Item), Width, Base);
else
- Aux_Int.Put (TFT (File), Integer (Item), Width, Base);
+ Aux_Int.Put (File, Integer (Item), Width, Base);
end if;
end Put;
@@ -172,7 +169,7 @@ package body Ada.Wide_Wide_Text_IO.Integer_IO is
Base : Number_Base := Default_Base)
is
begin
- Put (Current_Output, Item, Width, Base);
+ Put (Current_Out, Item, Width, Base);
end Put;
procedure Put
diff --git a/gcc/ada/libgnat/a-ztmoio.adb b/gcc/ada/libgnat/a-ztmoio.adb
index d2f81e2..ba854ff 100644
--- a/gcc/ada/libgnat/a-ztmoio.adb
+++ b/gcc/ada/libgnat/a-ztmoio.adb
@@ -65,9 +65,6 @@ package body Ada.Wide_Wide_Text_IO.Modular_IO is
-- Boolean is used to test for these cases and since it is a constant, only
-- code for the relevant case will be included in the instance.
- subtype TFT is Ada.Wide_Wide_Text_IO.File_Type;
- -- File type required for calls to routines in Aux
-
---------
-- Get --
---------
@@ -83,9 +80,9 @@ package body Ada.Wide_Wide_Text_IO.Modular_IO is
begin
if Need_LLU then
- Aux_LLU.Get (TFT (File), Long_Long_Unsigned (Item), Width);
+ Aux_LLU.Get (File, Long_Long_Unsigned (Item), Width);
else
- Aux_Uns.Get (TFT (File), Unsigned (Item), Width);
+ Aux_Uns.Get (File, Unsigned (Item), Width);
end if;
exception
@@ -97,7 +94,7 @@ package body Ada.Wide_Wide_Text_IO.Modular_IO is
Width : Field := 0)
is
begin
- Get (Current_Input, Item, Width);
+ Get (Current_In, Item, Width);
end Get;
procedure Get
@@ -138,9 +135,9 @@ package body Ada.Wide_Wide_Text_IO.Modular_IO is
is
begin
if Need_LLU then
- Aux_LLU.Put (TFT (File), Long_Long_Unsigned (Item), Width, Base);
+ Aux_LLU.Put (File, Long_Long_Unsigned (Item), Width, Base);
else
- Aux_Uns.Put (TFT (File), Unsigned (Item), Width, Base);
+ Aux_Uns.Put (File, Unsigned (Item), Width, Base);
end if;
end Put;
@@ -150,7 +147,7 @@ package body Ada.Wide_Wide_Text_IO.Modular_IO is
Base : Number_Base := Default_Base)
is
begin
- Put (Current_Output, Item, Width, Base);
+ Put (Current_Out, Item, Width, Base);
end Put;
procedure Put
diff --git a/gcc/ada/libgnat/a-ztmoio__128.adb b/gcc/ada/libgnat/a-ztmoio__128.adb
index e6e11de..2101508 100644
--- a/gcc/ada/libgnat/a-ztmoio__128.adb
+++ b/gcc/ada/libgnat/a-ztmoio__128.adb
@@ -79,9 +79,6 @@ package body Ada.Wide_Wide_Text_IO.Modular_IO is
-- are used to test for these cases and since they are constant, only code
-- for the relevant case will be included in the instance.
- subtype TFT is Ada.Wide_Wide_Text_IO.File_Type;
- -- File type required for calls to routines in Aux
-
---------
-- Get --
---------
@@ -99,9 +96,9 @@ package body Ada.Wide_Wide_Text_IO.Modular_IO is
if Need_LLLU then
Aux_LLLU.Get (File, Long_Long_Long_Unsigned (Item), Width);
elsif Need_LLU then
- Aux_LLU.Get (TFT (File), Long_Long_Unsigned (Item), Width);
+ Aux_LLU.Get (File, Long_Long_Unsigned (Item), Width);
else
- Aux_Uns.Get (TFT (File), Unsigned (Item), Width);
+ Aux_Uns.Get (File, Unsigned (Item), Width);
end if;
exception
@@ -113,7 +110,7 @@ package body Ada.Wide_Wide_Text_IO.Modular_IO is
Width : Field := 0)
is
begin
- Get (Current_Input, Item, Width);
+ Get (Current_In, Item, Width);
end Get;
procedure Get
@@ -158,9 +155,9 @@ package body Ada.Wide_Wide_Text_IO.Modular_IO is
if Need_LLLU then
Aux_LLLU.Put (File, Long_Long_Long_Unsigned (Item), Width, Base);
elsif Need_LLU then
- Aux_LLU.Put (TFT (File), Long_Long_Unsigned (Item), Width, Base);
+ Aux_LLU.Put (File, Long_Long_Unsigned (Item), Width, Base);
else
- Aux_Uns.Put (TFT (File), Unsigned (Item), Width, Base);
+ Aux_Uns.Put (File, Unsigned (Item), Width, Base);
end if;
end Put;
@@ -170,7 +167,7 @@ package body Ada.Wide_Wide_Text_IO.Modular_IO is
Base : Number_Base := Default_Base)
is
begin
- Put (Current_Output, Item, Width, Base);
+ Put (Current_Out, Item, Width, Base);
end Put;
procedure Put
diff --git a/gcc/ada/libgnat/g-diopit.adb b/gcc/ada/libgnat/g-diopit.adb
index 50bbf9b..1e8627e 100644
--- a/gcc/ada/libgnat/g-diopit.adb
+++ b/gcc/ada/libgnat/g-diopit.adb
@@ -32,6 +32,7 @@
with Ada.Characters.Handling;
with Ada.Strings.Fixed;
with Ada.Strings.Maps;
+
with GNAT.OS_Lib;
with GNAT.Regexp;
@@ -49,7 +50,7 @@ package body GNAT.Directory_Operations.Iteration is
is
File_Regexp : constant Regexp.Regexp := Regexp.Compile (File_Pattern);
Index : Natural := 0;
- Quit : Boolean;
+ Quit : Boolean := False;
procedure Read_Directory (Directory : Dir_Name_Str);
-- Open Directory and read all entries. This routine is called
@@ -113,6 +114,7 @@ package body GNAT.Directory_Operations.Iteration is
if not (Dir_Entry = "." or else Dir_Entry = "..")
and then OS_Lib.Is_Directory (Pathname)
+ and then not OS_Lib.Is_Symbolic_Link (Pathname)
then
Read_Directory (Pathname);
exit when Quit;
@@ -124,7 +126,6 @@ package body GNAT.Directory_Operations.Iteration is
end Read_Directory;
begin
- Quit := False;
Read_Directory (Root_Directory);
end Find;
diff --git a/gcc/ada/libgnat/g-diopit.ads b/gcc/ada/libgnat/g-diopit.ads
index aa60d32..952d795 100644
--- a/gcc/ada/libgnat/g-diopit.ads
+++ b/gcc/ada/libgnat/g-diopit.ads
@@ -50,6 +50,8 @@ package GNAT.Directory_Operations.Iteration is
-- will pass in the value False on each call to Action. The iterator will
-- terminate after passing the last matched path to Action or after
-- returning from a call to Action which sets Quit to True.
+ -- The iterator does not follow symbolic links avoiding possible
+ -- circularities or exploring unrelated directories.
-- Raises GNAT.Regexp.Error_In_Regexp if File_Pattern is ill formed.
generic
diff --git a/gcc/ada/libgnat/g-expect.adb b/gcc/ada/libgnat/g-expect.adb
index 78b3c27..0f9d0b9 100644
--- a/gcc/ada/libgnat/g-expect.adb
+++ b/gcc/ada/libgnat/g-expect.adb
@@ -1181,6 +1181,12 @@ package body GNAT.Expect is
Set_Up_Child_Communications
(Descriptor, Pipe1, Pipe2, Pipe3, Command_With_Path.all,
C_Arg_List'Address);
+
+ -- On Windows systems we need to release memory taken for Arg_List
+
+ for A of Arg_List loop
+ Free (A);
+ end loop;
end if;
Free (Command_With_Path);
diff --git a/gcc/ada/libgnat/g-rannum.adb b/gcc/ada/libgnat/g-rannum.adb
index b7ef7d1..9c6693b 100644
--- a/gcc/ada/libgnat/g-rannum.adb
+++ b/gcc/ada/libgnat/g-rannum.adb
@@ -58,6 +58,8 @@ is
new Ada.Unchecked_Conversion (Unsigned_32, Integer_32);
function To_Signed is
new Ada.Unchecked_Conversion (Unsigned_64, Integer_64);
+ function To_Signed is
+ new Ada.Unchecked_Conversion (Unsigned_128, Integer_128);
------------------
-- Insert_Image --
@@ -98,12 +100,37 @@ is
Min : Result_Subtype := Default_Min;
Max : Result_Subtype := Result_Subtype'Last) return Result_Subtype
is
- subtype IntV is Integer_64 range
- Integer_64'Integer_Value (Min) ..
- Integer_64'Integer_Value (Max);
- function R is new Random_Discrete (Integer_64, IntV'First);
begin
- return Result_Subtype'Fixed_Value (R (Gen, IntV'First, IntV'Last));
+ if Result_Subtype'Base'Size > 64 then
+ declare
+ subtype IntV is Integer_128 range
+ Integer_128'Integer_Value (Min) ..
+ Integer_128'Integer_Value (Max);
+ function R is new Random_Discrete (Integer_128, IntV'First);
+ begin
+ return Result_Subtype'Fixed_Value (R (Gen, IntV'First, IntV'Last));
+ end;
+
+ elsif Result_Subtype'Base'Size > 32 then
+ declare
+ subtype IntV is Integer_64 range
+ Integer_64'Integer_Value (Min) ..
+ Integer_64'Integer_Value (Max);
+ function R is new Random_Discrete (Integer_64, IntV'First);
+ begin
+ return Result_Subtype'Fixed_Value (R (Gen, IntV'First, IntV'Last));
+ end;
+
+ else
+ declare
+ subtype IntV is Integer_32 range
+ Integer_32'Integer_Value (Min) ..
+ Integer_32'Integer_Value (Max);
+ function R is new Random_Discrete (Integer_32, IntV'First);
+ begin
+ return Result_Subtype'Fixed_Value (R (Gen, IntV'First, IntV'Last));
+ end;
+ end if;
end Random_Decimal_Fixed;
---------------------------
@@ -115,12 +142,37 @@ is
Min : Result_Subtype := Default_Min;
Max : Result_Subtype := Result_Subtype'Last) return Result_Subtype
is
- subtype IntV is Integer_64 range
- Integer_64'Integer_Value (Min) ..
- Integer_64'Integer_Value (Max);
- function R is new Random_Discrete (Integer_64, IntV'First);
begin
- return Result_Subtype'Fixed_Value (R (Gen, IntV'First, IntV'Last));
+ if Result_Subtype'Base'Size > 64 then
+ declare
+ subtype IntV is Integer_128 range
+ Integer_128'Integer_Value (Min) ..
+ Integer_128'Integer_Value (Max);
+ function R is new Random_Discrete (Integer_128, IntV'First);
+ begin
+ return Result_Subtype'Fixed_Value (R (Gen, IntV'First, IntV'Last));
+ end;
+
+ elsif Result_Subtype'Base'Size > 32 then
+ declare
+ subtype IntV is Integer_64 range
+ Integer_64'Integer_Value (Min) ..
+ Integer_64'Integer_Value (Max);
+ function R is new Random_Discrete (Integer_64, IntV'First);
+ begin
+ return Result_Subtype'Fixed_Value (R (Gen, IntV'First, IntV'Last));
+ end;
+
+ else
+ declare
+ subtype IntV is Integer_32 range
+ Integer_32'Integer_Value (Min) ..
+ Integer_32'Integer_Value (Max);
+ function R is new Random_Discrete (Integer_32, IntV'First);
+ begin
+ return Result_Subtype'Fixed_Value (R (Gen, IntV'First, IntV'Last));
+ end;
+ end if;
end Random_Ordinary_Fixed;
------------
@@ -147,9 +199,9 @@ is
return Random (Gen.Rep);
end Random;
- function Random (Gen : Generator) return Integer_64 is
+ function Random (Gen : Generator) return Interfaces.Unsigned_128 is
begin
- return To_Signed (Unsigned_64'(Random (Gen)));
+ return Random (Gen.Rep);
end Random;
function Random (Gen : Generator) return Integer_32 is
@@ -157,6 +209,16 @@ is
return To_Signed (Unsigned_32'(Random (Gen)));
end Random;
+ function Random (Gen : Generator) return Integer_64 is
+ begin
+ return To_Signed (Unsigned_64'(Random (Gen)));
+ end Random;
+
+ function Random (Gen : Generator) return Integer_128 is
+ begin
+ return To_Signed (Unsigned_128'(Random (Gen)));
+ end Random;
+
function Random (Gen : Generator) return Long_Integer is
function Random_Long_Integer is new Random_Discrete (Long_Integer);
begin
diff --git a/gcc/ada/libgnat/g-rannum.ads b/gcc/ada/libgnat/g-rannum.ads
index 5b633ff..f795ae0 100644
--- a/gcc/ada/libgnat/g-rannum.ads
+++ b/gcc/ada/libgnat/g-rannum.ads
@@ -69,6 +69,8 @@ is
function Random (Gen : Generator) return Interfaces.Unsigned_32;
function Random (Gen : Generator) return Interfaces.Integer_64;
function Random (Gen : Generator) return Interfaces.Unsigned_64;
+ function Random (Gen : Generator) return Interfaces.Integer_128;
+ function Random (Gen : Generator) return Interfaces.Unsigned_128;
function Random (Gen : Generator) return Integer;
function Random (Gen : Generator) return Long_Integer;
-- Return pseudo-random numbers uniformly distributed on T'First .. T'Last
diff --git a/gcc/ada/libgnat/g-sercom__linux.adb b/gcc/ada/libgnat/g-sercom__linux.adb
index 7d93e57..f7212e8 100644
--- a/gcc/ada/libgnat/g-sercom__linux.adb
+++ b/gcc/ada/libgnat/g-sercom__linux.adb
@@ -30,15 +30,41 @@
------------------------------------------------------------------------------
-- This is the GNU/Linux implementation of this package
-
-with Ada.Streams; use Ada.Streams;
-with Ada; use Ada;
+--
+-- Testing on GNU/Linux can be done with socat & stty tools.
+--
+-- First in a terminal create a virtual serial port:
+--
+-- * First solution, the terminal is one of the side of the channel
+-- characters written with Write into the port will be displayed
+-- there and characters typed into the terminal will be send to the
+-- channel and will be received by a Read call.
+--
+-- $ socat PTY,link=/tmp/virtual-tty,raw,echo=1 -
+--
+-- * Second solution, the virtual channel contains two side and the
+-- program can Read and Write date to it.
+--
+-- $ socat PTY,link=/tmp/virtual-tty,raw,echo=1 \
+-- PTY,link=/tmp/virtual-tty,raw,echo=1
+--
+-- Connect to this virtual serial port with:
+--
+-- Open (Port => P, Name => "/tmp/virtual-tty");
+--
+-- Do any settings using the Set routine below, then you can check
+-- the serial port configuration with:
+--
+-- $ stty --file /tmp/virtual-tty
+--
+
+with Ada.Streams; use Ada.Streams;
with System; use System;
with System.Communication; use System.Communication;
with System.CRTL; use System.CRTL;
-with GNAT.OS_Lib; use GNAT.OS_Lib;
+with GNAT.OS_Lib; use GNAT.OS_Lib;
package body GNAT.Serial_Communications is
@@ -191,6 +217,8 @@ package body GNAT.Serial_Communications is
is
use OSC;
+ subtype speed_t is unsigned;
+
type termios is record
c_iflag : unsigned;
c_oflag : unsigned;
@@ -198,8 +226,8 @@ package body GNAT.Serial_Communications is
c_lflag : unsigned;
c_line : unsigned_char;
c_cc : Interfaces.C.char_array (0 .. 31);
- c_ispeed : unsigned;
- c_ospeed : unsigned;
+ c_ispeed : speed_t;
+ c_ospeed : speed_t;
end record;
pragma Convention (C, termios);
@@ -213,9 +241,15 @@ package body GNAT.Serial_Communications is
function tcflush (fd : int; queue_selector : int) return int;
pragma Import (C, tcflush, "tcflush");
+ function cfsetospeed (termios_p : Address; speed : speed_t) return int;
+ pragma Import (C, cfsetospeed, "cfsetospeed");
+
+ function cfsetispeed (termios_p : Address; speed : speed_t) return int;
+ pragma Import (C, cfsetispeed, "cfsetispeed");
+
Current : termios;
- Res : int;
+ Res : int := 0;
pragma Warnings (Off, Res);
-- Warnings off, since we don't always test the result
@@ -230,11 +264,11 @@ package body GNAT.Serial_Communications is
-- Change settings now
- Current.c_cflag := C_Data_Rate (Rate)
- or C_Bits (Bits)
+ Current.c_cflag := C_Bits (Bits)
or C_Stop_Bits (Stop_Bits)
or C_Parity (Parity)
or CREAD;
+
Current.c_iflag := 0;
Current.c_lflag := 0;
Current.c_oflag := 0;
@@ -254,10 +288,36 @@ package body GNAT.Serial_Communications is
Current.c_iflag := Current.c_iflag or IXON;
end case;
- Current.c_ispeed := Data_Rate_Value (Rate);
- Current.c_ospeed := Data_Rate_Value (Rate);
- Current.c_cc (VMIN) := char'Val (0);
- Current.c_cc (VTIME) := char'Val (Natural (Timeout * 10));
+ Current.c_ispeed := Data_Rate_Value (Rate);
+ Current.c_ospeed := Data_Rate_Value (Rate);
+
+ -- See man termios for descriptions about the different modes
+
+ if Block and then Timeout = 0.0 then
+ -- MIN > 0, TIME == 0 (blocking read)
+ Current.c_cc (VMIN) := char'Val (1);
+ Current.c_cc (VTIME) := char'Val (0);
+
+ else
+ -- MIN == 0, TIME > 0 (read with timeout)
+ -- MIN == 0, TIME == 0 (polling read)
+ Current.c_cc (VMIN) := char'Val (0);
+ Current.c_cc (VTIME) := char'Val (Natural (Timeout * 10));
+
+ Current.c_lflag := Current.c_lflag or (not ICANON);
+ end if;
+
+ Res := cfsetispeed (Current'Address, C_Data_Rate (Rate));
+
+ if Res = -1 then
+ Raise_Error ("set: cfsetispeed failed");
+ end if;
+
+ Res := cfsetospeed (Current'Address, C_Data_Rate (Rate));
+
+ if Res = -1 then
+ Raise_Error ("set: cfsetospeed failed");
+ end if;
-- Set port settings
@@ -266,7 +326,11 @@ package body GNAT.Serial_Communications is
-- Block
- Res := fcntl (int (Port.H), F_SETFL, (if Block then 0 else FNDELAY));
+ if Block then
+ -- In blocking mode, remove the non-blocking flags set while
+ -- opening the serial port (see Open).
+ Res := fcntl (int (Port.H), F_SETFL, 0);
+ end if;
if Res = -1 then
Raise_Error ("set: fcntl failed");
diff --git a/gcc/ada/libgnat/g-socket.adb b/gcc/ada/libgnat/g-socket.adb
index 57a8800..a4e9fd1 100644
--- a/gcc/ada/libgnat/g-socket.adb
+++ b/gcc/ada/libgnat/g-socket.adb
@@ -42,6 +42,8 @@ with GNAT.Sockets.Linker_Options;
pragma Warnings (Off, GNAT.Sockets.Linker_Options);
-- Need to include pragma Linker_Options which is platform dependent
+with GNAT.Sockets.Poll;
+
with System; use System;
with System.Communication; use System.Communication;
with System.CRTL; use System.CRTL;
@@ -252,15 +254,13 @@ package body GNAT.Sockets is
procedure Wait_On_Socket
(Socket : Socket_Type;
- For_Read : Boolean;
+ Event : Poll.Wait_Event_Set;
Timeout : Selector_Duration;
Selector : access Selector_Type := null;
Status : out Selector_Status);
-- Common code for variants of socket operations supporting a timeout:
- -- block in Check_Selector on Socket for at most the indicated timeout.
- -- If For_Read is True, Socket is added to the read set for this call, else
- -- it is added to the write set. If no selector is provided, a local one is
- -- created for this call and destroyed prior to returning.
+ -- block in Poll.Wait on Socket for at most the indicated timeout.
+ -- Event parameter defines what the Poll.Wait is waiting for.
type Sockets_Library_Controller is new Ada.Finalization.Limited_Controlled
with null record;
@@ -371,11 +371,11 @@ package body GNAT.Sockets is
-- Wait for socket to become available for reading
Wait_On_Socket
- (Socket => Server,
- For_Read => True,
- Timeout => Timeout,
- Selector => Selector,
- Status => Status);
+ (Socket => Server,
+ Event => Poll.Input_Event,
+ Timeout => Timeout,
+ Selector => Selector,
+ Status => Status);
-- Accept connection if available
@@ -729,7 +729,7 @@ package body GNAT.Sockets is
else
Wait_On_Socket
(Socket => Socket,
- For_Read => False,
+ Event => Poll.Output_Event,
Timeout => Timeout,
Selector => Selector,
Status => Status);
@@ -2016,57 +2016,32 @@ package body GNAT.Sockets is
procedure Wait_On_Socket
(Socket : Socket_Type;
- For_Read : Boolean;
+ Event : Poll.Wait_Event_Set;
Timeout : Selector_Duration;
Selector : access Selector_Type := null;
Status : out Selector_Status)
is
- type Local_Selector_Access is access Selector_Type;
- for Local_Selector_Access'Storage_Size use Selector_Type'Size;
-
- procedure Unchecked_Free is new Ada.Unchecked_Deallocation
- (Selector_Type, Local_Selector_Access);
+ Fd_Set : Poll.Set := Poll.To_Set (Socket, Event, 2);
+ -- Socket itself and second place for signaling socket if necessary
- Local_S : Local_Selector_Access;
- S : Selector_Access;
- -- Selector to use for waiting
-
- R_Fd_Set : Socket_Set_Type;
- W_Fd_Set : Socket_Set_Type;
+ Count : Natural;
+ Index : Natural := 0;
begin
- -- Create selector if not provided by the user
-
- if Selector = null then
- Local_S := new Selector_Type;
- S := Local_S.all'Unchecked_Access;
- Create_Selector (S.all);
+ -- Add signaling socket if selector defined
- else
- S := Selector.all'Access;
+ if Selector /= null then
+ Poll.Append (Fd_Set, Selector.R_Sig_Socket, Poll.Input_Event);
end if;
- if For_Read then
- Set (R_Fd_Set, Socket);
- else
- Set (W_Fd_Set, Socket);
- end if;
+ Poll.Wait (Fd_Set, Timeout, Count);
- Check_Selector (S.all, R_Fd_Set, W_Fd_Set, Status, Timeout);
-
- if Selector = null then
- Close_Selector (S.all);
- Unchecked_Free (Local_S);
+ if Count = 0 then
+ Status := Expired;
+ else
+ Poll.Next (Fd_Set, Index);
+ Status := (if Index = 1 then Completed else Aborted);
end if;
-
- exception
- when others =>
- Status := Completed;
-
- if Selector = null then
- Close_Selector (S.all);
- Unchecked_Free (Local_S);
- end if;
end Wait_On_Socket;
-----------------
diff --git a/gcc/ada/libgnat/g-socpol.adb b/gcc/ada/libgnat/g-socpol.adb
index ab3286c..cd82bb8 100644
--- a/gcc/ada/libgnat/g-socpol.adb
+++ b/gcc/ada/libgnat/g-socpol.adb
@@ -368,8 +368,7 @@ package body GNAT.Sockets.Poll is
Poll_Timeout := Timeout - (Clock - Stamp);
if Poll_Timeout < 0.0 then
- Count := 0;
- return;
+ Poll_Timeout := 0.0;
elsif Poll_Timeout > Timeout then
-- Clock moved back in time. This should not be happen when
diff --git a/gcc/ada/libgnat/g-spogwa.adb b/gcc/ada/libgnat/g-spogwa.adb
index a9135ea..6e0af44 100644
--- a/gcc/ada/libgnat/g-spogwa.adb
+++ b/gcc/ada/libgnat/g-spogwa.adb
@@ -36,8 +36,6 @@ procedure GNAT.Sockets.Poll.G_Wait
is
use Interfaces;
- use type C.int;
-
function C_Select
(Nfds : C.int;
readfds : access FD_Set_Type;
@@ -65,8 +63,8 @@ begin
if Timeout >= 0 then
Timeout_A := Timeout_V'Access;
- Timeout_V.tv_sec := Thin_Common.time_t (Timeout / 1000);
- Timeout_V.tv_usec := Thin_Common.suseconds_t (Timeout rem 1000 * 1000);
+ Timeout_V.Tv_Sec := Thin_Common.time_t (Timeout / 1000);
+ Timeout_V.Tv_Usec := Thin_Common.suseconds_t (Timeout rem 1000 * 1000);
end if;
Reset_Socket_Set (Rfds);
diff --git a/gcc/ada/libgnat/memtrack.adb b/gcc/ada/libgnat/memtrack.adb
index bd34796..a5f508d 100644
--- a/gcc/ada/libgnat/memtrack.adb
+++ b/gcc/ada/libgnat/memtrack.adb
@@ -102,6 +102,9 @@ package body System.Memory is
pragma Import (C, OS_Exit, "__gnat_os_exit");
pragma No_Return (OS_Exit);
+ In_Child_After_Fork : Integer;
+ pragma Import (C, In_Child_After_Fork, "__gnat_in_child_after_fork");
+
procedure fwrite
(Ptr : System.Address;
Size : size_t;
@@ -149,6 +152,24 @@ package body System.Memory is
-- themselves do dynamic allocation. We use First_Call flag to avoid
-- infinite recursion
+ function Allow_Trace return Boolean;
+ pragma Inline (Allow_Trace);
+ -- Check if the memory trace is allowed
+
+ -----------------
+ -- Allow_Trace --
+ -----------------
+
+ function Allow_Trace return Boolean is
+ begin
+ if First_Call then
+ First_Call := False;
+ return In_Child_After_Fork = 0;
+ else
+ return False;
+ end if;
+ end Allow_Trace;
+
-----------
-- Alloc --
-----------
@@ -176,14 +197,12 @@ package body System.Memory is
Result := c_malloc (Actual_Size);
- if First_Call then
+ if Allow_Trace then
-- Logs allocation call
-- format is:
-- 'A' <mem addr> <size chunk> <len backtrace> <addr1> ... <addrn>
- First_Call := False;
-
if Needs_Init then
Gmem_Initialize;
end if;
@@ -243,14 +262,12 @@ package body System.Memory is
begin
Lock_Task.all;
- if First_Call then
+ if Allow_Trace then
-- Logs deallocation call
-- format is:
-- 'D' <mem addr> <len backtrace> <addr1> ... <addrn>
- First_Call := False;
-
if Needs_Init then
Gmem_Initialize;
end if;
@@ -334,9 +351,7 @@ package body System.Memory is
Abort_Defer.all;
Lock_Task.all;
- if First_Call then
- First_Call := False;
-
+ if Allow_Trace then
-- We first log deallocation call
if Needs_Init then
diff --git a/gcc/ada/libgnat/s-arit32.adb b/gcc/ada/libgnat/s-arit32.adb
new file mode 100644
index 0000000..742f2e1
--- /dev/null
+++ b/gcc/ada/libgnat/s-arit32.adb
@@ -0,0 +1,182 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . A R I T H _ 3 2 --
+-- --
+-- 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.Unchecked_Conversion;
+
+package body System.Arith_32 is
+
+ pragma Suppress (Overflow_Check);
+ pragma Suppress (Range_Check);
+
+ subtype Uns32 is Interfaces.Unsigned_32;
+ subtype Uns64 is Interfaces.Unsigned_64;
+
+ use Interfaces;
+
+ function To_Int is new Ada.Unchecked_Conversion (Uns32, Int32);
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ function "abs" (X : Int32) return Uns32 is
+ (if X = Int32'First
+ then 2**31
+ else Uns32 (Int32'(abs X)));
+ -- Convert absolute value of X to unsigned. Note that we can't just use
+ -- the expression of the Else since it overflows for X = Int32'First.
+
+ function Hi (A : Uns64) return Uns32 is (Uns32 (Shift_Right (A, 32)));
+ -- High order half of 64-bit value
+
+ function To_Neg_Int (A : Uns32) return Int32;
+ -- Convert to negative integer equivalent. If the input is in the range
+ -- 0 .. 2**31, then the corresponding nonpositive signed integer (obtained
+ -- by negating the given value) is returned, otherwise constraint error is
+ -- raised.
+
+ function To_Pos_Int (A : Uns32) return Int32;
+ -- Convert to positive integer equivalent. If the input is in the range
+ -- 0 .. 2**31 - 1, then the corresponding nonnegative signed integer is
+ -- returned, otherwise constraint error is raised.
+
+ procedure Raise_Error;
+ pragma No_Return (Raise_Error);
+ -- Raise constraint error with appropriate message
+
+ -----------------
+ -- Raise_Error --
+ -----------------
+
+ procedure Raise_Error is
+ begin
+ raise Constraint_Error with "32-bit arithmetic overflow";
+ end Raise_Error;
+
+ -------------------
+ -- Scaled_Divide --
+ -------------------
+
+ procedure Scaled_Divide32
+ (X, Y, Z : Int32;
+ Q, R : out Int32;
+ Round : Boolean)
+ is
+ Xu : constant Uns32 := abs X;
+ Yu : constant Uns32 := abs Y;
+ Zu : constant Uns32 := abs Z;
+
+ D : Uns64;
+ -- The dividend
+
+ Qu : Uns32;
+ Ru : Uns32;
+ -- Unsigned quotient and remainder
+
+ begin
+ -- First do the 64-bit multiplication
+
+ D := Uns64 (Xu) * Uns64 (Yu);
+
+ -- If dividend is too large, raise error
+
+ if Hi (D) >= Zu then
+ Raise_Error;
+
+ -- Then do the 64-bit division
+
+ else
+ Qu := Uns32 (D / Uns64 (Zu));
+ Ru := Uns32 (D rem Uns64 (Zu));
+ end if;
+
+ -- Deal with rounding case
+
+ if Round and then Ru > (Zu - Uns32'(1)) / Uns32'(2) then
+
+ -- Protect against wrapping around when rounding, by signaling
+ -- an overflow when the quotient is too large.
+
+ if Qu = Uns32'Last then
+ Raise_Error;
+ end if;
+
+ Qu := Qu + Uns32'(1);
+ end if;
+
+ -- Set final signs (RM 4.5.5(27-30))
+
+ -- Case of dividend (X * Y) sign positive
+
+ if (X >= 0 and then Y >= 0) or else (X < 0 and then Y < 0) then
+ R := To_Pos_Int (Ru);
+ Q := (if Z > 0 then To_Pos_Int (Qu) else To_Neg_Int (Qu));
+
+ -- Case of dividend (X * Y) sign negative
+
+ else
+ R := To_Neg_Int (Ru);
+ Q := (if Z > 0 then To_Neg_Int (Qu) else To_Pos_Int (Qu));
+ end if;
+ end Scaled_Divide32;
+
+ ----------------
+ -- To_Neg_Int --
+ ----------------
+
+ function To_Neg_Int (A : Uns32) return Int32 is
+ R : constant Int32 :=
+ (if A = 2**31 then Int32'First else -To_Int (A));
+ -- Note that we can't just use the expression of the Else, because it
+ -- overflows for A = 2**31.
+ begin
+ if R <= 0 then
+ return R;
+ else
+ Raise_Error;
+ end if;
+ end To_Neg_Int;
+
+ ----------------
+ -- To_Pos_Int --
+ ----------------
+
+ function To_Pos_Int (A : Uns32) return Int32 is
+ R : constant Int32 := To_Int (A);
+ begin
+ if R >= 0 then
+ return R;
+ else
+ Raise_Error;
+ end if;
+ end To_Pos_Int;
+
+end System.Arith_32;
diff --git a/gcc/ada/libgnat/s-arit32.ads b/gcc/ada/libgnat/s-arit32.ads
new file mode 100644
index 0000000..5656855
--- /dev/null
+++ b/gcc/ada/libgnat/s-arit32.ads
@@ -0,0 +1,55 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . A R I T H _ 3 2 --
+-- --
+-- 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. --
+-- --
+------------------------------------------------------------------------------
+
+-- This unit provides software routines for doing arithmetic on 32-bit
+-- signed integer values in cases where either overflow checking is
+-- required, or intermediate results are longer than 32 bits.
+
+with Interfaces;
+
+package System.Arith_32 is
+ pragma Pure;
+
+ subtype Int32 is Interfaces.Integer_32;
+
+ procedure Scaled_Divide32
+ (X, Y, Z : Int32;
+ Q, R : out Int32;
+ Round : Boolean);
+ -- Performs the division of (X * Y) / Z, storing the quotient in Q
+ -- and the remainder in R. Constraint_Error is raised if Z is zero,
+ -- or if the quotient does not fit in 32 bits. Round indicates if
+ -- the result should be rounded. If Round is False, then Q, R are
+ -- the normal quotient and remainder from a truncating division.
+ -- If Round is True, then Q is the rounded quotient. The remainder
+ -- R is not affected by the setting of the Round flag.
+
+end System.Arith_32;
diff --git a/gcc/ada/libgnat/s-bitfie.ads b/gcc/ada/libgnat/s-bitfie.ads
index 4f17a9c..21b7294 100644
--- a/gcc/ada/libgnat/s-bitfie.ads
+++ b/gcc/ada/libgnat/s-bitfie.ads
@@ -47,6 +47,12 @@ 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.
+
+ pragma Suppress (Alignment_Check);
package Utils is new System.Bitfield_Utils.G (Val, Val_2);
procedure Copy_Bitfield
diff --git a/gcc/ada/libgnat/s-bituti.adb b/gcc/ada/libgnat/s-bituti.adb
index e3bd70a..ef839a8 100644
--- a/gcc/ada/libgnat/s-bituti.adb
+++ b/gcc/ada/libgnat/s-bituti.adb
@@ -317,6 +317,7 @@ package body System.Bitfield_Utils is
Get_Val_2 (S_Addr, S_Off, Initial_Size);
Initial_Val : constant Val :=
Get_Bitfield (Initial_Val_2, S_Off, Initial_Size);
+
begin
Set_Bitfield
(Initial_Val, D_Addr, D_Off, Initial_Size);
diff --git a/gcc/ada/libgnat/s-dwalin.adb b/gcc/ada/libgnat/s-dwalin.adb
index abb499c..d8b15c5d 100644
--- a/gcc/ada/libgnat/s-dwalin.adb
+++ b/gcc/ada/libgnat/s-dwalin.adb
@@ -1582,6 +1582,13 @@ package body System.Dwarf_Lines is
Subprg_Name,
Line_Num);
+ -- If we're not requested to suppress hex addresses, emit it now.
+
+ if not Suppress_Hex then
+ Append_Address (Res, Addr_In_Traceback);
+ Append (Res, ' ');
+ end if;
+
if File_Name /= null then
declare
Last : constant Natural := String_Length (File_Name);
@@ -1626,26 +1633,22 @@ package body System.Dwarf_Lines is
(Res,
String (Subprg_Name.Ptr (Off .. Subprg_Name.Len)));
end if;
- Append (Res, ' ');
+ else
+ Append (Res, "???");
end if;
- Append (Res, "at ");
+ Append (Res, " at ");
Append (Res, String (File_Name (1 .. Last)));
Append (Res, ':');
Append (Res, Line_Image (2 .. Line_Image'Last));
end;
else
- if Suppress_Hex then
- Append (Res, "...");
- else
- Append_Address (Res, Addr_In_Traceback);
- end if;
-
if Subprg_Name.Len > 0 then
Off := Strip_Leading_Char (C.Obj.all, Subprg_Name);
- Append (Res, ' ');
Append (Res, String (Subprg_Name.Ptr (Off .. Subprg_Name.Len)));
+ else
+ Append (Res, "???");
end if;
Append (Res, " at ???");
diff --git a/gcc/ada/libgnat/s-fatgen.adb b/gcc/ada/libgnat/s-fatgen.adb
index a598a12..9f25987 100644
--- a/gcc/ada/libgnat/s-fatgen.adb
+++ b/gcc/ada/libgnat/s-fatgen.adb
@@ -29,50 +29,137 @@
-- --
------------------------------------------------------------------------------
--- The implementation here is portable to any IEEE implementation. It does
--- not handle nonbinary radix, and also assumes that model numbers and
--- machine numbers are basically identical, which is not true of all possible
--- floating-point implementations. On a non-IEEE machine, this body must be
--- specialized appropriately, or better still, its generic instantiations
--- should be replaced by efficient machine-specific code.
+-- This implementation is portable to any IEEE implementation. It does not
+-- handle nonbinary radix, and also assumes that model numbers and machine
+-- numbers are basically identical, which is not true of all possible
+-- floating-point implementations.
with Ada.Unchecked_Conversion;
-with System;
-package body System.Fat_Gen is
+with Interfaces;
+with System.Unsigned_Types;
+
+pragma Warnings (Off, "non-static constant in preelaborated unit");
+-- Every constant is static given our instantiation model
- Float_Radix : constant T := T (T'Machine_Radix);
- Radix_To_M_Minus_1 : constant T := Float_Radix ** (T'Machine_Mantissa - 1);
+package body System.Fat_Gen is
+ use type Interfaces.Unsigned_64;
pragma Assert (T'Machine_Radix = 2);
-- This version does not handle radix 16
- -- Constants for Decompose and Scaling
+ Rad : constant T := T (T'Machine_Radix);
+ -- Renaming for the machine radix
- Rad : constant T := T (T'Machine_Radix);
- Invrad : constant T := 1.0 / Rad;
+ Mantissa : constant Integer := T'Machine_Mantissa;
+ -- Renaming for the machine mantissa
- subtype Expbits is Integer range 0 .. 6;
- -- 2 ** (2 ** 7) might overflow. How big can radix-16 exponents get?
-
- Log_Power : constant array (Expbits) of Integer := (1, 2, 4, 8, 16, 32, 64);
-
- R_Power : constant array (Expbits) of T :=
- (Rad ** 1,
- Rad ** 2,
- Rad ** 4,
- Rad ** 8,
- Rad ** 16,
- Rad ** 32,
- Rad ** 64);
-
- R_Neg_Power : constant array (Expbits) of T :=
- (Invrad ** 1,
- Invrad ** 2,
- Invrad ** 4,
- Invrad ** 8,
- Invrad ** 16,
- Invrad ** 32,
- Invrad ** 64);
+ Invrad : constant T := 1.0 / Rad;
+ -- Smallest positive mantissa in the canonical form (RM A.5.3(4))
+
+ -- Small : constant T := Rad ** (T'Machine_Emin - 1);
+ -- Smallest positive normalized number
+
+ -- 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
+ -- any nonzero denormalized number.
+
+ IEEE_Emin : constant Integer := T'Machine_Emin - 1;
+ IEEE_Emax : constant Integer := T'Machine_Emax - 1;
+ -- The mantissa is a fraction with first digit set in Ada whereas it is
+ -- shifted by 1 digit to the left in the IEEE floating-point format.
+
+ subtype IEEE_Erange is Integer range IEEE_Emin - 1 .. IEEE_Emax + 1;
+ -- The IEEE floating-point format extends the machine range by 1 to the
+ -- left for denormalized numbers and 1 to the right for infinities/NaNs.
+
+ IEEE_Ebias : constant Integer := -(IEEE_Emin - 1);
+ -- The exponent is biased such that denormalized numbers have it zero
+
+ -- The implementation uses a representation type Float_Rep that allows
+ -- direct access to exponent and mantissa of the floating point number.
+
+ -- The Float_Rep type is a simple array of Float_Word elements. This
+ -- representation is chosen to make it possible to size the type based
+ -- on a generic parameter. Since the array size is known at compile
+ -- time, efficient code can still be generated. The size of Float_Word
+ -- elements should be large enough to allow accessing the exponent in
+ -- one read, but small enough so that all floating-point object sizes
+ -- are a multiple of Float_Word'Size.
+
+ -- The following conditions must be met for all possible instantiations
+ -- of the attribute package:
+
+ -- - T'Size is an integral multiple of Float_Word'Size
+
+ -- - The exponent and sign are completely contained in a single
+ -- 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
+ -- numbers, may or may not be stored by the hardware.
+
+ Siz : constant := (if System.Word_Size > 32 then 32 else System.Word_Size);
+ type Float_Word is mod 2**Siz;
+
+ N : constant Natural := (T'Size + Siz - 1) / Siz;
+ Rep_Last : constant Natural := Natural'Min (N - 1, (Mantissa + 16) / Siz);
+ -- 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
+ -- bits. In general, the exponent field cannot be larger than 15 bits,
+ -- even for 128-bit floating-point types, so the final format size
+ -- won't be larger than Mantissa + 16.
+
+ type Float_Rep is array (Natural range 0 .. N - 1) of Float_Word;
+ pragma Suppress_Initialization (Float_Rep);
+ -- This pragma suppresses the generation of an initialization procedure
+ -- for type Float_Rep when operating in Initialize/Normalize_Scalars mode.
+
+ MSW : constant Natural := Rep_Last * Standard'Default_Bit_Order;
+ -- Finding the location of the Exponent_Word is a bit tricky. In general
+ -- 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));
+ -- 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.
+
+ Exp_Mask : constant Float_Word :=
+ Float_Word (IEEE_Emax - IEEE_Emin + 2) * Exp_Factor;
+ -- Value needed to mask out the exponent field. This assumes that the
+ -- 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.
-----------------------
-- Local Subprograms --
@@ -84,11 +171,6 @@ 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 Gradual_Scaling (Adjustment : UI) return T;
- -- Like Scaling with a first argument of 1.0, but returns the smallest
- -- denormal rather than zero when the adjustment is smaller than
- -- Machine_Emin. Used for Succ and Pred.
-
--------------
-- Adjacent --
--------------
@@ -138,19 +220,22 @@ package body System.Fat_Gen is
---------------
function Copy_Sign (Value, Sign : T) return T is
- Result : T;
+ S : constant T := T'Machine (Sign);
- function Is_Negative (V : T) return Boolean;
- pragma Import (Intrinsic, Is_Negative);
+ Rep_S : Float_Rep;
+ for Rep_S'Address use S'Address;
+ -- Rep_S is a view of the Sign parameter
- begin
- Result := abs Value;
+ V : T := T'Machine (Value);
- if Is_Negative (Sign) then
- return -Result;
- else
- return Result;
- end if;
+ Rep_V : Float_Rep;
+ for Rep_V'Address use V'Address;
+ -- Rep_V is a view of the Value parameter
+
+ begin
+ Rep_V (MSW) :=
+ (Rep_V (MSW) and not Sign_Mask) or (Rep_S (MSW) and Sign_Mask);
+ return V;
end Copy_Sign;
---------------
@@ -158,94 +243,53 @@ package body System.Fat_Gen is
---------------
procedure Decompose (XX : T; Frac : out T; Expo : out UI) is
- X : constant T := T'Machine (XX);
+ X : T := T'Machine (XX);
- begin
- if X = 0.0 then
+ Rep : Float_Rep;
+ for Rep'Address use X'Address;
+ -- Rep is a view of the input floating-point parameter
- -- The normalized exponent of zero is zero, see RM A.5.2(15)
+ Exp : constant IEEE_Erange :=
+ Integer ((Rep (MSW) and Exp_Mask) / Exp_Factor) - IEEE_Ebias;
+ -- Mask/Shift X to only get bits from the exponent. Then convert biased
+ -- value to final value.
- Frac := X;
- Expo := 0;
-
- -- Check for infinities, transfinites, whatnot
+ Minus : constant Boolean := (Rep (MSW) and Sign_Mask) /= 0;
+ -- Mask/Shift X to only get bit from the sign
- elsif X > T'Safe_Last then
- Frac := Invrad;
- pragma Annotate (CodePeer, Intentional, "dead code",
- "Check float range.");
- Expo := T'Machine_Emax + 1;
-
- elsif X < T'Safe_First then
- Frac := -Invrad;
- pragma Annotate (CodePeer, Intentional, "dead code",
- "Check float range.");
- Expo := T'Machine_Emax + 2; -- how many extra negative values?
+ begin
+ -- The normalized exponent of zero is zero, see RM A.5.3(15)
- else
- -- Case of nonzero finite x. Essentially, we just multiply
- -- by Rad ** (+-2**N) to reduce the range.
+ if X = 0.0 then
+ Expo := 0;
+ Frac := X;
- declare
- Ax : T := abs X;
- Ex : UI := 0;
+ -- Check for infinities and NaNs
- -- Ax * Rad ** Ex is invariant
+ elsif Exp = IEEE_Emax + 1 then
+ Expo := T'Machine_Emax + 1;
+ Frac := (if Minus then -Invrad else Invrad);
- begin
- if Ax >= 1.0 then
- while Ax >= R_Power (Expbits'Last) loop
- Ax := Ax * R_Neg_Power (Expbits'Last);
- Ex := Ex + Log_Power (Expbits'Last);
- end loop;
+ -- Check for nonzero denormalized numbers
- -- Ax < Rad ** 64
+ elsif Exp = IEEE_Emin - 1 then
+ -- Normalize by multiplying by Radix ** (Mantissa - 1)
- for N in reverse Expbits'First .. Expbits'Last - 1 loop
- if Ax >= R_Power (N) then
- Ax := Ax * R_Neg_Power (N);
- Ex := Ex + Log_Power (N);
- end if;
+ Decompose (X * RM1, Frac, Expo);
+ Expo := Expo - (Mantissa - 1);
- -- Ax < R_Power (N)
+ -- Case of normalized numbers
- end loop;
+ else
+ -- The Ada exponent is the IEEE exponent plus 1, see above
- -- 1 <= Ax < Rad
+ Expo := Exp + 1;
- Ax := Ax * Invrad;
- Ex := Ex + 1;
+ -- Set Ada exponent of X to zero, so we end up with the fraction
- else
- -- 0 < ax < 1
-
- while Ax < R_Neg_Power (Expbits'Last) loop
- Ax := Ax * R_Power (Expbits'Last);
- pragma Annotate (CodePeer, Intentional, "dead code",
- "Check float range.");
- Ex := Ex - Log_Power (Expbits'Last);
- end loop;
- pragma Annotate
- (CodePeer, Intentional,
- "test always false",
- "expected for some instantiations");
-
- -- Rad ** -64 <= Ax < 1
-
- for N in reverse Expbits'First .. Expbits'Last - 1 loop
- if Ax < R_Neg_Power (N) then
- Ax := Ax * R_Power (N);
- Ex := Ex - Log_Power (N);
- end if;
-
- -- R_Neg_Power (N) <= Ax < 1
-
- end loop;
- end if;
-
- Frac := (if X > 0.0 then Ax else -Ax);
- Expo := Ex;
- end;
+ Rep (MSW) := (Rep (MSW) and not Exp_Mask) +
+ Float_Word (IEEE_Ebias - 1) * Exp_Factor;
+ Frac := X;
end if;
end Decompose;
@@ -291,38 +335,6 @@ package body System.Fat_Gen is
return X_Frac;
end Fraction;
- ---------------------
- -- Gradual_Scaling --
- ---------------------
-
- function Gradual_Scaling (Adjustment : UI) return T is
- Y : T;
- Y1 : T;
- Ex : UI := Adjustment;
-
- begin
- if Adjustment < T'Machine_Emin - 1 then
- Y := 2.0 ** T'Machine_Emin;
- Y1 := Y;
- Ex := Ex - T'Machine_Emin;
- while Ex < 0 loop
- Y := T'Machine (Y / 2.0);
-
- if Y = 0.0 then
- return Y1;
- end if;
-
- Ex := Ex + 1;
- Y1 := Y;
- end loop;
-
- return Y1;
-
- else
- return Scaling (1.0, Adjustment);
- end if;
- end Gradual_Scaling;
-
------------------
-- Leading_Part --
------------------
@@ -332,7 +344,7 @@ package body System.Fat_Gen is
Y, Z : T;
begin
- if Radix_Digits >= T'Machine_Mantissa then
+ if Radix_Digits >= Mantissa then
return X;
elsif Radix_Digits <= 0 then
@@ -412,6 +424,13 @@ 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;
@@ -419,12 +438,11 @@ package body System.Fat_Gen is
-- Zero has to be treated specially, since its exponent is zero
if X = 0.0 then
- return -Succ (X);
+ return -Tiny;
- -- Special treatment for most negative number
+ -- Special treatment for largest negative number: raise Constraint_Error
elsif X = T'First then
-
raise Constraint_Error with "Pred of largest negative number";
-- For infinities, return unchanged
@@ -438,28 +456,33 @@ package body System.Fat_Gen is
-- 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,
+ -- 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.
else
Decompose (X, X_Frac, X_Exp);
- -- A special case, if the number we had was a positive power of
- -- two, then we want to subtract half of what we would otherwise
- -- subtract, since the exponent is going to be reduced.
+ -- 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;
- -- Note that X_Frac has the same sign as X, so if X_Frac is 0.5,
- -- then we know that we have a positive number (and hence a
- -- positive power of 2).
+ -- 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.
- if X_Frac = 0.5 then
- return X - Gradual_Scaling (X_Exp - T'Machine_Mantissa - 1);
+ -- 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.
- -- Otherwise the exponent is unchanged
+ elsif X_Frac = Invrad then
+ return X - Scaling (1.0, X_Exp - Mantissa - 1);
+
+ -- Otherwise the adjustment is unchanged
else
- return X - Gradual_Scaling (X_Exp - T'Machine_Mantissa);
+ return X - Scaling (1.0, X_Exp - Mantissa);
end if;
end if;
end Pred;
@@ -579,70 +602,97 @@ package body System.Fat_Gen is
-- Scaling --
-------------
- -- Return x * rad ** adjustment quickly, or quietly underflow to zero,
- -- or overflow naturally.
-
function Scaling (X : T; Adjustment : UI) return T is
+ pragma Assert (Mantissa <= 64);
+ -- This implementation handles only 80-bit IEEE Extended or smaller
+
+ package UST renames System.Unsigned_Types;
+ use type UST.Long_Long_Unsigned;
+
+ XX : T := T'Machine (X);
+
+ Rep : Float_Rep;
+ for Rep'Address use XX'Address;
+ -- Rep is a view of the input floating-point parameter
+
+ Exp : constant IEEE_Erange :=
+ Integer ((Rep (MSW) and Exp_Mask) / Exp_Factor) - IEEE_Ebias;
+ -- Mask/Shift X to only get bits from the exponent. Then convert biased
+ -- value to final value.
+
+ Minus : constant Boolean := (Rep (MSW) and Sign_Mask) /= 0;
+ -- Mask/Shift X to only get bit from the sign
+
+ Expi, Expf : IEEE_Erange;
+
begin
- if X = 0.0 or else Adjustment = 0 then
+ -- Check for zero, infinities, NaNs as well as no adjustment
+
+ if X = 0.0 or else Exp = IEEE_Emax + 1 or else Adjustment = 0 then
return X;
- end if;
- -- Nonzero x essentially, just multiply repeatedly by Rad ** (+-2**n)
+ -- Check for nonzero denormalized numbers
- declare
- Y : T := X;
- Ex : UI := Adjustment;
+ elsif Exp = IEEE_Emin - 1 then
+ -- Check for zero result to protect the subtraction below
- -- Y * Rad ** Ex is invariant
+ if Adjustment < -(Mantissa - 1) then
+ XX := 0.0;
+ return (if Minus then -XX else XX);
- begin
- if Ex < 0 then
- while Ex <= -Log_Power (Expbits'Last) loop
- Y := Y * R_Neg_Power (Expbits'Last);
- Ex := Ex + Log_Power (Expbits'Last);
- end loop;
+ -- Normalize by multiplying by Radix ** (Mantissa - 1)
- -- -64 < Ex <= 0
+ else
+ return Scaling (XX * RM1, Adjustment - (Mantissa - 1));
+ end if;
- for N in reverse Expbits'First .. Expbits'Last - 1 loop
- if Ex <= -Log_Power (N) then
- Y := Y * R_Neg_Power (N);
- Ex := Ex + Log_Power (N);
- end if;
+ -- Case of normalized numbers
- -- -Log_Power (N) < Ex <= 0
+ else
+ -- Check for overflow
- end loop;
+ 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");
- -- Ex = 0
+ -- Check for underflow
- else
- -- Ex >= 0
+ elsif Adjustment < IEEE_Emin - Exp then
+ -- Check for gradual underflow
- while Ex >= Log_Power (Expbits'Last) loop
- Y := Y * R_Power (Expbits'Last);
- Ex := Ex - Log_Power (Expbits'Last);
- end loop;
+ if T'Denorm
+ and then Adjustment >= IEEE_Emin - (Mantissa - 1) - Exp
+ then
+ Expf := IEEE_Emin;
+ Expi := Exp + Adjustment - Expf;
- -- 0 <= Ex < 64
+ -- Case of zero result
- for N in reverse Expbits'First .. Expbits'Last - 1 loop
- if Ex >= Log_Power (N) then
- Y := Y * R_Power (N);
- Ex := Ex - Log_Power (N);
- end if;
+ else
+ XX := 0.0;
+ return (if Minus then -XX else XX);
+ end if;
- -- 0 <= Ex < Log_Power (N)
+ -- Case of normalized results
- end loop;
+ else
+ Expf := Exp + Adjustment;
+ Expi := 0;
+ end if;
- -- Ex = 0
+ Rep (MSW) := (Rep (MSW) and not Exp_Mask) +
+ Float_Word (IEEE_Ebias + Expf) * Exp_Factor;
+ if Expi < 0 then
+ XX := XX / T (UST.Long_Long_Unsigned (2) ** (-Expi));
end if;
- return Y;
- end;
+ return XX;
+ end if;
end Scaling;
----------
@@ -650,36 +700,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;
- X1, X2 : T;
begin
-- Treat zero specially since it has a zero exponent
if X = 0.0 then
- X1 := 2.0 ** T'Machine_Emin;
+ return Tiny;
- -- Following loop generates smallest denormal
-
- loop
- X2 := T'Machine (X1 / 2.0);
- exit when X2 = 0.0;
- X1 := X2;
- end loop;
-
- return X1;
-
- -- Special treatment for largest positive number
+ -- Special treatment for largest positive number: raise Constraint_Error
elsif X = T'Last then
-
- -- If not generating infinities, we raise a constraint error
-
raise Constraint_Error with "Succ of largest positive number";
- -- Otherwise generate a positive infinity
-
-- For infinities, return unchanged
elsif X < T'First or else X > T'Last then
@@ -689,30 +730,35 @@ package body System.Fat_Gen is
pragma Annotate (CodePeer, Intentional, "dead code",
"Check float range.");
- -- 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,
+ -- 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.
else
Decompose (X, X_Frac, X_Exp);
- -- A special case, if the number we had was a negative power of two,
- -- then we want to add half of what we would otherwise add, since the
- -- exponent is going to be reduced.
+ -- 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;
- -- Note that X_Frac has the same sign as X, so if X_Frac is -0.5,
- -- then we know that we have a negative number (and hence a negative
- -- power of 2).
+ -- 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.
- if X_Frac = -0.5 then
- return X + Gradual_Scaling (X_Exp - T'Machine_Mantissa - 1);
+ -- 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.
- -- Otherwise the exponent is unchanged
+ elsif X_Frac = -Invrad then
+ return X + Scaling (1.0, X_Exp - Mantissa - 1);
+
+ -- Otherwise the adjustment is unchanged
else
- return X + Gradual_Scaling (X_Exp - T'Machine_Mantissa);
+ return X + Scaling (1.0, X_Exp - Mantissa);
end if;
end if;
end Succ;
@@ -725,7 +771,7 @@ package body System.Fat_Gen is
-- T'Machine (RM1 + N) - RM1
- -- where N >= 0.0 and RM1 = radix ** (mantissa - 1)
+ -- where N >= 0.0 and RM1 = Radix ** (Mantissa - 1)
-- This works provided that the intermediate result (RM1 + N) does not
-- have extra precision (which is why we call Machine). When we compute
@@ -742,19 +788,18 @@ package body System.Fat_Gen is
begin
Result := abs X;
- if Result >= Radix_To_M_Minus_1 then
+ if Result >= RM1 then
return T'Machine (X);
else
- Result :=
- T'Machine (Radix_To_M_Minus_1 + Result) - Radix_To_M_Minus_1;
+ Result := T'Machine (RM1 + Result) - RM1;
if Result > abs X then
Result := Result - 1.0;
end if;
if X > 0.0 then
- return Result;
+ return Result;
elsif X < 0.0 then
return -Result;
@@ -805,132 +850,37 @@ package body System.Fat_Gen is
-----------
function Valid (X : not null access T) return Boolean is
- IEEE_Emin : constant Integer := T'Machine_Emin - 1;
- IEEE_Emax : constant Integer := T'Machine_Emax - 1;
-
- IEEE_Bias : constant Integer := -(IEEE_Emin - 1);
-
- subtype IEEE_Exponent_Range is
- Integer range IEEE_Emin - 1 .. IEEE_Emax + 1;
-
- -- The implementation of this floating point attribute uses a
- -- representation type Float_Rep that allows direct access to the
- -- exponent and mantissa parts of a floating point number.
-
- -- The Float_Rep type is an array of Float_Word elements. This
- -- representation is chosen to make it possible to size the type based
- -- on a generic parameter. Since the array size is known at compile
- -- time, efficient code can still be generated. The size of Float_Word
- -- elements should be large enough to allow accessing the exponent in
- -- one read, but small enough so that all floating point object sizes
- -- are a multiple of the Float_Word'Size.
-
- -- The following conditions must be met for all possible instantiations
- -- of the attributes package:
-
- -- - T'Size is an integral multiple of Float_Word'Size
-
- -- - The exponent and sign are completely contained in a single
- -- 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. Unused bits (if any) are in
- -- the least significant part.
-
- type Float_Word is mod 2**Positive'Min (System.Word_Size, 32);
- type Rep_Index is range 0 .. 7;
-
- Rep_Words : constant Positive :=
- (T'Size + Float_Word'Size - 1) / Float_Word'Size;
- Rep_Last : constant Rep_Index :=
- Rep_Index'Min
- (Rep_Index (Rep_Words - 1),
- (T'Mantissa + 16) / Float_Word'Size);
- -- 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
- -- bits. In general, the exponent field cannot be larger than 15 bits,
- -- even for 128-bit floating-point types, so the final format size
- -- won't be larger than T'Mantissa + 16.
-
- type Float_Rep is
- array (Rep_Index range 0 .. Rep_Index (Rep_Words - 1)) of Float_Word;
-
- pragma Suppress_Initialization (Float_Rep);
- -- This pragma suppresses the generation of an initialization procedure
- -- for type Float_Rep when operating in Initialize/Normalize_Scalars
- -- mode. This is not just a matter of efficiency, but of functionality,
- -- since Valid has a pragma Inline_Always, which is not permitted if
- -- there are nested subprograms present.
-
- Most_Significant_Word : constant Rep_Index :=
- Rep_Last * Standard'Default_Bit_Order;
- -- Finding the location of the Exponent_Word is a bit tricky. In general
- -- we assume Word_Order = Bit_Order.
-
- Exponent_Factor : constant Float_Word :=
- 2**(Float_Word'Size - 1) /
- Float_Word (IEEE_Emax - IEEE_Emin + 3) *
- Boolean'Pos (Most_Significant_Word /= 2) +
- Boolean'Pos (Most_Significant_Word = 2);
- -- Factor that the extracted exponent needs to be divided by to be in
- -- range 0 .. IEEE_Emax - IEEE_Emin + 2. Special case: Exponent_Factor
- -- is 1 for x86/IA64 double extended (GCC adds unused bits to the type).
-
- Exponent_Mask : constant Float_Word :=
- Float_Word (IEEE_Emax - IEEE_Emin + 2) *
- Exponent_Factor;
- -- Value needed to mask out the exponent field. This assumes that the
- -- range IEEE_Emin - 1 .. IEEE_Emax + contains 2**N values, for some N
- -- in Natural.
-
- function To_Float is new Ada.Unchecked_Conversion (Float_Rep, T);
-
- type Float_Access is access all T;
+ type Access_T is access all T;
function To_Address is
- new Ada.Unchecked_Conversion (Float_Access, System.Address);
-
- XA : constant System.Address := To_Address (Float_Access (X));
+ new Ada.Unchecked_Conversion (Access_T, System.Address);
- R : Float_Rep;
- pragma Import (Ada, R);
- for R'Address use XA;
- -- R is a view of the input floating-point parameter. Note that we
- -- must avoid copying the actual bits of this parameter in float
- -- form (since it may be a signalling NaN).
+ Rep : Float_Rep;
+ for Rep'Address use To_Address (Access_T (X));
+ -- Rep is a view of the input floating-point parameter. Note that we
+ -- must avoid reading the actual bits of this parameter in float form
+ -- since it may be a signalling NaN.
- E : constant IEEE_Exponent_Range :=
- Integer ((R (Most_Significant_Word) and Exponent_Mask) /
- Exponent_Factor)
- - IEEE_Bias;
- -- Mask/Shift T to only get bits from the exponent. Then convert biased
- -- value to integer value.
-
- SR : Float_Rep;
- -- Float_Rep representation of significant of X.all
+ Exp : constant IEEE_Erange :=
+ Integer ((Rep (MSW) and Exp_Mask) / Exp_Factor) - IEEE_Ebias;
+ -- Mask/Shift X to only get bits from the exponent. Then convert biased
+ -- value to final value.
begin
- if T'Denorm then
-
- -- All denormalized numbers are valid, so the only invalid numbers
- -- are overflows and NaNs, both with exponent = Emax + 1.
+ if Exp = IEEE_Emax + 1 then
+ -- This is an infinity or a NaN, i.e. always invalid
- return E /= IEEE_Emax + 1;
+ return False;
- end if;
+ elsif Exp in IEEE_Emin .. IEEE_Emax then
+ -- This is a normalized number, i.e. always valid
- -- All denormalized numbers except 0.0 are invalid
+ return True;
- -- Set exponent of X to zero, so we end up with the significand, which
- -- definitely is a valid number and can be converted back to a float.
+ else pragma Assert (Exp = IEEE_Emin - 1);
+ -- This is a denormalized number, valid if T'Denorm is True or 0.0
- SR := R;
- SR (Most_Significant_Word) :=
- (SR (Most_Significant_Word)
- and not Exponent_Mask) + Float_Word (IEEE_Bias) * Exponent_Factor;
-
- return (E in IEEE_Emin .. IEEE_Emax) or else
- ((E = IEEE_Emin - 1) and then abs To_Float (SR) = 1.0);
+ return T'Denorm or else X.all = 0.0;
+ end if;
end Valid;
end System.Fat_Gen;
diff --git a/gcc/ada/libgnat/s-fatgen.ads b/gcc/ada/libgnat/s-fatgen.ads
index b84d23b..700cfdc 100644
--- a/gcc/ada/libgnat/s-fatgen.ads
+++ b/gcc/ada/libgnat/s-fatgen.ads
@@ -31,9 +31,8 @@
-- This generic package provides a target independent implementation of the
-- floating-point attributes that denote functions. The implementations here
--- are portable, but very slow. The runtime contains a set of instantiations
--- of this package for all predefined floating-point types, and these should
--- be replaced by efficient assembly language code where possible.
+-- should be portable and reasonably efficient. The runtime contains a set of
+-- instantiations of this package for all predefined floating-point types.
generic
type T is digits <>;
@@ -107,12 +106,12 @@ package System.Fat_Gen is
-- floating point register).
private
+ pragma Inline (Compose);
+ pragma Inline (Copy_Sign);
+ pragma Inline (Exponent);
+ pragma Inline (Fraction);
pragma Inline (Machine);
pragma Inline (Model);
-
- -- Note: previously the validity checking subprograms (Unaligned_Valid and
- -- Valid) were also inlined, but this was changed since there were some
- -- problems with this inlining in optimized mode, and in any case it seems
- -- better to avoid this inlining (space and robustness considerations).
+ pragma Inline (Valid);
end System.Fat_Gen;
diff --git a/gcc/ada/libgnat/s-finmas.adb b/gcc/ada/libgnat/s-finmas.adb
index 5a6583a..3e9ae58 100644
--- a/gcc/ada/libgnat/s-finmas.adb
+++ b/gcc/ada/libgnat/s-finmas.adb
@@ -119,20 +119,6 @@ package body System.Finalization_Masters is
Finalize_Address_Table.Remove (Obj);
end Delete_Finalize_Address_Unprotected;
- ------------
- -- Detach --
- ------------
-
- procedure Detach (N : not null FM_Node_Ptr) is
- begin
- Lock_Task.all;
- Detach_Unprotected (N);
- Unlock_Task.all;
-
- -- Note: No need to unlock in case of an exception because the above
- -- code can never raise one.
- end Detach;
-
------------------------
-- Detach_Unprotected --
------------------------
diff --git a/gcc/ada/libgnat/s-finmas.ads b/gcc/ada/libgnat/s-finmas.ads
index ae0276f..eb30ea1 100644
--- a/gcc/ada/libgnat/s-finmas.ads
+++ b/gcc/ada/libgnat/s-finmas.ads
@@ -86,10 +86,6 @@ package System.Finalization_Masters is
-- Destroy the relation pair object - Finalize_Address from the internal
-- hash table.
- procedure Detach (N : not null FM_Node_Ptr);
- -- Compiler interface, do not call from within the run-time. Remove a node
- -- from an arbitrary finalization master.
-
procedure Detach_Unprotected (N : not null FM_Node_Ptr);
-- Remove a node from an arbitrary finalization master
diff --git a/gcc/ada/libgnat/s-fatsfl.ads b/gcc/ada/libgnat/s-fode128.ads
index 45b13e1..200a020 100644
--- a/gcc/ada/libgnat/s-fatsfl.ads
+++ b/gcc/ada/libgnat/s-fode128.ads
@@ -1,12 +1,12 @@
------------------------------------------------------------------------------
-- --
--- GNAT COMPILER COMPONENTS --
+-- GNAT RUN-TIME COMPONENTS --
-- --
--- S Y S T E M . F A T _ S F L T --
+-- S Y S T E M . F O R E _ D E C I M A L _ 1 2 8 --
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -29,19 +29,20 @@
-- --
------------------------------------------------------------------------------
--- This package contains an instantiation of the floating-point attribute
--- runtime routines for the type Short_Float.
+-- This package contains the routine used for the 'Fore attribute for decimal
+-- fixed point types up to 128-bit mantissa.
-with System.Fat_Gen;
+with Interfaces;
+with System.Fore_D;
-package System.Fat_SFlt is
+package System.Fore_Decimal_128 is
pragma Pure;
- -- Note the only entity from this package that is accessed by Rtsfind
- -- is the name of the package instantiation. Entities within this package
- -- (i.e. the individual floating-point attribute routines) are accessed
- -- by name using selected notation.
+ subtype Int128 is Interfaces.Integer_128;
- package Attr_Short_Float is new System.Fat_Gen (Short_Float);
+ package Impl is new Fore_D (Int128);
-end System.Fat_SFlt;
+ function Fore_Decimal128 (Lo, Hi : Int128; Scale : Integer) return Natural
+ renames Impl.Fore_Decimal;
+
+end System.Fore_Decimal_128;
diff --git a/gcc/ada/libgnat/s-fode32.ads b/gcc/ada/libgnat/s-fode32.ads
new file mode 100644
index 0000000..15c07a4
--- /dev/null
+++ b/gcc/ada/libgnat/s-fode32.ads
@@ -0,0 +1,48 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . F O R E _ D E C I M A L _ 3 2 --
+-- --
+-- 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. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains the routine used for the 'Fore attribute for decimal
+-- fixed point types up to 32-bit mantissa.
+
+with Interfaces;
+with System.Fore_D;
+
+package System.Fore_Decimal_32 is
+ pragma Pure;
+
+ subtype Int32 is Interfaces.Integer_32;
+
+ package Impl is new Fore_D (Int32);
+
+ function Fore_Decimal32 (Lo, Hi : Int32; Scale : Integer) return Natural
+ renames Impl.Fore_Decimal;
+
+end System.Fore_Decimal_32;
diff --git a/gcc/ada/libgnat/s-fode64.ads b/gcc/ada/libgnat/s-fode64.ads
new file mode 100644
index 0000000..7e98185
--- /dev/null
+++ b/gcc/ada/libgnat/s-fode64.ads
@@ -0,0 +1,48 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . F O R E _ D E C I M A L _ 6 4 --
+-- --
+-- 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. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains the routine used for the 'Fore attribute for decimal
+-- fixed point types up to 64-bit mantissa.
+
+with Interfaces;
+with System.Fore_D;
+
+package System.Fore_Decimal_64 is
+ pragma Pure;
+
+ subtype Int64 is Interfaces.Integer_64;
+
+ package Impl is new Fore_D (Int64);
+
+ function Fore_Decimal64 (Lo, Hi : Int64; Scale : Integer) return Natural
+ renames Impl.Fore_Decimal;
+
+end System.Fore_Decimal_64;
diff --git a/gcc/ada/libgnat/s-fofi128.ads b/gcc/ada/libgnat/s-fofi128.ads
new file mode 100644
index 0000000..aaa117f
--- /dev/null
+++ b/gcc/ada/libgnat/s-fofi128.ads
@@ -0,0 +1,50 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . F O F I _ 1 2 8 --
+-- --
+-- 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. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains the routine used for the 'Fore attribute for ordinary
+-- fixed point types up to 128-bit small and mantissa.
+
+with Interfaces;
+with System.Arith_128;
+with System.Fore_F;
+
+package System.Fore_Fixed_128 is
+ pragma Pure;
+
+ subtype Int128 is Interfaces.Integer_128;
+
+ package Impl is new Fore_F (Int128, Arith_128.Scaled_Divide128);
+
+ function Fore_Fixed128
+ (Lo, Hi, Num, Den : Int128; Scale : Integer) return Natural
+ renames Impl.Fore_Fixed;
+
+end System.Fore_Fixed_128;
diff --git a/gcc/ada/libgnat/s-fofi32.ads b/gcc/ada/libgnat/s-fofi32.ads
new file mode 100644
index 0000000..cf94fb8
--- /dev/null
+++ b/gcc/ada/libgnat/s-fofi32.ads
@@ -0,0 +1,50 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . F O R E _ F I X E D _ 3 2 --
+-- --
+-- 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. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains the routine used for the 'Fore attribute for ordinary
+-- fixed point types up to 32-bit small and mantissa.
+
+with Interfaces;
+with System.Arith_32;
+with System.Fore_F;
+
+package System.Fore_Fixed_32 is
+ pragma Pure;
+
+ subtype Int32 is Interfaces.Integer_32;
+
+ package Impl is new Fore_F (Int32, Arith_32.Scaled_Divide32);
+
+ function Fore_Fixed32
+ (Lo, Hi, Num, Den : Int32; Scale : Integer) return Natural
+ renames Impl.Fore_Fixed;
+
+end System.Fore_Fixed_32;
diff --git a/gcc/ada/libgnat/s-fofi64.ads b/gcc/ada/libgnat/s-fofi64.ads
new file mode 100644
index 0000000..cdde204
--- /dev/null
+++ b/gcc/ada/libgnat/s-fofi64.ads
@@ -0,0 +1,50 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . F O R E _ F I X E D _ 6 4 --
+-- --
+-- 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. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains the routine used for the 'Fore attribute for ordinary
+-- fixed point types up to 64-bit small and mantissa.
+
+with Interfaces;
+with System.Arith_64;
+with System.Fore_F;
+
+package System.Fore_Fixed_64 is
+ pragma Pure;
+
+ subtype Int64 is Interfaces.Integer_64;
+
+ package Impl is new Fore_F (Int64, Arith_64.Scaled_Divide64);
+
+ function Fore_Fixed64
+ (Lo, Hi, Num, Den : Int64; Scale : Integer) return Natural
+ renames Impl.Fore_Fixed;
+
+end System.Fore_Fixed_64;
diff --git a/gcc/ada/libgnat/s-fore_d.adb b/gcc/ada/libgnat/s-fore_d.adb
new file mode 100644
index 0000000..1141c67
--- /dev/null
+++ b/gcc/ada/libgnat/s-fore_d.adb
@@ -0,0 +1,62 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . F O R E _ D --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+package body System.Fore_D is
+
+ ------------------
+ -- Fore_Decimal --
+ ------------------
+
+ function Fore_Decimal (Lo, Hi : Int; Scale : Integer) return Natural is
+
+ function Negative_Abs (Val : Int) return Int is
+ (if Val <= 0 then Val else -Val);
+ -- Return the opposite of the absolute value of Val
+
+ T : Int := Int'Min (Negative_Abs (Lo), Negative_Abs (Hi));
+ F : Natural;
+
+ begin
+ -- Initial value of 2 allows for sign and mandatory single digit
+
+ F := 2;
+
+ -- Loop to increase Fore as needed to include full range of values
+
+ while T <= -10 loop
+ T := T / 10;
+ F := F + 1;
+ end loop;
+
+ return Natural'Max (F - Scale, 2);
+ end Fore_Decimal;
+
+end System.Fore_D;
diff --git a/gcc/ada/libgnat/s-fore_d.ads b/gcc/ada/libgnat/s-fore_d.ads
new file mode 100644
index 0000000..25e3449
--- /dev/null
+++ b/gcc/ada/libgnat/s-fore_d.ads
@@ -0,0 +1,47 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . F O R E _ D --
+-- --
+-- 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. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains the routine used for the Fore attribute of decimal
+-- fixed point types.
+
+generic
+
+ type Int is range <>;
+
+package System.Fore_D is
+ pragma Pure;
+
+ function Fore_Decimal (Lo, Hi : Int; Scale : Integer) return Natural;
+ -- Compute Fore attribute value for a decimal fixed point type. The
+ -- parameters are the low and high bounds (in units of delta) and the
+ -- scale.
+
+end System.Fore_D;
diff --git a/gcc/ada/libgnat/s-fore_f.adb b/gcc/ada/libgnat/s-fore_f.adb
new file mode 100644
index 0000000..c9c476d
--- /dev/null
+++ b/gcc/ada/libgnat/s-fore_f.adb
@@ -0,0 +1,136 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . F O R E _ F --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+package body System.Fore_F is
+
+ Maxdigs : constant Natural := Int'Width - 2;
+ -- Maximum number of decimal digits that can be represented in an Int.
+ -- 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,
+ -- Integer_64'Width is 20 since the maximum value is approximately 9.2E+18
+ -- and has 19 digits, but the maximum number of 9's that can be represented
+ -- in Integer_64 is only 18.
+
+ -- The first prerequisite of the implementation is that the scaled divide
+ -- does not overflow, which means that the absolute value of the bounds of
+ -- the subtype must be smaller than 10**Maxdigs * 2**(Int'Size - 1).
+ -- Otherwise Constraint_Error is raised by the scaled divide operation.
+
+ -- The second prerequisite is that the computation of the operands does not
+ -- overflow, which means that, if the small is larger than 1, it is either
+ -- an integer or its numerator and denominator must be both smaller than
+ -- the power 10**(Maxdigs - 1).
+
+ ----------------
+ -- Fore_Fixed --
+ ----------------
+
+ function Fore_Fixed (Lo, Hi, Num, Den : Int; Scale : Integer) return Natural
+ is
+ pragma Assert (Num < 0 and then Den < 0);
+ -- Accept only negative numbers to allow -2**(Int'Size - 1)
+
+ function Negative_Abs (Val : Int) return Int is
+ (if Val <= 0 then Val else -Val);
+ -- Return the opposite of the absolute value of Val
+
+ T : Int := Int'Min (Negative_Abs (Lo), Negative_Abs (Hi));
+ F : Natural;
+
+ Q, R : Int;
+
+ begin
+ -- Initial value of 2 allows for sign and mandatory single digit
+
+ F := 2;
+
+ -- The easy case is when Num is not larger than Den in magnitude,
+ -- i.e. if S = Num / Den, then S <= 1, in which case we can just
+ -- compute the product Q = T * S.
+
+ if Num >= Den then
+ Scaled_Divide (T, Num, Den, Q, R, Round => False);
+ T := Q;
+
+ -- Otherwise S > 1 and thus Scale <= 0, compute Q and R such that
+
+ -- T * Num = Q * (Den * 10**(-D)) + R
+
+ -- with
+
+ -- D = Integer'Max (-Maxdigs, Scale - 1)
+
+ -- then reason on Q if it is non-zero or else on R / Den.
+
+ -- This works only if Den * 10**(-D) does not overflow, which is true
+ -- if Den = 1. Suppose that Num corresponds to the maximum value of -D,
+ -- i.e. Maxdigs and 10**(-D) = 10**Maxdigs. If you change Den into 10,
+ -- then S becomes 10 times smaller and, therefore, Scale is incremented
+ -- by 1, which means that -D is decremented by 1 provided that Scale was
+ -- initially not smaller than 1 - Maxdigs, so the multiplication still
+ -- does not overflow. But you need to reach 10 to trigger this effect,
+ -- which means that a leeway of 10 is required, so let's restrict this
+ -- to a Num for which 10**(-D) <= 10**(Maxdigs - 1). To sum up, if S is
+ -- the ratio of two integers with
+
+ -- 1 < Den < Num <= B
+
+ -- where B is a fixed limit, then the multiplication does not overflow.
+ -- B can be taken as the largest integer Small such that D = 1 - Maxdigs
+ -- i.e. such that Scale = 2 - Maxdigs, which is 10**(Maxdigs - 1) - 1.
+
+ else
+ declare
+ D : constant Integer := Integer'Max (-Maxdigs, Scale - 1);
+
+ begin
+ Scaled_Divide (T, Num, Den * 10**(-D), Q, R, Round => False);
+
+ if Q /= 0 then
+ T := Q;
+ F := F - D;
+ else
+ T := R / Den;
+ end if;
+ end;
+ end if;
+
+ -- Loop to increase Fore as needed to include full range of values
+
+ while T <= -10 or else T >= 10 loop
+ T := T / 10;
+ F := F + 1;
+ end loop;
+
+ return F;
+ end Fore_Fixed;
+
+end System.Fore_F;
diff --git a/gcc/ada/libgnat/s-fore_f.ads b/gcc/ada/libgnat/s-fore_f.ads
new file mode 100644
index 0000000..cf6d983
--- /dev/null
+++ b/gcc/ada/libgnat/s-fore_f.ads
@@ -0,0 +1,54 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . F O R E _ F --
+-- --
+-- 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. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains the routine used for the Fore attribute of ordinary
+-- fixed point types whose Small is the ratio of two Int values.
+
+generic
+
+ type Int is range <>;
+
+ with procedure Scaled_Divide
+ (X, Y, Z : Int;
+ Q, R : out Int;
+ Round : Boolean);
+
+package System.Fore_F is
+ pragma Pure;
+
+ function Fore_Fixed
+ (Lo, Hi, Num, Den : Int; Scale : Integer) return Natural;
+ -- Compute Fore attribute value for an ordinary fixed point type. The
+ -- parameters are the low and high bounds (in units of small), the small
+ -- Num/Den and the associated scale, which is the smallest integer N such
+ -- that 10**N * (Num/Den) is greater or equal to 1, if it is nonpositive.
+
+end System.Fore_F;
diff --git a/gcc/ada/libgnat/s-fore.adb b/gcc/ada/libgnat/s-forrea.adb
index 2a4aa81..cb74dc6 100644
--- a/gcc/ada/libgnat/s-fore.adb
+++ b/gcc/ada/libgnat/s-forrea.adb
@@ -2,7 +2,7 @@
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
--- S Y S T E M . F O R E --
+-- S Y S T E M . F O R E _ R E A L --
-- --
-- B o d y --
-- --
@@ -29,28 +29,29 @@
-- --
------------------------------------------------------------------------------
-package body System.Fore is
+package body System.Fore_Real is
- ----------
- -- Fore --
- ----------
+ ---------------
+ -- Fore_Real --
+ ---------------
- function Fore (Lo, Hi : Long_Long_Float) return Natural is
+ function Fore_Real (Lo, Hi : Long_Long_Float) return Natural is
T : Long_Long_Float := Long_Long_Float'Max (abs Lo, abs Hi);
- R : Natural;
+ F : Natural;
begin
-- Initial value of 2 allows for sign and mandatory single digit
- R := 2;
+ F := 2;
-- Loop to increase Fore as needed to include full range of values
while T >= 10.0 loop
T := T / 10.0;
- R := R + 1;
+ F := F + 1;
end loop;
- return R;
- end Fore;
-end System.Fore;
+ return F;
+ end Fore_Real;
+
+end System.Fore_Real;
diff --git a/gcc/ada/libgnat/s-fore.ads b/gcc/ada/libgnat/s-forrea.ads
index 7d78952..6b0a211 100644
--- a/gcc/ada/libgnat/s-fore.ads
+++ b/gcc/ada/libgnat/s-forrea.ads
@@ -2,7 +2,7 @@
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
--- S Y S T E M . F O R E --
+-- S Y S T E M . F O R E _ R E A L --
-- --
-- S p e c --
-- --
@@ -29,13 +29,14 @@
-- --
------------------------------------------------------------------------------
--- This package contains the routine used for the 'Fore attribute
+-- This package contains the routine used for the Fore attribute of ordinary
+-- fixed point types whose Small is neither an integer nor its reciprocal.
-package System.Fore is
+package System.Fore_Real is
pragma Pure;
- function Fore (Lo, Hi : Long_Long_Float) return Natural;
- -- Compute Fore attribute value for a fixed-point type. The parameters
- -- are the low and high bounds values, converted to Long_Long_Float.
+ function Fore_Real (Lo, Hi : Long_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.
-end System.Fore;
+end System.Fore_Real;
diff --git a/gcc/ada/libgnat/s-genbig.adb b/gcc/ada/libgnat/s-genbig.adb
index 12167ac..bf222ac 100644
--- a/gcc/ada/libgnat/s-genbig.adb
+++ b/gcc/ada/libgnat/s-genbig.adb
@@ -1193,7 +1193,7 @@ package body System.Generic_Bignums is
return To_Bignum (Long_Long_Long_Integer (X));
end To_Bignum;
- function To_Bignum (X : Unsigned_64) return Big_Integer is
+ function To_Bignum (X : Unsigned_128) return Big_Integer is
begin
if X = 0 then
return Allocate_Big_Integer ((1 .. 0 => <>), False);
@@ -1205,11 +1205,33 @@ package body System.Generic_Bignums is
-- Two word result
- else
+ elsif Shift_Right (X, 32) < 2 ** 32 then
return Allocate_Big_Integer ((SD (X / Base), SD (X mod Base)), False);
+
+ -- Three or four word result
+
+ else
+ declare
+ Vector : Digit_Vector (1 .. 4);
+ High : constant Unsigned_64 := Unsigned_64 (Shift_Right (X, 64));
+ Low : constant Unsigned_64 :=
+ Unsigned_64 (X and 16#FFFF_FFFF_FFFF_FFFF#);
+
+ begin
+ Vector (1) := SD (High / Base);
+ Vector (2) := SD (High mod Base);
+ Vector (3) := SD (Low / Base);
+ Vector (4) := SD (Low mod Base);
+ return Normalize (Vector, False);
+ end;
end if;
end To_Bignum;
+ function To_Bignum (X : Unsigned_64) return Big_Integer is
+ begin
+ return To_Bignum (Unsigned_128 (X));
+ end To_Bignum;
+
---------------
-- To_String --
---------------
diff --git a/gcc/ada/libgnat/s-genbig.ads b/gcc/ada/libgnat/s-genbig.ads
index 81e3843..be8340e 100644
--- a/gcc/ada/libgnat/s-genbig.ads
+++ b/gcc/ada/libgnat/s-genbig.ads
@@ -109,6 +109,10 @@ package System.Generic_Bignums is
-- Convert Unsigned_64 to a big integer. No exception can be raised for any
-- input argument.
+ function To_Bignum (X : Interfaces.Unsigned_128) return Big_Integer;
+ -- Convert Unsigned_128 to a big integer. No exception can be raised for
+ -- any input argument.
+
function From_Bignum (X : Bignum) return Long_Long_Integer;
-- Convert Bignum to Long_Long_Integer. Constraint_Error raised with
-- appropriate message if value is out of range of Long_Long_Integer.
diff --git a/gcc/ada/libgnat/s-imglld.adb b/gcc/ada/libgnat/s-imaged.adb
index c70f409..726b9d8 100644
--- a/gcc/ada/libgnat/s-imglld.adb
+++ b/gcc/ada/libgnat/s-imaged.adb
@@ -2,11 +2,11 @@
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
--- S Y S T E M . I M G _ L L D --
+-- S Y S T E M . I M A G E _ D --
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -29,16 +29,16 @@
-- --
------------------------------------------------------------------------------
-with System.Img_Dec; use System.Img_Dec;
+with System.Img_Util; use System.Img_Util;
-package body System.Img_LLD is
+package body System.Image_D is
- -----------------------------
- -- Image_Long_Long_Decimal --
- ----------------------------
+ -------------------
+ -- Image_Decimal --
+ -------------------
- procedure Image_Long_Long_Decimal
- (V : Long_Long_Integer;
+ procedure Image_Decimal
+ (V : Int;
S : in out String;
P : out Natural;
Scale : Integer)
@@ -55,16 +55,15 @@ package body System.Img_LLD is
P := 0;
end if;
- Set_Image_Long_Long_Decimal
- (V, S, P, Scale, 1, Integer'Max (1, Scale), 0);
- end Image_Long_Long_Decimal;
+ Set_Image_Decimal (V, S, P, Scale, 1, Integer'Max (1, Scale), 0);
+ end Image_Decimal;
- ---------------------------------
- -- Set_Image_Long_Long_Decimal --
- ---------------------------------
+ -----------------------
+ -- Set_Image_Decimal --
+ -----------------------
- procedure Set_Image_Long_Long_Decimal
- (V : Long_Long_Integer;
+ procedure Set_Image_Decimal
+ (V : Int;
S : in out String;
P : in out Natural;
Scale : Integer;
@@ -72,11 +71,11 @@ package body System.Img_LLD is
Aft : Natural;
Exp : Natural)
is
- Digs : String := Long_Long_Integer'Image (V);
+ Digs : String := Int'Image (V);
-- Sign and digits of decimal value
begin
Set_Decimal_Digits (Digs, Digs'Length, S, P, Scale, Fore, Aft, Exp);
- end Set_Image_Long_Long_Decimal;
+ end Set_Image_Decimal;
-end System.Img_LLD;
+end System.Image_D;
diff --git a/gcc/ada/libgnat/s-imglld.ads b/gcc/ada/libgnat/s-imaged.ads
index fdb25b4..5c3f82a 100644
--- a/gcc/ada/libgnat/s-imglld.ads
+++ b/gcc/ada/libgnat/s-imaged.ads
@@ -2,11 +2,11 @@
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
--- S Y S T E M . I M G _ L L D --
+-- S Y S T E M . I M A G E _ D --
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -29,26 +29,31 @@
-- --
------------------------------------------------------------------------------
--- Image for decimal fixed types where the size of the corresponding integer
--- type does exceeds Integer'Size (also used for Text_IO.Decimal_IO output)
+-- This package contains the routines for supporting the Image attribute for
+-- decimal fixed point types, and also for conversion operations required in
+-- Text_IO.Decimal_IO for such types.
-package System.Img_LLD is
+generic
+
+ type Int is range <>;
+
+package System.Image_D is
pragma Pure;
- procedure Image_Long_Long_Decimal
- (V : Long_Long_Integer;
+ procedure Image_Decimal
+ (V : Int;
S : in out String;
P : out Natural;
Scale : Integer);
-- Computes fixed_type'Image (V), where V is the integer value (in units of
- -- delta) of a decimal type whose Scale is as given and store the result in
- -- S (P + 1 .. L), updating P to the value of L. The image is given by the
+ -- delta) of a decimal type whose Scale is as given and stores the result
+ -- S (1 .. P), updating P to the value of L. The image is given by the
-- rules in RM 3.5(34) for fixed-point type image functions. The caller
- -- guarantees that S is long enough to hold the result. S need not have a
- -- lower bound of 1.
+ -- guarantees that S is long enough to hold the result and has a lower
+ -- bound of 1.
- procedure Set_Image_Long_Long_Decimal
- (V : Long_Long_Integer;
+ procedure Set_Image_Decimal
+ (V : Int;
S : in out String;
P : in out Natural;
Scale : Integer;
@@ -56,12 +61,12 @@ package System.Img_LLD is
Aft : Natural;
Exp : Natural);
-- Sets the image of V, where V is the integer value (in units of delta)
- -- of a decimal type with the given Scale, 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
+ -- of a decimal type with the specified Scale, starting at S (P + 1) and
+ -- updating P to point to the last character stored, the caller promises
+ -- that the buffer is large enough and no check is made. Constraint_Error
-- will not necessarily be raised if this requirement 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
- -- by Text_IO.Decimal_IO. Note that there is no leading space stored.
+ -- by Text_IO.Decimal_IO.
-end System.Img_LLD;
+end System.Image_D;
diff --git a/gcc/ada/libgnat/s-imagef.adb b/gcc/ada/libgnat/s-imagef.adb
new file mode 100644
index 0000000..94a7a2f
--- /dev/null
+++ b/gcc/ada/libgnat/s-imagef.adb
@@ -0,0 +1,362 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . I M A G E _ F --
+-- --
+-- 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 System.Image_I;
+with System.Img_Util; use System.Img_Util;
+
+package body System.Image_F is
+
+ Maxdigs : constant Natural := Int'Width - 2;
+ -- Maximum number of decimal digits that can be represented in an Int.
+ -- 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,
+ -- Integer_64'Width is 20 since the maximum value is approximately 9.2E+18
+ -- and has 19 digits, but the maximum number of 9's that can be represented
+ -- in Integer_64 is only 18.
+
+ -- The first prerequisite of the implementation is that the first scaled
+ -- divide does not overflow, which means that the absolute value of the
+ -- input X must always be smaller than 10**Maxdigs * 2**(Int'Size - 1).
+ -- Otherwise Constraint_Error is raised by the scaled divide operation.
+
+ -- The second prerequisite of the implementation is that the computation
+ -- of the operands does not overflow when the small is neither an integer
+ -- nor the reciprocal of an integer, which means that its numerator and
+ -- denominator must be smaller than 10**(2*Maxdigs-1) / 2**(Int'Size - 1)
+ -- if the small is larger than 1, and smaller than 2**(Int'Size - 1) / 10
+ -- if the small is smaller than 1.
+
+ package Image_I is new System.Image_I (Int);
+
+ procedure Set_Image_Integer
+ (V : Int;
+ S : in out String;
+ P : in out Natural)
+ renames Image_I.Set_Image_Integer;
+
+ -- The following section describes a specific implementation choice for
+ -- performing base conversions needed for output of values of a fixed
+ -- point type T with small T'Small. The goal is to be able to output
+ -- all values of fixed point types with a precision of 64 bits and a
+ -- small in the range 2.0**(-63) .. 2.0**63. The reasoning can easily
+ -- be adapted to fixed point types with a precision of 32 or 128 bits.
+
+ -- The chosen algorithm uses fixed precision integer arithmetic for
+ -- reasons of simplicity and efficiency. It is important to understand
+ -- in what ways the most simple and accurate approach to fixed point I/O
+ -- is limiting, before considering more complicated schemes.
+
+ -- Without loss of generality assume T has a range (-2.0**63) * T'Small
+ -- .. (2.0**63 - 1) * T'Small, and is output with Aft digits after the
+ -- decimal point and T'Fore - 1 before. If T'Small is integer, or
+ -- 1.0 / T'Small is integer, let S = T'Small.
+
+ -- The idea is to convert a value X * S of type T to a 64-bit integer value
+ -- Q equal to 10.0**D * (X * S) rounded to the nearest integer, using only
+ -- a scaled integer divide of the form
+
+ -- Q = (X * Y) / Z,
+
+ -- where the variables X, Y, Z are 64-bit integers, and both multiplication
+ -- and division are done using full intermediate precision. Then the final
+ -- decimal value to be output is
+
+ -- Q * 10**(-D)
+
+ -- This value can be written to the output file or to the result string
+ -- according to the format described in RM A.3.10. The details of this
+ -- operation are omitted here.
+
+ -- A 64-bit value can represent all integers with 18 decimal digits, but
+ -- not all with 19 decimal digits. If the total number of requested ouput
+ -- digits (Fore - 1) + Aft is greater than 18 then, for purposes of the
+ -- conversion, Aft is adjusted to 18 - (Fore - 1). In that case, trailing
+ -- zeros can complete the output after writing the first 18 significant
+ -- digits, or the technique described in the next section can be used.
+ -- In addition, D cannot be smaller than -18, in order for 10.0**(-D) to
+ -- fit in a 64-bit integer.
+
+ -- The final expression for D is
+
+ -- D = Integer'Max (-18, Integer'Min (Aft, 18 - (Fore - 1)));
+
+ -- For Y and Z the following expressions can be derived:
+
+ -- Q = X * S * (10.0**D) = (X * Y) / Z
+
+ -- If S is an integer greater than or equal to one, then Fore must be at
+ -- least 20 in order to print T'First, which is at most -2.0**63. This
+ -- means that D < 0, so use
+
+ -- (1) Y = -S and Z = -10**(-D)
+
+ -- If 1.0 / S is an integer greater than one, use
+
+ -- (2) Y = -10**D and Z = -(1.0 / S), for D >= 0
+
+ -- or
+
+ -- (3) Y = -1 and Z = -(1.0 / S) * 10**(-D), for D < 0
+
+ -- Negative values are used for nominator Y and denominator Z, so that S
+ -- can have a maximum value of 2.0**63 and a minimum of 2.0**(-63). For
+ -- -(1.0 / S) in -1 .. -9, Fore will still be 20, and D will be negative,
+ -- as (-2.0**63) / -9 is greater than 10**18. In these cases there is room
+ -- in the denominator for the extra decimal scaling required, so case (3)
+ -- will not overflow.
+
+ -- In fact this reasoning can be generalized to most S which are the ratio
+ -- of two integers with bounded magnitude. Let S = Num / Den and rewrite
+ -- case (1) above where Den = 1 into
+
+ -- (1b) Y = -Num and Z = -Den * 10**(-D)
+
+ -- Suppose that Num corresponds to the maximum value of -D, i.e. 18 and
+ -- 10**(-D) = 10**18. If you change Den into 10, then S becomes 10 times
+ -- smaller and, therefore, Fore is decremented by 1, which means that -D
+ -- is as well, provided that Fore was initially not larger than 37, so the
+ -- multiplication for Z still does not overflow. But you need to reach 10
+ -- to trigger this effect, which means that a leeway of 10 is required, so
+ -- let's restrict this to a Num for which 10**(-D) <= 10**17. To summarize
+ -- this case, if S is the ratio of two integers with
+
+ -- Den < Num <= B1
+
+ -- where B1 is a fixed limit, then case (1b) does not overflow. B1 can be
+ -- taken as the largest integer Small such that D = -17, i.e. Fore = 36,
+ -- which means that B1 * 2.0**63 must be smaller than 10**35.
+
+ -- Let's continue and rewrite case (2) above when Num = 1 into
+
+ -- (2b) Y = -Num * 10**D and Z = -Den, for D >= 0
+
+ -- Note that D <= 18 - (Fore - 1) and Fore >= 2 so D <= 17, thus you can
+ -- safely change Num into 10 in the product, but then S becomes 10 times
+ -- larger and, therefore, Fore is incremented by 1, which means that D is
+ -- decremented by 1 so you again have a product lesser or equal to 10**17.
+ -- To sum up, if S is the ratio of two integers with
+
+ -- Num <= Den * S0
+
+ -- where S0 is the largest Small such that D >= 0, then case (2b) does not
+ -- overflow.
+
+ -- Let's conclude and rewrite case (3) above when Num = 1 into
+
+ -- (3b) Y = -Num and Z = -Den * 10**(-D), for D < 0
+
+ -- As explained above, this occurs only if both S0 < S < 1 and D = -1 and
+ -- is preserved if you scale up Num and Den simultaneously, what you can
+ -- do until Den * 10 tops the upper bound. To sum up, if S is the ratio of
+ -- two integers with
+
+ -- Den * S0 < Num < Den <= B2
+
+ -- where B2 is a fixed limit, then case (3b) does not overflow. B2 can be
+ -- taken as the largest integer such that B2 * 10 is smaller than 2.0**63.
+
+ -- The conclusion is that the algorithm works if the small is the ratio of
+ -- two integers in the range 1 .. 2**63 if either is equal to 1, or of two
+ -- integers in the range 1 .. B1 if the small is larger than 1, or of two
+ -- integers in the range 1 .. B2 if the small is smaller than 1.
+
+ -- Using a scaled divide which truncates and returns a remainder R,
+ -- another K trailing digits can be calculated by computing the value
+ -- (R * (10.0**K)) / Z using another scaled divide. This procedure
+ -- can be repeated to compute an arbitrary number of digits in linear
+ -- time and storage. The last scaled divide should be rounded, with
+ -- a possible carry propagating to the more significant digits, to
+ -- ensure correct rounding of the unit in the last place.
+
+ -----------------
+ -- Image_Fixed --
+ -----------------
+
+ procedure Image_Fixed
+ (V : Int;
+ S : in out String;
+ P : out Natural;
+ Num : Int;
+ Den : Int;
+ For0 : Natural;
+ Aft0 : Natural)
+ is
+ pragma Assert (S'First = 1);
+
+ begin
+ -- Add space at start for non-negative numbers
+
+ if V >= 0 then
+ S (1) := ' ';
+ P := 1;
+ else
+ P := 0;
+ end if;
+
+ Set_Image_Fixed (V, S, P, Num, Den, For0, Aft0, 1, Aft0, 0);
+ end Image_Fixed;
+
+ ---------------------
+ -- Set_Image_Fixed --
+ ---------------------
+
+ procedure Set_Image_Fixed
+ (V : Int;
+ S : in out String;
+ P : in out Natural;
+ Num : Int;
+ Den : Int;
+ For0 : Natural;
+ Aft0 : Natural;
+ Fore : Natural;
+ Aft : Natural;
+ Exp : Natural)
+ is
+ pragma Assert (Num < 0 and then Den < 0);
+ -- Accept only negative numbers to allow -2**(Int'Size - 1)
+
+ A : constant Natural :=
+ Boolean'Pos (Exp > 0) * Aft0 + Natural'Max (Aft, 1) + 1;
+ -- Number of digits after the decimal point to be computed. If Exp is
+ -- positive, we need to compute Aft decimal digits after the first non
+ -- zero digit and we are guaranteed there is at least one in the first
+ -- Aft0 digits (unless V is zero). In both cases, we compute one more
+ -- digit than requested so that Set_Decimal_Digits can round at Aft.
+
+ D : constant Integer :=
+ Integer'Max (-Maxdigs, Integer'Min (A, Maxdigs - (For0 - 1)));
+ Y : constant Int := Num * 10**Integer'Max (0, D);
+ Z : constant Int := Den * 10**Integer'Max (0, -D);
+ -- See the description of the algorithm above
+
+ AF : constant Natural := A - D;
+ -- Number of remaining digits to be computed after the first round. It
+ -- is larger than A if the first round does not compute all the digits
+ -- before the decimal point, i.e. (For0 - 1) larger than Maxdigs.
+
+ N : constant Natural := 1 + (AF + Maxdigs - 1) / Maxdigs;
+ -- Number of rounds of scaled divide to be performed
+
+ Q : Int;
+ -- Quotient of the scaled divide in this round. Only the first round may
+ -- yield more than Maxdigs digits and has a significant sign.
+
+ Buf : String (1 .. Maxdigs);
+ Len : Natural;
+ -- Buffer for the image of the quotient
+
+ Digs : String (1 .. 2 + N * Maxdigs);
+ Ndigs : Natural;
+ -- Concatenated image of the successive quotients
+
+ Scale : Integer := 0;
+ -- Exponent such that the result is Digs (1 .. NDigs) * 10**(-Scale)
+
+ XX : Int := V;
+ YY : Int := Y;
+ -- First two operands of the scaled divide
+
+ begin
+ -- Set the first character like Image
+
+ if V >= 0 then
+ Digs (1) := ' ';
+ Ndigs := 1;
+ else
+ Ndigs := 0;
+ end if;
+
+ for J in 1 .. N loop
+ exit when XX = 0;
+
+ Scaled_Divide (XX, YY, Z, Q, R => XX, Round => False);
+
+ if J = 1 then
+ if Q /= 0 then
+ Set_Image_Integer (Q, Digs, Ndigs);
+ end if;
+
+ Scale := Scale + D;
+
+ -- Prepare for next round, if any
+
+ YY := 10**Maxdigs;
+
+ else
+ pragma Assert (-10**Maxdigs < Q and then Q < 10**Maxdigs);
+
+ Len := 0;
+ Set_Image_Integer (abs Q, Buf, Len);
+
+ pragma Assert (1 <= Len and then Len <= Maxdigs);
+
+ -- If no character but the space has been written, write the
+ -- minus if need be, since Set_Image_Integer did not do it.
+
+ if Ndigs <= 1 then
+ if Q /= 0 then
+ if Ndigs = 0 then
+ Digs (1) := '-';
+ end if;
+
+ Digs (2 .. Len + 1) := Buf (1 .. Len);
+ Ndigs := Len + 1;
+ end if;
+
+ -- Or else pad the output with zeroes up to Maxdigs
+
+ else
+ for K in 1 .. Maxdigs - Len loop
+ Digs (Ndigs + K) := '0';
+ end loop;
+
+ for K in 1 .. Len loop
+ Digs (Ndigs + Maxdigs - Len + K) := Buf (K);
+ end loop;
+
+ Ndigs := Ndigs + Maxdigs;
+ end if;
+
+ Scale := Scale + Maxdigs;
+ end if;
+ end loop;
+
+ -- If no digit was output, this is zero
+
+ if Ndigs <= 1 then
+ Digs (1 .. 2) := " 0";
+ Ndigs := 2;
+ end if;
+
+ Set_Decimal_Digits (Digs, Ndigs, S, P, Scale, Fore, Aft, Exp);
+ end Set_Image_Fixed;
+
+end System.Image_F;
diff --git a/gcc/ada/libgnat/s-imgdec.ads b/gcc/ada/libgnat/s-imagef.ads
index d45a05f..ace7e6b 100644
--- a/gcc/ada/libgnat/s-imgdec.ads
+++ b/gcc/ada/libgnat/s-imagef.ads
@@ -2,11 +2,11 @@
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
--- S Y S T E M . I M G _ D E C --
+-- S Y S T E M . I M A G E _ F --
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -29,55 +29,60 @@
-- --
------------------------------------------------------------------------------
--- Image for decimal fixed types where the size of the corresponding integer
--- type does not exceed Integer'Size (also used for Text_IO.Decimal_IO output)
+-- This package contains the routines for supporting the Image attribute for
+-- ordinary fixed point types whose Small is the ratio of two Int values, and
+-- also for conversion operations required in Text_IO.Fixed_IO for such types.
-package System.Img_Dec is
+generic
+
+ type Int is range <>;
+
+ with procedure Scaled_Divide
+ (X, Y, Z : Int;
+ Q, R : out Int;
+ Round : Boolean);
+
+package System.Image_F is
pragma Pure;
- procedure Image_Decimal
- (V : Integer;
- S : in out String;
- P : out Natural;
- Scale : Integer);
+ procedure Image_Fixed
+ (V : Int;
+ S : in out String;
+ P : out Natural;
+ Num : Int;
+ Den : Int;
+ For0 : Natural;
+ Aft0 : Natural);
-- Computes fixed_type'Image (V), where V is the integer value (in units of
- -- delta) of a decimal type whose Scale is as given and stores the result
- -- S (1 .. P), updating P to the value of L. The image is given by the
- -- rules in RM 3.5(34) for fixed-point type image functions. The caller
- -- guarantees that S is long enough to hold the result. S need not have a
- -- lower bound of 1.
+ -- small) of an ordinary fixed point type with small Num/Den, and stores
+ -- 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)).
+ -- 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
+ -- ordinary fixed-point types). The caller guarantees that S is long enough
+ -- to hold the result and has a lower bound of 1.
- procedure Set_Image_Decimal
- (V : Integer;
- S : in out String;
- P : in out Natural;
- Scale : Integer;
- Fore : Natural;
- Aft : Natural;
- Exp : Natural);
- -- Sets the image of V, where V is the integer value (in units of delta)
- -- of a decimal type with the given Scale, 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
+ procedure Set_Image_Fixed
+ (V : Int;
+ S : in out String;
+ P : in out Natural;
+ Num : Int;
+ Den : Int;
+ For0 : Natural;
+ Aft0 : Natural;
+ Fore : Natural;
+ Aft : Natural;
+ Exp : Natural);
+ -- Sets the image of V, where V is the integer value (in units of small)
+ -- of a fixed point type with small Num/Den, starting at S (P + 1) and
+ -- updating P to point to the last character stored, the caller promises
+ -- that the buffer is large enough and no check is made. Constraint_Error
-- will not necessarily be raised if this requirement 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
- -- by Text_IO.Decimal_IO. Note that there is no leading space stored.
-
- procedure Set_Decimal_Digits
- (Digs : in out String;
- NDigs : Natural;
- S : out String;
- P : in out Natural;
- Scale : Integer;
- Fore : Natural;
- Aft : Natural;
- Exp : Natural);
- -- This procedure has the same semantics as Set_Image_Decimal, except that
- -- the value in Digs (1 .. NDigs) is given as a string of decimal digits
- -- preceded by either a minus sign or a space (i.e. the integer image of
- -- the value in units of delta). The call may destroy the value in Digs,
- -- which is why Digs is in-out (this happens if rounding is required).
- -- Set_Decimal_Digits is shared by all the decimal image routines.
+ -- it is perfectly valid to compile this unit with checks off. 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. The Fore,
+ -- Aft and Exp can be set to any valid values for use by Text_IO.Fixed_IO.
-end System.Img_Dec;
+end System.Image_F;
diff --git a/gcc/ada/libgnat/s-imagei.adb b/gcc/ada/libgnat/s-imagei.adb
index c739dfb..36c1f6f 100644
--- a/gcc/ada/libgnat/s-imagei.adb
+++ b/gcc/ada/libgnat/s-imagei.adb
@@ -56,8 +56,11 @@ package body System.Image_I is
if V >= 0 then
S (1) := ' ';
P := 1;
+ pragma Assert (P < S'Last);
+
else
P := 0;
+ pragma Assert (P < S'Last - 1);
end if;
Set_Image_Integer (V, S, P);
@@ -72,26 +75,31 @@ package body System.Image_I is
S : in out String;
P : in out Natural)
is
+ Nb_Digits : Natural := 0;
+ Value : Non_Positive := T;
begin
- if T <= -10 then
- Set_Digits (T / 10, S, P);
- pragma Assert (P >= (S'First - 1) and P < S'Last and
- P < Natural'Last);
- -- No check is done since, as documented in the Set_Image_Integer
- -- specification, the caller guarantees that S is long enough to
- -- hold the result.
- P := P + 1;
- S (P) := Character'Val (48 - (T rem 10));
+ pragma Assert (P >= S'First - 1 and P < S'Last);
+ -- No check is done since, as documented in the Set_Image_Integer
+ -- specification, the caller guarantees that S is long enough to
+ -- hold the result.
- else
- pragma Assert (P >= (S'First - 1) and P < S'Last and
- P < Natural'Last);
- -- No check is done since, as documented in the Set_Image_Integer
- -- specification, the caller guarantees that S is long enough to
- -- hold the result.
- P := P + 1;
- S (P) := Character'Val (48 - T);
- end if;
+ -- First we compute the number of characters needed for representing
+ -- the number.
+ loop
+ Value := Value / 10;
+ Nb_Digits := Nb_Digits + 1;
+ exit when Value = 0;
+ end loop;
+
+ Value := T;
+
+ -- We now populate digits from the end of the string to the beginning
+ for J in reverse 1 .. Nb_Digits loop
+ S (P + J) := Character'Val (48 - (Value rem 10));
+ Value := Value / 10;
+ end loop;
+
+ P := P + Nb_Digits;
end Set_Digits;
-----------------------
@@ -108,8 +116,7 @@ package body System.Image_I is
Set_Digits (-V, S, P);
else
- pragma Assert (P >= (S'First - 1) and P < S'Last and
- P < Natural'Last);
+ pragma Assert (P >= S'First - 1 and P < S'Last);
-- No check is done since, as documented in the specification,
-- the caller guarantees that S is long enough to hold the result.
P := P + 1;
diff --git a/gcc/ada/libgnat/s-imageu.adb b/gcc/ada/libgnat/s-imageu.adb
index c995d55..8ffb8f0 100644
--- a/gcc/ada/libgnat/s-imageu.adb
+++ b/gcc/ada/libgnat/s-imageu.adb
@@ -56,24 +56,31 @@ package body System.Image_U is
S : in out String;
P : in out Natural)
is
+ Nb_Digits : Natural := 0;
+ Value : Uns := V;
begin
- if V >= 10 then
- Set_Image_Unsigned (V / 10, S, P);
- pragma Assert (P >= (S'First - 1) and P < S'Last and
- P < Natural'Last);
- -- No check is done since, as documented in the specification,
- -- the caller guarantees that S is long enough to hold the result.
- P := P + 1;
- S (P) := Character'Val (48 + (V rem 10));
+ pragma Assert (P >= S'First - 1 and then P < S'Last and then
+ P < Natural'Last);
+ -- No check is done since, as documented in the specification, the
+ -- caller guarantees that S is long enough to hold the result.
- else
- pragma Assert (P >= (S'First - 1) and P < S'Last and
- P < Natural'Last);
- -- No check is done since, as documented in the specification,
- -- the caller guarantees that S is long enough to hold the result.
- P := P + 1;
- S (P) := Character'Val (48 + V);
- end if;
+ -- First we compute the number of characters needed for representing
+ -- the number.
+ loop
+ Value := Value / 10;
+ Nb_Digits := Nb_Digits + 1;
+ exit when Value = 0;
+ end loop;
+
+ Value := V;
+
+ -- We now populate digits from the end of the string to the beginning
+ for J in reverse 1 .. Nb_Digits loop
+ S (P + J) := Character'Val (48 + (Value rem 10));
+ Value := Value / 10;
+ end loop;
+
+ P := P + Nb_Digits;
end Set_Image_Unsigned;
end System.Image_U;
diff --git a/gcc/ada/libgnat/s-imde128.ads b/gcc/ada/libgnat/s-imde128.ads
new file mode 100644
index 0000000..cffd0c0
--- /dev/null
+++ b/gcc/ada/libgnat/s-imde128.ads
@@ -0,0 +1,63 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . I M G _ D E C I M A L _ 1 2 8 --
+-- --
+-- 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. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains the routines for supporting the Image attribute for
+-- decimal fixed point types up to 128-bit mantissa, and also for conversion
+-- operations required in Text_IO.Decimal_IO for them.
+
+with Interfaces;
+with System.Image_D;
+
+package System.Img_Decimal_128 is
+ pragma Pure;
+
+ subtype Int128 is Interfaces.Integer_128;
+
+ package Impl is new Image_D (Int128);
+
+ procedure Image_Decimal128
+ (V : Int128;
+ S : in out String;
+ P : out Natural;
+ Scale : Integer)
+ renames Impl.Image_Decimal;
+
+ procedure Set_Image_Decimal128
+ (V : Int128;
+ S : in out String;
+ P : in out Natural;
+ Scale : Integer;
+ Fore : Natural;
+ Aft : Natural;
+ Exp : Natural)
+ renames Impl.Set_Image_Decimal;
+
+end System.Img_Decimal_128;
diff --git a/gcc/ada/libgnat/s-imde32.ads b/gcc/ada/libgnat/s-imde32.ads
new file mode 100644
index 0000000..bf19e9c
--- /dev/null
+++ b/gcc/ada/libgnat/s-imde32.ads
@@ -0,0 +1,63 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . I M G _ D E C I M A L _ 3 2 --
+-- --
+-- 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. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains the routines for supporting the Image attribute for
+-- decimal fixed point types up to 32-bit mantissa, and also for conversion
+-- operations required in Text_IO.Decimal_IO for such types.
+
+with Interfaces;
+with System.Image_D;
+
+package System.Img_Decimal_32 is
+ pragma Pure;
+
+ subtype Int32 is Interfaces.Integer_32;
+
+ package Impl is new Image_D (Int32);
+
+ procedure Image_Decimal32
+ (V : Int32;
+ S : in out String;
+ P : out Natural;
+ Scale : Integer)
+ renames Impl.Image_Decimal;
+
+ procedure Set_Image_Decimal32
+ (V : Int32;
+ S : in out String;
+ P : in out Natural;
+ Scale : Integer;
+ Fore : Natural;
+ Aft : Natural;
+ Exp : Natural)
+ renames Impl.Set_Image_Decimal;
+
+end System.Img_Decimal_32;
diff --git a/gcc/ada/libgnat/s-imde64.ads b/gcc/ada/libgnat/s-imde64.ads
new file mode 100644
index 0000000..dfc8403
--- /dev/null
+++ b/gcc/ada/libgnat/s-imde64.ads
@@ -0,0 +1,63 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . I M G _ D E C I M A L _ 6 4 --
+-- --
+-- 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. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains the routines for supporting the Image attribute for
+-- decimal fixed point types up to 64-bit mantissa, and also for conversion
+-- operations required in Text_IO.Decimal_IO for such types.
+
+with Interfaces;
+with System.Image_D;
+
+package System.Img_Decimal_64 is
+ pragma Pure;
+
+ subtype Int64 is Interfaces.Integer_64;
+
+ package Impl is new Image_D (Int64);
+
+ procedure Image_Decimal64
+ (V : Int64;
+ S : in out String;
+ P : out Natural;
+ Scale : Integer)
+ renames Impl.Image_Decimal;
+
+ procedure Set_Image_Decimal64
+ (V : Int64;
+ S : in out String;
+ P : in out Natural;
+ Scale : Integer;
+ Fore : Natural;
+ Aft : Natural;
+ Exp : Natural)
+ renames Impl.Set_Image_Decimal;
+
+end System.Img_Decimal_64;
diff --git a/gcc/ada/libgnat/s-imfi128.ads b/gcc/ada/libgnat/s-imfi128.ads
new file mode 100644
index 0000000..24fdf97
--- /dev/null
+++ b/gcc/ada/libgnat/s-imfi128.ads
@@ -0,0 +1,69 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . I M G _ F I X E D _ 1 2 8 --
+-- --
+-- 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. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains the routines for supporting the Image attribute for
+-- ordinary fixed point types up to 128-bit small and mantissa.
+
+with Interfaces;
+with System.Arith_128;
+with System.Image_F;
+
+package System.Img_Fixed_128 is
+ pragma Pure;
+
+ subtype Int128 is Interfaces.Integer_128;
+
+ package Impl is new Image_F (Int128, Arith_128.Scaled_Divide128);
+
+ procedure Image_Fixed128
+ (V : Int128;
+ S : in out String;
+ P : out Natural;
+ Num : Int128;
+ Den : Int128;
+ For0 : Natural;
+ Aft0 : Natural)
+ renames Impl.Image_Fixed;
+
+ procedure Set_Image_Fixed128
+ (V : Int128;
+ S : in out String;
+ P : in out Natural;
+ Num : Int128;
+ Den : Int128;
+ For0 : Natural;
+ Aft0 : Natural;
+ Fore : Natural;
+ Aft : Natural;
+ Exp : Natural)
+ renames Impl.Set_Image_Fixed;
+
+end System.Img_Fixed_128;
diff --git a/gcc/ada/libgnat/s-imfi32.ads b/gcc/ada/libgnat/s-imfi32.ads
new file mode 100644
index 0000000..8c425df
--- /dev/null
+++ b/gcc/ada/libgnat/s-imfi32.ads
@@ -0,0 +1,69 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . I M G _ F I X E D _ 3 2 --
+-- --
+-- 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. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains the routines for supporting the Image attribute for
+-- ordinary fixed point types up to 32-bit small and mantissa.
+
+with Interfaces;
+with System.Arith_32;
+with System.Image_F;
+
+package System.Img_Fixed_32 is
+ pragma Pure;
+
+ subtype Int32 is Interfaces.Integer_32;
+
+ package Impl is new Image_F (Int32, Arith_32.Scaled_Divide32);
+
+ procedure Image_Fixed32
+ (V : Int32;
+ S : in out String;
+ P : out Natural;
+ Num : Int32;
+ Den : Int32;
+ For0 : Natural;
+ Aft0 : Natural)
+ renames Impl.Image_Fixed;
+
+ procedure Set_Image_Fixed32
+ (V : Int32;
+ S : in out String;
+ P : in out Natural;
+ Num : Int32;
+ Den : Int32;
+ For0 : Natural;
+ Aft0 : Natural;
+ Fore : Natural;
+ Aft : Natural;
+ Exp : Natural)
+ renames Impl.Set_Image_Fixed;
+
+end System.Img_Fixed_32;
diff --git a/gcc/ada/libgnat/s-imfi64.ads b/gcc/ada/libgnat/s-imfi64.ads
new file mode 100644
index 0000000..9045bf6
--- /dev/null
+++ b/gcc/ada/libgnat/s-imfi64.ads
@@ -0,0 +1,69 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . I M G _ F I X E D _ 6 4 --
+-- --
+-- 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. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains the routines for supporting the Image attribute for
+-- ordinary fixed point types up to 64-bit small and mantissa.
+
+with Interfaces;
+with System.Arith_64;
+with System.Image_F;
+
+package System.Img_Fixed_64 is
+ pragma Pure;
+
+ subtype Int64 is Interfaces.Integer_64;
+
+ package Impl is new Image_F (Int64, Arith_64.Scaled_Divide64);
+
+ procedure Image_Fixed64
+ (V : Int64;
+ S : in out String;
+ P : out Natural;
+ Num : Int64;
+ Den : Int64;
+ For0 : Natural;
+ Aft0 : Natural)
+ renames Impl.Image_Fixed;
+
+ procedure Set_Image_Fixed64
+ (V : Int64;
+ S : in out String;
+ P : in out Natural;
+ Num : Int64;
+ Den : Int64;
+ For0 : Natural;
+ Aft0 : Natural;
+ Fore : Natural;
+ Aft : Natural;
+ Exp : Natural)
+ renames Impl.Set_Image_Fixed;
+
+end System.Img_Fixed_64;
diff --git a/gcc/ada/libgnat/s-imgrea.adb b/gcc/ada/libgnat/s-imgrea.adb
index 45d0ae5..2ec6a1a 100644
--- a/gcc/ada/libgnat/s-imgrea.adb
+++ b/gcc/ada/libgnat/s-imgrea.adb
@@ -29,9 +29,9 @@
-- --
------------------------------------------------------------------------------
-with System.Img_LLU; use System.Img_LLU;
-with System.Img_Uns; use System.Img_Uns;
-with System.Powten_Table; use System.Powten_Table;
+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;
package body System.Img_Real is
@@ -47,10 +47,10 @@ package body System.Img_Real is
-- in very high precision floating-point output.
-- Note that in the following, the "-2" accounts for the sign and one
- -- extra digits, since we need the maximum number of 9's that can be
- -- supported, e.g. for the normal 64 bit case, Long_Long_Integer'Width
- -- is 21, since the maximum value (approx 1.6 * 10**19) has 20 digits,
- -- but the maximum number of 9's that can be supported is 19.
+ -- 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
@@ -58,7 +58,6 @@ package body System.Img_Real is
Unsdigs : constant := Unsigned'Width - 2;
-- Number of digits that can be converted using type Unsigned
- -- See above for the explanation of the -2.
Maxscaling : constant := 5000;
-- Max decimal scaling required during conversion of floating-point
@@ -88,11 +87,8 @@ package body System.Img_Real is
-- 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
- -- space only if Signed_Zeroes is True (the RM only permits the
- -- output of -0.0 on targets where this is the case). We can of
- -- course still see a -0.0 on a target where Signed_Zeroes is
- -- False (since this attribute refers to the proper handling of
- -- negative zeroes, not to their existence). We do not generate
+ -- 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)
@@ -150,7 +146,7 @@ package body System.Img_Real is
Exp : Natural)
is
NFrac : constant Natural := Natural'Max (Aft, 1);
- Sign : Character;
+ Minus : Boolean;
X : Long_Long_Float;
Scale : Integer;
Expon : Integer;
@@ -419,7 +415,7 @@ package body System.Img_Real is
procedure Set_Blanks_And_Sign (N : Integer) is
begin
- if Sign = '-' then
+ if Minus then
for J in 1 .. N - 1 loop
Set (' ');
end loop;
@@ -483,10 +479,10 @@ package body System.Img_Real is
-- Start of processing for Set_Image_Real
begin
- -- We call the floating-point processor reset routine so that we can
- -- be sure the floating-point processor is properly set for conversion
- -- calls. This is notably need on Windows, where calls to the operating
- -- system randomly reset the processor into 64-bit mode.
+ -- 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;
@@ -539,21 +535,21 @@ package body System.Img_Real is
if V > 0.0 then
X := V;
- Sign := '+';
+ Minus := False;
-- Negative values
elsif V < 0.0 then
X := -V;
- Sign := '-';
+ Minus := True;
-- Zero values
elsif V = 0.0 then
if Long_Long_Float'Signed_Zeros and then Is_Negative (V) then
- Sign := '-';
+ Minus := True;
else
- Sign := '+';
+ Minus := False;
end if;
Set_Blanks_And_Sign (Fore - 1);
@@ -578,7 +574,7 @@ package body System.Img_Real is
raise Constraint_Error;
end if;
- -- X and Sign are set here, and X is known to be a valid,
+ -- 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
diff --git a/gcc/ada/libgnat/s-imgrea.ads b/gcc/ada/libgnat/s-imgrea.ads
index 9711516..d8eb721 100644
--- a/gcc/ada/libgnat/s-imgrea.ads
+++ b/gcc/ada/libgnat/s-imgrea.ads
@@ -44,15 +44,18 @@ package System.Img_Real is
-- 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
+ -- 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 fixed_type'Image (V) and returns the result in S (1 .. P)
+ -- 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
diff --git a/gcc/ada/libgnat/s-imgdec.adb b/gcc/ada/libgnat/s-imguti.adb
index 840dadb..571fb67 100644
--- a/gcc/ada/libgnat/s-imgdec.adb
+++ b/gcc/ada/libgnat/s-imguti.adb
@@ -2,11 +2,11 @@
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
--- S Y S T E M . I M G _ D E C --
+-- S Y S T E M . I M G _ U T I L --
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -29,34 +29,9 @@
-- --
------------------------------------------------------------------------------
-with System.Img_Int; use System.Img_Int;
+with System.Img_Uns; use System.Img_Uns;
-package body System.Img_Dec is
-
- -------------------
- -- Image_Decimal --
- -------------------
-
- procedure Image_Decimal
- (V : Integer;
- S : in out String;
- P : out Natural;
- Scale : Integer)
- is
- pragma Assert (S'First = 1);
-
- begin
- -- Add space at start for non-negative numbers
-
- if V >= 0 then
- S (1) := ' ';
- P := 1;
- else
- P := 0;
- end if;
-
- Set_Image_Decimal (V, S, P, Scale, 1, Integer'Max (1, Scale), 0);
- end Image_Decimal;
+package body System.Img_Util is
------------------------
-- Set_Decimal_Digits --
@@ -121,8 +96,8 @@ package body System.Img_Dec is
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, For a positive value, if N is non-positive, then
- -- a leading blank is filled.
+ -- or negative, but for a positive value, if N is non-positive, then
+ -- the call has no effect).
procedure Set_Digits (S, E : Natural);
pragma Inline (Set_Digits);
@@ -219,9 +194,6 @@ package body System.Img_Dec is
-- Constraint_Error will not necessarily be raised if this
-- requirement is violated, since it is perfectly valid to compile
-- this unit with checks off.
- --
- -- Due to codepeer limitation, codepeer should be used with switch:
- -- -no-propagation system.img_dec.set_decimal_digits.set
P := P + 1;
S (P) := C;
end Set;
@@ -231,20 +203,16 @@ package body System.Img_Dec is
-------------------------
procedure Set_Blanks_And_Sign (N : Integer) is
- W : Integer := N;
-
begin
if Minus then
- W := W - 1;
-
- for J in 1 .. W loop
+ for J in 1 .. N - 1 loop
Set (' ');
end loop;
Set ('-');
else
- for J in 1 .. W loop
+ for J in 1 .. N loop
Set (' ');
end loop;
end if;
@@ -305,15 +273,16 @@ package body System.Img_Dec is
-- exponent of +0.
Expon := (if Zero then 0 else Digits_Before_Point - 1);
+
Set ('E');
ND := 0;
if Expon >= 0 then
Set ('+');
- Set_Image_Integer (Expon, Digs, ND);
+ Set_Image_Unsigned (Unsigned (Expon), Digs, ND);
else
Set ('-');
- Set_Image_Integer (-Expon, Digs, ND);
+ Set_Image_Unsigned (Unsigned (-Expon), Digs, ND);
end if;
Set_Zeroes (Exp - ND - 1);
@@ -431,24 +400,4 @@ package body System.Img_Dec is
end if;
end Set_Decimal_Digits;
- -----------------------
- -- Set_Image_Decimal --
- -----------------------
-
- procedure Set_Image_Decimal
- (V : Integer;
- S : in out String;
- P : in out Natural;
- Scale : Integer;
- Fore : Natural;
- Aft : Natural;
- Exp : Natural)
- is
- Digs : String := Integer'Image (V);
- -- Sign and digits of decimal value
-
- begin
- Set_Decimal_Digits (Digs, Digs'Length, S, P, Scale, Fore, Aft, Exp);
- end Set_Image_Decimal;
-
-end System.Img_Dec;
+end System.Img_Util;
diff --git a/gcc/ada/libgnat/s-imguti.ads b/gcc/ada/libgnat/s-imguti.ads
new file mode 100644
index 0000000..6e21c65
--- /dev/null
+++ b/gcc/ada/libgnat/s-imguti.ads
@@ -0,0 +1,61 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . I M G _ U T I L --
+-- --
+-- 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. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package provides some common utilities used by the s-imgxxx files
+
+package System.Img_Util is
+ pragma Pure;
+
+ procedure Set_Decimal_Digits
+ (Digs : in out String;
+ NDigs : Natural;
+ S : out String;
+ P : in out Natural;
+ Scale : Integer;
+ Fore : Natural;
+ Aft : Natural;
+ Exp : Natural);
+ -- Sets the image of Digs (1 .. NDigs), which is a string of decimal digits
+ -- preceded by either a minus sign or a space, i.e. the integer image of
+ -- the value in units of delta if this is for a decimal fixed point type
+ -- with the given Scale, or the integer image of the value converted to an
+ -- implicit decimal fixed point type with the given Scale if this is for an
+ -- ordinary fixed point type, 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. The Fore, Aft and Exp values can
+ -- be set to any valid values for the case of use by Text_IO.Decimal_IO or
+ -- Text_IO.Fixed_IO. Note that there is no leading space stored. The call
+ -- may destroy the value in Digs, which is why Digs is in-out (this happens
+ -- if rounding is required).
+
+end System.Img_Util;
diff --git a/gcc/ada/libgnat/s-objrea.adb b/gcc/ada/libgnat/s-objrea.adb
index d64e285..0cfa522 100644
--- a/gcc/ada/libgnat/s-objrea.adb
+++ b/gcc/ada/libgnat/s-objrea.adb
@@ -645,6 +645,9 @@ package body System.Object_Reader is
when EM_X86_64 =>
Res.Arch := x86_64;
+ when EM_ARM =>
+ Res.Arch := ARM;
+
when others =>
raise Format_Error with "unrecognized architecture";
end case;
@@ -2030,6 +2033,7 @@ package body System.Object_Reader is
| MIPS
| PPC
| SPARC
+ | ARM
=>
Address_32 := Read (S);
return uint64 (Address_32);
diff --git a/gcc/ada/libgnat/s-objrea.ads b/gcc/ada/libgnat/s-objrea.ads
index bd4fbd5..b3cfe13 100644
--- a/gcc/ada/libgnat/s-objrea.ads
+++ b/gcc/ada/libgnat/s-objrea.ads
@@ -117,9 +117,12 @@ package System.Object_Reader is
PPC,
-- 32-bit PowerPC
- PPC64);
+ PPC64,
-- 64-bit PowerPC
+ ARM);
+ -- 32-bit ARM
+
------------------
-- Target types --
------------------
diff --git a/gcc/ada/libgnat/s-os_lib.adb b/gcc/ada/libgnat/s-os_lib.adb
index 288325c..93522bc 100644
--- a/gcc/ada/libgnat/s-os_lib.adb
+++ b/gcc/ada/libgnat/s-os_lib.adb
@@ -1365,6 +1365,21 @@ package body System.OS_Lib is
S : Integer;
begin
+ -- Special case Invalid_Time which is handled differently between
+ -- Windows and Linux: Linux will set to 1 second before 1970-01-01
+ -- while Windows will set the time to 1970-01-01 with Second set to -1,
+ -- which is not a valid value.
+
+ if Date = Invalid_Time then
+ Year := 1969;
+ Month := 12;
+ Day := 31;
+ Hour := 23;
+ Minute := 59;
+ Second := 59;
+ return;
+ end if;
+
-- Use the global lock because To_GM_Time is not thread safe
Locked_Processing : begin
@@ -1387,7 +1402,15 @@ package body System.OS_Lib is
Year := Y + 1900;
Month := Mo + 1;
- Day := D;
+
+ -- May happen if To_GM_Time fails
+
+ if D = 0 then
+ Day := 1;
+ else
+ Day := D;
+ end if;
+
Hour := H;
Minute := Mn;
Second := S;
diff --git a/gcc/ada/libgnat/s-powflt.ads b/gcc/ada/libgnat/s-powflt.ads
new file mode 100644
index 0000000..9d58967
--- /dev/null
+++ b/gcc/ada/libgnat/s-powflt.ads
@@ -0,0 +1,85 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . P O W T E N _ F L T --
+-- --
+-- 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. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package provides a powers of ten table used for real conversions
+
+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);
+
+end System.Powten_Flt;
diff --git a/gcc/ada/libgnat/s-powlfl.ads b/gcc/ada/libgnat/s-powlfl.ads
new file mode 100644
index 0000000..d191eff
--- /dev/null
+++ b/gcc/ada/libgnat/s-powlfl.ads
@@ -0,0 +1,355 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . P O W T E N _ L F L T --
+-- --
+-- 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. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package provides a powers of ten table used for real conversions
+
+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);
+
+end System.Powten_LFlt;
diff --git a/gcc/ada/libgnat/s-powtab.ads b/gcc/ada/libgnat/s-powllf.ads
index ef8d74a..c5c42a1 100644
--- a/gcc/ada/libgnat/s-powtab.ads
+++ b/gcc/ada/libgnat/s-powllf.ads
@@ -2,7 +2,7 @@
-- --
-- GNAT COMPILER COMPONENTS --
-- --
--- S Y S T E M . P O W T E N _ T A B L E --
+-- S Y S T E M . P O W T E N _ L L F --
-- --
-- S p e c --
-- --
@@ -31,14 +31,14 @@
-- This package provides a powers of ten table used for real conversions
-package System.Powten_Table is
+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 5). If the scaling factor for a string is greater than
+ -- 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.
@@ -67,4 +67,4 @@ package System.Powten_Table is
21 => 1.0E+21,
22 => 1.0E+22);
-end System.Powten_Table;
+end System.Powten_LLF;
diff --git a/gcc/ada/libgnat/s-rannum.adb b/gcc/ada/libgnat/s-rannum.adb
index e65e6a7..ab6428f 100644
--- a/gcc/ada/libgnat/s-rannum.adb
+++ b/gcc/ada/libgnat/s-rannum.adb
@@ -409,6 +409,41 @@ is
elsif Max < Min then
raise Constraint_Error;
+ -- In the 128-bit case, we have to be careful since not all 128-bit
+ -- unsigned values are representable in GNAT's universal integer.
+
+ elsif Result_Subtype'Base'Size > 64 then
+ declare
+ -- Ignore unequal-size warnings since GNAT's handling is correct.
+
+ pragma Warnings ("Z");
+ function Conv_To_Unsigned is
+ new Unchecked_Conversion (Result_Subtype'Base, Unsigned_128);
+ function Conv_To_Result is
+ new Unchecked_Conversion (Unsigned_128, Result_Subtype'Base);
+ pragma Warnings ("z");
+
+ N : constant Unsigned_128 :=
+ Conv_To_Unsigned (Max) - Conv_To_Unsigned (Min) + 1;
+
+ X, Slop : Unsigned_128;
+
+ begin
+ if N = 0 then
+ return Conv_To_Result (Conv_To_Unsigned (Min) + Random (Gen));
+
+ else
+ Slop := Unsigned_128'Last rem N + 1;
+
+ loop
+ X := Random (Gen);
+ exit when Slop = N or else X <= Unsigned_128'Last - Slop;
+ end loop;
+
+ return Conv_To_Result (Conv_To_Unsigned (Min) + X rem N);
+ end if;
+ end;
+
-- In the 64-bit case, we have to be careful since not all 64-bit
-- unsigned values are representable in GNAT's universal integer.
diff --git a/gcc/ada/libgnat/s-rident.ads b/gcc/ada/libgnat/s-rident.ads
index 662721a..c6c3d3d 100644
--- a/gcc/ada/libgnat/s-rident.ads
+++ b/gcc/ada/libgnat/s-rident.ads
@@ -184,6 +184,8 @@ package System.Rident is
No_Implicit_Loops, -- GNAT
No_Elaboration_Code, -- GNAT
No_Obsolescent_Features, -- Ada 2005 AI-368
+ No_Unrecognized_Aspects, -- AI12-0389-1/02
+ No_Unrecognized_Pragmas, -- AI12-0389-1/02
No_Wide_Characters, -- GNAT
Static_Dispatch_Tables, -- GNAT
SPARK_05, -- GNAT
diff --git a/gcc/ada/libgnat/s-secsta.adb b/gcc/ada/libgnat/s-secsta.adb
index 7ec8462..f2d264d 100644
--- a/gcc/ada/libgnat/s-secsta.adb
+++ b/gcc/ada/libgnat/s-secsta.adb
@@ -587,15 +587,18 @@ package body System.Secondary_Stack is
-- Start of processing for SS_Allocate
begin
- -- It should not be possible to request an allocation of negative or
- -- zero size.
-
- pragma Assert (Storage_Size > 0);
-
-- Round the requested size up to the nearest multiple of the maximum
-- alignment to ensure efficient access.
- Mem_Size := Round_Up (Storage_Size);
+ if Storage_Size = 0 then
+ Mem_Size := Memory_Alignment;
+ else
+ -- It should not be possible to request an allocation of negative
+ -- size.
+
+ pragma Assert (Storage_Size >= 0);
+ Mem_Size := Round_Up (Storage_Size);
+ end if;
if Sec_Stack_Dynamic then
Allocate_Dynamic (Stack, Mem_Size, Addr);
diff --git a/gcc/ada/libgnat/s-stratt.adb b/gcc/ada/libgnat/s-stratt.adb
index 366dabd..8fe2721 100644
--- a/gcc/ada/libgnat/s-stratt.adb
+++ b/gcc/ada/libgnat/s-stratt.adb
@@ -44,7 +44,8 @@ package body System.Stream_Attributes is
function XDR_Support return Boolean;
pragma Inline (XDR_Support);
- -- Return True if XDR streaming should be used
+ -- Return True if XDR streaming should be used. Note that 128-bit integers
+ -- are not supported by the XDR protocol and will raise Device_Error.
Err : exception renames Ada.IO_Exceptions.End_Error;
-- Exception raised if insufficient data read (note that the RM implies
@@ -64,74 +65,81 @@ package body System.Stream_Attributes is
Thin_Pointer_Size : constant := System.Address'Size;
Fat_Pointer_Size : constant := System.Address'Size * 2;
- subtype S_AD is SEA (1 .. (Fat_Pointer_Size + SU - 1) / SU);
- subtype S_AS is SEA (1 .. (Thin_Pointer_Size + SU - 1) / SU);
- subtype S_B is SEA (1 .. (Boolean'Size + SU - 1) / SU);
- subtype S_C is SEA (1 .. (Character'Size + SU - 1) / SU);
- subtype S_F is SEA (1 .. (Float'Size + SU - 1) / SU);
- subtype S_I is SEA (1 .. (Integer'Size + SU - 1) / SU);
- subtype S_I24 is SEA (1 .. (Integer_24'Size + SU - 1) / SU);
- subtype S_LF is SEA (1 .. (Long_Float'Size + SU - 1) / SU);
- subtype S_LI is SEA (1 .. (Long_Integer'Size + SU - 1) / SU);
- subtype S_LLF is SEA (1 .. (Long_Long_Float'Size + SU - 1) / SU);
- subtype S_LLI is SEA (1 .. (Long_Long_Integer'Size + SU - 1) / SU);
- subtype S_LLU is SEA (1 .. (UST.Long_Long_Unsigned'Size + SU - 1) / SU);
- subtype S_LU is SEA (1 .. (UST.Long_Unsigned'Size + SU - 1) / SU);
- subtype S_SF is SEA (1 .. (Short_Float'Size + SU - 1) / SU);
- subtype S_SI is SEA (1 .. (Short_Integer'Size + SU - 1) / SU);
- subtype S_SSI is SEA (1 .. (Short_Short_Integer'Size + SU - 1) / SU);
- subtype S_SSU is SEA (1 .. (UST.Short_Short_Unsigned'Size + SU - 1) / SU);
- subtype S_SU is SEA (1 .. (UST.Short_Unsigned'Size + SU - 1) / SU);
- subtype S_U is SEA (1 .. (UST.Unsigned'Size + SU - 1) / SU);
- subtype S_U24 is SEA (1 .. (Unsigned_24'Size + SU - 1) / SU);
- subtype S_WC is SEA (1 .. (Wide_Character'Size + SU - 1) / SU);
- subtype S_WWC is SEA (1 .. (Wide_Wide_Character'Size + SU - 1) / SU);
+ subtype S_AD is SEA (1 .. (Fat_Pointer_Size + SU - 1) / SU);
+ subtype S_AS is SEA (1 .. (Thin_Pointer_Size + SU - 1) / SU);
+ subtype S_B is SEA (1 .. (Boolean'Size + SU - 1) / SU);
+ subtype S_C is SEA (1 .. (Character'Size + SU - 1) / SU);
+ subtype S_F is SEA (1 .. (Float'Size + SU - 1) / SU);
+ subtype S_I is SEA (1 .. (Integer'Size + SU - 1) / SU);
+ subtype S_I24 is SEA (1 .. (Integer_24'Size + SU - 1) / SU);
+ subtype S_LF is SEA (1 .. (Long_Float'Size + SU - 1) / SU);
+ subtype S_LI is SEA (1 .. (Long_Integer'Size + SU - 1) / SU);
+ subtype S_LLF is SEA (1 .. (Long_Long_Float'Size + SU - 1) / SU);
+ subtype S_LLI is SEA (1 .. (Long_Long_Integer'Size + SU - 1) / SU);
+ subtype S_LLLI is SEA (1 .. (Long_Long_Long_Integer'Size + SU - 1) / SU);
+ subtype S_LLLU is
+ SEA (1 .. (UST.Long_Long_Long_Unsigned'Size + SU - 1) / SU);
+ subtype S_LLU is SEA (1 .. (UST.Long_Long_Unsigned'Size + SU - 1) / SU);
+ subtype S_LU is SEA (1 .. (UST.Long_Unsigned'Size + SU - 1) / SU);
+ subtype S_SF is SEA (1 .. (Short_Float'Size + SU - 1) / SU);
+ subtype S_SI is SEA (1 .. (Short_Integer'Size + SU - 1) / SU);
+ subtype S_SSI is SEA (1 .. (Short_Short_Integer'Size + SU - 1) / SU);
+ subtype S_SSU is SEA (1 .. (UST.Short_Short_Unsigned'Size + SU - 1) / SU);
+ subtype S_SU is SEA (1 .. (UST.Short_Unsigned'Size + SU - 1) / SU);
+ subtype S_U is SEA (1 .. (UST.Unsigned'Size + SU - 1) / SU);
+ subtype S_U24 is SEA (1 .. (Unsigned_24'Size + SU - 1) / SU);
+ subtype S_WC is SEA (1 .. (Wide_Character'Size + SU - 1) / SU);
+ subtype S_WWC is SEA (1 .. (Wide_Wide_Character'Size + SU - 1) / SU);
-- Unchecked conversions from the elementary type to the stream type
- function From_AD is new UC (Fat_Pointer, S_AD);
- function From_AS is new UC (Thin_Pointer, S_AS);
- function From_F is new UC (Float, S_F);
- function From_I is new UC (Integer, S_I);
- function From_I24 is new UC (Integer_24, S_I24);
- function From_LF is new UC (Long_Float, S_LF);
- function From_LI is new UC (Long_Integer, S_LI);
- function From_LLF is new UC (Long_Long_Float, S_LLF);
- function From_LLI is new UC (Long_Long_Integer, S_LLI);
- function From_LLU is new UC (UST.Long_Long_Unsigned, S_LLU);
- function From_LU is new UC (UST.Long_Unsigned, S_LU);
- function From_SF is new UC (Short_Float, S_SF);
- function From_SI is new UC (Short_Integer, S_SI);
- function From_SSI is new UC (Short_Short_Integer, S_SSI);
- function From_SSU is new UC (UST.Short_Short_Unsigned, S_SSU);
- function From_SU is new UC (UST.Short_Unsigned, S_SU);
- function From_U is new UC (UST.Unsigned, S_U);
- function From_U24 is new UC (Unsigned_24, S_U24);
- function From_WC is new UC (Wide_Character, S_WC);
- function From_WWC is new UC (Wide_Wide_Character, S_WWC);
+ function From_AD is new UC (Fat_Pointer, S_AD);
+ function From_AS is new UC (Thin_Pointer, S_AS);
+ function From_F is new UC (Float, S_F);
+ function From_I is new UC (Integer, S_I);
+ function From_I24 is new UC (Integer_24, S_I24);
+ function From_LF is new UC (Long_Float, S_LF);
+ function From_LI is new UC (Long_Integer, S_LI);
+ function From_LLF is new UC (Long_Long_Float, S_LLF);
+ function From_LLI is new UC (Long_Long_Integer, S_LLI);
+ function From_LLLI is new UC (Long_Long_Long_Integer, S_LLLI);
+ function From_LLLU is new UC (UST.Long_Long_Long_Unsigned, S_LLLU);
+ function From_LLU is new UC (UST.Long_Long_Unsigned, S_LLU);
+ function From_LU is new UC (UST.Long_Unsigned, S_LU);
+ function From_SF is new UC (Short_Float, S_SF);
+ function From_SI is new UC (Short_Integer, S_SI);
+ function From_SSI is new UC (Short_Short_Integer, S_SSI);
+ function From_SSU is new UC (UST.Short_Short_Unsigned, S_SSU);
+ function From_SU is new UC (UST.Short_Unsigned, S_SU);
+ function From_U is new UC (UST.Unsigned, S_U);
+ function From_U24 is new UC (Unsigned_24, S_U24);
+ function From_WC is new UC (Wide_Character, S_WC);
+ function From_WWC is new UC (Wide_Wide_Character, S_WWC);
-- Unchecked conversions from the stream type to elementary type
- function To_AD is new UC (S_AD, Fat_Pointer);
- function To_AS is new UC (S_AS, Thin_Pointer);
- function To_F is new UC (S_F, Float);
- function To_I is new UC (S_I, Integer);
- function To_I24 is new UC (S_I24, Integer_24);
- function To_LF is new UC (S_LF, Long_Float);
- function To_LI is new UC (S_LI, Long_Integer);
- function To_LLF is new UC (S_LLF, Long_Long_Float);
- function To_LLI is new UC (S_LLI, Long_Long_Integer);
- function To_LLU is new UC (S_LLU, UST.Long_Long_Unsigned);
- function To_LU is new UC (S_LU, UST.Long_Unsigned);
- function To_SF is new UC (S_SF, Short_Float);
- function To_SI is new UC (S_SI, Short_Integer);
- function To_SSI is new UC (S_SSI, Short_Short_Integer);
- function To_SSU is new UC (S_SSU, UST.Short_Short_Unsigned);
- function To_SU is new UC (S_SU, UST.Short_Unsigned);
- function To_U is new UC (S_U, UST.Unsigned);
- function To_U24 is new UC (S_U24, Unsigned_24);
- function To_WC is new UC (S_WC, Wide_Character);
- function To_WWC is new UC (S_WWC, Wide_Wide_Character);
+ function To_AD is new UC (S_AD, Fat_Pointer);
+ function To_AS is new UC (S_AS, Thin_Pointer);
+ function To_F is new UC (S_F, Float);
+ function To_I is new UC (S_I, Integer);
+ function To_I24 is new UC (S_I24, Integer_24);
+ function To_LF is new UC (S_LF, Long_Float);
+ function To_LI is new UC (S_LI, Long_Integer);
+ function To_LLF is new UC (S_LLF, Long_Long_Float);
+ function To_LLI is new UC (S_LLI, Long_Long_Integer);
+ function To_LLLI is new UC (S_LLLI, Long_Long_Long_Integer);
+ function To_LLLU is new UC (S_LLLU, UST.Long_Long_Long_Unsigned);
+ function To_LLU is new UC (S_LLU, UST.Long_Long_Unsigned);
+ function To_LU is new UC (S_LU, UST.Long_Unsigned);
+ function To_SF is new UC (S_SF, Short_Float);
+ function To_SI is new UC (S_SI, Short_Integer);
+ function To_SSI is new UC (S_SSI, Short_Short_Integer);
+ function To_SSU is new UC (S_SSU, UST.Short_Short_Unsigned);
+ function To_SU is new UC (S_SU, UST.Short_Unsigned);
+ function To_U is new UC (S_U, UST.Unsigned);
+ function To_U24 is new UC (S_U24, Unsigned_24);
+ function To_WC is new UC (S_WC, Wide_Character);
+ function To_WWC is new UC (S_WWC, Wide_Wide_Character);
-----------------
-- XDR_Support --
@@ -393,6 +401,53 @@ package body System.Stream_Attributes is
end if;
end I_LLI;
+ ------------
+ -- I_LLLI --
+ ------------
+
+ function I_LLLI (Stream : not null access RST) return Long_Long_Long_Integer
+ is
+ T : S_LLLI;
+ L : SEO;
+
+ begin
+ if XDR_Support then
+ raise Ada.IO_Exceptions.Device_Error;
+ end if;
+
+ Ada.Streams.Read (Stream.all, T, L);
+
+ if L < T'Last then
+ raise Err;
+ else
+ return To_LLLI (T);
+ end if;
+ end I_LLLI;
+
+ ------------
+ -- I_LLLU --
+ ------------
+
+ function I_LLLU
+ (Stream : not null access RST) return UST.Long_Long_Long_Unsigned
+ is
+ T : S_LLLU;
+ L : SEO;
+
+ begin
+ if XDR_Support then
+ raise Ada.IO_Exceptions.Device_Error;
+ end if;
+
+ Ada.Streams.Read (Stream.all, T, L);
+
+ if L < T'Last then
+ raise Err;
+ else
+ return To_LLLU (T);
+ end if;
+ end I_LLLU;
+
-----------
-- I_LLU --
-----------
@@ -799,6 +854,35 @@ package body System.Stream_Attributes is
Ada.Streams.Write (Stream.all, From_LLI (Item));
end W_LLI;
+ ------------
+ -- W_LLLI --
+ ------------
+
+ procedure W_LLLI
+ (Stream : not null access RST; Item : Long_Long_Long_Integer) is
+ begin
+ if XDR_Support then
+ raise Ada.IO_Exceptions.Device_Error;
+ end if;
+
+ Ada.Streams.Write (Stream.all, From_LLLI (Item));
+ end W_LLLI;
+
+ ------------
+ -- W_LLLU --
+ ------------
+
+ procedure W_LLLU
+ (Stream : not null access RST; Item : UST.Long_Long_Long_Unsigned)
+ is
+ begin
+ if XDR_Support then
+ raise Ada.IO_Exceptions.Device_Error;
+ end if;
+
+ Ada.Streams.Write (Stream.all, From_LLLU (Item));
+ end W_LLLU;
+
-----------
-- W_LLU --
-----------
diff --git a/gcc/ada/libgnat/s-stratt.ads b/gcc/ada/libgnat/s-stratt.ads
index c8c453a..965dff6 100644
--- a/gcc/ada/libgnat/s-stratt.ads
+++ b/gcc/ada/libgnat/s-stratt.ads
@@ -104,29 +104,34 @@ package System.Stream_Attributes is
-- is the same for all elementary types (no bounds or discriminants
-- are involved).
- function I_AD (Stream : not null access RST) return Fat_Pointer;
- function I_AS (Stream : not null access RST) return Thin_Pointer;
- function I_B (Stream : not null access RST) return Boolean;
- function I_C (Stream : not null access RST) return Character;
- function I_F (Stream : not null access RST) return Float;
- function I_I (Stream : not null access RST) return Integer;
- function I_I24 (Stream : not null access RST) return Integer_24;
- function I_LF (Stream : not null access RST) return Long_Float;
- function I_LI (Stream : not null access RST) return Long_Integer;
- function I_LLF (Stream : not null access RST) return Long_Long_Float;
- function I_LLI (Stream : not null access RST) return Long_Long_Integer;
- function I_LLU (Stream : not null access RST) return UST.Long_Long_Unsigned;
- function I_LU (Stream : not null access RST) return UST.Long_Unsigned;
- function I_SF (Stream : not null access RST) return Short_Float;
- function I_SI (Stream : not null access RST) return Short_Integer;
- function I_SSI (Stream : not null access RST) return Short_Short_Integer;
- function I_SSU (Stream : not null access RST) return
- UST.Short_Short_Unsigned;
- function I_SU (Stream : not null access RST) return UST.Short_Unsigned;
- function I_U (Stream : not null access RST) return UST.Unsigned;
- function I_U24 (Stream : not null access RST) return Unsigned_24;
- function I_WC (Stream : not null access RST) return Wide_Character;
- function I_WWC (Stream : not null access RST) return Wide_Wide_Character;
+ function I_AD (Stream : not null access RST) return Fat_Pointer;
+ function I_AS (Stream : not null access RST) return Thin_Pointer;
+ function I_B (Stream : not null access RST) return Boolean;
+ function I_C (Stream : not null access RST) return Character;
+ function I_F (Stream : not null access RST) return Float;
+ function I_I (Stream : not null access RST) return Integer;
+ function I_I24 (Stream : not null access RST) return Integer_24;
+ function I_LF (Stream : not null access RST) return Long_Float;
+ function I_LI (Stream : not null access RST) return Long_Integer;
+ function I_LLF (Stream : not null access RST) return Long_Long_Float;
+ function I_LLI (Stream : not null access RST) return Long_Long_Integer;
+ function I_LLLI (Stream : not null access RST) return
+ Long_Long_Long_Integer;
+ function I_LLLU (Stream : not null access RST) return
+ UST.Long_Long_Long_Unsigned;
+ function I_LLU (Stream : not null access RST) return
+ UST.Long_Long_Unsigned;
+ function I_LU (Stream : not null access RST) return UST.Long_Unsigned;
+ function I_SF (Stream : not null access RST) return Short_Float;
+ function I_SI (Stream : not null access RST) return Short_Integer;
+ function I_SSI (Stream : not null access RST) return Short_Short_Integer;
+ function I_SSU (Stream : not null access RST) return
+ UST.Short_Short_Unsigned;
+ function I_SU (Stream : not null access RST) return UST.Short_Unsigned;
+ function I_U (Stream : not null access RST) return UST.Unsigned;
+ function I_U24 (Stream : not null access RST) return Unsigned_24;
+ function I_WC (Stream : not null access RST) return Wide_Character;
+ function I_WWC (Stream : not null access RST) return Wide_Wide_Character;
-----------------------
-- Output Procedures --
@@ -137,30 +142,34 @@ package System.Stream_Attributes is
-- 'Write and 'Output because there are no discriminants or bounds to
-- be written.
- procedure W_AD (Stream : not null access RST; Item : Fat_Pointer);
- procedure W_AS (Stream : not null access RST; Item : Thin_Pointer);
- procedure W_B (Stream : not null access RST; Item : Boolean);
- procedure W_C (Stream : not null access RST; Item : Character);
- procedure W_F (Stream : not null access RST; Item : Float);
- procedure W_I (Stream : not null access RST; Item : Integer);
- procedure W_I24 (Stream : not null access RST; Item : Integer_24);
- procedure W_LF (Stream : not null access RST; Item : Long_Float);
- procedure W_LI (Stream : not null access RST; Item : Long_Integer);
- procedure W_LLF (Stream : not null access RST; Item : Long_Long_Float);
- procedure W_LLI (Stream : not null access RST; Item : Long_Long_Integer);
- procedure W_LLU (Stream : not null access RST; Item :
- UST.Long_Long_Unsigned);
- procedure W_LU (Stream : not null access RST; Item : UST.Long_Unsigned);
- procedure W_SF (Stream : not null access RST; Item : Short_Float);
- procedure W_SI (Stream : not null access RST; Item : Short_Integer);
- procedure W_SSI (Stream : not null access RST; Item : Short_Short_Integer);
- procedure W_SSU (Stream : not null access RST; Item :
- UST.Short_Short_Unsigned);
- procedure W_SU (Stream : not null access RST; Item : UST.Short_Unsigned);
- procedure W_U (Stream : not null access RST; Item : UST.Unsigned);
- procedure W_U24 (Stream : not null access RST; Item : Unsigned_24);
- procedure W_WC (Stream : not null access RST; Item : Wide_Character);
- procedure W_WWC (Stream : not null access RST; Item : Wide_Wide_Character);
+ procedure W_AD (Stream : not null access RST; Item : Fat_Pointer);
+ procedure W_AS (Stream : not null access RST; Item : Thin_Pointer);
+ procedure W_B (Stream : not null access RST; Item : Boolean);
+ procedure W_C (Stream : not null access RST; Item : Character);
+ procedure W_F (Stream : not null access RST; Item : Float);
+ procedure W_I (Stream : not null access RST; Item : Integer);
+ procedure W_I24 (Stream : not null access RST; Item : Integer_24);
+ procedure W_LF (Stream : not null access RST; Item : Long_Float);
+ procedure W_LI (Stream : not null access RST; Item : Long_Integer);
+ procedure W_LLF (Stream : not null access RST; Item : Long_Long_Float);
+ procedure W_LLI (Stream : not null access RST; Item : Long_Long_Integer);
+ procedure W_LLLI (Stream : not null access RST; Item :
+ Long_Long_Long_Integer);
+ procedure W_LLLU (Stream : not null access RST; Item :
+ UST.Long_Long_Long_Unsigned);
+ procedure W_LLU (Stream : not null access RST; Item :
+ UST.Long_Long_Unsigned);
+ procedure W_LU (Stream : not null access RST; Item : UST.Long_Unsigned);
+ procedure W_SF (Stream : not null access RST; Item : Short_Float);
+ procedure W_SI (Stream : not null access RST; Item : Short_Integer);
+ procedure W_SSI (Stream : not null access RST; Item : Short_Short_Integer);
+ procedure W_SSU (Stream : not null access RST; Item :
+ UST.Short_Short_Unsigned);
+ procedure W_SU (Stream : not null access RST; Item : UST.Short_Unsigned);
+ procedure W_U (Stream : not null access RST; Item : UST.Unsigned);
+ procedure W_U24 (Stream : not null access RST; Item : Unsigned_24);
+ procedure W_WC (Stream : not null access RST; Item : Wide_Character);
+ procedure W_WWC (Stream : not null access RST; Item : Wide_Wide_Character);
function Block_IO_OK return Boolean;
-- Indicate whether the current setting supports block IO. See
@@ -177,6 +186,8 @@ private
pragma Inline (I_LI);
pragma Inline (I_LLF);
pragma Inline (I_LLI);
+ pragma Inline (I_LLLI);
+ pragma Inline (I_LLLU);
pragma Inline (I_LLU);
pragma Inline (I_LU);
pragma Inline (I_SF);
@@ -198,6 +209,8 @@ private
pragma Inline (W_LI);
pragma Inline (W_LLF);
pragma Inline (W_LLI);
+ pragma Inline (W_LLLI);
+ pragma Inline (W_LLLU);
pragma Inline (W_LLU);
pragma Inline (W_LU);
pragma Inline (W_SF);
diff --git a/gcc/ada/libgnat/s-trasym.ads b/gcc/ada/libgnat/s-trasym.ads
index e974ee9..fbeec8d 100644
--- a/gcc/ada/libgnat/s-trasym.ads
+++ b/gcc/ada/libgnat/s-trasym.ads
@@ -33,7 +33,8 @@
-- The full capability is currently supported on the following targets:
--- GNU/Linux x86, x86_64, ia64
+-- GNU/Linux x86, x86_64
+-- Windows x86, x86_64
-- Note: on targets other than those listed above, a dummy implementation
-- of the body returns a series of LF separated strings of the form "0x..."
diff --git a/gcc/ada/libgnat/s-valdec.adb b/gcc/ada/libgnat/s-vade128.ads
index 99fffaf..8edc742 100644
--- a/gcc/ada/libgnat/s-valdec.adb
+++ b/gcc/ada/libgnat/s-vade128.ads
@@ -2,11 +2,11 @@
-- --
-- GNAT COMPILER COMPONENTS --
-- --
--- S Y S T E M . V A L _ D E C --
+-- S Y S T E M . V A L _ D E C I M A L _ 1 2 8 --
-- --
--- B o d y --
+-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -29,40 +29,32 @@
-- --
------------------------------------------------------------------------------
-with System.Val_Real; use System.Val_Real;
+-- This package contains routines for scanning values for decimal fixed point
+-- types up to 128-bit mantissa, for use in Text_IO.Decimal_IO, and the Value
+-- attribute for such decimal types.
-package body System.Val_Dec is
+with Interfaces;
+with System.Arith_128;
+with System.Value_D;
- ------------------
- -- Scan_Decimal --
- ------------------
+package System.Val_Decimal_128 is
+ pragma Preelaborate;
- -- For decimal types where Size < Integer'Size, it is fine to use
- -- the floating-point circuit, since it certainly has sufficient
- -- precision for any reasonable hardware, and we just don't support
- -- things on junk hardware.
+ subtype Int128 is Interfaces.Integer_128;
+ subtype Uns128 is Interfaces.Unsigned_128;
- function Scan_Decimal
+ package Impl is new Value_D (Int128, Uns128, Arith_128.Scaled_Divide128);
+
+ function Scan_Decimal128
(Str : String;
Ptr : not null access Integer;
Max : Integer;
- Scale : Integer) return Integer
- is
- Val : Long_Long_Float;
- begin
- Val := Scan_Real (Str, Ptr, Max);
- return Integer (Val * 10.0 ** Scale);
- end Scan_Decimal;
-
- -------------------
- -- Value_Decimal --
- -------------------
+ Scale : Integer) return Int128
+ renames Impl.Scan_Decimal;
- -- Again, we use the real circuit for this purpose
-
- function Value_Decimal (Str : String; Scale : Integer) return Integer is
- begin
- return Integer (Value_Real (Str) * 10.0 ** Scale);
- end Value_Decimal;
+ function Value_Decimal128
+ (Str : String;
+ Scale : Integer) return Int128
+ renames Impl.Value_Decimal;
-end System.Val_Dec;
+end System.Val_Decimal_128;
diff --git a/gcc/ada/libgnat/s-vade32.ads b/gcc/ada/libgnat/s-vade32.ads
new file mode 100644
index 0000000..b86ae52
--- /dev/null
+++ b/gcc/ada/libgnat/s-vade32.ads
@@ -0,0 +1,58 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . V A L _ D E C I M A L _ 3 2 --
+-- --
+-- 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. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains routines for scanning values for decimal fixed point
+-- types up to 32-bit mantissa, for use in Text_IO.Decimal_IO, and the Value
+-- attribute for such decimal types.
+
+with Interfaces;
+with System.Arith_32;
+with System.Value_D;
+
+package System.Val_Decimal_32 is
+ pragma Preelaborate;
+
+ subtype Int32 is Interfaces.Integer_32;
+ subtype Uns32 is Interfaces.Unsigned_32;
+
+ package Impl is new Value_D (Int32, Uns32, Arith_32.Scaled_Divide32);
+
+ function Scan_Decimal32
+ (Str : String;
+ Ptr : not null access Integer;
+ Max : Integer;
+ Scale : Integer) return Int32
+ renames Impl.Scan_Decimal;
+
+ function Value_Decimal32 (Str : String; Scale : Integer) return Int32
+ renames Impl.Value_Decimal;
+
+end System.Val_Decimal_32;
diff --git a/gcc/ada/libgnat/s-vade64.ads b/gcc/ada/libgnat/s-vade64.ads
new file mode 100644
index 0000000..d3a5b4f
--- /dev/null
+++ b/gcc/ada/libgnat/s-vade64.ads
@@ -0,0 +1,60 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . V A L _ D E C I M A L _ 6 4 --
+-- --
+-- 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. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains routines for scanning values for decimal fixed point
+-- types up to 64-bit mantissa, for use in Text_IO.Decimal_IO, and the Value
+-- attribute for such decimal types.
+
+with Interfaces;
+with System.Arith_64;
+with System.Value_D;
+
+package System.Val_Decimal_64 is
+ pragma Preelaborate;
+
+ subtype Int64 is Interfaces.Integer_64;
+ subtype Uns64 is Interfaces.Unsigned_64;
+
+ package Impl is new Value_D (Int64, Uns64, Arith_64.Scaled_Divide64);
+
+ function Scan_Decimal64
+ (Str : String;
+ Ptr : not null access Integer;
+ Max : Integer;
+ Scale : Integer) return Int64
+ renames Impl.Scan_Decimal;
+
+ function Value_Decimal64
+ (Str : String;
+ Scale : Integer) return Int64
+ renames Impl.Value_Decimal;
+
+end System.Val_Decimal_64;
diff --git a/gcc/ada/libgnat/s-vafi128.ads b/gcc/ada/libgnat/s-vafi128.ads
new file mode 100644
index 0000000..03fbe80
--- /dev/null
+++ b/gcc/ada/libgnat/s-vafi128.ads
@@ -0,0 +1,60 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . V A L _ F I X E D _ 1 2 8 --
+-- --
+-- 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. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains routines for scanning values for ordinary fixed point
+-- types up to 128-bit small and mantissa, for use in Text_IO.Decimal_IO, and
+-- the Value attribute for such decimal types.
+
+with Interfaces;
+with System.Arith_128;
+with System.Value_F;
+
+package System.Val_Fixed_128 is
+ pragma Preelaborate;
+
+ subtype Int128 is Interfaces.Integer_128;
+ subtype Uns128 is Interfaces.Unsigned_128;
+
+ package Impl is new Value_F (Int128, Uns128, Arith_128.Scaled_Divide128);
+
+ function Scan_Fixed128
+ (Str : String;
+ Ptr : not null access Integer;
+ Max : Integer;
+ Num : Int128;
+ Den : Int128) return Int128
+ renames Impl.Scan_Fixed;
+
+ function Value_Fixed128
+ (Str : String; Num : Int128; Den : Int128) return Int128
+ renames Impl.Value_Fixed;
+
+end System.Val_Fixed_128;
diff --git a/gcc/ada/libgnat/s-vafi32.ads b/gcc/ada/libgnat/s-vafi32.ads
new file mode 100644
index 0000000..6235a82
--- /dev/null
+++ b/gcc/ada/libgnat/s-vafi32.ads
@@ -0,0 +1,60 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . V A L _ F I X E D _ 3 2 --
+-- --
+-- 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. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains routines for scanning values for decimal fixed point
+-- types up to 32-bit small and mantissa, for use in Text_IO.Decimal_IO, and
+-- the Value attribute for such decimal types.
+
+with Interfaces;
+with System.Arith_32;
+with System.Value_F;
+
+package System.Val_Fixed_32 is
+ pragma Preelaborate;
+
+ subtype Int32 is Interfaces.Integer_32;
+ subtype Uns32 is Interfaces.Unsigned_32;
+
+ package Impl is new Value_F (Int32, Uns32, Arith_32.Scaled_Divide32);
+
+ function Scan_Fixed32
+ (Str : String;
+ Ptr : not null access Integer;
+ Max : Integer;
+ Num : Int32;
+ Den : Int32) return Int32
+ renames Impl.Scan_Fixed;
+
+ function Value_Fixed32
+ (Str : String; Num : Int32; Den : Int32) return Int32
+ renames Impl.Value_Fixed;
+
+end System.Val_Fixed_32;
diff --git a/gcc/ada/libgnat/s-vafi64.ads b/gcc/ada/libgnat/s-vafi64.ads
new file mode 100644
index 0000000..9f98df4
--- /dev/null
+++ b/gcc/ada/libgnat/s-vafi64.ads
@@ -0,0 +1,60 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . V A L _ F I X E D _ 6 4 --
+-- --
+-- 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. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains routines for scanning values for decimal fixed point
+-- types up to 64-bit small and mantissa, for use in Text_IO.Decimal_IO, and
+-- the Value attribute for such decimal types.
+
+with Interfaces;
+with System.Arith_64;
+with System.Value_F;
+
+package System.Val_Fixed_64 is
+ pragma Preelaborate;
+
+ subtype Int64 is Interfaces.Integer_64;
+ subtype Uns64 is Interfaces.Unsigned_64;
+
+ package Impl is new Value_F (Int64, Uns64, Arith_64.Scaled_Divide64);
+
+ function Scan_Fixed64
+ (Str : String;
+ Ptr : not null access Integer;
+ Max : Integer;
+ Num : Int64;
+ Den : Int64) return Int64
+ renames Impl.Scan_Fixed;
+
+ function Value_Fixed64
+ (Str : String; Num : Int64; Den : Int64) return Int64
+ renames Impl.Value_Fixed;
+
+end System.Val_Fixed_64;
diff --git a/gcc/ada/libgnat/s-valflt.ads b/gcc/ada/libgnat/s-valflt.ads
new file mode 100644
index 0000000..5806d58
--- /dev/null
+++ b/gcc/ada/libgnat/s-valflt.ads
@@ -0,0 +1,57 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . V A L _ F L T --
+-- --
+-- 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. --
+-- --
+------------------------------------------------------------------------------
+
+-- 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.Val_Real;
+
+package System.Val_Flt is
+ pragma Preelaborate;
+
+ package Impl is new Val_Real
+ (Float,
+ Interfaces.Unsigned_32,
+ System.Powten_Flt.Maxpow,
+ System.Powten_Flt.Powten'Address);
+
+ function Scan_Float
+ (Str : String;
+ Ptr : not null access Integer;
+ Max : Integer) return Float
+ renames Impl.Scan_Real;
+
+ function Value_Float (Str : String) return Float
+ renames Impl.Value_Real;
+
+end System.Val_Flt;
diff --git a/gcc/ada/libgnat/s-vallfl.ads b/gcc/ada/libgnat/s-vallfl.ads
new file mode 100644
index 0000000..c612f75
--- /dev/null
+++ b/gcc/ada/libgnat/s-vallfl.ads
@@ -0,0 +1,57 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . V A L _ L F L T --
+-- --
+-- 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. --
+-- --
+------------------------------------------------------------------------------
+
+-- 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.Val_Real;
+
+package System.Val_LFlt is
+ pragma Preelaborate;
+
+ package Impl is new Val_Real
+ (Long_Float,
+ Interfaces.Unsigned_64,
+ System.Powten_LFlt.Maxpow,
+ System.Powten_LFlt.Powten'Address);
+
+ function Scan_Long_Float
+ (Str : String;
+ Ptr : not null access Integer;
+ Max : Integer) return Long_Float
+ renames Impl.Scan_Real;
+
+ function Value_Long_Float (Str : String) return Long_Float
+ renames Impl.Value_Real;
+
+end System.Val_LFlt;
diff --git a/gcc/ada/libgnat/s-vallld.adb b/gcc/ada/libgnat/s-vallld.adb
deleted file mode 100644
index 4efa969..0000000
--- a/gcc/ada/libgnat/s-vallld.adb
+++ /dev/null
@@ -1,70 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- S Y S T E M . V A L _ L L D --
--- --
--- B o d y --
--- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-with System.Val_Real; use System.Val_Real;
-
-package body System.Val_LLD is
-
- ----------------------------
- -- Scan_Long_Long_Decimal --
- ----------------------------
-
- -- We use the floating-point circuit for now, this will be OK on a PC,
- -- but definitely does NOT have the required precision if the longest
- -- float type is IEEE double. This must be fixed in the future ???
-
- function Scan_Long_Long_Decimal
- (Str : String;
- Ptr : not null access Integer;
- Max : Integer;
- Scale : Integer) return Long_Long_Integer
- is
- Val : Long_Long_Float;
- begin
- Val := Scan_Real (Str, Ptr, Max);
- return Long_Long_Integer (Val * 10.0 ** Scale);
- end Scan_Long_Long_Decimal;
-
- -----------------------------
- -- Value_Long_Long_Decimal --
- -----------------------------
-
- -- Again we cheat and use floating-point ???
-
- function Value_Long_Long_Decimal
- (Str : String;
- Scale : Integer) return Long_Long_Integer
- is
- begin
- return Long_Long_Integer (Value_Real (Str) * 10.0 ** Scale);
- end Value_Long_Long_Decimal;
-
-end System.Val_LLD;
diff --git a/gcc/ada/libgnat/s-valllf.ads b/gcc/ada/libgnat/s-valllf.ads
new file mode 100644
index 0000000..46a311b
--- /dev/null
+++ b/gcc/ada/libgnat/s-valllf.ads
@@ -0,0 +1,57 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . V A L _ L L F --
+-- --
+-- 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. --
+-- --
+------------------------------------------------------------------------------
+
+-- 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.Val_Real;
+
+package System.Val_LLF is
+ pragma Preelaborate;
+
+ package Impl is new Val_Real
+ (Long_Long_Float,
+ Interfaces.Unsigned_64,
+ System.Powten_LLF.Maxpow,
+ System.Powten_LLF.Powten'Address);
+
+ function Scan_Long_Long_Float
+ (Str : String;
+ Ptr : not null access Integer;
+ Max : Integer) return Long_Long_Float
+ renames Impl.Scan_Real;
+
+ function Value_Long_Long_Float (Str : String) return Long_Long_Float
+ renames Impl.Value_Real;
+
+end System.Val_LLF;
diff --git a/gcc/ada/libgnat/s-valrea.adb b/gcc/ada/libgnat/s-valrea.adb
index 1a47dc2..0ac3846 100644
--- a/gcc/ada/libgnat/s-valrea.adb
+++ b/gcc/ada/libgnat/s-valrea.adb
@@ -29,514 +29,241 @@
-- --
------------------------------------------------------------------------------
-with System.Val_Util; use System.Val_Util;
with System.Float_Control;
+with System.Unsigned_Types; use System.Unsigned_Types;
+with System.Val_Util; use System.Val_Util;
+with System.Value_R;
-package body System.Val_Real is
+pragma Warnings (Off, "non-static constant in preelaborated unit");
+-- Every constant is static given our instantiation model
- procedure Scan_Integral_Digits
- (Str : String;
- Index : in out Integer;
- Max : Integer;
- Value : out Long_Long_Integer;
- Scale : out Integer;
- Base_Violation : in out Boolean;
- Base : Long_Long_Integer := 10;
- Base_Specified : Boolean := False);
- -- Scan the integral part of a real (i.e: before decimal separator)
- --
- -- The string parsed is Str (Index .. Max), and after the call Index will
- -- point to the first non parsed character.
- --
- -- For each digit parsed either value := value * base + digit, or scale
- -- is incremented by 1.
- --
- -- Base_Violation will be set to True a digit found is not part of the Base
-
- procedure Scan_Decimal_Digits
- (Str : String;
- Index : in out Integer;
- Max : Integer;
- Value : in out Long_Long_Integer;
- Scale : in out Integer;
- Base_Violation : in out Boolean;
- Base : Long_Long_Integer := 10;
- Base_Specified : Boolean := False);
- -- Scan the decimal part of a real (i.e: after decimal separator)
- --
- -- The string parsed is Str (Index .. Max), and after the call Index will
- -- point to the first non parsed character.
- --
- -- For each digit parsed value = value * base + digit and scale is
- -- decremented by 1. If precision limit is reached remaining digits are
- -- still parsed but ignored.
- --
- -- Base_Violation will be set to True a digit found is not part of the Base
-
- subtype Char_As_Digit is Long_Long_Integer range -2 .. 15;
- subtype Valid_Digit is Char_As_Digit range 0 .. Char_As_Digit'Last;
- Underscore : constant Char_As_Digit := -2;
- E_Digit : constant Char_As_Digit := 14;
-
- function As_Digit (C : Character) return Char_As_Digit;
- -- Given a character return the digit it represent. If the character is
- -- not a digit then a negative value is returned, -2 for underscore and
- -- -1 for any other character.
-
- Precision_Limit : constant Long_Long_Integer :=
- 2 ** (Long_Long_Float'Machine_Mantissa - 1) - 1;
- -- This is an upper bound for the number of bits used to represent the
- -- mantissa. Beyond that number, any digits parsed are useless.
-
- --------------
- -- As_Digit --
- --------------
-
- function As_Digit (C : Character) return Char_As_Digit is
- begin
- case C is
- when '0' .. '9' =>
- return Character'Pos (C) - Character'Pos ('0');
- when 'a' .. 'f' =>
- return Character'Pos (C) - (Character'Pos ('a') - 10);
- when 'A' .. 'F' =>
- return Character'Pos (C) - (Character'Pos ('A') - 10);
- when '_' =>
- return Underscore;
- when others =>
- return -1;
- end case;
- end As_Digit;
-
- -------------------------
- -- Scan_Decimal_Digits --
- -------------------------
-
- procedure Scan_Decimal_Digits
- (Str : String;
- Index : in out Integer;
- Max : Integer;
- Value : in out Long_Long_Integer;
- Scale : in out Integer;
- Base_Violation : in out Boolean;
- Base : Long_Long_Integer := 10;
- Base_Specified : Boolean := False)
+package body System.Val_Real is
+ pragma Assert (Num'Machine_Mantissa <= Uns'Size);
+ -- We need an unsigned type large enough to represent the mantissa
+
+ Need_Extra : constant Boolean := Num'Machine_Mantissa > Uns'Size - 4;
+ -- 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.
+
+ Precision_Limit : constant Uns :=
+ (if Need_Extra then 2**Num'Machine_Mantissa - 1 else 2**Uns'Size - 1);
+ -- If we handle the extra digit separately, we use the precision of the
+ -- floating-point type so that the conversion is exact.
+
+ package Impl is new Value_R (Uns, Precision_Limit, Round => Need_Extra);
+
+ subtype Base_T is Unsigned range 2 .. 16;
+
+ -- The following tables compute the maximum exponent of the base that can
+ -- fit in the given floating-point format, that is to say the element at
+ -- index N is the largest K such that N**K <= Num'Last.
+
+ Maxexp32 : constant array (Base_T) of Positive :=
+ (2 => 127, 3 => 80, 4 => 63, 5 => 55, 6 => 49,
+ 7 => 45, 8 => 42, 9 => 40, 10 => 38, 11 => 37,
+ 12 => 35, 13 => 34, 14 => 33, 15 => 32, 16 => 31);
+
+ Maxexp64 : constant array (Base_T) of Positive :=
+ (2 => 1023, 3 => 646, 4 => 511, 5 => 441, 6 => 396,
+ 7 => 364, 8 => 341, 9 => 323, 10 => 308, 11 => 296,
+ 12 => 285, 13 => 276, 14 => 268, 15 => 262, 16 => 255);
+
+ Maxexp80 : constant array (Base_T) of Positive :=
+ (2 => 16383, 3 => 10337, 4 => 8191, 5 => 7056, 6 => 6338,
+ 7 => 5836, 8 => 5461, 9 => 5168, 10 => 4932, 11 => 4736,
+ 12 => 4570, 13 => 4427, 14 => 4303, 15 => 4193, 16 => 4095);
+
+ function Integer_to_Real
+ (Str : String;
+ Val : Uns;
+ Base : Unsigned;
+ Scale : Integer;
+ Extra : Unsigned;
+ Minus : Boolean) return Num;
+ -- Convert the real value from integer to real representation
+
+ ---------------------
+ -- Integer_to_Real --
+ ---------------------
+
+ function Integer_to_Real
+ (Str : String;
+ Val : Uns;
+ Base : Unsigned;
+ Scale : Integer;
+ Extra : Unsigned;
+ Minus : Boolean) return Num
is
- Precision_Limit_Reached : Boolean := False;
- -- Set to True if addition of a digit will cause Value to be superior
- -- to Precision_Limit.
+ pragma Assert (Base in 2 .. 16);
+
+ pragma Assert (Num'Machine_Radix = 2);
+
+ pragma Unsuppress (Range_Check);
+
+ Maxexp : constant Positive :=
+ (if Num'Size = 32 then Maxexp32 (Base)
+ elsif Num'Size = 64 then Maxexp64 (Base)
+ elsif Num'Machine_Mantissa = 64 then Maxexp80 (Base)
+ else raise Program_Error);
+ -- Maximum exponent of the base that can fit in Num
- Digit : Char_As_Digit;
- -- The current digit.
+ B : constant Num := Num (Base);
- Trailing_Zeros : Natural := 0;
- -- Number of trailing zeros at a given point.
+ R_Val : Num;
+ S : Integer := Scale;
begin
- pragma Assert (Base in 2 .. 16);
+ -- We call the floating-point processor reset routine so we can be sure
+ -- that the x87 FPU is properly set for conversions. This is especially
+ -- needed on Windows, where calls to the operating system randomly reset
+ -- the processor into 64-bit mode.
- -- If initial Scale is not 0 then it means that Precision_Limit was
- -- reached during integral part scanning.
- if Scale > 0 then
- Precision_Limit_Reached := True;
+ if Num'Machine_Mantissa = 64 then
+ System.Float_Control.Reset;
end if;
- -- The function precondition is that the first character is a valid
- -- digit.
- Digit := As_Digit (Str (Index));
-
- loop
- -- Check if base is correct. If the base is not specified the digit
- -- E or e cannot be considered as a base violation as it can be used
- -- for exponentiation.
- if Digit >= Base then
- if Base_Specified then
- Base_Violation := True;
- elsif Digit = E_Digit then
- return;
- else
- Base_Violation := True;
- end if;
- end if;
-
- -- If precision limit has been reached just ignore any remaining
- -- digits for the computation of Value and Scale. The scanning
- -- should continue only to assess the validity of the string
- if not Precision_Limit_Reached then
- if Digit = 0 then
- -- Trailing '0' digits are ignored unless a non-zero digit is
- -- found.
- Trailing_Zeros := Trailing_Zeros + 1;
- else
-
- -- Handle accumulated zeros.
- for J in 1 .. Trailing_Zeros loop
- if Value > Precision_Limit / Base then
- Precision_Limit_Reached := True;
- exit;
- else
- Value := Value * Base;
- Scale := Scale - 1;
- end if;
- end loop;
+ -- Do the conversion
- -- Reset trailing zero counter
- Trailing_Zeros := 0;
+ R_Val := Num (Val);
- -- Handle current non zero digit
- if Value > (Precision_Limit - Digit) / Base then
- Precision_Limit_Reached := True;
- else
- Value := Value * Base + Digit;
- Scale := Scale - 1;
- end if;
- end if;
- end if;
+ -- Take into account the extra digit, if need be. In this case, the
+ -- three operands are exact, so using an FMA would be ideal.
- -- Check next character
- Index := Index + 1;
+ if Need_Extra and then Extra > 0 then
+ R_Val := R_Val * B + Num (Extra);
+ S := S - 1;
+ end if;
- if Index > Max then
- return;
- end if;
+ -- Compute the final value
- Digit := As_Digit (Str (Index));
+ if R_Val /= 0.0 and then S /= 0 then
+ 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.
- if Digit < 0 then
- if Digit = Underscore and Index + 1 <= Max then
- -- Underscore is only allowed if followed by a digit
- Digit := As_Digit (Str (Index + 1));
- if Digit in Valid_Digit then
- Index := Index + 1;
- else
- return;
+ when 2 =>
+ R_Val := Num'Scaling (R_Val, S);
+
+ when 4 =>
+ if Integer'First / 2 <= S and then S <= Integer'Last / 2 then
+ S := S * 2;
end if;
- else
- -- Neither a valid underscore nor a digit.
- return;
- end if;
- end if;
- end loop;
- end Scan_Decimal_Digits;
-
- --------------------------
- -- Scan_Integral_Digits --
- --------------------------
-
- procedure Scan_Integral_Digits
- (Str : String;
- Index : in out Integer;
- Max : Integer;
- Value : out Long_Long_Integer;
- Scale : out Integer;
- Base_Violation : in out Boolean;
- Base : Long_Long_Integer := 10;
- Base_Specified : Boolean := False)
- is
- Precision_Limit_Reached : Boolean := False;
- -- Set to True if addition of a digit will cause Value to be superior
- -- to Precision_Limit.
- Digit : Char_As_Digit;
- -- The current digit
- begin
+ R_Val := Num'Scaling (R_Val, S);
- -- Initialize Scale and Value
- Value := 0;
- Scale := 0;
-
- -- The function precondition is that the first character is a valid
- -- digit.
- Digit := As_Digit (Str (Index));
-
- loop
- -- Check if base is correct. If the base is not specified the digit
- -- E or e cannot be considered as a base violation as it can be used
- -- for exponentiation.
- if Digit >= Base then
- if Base_Specified then
- Base_Violation := True;
- elsif Digit = E_Digit then
- return;
- else
- Base_Violation := True;
- end if;
- end if;
-
- if Precision_Limit_Reached then
- -- Precision limit has been reached so just update the exponent
- Scale := Scale + 1;
- else
- pragma Assert (Base /= 0);
-
- if Value > (Precision_Limit - Digit) / Base then
- -- Updating Value will overflow so ignore this digit and any
- -- following ones. Only update the scale
- Precision_Limit_Reached := True;
- Scale := Scale + 1;
- else
- Value := Value * Base + Digit;
- end if;
- end if;
-
- -- Look for the next character
- Index := Index + 1;
- if Index > Max then
- return;
- end if;
-
- Digit := As_Digit (Str (Index));
-
- if Digit not in Valid_Digit then
- -- Next character is not a digit. In that case stop scanning
- -- unless the next chracter is an underscore followed by a digit.
- if Digit = Underscore and Index + 1 <= Max then
- Digit := As_Digit (Str (Index + 1));
- if Digit in Valid_Digit then
- Index := Index + 1;
- else
- return;
+ when 8 =>
+ if Integer'First / 3 <= S and then S <= Integer'Last / 3 then
+ S := S * 3;
end if;
- else
- return;
- end if;
- end if;
- end loop;
- end Scan_Integral_Digits;
+ R_Val := Num'Scaling (R_Val, S);
- ---------------
- -- Scan_Real --
- ---------------
-
- function Scan_Real
- (Str : String;
- Ptr : not null access Integer;
- Max : Integer)
- return Long_Long_Float
+ when 16 =>
+ if Integer'First / 4 <= S and then S <= Integer'Last / 4 then
+ S := S * 4;
+ end if;
- is
- Start : Positive;
- -- Position of starting non-blank character
+ R_Val := Num'Scaling (R_Val, S);
- Minus : Boolean;
- -- Set to True if minus sign is present, otherwise to False
+ -- If the base is 10, we use a table of powers for accuracy's sake
- Index : Integer;
- -- Local copy of string pointer
+ when 10 =>
+ declare
+ Powten : constant array (0 .. Maxpow) of Num;
+ pragma Import (Ada, Powten);
+ for Powten'Address use Powten_Address;
- Int_Value : Long_Long_Integer := -1;
- -- Mantissa as an Integer
+ begin
+ if S > 0 then
+ while S > Maxpow loop
+ R_Val := R_Val * Powten (Maxpow);
+ S := S - Maxpow;
+ end loop;
- Int_Scale : Integer := 0;
- -- Exponent value
+ R_Val := R_Val * Powten (S);
- Base_Violation : Boolean := False;
- -- If True some digits where not in the base. The float is still scan
- -- till the end even if an error will be raised.
-
- Uval : Long_Long_Float := 0.0;
- -- Contain the final value at the end of the function
+ else
+ while S < -Maxpow loop
+ R_Val := R_Val / Powten (Maxpow);
+ S := S + Maxpow;
+ end loop;
- After_Point : Boolean := False;
- -- True if a decimal should be parsed
+ R_Val := R_Val / Powten (-S);
+ end if;
+ end;
- Base : Long_Long_Integer := 10;
- -- Current base (default: 10)
+ -- Implementation for other bases with exponentiation
- Base_Char : Character := ASCII.NUL;
- -- Character used to set the base. If Nul this means that default
- -- base is used.
+ -- 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.
- begin
- -- We do not tolerate strings with Str'Last = Positive'Last
+ when others =>
+ if S > 0 then
+ R_Val := R_Val * B ** S;
- if Str'Last = Positive'Last then
- raise Program_Error with
- "string upper bound is Positive'Last, not supported";
- end if;
+ else
+ if S < -Maxexp then
+ R_Val := R_Val / B ** Maxexp;
+ S := S + Maxexp;
+ end if;
- -- We call the floating-point processor reset routine so that we can
- -- be sure the floating-point processor is properly set for conversion
- -- calls. This is notably need on Windows, where calls to the operating
- -- system randomly reset the processor into 64-bit mode.
-
- System.Float_Control.Reset;
-
- -- Scan the optional sign
- Scan_Sign (Str, Ptr, Max, Minus, Start);
- Index := Ptr.all;
- Ptr.all := Start;
-
- -- First character can be either a decimal digit or a dot.
- if Str (Index) in '0' .. '9' then
- pragma Annotate
- (CodePeer, Intentional,
- "test always true", "defensive code below");
-
- -- If this is a digit it can indicates either the float decimal
- -- part or the base to use
- Scan_Integral_Digits
- (Str,
- Index,
- Max => Max,
- Value => Int_Value,
- Scale => Int_Scale,
- Base_Violation => Base_Violation,
- Base => 10);
- elsif Str (Index) = '.' and then
- -- A dot is only allowed if followed by a digit.
- Index < Max and then
- Str (Index + 1) in '0' .. '9'
- then
- -- Initial point, allowed only if followed by digit (RM 3.5(47))
- After_Point := True;
- Index := Index + 1;
- Int_Value := 0;
- else
- Bad_Value (Str);
+ R_Val := R_Val / B ** (-S);
+ end if;
+ end case;
end if;
- -- Check if the first number encountered is a base
- if Index < Max and then
- (Str (Index) = '#' or else Str (Index) = ':')
- then
- Base_Char := Str (Index);
- Base := Int_Value;
-
- -- Reset Int_Value to indicate that parsing of integral value should
- -- be done
- Int_Value := -1;
- if Base < 2 or else Base > 16 then
- Base_Violation := True;
- Base := 16;
- end if;
-
- Index := Index + 1;
-
- if Str (Index) = '.' and then
- Index < Max and then
- As_Digit (Str (Index + 1)) in Valid_Digit
- then
- After_Point := True;
- Index := Index + 1;
- Int_Value := 0;
- end if;
- end if;
+ -- Finally deal with initial minus sign, note that this processing is
+ -- done even if Uval is zero, so that -0.0 is correctly interpreted.
- -- Does scanning of integral part needed
- if Int_Value < 0 then
- if Index > Max or else As_Digit (Str (Index)) not in Valid_Digit then
- Bad_Value (Str);
- end if;
-
- Scan_Integral_Digits
- (Str,
- Index,
- Max => Max,
- Value => Int_Value,
- Scale => Int_Scale,
- Base_Violation => Base_Violation,
- Base => Base,
- Base_Specified => Base_Char /= ASCII.NUL);
- end if;
+ return (if Minus then -R_Val else R_Val);
- -- Do we have a dot ?
- if not After_Point and then
- Index <= Max and then
- Str (Index) = '.'
- then
- -- At this stage if After_Point was not set, this means that an
- -- integral part has been found. Thus the dot is valid even if not
- -- followed by a digit.
- if Index < Max and then As_Digit (Str (Index + 1)) in Valid_Digit then
- After_Point := True;
- end if;
-
- Index := Index + 1;
- end if;
+ exception
+ when Constraint_Error => Bad_Value (Str);
+ end Integer_to_Real;
- if After_Point then
- -- Parse decimal part
- Scan_Decimal_Digits
- (Str,
- Index,
- Max => Max,
- Value => Int_Value,
- Scale => Int_Scale,
- Base_Violation => Base_Violation,
- Base => Base,
- Base_Specified => Base_Char /= ASCII.NUL);
- end if;
+ ---------------
+ -- Scan_Real --
+ ---------------
- -- If an explicit base was specified ensure that the delimiter is found
- if Base_Char /= ASCII.NUL then
- if Index > Max or else Str (Index) /= Base_Char then
- Bad_Value (Str);
- else
- Index := Index + 1;
- end if;
- end if;
+ function Scan_Real
+ (Str : String;
+ Ptr : not null access Integer;
+ Max : Integer) return Num
+ is
+ Base : Unsigned;
+ Scale : Integer;
+ Extra : Unsigned;
+ Minus : Boolean;
+ Val : Uns;
- -- Compute the final value
- Uval := Long_Long_Float (Int_Value);
-
- -- Update pointer and scan exponent.
- Ptr.all := Index;
-
- Int_Scale := Int_Scale + Scan_Exponent (Str,
- Ptr,
- Max,
- Real => True);
-
- Uval := Uval * Long_Long_Float (Base) ** Int_Scale;
-
- -- Here is where we check for a bad based number
- if Base_Violation then
- Bad_Value (Str);
-
- -- If OK, then deal with initial minus sign, note that this processing
- -- is done even if Uval is zero, so that -0.0 is correctly interpreted.
- else
- if Minus then
- return -Uval;
- else
- return Uval;
- end if;
- end if;
+ begin
+ Val := Impl.Scan_Raw_Real (Str, Ptr, Max, Base, Scale, Extra, Minus);
+ return Integer_to_Real (Str, Val, Base, Scale, Extra, Minus);
end Scan_Real;
----------------
-- Value_Real --
----------------
- function Value_Real (Str : String) return Long_Long_Float is
+ function Value_Real (Str : String) return Num is
+ Base : Unsigned;
+ Scale : Integer;
+ Extra : Unsigned;
+ Minus : Boolean;
+ Val : Uns;
+
begin
- -- We have to special case Str'Last = Positive'Last because the normal
- -- circuit ends up setting P to Str'Last + 1 which is out of bounds. We
- -- deal with this by converting to a subtype which fixes the bounds.
-
- if Str'Last = Positive'Last then
- declare
- subtype NT is String (1 .. Str'Length);
- begin
- return Value_Real (NT (Str));
- end;
-
- -- Normal case where Str'Last < Positive'Last
-
- else
- declare
- V : Long_Long_Float;
- P : aliased Integer := Str'First;
- begin
- V := Scan_Real (Str, P'Access, Str'Last);
- Scan_Trailing_Blanks (Str, P);
- return V;
- end;
- end if;
+ Val := Impl.Value_Raw_Real (Str, Base, Scale, Extra, Minus);
+
+ return Integer_to_Real (Str, Val, Base, Scale, Extra, Minus);
end Value_Real;
end System.Val_Real;
diff --git a/gcc/ada/libgnat/s-valrea.ads b/gcc/ada/libgnat/s-valrea.ads
index cb5374c..d6ade80 100644
--- a/gcc/ada/libgnat/s-valrea.ads
+++ b/gcc/ada/libgnat/s-valrea.ads
@@ -29,13 +29,26 @@
-- --
------------------------------------------------------------------------------
+-- This package contains routines for scanning real values for use in
+-- Text_IO.Float_IO and the Value attribute.
+
+generic
+
+ type Num is digits <>;
+
+ type Uns is mod <>;
+
+ Maxpow : Positive;
+
+ Powten_Address : System.Address;
+
package System.Val_Real is
pragma Preelaborate;
function Scan_Real
(Str : String;
Ptr : not null access Integer;
- Max : Integer) return Long_Long_Float;
+ Max : Integer) return Num;
-- This function scans the string starting at Str (Ptr.all) for a valid
-- real literal according to the syntax described in (RM 3.5(43)). The
-- substring scanned extends no further than Str (Max). There are three
@@ -65,10 +78,10 @@ package System.Val_Real is
-- If this occurs Program_Error is raised with a message noting that this
-- case is not supported. Most such cases are eliminated by the caller.
- function Value_Real (Str : String) return Long_Long_Float;
+ function Value_Real (Str : String) return Num;
-- Used in computing X'Value (Str) where X is a floating-point type or an
-- ordinary fixed-point type. Str is the string argument of the attribute.
-- Constraint_Error is raised if the string is malformed, or if the value
- -- out of range of Long_Long_Float.
+ -- out of range of Num.
end System.Val_Real;
diff --git a/gcc/ada/libgnat/s-valued.adb b/gcc/ada/libgnat/s-valued.adb
new file mode 100644
index 0000000..8930752
--- /dev/null
+++ b/gcc/ada/libgnat/s-valued.adb
@@ -0,0 +1,263 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . V A L U E _ D --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with System.Unsigned_Types; use System.Unsigned_Types;
+with System.Val_Util; use System.Val_Util;
+with System.Value_R;
+
+package body System.Value_D is
+
+ pragma Assert (Int'Size <= Uns'Size);
+ -- We need an unsigned type large enough to represent the mantissa
+
+ package Impl is new Value_R (Uns, 2**(Int'Size - 1), Round => False);
+ -- We do not use the Extra digit for decimal fixed-point types
+
+ function Integer_to_Decimal
+ (Str : String;
+ Val : Uns;
+ Base : Unsigned;
+ ScaleB : Integer;
+ Minus : Boolean;
+ Scale : Integer) return Int;
+ -- Convert the real value from integer to decimal representation
+
+ ------------------------
+ -- Integer_to_Decimal --
+ ------------------------
+
+ function Integer_to_Decimal
+ (Str : String;
+ Val : Uns;
+ Base : Unsigned;
+ ScaleB : Integer;
+ Minus : Boolean;
+ Scale : Integer) return Int
+ is
+ function Safe_Expont
+ (Base : Int;
+ Exp : in out Natural;
+ Factor : Int) return Int;
+ -- Return (Base ** Exp) * Factor if the computation does not overflow,
+ -- or else the number of the form (Base ** K) * Factor with the largest
+ -- magnitude if the former computation overflows. In both cases, Exp is
+ -- updated to contain the remaining power in the computation. Note that
+ -- Factor is expected to be positive in this context.
+
+ function Unsigned_To_Signed (Val : Uns) return Int;
+ -- Convert an integer value from unsigned to signed representation
+
+ -----------------
+ -- Safe_Expont --
+ -----------------
+
+ function Safe_Expont
+ (Base : Int;
+ Exp : in out Natural;
+ Factor : Int) return Int
+ is
+ pragma Assert (Base /= 0 and then Factor > 0);
+
+ Max : constant Int := Int'Last / Base;
+
+ Result : Int := Factor;
+
+ begin
+ while Exp > 0 and then Result <= Max loop
+ Result := Result * Base;
+ Exp := Exp - 1;
+ end loop;
+
+ return Result;
+ end Safe_Expont;
+
+ ------------------------
+ -- Unsigned_To_Signed --
+ ------------------------
+
+ function Unsigned_To_Signed (Val : Uns) return Int is
+ begin
+ -- Deal with overflow cases, and also with largest negative number
+
+ if Val > Uns (Int'Last) then
+ if Minus and then Val = Uns (-(Int'First)) then
+ return Int'First;
+ else
+ Bad_Value (Str);
+ end if;
+
+ -- Negative values
+
+ elsif Minus then
+ return -(Int (Val));
+
+ -- Positive values
+
+ else
+ return Int (Val);
+ end if;
+ end Unsigned_To_Signed;
+
+ begin
+ -- If the base of the value is 10 or its scaling factor is zero, then
+ -- add the scales (they are defined in the opposite sense) and apply
+ -- the result to the value, checking for overflow in the process.
+
+ if Base = 10 or else ScaleB = 0 then
+ declare
+ S : Integer := ScaleB + Scale;
+ V : Uns := Val;
+
+ begin
+ while S < 0 loop
+ V := V / 10;
+ S := S + 1;
+ end loop;
+
+ while S > 0 loop
+ if V <= Uns'Last / 10 then
+ V := V * 10;
+ S := S - 1;
+ else
+ Bad_Value (Str);
+ end if;
+ end loop;
+
+ return Unsigned_To_Signed (V);
+ end;
+
+ -- If the base of the value is not 10, use a scaled divide operation
+ -- to compute Val * (Base ** ScaleB) * (10 ** Scale).
+
+ else
+ declare
+ B : constant Int := Int (Base);
+ S : constant Integer := ScaleB;
+
+ V : Uns := Val;
+
+ Y, Z, Q, R : Int;
+
+ begin
+ -- If S is too negative, then drop trailing digits
+
+ if S < 0 then
+ declare
+ LS : Integer := -S;
+
+ begin
+ Y := 10 ** Integer'Max (0, Scale);
+ Z := Safe_Expont (B, LS, 10 ** Integer'Max (0, -Scale));
+
+ for J in 1 .. LS loop
+ V := V / Uns (B);
+ end loop;
+ end;
+
+ -- If S is too positive, then scale V up, which may then overflow
+
+ elsif S > 0 then
+ declare
+ LS : Integer := S;
+
+ begin
+ Y := Safe_Expont (B, LS, 10 ** Integer'Max (0, Scale));
+ Z := 10 ** Integer'Max (0, -Scale);
+
+ for J in 1 .. LS loop
+ if V <= Uns'Last / Uns (B) then
+ V := V * Uns (B);
+ else
+ Bad_Value (Str);
+ end if;
+ end loop;
+ end;
+
+ -- The case S equal to zero should have been handled earlier
+
+ else
+ raise Program_Error;
+ end if;
+
+ -- Perform a scale divide operation with rounding to match 'Image
+
+ Scaled_Divide (Unsigned_To_Signed (V), Y, Z, Q, R, Round => True);
+
+ return Q;
+ end;
+ end if;
+
+ exception
+ when Constraint_Error => Bad_Value (Str);
+ end Integer_to_Decimal;
+
+ ------------------
+ -- Scan_Decimal --
+ ------------------
+
+ function Scan_Decimal
+ (Str : String;
+ Ptr : not null access Integer;
+ Max : Integer;
+ Scale : Integer) return Int
+ is
+ Base : Unsigned;
+ ScaleB : Integer;
+ Extra : Unsigned;
+ pragma Unreferenced (Extra);
+ Minus : Boolean;
+ Val : Uns;
+
+ begin
+ Val := Impl.Scan_Raw_Real (Str, Ptr, Max, Base, ScaleB, Extra, Minus);
+
+ return Integer_to_Decimal (Str, Val, Base, ScaleB, Minus, Scale);
+ end Scan_Decimal;
+
+ -------------------
+ -- Value_Decimal --
+ -------------------
+
+ function Value_Decimal (Str : String; Scale : Integer) return Int is
+ Base : Unsigned;
+ ScaleB : Integer;
+ Extra : Unsigned;
+ pragma Unreferenced (Extra);
+ Minus : Boolean;
+ Val : Uns;
+
+ begin
+ Val := Impl.Value_Raw_Real (Str, Base, ScaleB, Extra, Minus);
+
+ return Integer_to_Decimal (Str, Val, Base, ScaleB, Minus, Scale);
+ end Value_Decimal;
+
+end System.Value_D;
diff --git a/gcc/ada/libgnat/s-valdec.ads b/gcc/ada/libgnat/s-valued.ads
index 05fab98..e27e171 100644
--- a/gcc/ada/libgnat/s-valdec.ads
+++ b/gcc/ada/libgnat/s-valued.ads
@@ -2,11 +2,11 @@
-- --
-- GNAT COMPILER COMPONENTS --
-- --
--- S Y S T E M . V A L _ D E C --
+-- S Y S T E M . V A L U E _ D --
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -29,18 +29,29 @@
-- --
------------------------------------------------------------------------------
--- This package contains routines for scanning decimal values where the size
--- of the type is no greater than Standard.Integer'Size, for use in Text_IO.
--- Decimal_IO, and the Value attribute for such decimal types.
+-- This package contains the routines for supporting the Value attribute for
+-- decimal fixed point types, and also for conversion operations required in
+-- Text_IO.Decimal_IO for such types.
-package System.Val_Dec is
+generic
+
+ type Int is range <>;
+
+ type Uns is mod <>;
+
+ with procedure Scaled_Divide
+ (X, Y, Z : Int;
+ Q, R : out Int;
+ Round : Boolean);
+
+package System.Value_D is
pragma Preelaborate;
function Scan_Decimal
(Str : String;
Ptr : not null access Integer;
Max : Integer;
- Scale : Integer) return Integer;
+ Scale : Integer) return Int;
-- This function scans the string starting at Str (Ptr.all) for a valid
-- real literal according to the syntax described in (RM 3.5(43)). The
-- substring scanned extends no further than Str (Max). There are three
@@ -49,8 +60,8 @@ package System.Val_Dec is
-- If a valid real literal is found after scanning past any initial spaces,
-- then Ptr.all is updated past the last character of the literal (but
-- trailing spaces are not scanned out). The value returned is the value
- -- Integer'Integer_Value (decimal-literal-value), using the given Scale
- -- to determine this value.
+ -- Int'Integer_Value (decimal-literal-value), using the given Scale to
+ -- determine this value.
--
-- If no valid real literal is found, then Ptr.all points either to an
-- initial non-digit character, or to Max + 1 if the field is all spaces
@@ -68,13 +79,12 @@ package System.Val_Dec is
-- special case of an all-blank string, and Ptr is unchanged, and hence
-- is greater than Max as required in this case.
- function Value_Decimal (Str : String; Scale : Integer) return Integer;
- -- Used in computing X'Value (Str) where X is a decimal fixed-point type
- -- whose size does not exceed Standard.Integer'Size. Str is the string
- -- argument of the attribute. Constraint_Error is raised if the string
- -- is malformed or if the value is out of range of Integer (not the
- -- range of the fixed-point type, that check must be done by the caller.
- -- Otherwise the value returned is the value Integer'Integer_Value
+ function Value_Decimal (Str : String; Scale : Integer) return Int;
+ -- Used in computing X'Value (Str) where X is a decimal fixed-point type.
+ -- Str is the string argument of the attribute. Constraint_Error is raised
+ -- if the string is malformed or if the value is out of range of Int (not
+ -- the range of the fixed-point type, which must be done by the caller).
+ -- Otherwise the value returned is the value Int'Integer_Value
-- (decimal-literal-value), using Scale to determine this value.
-end System.Val_Dec;
+end System.Value_D;
diff --git a/gcc/ada/libgnat/s-valuef.adb b/gcc/ada/libgnat/s-valuef.adb
new file mode 100644
index 0000000..d13111a
--- /dev/null
+++ b/gcc/ada/libgnat/s-valuef.adb
@@ -0,0 +1,368 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . V A L U E _ F --
+-- --
+-- 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 System.Unsigned_Types; use System.Unsigned_Types;
+with System.Val_Util; use System.Val_Util;
+with System.Value_R;
+
+package body System.Value_F is
+
+ -- The prerequisite of the implementation is that the computation of the
+ -- operands of the scaled divide does not unduly overflow when the small
+ -- is neither an integer nor the reciprocal of an integer, which means
+ -- that its numerator and denominator must be both not larger than the
+ -- smallest divide 2**(Int'Size - 1) / Base where Base ranges over the
+ -- supported values for the base of the literal. Given that the largest
+ -- supported base is 16, this gives a limit of 2**(Int'Size - 5).
+
+ pragma Assert (Int'Size <= Uns'Size);
+ -- We need an unsigned type large enough to represent the mantissa
+
+ package Impl is new Value_R (Uns, 2**(Int'Size - 1), Round => True);
+ -- We use the Extra digit for ordinary fixed-point types
+
+ function Integer_To_Fixed
+ (Str : String;
+ Val : Uns;
+ Base : Unsigned;
+ ScaleB : Integer;
+ Extra : Unsigned;
+ Minus : Boolean;
+ Num : Int;
+ Den : Int) return Int;
+ -- Convert the real value from integer to fixed point representation
+
+ -- The goal is to compute Val * (Base ** ScaleB) / (Num / Den) with correct
+ -- rounding for all decimal values output by Typ'Image, that is to say up
+ -- to Typ'Aft decimal digits. Unlike for the output, the RM does not say
+ -- what the rounding must be for the input, but a reasonable exegesis of
+ -- the intent is that Typ'Value o Typ'Image should be the identity, which
+ -- is made possible because 'Aft is defined such that 'Image is injective.
+
+ -- For a type with a mantissa of M bits including the sign, the number N1
+ -- of decimal digits required to represent all the numbers is given by:
+
+ -- N1 = ceil ((M - 1) * log 2 / log 10) [N1 = 10/19/39 for M = 32/64/128]
+
+ -- but this mantissa can represent any set of contiguous numbers with only
+ -- N2 different decimal digits where:
+
+ -- N2 = floor ((M - 1) * log 2 / log 10) [N2 = 9/18/38 for M = 32/64/128]
+
+ -- Of course N1 = N2 + 1 holds, which means both that Val may not contain
+ -- enough significant bits to represent all the values of the type and that
+ -- 1 extra decimal digit contains the information for the missing bits.
+
+ -- Therefore the actual computation to be performed is
+
+ -- V = (Val * Base + Extra) * (Base ** (ScaleB - 1)) / (Num / Den)
+
+ -- using two steps of scaled divide if Extra is positive and ScaleB too
+
+ -- (1) Val * (Den * (Base ** ScaleB)) = Q1 * Num + R1
+
+ -- (2) Extra * (Den * (Base ** ScaleB)) = Q2 * -Base + R2
+
+ -- which yields after dividing (1) by Num and (2) by Num * Base and summing
+
+ -- V = Q1 + (R1 - Q2) / Num + R2 / (Num * Base)
+
+ -- but we get rid of the third term by using a rounding divide for (2).
+
+ -- This works only if Den * (Base ** ScaleB) does not overflow for inputs
+ -- corresponding to 'Image. Let S = Num / Den, B = Base and N the scale in
+ -- base B of S, i.e. the smallest integer such that B**N * S >= 1. Then,
+ -- for X a positive of the mantissa, i.e. 1 <= X <= 2**(M-1), we have
+
+ -- 1/B <= X * S * B**(N-1) < 2**(M-1)
+
+ -- which means that the inputs corresponding to the output of 'Image have a
+ -- ScaleB equal either to 1 - N or (after multiplying the inequality by B)
+ -- to -N, possibly after renormalizing X, i.e. multiplying it by a suitable
+ -- power of B. Therefore
+
+ -- Den * (Base ** ScaleB) <= Den * (B ** (1 - N)) < Num * B
+
+ -- which means that the product does not overflow if Num <= 2**(M-1) / B.
+
+ -- On the other hand, if Extra is positive and ScaleB negative, the above
+ -- two steps are
+
+ -- (1b) Val * Den = Q1 * (Num * (Base ** -ScaleB)) + R1
+
+ -- (2b) Extra * Den = Q2 * -Base + R2
+
+ -- which yields after dividing (1b) by Num * (Base ** -ScaleB) and (2b) by
+ -- Num * (Base ** (1 - ScaleB)) and summing
+
+ -- V = Q1 + (R1 - Q2) / (Num * (Base ** -ScaleB)) + R2 / ...
+
+ -- but we get rid of the third term by using a rounding divide for (2b).
+
+ -- This works only if Num * (Base ** -ScaleB) does not overflow for inputs
+ -- corresponding to 'Image. With the determination of ScaleB above, we have
+
+ -- Num * (Base ** -ScaleB) <= Num * (B ** N) < Den * B
+
+ -- which means that the product does not overflow if Den <= 2**(M-1) / B.
+
+ ----------------------
+ -- Integer_To_Fixed --
+ ----------------------
+
+ function Integer_To_Fixed
+ (Str : String;
+ Val : Uns;
+ Base : Unsigned;
+ ScaleB : Integer;
+ Extra : Unsigned;
+ Minus : Boolean;
+ Num : Int;
+ Den : Int) return Int
+ is
+ pragma Assert (Base in 2 .. 16);
+
+ pragma Assert (Extra < Base);
+ -- Accept only one extra digit after those used for Val
+
+ pragma Assert (Num < 0 and then Den < 0);
+ -- Accept only negative numbers to allow -2**(Int'Size - 1)
+
+ function Safe_Expont
+ (Base : Int;
+ Exp : in out Natural;
+ Factor : Int) return Int;
+ -- Return (Base ** Exp) * Factor if the computation does not overflow,
+ -- or else the number of the form (Base ** K) * Factor with the largest
+ -- magnitude if the former computation overflows. In both cases, Exp is
+ -- updated to contain the remaining power in the computation. Note that
+ -- Factor is expected to be negative in this context.
+
+ function Unsigned_To_Signed (Val : Uns) return Int;
+ -- Convert an integer value from unsigned to signed representation
+
+ -----------------
+ -- Safe_Expont --
+ -----------------
+
+ function Safe_Expont
+ (Base : Int;
+ Exp : in out Natural;
+ Factor : Int) return Int
+ is
+ pragma Assert (Base /= 0 and then Factor < 0);
+
+ Min : constant Int := Int'First / Base;
+
+ Result : Int := Factor;
+
+ begin
+ while Exp > 0 and then Result >= Min loop
+ Result := Result * Base;
+ Exp := Exp - 1;
+ end loop;
+
+ return Result;
+ end Safe_Expont;
+
+ ------------------------
+ -- Unsigned_To_Signed --
+ ------------------------
+
+ function Unsigned_To_Signed (Val : Uns) return Int is
+ begin
+ -- Deal with overflow cases, and also with largest negative number
+
+ if Val > Uns (Int'Last) then
+ if Minus and then Val = Uns (-(Int'First)) then
+ return Int'First;
+ else
+ Bad_Value (Str);
+ end if;
+
+ -- Negative values
+
+ elsif Minus then
+ return -(Int (Val));
+
+ -- Positive values
+
+ else
+ return Int (Val);
+ end if;
+ end Unsigned_To_Signed;
+
+ -- Local variables
+
+ B : constant Int := Int (Base);
+
+ V : Uns := Val;
+ E : Uns := Uns (Extra);
+
+ Y, Z, Q1, R1, Q2, R2 : Int;
+
+ begin
+ -- We will use a scaled divide operation for which we must control the
+ -- magnitude of operands so that an overflow exception is not unduly
+ -- raised during the computation. The only real concern is the exponent.
+
+ -- If ScaleB is too negative, then drop trailing digits, but preserve
+ -- the last dropped digit.
+
+ if ScaleB < 0 then
+ declare
+ LS : Integer := -ScaleB;
+
+ begin
+ Y := Den;
+ Z := Safe_Expont (B, LS, Num);
+
+ for J in 1 .. LS loop
+ E := V rem Uns (B);
+ V := V / Uns (B);
+ end loop;
+ end;
+
+ -- If ScaleB is too positive, then scale V up, which may then overflow
+
+ elsif ScaleB > 0 then
+ declare
+ LS : Integer := ScaleB;
+
+ begin
+ Y := Safe_Expont (B, LS, Den);
+ Z := Num;
+
+ for J in 1 .. LS loop
+ if V <= (Uns'Last - E) / Uns (B) then
+ V := V * Uns (B) + E;
+ E := 0;
+ else
+ Bad_Value (Str);
+ end if;
+ end loop;
+ end;
+
+ -- If ScaleB is zero, then proceed directly
+
+ else
+ Y := Den;
+ Z := Num;
+ end if;
+
+ -- Perform a scaled divide operation with final rounding to match Image
+ -- using two steps if there is an extra digit available. The second and
+ -- third operands are always negative so the sign of the quotient is the
+ -- sign of the first operand and the sign of the remainder the opposite.
+
+ if E > 0 then
+ Scaled_Divide (Unsigned_To_Signed (V), Y, Z, Q1, R1, Round => False);
+ Scaled_Divide (Unsigned_To_Signed (E), Y, -B, Q2, R2, Round => True);
+
+ -- Avoid an overflow during the subtraction. Note that Q2 is smaller
+ -- than Y and R1 smaller than Z in magnitude, so it is safe to take
+ -- their absolute value.
+
+ if abs Q2 >= 2 ** (Int'Size - 2)
+ or else abs R1 >= 2 ** (Int'Size - 2)
+ then
+ declare
+ Bit : constant Int := Q2 rem 2;
+
+ begin
+ Q2 := (Q2 - Bit) / 2;
+ R1 := (R1 - Bit) / 2;
+ Y := -2;
+ end;
+
+ else
+ Y := -1;
+ end if;
+
+ Scaled_Divide (Q2 - R1, Y, Z, Q2, R2, Round => True);
+
+ return Q1 + Q2;
+
+ else
+ Scaled_Divide (Unsigned_To_Signed (V), Y, Z, Q1, R1, Round => True);
+
+ return Q1;
+ end if;
+
+ exception
+ when Constraint_Error => Bad_Value (Str);
+ end Integer_To_Fixed;
+
+ ----------------
+ -- Scan_Fixed --
+ ----------------
+
+ function Scan_Fixed
+ (Str : String;
+ Ptr : not null access Integer;
+ Max : Integer;
+ Num : Int;
+ Den : Int) return Int
+ is
+ Base : Unsigned;
+ ScaleB : Integer;
+ Extra : Unsigned;
+ Minus : Boolean;
+ Val : Uns;
+
+ begin
+ Val := Impl.Scan_Raw_Real (Str, Ptr, Max, Base, ScaleB, Extra, Minus);
+
+ return Integer_To_Fixed (Str, Val, Base, ScaleB, Extra, Minus, Num, Den);
+ end Scan_Fixed;
+
+ -----------------
+ -- Value_Fixed --
+ -----------------
+
+ function Value_Fixed
+ (Str : String;
+ Num : Int;
+ Den : Int) return Int
+ is
+ Base : Unsigned;
+ ScaleB : Integer;
+ Extra : Unsigned;
+ Minus : Boolean;
+ Val : Uns;
+
+ begin
+ Val := Impl.Value_Raw_Real (Str, Base, ScaleB, Extra, Minus);
+
+ return Integer_To_Fixed (Str, Val, Base, ScaleB, Extra, Minus, Num, Den);
+ end Value_Fixed;
+
+end System.Value_F;
diff --git a/gcc/ada/libgnat/s-vallld.ads b/gcc/ada/libgnat/s-valuef.ads
index 652362d..abd4817 100644
--- a/gcc/ada/libgnat/s-vallld.ads
+++ b/gcc/ada/libgnat/s-valuef.ads
@@ -2,11 +2,11 @@
-- --
-- GNAT COMPILER COMPONENTS --
-- --
--- S Y S T E M . V A L _ L L D --
+-- S Y S T E M . V A L U E _ F --
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -29,18 +29,30 @@
-- --
------------------------------------------------------------------------------
--- This package contains routines for scanning decimal values where the size
--- of the type is greater than Standard.Integer'Size, for use in Text_IO.
--- Decimal_IO, and the Value attribute for such decimal types.
+-- This package contains the routines for supporting the Value attribute for
+-- ordinary fixed point types whose Small is the ratio of two Int values, and
+-- also for conversion operations required in Text_IO.Fixed_IO for such types.
-package System.Val_LLD is
+generic
+
+ type Int is range <>;
+
+ type Uns is mod <>;
+
+ with procedure Scaled_Divide
+ (X, Y, Z : Int;
+ Q, R : out Int;
+ Round : Boolean);
+
+package System.Value_F is
pragma Preelaborate;
- function Scan_Long_Long_Decimal
- (Str : String;
- Ptr : not null access Integer;
- Max : Integer;
- Scale : Integer) return Long_Long_Integer;
+ function Scan_Fixed
+ (Str : String;
+ Ptr : not null access Integer;
+ Max : Integer;
+ Num : Int;
+ Den : Int) return Int;
-- This function scans the string starting at Str (Ptr.all) for a valid
-- real literal according to the syntax described in (RM 3.5(43)). The
-- substring scanned extends no further than Str (Max). There are three
@@ -49,8 +61,8 @@ package System.Val_LLD is
-- If a valid real literal is found after scanning past any initial spaces,
-- then Ptr.all is updated past the last character of the literal (but
-- trailing spaces are not scanned out). The value returned is the value
- -- Long_Long_Integer'Integer_Value (decimal-literal-value), using the given
- -- Scale to determine this value.
+ -- Int'Integer_Value (decimal-literal-value), using the given Num/Den to
+ -- determine this value.
--
-- If no valid real literal is found, then Ptr.all points either to an
-- initial non-digit character, or to Max + 1 if the field is all spaces
@@ -68,14 +80,15 @@ package System.Val_LLD is
-- special case of an all-blank string, and Ptr is unchanged, and hence
-- is greater than Max as required in this case.
- function Value_Long_Long_Decimal
- (Str : String;
- Scale : Integer) return Long_Long_Integer;
- -- Used in computing X'Value (Str) where X is a decimal types whose size
- -- exceeds Standard.Integer'Size. Str is the string argument of the
- -- attribute. Constraint_Error is raised if the string is malformed
- -- or if the value is out of range, otherwise the value returned is the
- -- value Long_Long_Integer'Integer_Value (decimal-literal-value), using
- -- the given Scale to determine this value.
+ function Value_Fixed
+ (Str : String;
+ Num : Int;
+ Den : Int) return Int;
+ -- Used in computing X'Value (Str) where X is an ordinary fixed-point type.
+ -- Str is the string argument of the attribute. Constraint_Error is raised
+ -- if the string is malformed or if the value is out of range of Int (not
+ -- the range of the fixed-point type, which must be done by the caller).
+ -- Otherwise the value returned is the value Int'Integer_Value
+ -- (decimal-literal-value), using Small Num/Den to determine this value.
-end System.Val_LLD;
+end System.Value_F;
diff --git a/gcc/ada/libgnat/s-valuei.adb b/gcc/ada/libgnat/s-valuei.adb
index 1bc8b32..ac5a776 100644
--- a/gcc/ada/libgnat/s-valuei.adb
+++ b/gcc/ada/libgnat/s-valuei.adb
@@ -61,7 +61,7 @@ package body System.Value_I is
Uval := Scan_Raw_Unsigned (Str, Ptr, Max);
- -- Deal with overflow cases, and also with maximum negative number
+ -- Deal with overflow cases, and also with largest negative number
if Uval > Uns (Int'Last) then
if Minus and then Uval = Uns (-(Int'First)) then
diff --git a/gcc/ada/libgnat/s-valuer.adb b/gcc/ada/libgnat/s-valuer.adb
new file mode 100644
index 0000000..9e4de3e
--- /dev/null
+++ b/gcc/ada/libgnat/s-valuer.adb
@@ -0,0 +1,685 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . V A L U E _ R --
+-- --
+-- 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 System.Val_Util; use System.Val_Util;
+
+package body System.Value_R is
+
+ subtype Char_As_Digit is Unsigned range 0 .. 17;
+ subtype Valid_Digit is Char_As_Digit range 0 .. 15;
+ E_Digit : constant Char_As_Digit := 14;
+ Underscore : constant Char_As_Digit := 16;
+ Not_A_Digit : constant Char_As_Digit := 17;
+
+ function As_Digit (C : Character) return Char_As_Digit;
+ -- Given a character return the digit it represents
+
+ procedure Round_Extra
+ (Digit : Char_As_Digit;
+ Value : in out Uns;
+ Scale : in out Integer;
+ Extra : in out Char_As_Digit;
+ Base : Unsigned);
+ -- Round the triplet (Value, Scale, Extra) according to Digit in Base
+
+ procedure Scan_Decimal_Digits
+ (Str : String;
+ Index : in out Integer;
+ Max : Integer;
+ Value : in out Uns;
+ Scale : in out Integer;
+ Extra : in out Char_As_Digit;
+ Base_Violation : in out Boolean;
+ Base : Unsigned;
+ Base_Specified : Boolean);
+ -- Scan the decimal part of a real (i.e. after decimal separator)
+ --
+ -- The string parsed is Str (Index .. Max) and after the call Index will
+ -- point to the first non-parsed character.
+ --
+ -- For each digit parsed, Value = Value * Base + Digit and Scale is
+ -- decremented by 1. If precision limit is reached, remaining digits are
+ -- still parsed but ignored, except for the first which is stored in Extra.
+ --
+ -- Base_Violation is set to True if a digit found is not part of the Base
+ --
+ -- If Base_Specified is set, then the base was specified in the real
+
+ procedure Scan_Integral_Digits
+ (Str : String;
+ Index : in out Integer;
+ Max : Integer;
+ Value : out Uns;
+ Scale : out Integer;
+ Extra : out Char_As_Digit;
+ Base_Violation : in out Boolean;
+ Base : Unsigned;
+ Base_Specified : Boolean);
+ -- Scan the integral part of a real (i.e. before decimal separator)
+ --
+ -- The string parsed is Str (Index .. Max) and after the call Index will
+ -- point to the first non-parsed character.
+ --
+ -- For each digit parsed, either Value := Value * Base + Digit or Scale
+ -- is incremented by 1 if precision limit is reached, in which case the
+ -- remaining digits are still parsed but ignored, except for the first
+ -- which is stored in Extra.
+ --
+ -- Base_Violation is set to True if a digit found is not part of the Base
+ --
+ -- If Base_Specified is set, then the base was specified in the real
+
+ --------------
+ -- As_Digit --
+ --------------
+
+ function As_Digit (C : Character) return Char_As_Digit is
+ begin
+ case C is
+ when '0' .. '9' =>
+ return Character'Pos (C) - Character'Pos ('0');
+ when 'a' .. 'f' =>
+ return Character'Pos (C) - (Character'Pos ('a') - 10);
+ when 'A' .. 'F' =>
+ return Character'Pos (C) - (Character'Pos ('A') - 10);
+ when '_' =>
+ return Underscore;
+ when others =>
+ return Not_A_Digit;
+ end case;
+ end As_Digit;
+
+ -----------------
+ -- Round_Extra --
+ -----------------
+
+ procedure Round_Extra
+ (Digit : Char_As_Digit;
+ Value : in out Uns;
+ Scale : in out Integer;
+ Extra : in out Char_As_Digit;
+ Base : Unsigned)
+ is
+ B : constant Uns := Uns (Base);
+
+ begin
+ if Digit >= Base / 2 then
+
+ -- If Extra is maximum, round Value
+
+ if Extra = Base - 1 then
+
+ -- If Value is maximum, scale it up
+
+ if Value = Precision_Limit then
+ Extra := Char_As_Digit (Value mod B);
+ Value := Value / B;
+ Scale := Scale + 1;
+ Round_Extra (Digit, Value, Scale, Extra, Base);
+
+ else
+ Extra := 0;
+ Value := Value + 1;
+ end if;
+
+ else
+ Extra := Extra + 1;
+ end if;
+ end if;
+ end Round_Extra;
+
+ -------------------------
+ -- Scan_Decimal_Digits --
+ -------------------------
+
+ procedure Scan_Decimal_Digits
+ (Str : String;
+ Index : in out Integer;
+ Max : Integer;
+ Value : in out Uns;
+ Scale : in out Integer;
+ Extra : in out Char_As_Digit;
+ Base_Violation : in out Boolean;
+ Base : Unsigned;
+ Base_Specified : Boolean)
+
+ is
+ pragma Assert (Base in 2 .. 16);
+ pragma Assert (Index in Str'Range);
+ pragma Assert (Max <= Str'Last);
+
+ Umax : constant Uns := (Precision_Limit - Uns (Base) + 1) / Uns (Base);
+ -- Max value which cannot overflow on accumulating next digit
+
+ UmaxB : constant Uns := Precision_Limit / Uns (Base);
+ -- Numbers bigger than UmaxB overflow if multiplied by base
+
+ Precision_Limit_Reached : Boolean := False;
+ -- Set to True if addition of a digit will cause Value to be superior
+ -- to Precision_Limit.
+
+ Precision_Limit_Just_Reached : Boolean;
+ -- Set to True if Precision_Limit_Reached was just set to True, but only
+ -- used when Round is True.
+
+ Digit : Char_As_Digit;
+ -- The current digit
+
+ Temp : Uns;
+ -- Temporary
+
+ Trailing_Zeros : Natural := 0;
+ -- Number of trailing zeros at a given point
+
+ begin
+ -- If initial Scale is not 0 then it means that Precision_Limit was
+ -- reached during scanning of the integral part.
+
+ if Scale > 0 then
+ Precision_Limit_Reached := True;
+ else
+ Extra := 0;
+ end if;
+
+ if Round then
+ Precision_Limit_Just_Reached := False;
+ end if;
+
+ -- The function precondition is that the first character is a valid
+ -- digit.
+
+ Digit := As_Digit (Str (Index));
+
+ loop
+ -- Check if base is correct. If the base is not specified, the digit
+ -- E or e cannot be considered as a base violation as it can be used
+ -- for exponentiation.
+
+ if Digit >= Base then
+ if Base_Specified then
+ Base_Violation := True;
+ elsif Digit = E_Digit then
+ return;
+ else
+ Base_Violation := True;
+ end if;
+ end if;
+
+ -- If precision limit has been reached, just ignore any remaining
+ -- digits for the computation of Value and Scale, but store the
+ -- first in Extra and use the second to round Extra. The scanning
+ -- should continue only to assess the validity of the string.
+
+ if Precision_Limit_Reached then
+ if Round and then Precision_Limit_Just_Reached then
+ Round_Extra (Digit, Value, Scale, Extra, Base);
+ Precision_Limit_Just_Reached := False;
+ end if;
+
+ else
+ -- Trailing '0' digits are ignored until a non-zero digit is found
+
+ if Digit = 0 then
+ Trailing_Zeros := Trailing_Zeros + 1;
+
+ else
+ -- Handle accumulated zeros.
+
+ for J in 1 .. Trailing_Zeros loop
+ if Value <= UmaxB then
+ Value := Value * Uns (Base);
+ Scale := Scale - 1;
+
+ else
+ Precision_Limit_Reached := True;
+ exit;
+ end if;
+ end loop;
+
+ -- Reset trailing zero counter
+
+ Trailing_Zeros := 0;
+
+ -- Handle current non zero digit
+
+ Temp := Value * Uns (Base) + Uns (Digit);
+
+ -- 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
+ or else (Value <= UmaxB
+ and then ((Precision_Limit < Uns'Last
+ and then Temp <= Precision_Limit)
+ or else (Precision_Limit = Uns'Last
+ and then Temp >= Uns (Base))))
+ then
+ Value := Temp;
+ Scale := Scale - 1;
+
+ else
+ Extra := Digit;
+ Precision_Limit_Reached := True;
+ if Round then
+ Precision_Limit_Just_Reached := True;
+ end if;
+ end if;
+ end if;
+ end if;
+
+ -- Check next character
+
+ Index := Index + 1;
+
+ if Index > Max then
+ return;
+ end if;
+
+ Digit := As_Digit (Str (Index));
+
+ if Digit not in Valid_Digit then
+
+ -- Underscore is only allowed if followed by a digit
+
+ if Digit = Underscore and Index + 1 <= Max then
+
+ Digit := As_Digit (Str (Index + 1));
+ if Digit in Valid_Digit then
+ Index := Index + 1;
+ else
+ return;
+ end if;
+
+ -- Neither a valid underscore nor a digit
+
+ else
+ return;
+ end if;
+ end if;
+ end loop;
+ end Scan_Decimal_Digits;
+
+ --------------------------
+ -- Scan_Integral_Digits --
+ --------------------------
+
+ procedure Scan_Integral_Digits
+ (Str : String;
+ Index : in out Integer;
+ Max : Integer;
+ Value : out Uns;
+ Scale : out Integer;
+ Extra : out Char_As_Digit;
+ Base_Violation : in out Boolean;
+ Base : Unsigned;
+ Base_Specified : Boolean)
+ is
+ pragma Assert (Base in 2 .. 16);
+
+ Umax : constant Uns := (Precision_Limit - Uns (Base) + 1) / Uns (Base);
+ -- Max value which cannot overflow on accumulating next digit
+
+ UmaxB : constant Uns := Precision_Limit / Uns (Base);
+ -- Numbers bigger than UmaxB overflow if multiplied by base
+
+ Precision_Limit_Reached : Boolean := False;
+ -- Set to True if addition of a digit will cause Value to be superior
+ -- to Precision_Limit.
+
+ Precision_Limit_Just_Reached : Boolean;
+ -- Set to True if Precision_Limit_Reached was just set to True, but only
+ -- used when Round is True.
+
+ Digit : Char_As_Digit;
+ -- The current digit
+
+ Temp : Uns;
+ -- Temporary
+
+ begin
+ -- Initialize Value, Scale and Extra
+
+ Value := 0;
+ Scale := 0;
+ Extra := 0;
+
+ if Round then
+ Precision_Limit_Just_Reached := False;
+ end if;
+
+ pragma Assert (Max <= Str'Last);
+
+ -- The function precondition is that the first character is a valid
+ -- digit.
+
+ Digit := As_Digit (Str (Index));
+
+ loop
+ -- Check if base is correct. If the base is not specified, the digit
+ -- E or e cannot be considered as a base violation as it can be used
+ -- for exponentiation.
+
+ if Digit >= Base then
+ if Base_Specified then
+ Base_Violation := True;
+ elsif Digit = E_Digit then
+ return;
+ else
+ Base_Violation := True;
+ end if;
+ end if;
+
+ -- If precision limit has been reached, just ignore any remaining
+ -- digits for the computation of Value and Scale, but store the
+ -- first in Extra and use the second to round Extra. The scanning
+ -- should continue only to assess the validity of the string.
+
+ if Precision_Limit_Reached then
+ Scale := Scale + 1;
+
+ if Round and then Precision_Limit_Just_Reached then
+ Round_Extra (Digit, Value, Scale, Extra, Base);
+ Precision_Limit_Just_Reached := False;
+ end if;
+
+ else
+ Temp := Value * Uns (Base) + Uns (Digit);
+
+ -- 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
+ or else (Value <= UmaxB
+ and then ((Precision_Limit < Uns'Last
+ and then Temp <= Precision_Limit)
+ or else (Precision_Limit = Uns'Last
+ and then Temp >= Uns (Base))))
+ then
+ Value := Temp;
+
+ else
+ Extra := Digit;
+ Precision_Limit_Reached := True;
+ if Round then
+ Precision_Limit_Just_Reached := True;
+ end if;
+ Scale := Scale + 1;
+ end if;
+ end if;
+
+ -- Look for the next character
+
+ Index := Index + 1;
+ if Index > Max then
+ return;
+ end if;
+
+ Digit := As_Digit (Str (Index));
+
+ if Digit not in Valid_Digit then
+
+ -- Next character is not a digit. In that case stop scanning
+ -- unless the next chracter is an underscore followed by a digit.
+
+ if Digit = Underscore and Index + 1 <= Max then
+ Digit := As_Digit (Str (Index + 1));
+ if Digit in Valid_Digit then
+ Index := Index + 1;
+ else
+ return;
+ end if;
+ else
+ return;
+ end if;
+ end if;
+ end loop;
+ end Scan_Integral_Digits;
+
+ -------------------
+ -- Scan_Raw_Real --
+ -------------------
+
+ function Scan_Raw_Real
+ (Str : String;
+ Ptr : not null access Integer;
+ Max : Integer;
+ Base : out Unsigned;
+ Scale : out Integer;
+ Extra : out Unsigned;
+ Minus : out Boolean) return Uns
+ is
+ pragma Assert (Max <= Str'Last);
+
+ After_Point : Boolean;
+ -- True if a decimal should be parsed
+
+ Base_Char : Character := ASCII.NUL;
+ -- Character used to set the base. If Nul this means that default
+ -- base is used.
+
+ Base_Violation : Boolean := False;
+ -- If True some digits where not in the base. The real is still scanned
+ -- till the end even if an error will be raised.
+
+ Index : Integer;
+ -- Local copy of string pointer
+
+ Start : Positive;
+ pragma Unreferenced (Start);
+
+ Value : Uns;
+ -- Mantissa as an Integer
+
+ begin
+ -- The default base is 10
+
+ Base := 10;
+
+ -- We do not tolerate strings with Str'Last = Positive'Last
+
+ if Str'Last = Positive'Last then
+ raise Program_Error with
+ "string upper bound is Positive'Last, not supported";
+ end if;
+
+ -- Scan the optional sign
+
+ Scan_Sign (Str, Ptr, Max, Minus, Start);
+ Index := Ptr.all;
+
+ pragma Assert (Index >= Str'First);
+
+ pragma Annotate (CodePeer, Modified, Str (Index));
+
+ -- First character can be either a decimal digit or a dot and for some
+ -- reason CodePeer incorrectly thinks it is always a digit.
+
+ if Str (Index) in '0' .. '9' then
+ After_Point := False;
+
+ -- If this is a digit it can indicates either the float decimal
+ -- part or the base to use.
+
+ Scan_Integral_Digits
+ (Str, Index, Max, Value, Scale, Char_As_Digit (Extra),
+ Base_Violation, Base, Base_Specified => False);
+
+ -- A dot is allowed only if followed by a digit (RM 3.5(47))
+
+ elsif Str (Index) = '.'
+ and then Index < Max
+ and then Str (Index + 1) in '0' .. '9'
+ then
+ After_Point := True;
+ Index := Index + 1;
+ Value := 0;
+ Scale := 0;
+ Extra := 0;
+
+ else
+ Bad_Value (Str);
+ end if;
+
+ -- Check if the first number encountered is a base
+
+ pragma Assert (Index >= Str'First);
+
+ if Index < Max
+ and then (Str (Index) = '#' or else Str (Index) = ':')
+ then
+ Base_Char := Str (Index);
+
+ if Value in 2 .. 16 then
+ Base := Unsigned (Value);
+ else
+ Base_Violation := True;
+ Base := 16;
+ end if;
+
+ Index := Index + 1;
+
+ if Str (Index) = '.'
+ and then Index < Max
+ and then As_Digit (Str (Index + 1)) in Valid_Digit
+ then
+ After_Point := True;
+ Index := Index + 1;
+ Value := 0;
+ end if;
+ end if;
+
+ -- Scan the integral part if still necessary
+
+ if Base_Char /= ASCII.NUL and then not After_Point then
+ if Index > Max or else As_Digit (Str (Index)) not in Valid_Digit then
+ Bad_Value (Str);
+ end if;
+
+ Scan_Integral_Digits
+ (Str, Index, Max, Value, Scale, Char_As_Digit (Extra),
+ Base_Violation, Base, Base_Specified => Base_Char /= ASCII.NUL);
+ end if;
+
+ -- Do we have a dot?
+
+ pragma Assert (Index >= Str'First);
+
+ if not After_Point and then Index <= Max and then Str (Index) = '.' then
+
+ -- At this stage if After_Point was not set, this means that an
+ -- integral part has been found. Thus the dot is valid even if not
+ -- followed by a digit.
+
+ if Index < Max and then As_Digit (Str (Index + 1)) in Valid_Digit then
+ After_Point := True;
+ end if;
+
+ Index := Index + 1;
+ end if;
+
+ -- Scan the decimal part
+
+ if After_Point then
+ pragma Assert (Index <= Max);
+
+ Scan_Decimal_Digits
+ (Str, Index, Max, Value, Scale, Char_As_Digit (Extra),
+ Base_Violation, Base, Base_Specified => Base_Char /= ASCII.NUL);
+ end if;
+
+ -- If an explicit base was specified ensure that the delimiter is found
+
+ if Base_Char /= ASCII.NUL then
+ pragma Assert (Index > Max or else Index in Str'Range);
+
+ if Index > Max or else Str (Index) /= Base_Char then
+ Bad_Value (Str);
+ else
+ Index := Index + 1;
+ end if;
+ end if;
+
+ -- Update pointer and scan exponent
+
+ Ptr.all := Index;
+ Scale := Scale + Scan_Exponent (Str, Ptr, Max, Real => True);
+
+ -- Here is where we check for a bad based number
+
+ if Base_Violation then
+ Bad_Value (Str);
+ else
+ return Value;
+ end if;
+
+ end Scan_Raw_Real;
+
+ --------------------
+ -- Value_Raw_Real --
+ --------------------
+
+ function Value_Raw_Real
+ (Str : String;
+ Base : out Unsigned;
+ Scale : out Integer;
+ Extra : out Unsigned;
+ Minus : out Boolean) return Uns
+ is
+ begin
+ -- We have to special case Str'Last = Positive'Last because the normal
+ -- circuit ends up setting P to Str'Last + 1 which is out of bounds. We
+ -- deal with this by converting to a subtype which fixes the bounds.
+
+ if Str'Last = Positive'Last then
+ declare
+ subtype NT is String (1 .. Str'Length);
+ begin
+ return Value_Raw_Real (NT (Str), Base, Scale, Extra, Minus);
+ end;
+
+ -- Normal case where Str'Last < Positive'Last
+
+ else
+ declare
+ V : Uns;
+ P : aliased Integer := Str'First;
+ begin
+ V := Scan_Raw_Real
+ (Str, P'Access, Str'Last, Base, Scale, Extra, Minus);
+ Scan_Trailing_Blanks (Str, P);
+ return V;
+ end;
+ end if;
+ end Value_Raw_Real;
+
+end System.Value_R;
diff --git a/gcc/ada/libgnat/s-valuer.ads b/gcc/ada/libgnat/s-valuer.ads
new file mode 100644
index 0000000..a933859
--- /dev/null
+++ b/gcc/ada/libgnat/s-valuer.ads
@@ -0,0 +1,101 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . V A L U E _ R --
+-- --
+-- 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. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains routines for scanning real values for use in
+-- Text_IO.Decimal_IO, Fixed_IO, Float_IO and the Value attribute.
+
+with System.Unsigned_Types; use System.Unsigned_Types;
+
+generic
+
+ type Uns is mod <>;
+
+ Precision_Limit : Uns;
+
+ Round : Boolean;
+
+package System.Value_R is
+ pragma Preelaborate;
+
+ function Scan_Raw_Real
+ (Str : String;
+ Ptr : not null access Integer;
+ Max : Integer;
+ Base : out Unsigned;
+ Scale : out Integer;
+ Extra : out Unsigned;
+ Minus : out Boolean) return Uns;
+ -- This function scans the string starting at Str (Ptr.all) for a valid
+ -- real literal according to the syntax described in (RM 3.5(43)). The
+ -- substring scanned extends no further than Str (Max). There are three
+ -- cases for the return:
+ --
+ -- If a valid real is found after scanning past any initial spaces, then
+ -- Ptr.all is updated past the last character of the real (but trailing
+ -- spaces are not scanned out) and the Base, Scale, Extra and Minus out
+ -- parameters are set; if Val is the result of the call, then the real
+ -- represented by the literal is equal to
+ --
+ -- (Val * Base + Extra) * (Base ** (Scale - 1))
+ --
+ -- with the negative sign if Minus is true.
+ --
+ -- If no valid real is found, then Ptr.all points either to an initial
+ -- non-blank character, or to Max + 1 if the field is all spaces and the
+ -- exception Constraint_Error is raised.
+ --
+ -- If a syntactically valid real is scanned, but the value is out of
+ -- range, or, in the based case, the base value is out of range or there
+ -- is an out of range digit, then Ptr.all points past the real literal,
+ -- and Constraint_Error is raised.
+ --
+ -- Note: these rules correspond to the requirements for leaving the
+ -- pointer positioned in Text_Io.Get
+ --
+ -- Note: if Str is null, i.e. if Max is less than Ptr, then this is a
+ -- special case of an all-blank string, and Ptr is unchanged, and hence
+ -- is greater than Max as required in this case.
+ --
+ -- Note: this routine should not be called with Str'Last = Positive'Last.
+ -- If this occurs Program_Error is raised with a message noting that this
+ -- case is not supported. Most such cases are eliminated by the caller.
+
+ function Value_Raw_Real
+ (Str : String;
+ Base : out Unsigned;
+ Scale : out Integer;
+ Extra : out Unsigned;
+ Minus : out Boolean) return Uns;
+ -- Used in computing X'Value (Str) where X is a real type. Str is the
+ -- string argument of the attribute. Constraint_Error is raised if the
+ -- string is malformed.
+
+end System.Value_R;
diff --git a/gcc/ada/libgnat/system-aix.ads b/gcc/ada/libgnat/system-aix.ads
index 5bf603d..db4579f 100644
--- a/gcc/ada/libgnat/system-aix.ads
+++ b/gcc/ada/libgnat/system-aix.ads
@@ -57,7 +57,7 @@ package System is
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 0.01;
@@ -135,8 +135,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;
diff --git a/gcc/ada/libgnat/system-darwin-arm.ads b/gcc/ada/libgnat/system-darwin-arm.ads
index 70e02a1..b306920 100644
--- a/gcc/ada/libgnat/system-darwin-arm.ads
+++ b/gcc/ada/libgnat/system-darwin-arm.ads
@@ -57,7 +57,7 @@ package System is
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 0.01;
@@ -151,8 +151,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;
diff --git a/gcc/ada/libgnat/system-darwin-ppc.ads b/gcc/ada/libgnat/system-darwin-ppc.ads
index 4947c6c..bc0b147 100644
--- a/gcc/ada/libgnat/system-darwin-ppc.ads
+++ b/gcc/ada/libgnat/system-darwin-ppc.ads
@@ -57,7 +57,7 @@ package System is
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 0.01;
@@ -151,8 +151,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;
diff --git a/gcc/ada/libgnat/system-darwin-x86.ads b/gcc/ada/libgnat/system-darwin-x86.ads
index 828b310..c175224 100644
--- a/gcc/ada/libgnat/system-darwin-x86.ads
+++ b/gcc/ada/libgnat/system-darwin-x86.ads
@@ -57,7 +57,7 @@ package System is
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 0.01;
@@ -151,8 +151,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;
diff --git a/gcc/ada/libgnat/system-djgpp.ads b/gcc/ada/libgnat/system-djgpp.ads
index 68fdb49..52e4a88 100644
--- a/gcc/ada/libgnat/system-djgpp.ads
+++ b/gcc/ada/libgnat/system-djgpp.ads
@@ -57,7 +57,7 @@ package System is
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 0.01;
@@ -125,8 +125,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;
diff --git a/gcc/ada/libgnat/system-dragonfly-x86_64.ads b/gcc/ada/libgnat/system-dragonfly-x86_64.ads
index 6bfb5c4..0cc0dab 100644
--- a/gcc/ada/libgnat/system-dragonfly-x86_64.ads
+++ b/gcc/ada/libgnat/system-dragonfly-x86_64.ads
@@ -57,7 +57,7 @@ package System is
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 0.000_001;
@@ -125,8 +125,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;
diff --git a/gcc/ada/libgnat/system-freebsd.ads b/gcc/ada/libgnat/system-freebsd.ads
index d4fe60e..ce1835c 100644
--- a/gcc/ada/libgnat/system-freebsd.ads
+++ b/gcc/ada/libgnat/system-freebsd.ads
@@ -57,7 +57,7 @@ package System is
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 0.000_001;
@@ -126,8 +126,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;
diff --git a/gcc/ada/libgnat/system-hpux-ia64.ads b/gcc/ada/libgnat/system-hpux-ia64.ads
index f11edc6..202bcac 100644
--- a/gcc/ada/libgnat/system-hpux-ia64.ads
+++ b/gcc/ada/libgnat/system-hpux-ia64.ads
@@ -57,7 +57,7 @@ package System is
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 0.01;
@@ -125,8 +125,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;
diff --git a/gcc/ada/libgnat/system-hpux.ads b/gcc/ada/libgnat/system-hpux.ads
index ddf6a82..34f2752 100644
--- a/gcc/ada/libgnat/system-hpux.ads
+++ b/gcc/ada/libgnat/system-hpux.ads
@@ -57,7 +57,7 @@ package System is
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 0.01;
@@ -125,8 +125,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;
diff --git a/gcc/ada/libgnat/system-linux-alpha.ads b/gcc/ada/libgnat/system-linux-alpha.ads
index eebe93a..2c638e5 100644
--- a/gcc/ada/libgnat/system-linux-alpha.ads
+++ b/gcc/ada/libgnat/system-linux-alpha.ads
@@ -57,7 +57,7 @@ package System is
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 1.0 / 1024.0;
@@ -125,8 +125,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;
diff --git a/gcc/ada/libgnat/system-linux-arm.ads b/gcc/ada/libgnat/system-linux-arm.ads
index 4d09d9e..9020c79 100644
--- a/gcc/ada/libgnat/system-linux-arm.ads
+++ b/gcc/ada/libgnat/system-linux-arm.ads
@@ -57,7 +57,7 @@ package System is
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 0.000_001;
@@ -134,8 +134,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;
diff --git a/gcc/ada/libgnat/system-linux-hppa.ads b/gcc/ada/libgnat/system-linux-hppa.ads
index 6bc9541..dccf444 100644
--- a/gcc/ada/libgnat/system-linux-hppa.ads
+++ b/gcc/ada/libgnat/system-linux-hppa.ads
@@ -57,7 +57,7 @@ package System is
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 0.000_001;
@@ -125,8 +125,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;
diff --git a/gcc/ada/libgnat/system-linux-ia64.ads b/gcc/ada/libgnat/system-linux-ia64.ads
index ae9b49a..14b6bb3 100644
--- a/gcc/ada/libgnat/system-linux-ia64.ads
+++ b/gcc/ada/libgnat/system-linux-ia64.ads
@@ -57,7 +57,7 @@ package System is
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 0.01;
@@ -133,8 +133,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;
diff --git a/gcc/ada/libgnat/system-linux-m68k.ads b/gcc/ada/libgnat/system-linux-m68k.ads
index 3fbd781..db7f9e7 100644
--- a/gcc/ada/libgnat/system-linux-m68k.ads
+++ b/gcc/ada/libgnat/system-linux-m68k.ads
@@ -57,7 +57,7 @@ package System is
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 0.000_001;
@@ -135,8 +135,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;
diff --git a/gcc/ada/libgnat/system-linux-mips.ads b/gcc/ada/libgnat/system-linux-mips.ads
index d760db8..d44bf1b 100644
--- a/gcc/ada/libgnat/system-linux-mips.ads
+++ b/gcc/ada/libgnat/system-linux-mips.ads
@@ -57,7 +57,7 @@ package System is
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 0.000_001;
@@ -126,8 +126,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;
diff --git a/gcc/ada/libgnat/system-linux-ppc.ads b/gcc/ada/libgnat/system-linux-ppc.ads
index 0f39370..917b949 100644
--- a/gcc/ada/libgnat/system-linux-ppc.ads
+++ b/gcc/ada/libgnat/system-linux-ppc.ads
@@ -57,7 +57,7 @@ package System is
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 0.000_001;
@@ -134,8 +134,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;
diff --git a/gcc/ada/libgnat/system-linux-riscv.ads b/gcc/ada/libgnat/system-linux-riscv.ads
index 91eddf2..9e93e5e 100644
--- a/gcc/ada/libgnat/system-linux-riscv.ads
+++ b/gcc/ada/libgnat/system-linux-riscv.ads
@@ -57,7 +57,7 @@ package System is
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 0.000_001;
@@ -125,8 +125,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;
diff --git a/gcc/ada/libgnat/system-linux-s390.ads b/gcc/ada/libgnat/system-linux-s390.ads
index 374b938..0ceeb96 100644
--- a/gcc/ada/libgnat/system-linux-s390.ads
+++ b/gcc/ada/libgnat/system-linux-s390.ads
@@ -57,7 +57,7 @@ package System is
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 0.000_001;
@@ -125,8 +125,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;
diff --git a/gcc/ada/libgnat/system-linux-sh4.ads b/gcc/ada/libgnat/system-linux-sh4.ads
index cd811de..fd0e0c7 100644
--- a/gcc/ada/libgnat/system-linux-sh4.ads
+++ b/gcc/ada/libgnat/system-linux-sh4.ads
@@ -57,7 +57,7 @@ package System is
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 0.000_001;
@@ -133,8 +133,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;
diff --git a/gcc/ada/libgnat/system-linux-sparc.ads b/gcc/ada/libgnat/system-linux-sparc.ads
index e74214b..29a650a 100644
--- a/gcc/ada/libgnat/system-linux-sparc.ads
+++ b/gcc/ada/libgnat/system-linux-sparc.ads
@@ -57,7 +57,7 @@ package System is
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 0.000_001;
@@ -125,8 +125,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;
diff --git a/gcc/ada/libgnat/system-linux-x86.ads b/gcc/ada/libgnat/system-linux-x86.ads
index eb8b5dd..73c99c3 100644
--- a/gcc/ada/libgnat/system-linux-x86.ads
+++ b/gcc/ada/libgnat/system-linux-x86.ads
@@ -57,7 +57,7 @@ package System is
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 0.000_001;
@@ -133,8 +133,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;
diff --git a/gcc/ada/libgnat/system-lynxos178-ppc.ads b/gcc/ada/libgnat/system-lynxos178-ppc.ads
index cf516e1..e2d9765 100644
--- a/gcc/ada/libgnat/system-lynxos178-ppc.ads
+++ b/gcc/ada/libgnat/system-lynxos178-ppc.ads
@@ -57,7 +57,7 @@ package System is
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 0.01;
@@ -102,7 +102,7 @@ package System is
-- (Priority'First + Priority'Last) / 2
-- However, the default priority given by the OS is not the same thing as
- -- the Ada value Default_Prioirity (previous examples include VxWorks).
+ -- the Ada value Default_Priority (previous examples include VxWorks).
-- Therefore, we follow a model based on the full range of LynxOS-178
-- priorities.
@@ -140,8 +140,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;
diff --git a/gcc/ada/libgnat/system-lynxos178-x86.ads b/gcc/ada/libgnat/system-lynxos178-x86.ads
index c151472..3131895 100644
--- a/gcc/ada/libgnat/system-lynxos178-x86.ads
+++ b/gcc/ada/libgnat/system-lynxos178-x86.ads
@@ -57,7 +57,7 @@ package System is
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 0.01;
@@ -102,7 +102,7 @@ package System is
-- (Priority'First + Priority'Last) / 2
-- However, the default priority given by the OS is not the same thing as
- -- the Ada value Default_Prioirity (previous examples include VxWorks).
+ -- the Ada value Default_Priority (previous examples include VxWorks).
-- Therefore, we follow a model based on the full range of LynxOS-178
-- priorities.
@@ -140,8 +140,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;
diff --git a/gcc/ada/libgnat/system-mingw.ads b/gcc/ada/libgnat/system-mingw.ads
index cf960da..3729e44 100644
--- a/gcc/ada/libgnat/system-mingw.ads
+++ b/gcc/ada/libgnat/system-mingw.ads
@@ -57,7 +57,7 @@ package System is
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 0.01;
@@ -125,8 +125,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;
diff --git a/gcc/ada/libgnat/system-qnx-aarch64.ads b/gcc/ada/libgnat/system-qnx-aarch64.ads
index 37b8fd1..a6336a9 100644
--- a/gcc/ada/libgnat/system-qnx-aarch64.ads
+++ b/gcc/ada/libgnat/system-qnx-aarch64.ads
@@ -57,7 +57,7 @@ package System is
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 0.000_001;
@@ -134,8 +134,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;
diff --git a/gcc/ada/libgnat/system-rtems.ads b/gcc/ada/libgnat/system-rtems.ads
index 099c234..dca09dd 100644
--- a/gcc/ada/libgnat/system-rtems.ads
+++ b/gcc/ada/libgnat/system-rtems.ads
@@ -61,7 +61,7 @@ package System is
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 0.01;
@@ -144,8 +144,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;
diff --git a/gcc/ada/libgnat/system-solaris-sparc.ads b/gcc/ada/libgnat/system-solaris-sparc.ads
index 0e1ce01..1efc78f 100644
--- a/gcc/ada/libgnat/system-solaris-sparc.ads
+++ b/gcc/ada/libgnat/system-solaris-sparc.ads
@@ -57,7 +57,7 @@ package System is
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 0.01;
@@ -125,8 +125,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;
diff --git a/gcc/ada/libgnat/system-solaris-x86.ads b/gcc/ada/libgnat/system-solaris-x86.ads
index 010ce5b..8dc46ed 100644
--- a/gcc/ada/libgnat/system-solaris-x86.ads
+++ b/gcc/ada/libgnat/system-solaris-x86.ads
@@ -57,7 +57,7 @@ package System is
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 0.01;
@@ -125,8 +125,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;
diff --git a/gcc/ada/libgnat/system-vxworks-arm-rtp-smp.ads b/gcc/ada/libgnat/system-vxworks-arm-rtp-smp.ads
index 91806e5..592e25b 100644
--- a/gcc/ada/libgnat/system-vxworks-arm-rtp-smp.ads
+++ b/gcc/ada/libgnat/system-vxworks-arm-rtp-smp.ads
@@ -59,7 +59,7 @@ package System is
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 1.0 / 60.0;
@@ -144,8 +144,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;
diff --git a/gcc/ada/libgnat/system-vxworks-arm-rtp.ads b/gcc/ada/libgnat/system-vxworks-arm-rtp.ads
index de13974..ac025ce 100644
--- a/gcc/ada/libgnat/system-vxworks-arm-rtp.ads
+++ b/gcc/ada/libgnat/system-vxworks-arm-rtp.ads
@@ -59,7 +59,7 @@ package System is
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 1.0 / 60.0;
@@ -143,8 +143,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;
diff --git a/gcc/ada/libgnat/system-vxworks-arm.ads b/gcc/ada/libgnat/system-vxworks-arm.ads
index fac4e72..483881f 100644
--- a/gcc/ada/libgnat/system-vxworks-arm.ads
+++ b/gcc/ada/libgnat/system-vxworks-arm.ads
@@ -57,7 +57,7 @@ package System is
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 1.0 / 60.0;
@@ -138,8 +138,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;
diff --git a/gcc/ada/libgnat/system-vxworks-e500-kernel.ads b/gcc/ada/libgnat/system-vxworks-e500-kernel.ads
index cf89c2d..ac674bd 100644
--- a/gcc/ada/libgnat/system-vxworks-e500-kernel.ads
+++ b/gcc/ada/libgnat/system-vxworks-e500-kernel.ads
@@ -57,7 +57,7 @@ package System is
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 1.0 / 60.0;
@@ -138,8 +138,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;
diff --git a/gcc/ada/libgnat/system-vxworks-e500-rtp-smp.ads b/gcc/ada/libgnat/system-vxworks-e500-rtp-smp.ads
index 862f3f6..45a99f3 100644
--- a/gcc/ada/libgnat/system-vxworks-e500-rtp-smp.ads
+++ b/gcc/ada/libgnat/system-vxworks-e500-rtp-smp.ads
@@ -59,7 +59,7 @@ package System is
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 1.0 / 60.0;
@@ -144,8 +144,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;
diff --git a/gcc/ada/libgnat/system-vxworks-e500-rtp.ads b/gcc/ada/libgnat/system-vxworks-e500-rtp.ads
index a3baecb..27f7707 100644
--- a/gcc/ada/libgnat/system-vxworks-e500-rtp.ads
+++ b/gcc/ada/libgnat/system-vxworks-e500-rtp.ads
@@ -59,7 +59,7 @@ package System is
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 1.0 / 60.0;
@@ -143,8 +143,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;
diff --git a/gcc/ada/libgnat/system-vxworks-e500-vthread.ads b/gcc/ada/libgnat/system-vxworks-e500-vthread.ads
index fc92958..f60fbcd 100644
--- a/gcc/ada/libgnat/system-vxworks-e500-vthread.ads
+++ b/gcc/ada/libgnat/system-vxworks-e500-vthread.ads
@@ -59,7 +59,7 @@ package System is
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 1.0 / 60.0;
@@ -140,8 +140,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;
diff --git a/gcc/ada/libgnat/system-vxworks-ppc-kernel.ads b/gcc/ada/libgnat/system-vxworks-ppc-kernel.ads
index 383c820..ec3de26 100644
--- a/gcc/ada/libgnat/system-vxworks-ppc-kernel.ads
+++ b/gcc/ada/libgnat/system-vxworks-ppc-kernel.ads
@@ -57,7 +57,7 @@ package System is
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 1.0 / 60.0;
@@ -138,8 +138,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;
diff --git a/gcc/ada/libgnat/system-vxworks-ppc-ravenscar.ads b/gcc/ada/libgnat/system-vxworks-ppc-ravenscar.ads
index 53a1f9e..e38ff3b 100644
--- a/gcc/ada/libgnat/system-vxworks-ppc-ravenscar.ads
+++ b/gcc/ada/libgnat/system-vxworks-ppc-ravenscar.ads
@@ -82,7 +82,7 @@ package System is
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 1.0 / 60.0;
@@ -163,8 +163,6 @@ private
Denorm : constant Boolean := True;
Duration_32_Bits : constant Boolean := True;
Exit_Status_Supported : constant Boolean := True;
- Fractional_Fixed_Ops : constant Boolean := False;
- Frontend_Layout : constant Boolean := False;
Machine_Overflows : constant Boolean := True;
Machine_Rounds : constant Boolean := True;
Preallocated_Stacks : constant Boolean := False;
diff --git a/gcc/ada/libgnat/system-vxworks-ppc-rtp-smp.ads b/gcc/ada/libgnat/system-vxworks-ppc-rtp-smp.ads
index aa99413..b4277e2 100644
--- a/gcc/ada/libgnat/system-vxworks-ppc-rtp-smp.ads
+++ b/gcc/ada/libgnat/system-vxworks-ppc-rtp-smp.ads
@@ -59,7 +59,7 @@ package System is
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 1.0 / 60.0;
@@ -144,8 +144,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;
diff --git a/gcc/ada/libgnat/system-vxworks-ppc-rtp.ads b/gcc/ada/libgnat/system-vxworks-ppc-rtp.ads
index acb20c4..eeeca9b 100644
--- a/gcc/ada/libgnat/system-vxworks-ppc-rtp.ads
+++ b/gcc/ada/libgnat/system-vxworks-ppc-rtp.ads
@@ -59,7 +59,7 @@ package System is
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 1.0 / 60.0;
@@ -143,8 +143,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;
diff --git a/gcc/ada/libgnat/system-vxworks-ppc-vthread.ads b/gcc/ada/libgnat/system-vxworks-ppc-vthread.ads
index aca420e..05d27d6 100644
--- a/gcc/ada/libgnat/system-vxworks-ppc-vthread.ads
+++ b/gcc/ada/libgnat/system-vxworks-ppc-vthread.ads
@@ -59,7 +59,7 @@ package System is
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 1.0 / 60.0;
@@ -140,8 +140,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 := True;
Machine_Rounds : constant Boolean := True;
Preallocated_Stacks : constant Boolean := False;
diff --git a/gcc/ada/libgnat/system-vxworks-ppc.ads b/gcc/ada/libgnat/system-vxworks-ppc.ads
index 99644ee..9862f42 100644
--- a/gcc/ada/libgnat/system-vxworks-ppc.ads
+++ b/gcc/ada/libgnat/system-vxworks-ppc.ads
@@ -57,7 +57,7 @@ package System is
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 1.0 / 60.0;
@@ -141,8 +141,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;
diff --git a/gcc/ada/libgnat/system-vxworks-x86-kernel.ads b/gcc/ada/libgnat/system-vxworks-x86-kernel.ads
index 3781020..b6eebb5 100644
--- a/gcc/ada/libgnat/system-vxworks-x86-kernel.ads
+++ b/gcc/ada/libgnat/system-vxworks-x86-kernel.ads
@@ -57,7 +57,7 @@ package System is
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 1.0 / 60.0;
@@ -141,8 +141,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;
diff --git a/gcc/ada/libgnat/system-vxworks-x86-rtp-smp.ads b/gcc/ada/libgnat/system-vxworks-x86-rtp-smp.ads
index 374041c..e6d31de 100644
--- a/gcc/ada/libgnat/system-vxworks-x86-rtp-smp.ads
+++ b/gcc/ada/libgnat/system-vxworks-x86-rtp-smp.ads
@@ -57,7 +57,7 @@ package System is
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 1.0 / 60.0;
@@ -142,8 +142,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;
diff --git a/gcc/ada/libgnat/system-vxworks-x86-rtp.ads b/gcc/ada/libgnat/system-vxworks-x86-rtp.ads
index cff7291..960a7ed 100644
--- a/gcc/ada/libgnat/system-vxworks-x86-rtp.ads
+++ b/gcc/ada/libgnat/system-vxworks-x86-rtp.ads
@@ -57,7 +57,7 @@ package System is
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 1.0 / 60.0;
@@ -141,8 +141,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;
diff --git a/gcc/ada/libgnat/system-vxworks-x86-vthread.ads b/gcc/ada/libgnat/system-vxworks-x86-vthread.ads
index 1867196..f3f4037 100644
--- a/gcc/ada/libgnat/system-vxworks-x86-vthread.ads
+++ b/gcc/ada/libgnat/system-vxworks-x86-vthread.ads
@@ -59,7 +59,7 @@ package System is
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 1.0 / 60.0;
@@ -140,8 +140,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 := True;
Machine_Rounds : constant Boolean := True;
Preallocated_Stacks : constant Boolean := False;
diff --git a/gcc/ada/libgnat/system-vxworks-x86.ads b/gcc/ada/libgnat/system-vxworks-x86.ads
index c82a61f..55bc3f6 100644
--- a/gcc/ada/libgnat/system-vxworks-x86.ads
+++ b/gcc/ada/libgnat/system-vxworks-x86.ads
@@ -57,7 +57,7 @@ package System is
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 1.0 / 60.0;
@@ -141,8 +141,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;
diff --git a/gcc/ada/libgnat/system-vxworks7-aarch64-rtp-smp.ads b/gcc/ada/libgnat/system-vxworks7-aarch64-rtp-smp.ads
index 37bf607..0624ffa 100644
--- a/gcc/ada/libgnat/system-vxworks7-aarch64-rtp-smp.ads
+++ b/gcc/ada/libgnat/system-vxworks7-aarch64-rtp-smp.ads
@@ -59,7 +59,7 @@ package System is
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 1.0 / 60.0;
@@ -143,8 +143,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;
diff --git a/gcc/ada/libgnat/system-vxworks7-aarch64.ads b/gcc/ada/libgnat/system-vxworks7-aarch64.ads
index c386500..1491332 100644
--- a/gcc/ada/libgnat/system-vxworks7-aarch64.ads
+++ b/gcc/ada/libgnat/system-vxworks7-aarch64.ads
@@ -59,7 +59,7 @@ package System is
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 1.0 / 60.0;
@@ -140,8 +140,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;
diff --git a/gcc/ada/libgnat/system-vxworks7-arm-rtp-smp.ads b/gcc/ada/libgnat/system-vxworks7-arm-rtp-smp.ads
index 7e2db7a..d7da53d 100644
--- a/gcc/ada/libgnat/system-vxworks7-arm-rtp-smp.ads
+++ b/gcc/ada/libgnat/system-vxworks7-arm-rtp-smp.ads
@@ -59,7 +59,7 @@ package System is
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 1.0 / 60.0;
@@ -140,8 +140,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;
diff --git a/gcc/ada/libgnat/system-vxworks7-arm.ads b/gcc/ada/libgnat/system-vxworks7-arm.ads
index fac4e72..483881f 100644
--- a/gcc/ada/libgnat/system-vxworks7-arm.ads
+++ b/gcc/ada/libgnat/system-vxworks7-arm.ads
@@ -57,7 +57,7 @@ package System is
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 1.0 / 60.0;
@@ -138,8 +138,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;
diff --git a/gcc/ada/libgnat/system-vxworks7-e500-kernel.ads b/gcc/ada/libgnat/system-vxworks7-e500-kernel.ads
index e03264e..e697629 100644
--- a/gcc/ada/libgnat/system-vxworks7-e500-kernel.ads
+++ b/gcc/ada/libgnat/system-vxworks7-e500-kernel.ads
@@ -57,7 +57,7 @@ package System is
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 1.0 / 60.0;
@@ -138,8 +138,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;
diff --git a/gcc/ada/libgnat/system-vxworks7-e500-rtp-smp.ads b/gcc/ada/libgnat/system-vxworks7-e500-rtp-smp.ads
index a9b3317..6388628 100644
--- a/gcc/ada/libgnat/system-vxworks7-e500-rtp-smp.ads
+++ b/gcc/ada/libgnat/system-vxworks7-e500-rtp-smp.ads
@@ -59,7 +59,7 @@ package System is
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 1.0 / 60.0;
@@ -143,8 +143,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;
diff --git a/gcc/ada/libgnat/system-vxworks7-e500-rtp.ads b/gcc/ada/libgnat/system-vxworks7-e500-rtp.ads
index 3e963d0..69a0a66 100644
--- a/gcc/ada/libgnat/system-vxworks7-e500-rtp.ads
+++ b/gcc/ada/libgnat/system-vxworks7-e500-rtp.ads
@@ -59,7 +59,7 @@ package System is
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 1.0 / 60.0;
@@ -143,8 +143,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;
diff --git a/gcc/ada/libgnat/system-vxworks7-ppc-kernel.ads b/gcc/ada/libgnat/system-vxworks7-ppc-kernel.ads
index 93b3271..82c5d3a 100644
--- a/gcc/ada/libgnat/system-vxworks7-ppc-kernel.ads
+++ b/gcc/ada/libgnat/system-vxworks7-ppc-kernel.ads
@@ -57,7 +57,7 @@ package System is
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 1.0 / 60.0;
@@ -138,8 +138,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;
diff --git a/gcc/ada/libgnat/system-vxworks7-ppc-rtp-smp.ads b/gcc/ada/libgnat/system-vxworks7-ppc-rtp-smp.ads
index e5d984b..d34d632 100644
--- a/gcc/ada/libgnat/system-vxworks7-ppc-rtp-smp.ads
+++ b/gcc/ada/libgnat/system-vxworks7-ppc-rtp-smp.ads
@@ -59,7 +59,7 @@ package System is
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 1.0 / 60.0;
@@ -143,8 +143,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;
diff --git a/gcc/ada/libgnat/system-vxworks7-ppc-rtp.ads b/gcc/ada/libgnat/system-vxworks7-ppc-rtp.ads
index e96d303..404da85 100644
--- a/gcc/ada/libgnat/system-vxworks7-ppc-rtp.ads
+++ b/gcc/ada/libgnat/system-vxworks7-ppc-rtp.ads
@@ -59,7 +59,7 @@ package System is
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 1.0 / 60.0;
@@ -143,8 +143,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;
diff --git a/gcc/ada/libgnat/system-vxworks7-ppc64-kernel.ads b/gcc/ada/libgnat/system-vxworks7-ppc64-kernel.ads
index 90499f6..05a51d9 100644
--- a/gcc/ada/libgnat/system-vxworks7-ppc64-kernel.ads
+++ b/gcc/ada/libgnat/system-vxworks7-ppc64-kernel.ads
@@ -59,7 +59,7 @@ package System is
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 1.0 / 60.0;
@@ -140,8 +140,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;
diff --git a/gcc/ada/libgnat/system-vxworks7-ppc64-rtp-smp.ads b/gcc/ada/libgnat/system-vxworks7-ppc64-rtp-smp.ads
index 49b22b6..e55de8c 100644
--- a/gcc/ada/libgnat/system-vxworks7-ppc64-rtp-smp.ads
+++ b/gcc/ada/libgnat/system-vxworks7-ppc64-rtp-smp.ads
@@ -59,7 +59,7 @@ package System is
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 1.0 / 60.0;
@@ -143,8 +143,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;
diff --git a/gcc/ada/libgnat/system-vxworks7-x86-kernel.ads b/gcc/ada/libgnat/system-vxworks7-x86-kernel.ads
index d7b35dd..b3659a3 100644
--- a/gcc/ada/libgnat/system-vxworks7-x86-kernel.ads
+++ b/gcc/ada/libgnat/system-vxworks7-x86-kernel.ads
@@ -57,7 +57,7 @@ package System is
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 1.0 / 60.0;
@@ -138,8 +138,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;
diff --git a/gcc/ada/libgnat/system-vxworks7-x86-rtp-smp.ads b/gcc/ada/libgnat/system-vxworks7-x86-rtp-smp.ads
index 293ede8..8c2d527 100644
--- a/gcc/ada/libgnat/system-vxworks7-x86-rtp-smp.ads
+++ b/gcc/ada/libgnat/system-vxworks7-x86-rtp-smp.ads
@@ -57,7 +57,7 @@ package System is
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 1.0 / 60.0;
@@ -141,8 +141,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;
diff --git a/gcc/ada/libgnat/system-vxworks7-x86-rtp.ads b/gcc/ada/libgnat/system-vxworks7-x86-rtp.ads
index caf458f..f6528ba 100644
--- a/gcc/ada/libgnat/system-vxworks7-x86-rtp.ads
+++ b/gcc/ada/libgnat/system-vxworks7-x86-rtp.ads
@@ -57,7 +57,7 @@ package System is
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 1.0 / 60.0;
@@ -141,8 +141,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;
diff --git a/gcc/ada/libgnat/system-vxworks7-x86_64-kernel.ads b/gcc/ada/libgnat/system-vxworks7-x86_64-kernel.ads
index a5f00ff..fc4655f 100644
--- a/gcc/ada/libgnat/system-vxworks7-x86_64-kernel.ads
+++ b/gcc/ada/libgnat/system-vxworks7-x86_64-kernel.ads
@@ -57,7 +57,7 @@ package System is
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 1.0 / 60.0;
@@ -138,8 +138,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;
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 05e69e5..2bc8e6a 100644
--- a/gcc/ada/libgnat/system-vxworks7-x86_64-rtp-smp.ads
+++ b/gcc/ada/libgnat/system-vxworks7-x86_64-rtp-smp.ads
@@ -57,7 +57,7 @@ package System is
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
- Max_Mantissa : constant := 63;
+ Max_Mantissa : constant := Standard'Max_Integer_Size - 1;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 1.0 / 60.0;
@@ -141,8 +141,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;
diff --git a/gcc/ada/make.adb b/gcc/ada/make.adb
index 0034d1a..ede4c5a 100644
--- a/gcc/ada/make.adb
+++ b/gcc/ada/make.adb
@@ -464,7 +464,7 @@ package body Make is
Ada_Flag_1 : constant String_Access := new String'("-x");
Ada_Flag_2 : constant String_Access := new String'("ada");
AdaSCIL_Flag : constant String_Access := new String'("adascil");
- GNAT_Flag : constant String_Access := new String'("-gnatpg");
+ GNAT_Flag : constant String_Access := new String'("-gnatg");
Do_Not_Check_Flag : constant String_Access := new String'("-x");
Object_Suffix : constant String := Get_Target_Object_Suffix.all;
@@ -1677,7 +1677,7 @@ package body Make is
L : File_Name_Type;
Source_Index : Int;
Args : Argument_List) return Process_Id;
- -- Compiles S using Args. If S is a GNAT predefined source "-gnatpg" is
+ -- Compiles S using Args. If S is a GNAT predefined source "-gnatg" is
-- added to Args. Non blocking call. L corresponds to the expected
-- library file name. Process_Id of the process spawned to execute the
-- compilation.
@@ -2027,7 +2027,7 @@ package body Make is
end loop;
end;
- -- Set -gnatpg for predefined files (for this purpose the renamings
+ -- Set -gnatg for predefined files (for this purpose the renamings
-- such as Text_IO do not count as predefined). Note that we strip
-- the directory name from the source file name because the call to
-- Fname.Is_Predefined_File_Name cannot deal with directory prefixes.
@@ -4697,19 +4697,9 @@ package body Make is
pragma Assert (Argv'Last = 2);
Minimal_Recompilation := True;
- -- -u
+ -- -u and -U (they are differentiated elsewhere)
- elsif Argv (2) = 'u' and then Argv'Last = 2 then
- Unique_Compile := True;
- Compile_Only := True;
- Do_Bind_Step := False;
- Do_Link_Step := False;
-
- -- -U
-
- elsif Argv (2) = 'U'
- and then Argv'Last = 2
- then
+ elsif Argv (2) in 'u' | 'U' and then Argv'Last = 2 then
Unique_Compile := True;
Compile_Only := True;
Do_Bind_Step := False;
diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads
index 7ec44dc..6b32a96 100644
--- a/gcc/ada/opt.ads
+++ b/gcc/ada/opt.ads
@@ -364,6 +364,11 @@ package Opt is
-- GNAT
-- Names of configuration pragmas files (given by switches -gnatec)
+ Config_Files_Store_Basename : Boolean := False;
+ -- GNAT
+ -- Set True for -gnateb. Tells GNAT that config files should be referred to
+ -- by their basename and their checksums computed in ALI files.
+
Configurable_Run_Time_Mode : Boolean := False;
-- GNAT, GNATBIND
-- Set True if the compiler is operating in configurable run-time mode.
@@ -719,6 +724,10 @@ package Opt is
-- the name is of the form .xxx, then to name.xxx where name is the source
-- file name with extension stripped.
+ Generate_Asm : Boolean := False;
+ -- GNAT
+ -- True if generating assembly instead of an object file, via the -S switch
+
Generate_C_Code : Boolean := False;
-- GNAT, GNATBIND
-- If True, the Cprint circuitry to generate C code output is activated.
@@ -1126,7 +1135,7 @@ package Opt is
-- make it easier to interface with back ends that implement C semantics.
-- There is a section in Sinfo which describes the transformations made.
- Multiple_Unit_Index : Int := 0;
+ Multiple_Unit_Index : Nat := 0;
-- GNAT
-- This is set non-zero if the current unit is being compiled in multiple
-- unit per file mode, meaning that the current unit is selected from the
@@ -1588,6 +1597,12 @@ package Opt is
-- Tolerate time stamp and other consistency errors. If this flag is set to
-- True (-t), then inconsistencies result in warnings rather than errors.
+ Transform_Function_Array : Boolean := False;
+ -- GNAT
+ -- If this switch is set True, then functions returning constrained arrays
+ -- are transformed into a procedure with an out parameter, and all calls
+ -- are updated accordingly.
+
Treat_Categorization_Errors_As_Warnings : Boolean := False;
-- Normally categorization errors are true illegalities. If this switch
-- is set, then such errors result in warning messages rather than error
diff --git a/gcc/ada/osint-c.adb b/gcc/ada/osint-c.adb
index 0010a8d..4fc0998 100644
--- a/gcc/ada/osint-c.adb
+++ b/gcc/ada/osint-c.adb
@@ -475,14 +475,14 @@ package body Osint.C is
begin
-- Make sure that the object file has the expected extension
+ -- Allow for either .o or .c (for C code generation)
if NL <= EL
or else
- (Name (NL - EL + Name'First .. Name'Last) /= Ext
+ (not Generate_Asm
+ and then Name (NL - EL + Name'First .. Name'Last) /= Ext
and then Name (NL - 2 + Name'First .. Name'Last) /= ".o"
- and then
- (not Generate_C_Code
- or else Name (NL - 2 + Name'First .. Name'Last) /= ".c"))
+ and then Name (NL - 2 + Name'First .. Name'Last) /= ".c")
then
Fail ("incorrect object file extension");
end if;
diff --git a/gcc/ada/par-ch10.adb b/gcc/ada/par-ch10.adb
index e4298e8..70984b1 100644
--- a/gcc/ada/par-ch10.adb
+++ b/gcc/ada/par-ch10.adb
@@ -861,11 +861,7 @@ package body Ch10 is
("unexpected LIMITED ignored");
end if;
- if Ada_Version < Ada_2005 then
- Error_Msg_SP ("LIMITED WITH is an Ada 2005 extension");
- Error_Msg_SP
- ("\unit must be compiled with -gnat05 switch");
- end if;
+ Error_Msg_Ada_2005_Extension ("`LIMITED WITH`");
elsif Token = Tok_Private then
Has_Limited := False;
@@ -879,13 +875,10 @@ package body Ch10 is
Restore_Scan_State (Scan_State); -- to PRIVATE
return Item_List;
-
- elsif Ada_Version < Ada_2005 then
- Error_Msg_SP ("`PRIVATE WITH` is an Ada 2005 extension");
- Error_Msg_SP
- ("\unit must be compiled with -gnat05 switch");
end if;
+ Error_Msg_Ada_2005_Extension ("`PRIVATE WITH`");
+
else
Has_Limited := False;
Has_Private := False;
diff --git a/gcc/ada/par-ch11.adb b/gcc/ada/par-ch11.adb
index 468ba03a..63f0c6e 100644
--- a/gcc/ada/par-ch11.adb
+++ b/gcc/ada/par-ch11.adb
@@ -227,10 +227,7 @@ package body Ch11 is
end if;
if Token = Tok_With then
- if Ada_Version < Ada_2005 then
- Error_Msg_SC ("string expression in raise is Ada 2005 extension");
- Error_Msg_SC ("\unit must be compiled with -gnat05 switch");
- end if;
+ Error_Msg_Ada_2005_Extension ("string expression in raise");
Scan; -- past WITH
Set_Expression (Raise_Node, P_Expression);
diff --git a/gcc/ada/par-ch12.adb b/gcc/ada/par-ch12.adb
index c53f7cb..a4799c7 100644
--- a/gcc/ada/par-ch12.adb
+++ b/gcc/ada/par-ch12.adb
@@ -349,24 +349,19 @@ package body Ch12 is
-- Ada 2005: an association can be given by: others => <>
if Token = Tok_Others then
- if Ada_Version < Ada_2005 then
- Error_Msg_SP
- ("partial parameterization of formal packages"
- & " is an Ada 2005 extension");
- Error_Msg_SP
- ("\unit must be compiled with -gnat05 switch");
- end if;
+ Error_Msg_Ada_2005_Extension
+ ("partial parameterization of formal package");
Scan; -- past OTHERS
if Token /= Tok_Arrow then
- Error_Msg_BC ("expect arrow after others");
+ Error_Msg_BC ("expect `='>` after OTHERS");
else
Scan; -- past arrow
end if;
if Token /= Tok_Box then
- Error_Msg_BC ("expect Box after arrow");
+ Error_Msg_BC ("expect `'<'>` after `='>`");
else
Scan; -- past box
end if;
@@ -428,12 +423,12 @@ package body Ch12 is
procedure P_Formal_Object_Declarations (Decls : List_Id) is
Decl_Node : Node_Id;
- Ident : Nat;
+ Ident : Pos;
Not_Null_Present : Boolean := False;
- Num_Idents : Nat;
+ Num_Idents : Pos;
Scan_State : Saved_Scan_State;
- Idents : array (Int range 1 .. 4096) of Entity_Id;
+ Idents : array (Pos range 1 .. 4096) of Entity_Id;
-- This array holds the list of defining identifiers. The upper bound
-- of 4096 is intended to be essentially infinite, and we do not even
-- bother to check for it being exceeded.
@@ -478,12 +473,8 @@ package body Ch12 is
Set_Access_Definition (Decl_Node,
P_Access_Definition (Not_Null_Present));
- if Ada_Version < Ada_2005 then
- Error_Msg_SP
- ("access definition not allowed in formal object " &
- "declaration");
- Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
- end if;
+ Error_Msg_Ada_2005_Extension
+ ("access definition in formal object declaration");
-- Formal object with a subtype mark
@@ -923,23 +914,13 @@ package body Ch12 is
Set_Limited_Present (Def_Node);
Scan; -- past LIMITED
- if Ada_Version < Ada_2005 then
- Error_Msg_SP
- ("LIMITED in derived type is an Ada 2005 extension");
- Error_Msg_SP
- ("\unit must be compiled with -gnat05 switch");
- end if;
+ Error_Msg_Ada_2005_Extension ("LIMITED in derived type");
elsif Token = Tok_Synchronized then
Set_Synchronized_Present (Def_Node);
Scan; -- past SYNCHRONIZED
- if Ada_Version < Ada_2005 then
- Error_Msg_SP
- ("SYNCHRONIZED in derived type is an Ada 2005 extension");
- Error_Msg_SP
- ("\unit must be compiled with -gnat05 switch");
- end if;
+ Error_Msg_Ada_2005_Extension ("SYNCHRONIZED in derived type");
end if;
if Token = Tok_Abstract then
@@ -955,11 +936,7 @@ package body Ch12 is
if Token = Tok_And then
Scan; -- past AND
- if Ada_Version < Ada_2005 then
- Error_Msg_SP
- ("abstract interface is an Ada 2005 extension");
- Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
- end if;
+ Error_Msg_Ada_2005_Extension ("abstract interface");
Set_Interface_List (Def_Node, New_List);
@@ -972,20 +949,21 @@ package body Ch12 is
if Token = Tok_With then
- if Ada_Version >= Ada_2020 and not Next_Token_Is (Tok_Private) then
-
+ if Next_Token_Is (Tok_Private) then
+ Scan; -- past WITH
+ Set_Private_Present (Def_Node, True);
+ T_Private;
+ else
-- Formal type has aspect specifications, parsed later.
-- Otherwise this is a formal derived type. Note that it may
-- also include later aspect specifications, as in:
- -- type DT is new T with private with atomic;
+ -- type DT is new T with private with Atomic;
- return Def_Node;
+ Error_Msg_Ada_2020_Feature
+ ("formal type with aspect specification", Token_Ptr);
- else
- Scan; -- past WITH
- Set_Private_Present (Def_Node, True);
- T_Private;
+ return Def_Node;
end if;
elsif Token = Tok_Tagged then
@@ -1190,11 +1168,7 @@ package body Ch12 is
New_Node (N_Formal_Abstract_Subprogram_Declaration, Prev_Sloc);
Scan; -- past ABSTRACT
- if Ada_Version < Ada_2005 then
- Error_Msg_SP
- ("formal abstract subprograms are an Ada 2005 extension");
- Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
- end if;
+ Error_Msg_Ada_2005_Extension ("formal abstract subprogram");
else
Def_Node :=
@@ -1214,11 +1188,7 @@ package body Ch12 is
Scan; -- past <>
elsif Token = Tok_Null then
- if Ada_Version < Ada_2005 then
- Error_Msg_SP
- ("null default subprograms are an Ada 2005 extension");
- Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
- end if;
+ Error_Msg_Ada_2005_Extension ("null default subprogram");
if Nkind (Spec_Node) = N_Procedure_Specification then
Set_Null_Present (Spec_Node);
diff --git a/gcc/ada/par-ch13.adb b/gcc/ada/par-ch13.adb
index 95223a1..8bee840 100644
--- a/gcc/ada/par-ch13.adb
+++ b/gcc/ada/par-ch13.adb
@@ -23,6 +23,8 @@
-- --
------------------------------------------------------------------------------
+with Rident; use Rident;
+with Restrict; use Restrict;
pragma Style_Checks (All_Checks);
-- Turn off subprogram body ordering check. Subprograms are in order
-- by RM section rather than alphabetical
@@ -264,20 +266,28 @@ package body Ch13 is
-- The aspect mark is not recognized
if A_Id = No_Aspect then
- Error_Msg_Warn := not Debug_Flag_2;
- Error_Msg_N ("<<& is not a valid aspect identifier", Token_Node);
- OK := False;
-
- -- Check bad spelling
-
- for J in Aspect_Id_Exclude_No_Aspect loop
- if Is_Bad_Spelling_Of (Token_Name, Aspect_Names (J)) then
- Error_Msg_Name_1 := Aspect_Names (J);
- Error_Msg_N -- CODEFIX
- ("\<<possible misspelling of%", Token_Node);
- exit;
+ declare
+ Msg_Issued : Boolean := False;
+ begin
+ Check_Restriction (Msg_Issued, No_Unrecognized_Aspects, Aspect);
+ if not Msg_Issued then
+ Error_Msg_Warn := not Debug_Flag_2;
+ Error_Msg_N
+ ("<<& is not a valid aspect identifier", Token_Node);
+ OK := False;
+
+ -- Check bad spelling
+
+ for J in Aspect_Id_Exclude_No_Aspect loop
+ if Is_Bad_Spelling_Of (Token_Name, Aspect_Names (J)) then
+ Error_Msg_Name_1 := Aspect_Names (J);
+ Error_Msg_N -- CODEFIX
+ ("\<<possible misspelling of%", Token_Node);
+ exit;
+ end if;
+ end loop;
end if;
- end loop;
+ end;
Scan; -- past incorrect identifier
diff --git a/gcc/ada/par-ch3.adb b/gcc/ada/par-ch3.adb
index 017a0a1..78a3ebd 100644
--- a/gcc/ada/par-ch3.adb
+++ b/gcc/ada/par-ch3.adb
@@ -690,12 +690,7 @@ package body Ch3 is
-- Ada 2005 (AI-419): LIMITED NEW
elsif Token = Tok_New then
- if Ada_Version < Ada_2005 then
- Error_Msg_SP
- ("LIMITED in derived type is an Ada 2005 extension");
- Error_Msg_SP
- ("\unit must be compiled with -gnat05 switch");
- end if;
+ Error_Msg_Ada_2005_Extension ("LIMITED in derived type");
Typedef_Node := P_Derived_Type_Def_Or_Private_Ext_Decl;
Set_Limited_Present (Typedef_Node);
@@ -919,7 +914,7 @@ package body Ch3 is
if Unknown_Dis then
Error_Msg
- ("Full type declaration cannot have unknown discriminants",
+ ("full type declaration cannot have unknown discriminants",
Discr_Sloc);
end if;
end if;
@@ -1056,7 +1051,7 @@ package body Ch3 is
-- otherwise things are really messed up, so resynchronize.
if Token = Tok_Record then
- Error_Msg_SC ("anonymous record definitions are not permitted");
+ Error_Msg_SC ("anonymous record definition not permitted");
Discard_Junk_Node (P_Record_Definition);
return Error;
@@ -1491,11 +1486,8 @@ package body Ch3 is
-- access_definition
elsif Token = Tok_Renames then
- if Ada_Version < Ada_2020 then
- Error_Msg_SC
- ("object renaming without subtype is an Ada 202x feature");
- Error_Msg_SC ("\compile with -gnat2020");
- end if;
+ Error_Msg_Ada_2020_Feature
+ ("object renaming without subtype", Token_Ptr);
Scan; -- past renames
@@ -1671,13 +1663,8 @@ package body Ch3 is
Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present);
if Token = Tok_Access then
- if Ada_Version < Ada_2005 then
- Error_Msg_SP
- ("generalized use of anonymous access types " &
- "is an Ada 2005 extension");
- Error_Msg_SP
- ("\unit must be compiled with -gnat05 switch");
- end if;
+ Error_Msg_Ada_2005_Extension
+ ("generalized use of anonymous access types");
Set_Object_Definition
(Decl_Node, P_Access_Definition (Not_Null_Present));
@@ -1734,13 +1721,8 @@ package body Ch3 is
-- Access definition (AI-406) or subtype indication
if Token = Tok_Access then
- if Ada_Version < Ada_2005 then
- Error_Msg_SP
- ("generalized use of anonymous access types " &
- "is an Ada 2005 extension");
- Error_Msg_SP
- ("\unit must be compiled with -gnat05 switch");
- end if;
+ Error_Msg_Ada_2005_Extension
+ ("generalized use of anonymous access types");
Set_Object_Definition
(Decl_Node, P_Access_Definition (Not_Null_Present));
@@ -1779,12 +1761,8 @@ package body Ch3 is
Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231/423)
if Token = Tok_Access then
- if Ada_Version < Ada_2005 then
- Error_Msg_SP
- ("generalized use of anonymous access types " &
- "is an Ada 2005 extension");
- Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
- end if;
+ Error_Msg_Ada_2005_Extension
+ ("generalized use of anonymous access types");
Acc_Node := P_Access_Definition (Not_Null_Present);
@@ -1850,12 +1828,8 @@ package body Ch3 is
-- Ada 2005 (AI-230): Access Definition case
elsif Token = Tok_Access then
- if Ada_Version < Ada_2005 then
- Error_Msg_SP
- ("generalized use of anonymous access types " &
- "is an Ada 2005 extension");
- Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
- end if;
+ Error_Msg_Ada_2005_Extension
+ ("generalized use of anonymous access types");
Acc_Node := P_Access_Definition (Null_Exclusion_Present => False);
@@ -2063,11 +2037,7 @@ package body Ch3 is
if Token = Tok_And then
Scan; -- past AND
- if Ada_Version < Ada_2005 then
- Error_Msg_SP
- ("abstract interface is an Ada 2005 extension");
- Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
- end if;
+ Error_Msg_Ada_2005_Extension ("abstract interface");
Set_Interface_List (Typedef_Node, New_List);
@@ -2457,7 +2427,7 @@ package body Ch3 is
begin
if Ada_Version = Ada_83 then
- Error_Msg_SC ("(Ada 83): modular types not allowed");
+ Error_Msg_SC ("(Ada 83) modular types not allowed");
end if;
Typedef_Node := New_Node (N_Modular_Type_Definition, Token_Ptr);
@@ -2795,12 +2765,8 @@ package body Ch3 is
-- Ada 2005 (AI-230): Access Definition case
if Token = Tok_Access then
- if Ada_Version < Ada_2005 then
- Error_Msg_SP
- ("generalized use of anonymous access types " &
- "is an Ada 2005 extension");
- Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
- end if;
+ Error_Msg_Ada_2005_Extension
+ ("generalized use of anonymous access types");
-- AI95-406 makes "aliased" legal (and useless) in this context so
-- followintg code which used to be needed is commented out.
@@ -3002,9 +2968,9 @@ package body Ch3 is
-- DISCRIMINANT_SPECIFICATION ::=
-- DEFINING_IDENTIFIER_LIST : [NULL_EXCLUSION] SUBTYPE_MARK
- -- [:= DEFAULT_EXPRESSION]
+ -- [:= DEFAULT_EXPRESSION] [ASPECT_SPECIFICATION]
-- | DEFINING_IDENTIFIER_LIST : ACCESS_DEFINITION
- -- [:= DEFAULT_EXPRESSION]
+ -- [:= DEFAULT_EXPRESSION] [ASPECT_SPECIFICATION]
-- If no known discriminant part is present, then No_List is returned
@@ -3098,6 +3064,10 @@ package body Ch3 is
Set_Expression
(Specification_Node, Init_Expr_Opt (True));
+ if Token = Tok_With then
+ P_Aspect_Specifications (Specification_Node, False);
+ end if;
+
if Ident > 1 then
Set_Prev_Ids (Specification_Node, True);
end if;
@@ -3584,7 +3554,7 @@ package body Ch3 is
Set_Defining_Identifier (Decl_Node, Idents (Ident));
if Token = Tok_Constant then
- Error_Msg_SC ("constant components are not permitted");
+ Error_Msg_SC ("constant component not permitted");
Scan;
end if;
@@ -3604,12 +3574,8 @@ package body Ch3 is
-- Ada 2005 (AI-230): Access Definition case
if Token = Tok_Access then
- if Ada_Version < Ada_2005 then
- Error_Msg_SP
- ("generalized use of anonymous access types " &
- "is an Ada 2005 extension");
- Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
- end if;
+ Error_Msg_Ada_2005_Extension
+ ("generalized use of anonymous access types");
-- AI95-406 makes "aliased" legal (and useless) here, so the
-- following code which used to be required is commented out.
@@ -3629,7 +3595,7 @@ package body Ch3 is
Set_Null_Exclusion_Present (CompDef_Node, Not_Null_Present);
if Token = Tok_Array then
- Error_Msg_SC ("anonymous arrays not allowed as components");
+ Error_Msg_SC ("anonymous array not allowed as component");
raise Error_Resync;
end if;
@@ -3949,10 +3915,7 @@ package body Ch3 is
Typedef_Node : Node_Id;
begin
- if Ada_Version < Ada_2005 then
- Error_Msg_SP ("abstract interface is an Ada 2005 extension");
- Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
- end if;
+ Error_Msg_Ada_2005_Extension ("abstract interface");
if Abstract_Present then
Error_Msg_SP
@@ -4139,11 +4102,7 @@ package body Ch3 is
-- Ada 2005 (AI-318-02)
if Token = Tok_Access then
- if Ada_Version < Ada_2005 then
- Error_Msg_SC
- ("anonymous access result type is an Ada 2005 extension");
- Error_Msg_SC ("\unit must be compiled with -gnat05 switch");
- end if;
+ Error_Msg_Ada_2005_Extension ("anonymous access result type");
Result_Node := P_Access_Definition (Result_Not_Null);
@@ -4241,10 +4200,7 @@ package body Ch3 is
or else Token = Tok_Procedure
or else Token = Tok_Function
then
- if Ada_Version < Ada_2005 then
- Error_Msg_SP ("access-to-subprogram is an Ada 2005 extension");
- Error_Msg_SP ("\unit should be compiled with -gnat05 switch");
- end if;
+ Error_Msg_Ada_2005_Extension ("access-to-subprogram");
Subp_Node := P_Access_Type_Definition (Header_Already_Parsed => True);
Set_Null_Exclusion_Present (Subp_Node, Null_Exclusion_Present);
@@ -4259,17 +4215,14 @@ package body Ch3 is
if Token = Tok_All then
if Ada_Version < Ada_2005 then
Error_Msg_SP
- ("ALL is not permitted for anonymous access types");
+ ("ALL not permitted for anonymous access type");
end if;
Scan; -- past ALL
Set_All_Present (Def_Node);
elsif Token = Tok_Constant then
- if Ada_Version < Ada_2005 then
- Error_Msg_SP ("access-to-constant is an Ada 2005 extension");
- Error_Msg_SP ("\unit should be compiled with -gnat05 switch");
- end if;
+ Error_Msg_Ada_2005_Extension ("access-to-constant");
Scan; -- past CONSTANT
Set_Constant_Present (Def_Node);
@@ -4794,7 +4747,7 @@ package body Ch3 is
elsif Kind = N_Assignment_Statement then
Error_Msg
("assignment statement not allowed in package spec",
- Sloc (Decl));
+ Sloc (Decl));
end if;
Next (Decl);
diff --git a/gcc/ada/par-ch4.adb b/gcc/ada/par-ch4.adb
index 925da76..340668e 100644
--- a/gcc/ada/par-ch4.adb
+++ b/gcc/ada/par-ch4.adb
@@ -1233,7 +1233,7 @@ package body Ch4 is
Attr_Node := New_Node (N_Attribute_Reference, Token_Ptr);
Set_Attribute_Name (Attr_Node, Attr_Name);
if Attr_Name /= Name_Reduce then
- Error_Msg ("reduce attribute expected", Prev_Token_Ptr);
+ Error_Msg ("Reduce attribute expected", Prev_Token_Ptr);
end if;
Set_Prefix (Attr_Node, S);
@@ -1360,9 +1360,7 @@ package body Ch4 is
procedure Box_Error is
begin
- if Ada_Version < Ada_2005 then
- Error_Msg_SC ("box in aggregate is an Ada 2005 extension");
- end if;
+ Error_Msg_Ada_2005_Extension ("'<'> in aggregate");
-- Ada 2005 (AI-287): The box notation is allowed only with named
-- notation because positional notation might be error prone. For
@@ -1580,17 +1578,13 @@ package body Ch4 is
-- Deal with others association first. This is a named association
if No (Expr_Node) then
- if No (Assoc_List) then
- Assoc_List := New_List;
- end if;
-
- Append (P_Record_Or_Array_Component_Association, Assoc_List);
+ Append_New (P_Record_Or_Array_Component_Association, Assoc_List);
-- Improper use of WITH
elsif Token = Tok_With then
Error_Msg_SC ("WITH must be preceded by single expression in " &
- "extension aggregate");
+ "extension aggregate");
raise Error_Resync;
-- Range attribute can only appear as part of a discrete choice list
@@ -1612,11 +1606,7 @@ package body Ch4 is
elsif Nkind (Expr_Node) in
N_Iterated_Component_Association | N_Iterated_Element_Association
then
- if No (Assoc_List) then
- Assoc_List := New_List (Expr_Node);
- else
- Append_To (Assoc_List, Expr_Node);
- end if;
+ Append_New (Expr_Node, Assoc_List);
elsif Token = Tok_Comma
or else Token = Tok_Right_Paren
@@ -1630,11 +1620,7 @@ package body Ch4 is
& "named association)");
end if;
- if No (Expr_List) then
- Expr_List := New_List;
- end if;
-
- Append (Expr_Node, Expr_List);
+ Append_New (Expr_Node, Expr_List);
-- Check for aggregate followed by left parent, maybe missing comma
@@ -1643,18 +1629,10 @@ package body Ch4 is
then
T_Comma;
- if No (Expr_List) then
- Expr_List := New_List;
- end if;
-
- Append (Expr_Node, Expr_List);
+ Append_New (Expr_Node, Expr_List);
elsif Token = Tok_Right_Bracket then
- if No (Expr_List) then
- Expr_List := New_List;
- end if;
-
- Append (Expr_Node, Expr_List);
+ Append_New (Expr_Node, Expr_List);
exit;
-- Anything else is assumed to be a named association
@@ -1662,11 +1640,7 @@ package body Ch4 is
else
Restore_Scan_State (Scan_State); -- to start of expression
- if No (Assoc_List) then
- Assoc_List := New_List;
- end if;
-
- Append (P_Record_Or_Array_Component_Association, Assoc_List);
+ Append_New (P_Record_Or_Array_Component_Association, Assoc_List);
end if;
exit when not Comma_Present;
@@ -1779,11 +1753,7 @@ package body Ch4 is
-- Ada 2005(AI-287): The box notation is used to indicate the
-- default initialization of aggregate components
- if Ada_Version < Ada_2005 then
- Error_Msg_SP
- ("component association with '<'> is an Ada 2005 extension");
- Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
- end if;
+ Error_Msg_Ada_2005_Extension ("component association with '<'>");
Set_Box_Present (Assoc_Node);
Scan; -- Past box
@@ -2958,10 +2928,7 @@ package body Ch4 is
Scan; -- past minus
when Tok_At_Sign => -- AI12-0125 : target_name
- if Ada_Version < Ada_2020 then
- Error_Msg_SC ("target name is an Ada 202x feature");
- Error_Msg_SC ("\compile with -gnat2020");
- end if;
+ Error_Msg_Ada_2020_Feature ("target name", Token_Ptr);
Node1 := P_Name;
return Node1;
@@ -3438,6 +3405,12 @@ package body Ch4 is
procedure Build_Iterated_Element_Association is
begin
+ -- Build loop_parameter_specification
+
+ Loop_Spec :=
+ New_Node (N_Loop_Parameter_Specification, Prev_Token_Ptr);
+ Set_Defining_Identifier (Loop_Spec, Id);
+
Choice := First (Discrete_Choices (Assoc_Node));
Assoc_Node :=
New_Node (N_Iterated_Element_Association, Prev_Token_Ptr);
@@ -3469,43 +3442,37 @@ package body Ch4 is
-- In addition, if "use" is present after the specification,
-- this is an Iterated_Element_Association that carries a
-- key_expression, and we generate the appropriate node.
- -- Finally, the Iterated_Element form is reserved for contwiner
+ -- Finally, the Iterated_Element form is reserved for container
-- aggregates, and is illegal in array aggregates.
Id := P_Defining_Identifier;
Assoc_Node :=
New_Node (N_Iterated_Component_Association, Prev_Token_Ptr);
- if Token = Tok_In then
+ if Token = Tok_In then
Set_Defining_Identifier (Assoc_Node, Id);
T_In;
Set_Discrete_Choices (Assoc_Node, P_Discrete_Choice_List);
- -- The iterator may include a filter.
+ -- The iterator may include a filter
if Token = Tok_When then
Scan; -- past WHEN
Filter := P_Condition;
end if;
- -- Build loop_parameter specification.
-
- Loop_Spec :=
- New_Node (N_Loop_Parameter_Specification, Prev_Token_Ptr);
- Set_Defining_Identifier (Loop_Spec, Id);
-
if Token = Tok_Use then
-- Ada_2020 Key-expression is present, rewrite node as an
- -- iterated_Element_Awwoiation.
+ -- Iterated_Element_Association.
Scan; -- past USE
Build_Iterated_Element_Association;
Set_Key_Expression (Assoc_Node, P_Expression);
elsif Present (Filter) then
- -- A loop_Parameter_Specification also indicates an Ada_2020
- -- conwtruct, in contrast with a subtype indication used in
+ -- A loop_parameter_specification also indicates an Ada_2020
+ -- construct, in contrast with a subtype indication used in
-- array aggregates.
Build_Iterated_Element_Association;
@@ -3525,7 +3492,7 @@ package body Ch4 is
if Token = Tok_Use then
Scan; -- past USE
- -- This is an iterated_elenent_qssociation.
+ -- This is an iterated_element_association
Assoc_Node :=
New_Node (N_Iterated_Element_Association, Prev_Token_Ptr);
@@ -3537,10 +3504,7 @@ package body Ch4 is
Set_Expression (Assoc_Node, P_Expression);
end if;
- if Ada_Version < Ada_2020 then
- Error_Msg_SC ("iterated component is an Ada 202x feature");
- Error_Msg_SC ("\compile with -gnat2020");
- end if;
+ Error_Msg_Ada_2020_Feature ("iterated component", Token_Ptr);
return Assoc_Node;
end P_Iterated_Component_Association;
@@ -3725,9 +3689,7 @@ package body Ch4 is
Result : constant Node_Id :=
Make_Expression_With_Actions (Loc, Actions, Expression);
begin
- if Ada_Version < Ada_2020 then
- Error_Msg ("declare_expression is an Ada 2020 feature", Loc);
- end if;
+ Error_Msg_Ada_2020_Feature ("declare expression", Loc);
return Result;
end;
diff --git a/gcc/ada/par-ch5.adb b/gcc/ada/par-ch5.adb
index 5b002c4..a8d49b1 100644
--- a/gcc/ada/par-ch5.adb
+++ b/gcc/ada/par-ch5.adb
@@ -1306,14 +1306,16 @@ package body Ch5 is
-- syntax rule.
else
- if Style_Check and then Paren_Count (Cond) > 0 then
- if Nkind (Cond) not in N_If_Expression
- | N_Case_Expression
+ if Style_Check
+ and then
+ Paren_Count (Cond) >
+ (if Nkind (Cond) in N_Case_Expression
+ | N_If_Expression
| N_Quantified_Expression
- or else Paren_Count (Cond) > 1
- then
- Style.Check_Xtra_Parens (First_Sloc (Cond));
- end if;
+ then 1
+ else 0)
+ then
+ Style.Check_Xtra_Parens (First_Sloc (Cond));
end if;
-- And return the result
@@ -1712,9 +1714,9 @@ package body Ch5 is
Set_Discrete_Subtype_Definition
(Loop_Param_Specification_Node, P_Discrete_Subtype_Definition);
- if Ada_Version >= Ada_2020
- and then Token = Tok_When
- then
+ if Token = Tok_When then
+ Error_Msg_Ada_2020_Feature ("iterator filter", Token_Ptr);
+
Scan; -- past WHEN
Set_Iterator_Filter
(Loop_Param_Specification_Node, P_Condition);
@@ -1773,9 +1775,9 @@ package body Ch5 is
Set_Name (Node1, P_Name);
- if Ada_Version >= Ada_2020
- and then Token = Tok_When
- then
+ if Token = Tok_When then
+ Error_Msg_Ada_2020_Feature ("iterator filter", Token_Ptr);
+
Scan; -- past WHEN
Set_Iterator_Filter
(Node1, P_Condition);
diff --git a/gcc/ada/par-ch6.adb b/gcc/ada/par-ch6.adb
index 622a508..145fbc4 100644
--- a/gcc/ada/par-ch6.adb
+++ b/gcc/ada/par-ch6.adb
@@ -426,11 +426,7 @@ package body Ch6 is
-- Ada 2005 (AI-318-02)
if Token = Tok_Access then
- if Ada_Version < Ada_2005 then
- Error_Msg_SC
- ("anonymous access result type is an Ada 2005 extension");
- Error_Msg_SC ("\unit must be compiled with -gnat05 switch");
- end if;
+ Error_Msg_Ada_2005_Extension ("anonymous access result type");
Result_Node := P_Access_Definition (Result_Not_Null);
@@ -598,10 +594,7 @@ package body Ch6 is
-- Ada 2005 (AI-248): Parse a null procedure declaration
elsif Token = Tok_Null then
- if Ada_Version < Ada_2005 then
- Error_Msg_SP ("null procedures are an Ada 2005 extension");
- Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
- end if;
+ Error_Msg_Ada_2005_Extension ("null procedure");
Scan; -- past NULL
@@ -1064,11 +1057,7 @@ package body Ch6 is
-- Ada 2005 (AI-318-02)
if Token = Tok_Access then
- if Ada_Version < Ada_2005 then
- Error_Msg_SC
- ("anonymous access result type is an Ada 2005 extension");
- Error_Msg_SC ("\unit must be compiled with -gnat05 switch");
- end if;
+ Error_Msg_Ada_2005_Extension ("anonymous access result type");
Result_Node := P_Access_Definition (Result_Not_Null);
@@ -1631,9 +1620,8 @@ package body Ch6 is
-- the time being.
elsif Token = Tok_With then
- if not Extensions_Allowed then
- Error_Msg_SP ("aspect on formal parameter requires -gnatX");
- end if;
+ Error_Msg_Ada_2020_Feature
+ ("aspect on formal parameter", Token_Ptr);
P_Aspect_Specifications (Specification_Node, False);
@@ -1650,7 +1638,6 @@ package body Ch6 is
elsif Token = Tok_Comma then
T_Semicolon;
- Scan; -- past comma
-- Special check for omitted separator
@@ -1771,7 +1758,8 @@ package body Ch6 is
--
-- EXTENDED_RETURN_STATEMENT ::=
-- return DEFINING_IDENTIFIER : [aliased] RETURN_SUBTYPE_INDICATION
- -- [:= EXPRESSION] [do
+ -- [:= EXPRESSION]
+ -- [ASPECT_SPECIFICATION] [do
-- HANDLED_SEQUENCE_OF_STATEMENTS
-- end return];
--
@@ -1917,6 +1905,7 @@ package body Ch6 is
Ret_Sloc : constant Source_Ptr := Token_Ptr;
Ret_Strt : constant Column_Number := Start_Column;
Ret_Node : Node_Id;
+ Decl : Node_Id;
-- Start of processing for P_Return_Statement
@@ -1949,15 +1938,15 @@ package body Ch6 is
-- Extended_return_statement (Ada 2005 only -- AI-318):
else
- if Ada_Version < Ada_2005 then
- Error_Msg_SP
- (" extended_return_statement is an Ada 2005 extension");
- Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
- end if;
+ Error_Msg_Ada_2005_Extension ("extended return statement");
Ret_Node := New_Node (N_Extended_Return_Statement, Ret_Sloc);
- Set_Return_Object_Declarations
- (Ret_Node, New_List (P_Return_Object_Declaration));
+ Decl := P_Return_Object_Declaration;
+ Set_Return_Object_Declarations (Ret_Node, New_List (Decl));
+
+ if Token = Tok_With then
+ P_Aspect_Specifications (Decl, False);
+ end if;
if Token = Tok_Do then
Push_Scope_Stack;
diff --git a/gcc/ada/par-ch9.adb b/gcc/ada/par-ch9.adb
index 2672e52..151656c 100644
--- a/gcc/ada/par-ch9.adb
+++ b/gcc/ada/par-ch9.adb
@@ -220,10 +220,7 @@ package body Ch9 is
if Token = Tok_New then
Scan; -- past NEW
- if Ada_Version < Ada_2005 then
- Error_Msg_SP ("task interface is an Ada 2005 extension");
- Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
- end if;
+ Error_Msg_Ada_2005_Extension ("task interface");
Set_Interface_List (Task_Node, New_List);
@@ -565,10 +562,7 @@ package body Ch9 is
if Token = Tok_New then
Scan; -- past NEW
- if Ada_Version < Ada_2005 then
- Error_Msg_SP ("protected interface is an Ada 2005 extension");
- Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
- end if;
+ Error_Msg_Ada_2005_Extension ("protected interface");
Set_Interface_List (Protected_Node, New_List);
@@ -758,8 +752,7 @@ package body Ch9 is
if Is_Overriding or else Not_Overriding then
if Ada_Version < Ada_2005 then
- Error_Msg_SP ("overriding indicator is an Ada 2005 extension");
- Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
+ Error_Msg_Ada_2005_Extension ("overriding indicator");
elsif Token = Tok_Entry then
Decl := P_Entry_Declaration;
@@ -910,7 +903,7 @@ package body Ch9 is
Resync_Past_Semicolon;
elsif Token in Token_Class_Declk then
- Error_Msg_SC ("this declaration not allowed in protected body");
+ Error_Msg_SC ("declaration not allowed in protected body");
Resync_Past_Semicolon;
else
@@ -968,9 +961,7 @@ package body Ch9 is
if Is_Overriding or else Not_Overriding then
if Ada_Version < Ada_2005 then
- Error_Msg_SP ("overriding indicator is an Ada 2005 extension");
- Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
-
+ Error_Msg_Ada_2005_Extension ("overriding indicator");
elsif Token /= Tok_Entry then
Error_Msg_SC -- CODEFIX
("ENTRY expected!");
@@ -1316,6 +1307,7 @@ package body Ch9 is
-- ENTRY_INDEX_SPECIFICATION ::=
-- for DEFINING_IDENTIFIER in DISCRETE_SUBTYPE_DEFINITION
+ -- [ASPECT_SPECIFICATION]
-- Error recovery: can raise Error_Resync
@@ -1329,6 +1321,11 @@ package body Ch9 is
T_In;
Set_Discrete_Subtype_Definition
(Iterator_Node, P_Discrete_Subtype_Definition);
+
+ if Token = Tok_With then
+ P_Aspect_Specifications (Iterator_Node, False);
+ end if;
+
return Iterator_Node;
end P_Entry_Index_Specification;
@@ -1654,7 +1651,7 @@ package body Ch9 is
if Ada_Version = Ada_83 then
Error_Msg_BC ("OR or ELSE expected");
else
- Error_Msg_BC ("OR or ELSE or THEN ABORT expected");
+ Error_Msg_BC ("OR or ELSE or `THEN ABORT` expected");
end if;
Select_Node := Error;
diff --git a/gcc/ada/par-load.adb b/gcc/ada/par-load.adb
index a1857dc..ecd5404 100644
--- a/gcc/ada/par-load.adb
+++ b/gcc/ada/par-load.adb
@@ -318,7 +318,7 @@ begin
Spec_Name := Get_Parent_Spec_Name (Unit_Name (Cur_Unum));
- if Spec_Name /= No_Unit_Name then
+ if Present (Spec_Name) then
Unum :=
Load_Unit
(Load_Name => Spec_Name,
diff --git a/gcc/ada/par-prag.adb b/gcc/ada/par-prag.adb
index 5783c33..51409f2 100644
--- a/gcc/ada/par-prag.adb
+++ b/gcc/ada/par-prag.adb
@@ -105,6 +105,9 @@ function Prag (Pragma_Node : Node_Id; Semi : Source_Ptr) return Node_Id is
-- No_Dependence must be processed at parse time, since otherwise it gets
-- handled too late.
--
+ -- No_Unrecognized_Aspects must be processed at parse time, since
+ -- unrecognized aspects are ignored by the parser.
+ --
-- Note that we don't need to do full error checking for badly formed cases
-- of restrictions, since these will be caught during semantic analysis.
@@ -259,6 +262,12 @@ function Prag (Pragma_Node : Node_Id; Semi : Source_Ptr) return Node_Id is
("??% restriction is obsolete and ignored, consider " &
"using 'S'P'A'R'K_'Mode and gnatprove instead", Arg);
+ when Name_No_Unrecognized_Aspects =>
+ Set_Restriction
+ (No_Unrecognized_Aspects,
+ Pragma_Node,
+ Prag_Id = Pragma_Restriction_Warnings);
+
when others =>
null;
end case;
diff --git a/gcc/ada/par-tchk.adb b/gcc/ada/par-tchk.adb
index 65ff45a..7a3ed5c 100644
--- a/gcc/ada/par-tchk.adb
+++ b/gcc/ada/par-tchk.adb
@@ -436,7 +436,6 @@ package body Tchk is
procedure T_Semicolon is
begin
-
if Token = Tok_Semicolon then
Scan;
diff --git a/gcc/ada/par.adb b/gcc/ada/par.adb
index 4c3a154..95695d2 100644
--- a/gcc/ada/par.adb
+++ b/gcc/ada/par.adb
@@ -1546,6 +1546,10 @@ begin
end loop;
end;
+ if Config_Files_Store_Basename then
+ Complete_Source_File_Entry;
+ end if;
+
-- Normal case of compilation unit
else
diff --git a/gcc/ada/repinfo.adb b/gcc/ada/repinfo.adb
index dff3272..61912ef 100644
--- a/gcc/ada/repinfo.adb
+++ b/gcc/ada/repinfo.adb
@@ -92,18 +92,6 @@ package body Repinfo is
Table_Increment => Alloc.Rep_Table_Increment,
Table_Name => "BE_Rep_Table");
- --------------------------------------------------------------
- -- Representation of Front-End Dynamic Size/Offset Entities --
- --------------------------------------------------------------
-
- package Dynamic_SO_Entity_Table is new Table.Table (
- Table_Component_Type => Entity_Id,
- Table_Index_Type => Nat,
- Table_Low_Bound => 1,
- Table_Initial => Alloc.Rep_Table_Initial,
- Table_Increment => Alloc.Rep_Table_Increment,
- Table_Name => "FE_Rep_Table");
-
Unit_Casing : Casing_Type;
-- Identifier casing for current unit. This is set by List_Rep_Info for
-- each unit, before calling subprograms which may read it.
@@ -138,11 +126,6 @@ package body Repinfo is
-- Local Subprograms --
-----------------------
- function Back_End_Layout return Boolean;
- -- Test for layout mode, True = back end, False = front end. This function
- -- is used rather than checking the configuration parameter because we do
- -- not want Repinfo to depend on Targparm.
-
procedure List_Entities
(Ent : Entity_Id;
Bytes_Big_Endian : Boolean;
@@ -218,18 +201,6 @@ package body Repinfo is
-- flag Paren is set, then the output is surrounded in parentheses if it is
-- other than a simple value.
- ---------------------
- -- Back_End_Layout --
- ---------------------
-
- function Back_End_Layout return Boolean is
- begin
- -- We have back-end layout if the back end has made any entries in the
- -- table of GCC expressions, otherwise we have front-end layout.
-
- return Rep_Table.Last > 0;
- end Back_End_Layout;
-
------------------------
-- Create_Discrim_Ref --
------------------------
@@ -241,16 +212,6 @@ package body Repinfo is
Op1 => Discriminant_Number (Discr));
end Create_Discrim_Ref;
- ---------------------------
- -- Create_Dynamic_SO_Ref --
- ---------------------------
-
- function Create_Dynamic_SO_Ref (E : Entity_Id) return Dynamic_SO_Ref is
- begin
- Dynamic_SO_Entity_Table.Append (E);
- return UI_From_Int (-Dynamic_SO_Entity_Table.Last);
- end Create_Dynamic_SO_Ref;
-
-----------------
-- Create_Node --
-----------------
@@ -279,33 +240,6 @@ package body Repinfo is
return Entity_Header_Num (Id mod Relevant_Entities_Size);
end Entity_Hash;
- ---------------------------
- -- Get_Dynamic_SO_Entity --
- ---------------------------
-
- function Get_Dynamic_SO_Entity (U : Dynamic_SO_Ref) return Entity_Id is
- begin
- return Dynamic_SO_Entity_Table.Table (-UI_To_Int (U));
- end Get_Dynamic_SO_Entity;
-
- -----------------------
- -- Is_Dynamic_SO_Ref --
- -----------------------
-
- function Is_Dynamic_SO_Ref (U : SO_Ref) return Boolean is
- begin
- return U < Uint_0;
- end Is_Dynamic_SO_Ref;
-
- ----------------------
- -- Is_Static_SO_Ref --
- ----------------------
-
- function Is_Static_SO_Ref (U : SO_Ref) return Boolean is
- begin
- return U >= Uint_0;
- end Is_Static_SO_Ref;
-
---------
-- lgx --
---------
@@ -1224,14 +1158,6 @@ package body Repinfo is
else
Write_Val (Esiz, Paren => not List_Representation_Info_To_JSON);
- -- If in front-end layout mode, then dynamic size is stored in
- -- storage units, so renormalize for output.
-
- if not Back_End_Layout then
- Write_Str (" * ");
- Write_Int (SSU);
- end if;
-
-- Add appropriate first bit offset
if not List_Representation_Info_To_JSON then
@@ -2397,11 +2323,7 @@ package body Repinfo is
Write_Char ('(');
end if;
- if Back_End_Layout then
- List_GCC_Expression (Val);
- else
- Write_Name_Decoded (Chars (Get_Dynamic_SO_Entity (Val)));
- end if;
+ List_GCC_Expression (Val);
if Paren then
Write_Char (')');
diff --git a/gcc/ada/repinfo.ads b/gcc/ada/repinfo.ads
index 6731dff..f730c53 100644
--- a/gcc/ada/repinfo.ads
+++ b/gcc/ada/repinfo.ads
@@ -45,28 +45,22 @@ package Repinfo is
-- the corresponding entities as constant non-negative integers,
-- and the Uint values are stored directly in these fields.
- -- For composite types, there are three cases:
+ -- For composite types, there are two cases:
-- 1. In some cases the front end knows the values statically,
-- for example in the case where representation clauses or
-- pragmas specify the values.
- -- 2. If Frontend_Layout is False, then the backend is responsible
- -- for layout of all types and objects not laid out by the
- -- front end. This includes all dynamic values, and also
- -- static values (e.g. record sizes) when not set by the
- -- front end.
-
- -- 3. If Frontend_Layout is True, then the front end lays out
- -- all data, according to target dependent size and alignment
- -- information, creating dynamic inlinable functions where
- -- needed in the case of sizes not known till runtime.
+ -- 2. Otherwise the backend is responsible for layout of all types and
+ -- objects not laid out by the front end. This includes all dynamic
+ -- values, and also static values (e.g. record sizes) when not set by
+ -- the front end.
-----------------------------
-- Back Annotation by Gigi --
-----------------------------
- -- The following interface is used by gigi if Frontend_Layout is False
+ -- The following interface is used by gigi
-- As part of the processing in gigi, the types are laid out and
-- appropriate values computed for the sizes and component positions
@@ -297,76 +291,6 @@ package Repinfo is
function Create_Discrim_Ref (Discr : Entity_Id) return Node_Ref;
-- Creates a reference to the discriminant whose entity is Discr
- --------------------------------------------------------
- -- Front-End Interface for Dynamic Size/Offset Values --
- --------------------------------------------------------
-
- -- If Frontend_Layout is True, then the front-end deals with all
- -- dynamic size and offset fields. There are two cases:
-
- -- 1. The value can be computed at the time of type freezing, and
- -- is stored in a run-time constant. In this case, the field
- -- contains a reference to this entity. In the case of sizes
- -- the value stored is the size in storage units, since dynamic
- -- sizes are always a multiple of storage units.
-
- -- 2. The size/offset depends on the value of discriminants at
- -- run-time. In this case, the front end builds a function to
- -- compute the value. This function has a single parameter
- -- which is the discriminated record object in question. Any
- -- references to discriminant values are simply references to
- -- the appropriate discriminant in this single argument, and
- -- to compute the required size/offset value at run time, the
- -- code generator simply constructs a call to the function
- -- with the appropriate argument. The size/offset field in
- -- this case contains a reference to the function entity.
- -- Note that as for case 1, if such a function is used to
- -- return a size, then the size in storage units is returned,
- -- not the size in bits.
-
- -- The interface here allows these created entities to be referenced
- -- using negative Unit values, so that they can be stored in the
- -- appropriate size and offset fields in the tree.
-
- -- In the case of components, if the location of the component is static,
- -- then all four fields (Component_Bit_Offset, Normalized_Position, Esize,
- -- and Normalized_First_Bit) are set to appropriate values. In the case of
- -- a non-static component location, Component_Bit_Offset is not used and
- -- is left set to Unknown. Normalized_Position and Normalized_First_Bit
- -- are set appropriately.
-
- subtype SO_Ref is Uint;
- -- Type used to represent a Uint value that represents a static or
- -- dynamic size/offset value (non-negative if static, negative if
- -- the size value is dynamic).
-
- subtype Dynamic_SO_Ref is Uint;
- -- Type used to represent a negative Uint value used to store
- -- a dynamic size/offset value.
-
- function Is_Dynamic_SO_Ref (U : SO_Ref) return Boolean;
- pragma Inline (Is_Dynamic_SO_Ref);
- -- Given a SO_Ref (Uint) value, returns True iff the SO_Ref value
- -- represents a dynamic Size/Offset value (i.e. it is negative).
-
- function Is_Static_SO_Ref (U : SO_Ref) return Boolean;
- pragma Inline (Is_Static_SO_Ref);
- -- Given a SO_Ref (Uint) value, returns True iff the SO_Ref value
- -- represents a static Size/Offset value (i.e. it is non-negative).
-
- function Create_Dynamic_SO_Ref (E : Entity_Id) return Dynamic_SO_Ref;
- -- Given the Entity_Id for a constant (case 1), the Node_Id for an
- -- expression (case 2), or the Entity_Id for a function (case 3),
- -- this function returns a (negative) Uint value that can be used
- -- to retrieve the entity or expression for later use.
-
- function Get_Dynamic_SO_Entity (U : Dynamic_SO_Ref) return Entity_Id;
- -- Retrieve the Node_Id or Entity_Id stored by a previous call to
- -- Create_Dynamic_SO_Ref. The approach is that the front end makes
- -- the necessary Create_Dynamic_SO_Ref calls to associate the node
- -- and entity id values and the back end makes Get_Dynamic_SO_Ref
- -- calls to retrieve them.
-
------------------------------
-- External tools Interface --
------------------------------
diff --git a/gcc/ada/rtsfind.adb b/gcc/ada/rtsfind.adb
index 872ce01..6a0631f 100644
--- a/gcc/ada/rtsfind.adb
+++ b/gcc/ada/rtsfind.adb
@@ -423,7 +423,7 @@ package body Rtsfind is
(Unit_Name (Current_Sem_Unit));
begin
- if Parent_Name /= No_Unit_Name then
+ if Present (Parent_Name) then
Get_Name_String (Parent_Name);
declare
diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads
index 42578db..a690bb4 100644
--- a/gcc/ada/rtsfind.ads
+++ b/gcc/ada/rtsfind.ads
@@ -239,8 +239,6 @@ package Rtsfind is
System_Exp_Mod,
System_Exp_Uns,
System_Fat_Flt,
- System_Fat_IEEE_Long_Float,
- System_Fat_IEEE_Short_Float,
System_Fat_LFlt,
System_Fat_LLF,
System_Fat_SFlt,
@@ -249,14 +247,24 @@ package Rtsfind is
System_Fat_VAX_G_Float,
System_Finalization_Masters,
System_Finalization_Root,
- System_Fore,
+ System_Fore_Decimal_32,
+ System_Fore_Decimal_64,
+ System_Fore_Decimal_128,
+ System_Fore_Fixed_32,
+ System_Fore_Fixed_64,
+ System_Fore_Fixed_128,
+ System_Fore_Real,
System_Img_Bool,
System_Img_Char,
- System_Img_Dec,
+ System_Img_Decimal_32,
+ System_Img_Decimal_64,
+ System_Img_Decimal_128,
System_Img_Enum,
System_Img_Enum_New,
+ System_Img_Fixed_32,
+ System_Img_Fixed_64,
+ System_Img_Fixed_128,
System_Img_Int,
- System_Img_LLD,
System_Img_LLI,
System_Img_LLLI,
System_Img_LLU,
@@ -417,16 +425,22 @@ package Rtsfind is
System_Unsigned_Types,
System_Val_Bool,
System_Val_Char,
- System_Val_Dec,
+ System_Val_Decimal_32,
+ System_Val_Decimal_64,
+ System_Val_Decimal_128,
System_Val_Enum,
+ System_Val_Fixed_32,
+ System_Val_Fixed_64,
+ System_Val_Fixed_128,
+ System_Val_Flt,
System_Val_Int,
- System_Val_LLD,
+ System_Val_LFlt,
+ System_Val_LLF,
System_Val_LLI,
System_Val_LLLI,
System_Val_LLU,
System_Val_LLLU,
System_Val_Name,
- System_Val_Real,
System_Val_Uns,
System_Val_WChar,
System_Version_Control,
@@ -756,8 +770,10 @@ package Rtsfind is
RE_Subtract_With_Ovflo_Check64, -- System.Arith_64
RE_Add_With_Ovflo_Check128, -- System.Arith_128
+ RE_Double_Divide128, -- System.Arith_128
RE_Multiply_With_Ovflo_Check128, -- System.Arith_128
RE_Subtract_With_Ovflo_Check128, -- System.Arith_128
+ RE_Scaled_Divide128, -- System.Arith_128
RE_Create_AST_Handler, -- System.AST_Handling
@@ -909,18 +925,10 @@ package Rtsfind is
RE_Attr_Float, -- System.Fat_Flt
- RE_Attr_IEEE_Long, -- System.Fat_IEEE_Long_Float
- RE_Fat_IEEE_Long, -- System.Fat_IEEE_Long_Float
-
- RE_Attr_IEEE_Short, -- System.Fat_IEEE_Short_Float
- RE_Fat_IEEE_Short, -- System.Fat_IEEE_Short_Float
-
RE_Attr_Long_Float, -- System.Fat_LFlt
RE_Attr_Long_Long_Float, -- System.Fat_LLF
- RE_Attr_Short_Float, -- System.Fat_SFlt
-
RE_Attr_VAX_D_Float, -- System.Fat_VAX_D_Float
RE_Fat_VAX_D, -- System.Fat_VAX_D_Float
@@ -933,7 +941,6 @@ package Rtsfind is
RE_Add_Offset_To_Address, -- System.Finalization_Masters
RE_Attach, -- System.Finalization_Masters
RE_Base_Pool, -- System.Finalization_Masters
- RE_Detach, -- System.Finalization_Masters
RE_Finalization_Master, -- System.Finalization_Masters
RE_Finalization_Master_Ptr, -- System.Finalization_Masters
RE_Set_Base_Pool, -- System.Finalization_Masters
@@ -943,14 +950,30 @@ package Rtsfind is
RE_Root_Controlled, -- System.Finalization_Root
RE_Root_Controlled_Ptr, -- System.Finalization_Root
- RE_Fore, -- System.Fore
+ RE_Fore_Decimal32, -- System.Fore_Decimal_32
+
+ RE_Fore_Decimal64, -- System.Fore_Decimal_64
+
+ RE_Fore_Decimal128, -- System.Fore_Decimal_128
+
+ 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
RE_Image_Character_05, -- System.Img_Char
- RE_Image_Decimal, -- System.Img_Dec
+ RE_Image_Decimal32, -- System.Img_Decimal_32
+
+ RE_Image_Decimal64, -- System.Img_Decimal_64
+
+ RE_Image_Decimal128, -- System.Img_Decimal_128
RE_Image_Enumeration_8, -- System.Img_Enum_New
RE_Image_Enumeration_16, -- System.Img_Enum_New
@@ -958,8 +981,6 @@ package Rtsfind is
RE_Image_Integer, -- System.Img_Int
- RE_Image_Long_Long_Decimal, -- System.Img_LLD
-
RE_Image_Long_Long_Integer, -- System.Img_LLI
RE_Image_Long_Long_Long_Integer, -- System.Img_LLLI
@@ -968,6 +989,10 @@ package Rtsfind is
RE_Image_Long_Long_Long_Unsigned, -- System.Img_LLLU
+ 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
@@ -1835,6 +1860,8 @@ package Rtsfind is
RE_I_LI, -- System.Stream_Attributes
RE_I_LLF, -- System.Stream_Attributes
RE_I_LLI, -- System.Stream_Attributes
+ RE_I_LLLI, -- System.Stream_Attributes
+ RE_I_LLLU, -- System.Stream_Attributes
RE_I_LLU, -- System.Stream_Attributes
RE_I_LU, -- System.Stream_Attributes
RE_I_SF, -- System.Stream_Attributes
@@ -1858,6 +1885,8 @@ package Rtsfind is
RE_W_LI, -- System.Stream_Attributes
RE_W_LLF, -- System.Stream_Attributes
RE_W_LLI, -- System.Stream_Attributes
+ RE_W_LLLI, -- System.Stream_Attributes
+ RE_W_LLLU, -- System.Stream_Attributes
RE_W_LLU, -- System.Stream_Attributes
RE_W_LU, -- System.Stream_Attributes
RE_W_SF, -- System.Stream_Attributes
@@ -1991,15 +2020,29 @@ package Rtsfind is
RE_Value_Character, -- System.Val_Char
- RE_Value_Decimal, -- System.Val_Dec
+ RE_Value_Decimal32, -- System_Val_Decimal_32
+
+ RE_Value_Decimal64, -- System_Val_Decimal_64
+
+ 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_Fixed32, -- System_Val_Fixed_32
+
+ RE_Value_Fixed64, -- System_Val_Fixed_64
+
+ RE_Value_Fixed128, -- System_Val_Fixed_128
+
+ RE_Value_Float, -- System_Val_Flt
+
RE_Value_Integer, -- System.Val_Int
- RE_Value_Long_Long_Decimal, -- System.Val_LLD
+ RE_Value_Long_Float, -- System_Val_LFlt
+
+ RE_Value_Long_Long_Float, -- System_Val_LLF
RE_Value_Long_Long_Integer, -- System.Val_LLI
@@ -2009,8 +2052,6 @@ package Rtsfind is
RE_Value_Long_Long_Long_Unsigned, -- System.Val_LLLU
- RE_Value_Real, -- System.Val_Real
-
RE_Value_Unsigned, -- System.Val_Uns
RE_Value_Wide_Character, -- System.Val_WChar
@@ -2403,8 +2444,10 @@ package Rtsfind is
RE_Subtract_With_Ovflo_Check64 => System_Arith_64,
RE_Add_With_Ovflo_Check128 => System_Arith_128,
+ RE_Double_Divide128 => System_Arith_128,
RE_Multiply_With_Ovflo_Check128 => System_Arith_128,
RE_Subtract_With_Ovflo_Check128 => System_Arith_128,
+ RE_Scaled_Divide128 => System_Arith_128,
RE_Create_AST_Handler => System_AST_Handling,
@@ -2562,18 +2605,10 @@ package Rtsfind is
RE_Attr_Float => System_Fat_Flt,
- RE_Attr_IEEE_Long => System_Fat_IEEE_Long_Float,
- RE_Fat_IEEE_Long => System_Fat_IEEE_Long_Float,
-
- RE_Attr_IEEE_Short => System_Fat_IEEE_Short_Float,
- RE_Fat_IEEE_Short => System_Fat_IEEE_Short_Float,
-
RE_Attr_Long_Float => System_Fat_LFlt,
RE_Attr_Long_Long_Float => System_Fat_LLF,
- RE_Attr_Short_Float => System_Fat_SFlt,
-
RE_Attr_VAX_D_Float => System_Fat_VAX_D_Float,
RE_Fat_VAX_D => System_Fat_VAX_D_Float,
@@ -2586,7 +2621,6 @@ package Rtsfind is
RE_Add_Offset_To_Address => System_Finalization_Masters,
RE_Attach => System_Finalization_Masters,
RE_Base_Pool => System_Finalization_Masters,
- RE_Detach => System_Finalization_Masters,
RE_Finalization_Master => System_Finalization_Masters,
RE_Finalization_Master_Ptr => System_Finalization_Masters,
RE_Set_Base_Pool => System_Finalization_Masters,
@@ -2596,14 +2630,30 @@ package Rtsfind is
RE_Root_Controlled => System_Finalization_Root,
RE_Root_Controlled_Ptr => System_Finalization_Root,
- RE_Fore => System_Fore,
+ RE_Fore_Decimal32 => System_Fore_Decimal_32,
+
+ RE_Fore_Decimal64 => System_Fore_Decimal_64,
+
+ RE_Fore_Decimal128 => System_Fore_Decimal_128,
+
+ 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,
RE_Image_Character_05 => System_Img_Char,
- RE_Image_Decimal => System_Img_Dec,
+ RE_Image_Decimal32 => System_Img_Decimal_32,
+
+ RE_Image_Decimal64 => System_Img_Decimal_64,
+
+ RE_Image_Decimal128 => System_Img_Decimal_128,
RE_Image_Enumeration_8 => System_Img_Enum_New,
RE_Image_Enumeration_16 => System_Img_Enum_New,
@@ -2611,8 +2661,6 @@ package Rtsfind is
RE_Image_Integer => System_Img_Int,
- RE_Image_Long_Long_Decimal => System_Img_LLD,
-
RE_Image_Long_Long_Integer => System_Img_LLI,
RE_Image_Long_Long_Long_Integer => System_Img_LLLI,
@@ -2621,6 +2669,10 @@ package Rtsfind is
RE_Image_Long_Long_Long_Unsigned => System_Img_LLLU,
+ 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,
@@ -3488,6 +3540,8 @@ package Rtsfind is
RE_I_LI => System_Stream_Attributes,
RE_I_LLF => System_Stream_Attributes,
RE_I_LLI => System_Stream_Attributes,
+ RE_I_LLLI => System_Stream_Attributes,
+ RE_I_LLLU => System_Stream_Attributes,
RE_I_LLU => System_Stream_Attributes,
RE_I_LU => System_Stream_Attributes,
RE_I_SF => System_Stream_Attributes,
@@ -3511,6 +3565,8 @@ package Rtsfind is
RE_W_LI => System_Stream_Attributes,
RE_W_LLF => System_Stream_Attributes,
RE_W_LLI => System_Stream_Attributes,
+ RE_W_LLLI => System_Stream_Attributes,
+ RE_W_LLLU => System_Stream_Attributes,
RE_W_LLU => System_Stream_Attributes,
RE_W_LU => System_Stream_Attributes,
RE_W_SF => System_Stream_Attributes,
@@ -3644,15 +3700,29 @@ package Rtsfind is
RE_Value_Character => System_Val_Char,
- RE_Value_Decimal => System_Val_Dec,
+ RE_Value_Decimal32 => System_Val_Decimal_32,
+
+ RE_Value_Decimal64 => System_Val_Decimal_64,
+
+ 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_Fixed32 => System_Val_Fixed_32,
+
+ RE_Value_Fixed64 => System_Val_Fixed_64,
+
+ RE_Value_Fixed128 => System_Val_Fixed_128,
+
+ RE_Value_Float => System_Val_Flt,
+
RE_Value_Integer => System_Val_Int,
- RE_Value_Long_Long_Decimal => System_Val_LLD,
+ RE_Value_Long_Float => System_Val_LFlt,
+
+ RE_Value_Long_Long_Float => System_Val_LLF,
RE_Value_Long_Long_Integer => System_Val_LLI,
@@ -3662,8 +3732,6 @@ package Rtsfind is
RE_Value_Long_Long_Long_Unsigned => System_Val_LLLU,
- RE_Value_Real => System_Val_Real,
-
RE_Value_Unsigned => System_Val_Uns,
RE_Value_Wide_Character => System_Val_WChar,
diff --git a/gcc/ada/s-oscons-tmplt.c b/gcc/ada/s-oscons-tmplt.c
index e3e5bc2..582c35e 100644
--- a/gcc/ada/s-oscons-tmplt.c
+++ b/gcc/ada/s-oscons-tmplt.c
@@ -724,6 +724,41 @@ CNU(CRTSCTS, "Output hw flow control")
#endif
CNU(CREAD, "Read")
+#ifndef ICANON
+# define ICANON -1
+#endif
+CNU(ICANON, "canonical mode")
+
+#ifndef CBAUD
+# define CBAUD -1
+#endif
+CNU(CBAUD, "baud speed mask")
+
+#ifndef ECHO
+# define ECHO -1
+#endif
+CNU(ECHO, "echo input characters")
+
+#ifndef ECHOE
+# define ECHOE -1
+#endif
+CNU(ECHOE, "erase preceding characters")
+
+#ifndef ECHOK
+# define ECHOK -1
+#endif
+CNU(ECHOK, "kill character, erases current line")
+
+#ifndef ECHOCTL
+# define ECHOCTL -1
+#endif
+CNU(ECHOCTL, "echo special characters")
+
+#ifndef ECHONL
+# define ECHONL -1
+#endif
+CNU(ECHONL, "force echo NL character")
+
#ifndef CS5
# define CS5 -1
#endif
@@ -1739,6 +1774,9 @@ CND(SIZEOF_sigset, "sigset")
#if defined(_WIN32) || defined(__vxworks)
#define SIZEOF_nfds_t sizeof (int) * 8
#define SIZEOF_socklen_t sizeof (size_t)
+#elif defined(__Lynx__)
+#define SIZEOF_nfds_t sizeof (unsigned long int) * 8
+#define SIZEOF_socklen_t sizeof (socklen_t)
#else
#define SIZEOF_nfds_t sizeof (nfds_t) * 8
#define SIZEOF_socklen_t sizeof (socklen_t)
diff --git a/gcc/ada/sa_messages.ads b/gcc/ada/sa_messages.ads
index 11da9fc..1f6fca8 100644
--- a/gcc/ada/sa_messages.ads
+++ b/gcc/ada/sa_messages.ads
@@ -94,7 +94,7 @@ package SA_Messages is
-- type invariant checks (specific and class-wide), and checks for
-- implementation-defined assertions such as Assert_And_Cut, Assume,
-- Contract_Cases, Default_Initial_Condition, Initial_Condition,
- -- Loop_Invariant, Loop_Variant, and Refined_Post.
+ -- Loop_Invariant, Loop_Variant, Refined_Post, and Subprogram_Variant.
--
-- TBD: it might be nice to distinguish these different kinds of assertions
-- as is done in SPARK's VC_Kind enumeration type, but any distinction
diff --git a/gcc/ada/scng.adb b/gcc/ada/scng.adb
index 0d5cff8..df6a689 100644
--- a/gcc/ada/scng.adb
+++ b/gcc/ada/scng.adb
@@ -25,6 +25,7 @@
with Atree; use Atree;
with Csets; use Csets;
+with Errout; use Errout;
with Hostparm; use Hostparm;
with Namet; use Namet;
with Opt; use Opt;
@@ -1299,19 +1300,15 @@ package body Scng is
return;
end if;
- when '@' =>
- if Ada_Version < Ada_2020 then
- Error_Msg ("target_name is an Ada 202x feature", Scan_Ptr);
- Scan_Ptr := Scan_Ptr + 1;
+ -- AI12-0125-03 : @ is target_name
- else
- -- AI12-0125-03 : @ is target_name
+ when '@' =>
+ Error_Msg_Ada_2020_Feature ("target name", Token_Ptr);
- Accumulate_Checksum ('@');
- Scan_Ptr := Scan_Ptr + 1;
- Token := Tok_At_Sign;
- return;
- end if;
+ Accumulate_Checksum ('@');
+ Scan_Ptr := Scan_Ptr + 1;
+ Token := Tok_At_Sign;
+ return;
-- Asterisk (can be multiplication operator or double asterisk which
-- is the exponentiation compound delimiter).
diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb
index fdc27b3..b94f369 100644
--- a/gcc/ada/sem_aggr.adb
+++ b/gcc/ada/sem_aggr.adb
@@ -452,7 +452,7 @@ package body Sem_Aggr is
This_Range : constant Node_Id := Aggregate_Bounds (N);
-- The aggregate range node of this specific sub-aggregate
- This_Low : constant Node_Id := Low_Bound (Aggregate_Bounds (N));
+ This_Low : constant Node_Id := Low_Bound (Aggregate_Bounds (N));
This_High : constant Node_Id := High_Bound (Aggregate_Bounds (N));
-- The aggregate bounds of this specific sub-aggregate
@@ -785,7 +785,7 @@ package body Sem_Aggr is
-----------------------
procedure Resolve_Aggregate (N : Node_Id; Typ : Entity_Id) is
- Loc : constant Source_Ptr := Sloc (N);
+ Loc : constant Source_Ptr := Sloc (N);
Aggr_Subtyp : Entity_Id;
-- The actual aggregate subtype. This is not necessarily the same as Typ
@@ -816,6 +816,8 @@ package body Sem_Aggr is
return False;
end Within_Aggregate;
+ -- Start of processing for Resolve_Aggregate
+
begin
-- Ignore junk empty aggregate resulting from parser error
@@ -1588,12 +1590,39 @@ package body Sem_Aggr is
Index_Typ : Entity_Id)
is
Loc : constant Source_Ptr := Sloc (N);
+ Id : constant Entity_Id := Defining_Identifier (N);
+
+ -----------------------
+ -- Remove_References --
+ -----------------------
+
+ function Remove_Ref (N : Node_Id) return Traverse_Result;
+ -- Remove references to the entity Id after analysis, so it can be
+ -- properly reanalyzed after construct is expanded into a loop.
+
+ function Remove_Ref (N : Node_Id) return Traverse_Result is
+ begin
+ if Nkind (N) = N_Identifier
+ and then Present (Entity (N))
+ and then Entity (N) = Id
+ then
+ Set_Entity (N, Empty);
+ Set_Etype (N, Empty);
+ end if;
+ Set_Analyzed (N, False);
+ return OK;
+ end Remove_Ref;
+
+ procedure Remove_References is new Traverse_Proc (Remove_Ref);
+
+ -- Local variables
Choice : Node_Id;
Dummy : Boolean;
Ent : Entity_Id;
Expr : Node_Id;
- Id : Entity_Id;
+
+ -- Start of processing for Resolve_Iterated_Component_Association
begin
-- An element iterator specification cannot appear in
@@ -1646,26 +1675,31 @@ package body Sem_Aggr is
-- The expression has to be analyzed once the index variable is
-- directly visible.
- Id := Defining_Identifier (N);
Enter_Name (Id);
Set_Etype (Id, Index_Typ);
Set_Ekind (Id, E_Variable);
Set_Scope (Id, Ent);
- -- Analyze a copy of the expression, to verify legality. We use
- -- a copy because the expression will be analyzed anew when the
- -- enclosing aggregate is expanded, and the construct is rewritten
- -- as a loop with a new index variable.
+ -- Analyze expression without expansion, to verify legality.
+ -- When generating code, we then remove references to the index
+ -- variable, because the expression will be analyzed anew after
+ -- rewritting as a loop with a new index variable; when not
+ -- generating code we leave the analyzed expression as it is.
+
+ Expr := Expression (N);
- Expr := New_Copy_Tree (Expression (N));
- Set_Parent (Expr, N);
- Dummy := Resolve_Aggr_Expr (Expr, False);
+ Expander_Mode_Save_And_Set (False);
+ Dummy := Resolve_Aggr_Expr (Expr, Single_Elmt => False);
+ Expander_Mode_Restore;
+
+ if Operating_Mode /= Check_Semantics then
+ Remove_References (Expr);
+ end if;
-- An iterated_component_association may appear in a nested
-- aggregate for a multidimensional structure: preserve the bounds
-- computed for the expression, as well as the anonymous array
-- type generated for it; both are needed during array expansion.
- -- This does not work for more than two levels of nesting. ???
if Nkind (Expr) = N_Aggregate then
Set_Aggregate_Bounds (Expression (N), Aggregate_Bounds (Expr));
@@ -1836,10 +1870,15 @@ package body Sem_Aggr is
-- Test for the validity of an others choice if present
if Others_Present and then not Others_Allowed then
- Error_Msg_N
- ("OTHERS choice not allowed here",
- First (Choice_List (First (Component_Associations (N)))));
- return Failure;
+ declare
+ Others_N : constant Node_Id :=
+ First (Choice_List (First (Component_Associations (N))));
+ begin
+ Error_Msg_N ("OTHERS choice not allowed here", Others_N);
+ Error_Msg_N ("\qualify the aggregate with a constrained subtype "
+ & "to provide bounds for it", Others_N);
+ return Failure;
+ end;
end if;
-- Protect against cascaded errors
@@ -2572,7 +2611,7 @@ package body Sem_Aggr is
-- In order to diagnose the semantic error we create a duplicate
-- tree to analyze it and perform the check.
- else
+ elsif Nkind (Assoc) /= N_Iterated_Component_Association then
declare
Save_Analysis : constant Boolean := Full_Analysis;
Expr : constant Node_Id :=
@@ -2910,7 +2949,7 @@ package body Sem_Aggr is
while Present (Choice) loop
Analyze_And_Resolve (Choice, Key_Type);
if not Is_Static_Expression (Choice) then
- Error_Msg_N ("Choice must be static", Choice);
+ Error_Msg_N ("choice must be static", Choice);
end if;
Next (Choice);
@@ -2955,7 +2994,7 @@ package body Sem_Aggr is
if Present (Component_Associations (N)) then
if Present (Expressions (N)) then
- Error_Msg_N ("Container aggregate cannot be "
+ Error_Msg_N ("container aggregate cannot be "
& "both positional and named", N);
return;
end if;
@@ -2996,10 +3035,7 @@ package body Sem_Aggr is
Base : constant Node_Id := Expression (N);
begin
- if Ada_Version < Ada_2020 then
- Error_Msg_N ("delta_aggregate is an Ada 202x feature", N);
- Error_Msg_N ("\compile with -gnat2020", N);
- end if;
+ Error_Msg_Ada_2020_Feature ("delta aggregate", Sloc (N));
if not Is_Composite_Type (Typ) then
Error_Msg_N ("not a composite type", N);
@@ -3026,6 +3062,7 @@ package body Sem_Aggr is
Assoc : Node_Id;
Choice : Node_Id;
+ Expr : Node_Id;
begin
Assoc := First (Deltas);
@@ -3035,7 +3072,11 @@ package body Sem_Aggr is
while Present (Choice) loop
if Nkind (Choice) = N_Others_Choice then
Error_Msg_N
- ("others not allowed in delta aggregate", Choice);
+ ("OTHERS not allowed in delta aggregate", Choice);
+
+ elsif Nkind (Choice) = N_Subtype_Indication then
+ Resolve_Discrete_Subtype_Indication
+ (Choice, Base_Type (Index_Type));
else
Analyze_And_Resolve (Choice, Index_Type);
@@ -3062,36 +3103,43 @@ package body Sem_Aggr is
end if;
Enter_Name (Id);
- Analyze_And_Resolve
- (New_Copy_Tree (Expression (Assoc)), Component_Type (Typ));
+ -- Resolve a copy of the expression, after setting
+ -- its parent properly to preserve its context.
+
+ Expr := New_Copy_Tree (Expression (Assoc));
+ Set_Parent (Expr, Assoc);
+ Analyze_And_Resolve (Expr, Component_Type (Typ));
End_Scope;
end;
else
Choice := First (Choice_List (Assoc));
while Present (Choice) loop
+ Analyze (Choice);
+
if Nkind (Choice) = N_Others_Choice then
Error_Msg_N
- ("others not allowed in delta aggregate", Choice);
+ ("OTHERS not allowed in delta aggregate", Choice);
- else
- Analyze (Choice);
+ elsif Is_Entity_Name (Choice)
+ and then Is_Type (Entity (Choice))
+ then
+ -- Choice covers a range of values
- if Is_Entity_Name (Choice)
- and then Is_Type (Entity (Choice))
+ if Base_Type (Entity (Choice)) /=
+ Base_Type (Index_Type)
then
- -- Choice covers a range of values
-
- if Base_Type (Entity (Choice)) /=
- Base_Type (Index_Type)
- then
- Error_Msg_NE
- ("choice does mat match index type of",
- Choice, Typ);
- end if;
- else
- Resolve (Choice, Index_Type);
+ Error_Msg_NE
+ ("choice does not match index type of &",
+ Choice, Typ);
end if;
+
+ elsif Nkind (Choice) = N_Subtype_Indication then
+ Resolve_Discrete_Subtype_Indication
+ (Choice, Base_Type (Index_Type));
+
+ else
+ Resolve (Choice, Index_Type);
end if;
Next (Choice);
@@ -3458,10 +3506,23 @@ package body Sem_Aggr is
if Is_Entity_Name (A) and then Is_Type (Entity (A)) then
- -- AI05-0115: if the ancestor part is a subtype mark, the ancestor
- -- must not have unknown discriminants.
-
- if Has_Unknown_Discriminants (Entity (A)) then
+ -- AI05-0115: If the ancestor part is a subtype mark, the ancestor
+ -- must not have unknown discriminants. To catch cases where the
+ -- aggregate occurs at a place where the full view of the ancestor
+ -- type is visible and doesn't have unknown discriminants, but the
+ -- aggregate type was derived from a partial view that has unknown
+ -- discriminants, we check whether the aggregate type has unknown
+ -- discriminants (unknown discriminants were inherited), along
+ -- with checking that the partial view of the ancestor has unknown
+ -- discriminants. (It might be sufficient to replace the entire
+ -- condition with Has_Unknown_Discriminants (Typ), but that might
+ -- miss some cases, not clear, and causes error changes in some tests
+ -- such as class-wide cases, that aren't clearly improvements. ???)
+
+ if Has_Unknown_Discriminants (Entity (A))
+ or else (Has_Unknown_Discriminants (Typ)
+ and then Partial_View_Has_Unknown_Discr (Entity (A)))
+ then
Error_Msg_NE
("aggregate not available for type& whose ancestor "
& "has unknown discriminants", N, Typ);
@@ -3651,9 +3712,10 @@ package body Sem_Aggr is
--
-- This variable is updated as a side effect of function Get_Value.
- Box_Node : Node_Id := Empty;
- Is_Box_Present : Boolean := False;
- Others_Box : Natural := 0;
+ Box_Node : Node_Id := Empty;
+ Is_Box_Present : Boolean := False;
+ Is_Box_Init_By_Default : Boolean := False;
+ Others_Box : Natural := 0;
-- Ada 2005 (AI-287): Variables used in case of default initialization
-- to provide a functionality similar to Others_Etype. Box_Present
-- indicates that the component takes its default initialization;
@@ -3778,6 +3840,14 @@ package body Sem_Aggr is
Choices => Choice_List,
Expression => Expr,
Box_Present => Is_Box_Present));
+
+ -- If this association has a box for a component that is initialized
+ -- by default, then set flag on the new association to indicate that
+ -- the original association was for such a box-initialized component.
+
+ if Is_Box_Init_By_Default then
+ Set_Was_Default_Init_Box_Association (Last (Assoc_List));
+ end if;
end Add_Association;
-----------------------------
@@ -3995,6 +4065,7 @@ package body Sem_Aggr is
begin
Is_Box_Present := False;
+ Is_Box_Init_By_Default := False;
if No (From) then
return Empty;
@@ -4990,6 +5061,11 @@ package body Sem_Aggr is
Ctyp : constant Entity_Id := Etype (Component);
begin
+ -- Initially assume that the box is for a default-initialized
+ -- component and reset to False in cases where that's not true.
+
+ Is_Box_Init_By_Default := True;
+
-- If there is a default expression for the aggregate, copy
-- it into a new association. This copy must modify the scopes
-- of internal types that may be attached to the expression
@@ -5013,6 +5089,11 @@ package body Sem_Aggr is
and then Nkind (Parent (Component)) = N_Component_Declaration
and then Present (Expression (Parent (Component)))
then
+ -- If component declaration has an initialization expression
+ -- then this is not a case of default initialization.
+
+ Is_Box_Init_By_Default := False;
+
Expr :=
New_Copy_Tree_And_Copy_Dimensions
(Expression (Parent (Component)),
@@ -5303,7 +5384,7 @@ package body Sem_Aggr is
("OTHERS must represent at least one component", Selectr);
elsif Others_Box = 1 and then Warn_On_Redundant_Constructs then
- Error_Msg_N ("others choice is redundant?", Box_Node);
+ Error_Msg_N ("OTHERS choice is redundant?", Box_Node);
Error_Msg_N
("\previous choices cover all components?", Box_Node);
end if;
@@ -5470,7 +5551,7 @@ package body Sem_Aggr is
-- because the association may be a null array range.
Error_Msg_N
- ("(Ada 2005) null not allowed in null-excluding component??", Expr);
+ ("(Ada 2005) NULL not allowed in null-excluding component??", Expr);
Error_Msg_N
("\Constraint_Error will be raised at run time??", Expr);
diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb
index e361601..e4537e4 100644
--- a/gcc/ada/sem_attr.adb
+++ b/gcc/ada/sem_attr.adb
@@ -227,9 +227,11 @@ package body Sem_Attr is
procedure Analyze_Attribute (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Aname : constant Name_Id := Attribute_Name (N);
- P : constant Node_Id := Prefix (N);
Exprs : constant List_Id := Expressions (N);
Attr_Id : constant Attribute_Id := Get_Attribute_Id (Aname);
+ P_Old : constant Node_Id := Prefix (N);
+
+ P : Node_Id := P_Old;
E1 : Node_Id;
E2 : Node_Id;
@@ -348,7 +350,7 @@ package body Sem_Attr is
procedure Check_Floating_Point_Type_2;
-- Verify that prefix of attribute N is a float type and that
- -- two attribute expressions are present
+ -- two attribute expressions are present.
procedure Check_Integer_Type;
-- Verify that prefix of attribute N is an integer type
@@ -420,9 +422,11 @@ package body Sem_Attr is
-- no arguments is used when the caller has already generated the
-- required error messages.
- procedure Error_Attr_P (Msg : String);
+ procedure Error_Attr_P (Msg : String; Msg_Cont : String := "");
pragma No_Return (Error_Attr_P);
- -- Like Error_Attr, but error is posted at the start of the prefix
+ -- Like Error_Attr, but error is posted at the start of the prefix. The
+ -- second message Msg_Cont is useful to issue a continuation message
+ -- before raising Bad_Attribute.
procedure Legal_Formal_Attribute;
-- Common processing for attributes Definite and Has_Discriminants.
@@ -780,6 +784,13 @@ package body Sem_Attr is
Par : Node_Id;
begin
+ -- If N does not come from source, the reference is assumed to be
+ -- valid.
+
+ if not Comes_From_Source (N) then
+ return True;
+ end if;
+
Par := Parent (N);
while Present (Par)
and then
@@ -1030,9 +1041,7 @@ package body Sem_Attr is
-- expression comes from source, e.g. when a single component
-- association in an aggregate has a box association.
- elsif Ada_Version >= Ada_2005
- and then OK_Self_Reference
- then
+ elsif Ada_Version >= Ada_2005 and then OK_Self_Reference then
null;
-- OK if reference to current instance of a protected object
@@ -1460,7 +1469,7 @@ package body Sem_Attr is
if Ada_Version < Ada_2020
and then not Is_Scalar_Type (Image_Type)
then
- Error_Msg_Ada_2020_Feature ("|nonscalar ''Image", Sloc (P));
+ Error_Msg_Ada_2020_Feature ("nonscalar ''Image", Sloc (P));
Error_Attr;
end if;
end Check_Image_Type;
@@ -1654,7 +1663,7 @@ package body Sem_Attr is
----------------------
procedure Check_Array_Type is
- D : Int;
+ D : Pos;
-- Dimension number for array attributes
begin
@@ -1739,9 +1748,7 @@ package body Sem_Attr is
("expression for dimension must be static!", E1);
Error_Attr;
- elsif UI_To_Int (Expr_Value (E1)) > D
- or else UI_To_Int (Expr_Value (E1)) < 1
- then
+ elsif Expr_Value (E1) > D or else Expr_Value (E1) < 1 then
Error_Attr ("invalid dimension number for array type", E1);
end if;
end if;
@@ -1831,7 +1838,7 @@ package body Sem_Attr is
-- Case of an expression
- Resolve (P);
+ Resolve (P_Old);
if Is_Access_Type (P_Type) then
@@ -1847,12 +1854,12 @@ package body Sem_Attr is
Freeze_Before (N, Designated_Type (P_Type));
end if;
- Rewrite (P,
- Make_Explicit_Dereference (Sloc (P),
- Prefix => Relocate_Node (P)));
+ Rewrite (P_Old,
+ Make_Explicit_Dereference (Sloc (P_Old),
+ Prefix => Relocate_Node (P_Old)));
- Analyze_And_Resolve (P);
- P_Type := Etype (P);
+ Analyze_And_Resolve (P_Old);
+ P_Type := Etype (P_Old);
if P_Type = Any_Type then
raise Bad_Attribute;
@@ -2690,10 +2697,13 @@ package body Sem_Attr is
-- Error_Attr_P --
------------------
- procedure Error_Attr_P (Msg : String) is
+ procedure Error_Attr_P (Msg : String; Msg_Cont : String := "") is
begin
Error_Msg_Name_1 := Aname;
Error_Msg_F (Msg, P);
+ if Msg_Cont /= "" then
+ Error_Msg_F (Msg_Cont, P);
+ end if;
Error_Attr;
end Error_Attr_P;
@@ -2842,7 +2852,10 @@ package body Sem_Attr is
and then Attr_Id = Attribute_Old
then " or be eligible for conditional evaluation"
& " (RM 6.1.1 (27))"
- else ""));
+ else ""),
+ Msg_Cont =>
+ "\using pragma Unevaluated_Use_Of_Old (Allow) will make "
+ & "this legal");
when 'W' =>
Error_Msg_Name_1 := Aname;
@@ -3091,6 +3104,15 @@ package body Sem_Attr is
end if;
end if;
+ -- If the prefix was rewritten as a raise node, then rewrite N as a
+ -- raise node, to avoid creating inconsistent trees. We still need to
+ -- perform legality checks on the original tree.
+
+ if Nkind (P) in N_Raise_xxx_Error then
+ Rewrite (N, Relocate_Node (P));
+ P := Original_Node (P_Old);
+ end if;
+
-- Remaining processing depends on attribute
case Attr_Id is
@@ -3151,7 +3173,10 @@ package body Sem_Attr is
-- Adjacent --
--------------
- when Attribute_Adjacent =>
+ when Attribute_Adjacent
+ | Attribute_Copy_Sign
+ | Attribute_Remainder
+ =>
Check_Floating_Point_Type_2;
Set_Etype (N, P_Base_Type);
Resolve (E1, P_Base_Type);
@@ -3273,7 +3298,7 @@ package body Sem_Attr is
Check_E0;
if not Is_Object_Reference (P) then
- Error_Attr_P ("prefix for % attribute must be object");
+ Error_Attr_P ("prefix of % attribute must be object");
-- What about the access object cases ???
@@ -3342,7 +3367,9 @@ package body Sem_Attr is
-- Callable --
--------------
- when Attribute_Callable =>
+ when Attribute_Callable
+ | Attribute_Terminated
+ =>
Check_E0;
Set_Etype (N, Standard_Boolean);
Check_Task_Prefix;
@@ -3387,7 +3414,16 @@ package body Sem_Attr is
-- Ceiling --
-------------
- when Attribute_Ceiling =>
+ when Attribute_Ceiling
+ | Attribute_Floor
+ | Attribute_Fraction
+ | Attribute_Machine
+ | Attribute_Machine_Rounding
+ | Attribute_Model
+ | Attribute_Rounding
+ | Attribute_Truncation
+ | Attribute_Unbiased_Rounding
+ =>
Check_Floating_Point_Type_1;
Set_Etype (N, P_Base_Type);
Resolve (E1, P_Base_Type);
@@ -3479,7 +3515,10 @@ package body Sem_Attr is
-- Compose --
-------------
- when Attribute_Compose =>
+ when Attribute_Compose
+ | Attribute_Leading_Part
+ | Attribute_Scaling
+ =>
Check_Floating_Point_Type_2;
Set_Etype (N, P_Base_Type);
Resolve (E1, P_Base_Type);
@@ -3597,11 +3636,7 @@ package body Sem_Attr is
-- Copy_Sign --
---------------
- when Attribute_Copy_Sign =>
- Check_Floating_Point_Type_2;
- Set_Etype (N, P_Base_Type);
- Resolve (E1, P_Base_Type);
- Resolve (E2, P_Base_Type);
+ -- Shares processing with Adjacent attribute
-----------
-- Count --
@@ -3674,7 +3709,7 @@ package body Sem_Attr is
null;
else
Error_Attr
- ("Attribute % must apply to entry of current task", N);
+ ("attribute % must apply to entry of current task", N);
end if;
end if;
@@ -3686,7 +3721,7 @@ package body Sem_Attr is
| E_Entry_Family
| E_Loop
then
- Error_Attr ("Attribute % cannot appear in inner unit", N);
+ Error_Attr ("attribute % cannot appear in inner unit", N);
elsif Ekind (Scope (Ent)) = E_Protected_Type
and then not Has_Completion (Scope (Ent))
@@ -3800,7 +3835,9 @@ package body Sem_Attr is
-- Denorm --
------------
- when Attribute_Denorm =>
+ when Attribute_Denorm
+ | Attribute_Signed_Zeros
+ =>
Check_Floating_Point_Type_0;
Set_Etype (N, Standard_Boolean);
@@ -3868,7 +3905,7 @@ package body Sem_Attr is
-- Elab_Spec --
---------------
- -- Shares processing with Elab_Body
+ -- Shares processing with Elab_Body attribute
----------------
-- Elaborated --
@@ -3883,7 +3920,14 @@ package body Sem_Attr is
-- Emax --
----------
- when Attribute_Emax =>
+ when Attribute_Emax
+ | Attribute_Machine_Emax
+ | Attribute_Machine_Emin
+ | Attribute_Machine_Mantissa
+ | Attribute_Model_Emin
+ | Attribute_Model_Mantissa
+ | Attribute_Safe_Emax
+ =>
Check_Floating_Point_Type_0;
Set_Etype (N, Universal_Integer);
@@ -3974,7 +4018,12 @@ package body Sem_Attr is
-- Epsilon --
-------------
- when Attribute_Epsilon =>
+ when Attribute_Epsilon
+ | Attribute_Model_Epsilon
+ | Attribute_Model_Small
+ | Attribute_Safe_First
+ | Attribute_Safe_Last
+ =>
Check_Floating_Point_Type_0;
Set_Etype (N, Universal_Real);
@@ -4049,7 +4098,9 @@ package body Sem_Attr is
-- First --
-----------
- when Attribute_First =>
+ when Attribute_First
+ | Attribute_Last
+ =>
Check_Array_Or_Scalar_Type;
Bad_Attribute_For_Predicate;
@@ -4057,7 +4108,10 @@ package body Sem_Attr is
-- First_Bit --
---------------
- when Attribute_First_Bit =>
+ when Attribute_First_Bit
+ | Attribute_Last_Bit
+ | Attribute_Position
+ =>
Check_Component;
Set_Etype (N, Universal_Integer);
@@ -4065,7 +4119,9 @@ package body Sem_Attr is
-- First_Valid --
-----------------
- when Attribute_First_Valid =>
+ when Attribute_First_Valid
+ | Attribute_Last_Valid
+ =>
Check_First_Last_Valid;
Set_Etype (N, P_Type);
@@ -4074,8 +4130,8 @@ package body Sem_Attr is
-----------------
when Attribute_Fixed_Value =>
- Check_E1;
Check_Fixed_Point_Type;
+ Check_E1;
Resolve (E1, Any_Integer);
Set_Etype (N, P_Base_Type);
@@ -4083,10 +4139,7 @@ package body Sem_Attr is
-- Floor --
-----------
- when Attribute_Floor =>
- Check_Floating_Point_Type_1;
- Set_Etype (N, P_Base_Type);
- Resolve (E1, P_Base_Type);
+ -- Shares processing with Ceiling attribute
----------
-- Fore --
@@ -4100,10 +4153,7 @@ package body Sem_Attr is
-- Fraction --
--------------
- when Attribute_Fraction =>
- Check_Floating_Point_Type_1;
- Set_Etype (N, P_Base_Type);
- Resolve (E1, P_Base_Type);
+ -- Shares processing with Ceiling attribute
--------------
-- From_Any --
@@ -4118,7 +4168,9 @@ package body Sem_Attr is
-- Has_Access_Values --
-----------------------
- when Attribute_Has_Access_Values =>
+ when Attribute_Has_Access_Values
+ | Attribute_Has_Tagged_Values
+ =>
Check_Type;
Check_E0;
Set_Etype (N, Standard_Boolean);
@@ -4142,10 +4194,7 @@ package body Sem_Attr is
-- Has_Tagged_Values --
-----------------------
- when Attribute_Has_Tagged_Values =>
- Check_Type;
- Check_E0;
- Set_Etype (N, Standard_Boolean);
+ -- Shares processing with Has_Access_Values attribute
-----------------------
-- Has_Discriminants --
@@ -4276,7 +4325,11 @@ package body Sem_Attr is
-- Large --
-----------
- when Attribute_Large =>
+ when Attribute_Large
+ | Attribute_Small
+ | Attribute_Safe_Large
+ | Attribute_Safe_Small
+ =>
Check_E0;
Check_Real_Type;
Set_Etype (N, Universal_Real);
@@ -4285,35 +4338,25 @@ package body Sem_Attr is
-- Last --
----------
- when Attribute_Last =>
- Check_Array_Or_Scalar_Type;
- Bad_Attribute_For_Predicate;
+ -- Shares processing with First attribute
--------------
-- Last_Bit --
--------------
- when Attribute_Last_Bit =>
- Check_Component;
- Set_Etype (N, Universal_Integer);
+ -- Shares processing with First_Bit attribute
----------------
-- Last_Valid --
----------------
- when Attribute_Last_Valid =>
- Check_First_Last_Valid;
- Set_Etype (N, P_Type);
+ -- Shares processing with First_Valid attribute
------------------
-- Leading_Part --
------------------
- when Attribute_Leading_Part =>
- Check_Floating_Point_Type_2;
- Set_Etype (N, P_Base_Type);
- Resolve (E1, P_Base_Type);
- Resolve (E2, Any_Integer);
+ -- Shares processing with Compose attribute
------------
-- Length --
@@ -4375,7 +4418,8 @@ package body Sem_Attr is
-- within the related loop.
function Declared_Within (Nod : Node_Id) return Boolean;
- -- Determine whether Nod appears in the subtree of Loop_Decl
+ -- Determine whether Nod appears in the subtree of Loop_Decl but
+ -- not within the subtree of the prefix P itself.
---------------------
-- Check_Reference --
@@ -4411,6 +4455,9 @@ package body Sem_Attr is
if Stmt = Loop_Decl then
return True;
+ elsif Stmt = P then
+ return False;
+
-- Prevent the search from going too far
elsif Is_Body_Or_Package_Declaration (Stmt) then
@@ -4679,40 +4726,33 @@ package body Sem_Attr is
-- Machine --
-------------
- when Attribute_Machine =>
- Check_Floating_Point_Type_1;
- Set_Etype (N, P_Base_Type);
- Resolve (E1, P_Base_Type);
+ -- Shares processing with Ceiling attribute
------------------
-- Machine_Emax --
------------------
- when Attribute_Machine_Emax =>
- Check_Floating_Point_Type_0;
- Set_Etype (N, Universal_Integer);
+ -- Shares processing with Emax attribute
------------------
-- Machine_Emin --
------------------
- when Attribute_Machine_Emin =>
- Check_Floating_Point_Type_0;
- Set_Etype (N, Universal_Integer);
+ -- Shares processing with Emax attribute
----------------------
-- Machine_Mantissa --
----------------------
- when Attribute_Machine_Mantissa =>
- Check_Floating_Point_Type_0;
- Set_Etype (N, Universal_Integer);
+ -- Shares processing with Emax attribute
-----------------------
-- Machine_Overflows --
-----------------------
- when Attribute_Machine_Overflows =>
+ when Attribute_Machine_Overflows
+ | Attribute_Machine_Rounds
+ =>
Check_Real_Type;
Check_E0;
Set_Etype (N, Standard_Boolean);
@@ -4721,7 +4761,9 @@ package body Sem_Attr is
-- Machine_Radix --
-------------------
- when Attribute_Machine_Radix =>
+ when Attribute_Machine_Radix
+ | Attribute_Mantissa
+ =>
Check_Real_Type;
Check_E0;
Set_Etype (N, Universal_Integer);
@@ -4730,25 +4772,22 @@ package body Sem_Attr is
-- Machine_Rounding --
----------------------
- when Attribute_Machine_Rounding =>
- Check_Floating_Point_Type_1;
- Set_Etype (N, P_Base_Type);
- Resolve (E1, P_Base_Type);
+ -- Shares processing with Ceiling attribute
--------------------
-- Machine_Rounds --
--------------------
- when Attribute_Machine_Rounds =>
- Check_Real_Type;
- Check_E0;
- Set_Etype (N, Standard_Boolean);
+ -- Shares processing with Machine_Overflows attribute
------------------
-- Machine_Size --
------------------
- when Attribute_Machine_Size =>
+ when Attribute_Machine_Size
+ | Attribute_Object_Size
+ | Attribute_Value_Size
+ =>
Check_E0;
Check_Type;
Check_Not_Incomplete_Type;
@@ -4758,10 +4797,7 @@ package body Sem_Attr is
-- Mantissa --
--------------
- when Attribute_Mantissa =>
- Check_E0;
- Check_Real_Type;
- Set_Etype (N, Universal_Integer);
+ -- Shares processing with Machine_Radix attribute
---------
-- Max --
@@ -4821,7 +4857,7 @@ package body Sem_Attr is
Error_Attr;
elsif UI_To_Int (Intval (E1)) > Number_Formals (Entity (P))
- or else UI_To_Int (Intval (E1)) < 0
+ or else Intval (E1) < 0
then
Error_Attr ("invalid parameter number for % attribute", E1);
end if;
@@ -4855,42 +4891,31 @@ package body Sem_Attr is
-- Model --
-----------
- when Attribute_Model =>
- Check_Floating_Point_Type_1;
- Set_Etype (N, P_Base_Type);
- Resolve (E1, P_Base_Type);
+ -- Shares processing with Ceiling attribute
----------------
-- Model_Emin --
----------------
- when Attribute_Model_Emin =>
- Check_Floating_Point_Type_0;
- Set_Etype (N, Universal_Integer);
+ -- Shares processing with Emax attribute
-------------------
-- Model_Epsilon --
-------------------
- when Attribute_Model_Epsilon =>
- Check_Floating_Point_Type_0;
- Set_Etype (N, Universal_Real);
+ -- Shares processing with Epsilon attribute
--------------------
-- Model_Mantissa --
--------------------
- when Attribute_Model_Mantissa =>
- Check_Floating_Point_Type_0;
- Set_Etype (N, Universal_Integer);
+ -- Shares processing with Emax attribute
-----------------
-- Model_Small --
-----------------
- when Attribute_Model_Small =>
- Check_Floating_Point_Type_0;
- Set_Etype (N, Universal_Real);
+ -- Shares processing with Epsilon attribute
-------------
-- Modulus --
@@ -4989,11 +5014,7 @@ package body Sem_Attr is
-- Object_Size --
-----------------
- when Attribute_Object_Size =>
- Check_E0;
- Check_Type;
- Check_Not_Incomplete_Type;
- Set_Etype (N, Universal_Integer);
+ -- Shares processing with Machine_Size attribute
---------
-- Old --
@@ -5300,23 +5321,23 @@ package body Sem_Attr is
-- Position --
--------------
- when Attribute_Position =>
- Check_Component;
- Set_Etype (N, Universal_Integer);
+ -- Shares processing with First_Bit attribute
----------
-- Pred --
----------
- when Attribute_Pred =>
+ when Attribute_Pred
+ | Attribute_Succ
+ =>
Check_Scalar_Type;
Check_E1;
Resolve (E1, P_Base_Type);
Set_Etype (N, P_Base_Type);
- -- Since Pred works on the base type, we normally do no check for the
- -- floating-point case, since the base type is unconstrained. But we
- -- make an exception in Check_Float_Overflow mode.
+ -- Since Pred/Succ work on the base type, we normally do no check for
+ -- the floating-point case, since the base type is unconstrained. But
+ -- we make an exception in Check_Float_Overflow mode.
if Is_Floating_Point_Type (P_Type) then
if not Range_Checks_Suppressed (P_Base_Type) then
@@ -5657,7 +5678,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))
@@ -5666,7 +5687,7 @@ package body Sem_Attr is
N_Iterated_Component_Association
then
Error_Msg_N
- ("Prefix of reduce must be an iterated component", N);
+ ("prefix of Reduce must be an iterated component", N);
end if;
Analyze (E1);
@@ -5706,11 +5727,7 @@ package body Sem_Attr is
-- Remainder --
---------------
- when Attribute_Remainder =>
- Check_Floating_Point_Type_2;
- Set_Etype (N, P_Base_Type);
- Resolve (E1, P_Base_Type);
- Resolve (E2, P_Base_Type);
+ -- Shares processing with Adjacent attribute
---------------------
-- Restriction_Set --
@@ -5833,52 +5850,37 @@ package body Sem_Attr is
-- Rounding --
--------------
- when Attribute_Rounding =>
- Check_Floating_Point_Type_1;
- Set_Etype (N, P_Base_Type);
- Resolve (E1, P_Base_Type);
+ -- Shares processing with Ceiling attribute
---------------
-- Safe_Emax --
---------------
- when Attribute_Safe_Emax =>
- Check_Floating_Point_Type_0;
- Set_Etype (N, Universal_Integer);
+ -- Shares processing with Emax attribute
----------------
-- Safe_First --
----------------
- when Attribute_Safe_First =>
- Check_Floating_Point_Type_0;
- Set_Etype (N, Universal_Real);
+ -- Shares processing with Epsilon attribute
----------------
-- Safe_Large --
----------------
- when Attribute_Safe_Large =>
- Check_E0;
- Check_Real_Type;
- Set_Etype (N, Universal_Real);
+ -- Shares processing with Large attribute
---------------
-- Safe_Last --
---------------
- when Attribute_Safe_Last =>
- Check_Floating_Point_Type_0;
- Set_Etype (N, Universal_Real);
+ -- Shares processing with Epsilon attribute
----------------
-- Safe_Small --
----------------
- when Attribute_Safe_Small =>
- Check_E0;
- Check_Real_Type;
- Set_Etype (N, Universal_Real);
+ -- Shares processing with Large attribute
--------------------------
-- Scalar_Storage_Order --
@@ -5947,18 +5949,13 @@ package body Sem_Attr is
-- Scaling --
-------------
- when Attribute_Scaling =>
- Check_Floating_Point_Type_2;
- Set_Etype (N, P_Base_Type);
- Resolve (E1, P_Base_Type);
+ -- Shares processing with Compose attribute
------------------
-- Signed_Zeros --
------------------
- when Attribute_Signed_Zeros =>
- Check_Floating_Point_Type_0;
- Set_Etype (N, Standard_Boolean);
+ -- Shares processing with Denorm attribute
----------
-- Size --
@@ -6048,10 +6045,17 @@ package body Sem_Attr is
-- Small --
-----------
- when Attribute_Small =>
- Check_E0;
- Check_Real_Type;
- Set_Etype (N, Universal_Real);
+ -- Shares processing with Large attribute
+
+ ---------------------------------------
+ -- Small_Denominator/Small_Numerator --
+ ---------------------------------------
+
+ when Attribute_Small_Denominator
+ | Attribute_Small_Numerator
+ =>
+ Check_Fixed_Point_Type_0;
+ Set_Etype (N, Universal_Integer);
------------------
-- Storage_Pool --
@@ -6135,6 +6139,8 @@ package body Sem_Attr is
Check_Restriction (No_Obsolescent_Features, P);
elsif Is_Access_Type (P_Type) then
+ Set_Etype (N, Universal_Integer);
+
if Ekind (P_Type) = E_Access_Subprogram_Type then
Error_Attr_P
("cannot use % attribute for access-to-subprogram type");
@@ -6144,7 +6150,6 @@ package body Sem_Attr is
and then Is_Type (Entity (P))
then
Check_Type;
- Set_Etype (N, Universal_Integer);
-- Validate_Remote_Access_To_Class_Wide_Type for attribute
-- Storage_Size since this attribute is not defined for
@@ -6157,7 +6162,6 @@ package body Sem_Attr is
else
Check_Task_Prefix;
- Set_Etype (N, Universal_Integer);
end if;
else
@@ -6227,30 +6231,7 @@ package body Sem_Attr is
-- Succ --
----------
- when Attribute_Succ =>
- Check_Scalar_Type;
- Check_E1;
- Resolve (E1, P_Base_Type);
- Set_Etype (N, P_Base_Type);
-
- -- Since Pred works on the base type, we normally do no check for the
- -- floating-point case, since the base type is unconstrained. But we
- -- make an exception in Check_Float_Overflow mode.
-
- if Is_Floating_Point_Type (P_Type) then
- if not Range_Checks_Suppressed (P_Base_Type) then
- Set_Do_Range_Check (E1);
- end if;
-
- -- If not modular type, test for overflow check required
-
- else
- if not Is_Modular_Integer_Type (P_Type)
- and then not Range_Checks_Suppressed (P_Base_Type)
- then
- Enable_Range_Check (E1);
- end if;
- end if;
+ -- Shares processing with Pred attribute
--------------------------------
-- System_Allocator_Alignment --
@@ -6279,7 +6260,7 @@ package body Sem_Attr is
then
Error_Attr_P
("% attribute can only be applied to objects " &
- "of class - wide type");
+ "of class-wide type");
end if;
-- The prefix cannot be an incomplete type. However, references to
@@ -6331,10 +6312,7 @@ package body Sem_Attr is
-- Terminated --
----------------
- when Attribute_Terminated =>
- Check_E0;
- Set_Etype (N, Standard_Boolean);
- Check_Task_Prefix;
+ -- Shares processing with Callable attribute
----------------
-- To_Address --
@@ -6397,10 +6375,7 @@ package body Sem_Attr is
-- Truncation --
----------------
- when Attribute_Truncation =>
- Check_Floating_Point_Type_1;
- Resolve (E1, P_Base_Type);
- Set_Etype (N, P_Base_Type);
+ -- Shares processing with Ceiling attribute
----------------
-- Type_Class --
@@ -6589,10 +6564,7 @@ package body Sem_Attr is
-- Unbiased_Rounding --
-----------------------
- when Attribute_Unbiased_Rounding =>
- Check_Floating_Point_Type_1;
- Set_Etype (N, P_Base_Type);
- Resolve (E1, P_Base_Type);
+ -- Shares processing with Ceiling attribute
----------------------
-- Unchecked_Access --
@@ -6632,7 +6604,7 @@ package body Sem_Attr is
Check_E0;
if not Is_Entity_Name (P)
- or else Ekind (Entity (P)) not in Named_Kind
+ or else not Is_Named_Number (Entity (P))
then
Error_Attr_P ("prefix for % attribute must be named number");
@@ -6773,7 +6745,7 @@ package body Sem_Attr is
if Nkind (Expr) = N_Others_Choice then
Error_Attr
- ("others choice not allowed in attribute %", Expr);
+ ("OTHERS choice not allowed in attribute %", Expr);
-- Otherwise analyze and resolve all indexes
@@ -6820,7 +6792,7 @@ package body Sem_Attr is
if Nkind (Index) = N_Others_Choice then
Error_Attr
- ("others choice not allowed in attribute %", Index);
+ ("OTHERS choice not allowed in attribute %", Index);
-- The index denotes a range of elements
@@ -6995,7 +6967,7 @@ package body Sem_Attr is
elsif Nkind (Comp) = N_Others_Choice then
Error_Attr
- ("others choice not allowed in attribute %", Comp);
+ ("OTHERS choice not allowed in attribute %", Comp);
-- The name of a record component cannot appear in any
-- other form.
@@ -7132,7 +7104,10 @@ package body Sem_Attr is
-- Value --
-----------
- when Attribute_Value =>
+ when Attribute_Value
+ | Attribute_Wide_Value
+ | Attribute_Wide_Wide_Value
+ =>
Check_E1;
Check_Scalar_Type;
@@ -7182,11 +7157,7 @@ package body Sem_Attr is
-- Value_Size --
----------------
- when Attribute_Value_Size =>
- Check_E0;
- Check_Type;
- Check_Not_Incomplete_Type;
- Set_Etype (N, Universal_Integer);
+ -- Shares processing with Machine_Size attribute
-------------
-- Version --
@@ -7222,51 +7193,22 @@ package body Sem_Attr is
-- Wide_Value --
----------------
- when Attribute_Wide_Value =>
- Check_E1;
- Check_Scalar_Type;
-
- -- Set Etype before resolving expression because expansion
- -- of expression may require enclosing type.
-
- Set_Etype (N, P_Type);
- Validate_Non_Static_Attribute_Function_Call;
-
- -- Check restriction No_Fixed_IO
-
- if Restriction_Check_Required (No_Fixed_IO)
- and then Is_Fixed_Point_Type (P_Type)
- then
- Check_Restriction (No_Fixed_IO, P);
- end if;
+ -- Shares processing with Value attribute
---------------------
-- Wide_Wide_Value --
---------------------
- when Attribute_Wide_Wide_Value =>
- Check_E1;
- Check_Scalar_Type;
-
- -- Set Etype before resolving expression because expansion
- -- of expression may require enclosing type.
-
- Set_Etype (N, P_Type);
- Validate_Non_Static_Attribute_Function_Call;
-
- -- Check restriction No_Fixed_IO
-
- if Restriction_Check_Required (No_Fixed_IO)
- and then Is_Fixed_Point_Type (P_Type)
- then
- Check_Restriction (No_Fixed_IO, P);
- end if;
+ -- Shares processing with Value attribute
---------------------
-- Wide_Wide_Width --
---------------------
- when Attribute_Wide_Wide_Width =>
+ when Attribute_Wide_Wide_Width
+ | Attribute_Wide_Width
+ | Attribute_Width
+ =>
Check_E0;
Check_Scalar_Type;
Set_Etype (N, Universal_Integer);
@@ -7275,19 +7217,13 @@ package body Sem_Attr is
-- Wide_Width --
----------------
- when Attribute_Wide_Width =>
- Check_E0;
- Check_Scalar_Type;
- Set_Etype (N, Universal_Integer);
+ -- Shares processing with Wide_Wide_Width attribute
-----------
-- Width --
-----------
- when Attribute_Width =>
- Check_E0;
- Check_Scalar_Type;
- Set_Etype (N, Universal_Integer);
+ -- Shares processing with Wide_Wide_Width attribute
---------------
-- Word_Size --
@@ -7789,7 +7725,7 @@ package body Sem_Attr is
-- we will do the folding right here (things get confused if we let this
-- case go through the normal circuitry).
- if Attribute_Name (N) = Name_Img
+ if Id = Attribute_Img
and then Is_Entity_Name (P)
and then Is_Enumeration_Type (Etype (Entity (P)))
and then Is_OK_Static_Expression (P)
@@ -8123,7 +8059,7 @@ package body Sem_Attr is
-- T'Descriptor_Size is never static, even if T is static.
if Is_Scalar_Type (P_Entity)
- and then (not Is_Generic_Type (P_Entity))
+ and then not Is_Generic_Type (P_Entity)
and then Is_Static_Subtype (P_Entity)
and then Is_Scalar_Type (Etype (N))
and then
@@ -8147,7 +8083,7 @@ package body Sem_Attr is
if Is_Type (P_Entity)
and then (Is_Scalar_Type (P_Entity) or Is_Array_Type (P_Entity))
- and then (not Is_Generic_Type (P_Entity))
+ and then not Is_Generic_Type (P_Entity)
then
P_Type := P_Entity;
@@ -8155,7 +8091,7 @@ package body Sem_Attr is
elsif Ekind (P_Entity) in E_Variable | E_Constant
and then Is_Array_Type (Etype (P_Entity))
- and then (not Is_Generic_Type (Etype (P_Entity)))
+ and then not Is_Generic_Type (Etype (P_Entity))
then
P_Type := Etype (P_Entity);
@@ -8204,7 +8140,7 @@ package body Sem_Attr is
elsif (Id = Attribute_Size or
Id = Attribute_Max_Size_In_Storage_Elements)
and then Is_Type (P_Entity)
- and then (not Is_Generic_Type (P_Entity))
+ and then not Is_Generic_Type (P_Entity)
and then Known_Static_RM_Size (P_Entity)
then
declare
@@ -8226,7 +8162,7 @@ package body Sem_Attr is
elsif Id = Attribute_Alignment
and then Is_Type (P_Entity)
- and then (not Is_Generic_Type (P_Entity))
+ and then not Is_Generic_Type (P_Entity)
and then Known_Alignment (P_Entity)
then
Compile_Time_Known_Attribute (N, Alignment (P_Entity));
@@ -8235,7 +8171,7 @@ package body Sem_Attr is
-- If this is an access attribute that is known to fail accessibility
-- check, rewrite accordingly.
- elsif Attribute_Name (N) = Name_Access
+ elsif Id = Attribute_Address
and then Raises_Constraint_Error (N)
then
Rewrite (N,
@@ -9894,6 +9830,20 @@ package body Sem_Attr is
Fold_Ureal (N, Small_Value (P_Type), True);
end if;
+ -----------------------
+ -- Small_Denominator --
+ -----------------------
+
+ when Attribute_Small_Denominator =>
+ Fold_Uint (N, Norm_Den (Small_Value (P_Type)), True);
+
+ ---------------------
+ -- Small_Numerator --
+ ---------------------
+
+ when Attribute_Small_Numerator =>
+ Fold_Uint (N, Norm_Num (Small_Value (P_Type)), True);
+
-----------------
-- Stream_Size --
-----------------
diff --git a/gcc/ada/sem_aux.adb b/gcc/ada/sem_aux.adb
index 36fd6ad..4925ffd 100644
--- a/gcc/ada/sem_aux.adb
+++ b/gcc/ada/sem_aux.adb
@@ -26,6 +26,7 @@
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;
@@ -430,34 +431,6 @@ package body Sem_Aux is
return Empty;
end First_Tag_Component;
- ---------------------
- -- Get_Binary_Nkind --
- ---------------------
-
- function Get_Binary_Nkind (Op : Entity_Id) return Node_Kind is
- begin
- case Chars (Op) is
- when Name_Op_Add => return N_Op_Add;
- when Name_Op_Concat => return N_Op_Concat;
- when Name_Op_Expon => return N_Op_Expon;
- when Name_Op_Subtract => return N_Op_Subtract;
- when Name_Op_Mod => return N_Op_Mod;
- when Name_Op_Multiply => return N_Op_Multiply;
- when Name_Op_Divide => return N_Op_Divide;
- when Name_Op_Rem => return N_Op_Rem;
- when Name_Op_And => return N_Op_And;
- when Name_Op_Eq => return N_Op_Eq;
- when Name_Op_Ge => return N_Op_Ge;
- when Name_Op_Gt => return N_Op_Gt;
- when Name_Op_Le => return N_Op_Le;
- when Name_Op_Lt => return N_Op_Lt;
- when Name_Op_Ne => return N_Op_Ne;
- when Name_Op_Or => return N_Op_Or;
- when Name_Op_Xor => return N_Op_Xor;
- when others => raise Program_Error;
- end case;
- end Get_Binary_Nkind;
-
-----------------------
-- Get_Called_Entity --
-----------------------
@@ -656,21 +629,6 @@ package body Sem_Aux is
return Empty;
end Get_Rep_Pragma;
- ---------------------
- -- Get_Unary_Nkind --
- ---------------------
-
- function Get_Unary_Nkind (Op : Entity_Id) return Node_Kind is
- begin
- case Chars (Op) is
- when Name_Op_Abs => return N_Op_Abs;
- when Name_Op_Subtract => return N_Op_Minus;
- when Name_Op_Not => return N_Op_Not;
- when Name_Op_Add => return N_Op_Plus;
- when others => raise Program_Error;
- end case;
- end Get_Unary_Nkind;
-
---------------------------------
-- Has_External_Tag_Rep_Clause --
---------------------------------
@@ -1288,19 +1246,6 @@ package body Sem_Aux is
end if;
end Is_Limited_View;
- ----------------------------
- -- Is_Protected_Operation --
- ----------------------------
-
- function Is_Protected_Operation (E : Entity_Id) return Boolean is
- begin
- return
- Is_Entry (E)
- or else (Is_Subprogram (E)
- and then Nkind (Parent (Unit_Declaration_Node (E))) =
- N_Protected_Definition);
- end Is_Protected_Operation;
-
-------------------------------
-- Is_Record_Or_Limited_Type --
-------------------------------
@@ -1414,33 +1359,6 @@ package body Sem_Aux is
return Empty;
end Next_Tag_Component;
- -----------------------
- -- Number_Components --
- -----------------------
-
- function Number_Components (Typ : Entity_Id) return Nat is
- N : Nat := 0;
- Comp : Entity_Id;
-
- begin
- -- We do not call Einfo.First_Component_Or_Discriminant, as this
- -- function does not skip completely hidden discriminants, which we
- -- want to skip here.
-
- if Has_Discriminants (Typ) then
- Comp := First_Discriminant (Typ);
- else
- Comp := First_Component (Typ);
- end if;
-
- while Present (Comp) loop
- N := N + 1;
- Next_Component_Or_Discriminant (Comp);
- end loop;
-
- return N;
- end Number_Components;
-
--------------------------
-- Number_Discriminants --
--------------------------
@@ -1479,38 +1397,6 @@ package body Sem_Aux is
end Object_Type_Has_Constrained_Partial_View;
------------------
- -- Package_Body --
- ------------------
-
- function Package_Body (E : Entity_Id) return Node_Id is
- N : Node_Id;
-
- begin
- if Ekind (E) = E_Package_Body then
- N := Parent (E);
-
- if Nkind (N) = N_Defining_Program_Unit_Name then
- N := Parent (N);
- end if;
-
- else
- N := Package_Spec (E);
-
- if Present (Corresponding_Body (N)) then
- N := Parent (Corresponding_Body (N));
-
- if Nkind (N) = N_Defining_Program_Unit_Name then
- N := Parent (N);
- end if;
- else
- N := Empty;
- end if;
- end if;
-
- return N;
- end Package_Body;
-
- ------------------
-- Package_Spec --
------------------
diff --git a/gcc/ada/sem_aux.ads b/gcc/ada/sem_aux.ads
index 1d82045..237d5dc 100644
--- a/gcc/ada/sem_aux.ads
+++ b/gcc/ada/sem_aux.ads
@@ -34,7 +34,6 @@ with Alloc;
with Namet; use Namet;
with Table;
with Types; use Types;
-with Sinfo; use Sinfo;
package Sem_Aux is
@@ -148,22 +147,10 @@ package Sem_Aux is
-- Typ must be a tagged record type. This function returns the Entity for
-- the first _Tag field in the record type.
- function Get_Binary_Nkind (Op : Entity_Id) return Node_Kind;
- -- Op must be an entity with an Ekind of E_Operator. This function returns
- -- the Nkind value that would be used to construct a binary operator node
- -- referencing this entity. It is an error to call this function if Ekind
- -- (Op) /= E_Operator.
-
function Get_Called_Entity (Call : Node_Id) return Entity_Id;
-- Obtain the entity of the entry, operator, or subprogram being invoked
-- by call Call.
- function Get_Unary_Nkind (Op : Entity_Id) return Node_Kind;
- -- Op must be an entity with an Ekind of E_Operator. This function returns
- -- the Nkind value that would be used to construct a unary operator node
- -- referencing this entity. It is an error to call this function if Ekind
- -- (Op) /= E_Operator.
-
function Get_Rep_Item
(E : Entity_Id;
Nam : Name_Id;
@@ -347,10 +334,6 @@ package Sem_Aux is
-- these types). This older routine overlaps with the previous one, this
-- should be cleaned up???
- function Is_Protected_Operation (E : Entity_Id) return Boolean;
- -- Given a subprogram or entry, determines whether E is a protected entry
- -- or subprogram.
-
function Is_Record_Or_Limited_Type (Typ : Entity_Id) return Boolean;
-- Return True if Typ requires is a record or limited type.
@@ -382,10 +365,6 @@ package Sem_Aux is
-- The result returned is the next _Tag field in this record, or Empty
-- if this is the last such field.
- function Number_Components (Typ : Entity_Id) return Nat;
- -- Typ is a record type, yields number of components (including
- -- discriminants) in type.
-
function Number_Discriminants (Typ : Entity_Id) return Pos;
-- Typ is a type with discriminants, yields number of discriminants in type
@@ -398,10 +377,6 @@ package Sem_Aux is
-- derived type, and the subtype is not an unconstrained array subtype
-- (RM 3.3(23.10/3)).
- function Package_Body (E : Entity_Id) return Node_Id;
- -- Given an entity for a package (spec or body), return the corresponding
- -- package body if any, or else Empty.
-
function Package_Spec (E : Entity_Id) return Node_Id;
-- Given an entity for a package spec, return the corresponding package
-- spec if any, or else Empty.
diff --git a/gcc/ada/sem_cat.adb b/gcc/ada/sem_cat.adb
index 7872c68..ee22113 100644
--- a/gcc/ada/sem_cat.adb
+++ b/gcc/ada/sem_cat.adb
@@ -1068,7 +1068,8 @@ package body Sem_Cat is
and then not Private_Present (P)
and then not Is_Remote_Call_Interface (E)
then
- Error_Msg_N ("public child of rci unit must also be rci unit", N);
+ Error_Msg_N
+ ("public child of 'R'C'I unit must also be 'R'C'I unit", N);
end if;
end if;
end Validate_Categorization_Dependency;
@@ -1580,21 +1581,21 @@ package body Sem_Cat is
if Comes_From_Source (E) then
if Is_Limited_Type (E) then
Error_Msg_N
- ("limited type not allowed in rci unit", Parent (E));
+ ("limited type not allowed in 'R'C'I unit", Parent (E));
Explain_Limited_Type (E, Parent (E));
elsif Ekind (E) in E_Generic_Function
| E_Generic_Package
| E_Generic_Procedure
then
- Error_Msg_N ("generic declaration not allowed in rci unit",
+ Error_Msg_N ("generic declaration not allowed in 'R'C'I unit",
Parent (E));
elsif (Ekind (E) = E_Function or else Ekind (E) = E_Procedure)
and then Has_Pragma_Inline (E)
then
Error_Msg_N
- ("inlined subprogram not allowed in rci unit", Parent (E));
+ ("inlined subprogram not allowed in 'R'C'I unit", Parent (E));
-- Inner packages that are renamings need not be checked. Generic
-- RCI packages are subject to the checks, but entities that come
diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb
index 0bad136..e5519bf 100644
--- a/gcc/ada/sem_ch10.adb
+++ b/gcc/ada/sem_ch10.adb
@@ -768,7 +768,7 @@ package body Sem_Ch10 is
Unum := Get_Cunit_Unit_Number (N);
Par_Spec_Name := Get_Parent_Spec_Name (Unit_Name (Unum));
- if Par_Spec_Name /= No_Unit_Name then
+ if Present (Par_Spec_Name) then
Unum :=
Load_Unit
(Load_Name => Par_Spec_Name,
@@ -828,6 +828,7 @@ package body Sem_Ch10 is
-- of the child unit does not act as spec any longer.
Set_Acts_As_Spec (N, False);
+ Move_Aspects (From => Unit_Node, To => Unit (Lib_Unit));
Set_Is_Child_Unit (Defining_Entity (Unit_Node));
Set_Debug_Info_Needed (Defining_Entity (Unit (Lib_Unit)));
Set_Comes_From_Source_Default (SCS);
@@ -6183,34 +6184,35 @@ package body Sem_Ch10 is
null;
when N_Subprogram_Declaration =>
- Error_Msg_N ("subprograms not allowed in limited with_clauses", N);
+ Error_Msg_N
+ ("subprogram not allowed in `LIMITED WITH` clause", N);
return;
when N_Generic_Package_Declaration
| N_Generic_Subprogram_Declaration
=>
- Error_Msg_N ("generics not allowed in limited with_clauses", N);
+ Error_Msg_N ("generic not allowed in `LIMITED WITH` clause", N);
return;
when N_Generic_Instantiation =>
Error_Msg_N
- ("generic instantiations not allowed in limited with_clauses",
+ ("generic instantiation not allowed in `LIMITED WITH` clause",
N);
return;
when N_Generic_Renaming_Declaration =>
Error_Msg_N
- ("generic renamings not allowed in limited with_clauses", N);
+ ("generic renaming not allowed in `LIMITED WITH` clause", N);
return;
when N_Subprogram_Renaming_Declaration =>
Error_Msg_N
- ("renamed subprograms not allowed in limited with_clauses", N);
+ ("renamed subprogram not allowed in `LIMITED WITH` clause", N);
return;
when N_Package_Renaming_Declaration =>
Error_Msg_N
- ("renamed packages not allowed in limited with_clauses", N);
+ ("renamed package not allowed in `LIMITED WITH` clause", N);
return;
when others =>
diff --git a/gcc/ada/sem_ch11.adb b/gcc/ada/sem_ch11.adb
index 940c93b..48c9855 100644
--- a/gcc/ada/sem_ch11.adb
+++ b/gcc/ada/sem_ch11.adb
@@ -127,7 +127,7 @@ package body Sem_Ch11 is
and then Comes_From_Source (Id)
then
Error_Msg_N
- ("(Ada 83): duplicate exception choice&", Id);
+ ("(Ada 83) duplicate exception choice&", Id);
end if;
end if;
end if;
diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb
index 06b3bec..7e6aa8f 100644
--- a/gcc/ada/sem_ch12.adb
+++ b/gcc/ada/sem_ch12.adb
@@ -1619,7 +1619,7 @@ package body Sem_Ch12 is
Others_Choice := Actual;
if Present (Next (Actual)) then
- Error_Msg_N ("others must be last association", Actual);
+ Error_Msg_N ("OTHERS must be last association", Actual);
end if;
-- This subprogram is used both for formal packages and for
@@ -1630,7 +1630,7 @@ package body Sem_Ch12 is
and then Comes_From_Source (I_Node)
then
Error_Msg_N
- ("others association not allowed in an instance",
+ ("OTHERS association not allowed in an instance",
Actual);
end if;
@@ -1998,7 +1998,7 @@ package body Sem_Ch12 is
Gen_Par : Entity_Id;
Needs_Freezing : Boolean;
- S : Entity_Id;
+ P : Node_Id;
procedure Check_Generic_Parent;
-- The actual may be an instantiation of a unit
@@ -2102,18 +2102,15 @@ package body Sem_Ch12 is
Needs_Freezing := True;
- S := Current_Scope;
- while Present (S) loop
- if Ekind (S) in E_Block
- | E_Function
- | E_Loop
- | E_Procedure
+ P := Parent (I_Node);
+ while Nkind (P) /= N_Compilation_Unit loop
+ if Nkind (P) = N_Handled_Sequence_Of_Statements
then
Needs_Freezing := False;
exit;
end if;
- S := Scope (S);
+ P := Parent (P);
end loop;
if Needs_Freezing then
@@ -4070,6 +4067,16 @@ package body Sem_Ch12 is
return True;
end if;
+ -- In GNATprove mode, never instantiate bodies outside of the main
+ -- unit, as it does not use frontend/backend inlining in the way that
+ -- GNAT does, so does not benefit from such instantiations. On the
+ -- contrary, such instantiations may bring artificial constraints,
+ -- as for example such bodies may require preprocessing.
+
+ if GNATprove_Mode then
+ return False;
+ end if;
+
-- If not, then again no need to instantiate bodies in generic units
if Is_Generic_Unit (Cunit_Entity (Get_Code_Unit (N))) then
@@ -4299,7 +4306,7 @@ package body Sem_Ch12 is
elsif Contains_Instance_Of (Gen_Unit, Current_Scope, Gen_Id) then
Error_Msg_Node_2 := Current_Scope;
Error_Msg_NE
- ("circular Instantiation: & instantiated in &!", N, Gen_Unit);
+ ("circular instantiation: & instantiated in &!", N, Gen_Unit);
Circularity_Detected := True;
Restore_Env;
goto Leave;
@@ -5675,7 +5682,7 @@ package body Sem_Ch12 is
if Contains_Instance_Of (Gen_Unit, Current_Scope, Gen_Id) then
Error_Msg_Node_2 := Current_Scope;
Error_Msg_NE
- ("circular Instantiation: & instantiated in &!", N, Gen_Unit);
+ ("circular instantiation: & instantiated in &!", N, Gen_Unit);
Circularity_Detected := True;
Restore_Hidden_Primitives (Vis_Prims_List);
goto Leave;
@@ -7793,7 +7800,7 @@ package body Sem_Ch12 is
if Node (Elmt) = Scop then
Error_Msg_Node_2 := Inner;
Error_Msg_NE
- ("circular Instantiation: & instantiated within &!",
+ ("circular instantiation: & instantiated within &!",
N, Scop);
return True;
@@ -7803,7 +7810,7 @@ package body Sem_Ch12 is
elsif Contains_Instance_Of (Node (Elmt), Scop, N) then
Error_Msg_Node_2 := Inner;
Error_Msg_NE
- ("circular Instantiation: & instantiated within &!",
+ ("circular instantiation: & instantiated within &!",
N, Node (Elmt));
return True;
end if;
@@ -8795,7 +8802,7 @@ package body Sem_Ch12 is
while not Is_List_Member (P1)
or else not Is_List_Member (P2)
- or else List_Containing (P1) /= List_Containing (P2)
+ or else not In_Same_List (P1, P2)
loop
P1 := True_Parent (P1);
P2 := True_Parent (P2);
@@ -9074,7 +9081,7 @@ package body Sem_Ch12 is
--
-- procedure P ... -- this body freezes Parent_Inst
--
- -- package Inst is new ...
+ -- procedure Inst is new ...
--
-- In this particular scenario, the freeze node for Inst must be
-- inserted in the same manner as that of Parent_Inst - before the
@@ -9085,9 +9092,8 @@ package body Sem_Ch12 is
-- after that of Parent_Inst. This relation is established by
-- comparing the Slocs of Parent_Inst freeze node and Inst.
- elsif List_Containing (Get_Unit_Instantiation_Node (Par)) =
- List_Containing (Inst_Node)
- and then Sloc (Freeze_Node (Par)) < Sloc (Inst_Node)
+ elsif In_Same_List (Get_Unit_Instantiation_Node (Par), Inst_Node)
+ and then Sloc (Freeze_Node (Par)) <= Sloc (Inst_Node)
then
Insert_Freeze_Node_For_Instance (Inst_Node, F_Node);
@@ -9928,7 +9934,7 @@ package body Sem_Ch12 is
if Parent (List_Containing (Get_Unit_Instantiation_Node (Par)))
= Parent (List_Containing (N))
- and then Sloc (Freeze_Node (Par)) < Sloc (N)
+ and then Sloc (Freeze_Node (Par)) <= Sloc (N)
then
Insert_Freeze_Node_For_Instance (N, F_Node);
else
@@ -9982,8 +9988,7 @@ package body Sem_Ch12 is
-- the enclosing package, insert the freeze node after
-- the body.
- elsif List_Containing (Freeze_Node (Par)) =
- List_Containing (Parent (N))
+ elsif In_Same_List (Freeze_Node (Par), Parent (N))
and then Sloc (Freeze_Node (Par)) < Sloc (Parent (N))
then
Insert_Freeze_Node_For_Instance
@@ -10796,6 +10801,16 @@ package body Sem_Ch12 is
Next_Non_Pragma (Formal_Node);
Next (Actual_Of_Formal);
+ -- A formal subprogram may be overloaded, so advance in
+ -- the list of actuals to make sure we do not match two
+ -- successive formals to the same actual. This is only
+ -- relevant for overloadable entities, others have
+ -- distinct names.
+
+ if Is_Overloadable (Actual_Ent) then
+ Next_Entity (Actual_Ent);
+ end if;
+
else
-- No further formals to match, but the generic part may
-- contain inherited operation that are not hidden in the
@@ -11552,7 +11567,7 @@ package body Sem_Ch12 is
-- Use default to construct declaration
if Present (Subt_Mark) then
- Def := New_Copy (Subt_Mark);
+ Def := New_Copy_Tree (Subt_Mark);
else
pragma Assert (Present (Acc_Def));
Def := New_Copy_Tree (Acc_Def);
@@ -12640,10 +12655,10 @@ package body Sem_Ch12 is
Analyzed_Formal : Node_Id;
Actual_Decls : List_Id) return List_Id
is
- A_Gen_T : constant Entity_Id :=
+ A_Gen_T : constant Entity_Id :=
Defining_Identifier (Analyzed_Formal);
- Def : constant Node_Id := Formal_Type_Definition (Formal);
- Gen_T : constant Entity_Id := Defining_Identifier (Formal);
+ Def : constant Node_Id := Formal_Type_Definition (Formal);
+ Gen_T : constant Entity_Id := Defining_Identifier (Formal);
Act_T : Entity_Id;
Ancestor : Entity_Id := Empty;
Decl_Node : Node_Id;
@@ -12921,10 +12936,10 @@ package body Sem_Ch12 is
elsif Ekind (A_Gen_T) = E_General_Access_Type
and then Ekind (Base_Type (Act_T)) /= E_General_Access_Type
then
- Error_Msg_N -- CODEFIX
+ Error_Msg_N
("actual must be general access type!", Actual);
Error_Msg_NE -- CODEFIX
- ("add ALL to }!", Actual, Act_T);
+ ("\add ALL to }!", Actual, Act_T);
Abandon_Instantiation (Actual);
end if;
end if;
@@ -12953,21 +12968,6 @@ package body Sem_Ch12 is
end if;
Abandon_Instantiation (Actual);
-
- elsif Is_Access_Type (Designated_Type (Act_T))
- and then Is_Constrained (Designated_Type (Designated_Type (Act_T)))
- /=
- Is_Constrained (Designated_Type (Desig_Type))
- then
- Error_Msg_NE
- ("designated type of actual does not match that of formal &",
- Actual, Gen_T);
-
- if not Predicates_Match (Desig_Type, Desig_Act) then
- Error_Msg_N ("\predicates do not match", Actual);
- end if;
-
- Abandon_Instantiation (Actual);
end if;
-- Ada 2005: null-exclusion indicators of the two types must agree
@@ -13230,7 +13230,7 @@ package body Sem_Ch12 is
else
Error_Msg_Name_1 := Chars (Act_T);
Error_Msg_NE
- ("Actual% must implement interface&",
+ ("actual% must implement interface&",
Actual, Etype (Iface));
end if;
@@ -15379,13 +15379,21 @@ package body Sem_Ch12 is
if Is_Type (E)
and then Nkind (Parent (E)) = N_Subtype_Declaration
then
+ -- Always preserve the flag Is_Generic_Actual_Type for GNATprove,
+ -- as it is needed to identify the subtype with the type it
+ -- renames, when there are conversions between access types
+ -- to these.
+
+ if GNATprove_Mode then
+ null;
+
-- If the actual for E is itself a generic actual type from
-- an enclosing instance, E is still a generic actual type
-- outside of the current instance. This matter when resolving
-- an overloaded call that may be ambiguous in the enclosing
-- instance, when two of its actuals coincide.
- if Is_Entity_Name (Subtype_Indication (Parent (E)))
+ elsif Is_Entity_Name (Subtype_Indication (Parent (E)))
and then Is_Generic_Actual_Type
(Entity (Subtype_Indication (Parent (E))))
then
diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb
index 7013094..4724e0e 100644
--- a/gcc/ada/sem_ch13.adb
+++ b/gcc/ada/sem_ch13.adb
@@ -54,7 +54,6 @@ 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_Disp; use Sem_Disp;
with Sem_Eval; use Sem_Eval;
with Sem_Prag; use Sem_Prag;
with Sem_Res; use Sem_Res;
@@ -65,6 +64,7 @@ with Sinfo; use Sinfo;
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;
@@ -252,6 +252,18 @@ package body Sem_Ch13 is
-- Resolve each one of the operations specified in the specification of
-- Aspect_Aggregate.
+ 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
+ -- (or Stable_Properties'Class) aspect.
+
+ procedure Resolve_Aspect_Stable_Properties
+ (Typ_Or_Subp : Entity_Id;
+ Expr : Node_Id;
+ Class_Present : Boolean);
+ -- Resolve each one of the functions specified in the specification of
+ -- aspect Stable_Properties (or Stable_Properties'Class).
+
procedure Resolve_Iterable_Operation
(N : Node_Id;
Cursor : Entity_Id;
@@ -1439,9 +1451,9 @@ package body Sem_Ch13 is
-- Aspect Full_Access_Only must be analyzed last so that
-- aspects Volatile and Atomic, if any, are analyzed.
- if A_Id /= Aspect_Export
- and then A_Id /= Aspect_Import
- and then A_Id /= Aspect_Full_Access_Only
+ if A_Id not in Aspect_Export
+ | Aspect_Full_Access_Only
+ | Aspect_Import
then
Make_Pragma_From_Boolean_Aspect (ASN);
end if;
@@ -2001,9 +2013,9 @@ package body Sem_Ch13 is
Error_Msg_N
("incompatible interfacing aspects given for &", E);
Error_Msg_Sloc := Sloc (Expo);
- Error_Msg_N ("\aspect `Export` #", E);
+ Error_Msg_N ("\aspect Export #", E);
Error_Msg_Sloc := Sloc (Imp);
- Error_Msg_N ("\aspect `Import` #", E);
+ Error_Msg_N ("\aspect Import #", E);
end if;
-- A variable is most likely modified from the outside. Take
@@ -2085,8 +2097,8 @@ package body Sem_Ch13 is
if A_Id = Aspect_External_Name then
if No (Expo) and then No (Imp) then
Error_Msg_N
- ("aspect `External_Name` requires aspect `Import` or "
- & "`Export`", Aspect);
+ ("aspect External_Name requires aspect Import or "
+ & "Export", Aspect);
end if;
-- Otherwise ensure that aspect Link_Name applies to aspect
@@ -2096,8 +2108,8 @@ package body Sem_Ch13 is
pragma Assert (A_Id = Aspect_Link_Name);
if No (Expo) and then No (Imp) then
Error_Msg_N
- ("aspect `Link_Name` requires aspect `Import` or "
- & "`Export`", Aspect);
+ ("aspect Link_Name requires aspect Import or Export",
+ Aspect);
end if;
end if;
end Analyze_Aspect_External_Link_Name;
@@ -2583,8 +2595,9 @@ package body Sem_Ch13 is
for Asp in Pre_Post_Aspects loop
if Has_Aspect (E, Asp) then
Error_Msg_N
- ("this aspect not allowed for static expression "
- & "functions", Find_Aspect (E, Asp));
+ ("this aspect is not allowed for a static "
+ & "expression function",
+ Find_Aspect (E, Asp));
return;
end if;
@@ -2648,7 +2661,7 @@ package body Sem_Ch13 is
elsif Within_Protected_Type (E) then
Error_Msg_N
- ("aspect% not applicable to protected operations", Id);
+ ("aspect% not applicable to protected operation", Id);
return;
else
@@ -2800,9 +2813,7 @@ package body Sem_Ch13 is
Ent := New_Occurrence_Of (E, Sloc (Id));
- if A_Id = Aspect_Attach_Handler
- or else A_Id = Aspect_Interrupt_Handler
- then
+ if A_Id in Aspect_Attach_Handler | Aspect_Interrupt_Handler then
-- Treat the specification as a reference to the protected
-- operation, which might otherwise appear unreferenced and
@@ -2846,10 +2857,10 @@ package body Sem_Ch13 is
-- Check some general restrictions on language defined aspects
if not Implementation_Defined_Aspect (A_Id)
- or else A_Id = Aspect_Async_Readers
- or else A_Id = Aspect_Async_Writers
- or else A_Id = Aspect_Effective_Reads
- or else A_Id = Aspect_Effective_Reads
+ or else A_Id in Aspect_Async_Readers
+ | Aspect_Async_Writers
+ | Aspect_Effective_Reads
+ | Aspect_Effective_Writes
then
Error_Msg_Name_1 := Nam;
@@ -2873,16 +2884,16 @@ package body Sem_Ch13 is
("aspect % not allowed for formal type declaration",
Aspect);
- elsif A_Id /= Aspect_Atomic
- and then A_Id /= Aspect_Volatile
- and then A_Id /= Aspect_Independent
- and then A_Id /= Aspect_Atomic_Components
- and then A_Id /= Aspect_Independent_Components
- and then A_Id /= Aspect_Volatile_Components
- and then A_Id /= Aspect_Async_Readers
- and then A_Id /= Aspect_Async_Writers
- and then A_Id /= Aspect_Effective_Reads
- and then A_Id /= Aspect_Effective_Reads
+ elsif A_Id not in Aspect_Atomic
+ | Aspect_Volatile
+ | Aspect_Independent
+ | Aspect_Atomic_Components
+ | Aspect_Independent_Components
+ | Aspect_Volatile_Components
+ | Aspect_Async_Readers
+ | Aspect_Async_Writers
+ | Aspect_Effective_Reads
+ | Aspect_Effective_Writes
then
Error_Msg_N
("aspect % not allowed for formal type declaration",
@@ -2938,11 +2949,11 @@ package body Sem_Ch13 is
-- an attribute reference whose prefix is Standard, for
-- example Standard'Maximum_Alignment or Standard'Word_Size.
- elsif (A_Id = Aspect_Alignment
- or else A_Id = Aspect_Component_Size
- or else A_Id = Aspect_Object_Size
- or else A_Id = Aspect_Size
- or else A_Id = Aspect_Value_Size)
+ elsif A_Id in Aspect_Alignment
+ | Aspect_Component_Size
+ | Aspect_Object_Size
+ | Aspect_Size
+ | Aspect_Value_Size
and then Present (Expr)
and then Nkind (Expr) = N_Attribute_Reference
and then Nkind (Prefix (Expr)) = N_Identifier
@@ -2958,6 +2969,18 @@ package body Sem_Ch13 is
end if;
end case;
+ if Delay_Required
+
+ and then A_Id = Aspect_Stable_Properties
+ -- ??? It seems like we should do this for all aspects, not
+ -- just Stable_Properties, but that causes as-yet-undiagnosed
+ -- regressions.
+
+ then
+ Set_Has_Delayed_Aspects (E);
+ Set_Is_Delayed_Aspect (Aspect);
+ end if;
+
-- Check 13.1(9.2/5): A representation aspect of a subtype or type
-- shall not be specified (whether by a representation item or an
-- aspect_specification) before the type is completely defined
@@ -3011,9 +3034,8 @@ package body Sem_Ch13 is
=>
-- Indexing aspects apply only to tagged type
- if (A_Id = Aspect_Constant_Indexing
- or else
- A_Id = Aspect_Variable_Indexing)
+ if A_Id in Aspect_Constant_Indexing
+ | Aspect_Variable_Indexing
and then not (Is_Type (E)
and then Is_Tagged_Type (E))
then
@@ -3040,10 +3062,10 @@ package body Sem_Ch13 is
-- illegal specification of this aspect for a subtype now,
-- to prevent malformed rep_item chains.
- if A_Id = Aspect_Input or else
- A_Id = Aspect_Output or else
- A_Id = Aspect_Read or else
- A_Id = Aspect_Write
+ if A_Id in Aspect_Input
+ | Aspect_Output
+ | Aspect_Read
+ | Aspect_Write
then
if not Is_First_Subtype (E) then
Error_Msg_N
@@ -3070,7 +3092,7 @@ package body Sem_Ch13 is
Aitem :=
Make_Attribute_Definition_Clause (Loc,
Name => Ent,
- Chars => Chars (Id),
+ Chars => Nam,
Expression => Relocate_Node (Expr));
-- If the address is specified, then we treat the entity as
@@ -3099,7 +3121,7 @@ package body Sem_Ch13 is
Expression => New_Occurrence_Of (E, Loc)),
Make_Pragma_Argument_Association (Sloc (Expr),
Expression => Relocate_Node (Expr))),
- Pragma_Name => Chars (Id));
+ Pragma_Name => Name_Linker_Section);
-- Linker_Section does not need delaying, as its argument
-- must be a static string. Furthermore, if applied to
@@ -3355,7 +3377,7 @@ package body Sem_Ch13 is
else
Error_Msg_N
- ("main subprogram CPU is out of range", Expr);
+ ("main subprogram 'C'P'U is out of range", Expr);
end if;
-- For the Priority aspect
@@ -3388,15 +3410,11 @@ package body Sem_Ch13 is
-- System.Tasking, but this package does not trigger the
-- required initialization of the run-time library.
- declare
- Discard : Entity_Id;
- begin
- if Restricted_Profile then
- Discard := RTE (RE_Activate_Restricted_Tasks);
- else
- Discard := RTE (RE_Activate_Tasks);
- end if;
- end;
+ if Restricted_Profile then
+ Discard_Node (RTE (RE_Activate_Restricted_Tasks));
+ else
+ Discard_Node (RTE (RE_Activate_Tasks));
+ end if;
-- Handling for these aspects in subprograms is complete
@@ -3409,7 +3427,7 @@ package body Sem_Ch13 is
Aitem :=
Make_Attribute_Definition_Clause (Loc,
Name => Ent,
- Chars => Chars (Id),
+ Chars => Nam,
Expression => Relocate_Node (Expr));
end if;
@@ -3424,7 +3442,7 @@ package body Sem_Ch13 is
Expression => Relocate_Node (Expr)),
Make_Pragma_Argument_Association (Sloc (Expr),
Expression => New_Occurrence_Of (E, Loc))),
- Pragma_Name => Chars (Id));
+ Pragma_Name => Nam);
Delay_Required := False;
@@ -3437,7 +3455,7 @@ package body Sem_Ch13 is
Expression => Relocate_Node (Expr)),
Make_Pragma_Argument_Association (Loc,
Expression => New_Occurrence_Of (E, Loc))),
- Pragma_Name => Chars (Id));
+ Pragma_Name => Name_Warnings);
Decorate (Aspect, Aitem);
Insert_Pragma (Aitem);
@@ -3586,11 +3604,17 @@ package body Sem_Ch13 is
-- wrapped inside of a procedure at the freeze point of the
-- private type's full view.
+ -- A type entity argument is appended to facilitate inheriting
+ -- the aspect from parent types (see Build_DIC_Procedure_Body),
+ -- though that extra argument isn't documented for the pragma.
+
when Aspect_Default_Initial_Condition =>
Aitem := Make_Aitem_Pragma
(Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Loc,
- Expression => Relocate_Node (Expr))),
+ Expression => Relocate_Node (Expr)),
+ Make_Pragma_Argument_Association (Sloc (Ent),
+ Expression => Ent)),
Pragma_Name =>
Name_Default_Initial_Condition);
@@ -3879,7 +3903,7 @@ package body Sem_Ch13 is
Aitem := Make_Aitem_Pragma
(Pragma_Argument_Associations => Args,
- Pragma_Name => Chars (Id));
+ Pragma_Name => Name_Obsolescent);
end;
-- Part_Of
@@ -4123,7 +4147,8 @@ package body Sem_Ch13 is
-- Must not be parenthesized
if Paren_Count (Expr) /= 0 then
- Error_Msg_F ("extra parentheses ignored", Expr);
+ Error_Msg -- CODEFIX
+ ("redundant parentheses", First_Sloc (Expr));
end if;
-- List of arguments is list of aggregate expressions
@@ -4165,7 +4190,7 @@ package body Sem_Ch13 is
-- pragmas/attributes but do require delayed analysis.
when Aspect_Default_Value | Aspect_Default_Component_Value =>
- Error_Msg_Name_1 := Chars (Id);
+ Error_Msg_Name_1 := Nam;
if not Is_Type (E) then
Error_Msg_N ("aspect% can only apply to a type", Id);
@@ -4178,14 +4203,14 @@ package body Sem_Ch13 is
elsif A_Id = Aspect_Default_Value
and then not Is_Scalar_Type (E)
then
- Error_Msg_N ("aspect% can only be applied to scalar type",
- Id);
+ Error_Msg_N
+ ("aspect% can only be applied to scalar type", Id);
goto Continue;
elsif A_Id = Aspect_Default_Component_Value then
if not Is_Array_Type (E) then
- Error_Msg_N ("aspect% can only be applied to array " &
- "type", Id);
+ Error_Msg_N
+ ("aspect% can only be applied to array type", Id);
goto Continue;
elsif not Is_Scalar_Type (Component_Type (E)) then
@@ -4201,6 +4226,12 @@ package body Sem_Ch13 is
Record_Rep_Item (E, Aspect);
goto Continue;
+ when Aspect_Stable_Properties =>
+ Validate_Aspect_Stable_Properties
+ (E, Expr, Class_Present => Class_Present (Aspect));
+ Record_Rep_Item (E, Aspect);
+ goto Continue;
+
when Aspect_Integer_Literal
| Aspect_Real_Literal
| Aspect_String_Literal
@@ -4262,7 +4293,7 @@ package body Sem_Ch13 is
Pname : Name_Id;
begin
- if A_Id = Aspect_Pre or else A_Id = Aspect_Precondition then
+ if A_Id in Aspect_Pre | Aspect_Precondition then
Pname := Name_Precondition;
else
Pname := Name_Postcondition;
@@ -4394,14 +4425,25 @@ package body Sem_Ch13 is
if Nkind (Parent (N)) = N_Compilation_Unit then
Error_Msg_Name_1 := Nam;
- Error_Msg_N ("incorrect placement of aspect `%`", E);
+ Error_Msg_N ("incorrect placement of aspect %", E);
goto Continue;
end if;
- if Nkind (Expr) /= N_Aggregate then
+ if Nkind (Expr) /= N_Aggregate
+ or else Null_Record_Present (Expr)
+ then
Error_Msg_Name_1 := Nam;
Error_Msg_NE
- ("wrong syntax for aspect `%` for &", Id, E);
+ ("wrong syntax for aspect % for &", Id, E);
+ goto Continue;
+ end if;
+
+ -- Check that the expression is a proper aggregate (no
+ -- parentheses).
+
+ if Paren_Count (Expr) /= 0 then
+ Error_Msg -- CODEFIX
+ ("redundant parentheses", First_Sloc (Expr));
goto Continue;
end if;
@@ -4424,7 +4466,7 @@ package body Sem_Ch13 is
then
Error_Msg_Name_1 := Nam;
Error_Msg_NE
- ("wrong syntax for aspect `%` for &", Id, E);
+ ("wrong syntax for aspect % for &", Id, E);
goto Continue;
end if;
@@ -4440,7 +4482,7 @@ package body Sem_Ch13 is
Aitem := Make_Aitem_Pragma
(Pragma_Argument_Associations => Args,
- Pragma_Name => Nam);
+ Pragma_Name => Name_Test_Case);
end Test_Case;
-- Contract_Cases
@@ -4450,7 +4492,7 @@ package body Sem_Ch13 is
(Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Loc,
Expression => Relocate_Node (Expr))),
- Pragma_Name => Nam);
+ Pragma_Name => Name_Contract_Cases);
Decorate (Aspect, Aitem);
Insert_Pragma (Aitem);
@@ -4463,7 +4505,7 @@ package body Sem_Ch13 is
(Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Loc,
Expression => Relocate_Node (Expr))),
- Pragma_Name => Nam);
+ Pragma_Name => Name_Subprogram_Variant);
Decorate (Aspect, Aitem);
Insert_Pragma (Aitem);
@@ -4509,7 +4551,7 @@ package body Sem_Ch13 is
goto Continue;
- elsif A_Id = Aspect_Export or else A_Id = Aspect_Import then
+ elsif A_Id in Aspect_Export | Aspect_Import then
Analyze_Aspect_Export_Import;
-- Disable_Controlled
@@ -4581,14 +4623,12 @@ package body Sem_Ch13 is
-- Exclude aspects Export and Import because their pragma
-- syntax does not map directly to a Boolean aspect.
- if A_Id /= Aspect_Export
- and then A_Id /= Aspect_Import
- then
+ if A_Id not in Aspect_Export | Aspect_Import then
Aitem := Make_Aitem_Pragma
(Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Sloc (Ent),
Expression => Ent)),
- Pragma_Name => Chars (Id));
+ Pragma_Name => Nam);
end if;
-- In general cases, the corresponding pragma/attribute
@@ -4651,7 +4691,7 @@ package body Sem_Ch13 is
Aitem :=
Make_Attribute_Definition_Clause (Loc,
Name => Ent,
- Chars => Chars (Id),
+ Chars => Name_Storage_Size,
Expression => Relocate_Node (Expr));
end if;
end case;
@@ -4698,7 +4738,7 @@ package body Sem_Ch13 is
(Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Sloc (Ent),
Expression => Ent)),
- Pragma_Name => Chars (Id));
+ Pragma_Name => Nam);
Set_From_Aspect_Specification (Aitem, True);
Set_Corresponding_Aspect (Aitem, Aspect);
@@ -6589,7 +6629,7 @@ package body Sem_Ch13 is
-- come from an aspect specification.
if not Is_Task_Type (U_Ent) then
- Error_Msg_N ("CPU can only be defined for task", Nam);
+ Error_Msg_N ("'C'P'U can only be defined for task", Nam);
elsif Duplicate_Clause then
null;
@@ -6680,7 +6720,7 @@ package body Sem_Ch13 is
else
Error_Msg_NE
- ("Default Iterator must be a primitive of&", Func, U_Ent);
+ ("Default_Iterator must be a primitive of&", Func, U_Ent);
end if;
end Default_Iterator;
@@ -7734,7 +7774,7 @@ package body Sem_Ch13 is
| N_Implicit_Label_Declaration
then
Error_Msg_N
- ("this declaration not allowed in machine code subprogram",
+ ("this declaration is not allowed in machine code subprogram",
DeclO);
end if;
@@ -7933,7 +7973,7 @@ package body Sem_Ch13 is
end if;
if Nkind (Choice) = N_Others_Choice then
- Error_Msg_N ("others choice not allowed here", Choice);
+ Error_Msg_N ("OTHERS choice not allowed here", Choice);
Err := True;
elsif Nkind (Choice) = N_Range then
@@ -9111,7 +9151,7 @@ package body Sem_Ch13 is
or else Etype (Expression (Expr)) /= Typ
then
Error_Msg_N
- ("expression must denaote subtype", Expression (Expr));
+ ("expression must denote subtype", Expression (Expr));
return False_Range;
end if;
@@ -10495,12 +10535,14 @@ package body Sem_Ch13 is
-- Expression from call to Check_Aspect_At_Freeze_Point.
T : constant Entity_Id :=
- (if Present (Freeze_Expr)
+ (if Present (Freeze_Expr) and (A_Id /= Aspect_Stable_Properties)
then Etype (Original_Node (Freeze_Expr))
else Empty);
-- Type required for preanalyze call. We use the original expression to
-- get the proper type, to prevent cascaded errors when the expression
- -- is constant-folded.
+ -- is constant-folded. For Stable_Properties, the aspect value is
+ -- not semantically an expression (although it is syntactically);
+ -- in particular, it has no type.
Err : Boolean;
-- Set False if error
@@ -10578,22 +10620,22 @@ package body Sem_Ch13 is
-- name, so we need to verify that one of these interpretations is
-- the one available at at the freeze point.
- elsif A_Id = Aspect_Input or else
- A_Id = Aspect_Output or else
- A_Id = Aspect_Read or else
- A_Id = Aspect_Write or else
- A_Id = Aspect_Put_Image
+ elsif A_Id in Aspect_Input
+ | Aspect_Output
+ | Aspect_Read
+ | Aspect_Write
+ | Aspect_Put_Image
then
Analyze (End_Decl_Expr);
Check_Overloaded_Name;
- elsif A_Id = Aspect_Variable_Indexing or else
- A_Id = Aspect_Constant_Indexing or else
- A_Id = Aspect_Default_Iterator or else
- A_Id = Aspect_Iterator_Element or else
- A_Id = Aspect_Integer_Literal or else
- A_Id = Aspect_Real_Literal or else
- A_Id = Aspect_String_Literal
+ elsif A_Id in Aspect_Variable_Indexing
+ | Aspect_Constant_Indexing
+ | Aspect_Default_Iterator
+ | Aspect_Iterator_Element
+ | Aspect_Integer_Literal
+ | Aspect_Real_Literal
+ | Aspect_String_Literal
then
-- Make type unfrozen before analysis, to prevent spurious errors
-- about late attributes.
@@ -10619,9 +10661,7 @@ 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 = Aspect_Dynamic_Predicate
- or else A_Id = Aspect_Predicate
- then
+ if A_Id in Aspect_Dynamic_Predicate | Aspect_Predicate then
Push_Type (Ent);
Preanalyze_Spec_Expression (Freeze_Expr, Standard_Boolean);
Pop_Type (Ent);
@@ -10647,9 +10687,9 @@ package body Sem_Ch13 is
-- visible for aspects that may reference them.
if Present (Freeze_Expr) and then No (T) then
- if A_Id = Aspect_Dynamic_Predicate
- or else A_Id = Aspect_Predicate
- or else A_Id = Aspect_Priority
+ if A_Id in Aspect_Dynamic_Predicate
+ | Aspect_Predicate
+ | Aspect_Priority
then
Push_Type (Ent);
Check_Aspect_At_Freeze_Point (ASN);
@@ -10665,9 +10705,7 @@ package body Sem_Ch13 is
-- partial view is visible. The expression must be scalar, so use
-- the full view to resolve.
- elsif (A_Id = Aspect_Default_Value
- or else
- A_Id = Aspect_Default_Component_Value)
+ elsif A_Id in Aspect_Default_Component_Value | Aspect_Default_Value
and then Is_Private_Type (T)
then
Preanalyze_Spec_Expression (End_Decl_Expr, Full_View (T));
@@ -10675,10 +10713,10 @@ package body Sem_Ch13 is
-- The following aspect expressions may contain references to
-- components and discriminants of the type.
- elsif A_Id = Aspect_Dynamic_Predicate
- or else A_Id = Aspect_Predicate
- or else A_Id = Aspect_Priority
- or else A_Id = Aspect_CPU
+ elsif A_Id in Aspect_CPU
+ | Aspect_Dynamic_Predicate
+ | Aspect_Predicate
+ | Aspect_Priority
then
Push_Type (Ent);
Preanalyze_Spec_Expression (End_Decl_Expr, T);
@@ -10911,7 +10949,13 @@ package body Sem_Ch13 is
return;
when Aspect_Aggregate =>
- Resolve_Aspect_Aggregate (Entity (ASN), Expr);
+ Resolve_Aspect_Aggregate (Entity (ASN), Expression (ASN));
+ return;
+
+ when Aspect_Stable_Properties =>
+ Resolve_Aspect_Stable_Properties
+ (Entity (ASN), Expression (ASN),
+ Class_Present => Class_Present (ASN));
return;
-- Invariant/Predicate take boolean expressions
@@ -11129,9 +11173,7 @@ package body Sem_Ch13 is
-- Otherwise look at the identifier and see if it is OK
- if Ekind (Ent) in E_Named_Integer | E_Named_Real
- or else Is_Type (Ent)
- then
+ if Is_Named_Number (Ent) or else Is_Type (Ent) then
return;
elsif Ekind (Ent) in E_Constant | E_In_Parameter then
@@ -12700,7 +12742,6 @@ package body Sem_Ch13 is
and then Scope (E) = Current_Scope
then
declare
- A_Id : Aspect_Id;
Ritem : Node_Id;
begin
@@ -12712,12 +12753,10 @@ package body Sem_Ch13 is
and then Entity (Ritem) = E
and then Is_Delayed_Aspect (Ritem)
then
- A_Id := Get_Aspect_Id (Ritem);
-
- if A_Id = Aspect_Dynamic_Predicate
- or else A_Id = Aspect_Predicate
- or else A_Id = Aspect_Priority
- or else A_Id = Aspect_CPU
+ if Get_Aspect_Id (Ritem) in Aspect_CPU
+ | Aspect_Dynamic_Predicate
+ | Aspect_Predicate
+ | Aspect_Priority
then
-- Retrieve the visibility to components and discriminants
-- in order to properly analyze the aspects.
@@ -13463,31 +13502,23 @@ package body Sem_Ch13 is
function Is_Operational_Item (N : Node_Id) return Boolean is
begin
- if Nkind (N) /= N_Attribute_Definition_Clause then
- return False;
-
- else
- declare
- Id : constant Attribute_Id := Get_Attribute_Id (Chars (N));
- begin
-
- -- List of operational items is given in AARM 13.1(8.mm/1).
- -- It is clearly incomplete, as it does not include iterator
- -- aspects, among others.
-
- return Id = Attribute_Constant_Indexing
- or else Id = Attribute_Default_Iterator
- or else Id = Attribute_Implicit_Dereference
- or else Id = Attribute_Input
- or else Id = Attribute_Iterator_Element
- or else Id = Attribute_Iterable
- or else Id = Attribute_Output
- or else Id = Attribute_Read
- or else Id = Attribute_Variable_Indexing
- or else Id = Attribute_Write
- or else Id = Attribute_External_Tag;
- end;
- end if;
+ -- List of operational items is given in AARM 13.1(8.mm/1). It is
+ -- clearly incomplete, as it does not include iterator aspects, among
+ -- others.
+
+ return Nkind (N) = N_Attribute_Definition_Clause
+ and then
+ Get_Attribute_Id (Chars (N)) in Attribute_Constant_Indexing
+ | Attribute_External_Tag
+ | Attribute_Default_Iterator
+ | Attribute_Implicit_Dereference
+ | Attribute_Input
+ | Attribute_Iterable
+ | Attribute_Iterator_Element
+ | Attribute_Output
+ | Attribute_Read
+ | Attribute_Variable_Indexing
+ | Attribute_Write;
end Is_Operational_Item;
-------------------------
@@ -13695,17 +13726,13 @@ package body Sem_Ch13 is
begin
case Nkind (N) is
when N_Attribute_Definition_Clause =>
- declare
- Id : constant Attribute_Id := Get_Attribute_Id (Chars (N));
- -- See AARM 13.1(8.f-8.x) list items that end in "clause"
- -- ???: include any GNAT-defined attributes here?
- begin
- return Id = Attribute_Component_Size
- or else Id = Attribute_Bit_Order
- or else Id = Attribute_Storage_Pool
- or else Id = Attribute_Stream_Size
- or else Id = Attribute_Machine_Radix;
- end;
+ -- See AARM 13.1(8.f-8.x) list items that end in "clause"
+ -- ???: include any GNAT-defined attributes here?
+ return Get_Attribute_Id (Chars (N)) in Attribute_Bit_Order
+ | Attribute_Component_Size
+ | Attribute_Machine_Radix
+ | Attribute_Storage_Pool
+ | Attribute_Stream_Size;
when N_Pragma =>
case Get_Pragma_Id (N) is
@@ -14920,6 +14947,10 @@ package body Sem_Ch13 is
when Aspect_Aggregate =>
Resolve_Aspect_Aggregate (Entity (ASN), Expr);
+ when Aspect_Stable_Properties =>
+ Resolve_Aspect_Stable_Properties
+ (Entity (ASN), Expr, Class_Present (ASN));
+
-- 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).
@@ -15058,6 +15089,72 @@ package body Sem_Ch13 is
end loop;
end Parse_Aspect_Aggregate;
+ ------------------------------------
+ -- Parse_Aspect_Stable_Properties --
+ ------------------------------------
+
+ function Parse_Aspect_Stable_Properties
+ (Aspect_Spec : Node_Id; Negated : out Boolean) return Subprogram_List
+ is
+ function Extract_Entity (Expr : Node_Id) return Entity_Id;
+ -- Given an element of a Stable_Properties aspect spec, return the
+ -- associated entity.
+ -- This function updates the Negated flag as a side-effect.
+
+ --------------------
+ -- Extract_Entity --
+ --------------------
+
+ function Extract_Entity (Expr : Node_Id) return Entity_Id is
+ Name : Node_Id;
+ begin
+ if Nkind (Expr) = N_Op_Not then
+ Negated := True;
+ Name := Right_Opnd (Expr);
+ else
+ Name := Expr;
+ end if;
+
+ if Nkind (Name) in N_Has_Entity then
+ return Entity (Name);
+ else
+ return Empty;
+ end if;
+ end Extract_Entity;
+
+ -- Local variables
+
+ L : List_Id;
+ Id : Node_Id;
+
+ -- Start of processing for Parse_Aspect_Stable_Properties
+
+ begin
+ Negated := False;
+
+ if Nkind (Aspect_Spec) /= N_Aggregate then
+ return (1 => Extract_Entity (Aspect_Spec));
+ else
+ L := Expressions (Aspect_Spec);
+ Id := First (L);
+
+ return Result : Subprogram_List (1 .. List_Length (L)) do
+ for I in Result'Range loop
+ Result (I) := Extract_Entity (Id);
+
+ if No (Result (I)) then
+ pragma Assert (Serious_Errors_Detected > 0);
+ goto Ignore_Aspect;
+ end if;
+
+ Next (Id);
+ end loop;
+ end return;
+ end if;
+
+ <<Ignore_Aspect>> return (1 .. 0 => <>);
+ end Parse_Aspect_Stable_Properties;
+
-------------------------------
-- Validate_Aspect_Aggregate --
-------------------------------
@@ -15070,14 +15167,13 @@ package body Sem_Ch13 is
Assign_Indexed_Subp : Node_Id := Empty;
begin
- if Ada_Version < Ada_2020 then
- Error_Msg_N ("Aspect Aggregate is an Ada_2020 feature", N);
+ Error_Msg_Ada_2020_Feature ("aspect Aggregate", Sloc (N));
- elsif Nkind (N) /= N_Aggregate
+ if Nkind (N) /= N_Aggregate
or else Present (Expressions (N))
or else No (Component_Associations (N))
then
- Error_Msg_N ("Aspect Aggregate requires an aggregate "
+ Error_Msg_N ("aspect Aggregate requires an aggregate "
& "with component associations", N);
return;
end if;
@@ -15104,6 +15200,136 @@ package body Sem_Ch13 is
end if;
end Validate_Aspect_Aggregate;
+ -------------------------------
+ -- Validate_Aspect_Stable_Properties --
+ -------------------------------
+
+ procedure Validate_Aspect_Stable_Properties
+ (E : Entity_Id; N : Node_Id; Class_Present : Boolean)
+ is
+ Is_Aspect_Of_Type : constant Boolean := Is_Type (E);
+
+ type Permission is (Forbidden, Optional, Required);
+ Modifier_Permission : Permission :=
+ (if Is_Aspect_Of_Type then Forbidden else Optional);
+ Modifier_Error_Called : Boolean := False;
+
+ procedure Check_Property_Function_Arg (PF_Arg : Node_Id);
+ -- Check syntax of a property function argument
+
+ ----------------------------------
+ -- Check_Property_Function_Arg --
+ ----------------------------------
+
+ procedure Check_Property_Function_Arg (PF_Arg : Node_Id) is
+ procedure Modifier_Error;
+ -- Generate message about bad "not" modifier if no message already
+ -- generated. Errors include specifying "not" for an aspect of
+ -- of a type and specifying "not" for some but not all of the
+ -- names in a list.
+
+ --------------------
+ -- Modifier_Error --
+ --------------------
+
+ procedure Modifier_Error is
+ begin
+ if Modifier_Error_Called then
+ return; -- error message already generated
+ end if;
+
+ Modifier_Error_Called := True;
+
+ if Is_Aspect_Of_Type then
+ Error_Msg_N
+ ("NOT modifier not allowed for Stable_Properties aspect"
+ & " of a type", PF_Arg);
+ else
+ Error_Msg_N ("mixed use of NOT modifiers", PF_Arg);
+ end if;
+ end Modifier_Error;
+
+ PF_Name : Node_Id := PF_Arg;
+
+ -- Start of processing for Check_Property_Function_Arg
+
+ begin
+ if Nkind (PF_Arg) = N_Op_Not then
+ PF_Name := Right_Opnd (PF_Arg);
+
+ case Modifier_Permission is
+ when Forbidden =>
+ Modifier_Error;
+ when Optional =>
+ Modifier_Permission := Required;
+ when Required =>
+ null;
+ end case;
+ else
+ case Modifier_Permission is
+ when Forbidden =>
+ null;
+ when Optional =>
+ Modifier_Permission := Forbidden;
+ when Required =>
+ Modifier_Error;
+ end case;
+ end if;
+
+ if Nkind (PF_Name) not in
+ N_Identifier | N_Operator_Symbol | N_Selected_Component
+ then
+ Error_Msg_N ("bad property function name", PF_Name);
+ end if;
+ end Check_Property_Function_Arg;
+
+ -- Start of processing for Validate_Aspect_Stable_Properties
+
+ begin
+ Error_Msg_Ada_2020_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 "
+ & "a type or a subprogram", N);
+ elsif Class_Present then
+ if Is_Aspect_Of_Type then
+ if not Is_Tagged_Type (E) then
+ Error_Msg_N
+ ("Stable_Properties''Class aspect cannot be specified for "
+ & "an untagged type", N);
+ end if;
+ else
+ if not Is_Dispatching_Operation (E) then
+ Error_Msg_N
+ ("Stable_Properties''Class aspect cannot be specified for "
+ & "a subprogram that is not a primitive subprogram "
+ & "of a tagged type", N);
+ end if;
+ end if;
+ end if;
+
+ if Nkind (N) = N_Aggregate then
+ if Present (Component_Associations (N))
+ or else Null_Record_Present (N)
+ or else not Present (Expressions (N))
+ then
+ Error_Msg_N ("bad Stable_Properties aspect specification", N);
+ return;
+ end if;
+
+ declare
+ PF_Arg : Node_Id := First (Expressions (N));
+ begin
+ while Present (PF_Arg) loop
+ Check_Property_Function_Arg (PF_Arg);
+ Next (PF_Arg);
+ end loop;
+ end;
+ else
+ Check_Property_Function_Arg (N);
+ end if;
+ end Validate_Aspect_Stable_Properties;
+
--------------------------------
-- Resolve_Iterable_Operation --
--------------------------------
@@ -15135,12 +15361,12 @@ package body Sem_Ch13 is
Ent := Entity (N);
F1 := First_Formal (Ent);
- if Nam = Name_First or else Nam = Name_Last then
+ if Nam in Name_First | Name_Last then
-- First or Last (Container) => Cursor
if Etype (Ent) /= Cursor then
- Error_Msg_N ("primitive for First must yield a curosr", N);
+ Error_Msg_N ("primitive for First must yield a cursor", N);
end if;
elsif Nam = Name_Next then
@@ -15463,6 +15689,224 @@ package body Sem_Ch13 is
end loop;
end Resolve_Aspect_Aggregate;
+ --------------------------------------
+ -- Resolve_Aspect_Stable_Properties --
+ --------------------------------------
+
+ procedure Resolve_Aspect_Stable_Properties
+ (Typ_Or_Subp : Entity_Id; Expr : Node_Id; Class_Present : Boolean)
+ is
+ Is_Aspect_Of_Type : constant Boolean := Is_Type (Typ_Or_Subp);
+
+ Singleton : constant Boolean := Nkind (Expr) /= N_Aggregate;
+ Subp_Name : Node_Id := (if Singleton
+ then Expr
+ else First (Expressions (Expr)));
+ Has_Not : Boolean;
+ begin
+ if Is_Aspect_Of_Type
+ and then Has_Private_Declaration (Typ_Or_Subp)
+ and then not Is_Private_Type (Typ_Or_Subp)
+ then
+ Error_Msg_N
+ ("Stable_Properties aspect cannot be specified " &
+ "for the completion of a private type", Typ_Or_Subp);
+ end if;
+
+ -- Analogous checks that the aspect is not specified for a completion
+ -- in the subprogram case are not performed here because they are not
+ -- specific to this particular aspect. Right ???
+
+ loop
+ Has_Not := Nkind (Subp_Name) = N_Op_Not;
+ if Has_Not then
+ Set_Analyzed (Subp_Name); -- ???
+ Subp_Name := Right_Opnd (Subp_Name);
+ end if;
+
+ if No (Etype (Subp_Name)) then
+ Analyze (Subp_Name);
+ end if;
+
+ declare
+ Subp : Entity_Id := Empty;
+
+ I : Interp_Index;
+ It : Interp;
+
+ function Is_Property_Function (E : Entity_Id) return Boolean;
+ -- Implements RM 7.3.4 definition of "property function".
+
+ function Is_Property_Function (E : Entity_Id) return Boolean is
+ begin
+ if Ekind (E) not in E_Function | E_Operator
+ or else Number_Formals (E) /= 1
+ then
+ return False;
+ end if;
+
+ declare
+ Param_Type : constant Entity_Id :=
+ Base_Type (Etype (First_Formal (E)));
+
+ function Matches_Param_Type (Typ : Entity_Id)
+ return Boolean is
+ ((Base_Type (Typ) = Param_Type)
+ or else
+ (Is_Class_Wide_Type (Param_Type)
+ and then Is_Ancestor (Root_Type (Param_Type),
+ Base_Type (Typ))));
+ begin
+ if Is_Aspect_Of_Type then
+ if Matches_Param_Type (Typ_Or_Subp) then
+ return True;
+ end if;
+ elsif Is_Primitive (Typ_Or_Subp) then
+ declare
+ Formal : Entity_Id := First_Formal (Typ_Or_Subp);
+ begin
+ while Present (Formal) loop
+ if Matches_Param_Type (Etype (Formal)) then
+
+ -- Test whether Typ_Or_Subp (which is a subp
+ -- in this case) is primitive op of the type
+ -- of this parameter.
+ if Scope (Typ_Or_Subp) = Scope (Param_Type) then
+ return True;
+ end if;
+ end if;
+ Next_Formal (Formal);
+ end loop;
+ end;
+ end if;
+ end;
+
+ return False;
+ end Is_Property_Function;
+ begin
+ if not Is_Overloaded (Subp_Name) then
+ Subp := Entity (Subp_Name);
+ if not Is_Property_Function (Subp) then
+ Error_Msg_NE ("improper property function for&",
+ Subp_Name, Typ_Or_Subp);
+ return;
+ end if;
+ else
+ Set_Entity (Subp_Name, Empty);
+ Get_First_Interp (Subp_Name, I, It);
+ while Present (It.Nam) loop
+ if Is_Property_Function (It.Nam) then
+ if Present (Subp) then
+ Error_Msg_NE
+ ("ambiguous property function name for&",
+ Subp_Name, Typ_Or_Subp);
+ return;
+ end if;
+
+ Subp := It.Nam;
+ Set_Is_Overloaded (Subp_Name, False);
+ Set_Entity (Subp_Name, Subp);
+ end if;
+
+ Get_Next_Interp (I, It);
+ end loop;
+
+ if No (Subp) then
+ Error_Msg_NE ("improper property function for&",
+ Subp_Name, Typ_Or_Subp);
+ return;
+ end if;
+ end if;
+
+ -- perform legality (as opposed to name resolution) Subp checks
+
+ if Is_Limited_Type (Etype (Subp)) then
+ Error_Msg_NE
+ ("result type of property function for& is limited",
+ Subp_Name, Typ_Or_Subp);
+ end if;
+
+ if Ekind (First_Formal (Subp)) /= E_In_Parameter then
+ Error_Msg_NE
+ ("mode of parameter of property function for& is not IN",
+ Subp_Name, Typ_Or_Subp);
+ end if;
+
+ if Is_Class_Wide_Type (Etype (First_Formal (Subp))) then
+ if not Covers (Etype (First_Formal (Subp)), Typ_Or_Subp) then
+ Error_Msg_NE
+ ("class-wide parameter type of property function " &
+ "for& does not cover the type",
+ Subp_Name, Typ_Or_Subp);
+
+ -- ??? This test is slightly stricter than 7.3.4(12/5);
+ -- some legal corner cases may be incorrectly rejected.
+ elsif Scope (Subp) /= Scope (Etype (First_Formal (Subp)))
+ then
+ Error_Msg_NE
+ ("property function for& not declared in same scope " &
+ "as parameter type",
+ Subp_Name, Typ_Or_Subp);
+ end if;
+ elsif Is_Aspect_Of_Type and then
+ Scope (Subp) /= Scope (Typ_Or_Subp) and then
+ Scope (Subp) /= Standard_Standard -- e.g., derived type's "abs"
+ then
+ Error_Msg_NE
+ ("property function for& " &
+ "not a primitive function of the type",
+ Subp_Name, Typ_Or_Subp);
+ end if;
+
+ if Has_Not then
+ -- check that Subp was mentioned in param type's aspect spec
+ declare
+ Param_Type : constant Entity_Id :=
+ Base_Type (Etype (First_Formal (Subp)));
+ Aspect_Spec : constant Node_Id :=
+ Find_Value_Of_Aspect
+ (Param_Type, Aspect_Stable_Properties,
+ Class_Present => Class_Present);
+ Found : Boolean := False;
+ begin
+ if Present (Aspect_Spec) then
+ declare
+ Ignored : Boolean;
+ SPF_List : constant Subprogram_List :=
+ Parse_Aspect_Stable_Properties
+ (Aspect_Spec, Negated => Ignored);
+ begin
+ Found := (for some E of SPF_List => E = Subp);
+ -- look through renamings ???
+ end;
+ end if;
+ if not Found then
+ declare
+ CW_Modifier : constant String :=
+ (if Class_Present then "class-wide " else "");
+ begin
+ Error_Msg_NE
+ (CW_Modifier
+ & "property function for& mentioned after NOT "
+ & "but not a "
+ & CW_Modifier
+ & "stable property function of its parameter type",
+ Subp_Name, Typ_Or_Subp);
+ end;
+ end if;
+ end;
+ end if;
+ end;
+
+ exit when Singleton;
+ Subp_Name :=
+ Next ((if Has_Not then Parent (Subp_Name) else Subp_Name));
+ exit when No (Subp_Name);
+ end loop;
+
+ Set_Analyzed (Expr);
+ end Resolve_Aspect_Stable_Properties;
+
----------------
-- Set_Biased --
----------------
@@ -15781,303 +16225,6 @@ package body Sem_Ch13 is
end loop;
end Validate_Address_Clauses;
- ---------------------------
- -- Validate_Independence --
- ---------------------------
-
- procedure Validate_Independence is
- SU : constant Uint := UI_From_Int (System_Storage_Unit);
- N : Node_Id;
- E : Entity_Id;
- IC : Boolean;
- Comp : Entity_Id;
- Addr : Node_Id;
- P : Node_Id;
-
- procedure Check_Array_Type (Atyp : Entity_Id);
- -- Checks if the array type Atyp has independent components, and
- -- if not, outputs an appropriate set of error messages.
-
- procedure No_Independence;
- -- Output message that independence cannot be guaranteed
-
- function OK_Component (C : Entity_Id) return Boolean;
- -- Checks one component to see if it is independently accessible, and
- -- if so yields True, otherwise yields False if independent access
- -- cannot be guaranteed. This is a conservative routine, it only
- -- returns True if it knows for sure, it returns False if it knows
- -- there is a problem, or it cannot be sure there is no problem.
-
- procedure Reason_Bad_Component (C : Entity_Id);
- -- Outputs continuation message if a reason can be determined for
- -- the component C being bad.
-
- ----------------------
- -- Check_Array_Type --
- ----------------------
-
- procedure Check_Array_Type (Atyp : Entity_Id) is
- Ctyp : constant Entity_Id := Component_Type (Atyp);
-
- begin
- -- OK if no alignment clause, no pack, and no component size
-
- if not Has_Component_Size_Clause (Atyp)
- and then not Has_Alignment_Clause (Atyp)
- and then not Is_Packed (Atyp)
- then
- return;
- end if;
-
- -- Case where component size is greater than or equal to the maximum
- -- integer size and the alignment of the array is at least as large
- -- as the alignment of the component. We are OK in this situation.
-
- if Known_Component_Size (Atyp)
- and then Component_Size (Atyp) >= System_Max_Integer_Size
- and then Known_Alignment (Atyp)
- and then Known_Alignment (Ctyp)
- and then Alignment (Atyp) >= Alignment (Ctyp)
- then
- return;
- end if;
-
- -- Check actual component size
-
- if not Known_Component_Size (Atyp)
- or else not Addressable (Component_Size (Atyp))
- or else Component_Size (Atyp) mod Esize (Ctyp) /= 0
- then
- No_Independence;
-
- -- Bad component size, check reason
-
- if Has_Component_Size_Clause (Atyp) then
- P := Get_Attribute_Definition_Clause
- (Atyp, Attribute_Component_Size);
-
- if Present (P) then
- Error_Msg_Sloc := Sloc (P);
- Error_Msg_N ("\because of Component_Size clause#", N);
- return;
- end if;
- end if;
-
- if Is_Packed (Atyp) then
- P := Get_Rep_Pragma (Atyp, Name_Pack);
-
- if Present (P) then
- Error_Msg_Sloc := Sloc (P);
- Error_Msg_N ("\because of pragma Pack#", N);
- return;
- end if;
- end if;
-
- -- No reason found, just return
-
- return;
- end if;
-
- -- Array type is OK independence-wise
-
- return;
- end Check_Array_Type;
-
- ---------------------
- -- No_Independence --
- ---------------------
-
- procedure No_Independence is
- begin
- if Pragma_Name (N) = Name_Independent then
- Error_Msg_NE ("independence cannot be guaranteed for&", N, E);
- else
- Error_Msg_NE
- ("independent components cannot be guaranteed for&", N, E);
- end if;
- end No_Independence;
-
- ------------------
- -- OK_Component --
- ------------------
-
- function OK_Component (C : Entity_Id) return Boolean is
- Rec : constant Entity_Id := Scope (C);
- Ctyp : constant Entity_Id := Etype (C);
-
- begin
- -- OK if no component clause, no Pack, and no alignment clause
-
- if No (Component_Clause (C))
- and then not Is_Packed (Rec)
- and then not Has_Alignment_Clause (Rec)
- then
- return True;
- end if;
-
- -- Here we look at the actual component layout. A component is
- -- addressable if its size is a multiple of the Esize of the
- -- component type, and its starting position in the record has
- -- appropriate alignment, and the record itself has appropriate
- -- alignment to guarantee the component alignment.
-
- -- Make sure sizes are static, always assume the worst for any
- -- cases where we cannot check static values.
-
- if not (Known_Static_Esize (C)
- and then
- Known_Static_Esize (Ctyp))
- then
- return False;
- end if;
-
- -- Size of component must be addressable or greater than the maximum
- -- integer size and a multiple of bytes.
-
- if not Addressable (Esize (C))
- and then Esize (C) < System_Max_Integer_Size
- then
- return False;
- end if;
-
- -- Check size is proper multiple
-
- if Esize (C) mod Esize (Ctyp) /= 0 then
- return False;
- end if;
-
- -- Check alignment of component is OK
-
- if not Known_Component_Bit_Offset (C)
- or else Component_Bit_Offset (C) < Uint_0
- or else Component_Bit_Offset (C) mod Esize (Ctyp) /= 0
- then
- return False;
- end if;
-
- -- Check alignment of record type is OK
-
- if not Known_Alignment (Rec)
- or else (Alignment (Rec) * SU) mod Esize (Ctyp) /= 0
- then
- return False;
- end if;
-
- -- All tests passed, component is addressable
-
- return True;
- end OK_Component;
-
- --------------------------
- -- Reason_Bad_Component --
- --------------------------
-
- procedure Reason_Bad_Component (C : Entity_Id) is
- Rec : constant Entity_Id := Scope (C);
- Ctyp : constant Entity_Id := Etype (C);
-
- begin
- -- If component clause present assume that's the problem
-
- if Present (Component_Clause (C)) then
- Error_Msg_Sloc := Sloc (Component_Clause (C));
- Error_Msg_N ("\because of Component_Clause#", N);
- return;
- end if;
-
- -- If pragma Pack clause present, assume that's the problem
-
- if Is_Packed (Rec) then
- P := Get_Rep_Pragma (Rec, Name_Pack);
-
- if Present (P) then
- Error_Msg_Sloc := Sloc (P);
- Error_Msg_N ("\because of pragma Pack#", N);
- return;
- end if;
- end if;
-
- -- See if record has bad alignment clause
-
- if Has_Alignment_Clause (Rec)
- and then Known_Alignment (Rec)
- and then (Alignment (Rec) * SU) mod Esize (Ctyp) /= 0
- then
- P := Get_Attribute_Definition_Clause (Rec, Attribute_Alignment);
-
- if Present (P) then
- Error_Msg_Sloc := Sloc (P);
- Error_Msg_N ("\because of Alignment clause#", N);
- end if;
- end if;
-
- -- Couldn't find a reason, so return without a message
-
- return;
- end Reason_Bad_Component;
-
- -- Start of processing for Validate_Independence
-
- begin
- for J in Independence_Checks.First .. Independence_Checks.Last loop
- N := Independence_Checks.Table (J).N;
- E := Independence_Checks.Table (J).E;
- IC := Pragma_Name (N) = Name_Independent_Components;
-
- -- Deal with component case
-
- if Ekind (E) = E_Discriminant or else Ekind (E) = E_Component then
- if not OK_Component (E) then
- No_Independence;
- Reason_Bad_Component (E);
- goto Continue;
- end if;
- end if;
-
- -- Deal with record with Independent_Components
-
- if IC and then Is_Record_Type (E) then
- Comp := First_Component_Or_Discriminant (E);
- while Present (Comp) loop
- if not OK_Component (Comp) then
- No_Independence;
- Reason_Bad_Component (Comp);
- goto Continue;
- end if;
-
- Next_Component_Or_Discriminant (Comp);
- end loop;
- end if;
-
- -- Deal with address clause case
-
- if Is_Object (E) then
- Addr := Address_Clause (E);
-
- if Present (Addr) then
- No_Independence;
- Error_Msg_Sloc := Sloc (Addr);
- Error_Msg_N ("\because of Address clause#", N);
- goto Continue;
- end if;
- end if;
-
- -- Deal with independent components for array type
-
- if IC and then Is_Array_Type (E) then
- Check_Array_Type (E);
- end if;
-
- -- Deal with independent components for array object
-
- if IC and then Is_Object (E) and then Is_Array_Type (Etype (E)) then
- Check_Array_Type (Etype (E));
- end if;
-
- <<Continue>> null;
- end loop;
- end Validate_Independence;
-
------------------------------
-- Validate_Iterable_Aspect --
------------------------------
@@ -16177,12 +16324,31 @@ package body Sem_Ch13 is
Func_Name : constant Node_Id := Expression (ASN);
Overloaded : Boolean := Is_Overloaded (Func_Name);
- I : Interp_Index;
- It : Interp;
- Param_Type : Entity_Id;
- Match_Found : Boolean := False;
- Is_Match : Boolean;
- Match : Interp;
+ I : Interp_Index;
+ It : Interp;
+ Param_Type : Entity_Id;
+ Match_Found : Boolean := False;
+ Match2_Found : Boolean := False;
+ Is_Match : Boolean;
+ Match : Interp;
+ Match2 : Entity_Id := Empty;
+
+ function Matching
+ (Param_Id : Entity_Id; Param_Type : Entity_Id) return Boolean;
+ -- Return True if Param_Id is a non aliased in parameter whose base type
+ -- is Param_Type.
+
+ --------------
+ -- Matching --
+ --------------
+
+ function Matching
+ (Param_Id : Entity_Id; Param_Type : Entity_Id) return Boolean is
+ begin
+ return Base_Type (Etype (Param_Id)) = Param_Type
+ and then Ekind (Param_Id) = E_In_Parameter
+ and then not Is_Aliased (Param_Id);
+ end Matching;
begin
if not Is_Type (Typ) then
@@ -16228,26 +16394,45 @@ package body Sem_Ch13 is
Is_Match := False;
if Ekind (It.Nam) = E_Function
- and then Base_Type (Etype (It.Nam)) = Typ
+ and then Base_Type (Etype (It.Nam)) = Base_Type (Typ)
then
declare
Params : constant List_Id :=
Parameter_Specifications (Parent (It.Nam));
Param_Spec : Node_Id;
- Param_Id : Entity_Id;
begin
if List_Length (Params) = 1 then
Param_Spec := First (Params);
+ Is_Match :=
+ Matching (Defining_Identifier (Param_Spec), Param_Type);
+
+ -- Look for the optional overloaded 2-param Real_Literal
+
+ elsif List_Length (Params) = 2
+ and then A_Id = Aspect_Real_Literal
+ then
+ Param_Spec := First (Params);
- if not More_Ids (Param_Spec) then
- Param_Id := Defining_Identifier (Param_Spec);
+ if Matching (Defining_Identifier (Param_Spec), Param_Type)
+ then
+ Param_Spec := Next (Param_Spec);
- if Base_Type (Etype (Param_Id)) = Param_Type
- and then Ekind (Param_Id) = E_In_Parameter
- and then not Is_Aliased (Param_Id)
+ if Matching (Defining_Identifier (Param_Spec), Param_Type)
then
- Is_Match := True;
+ if No (Match2) then
+ Match2 := It.Nam;
+ Match2_Found := True;
+ else
+ -- If we find more than one possible match then
+ -- do not take any into account here: since the
+ -- 2-parameter version of Real_Literal is optional
+ -- we cannot generate an error here, so let
+ -- standard resolution fail later if we do need to
+ -- call this variant.
+
+ Match2_Found := False;
+ end if;
end if;
end if;
end if;
@@ -16282,6 +16467,12 @@ package body Sem_Ch13 is
Set_Entity (Func_Name, Match.Nam);
Set_Etype (Func_Name, Etype (Match.Nam));
Set_Is_Overloaded (Func_Name, False);
+
+ -- Record the match for 2-parameter function if found
+
+ if Match2_Found then
+ Set_Related_Expression (Match.Nam, Match2);
+ end if;
end Validate_Literal_Aspect;
-----------------------------------
diff --git a/gcc/ada/sem_ch13.ads b/gcc/ada/sem_ch13.ads
index 7d9f38d..e2ea55a 100644
--- a/gcc/ada/sem_ch13.ads
+++ b/gcc/ada/sem_ch13.ads
@@ -23,8 +23,8 @@
-- --
------------------------------------------------------------------------------
-with Table;
with Types; use Types;
+with Sem_Disp; use Sem_Disp;
with Uintp; use Uintp;
package Sem_Ch13 is
@@ -147,6 +147,11 @@ package Sem_Ch13 is
-- used to verify the structure of the aspect, and resolve and expand an
-- aggregate for a container type that carries the aspect.
+ function Parse_Aspect_Stable_Properties
+ (Aspect_Spec : Node_Id; Negated : out Boolean) return Subprogram_List;
+ -- Utility to unpack the subprograms in a Stable_Properties list;
+ -- in the case of the aspect of a type, Negated will always be False.
+
function Rep_Item_Too_Early (T : Entity_Id; N : Node_Id) return Boolean;
-- Called at start of processing a representation clause/pragma. Used to
-- check that the representation item is not being applied to an incomplete
@@ -232,36 +237,6 @@ package Sem_Ch13 is
-- table of saved address clauses checking for suspicious alignments and
-- if necessary issuing warnings.
- procedure Validate_Independence;
- -- This is called after the back end has been called (and thus after the
- -- layout of components has been back annotated). It goes through the
- -- table of saved pragma Independent[_Component] entries, checking that
- -- independence can be achieved, and if necessary issuing error messages.
-
- -------------------------------------
- -- Table for Validate_Independence --
- -------------------------------------
-
- -- If a legal pragma Independent or Independent_Components is given for
- -- an entity, then an entry is made in this table, to be checked by a
- -- call to Validate_Independence after back annotation of layout is done.
-
- type Independence_Check_Record is record
- N : Node_Id;
- -- The pragma Independent or Independent_Components
-
- E : Entity_Id;
- -- The entity to which it applies
- end record;
-
- package Independence_Checks is new Table.Table (
- Table_Component_Type => Independence_Check_Record,
- Table_Index_Type => Int,
- Table_Low_Bound => 1,
- Table_Initial => 20,
- Table_Increment => 200,
- Table_Name => "Independence_Checks");
-
-----------------------------------
-- Handling of Aspect Visibility --
-----------------------------------
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index 269818a..c01bce1 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -833,7 +833,7 @@ package body Sem_Ch3 is
if All_Present (N)
and then Ada_Version >= Ada_2005
then
- Error_Msg_N ("ALL is not permitted for anonymous access types", N);
+ Error_Msg_N ("ALL not permitted for anonymous access types", N);
end if;
-- Ada 2005 (AI-254): In case of anonymous access to subprograms call
@@ -1026,7 +1026,8 @@ package body Sem_Ch3 is
if Nkind (Def) in N_Has_Etype then
if Etype (Def) = T_Name then
Error_Msg_N
- ("type& cannot be used before end of its declaration", Def);
+ ("type& cannot be used before the end of its declaration",
+ Def);
end if;
-- If this is not a subtype, then this is an access_definition
@@ -1411,6 +1412,8 @@ package body Sem_Ch3 is
Set_Is_Tagged_Type (T, False);
end if;
+ Set_Etype (T, T);
+
-- For SPARK, check that the designated type is compatible with
-- respect to volatility with the access type.
@@ -1431,8 +1434,6 @@ package body Sem_Ch3 is
Srcpos_Bearer => T);
end if;
- Set_Etype (T, T);
-
-- If the type has appeared already in a with_type clause, it is frozen
-- and the pointer size is already set. Else, initialize.
@@ -2312,13 +2313,6 @@ package body Sem_Ch3 is
procedure Build_Assertion_Bodies_For_Type (Typ : Entity_Id) is
begin
- -- Preanalyze and resolve the Default_Initial_Condition assertion
- -- expression at the end of the declarations to catch any errors.
-
- if Has_DIC (Typ) then
- Build_DIC_Procedure_Body (Typ);
- end if;
-
if Nkind (Context) = N_Package_Specification then
-- Preanalyze and resolve the class-wide invariants of an
@@ -2341,32 +2335,57 @@ package body Sem_Ch3 is
Partial_Invariant => True);
end if;
- -- Preanalyze and resolve the invariants of a private type
- -- at the end of the visible declarations to catch potential
- -- errors. Inherited class-wide invariants are not included
- -- because they have already been resolved.
+ elsif Decls = Visible_Declarations (Context) then
+ -- Preanalyze and resolve the invariants of a private type
+ -- at the end of the visible declarations to catch potential
+ -- errors. Inherited class-wide invariants are not included
+ -- because they have already been resolved.
- elsif Decls = Visible_Declarations (Context)
- and then Ekind (Typ) in E_Limited_Private_Type
- | E_Private_Type
- | E_Record_Type_With_Private
- and then Has_Own_Invariants (Typ)
- then
- Build_Invariant_Procedure_Body
- (Typ => Typ,
- Partial_Invariant => True);
-
- -- Preanalyze and resolve the invariants of a private type's
- -- full view at the end of the private declarations to catch
- -- potential errors.
-
- elsif Decls = Private_Declarations (Context)
- and then (not Is_Private_Type (Typ)
- or else Present (Underlying_Full_View (Typ)))
- and then Has_Private_Declaration (Typ)
- and then Has_Invariants (Typ)
- then
- Build_Invariant_Procedure_Body (Typ);
+ if Ekind (Typ) in E_Limited_Private_Type
+ | E_Private_Type
+ | E_Record_Type_With_Private
+ and then Has_Own_Invariants (Typ)
+ then
+ Build_Invariant_Procedure_Body
+ (Typ => Typ,
+ Partial_Invariant => True);
+ end if;
+
+ -- Preanalyze and resolve the Default_Initial_Condition
+ -- assertion expression at the end of the declarations to
+ -- catch any errors.
+
+ if Ekind (Typ) in E_Limited_Private_Type
+ | E_Private_Type
+ | E_Record_Type_With_Private
+ and then Has_Own_DIC (Typ)
+ then
+ Build_DIC_Procedure_Body
+ (Typ => Typ,
+ Partial_DIC => True);
+ end if;
+
+ elsif Decls = Private_Declarations (Context) then
+
+ -- Preanalyze and resolve the invariants of a private type's
+ -- full view at the end of the private declarations to catch
+ -- potential errors.
+
+ if (not Is_Private_Type (Typ)
+ or else Present (Underlying_Full_View (Typ)))
+ and then Has_Private_Declaration (Typ)
+ and then Has_Invariants (Typ)
+ then
+ Build_Invariant_Procedure_Body (Typ);
+ end if;
+
+ if (not Is_Private_Type (Typ)
+ or else Present (Underlying_Full_View (Typ)))
+ and then Has_Private_Declaration (Typ)
+ and then Has_DIC (Typ)
+ then
+ Build_DIC_Procedure_Body (Typ);
+ end if;
end if;
end if;
end Build_Assertion_Bodies_For_Type;
@@ -12974,7 +12993,7 @@ package body Sem_Ch3 is
then
Error_Msg_N
("deferred constant must be declared in visible part",
- Parent (Prev));
+ Parent (Prev));
end if;
if Is_Access_Type (T)
@@ -14600,11 +14619,13 @@ package body Sem_Ch3 is
Comp_List : constant Elist_Id := New_Elmt_List;
Parent_Type : constant Entity_Id := Etype (Typ);
Assoc_List : constant List_Id := New_List;
- Discr_Val : Elmt_Id;
- Errors : Boolean;
- New_C : Entity_Id;
- Old_C : Entity_Id;
- Is_Static : Boolean := True;
+
+ Discr_Val : Elmt_Id;
+ Errors : Boolean;
+ New_C : Entity_Id;
+ Old_C : Entity_Id;
+ Is_Static : Boolean := True;
+ Is_Compile_Time_Known : Boolean := True;
procedure Collect_Fixed_Components (Typ : Entity_Id);
-- Collect parent type components that do not appear in a variant part
@@ -14754,7 +14775,11 @@ package body Sem_Ch3 is
while Present (Discr_Val) loop
if not Is_OK_Static_Expression (Node (Discr_Val)) then
Is_Static := False;
- exit;
+
+ if not Compile_Time_Known_Value (Node (Discr_Val)) then
+ Is_Compile_Time_Known := False;
+ exit;
+ end if;
end if;
Next_Elmt (Discr_Val);
@@ -14852,19 +14877,18 @@ package body Sem_Ch3 is
end if;
end Add_Discriminants;
- if Is_Static
+ if Is_Compile_Time_Known
and then Is_Variant_Record (Typ)
then
Collect_Fixed_Components (Typ);
-
- Gather_Components (
- Typ,
- Component_List (Type_Definition (Parent (Typ))),
- Governed_By => Assoc_List,
- Into => Comp_List,
- Report_Errors => Errors);
- pragma Assert (not Errors
- or else Serious_Errors_Detected > 0);
+ Gather_Components
+ (Typ,
+ Component_List (Type_Definition (Parent (Typ))),
+ Governed_By => Assoc_List,
+ Into => Comp_List,
+ Report_Errors => Errors,
+ Allow_Compile_Time => True);
+ pragma Assert (not Errors or else Serious_Errors_Detected > 0);
Create_All_Components;
@@ -14872,7 +14896,7 @@ package body Sem_Ch3 is
-- with constraints, we retrieve the record definition of the parent
-- type to select the components of the proper variant.
- elsif Is_Static
+ elsif Is_Compile_Time_Known
and then Is_Tagged_Type (Typ)
and then Nkind (Parent (Typ)) = N_Full_Type_Declaration
and then
@@ -14880,13 +14904,13 @@ package body Sem_Ch3 is
and then Is_Variant_Record (Parent_Type)
then
Collect_Fixed_Components (Typ);
-
Gather_Components
(Typ,
Component_List (Type_Definition (Parent (Parent_Type))),
- Governed_By => Assoc_List,
- Into => Comp_List,
- Report_Errors => Errors);
+ Governed_By => Assoc_List,
+ Into => Comp_List,
+ Report_Errors => Errors,
+ Allow_Compile_Time => True);
-- Note: previously there was a check at this point that no errors
-- were detected. As a consequence of AI05-220 there may be an error
@@ -14894,21 +14918,19 @@ package body Sem_Ch3 is
-- static constraint.
-- If the tagged derivation has a type extension, collect all the
- -- new components therein.
+ -- new relevant components therein via Gather_Components.
if Present (Record_Extension_Part (Type_Definition (Parent (Typ))))
then
- Old_C := First_Component (Typ);
- while Present (Old_C) loop
- if Original_Record_Component (Old_C) = Old_C
- and then Chars (Old_C) /= Name_uTag
- and then Chars (Old_C) /= Name_uParent
- then
- Append_Elmt (Old_C, Comp_List);
- end if;
-
- Next_Component (Old_C);
- end loop;
+ Gather_Components
+ (Typ,
+ Component_List
+ (Record_Extension_Part (Type_Definition (Parent (Typ)))),
+ Governed_By => Assoc_List,
+ Into => Comp_List,
+ Report_Errors => Errors,
+ Allow_Compile_Time => True,
+ Include_Interface_Tag => True);
end if;
Create_All_Components;
@@ -14945,6 +14967,10 @@ package body Sem_Ch3 is
Loc : constant Source_Ptr := Sloc (Def);
Digs_Expr : constant Node_Id := Digits_Expression (Def);
Delta_Expr : constant Node_Id := Delta_Expression (Def);
+ Max_Digits : constant Nat :=
+ (if System_Max_Integer_Size = 128 then 38 else 18);
+ -- Maximum number of digits that can be represented in an integer
+
Implicit_Base : Entity_Id;
Digs_Val : Uint;
Delta_Val : Ureal;
@@ -14982,9 +15008,10 @@ package body Sem_Ch3 is
Scale_Val := Scale_Val + 1;
end loop;
- if Scale_Val > 18 then
- Error_Msg_N ("scale exceeds maximum value of 18", Def);
- Scale_Val := UI_From_Int (+18);
+ if Scale_Val > Max_Digits then
+ Error_Msg_Uint_1 := UI_From_Int (Max_Digits);
+ Error_Msg_N ("scale exceeds maximum value of ^", Def);
+ Scale_Val := UI_From_Int (Max_Digits);
end if;
else
@@ -14993,9 +15020,10 @@ package body Sem_Ch3 is
Scale_Val := Scale_Val - 1;
end loop;
- if Scale_Val < -18 then
- Error_Msg_N ("scale is less than minimum value of -18", Def);
- Scale_Val := UI_From_Int (-18);
+ if Scale_Val < -Max_Digits then
+ Error_Msg_Uint_1 := UI_From_Int (-Max_Digits);
+ Error_Msg_N ("scale is less than minimum value of ^", Def);
+ Scale_Val := UI_From_Int (-Max_Digits);
end if;
end if;
@@ -15017,9 +15045,10 @@ package body Sem_Ch3 is
Check_Digits_Expression (Digs_Expr);
Digs_Val := Expr_Value (Digs_Expr);
- if Digs_Val > 18 then
- Digs_Val := UI_From_Int (+18);
- Error_Msg_N ("digits value out of range, maximum is 18", Digs_Expr);
+ if Digs_Val > Max_Digits then
+ Error_Msg_Uint_1 := UI_From_Int (Max_Digits);
+ Error_Msg_N ("digits value out of range, maximum is ^", Digs_Expr);
+ Digs_Val := UI_From_Int (Max_Digits);
end if;
Set_Digits_Value (Implicit_Base, Digs_Val);
@@ -16918,7 +16947,7 @@ package body Sem_Ch3 is
then
if Ada_Version = Ada_83 and then Comes_From_Source (Indic) then
Error_Msg_N
- ("(Ada 83): premature use of type for derivation", Indic);
+ ("(Ada 83) premature use of type for derivation", Indic);
end if;
end if;
@@ -20093,7 +20122,7 @@ package body Sem_Ch3 is
-- Per-Object Expressions" in spec of package Sem).
if Present (Expression (Discr)) then
- Preanalyze_Spec_Expression (Expression (Discr), Discr_Type);
+ Preanalyze_Default_Expression (Expression (Discr), Discr_Type);
-- Legaity checks
diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb
index d06a4a8..7a8c261 100644
--- a/gcc/ada/sem_ch4.adb
+++ b/gcc/ada/sem_ch4.adb
@@ -2297,7 +2297,7 @@ package body Sem_Ch4 is
end if;
if Aliased_Present (A) then
- Error_Msg_N ("aliased not allowed in declare_expression", A);
+ Error_Msg_N ("ALIASED not allowed in declare_expression", A);
end if;
if Constant_Present (A)
@@ -2449,7 +2449,7 @@ package body Sem_Ch4 is
if Etype (N) = Any_Type then
Error_Msg_N
- ("type incompatible with that of `THEN` expression",
+ ("type incompatible with that of THEN expression",
Else_Expr);
return;
end if;
@@ -3414,7 +3414,7 @@ package body Sem_Ch4 is
Success := True;
-- If the prefix of the call is a name, indicate the entity
- -- being called. If it is not a name, it is an expression that
+ -- being called. If it is not a name, it is an expression that
-- denotes an access to subprogram or else an entry or family. In
-- the latter case, the name is a selected component, and the entity
-- being called is noted on the selector.
@@ -5455,7 +5455,7 @@ package body Sem_Ch4 is
Apply_Compile_Time_Constraint_Error
(N, "component not present in }??",
CE_Discriminant_Check_Failed,
- Ent => Prefix_Type, Rep => False);
+ Ent => Prefix_Type);
Set_Raises_Constraint_Error (N);
return;
@@ -5700,7 +5700,7 @@ package body Sem_Ch4 is
Error_Msg_N ("\use qualified expression instead", N);
elsif Nkind (Expr) = N_Allocator then
- Error_Msg_N ("argument of conversion cannot be an allocator", N);
+ Error_Msg_N ("argument of conversion cannot be allocator", N);
Error_Msg_N ("\use qualified expression instead", N);
elsif Nkind (Expr) = N_String_Literal then
@@ -5711,8 +5711,8 @@ package body Sem_Ch4 is
if Ada_Version = Ada_83 then
Resolve (Expr, Typ);
else
- Error_Msg_N ("argument of conversion cannot be character literal",
- N);
+ Error_Msg_N
+ ("argument of conversion cannot be character literal", N);
Error_Msg_N ("\use qualified expression instead", N);
end if;
@@ -5721,7 +5721,8 @@ package body Sem_Ch4 is
| Name_Unchecked_Access
| Name_Unrestricted_Access
then
- Error_Msg_N ("argument of conversion cannot be access", N);
+ Error_Msg_N
+ ("argument of conversion cannot be access attribute", N);
Error_Msg_N ("\use qualified expression instead", N);
end if;
@@ -8088,8 +8089,7 @@ package body Sem_Ch4 is
-- resolution does not depend on the type of the parameter that
-- includes the indexing operation.
- elsif Nkind (Parent (Par)) in
- N_Function_Call | N_Procedure_Call_Statement
+ elsif Nkind (Parent (Par)) in N_Subprogram_Call
and then Is_Entity_Name (Name (Parent (Par)))
then
declare
diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb
index 2afe18b..04fc980 100644
--- a/gcc/ada/sem_ch5.adb
+++ b/gcc/ada/sem_ch5.adb
@@ -192,12 +192,11 @@ package body Sem_Ch5 is
-- directly.
elsif (Is_Prival (Ent) and then Within_Function)
- or else
- (Ekind (Ent) = E_Component
- and then Is_Protected_Type (Scope (Ent)))
+ or else Is_Protected_Component (Ent)
then
Error_Msg_N
- ("protected function cannot modify protected object", N);
+ ("protected function cannot modify its protected object",
+ N);
return;
end if;
end;
@@ -305,9 +304,9 @@ package body Sem_Ch5 is
-- also have an actual subtype.
if Is_Entity_Name (Opnd)
- and then (Ekind (Entity (Opnd)) = E_Out_Parameter
- or else Ekind (Entity (Opnd)) in
- E_In_Out_Parameter | E_Generic_In_Out_Parameter
+ and then (Ekind (Entity (Opnd)) in E_Out_Parameter
+ | E_In_Out_Parameter
+ | E_Generic_In_Out_Parameter
or else
(Ekind (Entity (Opnd)) = E_Variable
and then Nkind (Parent (Entity (Opnd))) =
@@ -351,8 +350,6 @@ package body Sem_Ch5 is
function Should_Transform_BIP_Assignment
(Typ : Entity_Id) return Boolean
is
- Result : Boolean;
-
begin
if Expander_Active
and then not Is_Limited_View (Typ)
@@ -366,37 +363,33 @@ package body Sem_Ch5 is
-- parameterless function call if it denotes a function.
-- Finally, an attribute reference can be a function call.
- case Nkind (Unqual_Conv (Rhs)) is
- when N_Function_Call
- | N_Op
- =>
- Result := True;
-
- when N_Expanded_Name
- | N_Identifier
- =>
- case Ekind (Entity (Unqual_Conv (Rhs))) is
- when E_Function
- | E_Operator
- =>
- Result := True;
-
- when others =>
- Result := False;
- end case;
-
- when N_Attribute_Reference =>
- Result := Attribute_Name (Unqual_Conv (Rhs)) = Name_Input;
+ declare
+ Unqual_Rhs : constant Node_Id := Unqual_Conv (Rhs);
+ begin
+ case Nkind (Unqual_Rhs) is
+ when N_Function_Call
+ | N_Op
+ =>
+ return True;
+
+ when N_Expanded_Name
+ | N_Identifier
+ =>
+ return
+ Ekind (Entity (Unqual_Rhs)) in E_Function | E_Operator;
+
-- T'Input will turn into a call whose result type is T
- when others =>
- Result := False;
- end case;
+ when N_Attribute_Reference =>
+ return Attribute_Name (Unqual_Rhs) = Name_Input;
+
+ when others =>
+ return False;
+ end case;
+ end;
else
- Result := False;
+ return False;
end if;
-
- return Result;
end Should_Transform_BIP_Assignment;
------------------------------
@@ -713,7 +706,8 @@ package body Sem_Ch5 is
and then Convention (S) = Convention_Protected
then
Error_Msg_N
- ("protected function cannot modify protected object",
+ ("protected function cannot modify its protected " &
+ "object",
Lhs);
end if;
@@ -779,7 +773,7 @@ package body Sem_Ch5 is
if Is_Protected_Part_Of_Constituent (Lhs) and then Within_Function then
Error_Msg_N
- ("protected function cannot modify protected object", Lhs);
+ ("protected function cannot modify its protected object", Lhs);
end if;
-- Resolution may have updated the subtype, in case the left-hand side
@@ -962,7 +956,7 @@ package body Sem_Ch5 is
Apply_Compile_Time_Constraint_Error
(N => Rhs,
Msg =>
- "(Ada 2005) null not allowed in null-excluding objects??",
+ "(Ada 2005) NULL not allowed in null-excluding objects??",
Reason => CE_Null_Not_Allowed);
-- We still mark this as a possible modification, that's necessary
@@ -1395,16 +1389,7 @@ package body Sem_Ch5 is
----------------------------
procedure Analyze_Case_Statement (N : Node_Id) is
- Exp : Node_Id;
- Exp_Type : Entity_Id;
- Exp_Btype : Entity_Id;
- Last_Choice : Nat;
-
- Others_Present : Boolean;
- -- Indicates if Others was present
-
- pragma Warnings (Off, Last_Choice);
- -- Don't care about assigned value
+ Exp : constant Node_Id := Expression (N);
Statements_Analyzed : Boolean := False;
-- Set True if at least some statement sequences get analyzed. If False
@@ -1412,9 +1397,6 @@ 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.
- Save_Unblocked_Exit_Count : constant Nat := Unblocked_Exit_Count;
- -- Recursively save value of this global, will be restored on exit
-
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.
@@ -1474,8 +1456,7 @@ package body Sem_Ch5 is
if Is_Entity_Name (Exp) then
Ent := Entity (Exp);
- if Ekind (Ent) in E_Variable | E_In_Out_Parameter | E_Out_Parameter
- then
+ if Is_Assignable (Ent) then
if List_Length (Choices) = 1
and then Nkind (First (Choices)) in N_Subexpr
and then Compile_Time_Known_Value (First (Choices))
@@ -1499,11 +1480,20 @@ package body Sem_Ch5 is
Analyze_Statements (Statements (Alternative));
end Process_Statements;
+ -- Local variables
+
+ Exp_Type : Entity_Id;
+ Exp_Btype : Entity_Id;
+
+ Others_Present : Boolean;
+ -- Indicates if Others was present
+
+ Save_Unblocked_Exit_Count : constant Nat := Unblocked_Exit_Count;
+ -- Recursively save value of this global, will be restored on exit
+
-- Start of processing for Analyze_Case_Statement
begin
- Unblocked_Exit_Count := 0;
- Exp := Expression (N);
Analyze (Exp);
-- The expression must be of any discrete type. In rare cases, the
@@ -1567,7 +1557,9 @@ package body Sem_Ch5 is
Exp_Type := Exp_Btype;
end if;
- -- Call instantiated procedures to analyzwe and check discrete choices
+ -- Call instantiated procedures to analyze and check discrete choices
+
+ Unblocked_Exit_Count := 0;
Analyze_Choices (Alternatives (N), Exp_Type);
Check_Choices (N, Alternatives (N), Exp_Type, Others_Present);
@@ -1782,8 +1774,6 @@ package body Sem_Ch5 is
-- on which they depend will not be available at the freeze point.
procedure Analyze_If_Statement (N : Node_Id) is
- E : Node_Id;
-
Save_Unblocked_Exit_Count : constant Nat := Unblocked_Exit_Count;
-- Recursively save value of this global, will be restored on exit
@@ -1848,6 +1838,11 @@ package body Sem_Ch5 is
end if;
end Analyze_Cond_Then;
+ -- Local variables
+
+ E : Node_Id;
+ -- For iterating over elsif parts
+
-- Start of processing for Analyze_If_Statement
begin
@@ -2629,7 +2624,10 @@ package body Sem_Ch5 is
end if;
if Present (Iterator_Filter (N)) then
- Analyze_And_Resolve (Iterator_Filter (N), Standard_Boolean);
+ -- Preanalyze the filter. Expansion will take place when enclosing
+ -- loop is expanded.
+
+ Preanalyze_And_Resolve (Iterator_Filter (N), Standard_Boolean);
end if;
end Analyze_Iterator_Specification;
@@ -3026,6 +3024,9 @@ package body Sem_Ch5 is
begin
Set_Iterator_Specification (Scheme, I_Spec);
Set_Loop_Parameter_Specification (Scheme, Empty);
+ Set_Iterator_Filter (I_Spec,
+ Relocate_Node (Iterator_Filter (N)));
+
Analyze_Iterator_Specification (I_Spec);
-- In a generic context, analyze the original domain of
@@ -3098,7 +3099,10 @@ package body Sem_Ch5 is
Check_Predicate_Use (Entity (Subtype_Mark (DS)));
end if;
- Make_Index (DS, N);
+ if Nkind (DS) not in N_Raise_xxx_Error then
+ Make_Index (DS, N);
+ end if;
+
Set_Ekind (Id, E_Loop_Parameter);
-- A quantified expression which appears in a pre- or post-condition may
diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index 88bbdf7..7bab772 100644
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -784,13 +784,49 @@ package body Sem_Ch6 is
------------------------------------------
procedure Check_Return_Construct_Accessibility (Return_Stmt : Node_Id) is
- Return_Con : Node_Id;
- Assoc : Node_Id := Empty;
- Assoc_Expr : Node_Id;
- Disc : Entity_Id;
+
+ function First_Selector (Assoc : Node_Id) return Node_Id;
+ -- Obtain the first selector or choice from a given association
+
+ --------------------
+ -- First_Selector --
+ --------------------
+
+ function First_Selector (Assoc : Node_Id) return Node_Id is
+ begin
+ if Nkind (Assoc) = N_Component_Association then
+ return First (Choices (Assoc));
+
+ elsif Nkind (Assoc) = N_Discriminant_Association then
+ return (First (Selector_Names (Assoc)));
+
+ else
+ raise Program_Error;
+ end if;
+ end First_Selector;
+
+ -- Local declarations
+
+ Assoc : Node_Id := Empty;
+ -- Assoc should perhaps be renamed and declared as a
+ -- Node_Or_Entity_Id since it encompasses not only component and
+ -- discriminant associations, but also discriminant components within
+ -- a type declaration or subtype indication ???
+
+ Assoc_Expr : Node_Id;
+ Assoc_Present : Boolean := False;
+
+ Unseen_Disc_Count : Nat := 0;
+ Seen_Discs : Elist_Id;
+ Disc : Entity_Id;
+ First_Disc : Entity_Id;
+
Obj_Decl : Node_Id;
+ Return_Con : Node_Id;
Unqual : Node_Id;
+ -- Start of processing for Check_Return_Construct_Accessibility
+
begin
-- Only perform checks on record types with access discriminants and
-- non-internally generated functions.
@@ -845,7 +881,7 @@ package body Sem_Ch6 is
Unqual := Unqualify (Original_Node (Return_Con));
- -- Obtain the corresponding declaration based on the return object's
+ -- Get the corresponding declaration based on the return object's
-- identifier.
if Nkind (Unqual) = N_Identifier
@@ -982,30 +1018,175 @@ package body Sem_Ch6 is
(Etype (Defining_Identifier (Obj_Decl)));
end if;
+ -- Preserve the first discriminant for checking named associations
+
+ First_Disc := Disc;
+
+ -- Count the number of discriminants for processing an aggregate
+ -- which includes an others.
+
+ Disc := First_Disc;
+ while Present (Disc) loop
+ Unseen_Disc_Count := Unseen_Disc_Count + 1;
+
+ Next_Discriminant (Disc);
+ end loop;
+
+ Seen_Discs := New_Elmt_List;
+
-- Loop through each of the discriminants and check each expression
-- associated with an anonymous access discriminant.
- while Present (Assoc) and then Present (Disc) loop
- -- Unwrap the associated expression
+ -- When named associations occur in the return aggregate then
+ -- discriminants can be in any order, so we need to ensure we do
+ -- not continue to loop when all discriminants have been seen.
+
+ Disc := First_Disc;
+ while Present (Assoc)
+ and then (Present (Disc) or else Assoc_Present)
+ and then Unseen_Disc_Count > 0
+ loop
+ -- Handle named associations by searching through the names of
+ -- the relevant discriminant components.
if Nkind (Assoc)
in N_Component_Association | N_Discriminant_Association
then
- Assoc_Expr := Expression (Assoc);
+ Assoc_Expr := Expression (Assoc);
+ Assoc_Present := True;
+
+ -- We currently don't handle box initialized discriminants,
+ -- however, since default initialized anonymous access
+ -- discriminants are a corner case, this is ok for now ???
+
+ if Nkind (Assoc) = N_Component_Association
+ and then Box_Present (Assoc)
+ then
+ Assoc_Present := False;
+
+ if Nkind (First_Selector (Assoc)) = N_Others_Choice then
+ Unseen_Disc_Count := 0;
+ end if;
+
+ -- When others is present we must identify a discriminant we
+ -- haven't already seen so as to get the appropriate type for
+ -- the static accessibility check.
+
+ -- This works because all components within an others clause
+ -- must have the same type.
+
+ elsif Nkind (First_Selector (Assoc)) = N_Others_Choice then
+
+ Disc := First_Disc;
+ Outer : while Present (Disc) loop
+ declare
+ Current_Seen_Disc : Elmt_Id;
+ begin
+ -- Move through the list of identified discriminants
+
+ Current_Seen_Disc := First_Elmt (Seen_Discs);
+ while Present (Current_Seen_Disc) loop
+ -- Exit the loop when we found a match
+
+ exit when
+ Chars (Node (Current_Seen_Disc)) = Chars (Disc);
+
+ Next_Elmt (Current_Seen_Disc);
+ end loop;
+
+ -- When we have exited the above loop without finding
+ -- a match then we know that Disc has not been seen.
+
+ exit Outer when No (Current_Seen_Disc);
+ end;
+
+ Next_Discriminant (Disc);
+ end loop Outer;
+
+ -- If we got to an others clause with a non-zero
+ -- discriminant count there must be a discriminant left to
+ -- check.
+
+ pragma Assert (Present (Disc));
+
+ -- Set the unseen discriminant count to zero because we know
+ -- an others clause sets all remaining components of an
+ -- aggregate.
+
+ Unseen_Disc_Count := 0;
+
+ -- Move through each of the selectors in the named association
+ -- and obtain a discriminant for accessibility checking if one
+ -- is referenced in the list. Also track which discriminants
+ -- are referenced for the purpose of handling an others clause.
+
+ else
+ declare
+ Assoc_Choice : Node_Id;
+ Curr_Disc : Node_Id;
+ begin
+
+ Disc := Empty;
+ Curr_Disc := First_Disc;
+ while Present (Curr_Disc) loop
+ -- Check each of the choices in the associations for a
+ -- match to the name of the current discriminant.
+
+ Assoc_Choice := First_Selector (Assoc);
+ while Present (Assoc_Choice) loop
+ -- When the name matches we track that we have seen
+ -- the discriminant, but instead of exiting the
+ -- loop we continue iterating to make sure all the
+ -- discriminants within the named association get
+ -- tracked.
+
+ if Chars (Assoc_Choice) = Chars (Curr_Disc) then
+ Append_Elmt (Curr_Disc, Seen_Discs);
+
+ Disc := Curr_Disc;
+ Unseen_Disc_Count := Unseen_Disc_Count - 1;
+ end if;
+
+ Next (Assoc_Choice);
+ end loop;
+
+ Next_Discriminant (Curr_Disc);
+ end loop;
+ end;
+ end if;
+
+ -- Unwrap the associated expression if we are looking at a default
+ -- initialized type declaration. In this case Assoc is not really
+ -- an association, but a component declaration. Should Assoc be
+ -- renamed in some way to be more clear ???
+
+ -- This occurs when the return object does not initialize
+ -- discriminant and instead relies on the type declaration for
+ -- their supplied values.
elsif Nkind (Assoc) in N_Entity
and then Ekind (Assoc) = E_Discriminant
then
- Assoc_Expr := Discriminant_Default_Value (Assoc);
+ Append_Elmt (Disc, Seen_Discs);
+
+ Assoc_Expr := Discriminant_Default_Value (Assoc);
+ Unseen_Disc_Count := Unseen_Disc_Count - 1;
+
+ -- Otherwise, there is nothing to do because Assoc is an
+ -- expression within the return aggregate itself.
else
- Assoc_Expr := Assoc;
+ Append_Elmt (Disc, Seen_Discs);
+
+ Assoc_Expr := Assoc;
+ Unseen_Disc_Count := Unseen_Disc_Count - 1;
end if;
-- Check the accessibility level of the expression when the
-- discriminant is of an anonymous access type.
if Present (Assoc_Expr)
+ and then Present (Disc)
and then Ekind (Etype (Disc)) = E_Anonymous_Access_Type
then
-- Perform a static check first, if possible
@@ -1019,8 +1200,8 @@ package body Sem_Ch6 is
Error_Msg_N
("access discriminant in return object would be a dangling"
& " reference", Return_Stmt);
- exit;
+ exit;
end if;
-- Otherwise, generate a dynamic check based on the extra
@@ -1041,9 +1222,16 @@ package body Sem_Ch6 is
end if;
end if;
- -- Iterate over the discriminants
+ -- Iterate over the discriminants, except when we have encountered
+ -- a named association since the discriminant order becomes
+ -- irrelevant in that case.
+
+ if not Assoc_Present then
+ Next_Discriminant (Disc);
+ end if;
+
+ -- Iterate over associations
- Disc := Next_Discriminant (Disc);
if not Is_List_Member (Assoc) then
exit;
else
@@ -1349,12 +1537,12 @@ package body Sem_Ch6 is
-- Can it really happen (extended return???)
Error_Msg_N
- ("aliased only allowed for limited return objects "
+ ("ALIASED only allowed for limited return objects "
& "in Ada 2012??", N);
elsif not Is_Limited_View (R_Type) then
Error_Msg_N
- ("aliased only allowed for limited return objects", N);
+ ("ALIASED only allowed for limited return objects", N);
end if;
end if;
@@ -1921,12 +2109,18 @@ package body Sem_Ch6 is
-- is just a string, as in (conjunction = "or"). In these cases the parser
-- generates this node, and the semantics does the disambiguation. Other
-- such case are actuals in an instantiation, the generic unit in an
- -- instantiation, and pragma arguments.
+ -- instantiation, pragma arguments, and aspect specifications.
procedure Analyze_Operator_Symbol (N : Node_Id) is
Par : constant Node_Id := Parent (N);
+ Maybe_Aspect_Spec : Node_Id := Par;
begin
+ if Nkind (Maybe_Aspect_Spec) /= N_Aspect_Specification then
+ -- deal with N_Aggregate nodes
+ Maybe_Aspect_Spec := Parent (Maybe_Aspect_Spec);
+ end if;
+
if (Nkind (Par) = N_Function_Call and then N = Name (Par))
or else Nkind (Par) = N_Function_Instantiation
or else (Nkind (Par) = N_Indexed_Component and then N = Prefix (Par))
@@ -1935,6 +2129,10 @@ package body Sem_Ch6 is
or else Nkind (Par) = N_Subprogram_Renaming_Declaration
or else (Nkind (Par) = N_Attribute_Reference
and then Attribute_Name (Par) /= Name_Value)
+ or else (Nkind (Maybe_Aspect_Spec) = N_Aspect_Specification
+ and then Get_Aspect_Id (Maybe_Aspect_Spec)
+ -- include other aspects here ???
+ in Aspect_Stable_Properties | Aspect_Aggregate)
then
Find_Direct_Name (N);
@@ -2232,6 +2430,26 @@ package body Sem_Ch6 is
else
Error_Msg_N ("invalid procedure or entry call", N);
+
+ -- Specialize the error message in the case where both a primitive
+ -- operation and a record component are visible at the same time.
+
+ if Nkind (P) = N_Selected_Component
+ and then Is_Entity_Name (Selector_Name (P))
+ then
+ declare
+ Sel : constant Entity_Id := Entity (Selector_Name (P));
+ begin
+ if Ekind (Sel) = E_Component
+ and then Present (Homonym (Sel))
+ and then Ekind (Homonym (Sel)) = E_Procedure
+ then
+ Error_Msg_NE ("\component & conflicts with"
+ & " homonym procedure (RM 4.1.3 (9.2/3))",
+ Selector_Name (P), Sel);
+ end if;
+ end;
+ end if;
end if;
<<Leave>>
@@ -2272,13 +2490,11 @@ package body Sem_Ch6 is
Result : Entity_Id := Empty;
begin
- -- Loop outward through the Scope_Stack, skipping blocks, loops,
- -- and postconditions.
+ -- Loop outward through the Scope_Stack, skipping blocks, and loops
for J in reverse 0 .. Scope_Stack.Last loop
Result := Scope_Stack.Table (J).Entity;
- exit when Ekind (Result) not in E_Block | E_Loop
- and then Chars (Result) /= Name_uPostconditions;
+ exit when Ekind (Result) not in E_Block | E_Loop;
end loop;
pragma Assert (Present (Result));
@@ -3023,10 +3239,10 @@ package body Sem_Ch6 is
-- Required to ensure that Expand_Call rewrites calls to this
-- function by calls to the built procedure.
- if Modify_Tree_For_C
+ if Transform_Function_Array
and then Nkind (Body_Spec) = N_Function_Specification
and then
- Rewritten_For_C (Defining_Entity (Specification (Subp_Decl)))
+ Rewritten_For_C (Defining_Entity (Specification (Subp_Decl)))
then
Set_Rewritten_For_C (Defining_Entity (Body_Spec));
Set_Corresponding_Procedure (Defining_Entity (Body_Spec),
@@ -4073,11 +4289,11 @@ package body Sem_Ch6 is
Build_Subprogram_Declaration;
-- If this is a function that returns a constrained array, and
- -- we are generating C code, create subprogram declaration
- -- to simplify subsequent C generation.
+ -- Transform_Function_Array is set, create subprogram
+ -- declaration to simplify e.g. subsequent C generation.
elsif No (Spec_Id)
- and then Modify_Tree_For_C
+ and then Transform_Function_Array
and then Nkind (Body_Spec) = N_Function_Specification
and then Is_Array_Type (Etype (Body_Id))
and then Is_Constrained (Etype (Body_Id))
@@ -4171,33 +4387,58 @@ package body Sem_Ch6 is
Spec_Id := Build_Internal_Protected_Declaration (N);
end if;
- -- If we are generating C and this is a function returning a constrained
- -- array type for which we must create a procedure with an extra out
- -- parameter, build and analyze the body now. The procedure declaration
- -- has already been created. We reuse the source body of the function,
- -- because in an instance it may contain global references that cannot
- -- be reanalyzed. The source function itself is not used any further,
- -- so we mark it as having a completion. If the subprogram is a stub the
- -- transformation is done later, when the proper body is analyzed.
+ -- If Transform_Function_Array is set and this is a function returning a
+ -- constrained array type for which we must create a procedure with an
+ -- extra out parameter, build and analyze the body now. The procedure
+ -- declaration has already been created. We reuse the source body of the
+ -- function, because in an instance it may contain global references
+ -- that cannot be reanalyzed. The source function itself is not used any
+ -- further, so we mark it as having a completion. If the subprogram is a
+ -- stub the transformation is done later, when the proper body is
+ -- analyzed.
if Expander_Active
- and then Modify_Tree_For_C
- and then Present (Spec_Id)
- and then Ekind (Spec_Id) = E_Function
+ and then Transform_Function_Array
and then Nkind (N) /= N_Subprogram_Body_Stub
- and then Rewritten_For_C (Spec_Id)
then
- Set_Has_Completion (Spec_Id);
+ declare
+ S : constant Entity_Id :=
+ (if Present (Spec_Id)
+ then Spec_Id
+ else Defining_Unit_Name (Specification (N)));
+ Proc_Body : Node_Id;
- Rewrite (N, Build_Procedure_Body_Form (Spec_Id, N));
- Analyze (N);
+ begin
+ if Ekind (S) = E_Function and then Rewritten_For_C (S) then
+ Set_Has_Completion (S);
+ Proc_Body := Build_Procedure_Body_Form (S, N);
- -- The entity for the created procedure must remain invisible, so it
- -- does not participate in resolution of subsequent references to the
- -- function.
+ if Present (Spec_Id) then
+ Rewrite (N, Proc_Body);
+ Analyze (N);
- Set_Is_Immediately_Visible (Corresponding_Spec (N), False);
- goto Leave;
+ -- The entity for the created procedure must remain
+ -- invisible, so it does not participate in resolution of
+ -- subsequent references to the function.
+
+ Set_Is_Immediately_Visible (Corresponding_Spec (N), False);
+
+ -- If we do not have a separate spec for N, build one and
+ -- insert the new body right after.
+
+ else
+ Rewrite (N,
+ Make_Subprogram_Declaration (Loc,
+ Specification => Relocate_Node (Specification (N))));
+ Analyze (N);
+ Insert_After_And_Analyze (N, Proc_Body);
+ Set_Is_Immediately_Visible
+ (Corresponding_Spec (Proc_Body), False);
+ end if;
+
+ goto Leave;
+ end if;
+ end;
end if;
-- If a separate spec is present, then deal with freezing issues
@@ -9727,7 +9968,7 @@ package body Sem_Ch6 is
Error_Msg_Sloc :=
Text_Ptr'Max (Sloc (Entity (E1)), Sloc (Entity (E2)));
Error_Msg_NE
- ("Meaning of& differs because of declaration#", E1, E2);
+ ("meaning of& differs because of declaration#", E1, E2);
end if;
return Result;
diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb
index 35c6f60..4689ae4 100644
--- a/gcc/ada/sem_ch8.adb
+++ b/gcc/ada/sem_ch8.adb
@@ -772,6 +772,31 @@ package body Sem_Ch8 is
-- Obtain the name of the object from node Nod which is being renamed by
-- the object renaming declaration N.
+ function Find_Raise_Node (N : Node_Id) return Traverse_Result;
+ -- Process one node in search for N_Raise_xxx_Error nodes.
+ -- Return Abandon if found, OK otherwise.
+
+ ---------------------
+ -- Find_Raise_Node --
+ ---------------------
+
+ function Find_Raise_Node (N : Node_Id) return Traverse_Result is
+ begin
+ if Nkind (N) in N_Raise_xxx_Error then
+ return Abandon;
+ else
+ return OK;
+ end if;
+ end Find_Raise_Node;
+
+ ------------------------
+ -- No_Raise_xxx_Error --
+ ------------------------
+
+ function No_Raise_xxx_Error is new Traverse_Func (Find_Raise_Node);
+ -- Traverse tree to look for a N_Raise_xxx_Error node and returns
+ -- Abandon if so and OK if none found.
+
------------------------------
-- Check_Constrained_Object --
------------------------------
@@ -1038,6 +1063,22 @@ package body Sem_Ch8 is
Mark_Ghost_Renaming (N, Entity (Nam));
end if;
+ -- Check against AI12-0401 here before Resolve may rewrite Nam and
+ -- potentially generate spurious warnings.
+
+ 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)))
+ then
+ Error_Msg_N
+ ("subtype of renamed qualified expression does not " &
+ "statically match", N);
+ return;
+ end if;
+
Resolve (Nam, T);
-- If the renamed object is a function call of a limited type,
@@ -1438,10 +1479,11 @@ package body Sem_Ch8 is
then
Error_Msg_N ("incompatible types in renaming", Nam);
- -- AI12-0383: Names that denote values can be renamed
+ -- AI12-0383: Names that denote values can be renamed.
+ -- Ignore (accept) N_Raise_xxx_Error nodes in this context.
- elsif Ada_Version < Ada_2020 then
- Error_Msg_N ("value in renaming requires -gnat2020", Nam);
+ elsif No_Raise_xxx_Error (Nam) = OK then
+ Error_Msg_Ada_2020_Feature ("value in renaming", Sloc (Nam));
end if;
Set_Etype (Id, T2);
@@ -5551,9 +5593,25 @@ package body Sem_Ch8 is
and then N = Prefix (Parent (N))
and then Is_Known_Unit (Parent (N))
then
- Error_Msg_Node_2 := Selector_Name (Parent (N));
- Error_Msg_N -- CODEFIX
- ("\\missing `WITH &.&;`", Prefix (Parent (N)));
+ declare
+ P : Node_Id := Parent (N);
+ begin
+ Error_Msg_Name_1 := Chars (N);
+ Error_Msg_Name_2 := Chars (Selector_Name (P));
+
+ if Nkind (Parent (P)) = N_Selected_Component
+ and then Is_Known_Unit (Parent (P))
+ then
+ P := Parent (P);
+ Error_Msg_Name_3 := Chars (Selector_Name (P));
+ Error_Msg_N -- CODEFIX
+ ("\\missing `WITH %.%.%;`", N);
+
+ else
+ Error_Msg_N -- CODEFIX
+ ("\\missing `WITH %.%;`", N);
+ end if;
+ end;
end if;
-- Now check for possible misspellings
@@ -5590,7 +5648,10 @@ package body Sem_Ch8 is
-- undefined reference. The entry is not added if we are ignoring
-- errors.
- if not All_Errors_Mode and then Ignore_Errors_Enable = 0 then
+ if not All_Errors_Mode
+ and then Ignore_Errors_Enable = 0
+ and then not Get_Ignore_Errors
+ then
Urefs.Append (
(Node => N,
Err => Emsg,
@@ -5643,8 +5704,7 @@ package body Sem_Ch8 is
-- happens for trees generated from Exp_Pakd, where expressions
-- can be deliberately "mis-typed" to the packed array type.
- if Is_Array_Type (Entyp)
- and then Is_Packed (Entyp)
+ if Is_Packed_Array (Entyp)
and then Present (Etype (N))
and then Etype (N) = Packed_Array_Impl_Type (Entyp)
then
@@ -5721,12 +5781,6 @@ package body Sem_Ch8 is
E := Homonym (E);
end loop;
- -- If we are ignoring errors, skip the error processing
-
- if Get_Ignore_Errors then
- return;
- end if;
-
-- If no entries on homonym chain that were potentially visible,
-- and no entities reasonably considered as non-visible, then
-- we have a plain undefined reference, with no additional
@@ -7504,7 +7558,7 @@ package body Sem_Ch8 is
-- Reference to type name in predicate/invariant expression
- elsif (Is_Task_Type (P_Type) or else Is_Protected_Type (P_Type))
+ elsif Is_Concurrent_Type (P_Type)
and then not In_Open_Scopes (P_Name)
and then (not Is_Concurrent_Type (Etype (P_Name))
or else not In_Open_Scopes (Etype (P_Name)))
@@ -7839,7 +7893,7 @@ package body Sem_Ch8 is
elsif Warn_On_Obsolescent_Feature and then False then
Error_Msg_N
- ("applying 'Class to an untagged incomplete type"
+ ("applying ''Class to an untagged incomplete type"
& " is an obsolescent feature (RM J.11)?r?", N);
end if;
end if;
@@ -8735,9 +8789,8 @@ package body Sem_Ch8 is
-- Mark primitives
- elsif (Ekind (Id) in Overloadable_Kind
- or else Ekind (Id) in
- E_Generic_Function | E_Generic_Procedure)
+ elsif (Is_Overloadable (Id)
+ or else Is_Generic_Subprogram (Id))
and then (Is_Potentially_Use_Visible (Id)
or else Is_Intrinsic_Subprogram (Id)
or else (Ekind (Id) in E_Function | E_Procedure
diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb
index a9d720b..b7b7d7d 100644
--- a/gcc/ada/sem_ch9.adb
+++ b/gcc/ada/sem_ch9.adb
@@ -790,13 +790,13 @@ package body Sem_Ch9 is
if Kind /= E_Block and then Kind /= E_Loop
and then not Is_Entry (Task_Nam)
then
- Error_Msg_N ("enclosing body of accept must be a task", N);
+ Error_Msg_N ("enclosing body of ACCEPT must be a task", N);
return;
end if;
end loop;
if Ekind (Etype (Task_Nam)) /= E_Task_Type then
- Error_Msg_N ("invalid context for accept statement", N);
+ Error_Msg_N ("invalid context for ACCEPT statement", N);
return;
end if;
@@ -844,7 +844,7 @@ package body Sem_Ch9 is
end loop;
if Entry_Nam = Any_Id then
- Error_Msg_N ("no entry declaration matches accept statement", N);
+ Error_Msg_N ("no entry declaration matches ACCEPT statement", N);
return;
else
Set_Entity (Nam, Entry_Nam);
@@ -882,7 +882,7 @@ package body Sem_Ch9 is
if Entry_Nam = Scope_Stack.Table (J).Entity then
Error_Msg_N
- ("duplicate accept statement for same entry (RM 9.5.2 (15))", N);
+ ("duplicate ACCEPT statement for same entry (RM 9.5.2 (15))", N);
-- Do not continue analysis of accept statement, to prevent
-- cascaded errors.
@@ -904,8 +904,8 @@ package body Sem_Ch9 is
when N_Asynchronous_Select =>
Error_Msg_N
- ("accept statements are not allowed within an "
- & "asynchronous select inner to the enclosing task body",
+ ("ACCEPT statement not allowed within an "
+ & "asynchronous SELECT inner to the enclosing task body",
N);
exit;
@@ -2671,7 +2671,7 @@ package body Sem_Ch9 is
if Entity (EDN1) = Ent then
Error_Msg_Sloc := Sloc (Stm1);
Error_Msg_N
- ("accept duplicates one on line#??", Stm);
+ ("ACCEPT duplicates one on line#??", Stm);
exit;
end if;
end if;
@@ -2691,16 +2691,16 @@ package body Sem_Ch9 is
Check_Potentially_Blocking_Operation (N);
if Terminate_Present and Delay_Present then
- Error_Msg_N ("at most one of terminate or delay alternative", N);
+ Error_Msg_N ("at most one of TERMINATE or DELAY alternative", N);
elsif not Accept_Present then
Error_Msg_N
- ("select must contain at least one accept alternative", N);
+ ("SELECT must contain at least one ACCEPT alternative", N);
end if;
if Present (Else_Statements (N)) then
if Terminate_Present or Delay_Present then
- Error_Msg_N ("else part not allowed with other alternatives", N);
+ Error_Msg_N ("ELSE part not allowed with other alternatives", N);
end if;
Analyze_Statements (Else_Statements (N));
diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb
index cf54337..36efa42 100644
--- a/gcc/ada/sem_disp.adb
+++ b/gcc/ada/sem_disp.adb
@@ -625,7 +625,7 @@ package body Sem_Disp is
Par := Parent (Par);
end if;
- if Nkind (Par) in N_Function_Call | N_Procedure_Call_Statement
+ if Nkind (Par) in N_Subprogram_Call
and then Is_Entity_Name (Name (Par))
then
declare
diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb
index d7a8bb0..89b6e13 100644
--- a/gcc/ada/sem_elab.adb
+++ b/gcc/ada/sem_elab.adb
@@ -2414,10 +2414,16 @@ package body Sem_Elab is
-- Default_Initial_Condition
elsif Is_Default_Initial_Condition_Proc (Subp_Id) then
- Output_Verification_Call
- (Pred => "Default_Initial_Condition",
- Id => First_Formal_Type (Subp_Id),
- Id_Kind => "type");
+
+ -- Only do output for a normal DIC procedure, since partial DIC
+ -- procedures are subsidiary to those.
+
+ if not Is_Partial_DIC_Procedure (Subp_Id) then
+ Output_Verification_Call
+ (Pred => "Default_Initial_Condition",
+ Id => First_Formal_Type (Subp_Id),
+ Id_Kind => "type");
+ end if;
-- Entries
@@ -3738,7 +3744,7 @@ package body Sem_Elab is
Set_Is_Dispatching_Call
(Marker,
- Nkind (N) in N_Function_Call | N_Procedure_Call_Statement
+ Nkind (N) in N_Subprogram_Call
and then Present (Controlling_Argument (N)));
Set_Is_Elaboration_Checks_OK_Node
@@ -19362,7 +19368,7 @@ package body Sem_Elab is
function Is_Call_Of_Generic_Formal (N : Node_Id) return Boolean is
begin
- return Nkind (N) in N_Function_Call | N_Procedure_Call_Statement
+ return Nkind (N) in N_Subprogram_Call
-- Always return False if debug flag -gnatd.G is set
diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb
index 12f2822..8d47589 100644
--- a/gcc/ada/sem_eval.adb
+++ b/gcc/ada/sem_eval.adb
@@ -43,6 +43,7 @@ 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;
@@ -124,7 +125,7 @@ package body Sem_Eval is
type CV_Cache_Array is array (CV_Range) of CV_Entry;
- CV_Cache : CV_Cache_Array := (others => (Node_High_Bound, Uint_0));
+ CV_Cache : CV_Cache_Array;
-- This is the actual cache, with entries consisting of node/value pairs,
-- and the impossible value Node_High_Bound used for unset entries.
@@ -1855,6 +1856,12 @@ package body Sem_Eval is
N_Character_Literal | N_Real_Literal | N_String_Literal | N_Null
then
return True;
+
+ -- Evaluate static discriminants, to eliminate dead paths and
+ -- redundant discriminant checks.
+
+ elsif Is_Static_Discriminant_Component (Op) then
+ return True;
end if;
end if;
@@ -3731,83 +3738,81 @@ package body Sem_Eval is
Raises_Constraint_Error (Right)
then
return;
+ end if;
-- OK, we have the case where we may be able to do this fold
- else
- Left_Len := Static_Length (Left);
- Right_Len := Static_Length (Right);
+ Left_Len := Static_Length (Left);
+ Right_Len := Static_Length (Right);
- if Left_Len /= Uint_Minus_1
- and then Right_Len /= Uint_Minus_1
- and then Left_Len /= Right_Len
- then
- -- AI12-0201: comparison of string is static in Ada 202x
+ if Left_Len /= Uint_Minus_1
+ and then Right_Len /= Uint_Minus_1
+ and then Left_Len /= Right_Len
+ then
+ -- AI12-0201: comparison of string is static in Ada 202x
- Fold_Uint
- (N,
- Test (Nkind (N) = N_Op_Ne),
- Static => Ada_Version >= Ada_2020
- and then Is_String_Type (Left_Typ));
- Warn_On_Known_Condition (N);
- return;
- end if;
+ Fold_Uint
+ (N,
+ Test (Nkind (N) = N_Op_Ne),
+ Static => Ada_Version >= Ada_2020
+ and then Is_String_Type (Left_Typ));
+ Warn_On_Known_Condition (N);
+ return;
end if;
+ end if;
-- General case
- else
- -- Initialize the value of Is_Static_Expression. The value of Fold
- -- returned by Test_Expression_Is_Foldable is not needed since, even
- -- when some operand is a variable, we can still perform the static
- -- evaluation of the expression in some cases (for example, for a
- -- variable of a subtype of Integer we statically know that any value
- -- stored in such variable is smaller than Integer'Last).
-
- Test_Expression_Is_Foldable
- (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 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.
-
- if Is_String_Type (Left_Typ) then
- if Ada_Version < Ada_2020
- and then (Comes_From_Source (N)
- or else Nkind (N) not in N_Op_Eq | N_Op_Ne)
- then
- Is_Static_Expression := False;
- Set_Is_Static_Expression (N, False);
- end if;
+ -- Initialize the value of Is_Static_Expression. The value of Fold
+ -- returned by Test_Expression_Is_Foldable is not needed since, even
+ -- when some operand is a variable, we can still perform the static
+ -- evaluation of the expression in some cases (for example, for a
+ -- variable of a subtype of Integer we statically know that any value
+ -- stored in such variable is smaller than Integer'Last).
- elsif not Is_Scalar_Type (Left_Typ) then
+ Test_Expression_Is_Foldable
+ (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
+ -- 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.
+
+ if Is_String_Type (Left_Typ) then
+ if Ada_Version < Ada_2020
+ and then (Comes_From_Source (N)
+ or else Nkind (N) not in N_Op_Eq | N_Op_Ne)
+ then
Is_Static_Expression := False;
Set_Is_Static_Expression (N, False);
end if;
- -- For operators on universal numeric types called as functions with
- -- an explicit scope, determine appropriate specific numeric type,
- -- and diagnose possible ambiguity.
+ elsif not Is_Scalar_Type (Left_Typ) then
+ Is_Static_Expression := False;
+ Set_Is_Static_Expression (N, False);
+ end if;
- if Is_Universal_Numeric_Type (Left_Typ)
- and then
- Is_Universal_Numeric_Type (Right_Typ)
- then
- Op_Typ := Find_Universal_Operator_Type (N);
- end if;
+ -- For operators on universal numeric types called as functions with an
+ -- explicit scope, determine appropriate specific numeric type, and
+ -- diagnose possible ambiguity.
+
+ if Is_Universal_Numeric_Type (Left_Typ)
+ and then
+ Is_Universal_Numeric_Type (Right_Typ)
+ then
+ Op_Typ := Find_Universal_Operator_Type (N);
+ end if;
- -- Attempt to fold the relational operator
+ -- Attempt to fold the relational operator
- if Is_Static_Expression and then Is_Real_Type (Left_Typ) then
- Fold_Static_Real_Op;
- else
- Fold_General_Op (Is_Static_Expression);
- end if;
+ if Is_Static_Expression and then Is_Real_Type (Left_Typ) then
+ Fold_Static_Real_Op;
+ else
+ Fold_General_Op (Is_Static_Expression);
end if;
-- For the case of a folded relational operator on a specific numeric
@@ -3820,6 +3825,24 @@ package body Sem_Eval is
Warn_On_Known_Condition (N);
end Eval_Relational_Op;
+ -----------------------------
+ -- Eval_Selected_Component --
+ -----------------------------
+
+ procedure Eval_Selected_Component (N : Node_Id) is
+ begin
+ -- If an attribute reference or a LHS, nothing to do.
+ -- Also do not fold if N is an [in] out subprogram parameter.
+ -- Fold will perform the other relevant tests.
+
+ if Nkind (Parent (N)) /= N_Attribute_Reference
+ and then Is_LHS (N) = No
+ and then not Is_Actual_Out_Or_In_Out_Parameter (N)
+ then
+ Fold (N);
+ end if;
+ end Eval_Selected_Component;
+
----------------
-- Eval_Shift --
----------------
@@ -3944,6 +3967,7 @@ package body Sem_Eval is
procedure Eval_Slice (N : Node_Id) is
Drange : constant Node_Id := Discrete_Range (N);
+ Name : constant Node_Id := Prefix (N);
begin
if Nkind (Drange) = N_Range then
@@ -3955,13 +3979,13 @@ package body Sem_Eval is
-- the type of A, is redundant, the slice can be replaced with A, and
-- this is worth a warning.
- if Is_Entity_Name (Prefix (N)) then
+ if Is_Entity_Name (Name) then
declare
- E : constant Entity_Id := Entity (Prefix (N));
+ E : constant Entity_Id := Entity (Name);
T : constant Entity_Id := Etype (E);
begin
- if Ekind (E) = E_Constant
+ if Is_Object (E)
and then Is_Array_Type (T)
and then Is_Entity_Name (Drange)
then
@@ -4360,8 +4384,62 @@ package body Sem_Eval is
-- processing is to check for a non-static context for the operand.
procedure Eval_Unchecked_Conversion (N : Node_Id) is
+ Target_Type : constant Entity_Id := Etype (N);
+ Operand : constant Node_Id := Expression (N);
+ Operand_Type : constant Entity_Id := Etype (Operand);
+
begin
- Check_Non_Static_Context (Expression (N));
+ Check_Non_Static_Context (Operand);
+
+ -- If we have a conversion of a compile time known value to a target
+ -- type and the value is in range of the target type, then we can simply
+ -- replace the construct by an integer literal of the correct type. We
+ -- only apply this to discrete types being converted. Possibly it may
+ -- apply in other cases, but it is too much trouble to worry about.
+
+ -- Note that we do not do this transformation if the Kill_Range_Check
+ -- flag is set, since then the value may be outside the expected range.
+ -- This happens in the Normalize_Scalars case.
+
+ -- We also skip this if either the target or operand type is biased
+ -- because in this case, the unchecked conversion is supposed to
+ -- preserve the bit pattern, not the integer value.
+
+ if Is_Integer_Type (Target_Type)
+ and then not Has_Biased_Representation (Target_Type)
+ and then Is_Discrete_Type (Operand_Type)
+ and then not Has_Biased_Representation (Operand_Type)
+ and then Compile_Time_Known_Value (Operand)
+ and then not Kill_Range_Check (N)
+ then
+ declare
+ Val : constant Uint := Expr_Rep_Value (Operand);
+
+ begin
+ if Compile_Time_Known_Value (Type_Low_Bound (Target_Type))
+ and then
+ Compile_Time_Known_Value (Type_High_Bound (Target_Type))
+ and then
+ Val >= Expr_Value (Type_Low_Bound (Target_Type))
+ and then
+ Val <= Expr_Value (Type_High_Bound (Target_Type))
+ then
+ Rewrite (N, Make_Integer_Literal (Sloc (N), Val));
+
+ -- If Address is the target type, just set the type to avoid a
+ -- spurious type error on the literal when Address is a visible
+ -- integer type.
+
+ if Is_Descendant_Of_Address (Target_Type) then
+ Set_Etype (N, Target_Type);
+ else
+ Analyze_And_Resolve (N, Target_Type);
+ end if;
+
+ return;
+ end if;
+ end;
+ end if;
end Eval_Unchecked_Conversion;
--------------------
@@ -4434,6 +4512,15 @@ package body Sem_Eval is
elsif Kind = N_Unchecked_Type_Conversion then
return Expr_Rep_Value (Expression (N));
+ -- Static discriminant value
+
+ elsif Is_Static_Discriminant_Component (N) then
+ return Expr_Rep_Value
+ (Get_Discriminant_Value
+ (Entity (Selector_Name (N)),
+ Etype (Prefix (N)),
+ Discriminant_Constraint (Etype (Prefix (N)))));
+
else
raise Program_Error;
end if;
@@ -4521,6 +4608,15 @@ package body Sem_Eval is
elsif Kind = N_Unchecked_Type_Conversion then
Val := Expr_Value (Expression (N));
+ -- Static discriminant value
+
+ elsif Is_Static_Discriminant_Component (N) then
+ Val := Expr_Value
+ (Get_Discriminant_Value
+ (Entity (Selector_Name (N)),
+ Etype (Prefix (N)),
+ Discriminant_Constraint (Etype (Prefix (N)))));
+
else
raise Program_Error;
end if;
@@ -4748,6 +4844,32 @@ package body Sem_Eval is
end if;
end Flag_Non_Static_Expr;
+ ----------
+ -- Fold --
+ ----------
+
+ procedure Fold (N : Node_Id) is
+ Typ : constant Entity_Id := Etype (N);
+ begin
+ -- If not known at compile time or if already a literal, nothing to do
+
+ if Nkind (N) in N_Numeric_Or_String_Literal
+ or else not Compile_Time_Known_Value (N)
+ then
+ null;
+
+ elsif Is_Discrete_Type (Typ) then
+ Fold_Uint (N, Expr_Value (N), Static => Is_Static_Expression (N));
+
+ elsif Is_Real_Type (Typ) then
+ Fold_Ureal (N, Expr_Value_R (N), Static => Is_Static_Expression (N));
+
+ elsif Is_String_Type (Typ) then
+ Fold_Str
+ (N, Strval (Expr_Value_S (N)), Static => Is_Static_Expression (N));
+ end if;
+ end Fold;
+
----------------
-- Fold_Dummy --
----------------
@@ -4786,7 +4908,7 @@ package body Sem_Eval is
Static : Boolean := False;
Check_Elab : Boolean := False)
is
- Typ : constant Entity_Id := Etype (Left);
+ Typ : constant Entity_Id := Base_Type (Etype (Left));
procedure Check_Elab_Call;
-- Add checks related to calls in elaboration code
@@ -4806,6 +4928,8 @@ package body Sem_Eval is
end if;
end Check_Elab_Call;
+ Modulus : Uint;
+
begin
if Compile_Time_Known_Value (Left)
and then Compile_Time_Known_Value (Right)
@@ -4815,30 +4939,55 @@ package body Sem_Eval is
if Op = N_Op_Shift_Left then
Check_Elab_Call;
- -- Fold Shift_Left (X, Y) by computing (X * 2**Y) rem modulus
+ declare
+ Modulus : Uint;
+ begin
+ if Is_Modular_Integer_Type (Typ) then
+ Modulus := Einfo.Modulus (Typ);
+ else
+ Modulus := Uint_2 ** RM_Size (Typ);
+ end if;
+
+ -- Fold Shift_Left (X, Y) by computing (X * 2**Y) rem modulus
- Fold_Uint
- (N,
- (Expr_Value (Left) * (Uint_2 ** Expr_Value (Right)))
- rem Modulus (Typ),
- Static => Static);
+ Fold_Uint
+ (N,
+ (Expr_Value (Left) * (Uint_2 ** Expr_Value (Right)))
+ rem Modulus,
+ Static => Static);
+ end;
elsif Op = N_Op_Shift_Right then
Check_Elab_Call;
- -- Fold Shift_Right (X, Y) by computing abs X / 2**Y
+ -- X >> 0 is a no-op
- Fold_Uint
- (N,
- abs Expr_Value (Left) / (Uint_2 ** Expr_Value (Right)),
- Static => Static);
+ if Expr_Value (Right) = Uint_0 then
+ Fold_Uint (N, Expr_Value (Left), Static => Static);
+ else
+ if Is_Modular_Integer_Type (Typ) then
+ Modulus := Einfo.Modulus (Typ);
+ else
+ Modulus := Uint_2 ** RM_Size (Typ);
+ end if;
+
+ -- Fold X >> Y by computing (X [+ Modulus]) / 2**Y
+ -- Note that after a Shift_Right operation (with Y > 0), the
+ -- result is always positive, even if the original operand was
+ -- negative.
+ Fold_Uint
+ (N,
+ (Expr_Value (Left) +
+ (if Expr_Value (Left) >= Uint_0 then Uint_0 else Modulus))
+ / (Uint_2 ** Expr_Value (Right)),
+ Static => Static);
+ end if;
elsif Op = N_Op_Shift_Right_Arithmetic then
Check_Elab_Call;
declare
Two_Y : constant Uint := Uint_2 ** Expr_Value (Right);
- Modulus : Uint;
begin
if Is_Modular_Integer_Type (Typ) then
Modulus := Einfo.Modulus (Typ);
@@ -6301,11 +6450,13 @@ package body Sem_Eval is
if Subtypes_Statically_Match (T1, T2) then
return True;
- -- If either subtype is nonstatic then they're not compatible
+ -- A scalar subtype S1 is compatible with S2 if their bounds
+ -- are static and compatible, even if S1 has dynamic predicates
+ -- and is thus non-static. Predicate compatibility has been
+ -- checked above.
- elsif not Is_OK_Static_Subtype (T1)
- or else
- not Is_OK_Static_Subtype (T2)
+ elsif not Is_Static_Range (Scalar_Range (T1))
+ or else not Is_Static_Range (Scalar_Range (T2))
then
return False;
@@ -6353,6 +6504,14 @@ package body Sem_Eval is
and then not (Can_Never_Be_Null (T2)
and then not Can_Never_Be_Null (T1));
+ -- Private types without discriminants can be handled specially.
+ -- Predicate matching has been checked above.
+
+ elsif Is_Private_Type (T1)
+ and then not Has_Discriminants (T1)
+ then
+ return not Has_Discriminants (T2);
+
-- All other cases
else
@@ -7318,7 +7477,7 @@ package body Sem_Eval is
elsif Ekind (E) = E_Constant then
- -- One case we can give a metter message is when we have a
+ -- One case we can give a better message is when we have a
-- string literal created by concatenating an aggregate with
-- an others expression.
diff --git a/gcc/ada/sem_eval.ads b/gcc/ada/sem_eval.ads
index 76e4bdf..972cee6 100644
--- a/gcc/ada/sem_eval.ads
+++ b/gcc/ada/sem_eval.ads
@@ -330,6 +330,7 @@ package Sem_Eval is
procedure Eval_Op_Not (N : Node_Id);
procedure Eval_Real_Literal (N : Node_Id);
procedure Eval_Relational_Op (N : Node_Id);
+ procedure Eval_Selected_Component (N : Node_Id);
procedure Eval_Shift (N : Node_Id);
procedure Eval_Short_Circuit (N : Node_Id);
procedure Eval_Slice (N : Node_Id);
@@ -387,6 +388,10 @@ package Sem_Eval is
-- The call has no effect if Raises_Constraint_Error (N) is True, since
-- there is no point in folding if we have an error.
+ procedure Fold (N : Node_Id);
+ -- Rewrite N with the relevant value if Compile_Time_Known_Value (N) is
+ -- True, otherwise a no-op.
+
function Is_In_Range
(N : Node_Id;
Typ : Entity_Id;
diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
index 1e1a279..3ef5e82 100644
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -466,7 +466,7 @@ package body Sem_Prag is
if Nkind (Case_Guard) = N_Others_Choice then
if Others_Seen then
Error_Msg_N
- ("only one others choice allowed in contract cases",
+ ("only one OTHERS choice allowed in contract cases",
Case_Guard);
else
Others_Seen := True;
@@ -474,7 +474,7 @@ package body Sem_Prag is
elsif Others_Seen then
Error_Msg_N
- ("others must be the last choice in contract cases", N);
+ ("OTHERS must be the last choice in contract cases", N);
end if;
-- Preanalyze the case guard and consequence
@@ -545,16 +545,31 @@ package body Sem_Prag is
-- Single and multiple contract cases must appear in aggregate form. If
-- this is not the case, then either the parser or the analysis of the
- -- pragma failed to produce an aggregate.
+ -- pragma failed to produce an aggregate, e.g. when the contract is
+ -- "null" or a "(null record)".
- pragma Assert (Nkind (CCases) = N_Aggregate);
+ pragma Assert
+ (if Nkind (CCases) = N_Aggregate
+ then Null_Record_Present (CCases)
+ xor (Present (Component_Associations (CCases))
+ or
+ Present (Expressions (CCases)))
+ else Nkind (CCases) = N_Null);
-- Only CASE_GUARD => CONSEQUENCE clauses are allowed
- if Present (Component_Associations (CCases))
+ if Nkind (CCases) = N_Aggregate
+ and then Present (Component_Associations (CCases))
and then No (Expressions (CCases))
then
+ -- Check that the expression is a proper aggregate (no parentheses)
+
+ if Paren_Count (CCases) /= 0 then
+ Error_Msg -- CODEFIX
+ ("redundant parentheses", First_Sloc (CCases));
+ end if;
+
-- Ensure that the formal parameters are visible when analyzing all
-- clauses. This falls out of the general rule of aspects pertaining
-- to subprogram declarations.
@@ -1267,9 +1282,9 @@ package body Sem_Prag is
(Item_Is_Input : out Boolean;
Item_Is_Output : out Boolean)
is
- -- A constant or IN parameter of access type should be handled
- -- like a variable, as the underlying memory pointed-to can be
- -- modified. Use Adjusted_Kind to do this adjustment.
+ -- A constant or IN parameter of 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);
@@ -1277,7 +1292,7 @@ package body Sem_Prag is
if Ekind (Item_Id) in E_Constant
| E_Generic_In_Parameter
| E_In_Parameter
- and then Is_Access_Type (Etype (Item_Id))
+ and then Is_Access_Variable (Etype (Item_Id))
then
Adjusted_Kind := E_Variable;
end if;
@@ -1975,7 +1990,7 @@ package body Sem_Prag is
-- clause as this will lead to misleading errors.
if Has_Extra_Parentheses (Deps) then
- return;
+ goto Leave;
end if;
if Present (Component_Associations (Deps)) then
@@ -2066,7 +2081,7 @@ package body Sem_Prag is
else
Error_Msg_N ("malformed dependency relation", Deps);
- return;
+ goto Leave;
end if;
-- The top level dependency relation is malformed. This is a syntax
@@ -2383,9 +2398,9 @@ package body Sem_Prag is
("global item must denote object, state or current "
& "instance of concurrent type", Item);
- if Ekind (Item_Id) in Named_Kind then
+ if Is_Named_Number (Item_Id) then
SPARK_Msg_NE
- ("\named number & is not an object", Item, Item);
+ ("\named number & is not an object", Item, Item_Id);
end if;
return;
@@ -2476,11 +2491,22 @@ package body Sem_Prag is
and then Ekind (Item_Id) = E_Variable
and then Is_Effectively_Volatile_For_Reading (Item_Id)
then
+ -- The current instance of a protected unit is not an
+ -- effectively volatile object, unless the protected unit
+ -- is already volatile for another reason (SPARK RM 7.1.2).
+
+ if Is_Single_Protected_Object (Item_Id)
+ and then Is_CCT_Instance (Etype (Item_Id), Spec_Id)
+ and then not Is_Effectively_Volatile_For_Reading
+ (Item_Id, Ignore_Protected => True)
+ then
+ null;
+
-- An effectively volatile object for reading cannot appear
-- as a global item of a nonvolatile function (SPARK RM
-- 7.1.3(8)).
- if Ekind (Spec_Id) in E_Function | E_Generic_Function
+ elsif Ekind (Spec_Id) in E_Function | E_Generic_Function
and then not Is_Volatile_Function (Spec_Id)
then
Error_Msg_NE
@@ -4062,7 +4088,8 @@ package body Sem_Prag is
-- than library level instantiations these can appear in contexts which
-- would normally be invalid (they only apply to the original template
-- and to library level instantiations), and they are simply ignored,
- -- which is implemented by rewriting them as null statements.
+ -- which is implemented by rewriting them as null statements and raising
+ -- exception to terminate analysis.
procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id);
-- Check an Unchecked_Union variant for lack of nested variants and
@@ -4437,7 +4464,17 @@ package body Sem_Prag is
-- Subprogram declaration
elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
- null;
+
+ -- Pragmas Global and Depends are forbidden on null procedures
+ -- (SPARK RM 6.1.2(2)).
+
+ if Nkind (Specification (Subp_Decl)) = N_Procedure_Specification
+ and then Null_Present (Specification (Subp_Decl))
+ then
+ Error_Msg_N (Fix_Error
+ ("pragma % cannot apply to null procedure"), N);
+ return;
+ end if;
-- Task type
@@ -6069,7 +6106,7 @@ package body Sem_Prag is
-- The group and the current pragma are not in the same
-- declarative or statement list.
- if List_Containing (Stmt) /= List_Containing (N) then
+ if not In_Same_List (Stmt, N) then
Grouping_Error (Stmt);
-- Try to reach the current pragma from the first pragma
@@ -6173,17 +6210,15 @@ package body Sem_Prag is
--------------------
function Is_Loop_Pragma (Stmt : Node_Id) return Boolean is
+ Original_Stmt : constant Node_Id := Original_Node (Stmt);
+
begin
-- Inspect the original node as Loop_Invariant and Loop_Variant
-- pragmas are rewritten to null when assertions are disabled.
- if Nkind (Original_Node (Stmt)) = N_Pragma then
- return
- Pragma_Name_Unmapped (Original_Node (Stmt))
+ return Nkind (Original_Stmt) = N_Pragma
+ and then Pragma_Name_Unmapped (Original_Stmt)
in Name_Loop_Invariant | Name_Loop_Variant;
- else
- return False;
- end if;
end Is_Loop_Pragma;
---------------------
@@ -6567,7 +6602,7 @@ package body Sem_Prag is
if Loc not in Source_First (Sindex) .. Source_Last (Sindex) then
Rewrite (N, Make_Null_Statement (Loc));
- return;
+ raise Pragma_Exit;
-- If before first declaration, the pragma applies to the
-- enclosing unit, and the name if present must be this name.
@@ -8100,7 +8135,7 @@ package body Sem_Prag is
-- Check that we are not applying this to a named constant
- if Ekind (E) in E_Named_Integer | E_Named_Real then
+ if Is_Named_Number (E) then
Error_Msg_Name_1 := Pname;
Error_Msg_N
("cannot apply pragma% to named constant!",
@@ -8841,7 +8876,7 @@ package body Sem_Prag is
Error_Pragma ("at least one parameter required for pragma%");
elsif Ekind (Formal) /= E_Out_Parameter then
- Error_Pragma ("first parameter must have mode out for pragma%");
+ Error_Pragma ("first parameter must have mode OUT for pragma%");
else
Set_Is_Valued_Procedure (Ent);
@@ -9866,7 +9901,7 @@ package body Sem_Prag is
-- the test will have been applied to the original generic.
elsif Nkind (Decl) in N_Formal_Subprogram_Declaration
- and then List_Containing (Decl) = List_Containing (N)
+ and then In_Same_List (Decl, N)
and then not In_Instance
then
Error_Msg_N
@@ -10418,10 +10453,13 @@ package body Sem_Prag is
Add_To_Config_Boolean_Restrictions (No_Elaboration_Code);
end if;
- -- Special processing for No_Tasking restriction placed in
- -- a configuration pragmas file.
+ -- Special processing for No_Tasking restriction (not just a
+ -- warning) when it appears as a configuration pragma.
- elsif R_Id = No_Tasking and then No (Cunit (Main_Unit)) then
+ elsif R_Id = No_Tasking
+ and then No (Cunit (Main_Unit))
+ and then not Warn
+ then
Set_Global_No_Tasking;
end if;
@@ -11343,19 +11381,26 @@ package body Sem_Prag is
-- Deal with unrecognized pragma
if not Is_Pragma_Name (Pname) then
- if Warn_On_Unrecognized_Pragma then
- Error_Msg_Name_1 := Pname;
- Error_Msg_N ("?g?unrecognized pragma%!", Pragma_Identifier (N));
-
- for PN in First_Pragma_Name .. Last_Pragma_Name loop
- if Is_Bad_Spelling_Of (Pname, PN) then
- Error_Msg_Name_1 := PN;
- Error_Msg_N -- CODEFIX
- ("\?g?possible misspelling of %!", Pragma_Identifier (N));
- exit;
- end if;
- end loop;
- end if;
+ declare
+ Msg_Issued : Boolean := False;
+ begin
+ Check_Restriction
+ (Msg_Issued, No_Unrecognized_Pragmas, Pragma_Identifier (N));
+ if not Msg_Issued and then Warn_On_Unrecognized_Pragma then
+ Error_Msg_Name_1 := Pname;
+ Error_Msg_N ("?g?unrecognized pragma%!", Pragma_Identifier (N));
+
+ for PN in First_Pragma_Name .. Last_Pragma_Name loop
+ if Is_Bad_Spelling_Of (Pname, PN) then
+ Error_Msg_Name_1 := PN;
+ Error_Msg_N -- CODEFIX
+ ("\?g?possible misspelling of %!",
+ Pragma_Identifier (N));
+ exit;
+ end if;
+ end loop;
+ end if;
+ end;
return;
end if;
@@ -11411,6 +11456,12 @@ package body Sem_Prag is
end if;
end if;
+ -- Mark assertion pragmas as Ghost depending on their enclosing context
+
+ if Assertion_Expression_Pragma (Prag_Id) then
+ Mark_Ghost_Pragma (N, Current_Scope);
+ end if;
+
-- Preset arguments
Arg_Count := 0;
@@ -11711,7 +11762,7 @@ package body Sem_Prag is
if Nkind (Prop) = N_Others_Choice then
if Others_Seen then
SPARK_Msg_N
- ("only one others choice allowed in option External",
+ ("only one OTHERS choice allowed in option External",
Prop);
else
Others_Seen := True;
@@ -11719,7 +11770,7 @@ package body Sem_Prag is
elsif Others_Seen then
SPARK_Msg_N
- ("others must be the last property in option External",
+ ("OTHERS must be the last property in option External",
Prop);
-- The only remaining legal options are the four predefined
@@ -12519,10 +12570,6 @@ package body Sem_Prag is
Check_Ada_83_Warning;
Check_Valid_Library_Unit_Pragma;
- if Nkind (N) = N_Null_Statement then
- return;
- end if;
-
Lib_Entity := Find_Lib_Unit_Name;
-- A pragma that applies to a Ghost entity becomes Ghost for the
@@ -12871,30 +12918,31 @@ package body Sem_Prag is
-- ASSERTION_KIND ::= RM_ASSERTION_KIND | ID_ASSERTION_KIND
- -- RM_ASSERTION_KIND ::= Assert |
- -- Static_Predicate |
- -- Dynamic_Predicate |
- -- Pre |
- -- Pre'Class |
- -- Post |
- -- Post'Class |
- -- Type_Invariant |
- -- Type_Invariant'Class
-
- -- ID_ASSERTION_KIND ::= Assert_And_Cut |
- -- Assume |
- -- Contract_Cases |
- -- Debug |
- -- Default_Initial_Condition |
- -- Ghost |
- -- Initial_Condition |
- -- Loop_Invariant |
- -- Loop_Variant |
- -- Postcondition |
- -- Precondition |
- -- Predicate |
- -- Refined_Post |
- -- Statement_Assertions
+ -- RM_ASSERTION_KIND ::= Assert |
+ -- Static_Predicate |
+ -- Dynamic_Predicate |
+ -- Pre |
+ -- Pre'Class |
+ -- Post |
+ -- Post'Class |
+ -- Type_Invariant |
+ -- Type_Invariant'Class |
+ -- Default_Initial_Condition
+
+ -- ID_ASSERTION_KIND ::= Assert_And_Cut |
+ -- Assume |
+ -- Contract_Cases |
+ -- Debug |
+ -- Ghost |
+ -- Initial_Condition |
+ -- Loop_Invariant |
+ -- Loop_Variant |
+ -- Postcondition |
+ -- Precondition |
+ -- Predicate |
+ -- Refined_Post |
+ -- Statement_Assertions |
+ -- Subprogram_Variant
-- Note: The RM_ASSERTION_KIND list is language-defined, and the
-- ID_ASSERTION_KIND list contains implementation-defined additions
@@ -15079,7 +15127,7 @@ package body Sem_Prag is
begin
GNAT_Pragma;
Check_No_Identifiers;
- Check_At_Most_N_Arguments (1);
+ Check_At_Most_N_Arguments (2); -- Accounts for implicit type arg
Typ := Empty;
Stmt := Prev (N);
@@ -15142,6 +15190,27 @@ package body Sem_Prag is
Set_Has_Own_DIC (Typ);
+ -- A type entity argument is appended to facilitate inheriting the
+ -- aspect/pragma from parent types (see Build_DIC_Procedure_Body),
+ -- though that extra argument isn't documented for the pragma.
+
+ if not Present (Arg2) then
+ -- When the pragma has no arguments, create an argument with
+ -- the value Empty, so the type name argument can be appended
+ -- following it (since it's expected as the second argument).
+
+ if not Present (Arg1) then
+ Set_Pragma_Argument_Associations (N, New_List (
+ Make_Pragma_Argument_Association (Sloc (Typ),
+ Expression => Empty)));
+ end if;
+
+ Append_To
+ (Pragma_Argument_Associations (N),
+ Make_Pragma_Argument_Association (Sloc (Typ),
+ Expression => New_Occurrence_Of (Typ, Sloc (Typ))));
+ end if;
+
-- Chain the pragma on the rep item chain for further processing
Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
@@ -15713,10 +15782,6 @@ package body Sem_Prag is
Check_Ada_83_Warning;
Check_Valid_Library_Unit_Pragma;
- if Nkind (N) = N_Null_Statement then
- return;
- end if;
-
Cunit_Node := Cunit (Current_Sem_Unit);
Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
@@ -18508,7 +18573,7 @@ package body Sem_Prag is
-- The pragma defines a type-specific invariant, the type is said
-- to have invariants of its "own".
- Set_Has_Own_Invariants (Typ);
+ Set_Has_Own_Invariants (Base_Type (Typ));
-- If the invariant is class-wide, then it can be inherited by
-- derived or interface implementing types. The type is said to
@@ -19421,10 +19486,6 @@ package body Sem_Prag is
GNAT_Pragma;
Check_Valid_Library_Unit_Pragma;
- if Nkind (N) = N_Null_Statement then
- return;
- end if;
-
-- Must appear for a spec or generic spec
if Nkind (Unit (Cunit (Current_Sem_Unit))) not in
@@ -19646,7 +19707,53 @@ package body Sem_Prag is
-- pragma No_Return (procedure_LOCAL_NAME {, procedure_Local_Name});
- when Pragma_No_Return => No_Return : declare
+ when Pragma_No_Return => Prag_No_Return : declare
+
+ function Check_No_Return
+ (E : Entity_Id;
+ N : Node_Id) return Boolean;
+ -- Check rule 6.5.1(4/3) of the Ada RM. If the rule is violated,
+ -- emit an error message and return False, otherwise return True.
+ -- 6.5.1 Nonreturning procedures:
+ -- 4/3 "Aspect No_Return shall not be specified for a null
+ -- procedure nor an instance of a generic unit."
+
+ ---------------------
+ -- Check_No_Return --
+ ---------------------
+
+ function Check_No_Return
+ (E : Entity_Id;
+ N : Node_Id) return Boolean
+ is
+ begin
+ if Ekind (E) = E_Procedure then
+
+ -- If E is a generic instance, marking it with No_Return
+ -- is forbidden, but having it inherit the No_Return of
+ -- the generic is allowed. We check if E is inheriting its
+ -- No_Return flag from the generic by checking if No_Return
+ -- is already set.
+
+ if Is_Generic_Instance (E) and then not No_Return (E) then
+ Error_Msg_NE
+ ("generic instance & is marked as No_Return", N, E);
+ Error_Msg_NE
+ ("\generic procedure & must be marked No_Return",
+ N,
+ Generic_Parent (Parent (E)));
+ return False;
+
+ elsif Null_Present (Subprogram_Specification (E)) then
+ Error_Msg_NE
+ ("null procedure & cannot be marked No_Return", N, E);
+ return False;
+ end if;
+ end if;
+
+ return True;
+ end Check_No_Return;
+
Arg : Node_Id;
E : Entity_Id;
Found : Boolean;
@@ -19718,7 +19825,9 @@ package body Sem_Prag is
end if;
end if;
- Set_No_Return (E);
+ if Check_No_Return (E, N) then
+ Set_No_Return (E);
+ end if;
-- A pragma that applies to a Ghost entity becomes Ghost
-- for the purposes of legality checks and removal of
@@ -19757,7 +19866,10 @@ package body Sem_Prag is
-- Set flag on any alias as well
- if Is_Overloadable (E) and then Present (Alias (E)) then
+ if Is_Overloadable (E)
+ and then Present (Alias (E))
+ and then Check_No_Return (Alias (E), N)
+ then
Set_No_Return (Alias (E));
end if;
@@ -19774,6 +19886,7 @@ package body Sem_Prag is
if not Found then
if Entity (Id) = Current_Scope
and then From_Aspect_Specification (N)
+ and then Check_No_Return (Entity (Id), N)
then
Set_No_Return (Entity (Id));
@@ -19788,7 +19901,7 @@ package body Sem_Prag is
Next (Arg);
end loop;
- end No_Return;
+ end Prag_No_Return;
-----------------
-- No_Run_Time --
@@ -21158,10 +21271,6 @@ package body Sem_Prag is
Check_Ada_83_Warning;
Check_Valid_Library_Unit_Pragma;
- if Nkind (N) = N_Null_Statement then
- return;
- end if;
-
Ent := Find_Lib_Unit_Name;
-- A pragma that applies to a Ghost entity becomes Ghost for the
@@ -21270,16 +21379,11 @@ package body Sem_Prag is
-- package does not trigger the required initialization of the
-- run-time library.
- declare
- Discard : Entity_Id;
- pragma Warnings (Off, Discard);
- begin
- if Restricted_Profile then
- Discard := RTE (RE_Activate_Restricted_Tasks);
- else
- Discard := RTE (RE_Activate_Tasks);
- end if;
- end;
+ if Restricted_Profile then
+ Discard_Node (RTE (RE_Activate_Restricted_Tasks));
+ else
+ Discard_Node (RTE (RE_Activate_Tasks));
+ end if;
-- Task or Protected, must be of type Integer
@@ -21462,7 +21566,11 @@ package body Sem_Prag is
Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
begin
- if Chars (Argx) = Name_Ravenscar then
+ if Nkind (Argx) /= N_Identifier then
+ Error_Msg_N
+ ("argument of pragma Profile must be an identifier", N);
+
+ elsif Chars (Argx) = Name_Ravenscar then
Set_Ravenscar_Profile (Ravenscar, N);
elsif Chars (Argx) = Name_Jorvik then
@@ -21803,10 +21911,6 @@ package body Sem_Prag is
Check_Valid_Library_Unit_Pragma;
end if;
- if Nkind (N) = N_Null_Statement then
- return;
- end if;
-
Ent := Find_Lib_Unit_Name;
-- A pragma that applies to a Ghost entity becomes Ghost for the
@@ -22343,10 +22447,6 @@ package body Sem_Prag is
Check_Ada_83_Warning;
Check_Valid_Library_Unit_Pragma;
- if Nkind (N) = N_Null_Statement then
- return;
- end if;
-
Cunit_Node := Cunit (Current_Sem_Unit);
K := Nkind (Unit (Cunit_Node));
Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
@@ -22386,10 +22486,6 @@ package body Sem_Prag is
Check_Ada_83_Warning;
Check_Valid_Library_Unit_Pragma;
- if Nkind (N) = N_Null_Statement then
- return;
- end if;
-
Cunit_Node := Cunit (Current_Sem_Unit);
Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
@@ -22586,10 +22682,6 @@ package body Sem_Prag is
Check_Ada_83_Warning;
Check_Valid_Library_Unit_Pragma;
- if Nkind (N) = N_Null_Statement then
- return;
- end if;
-
Cunit_Node := Cunit (Current_Sem_Unit);
Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
@@ -24773,18 +24865,15 @@ package body Sem_Prag is
-- body, not in the spec).
when Pragma_Unimplemented_Unit => Unimplemented_Unit : declare
- Cunitent : constant Entity_Id :=
+ Cunitent : constant Entity_Id :=
Cunit_Entity (Get_Source_Unit (Loc));
- Ent_Kind : constant Entity_Kind := Ekind (Cunitent);
begin
GNAT_Pragma;
Check_Arg_Count (0);
if Operating_Mode = Generate_Code
- or else Ent_Kind = E_Generic_Function
- or else Ent_Kind = E_Generic_Procedure
- or else Ent_Kind = E_Generic_Package
+ or else Is_Generic_Unit (Cunitent)
then
Get_Name_String (Chars (Cunitent));
Set_Casing (Mixed_Case);
@@ -28414,35 +28503,69 @@ package body Sem_Prag is
Constit, Encapsulating_State (Constit_Id));
end if;
- -- The only other source of legal constituents is the body
- -- state space of the related package.
-
else
- if Present (Body_States) then
- State_Elmt := First_Elmt (Body_States);
- while Present (State_Elmt) loop
+ declare
+ Pack_Id : Entity_Id;
+ Placement : State_Space_Kind;
+ begin
+ -- Find where the constituent lives with respect to the
+ -- state space.
- -- Consume a valid constituent to signal that it has
- -- been encountered.
+ Find_Placement_In_State_Space
+ (Item_Id => Constit_Id,
+ Placement => Placement,
+ Pack_Id => Pack_Id);
- if Node (State_Elmt) = Constit_Id then
- Remove_Elmt (Body_States, State_Elmt);
- Collect_Constituent;
- return;
- end if;
+ -- The constituent is part of the visible state of a
+ -- private child package, but lacks a Part_Of indicator.
- Next_Elmt (State_Elmt);
- end loop;
- end if;
+ if Placement = Visible_State_Space
+ and then Is_Child_Unit (Pack_Id)
+ and then not Is_Generic_Unit (Pack_Id)
+ and then Is_Private_Descendant (Pack_Id)
+ then
+ Error_Msg_Name_1 := Chars (State_Id);
+ SPARK_Msg_NE
+ ("& cannot act as constituent of state %",
+ Constit, Constit_Id);
+ Error_Msg_Sloc :=
+ Sloc (Enclosing_Declaration (Constit_Id));
+ SPARK_Msg_NE
+ ("\missing Part_Of indicator # should specify "
+ & "encapsulator &",
+ Constit, State_Id);
- -- At this point it is known that the constituent is not
- -- part of the package hidden state and cannot be used in
- -- a refinement (SPARK RM 7.2.2(9)).
+ -- The only other source of legal constituents is the
+ -- body state space of the related package.
- Error_Msg_Name_1 := Chars (Spec_Id);
- SPARK_Msg_NE
- ("cannot use & in refinement, constituent is not a hidden "
- & "state of package %", Constit, Constit_Id);
+ else
+ if Present (Body_States) then
+ State_Elmt := First_Elmt (Body_States);
+ while Present (State_Elmt) loop
+
+ -- Consume a valid constituent to signal that it
+ -- has been encountered.
+
+ if Node (State_Elmt) = Constit_Id then
+ Remove_Elmt (Body_States, State_Elmt);
+ Collect_Constituent;
+ return;
+ end if;
+
+ Next_Elmt (State_Elmt);
+ end loop;
+ end if;
+
+ -- At this point it is known that the constituent is
+ -- not part of the package hidden state and cannot be
+ -- used in a refinement (SPARK RM 7.2.2(9)).
+
+ Error_Msg_Name_1 := Chars (Spec_Id);
+ SPARK_Msg_NE
+ ("cannot use & in refinement, constituent is not a "
+ & "hidden state of package %", Constit, Constit_Id);
+ end if;
+ end;
end if;
end Match_Constituent;
@@ -28864,6 +28987,20 @@ package body Sem_Prag is
-- in the refinement clause.
Report_Unused_Constituents (Part_Of_Constits);
+
+ -- Avoid a cascading error reporting a missing refinement by adding a
+ -- dummy constituent.
+
+ if No (Refinement_Constituents (State_Id)) then
+ Set_Refinement_Constituents (State_Id, New_Elmt_List (Any_Id));
+ end if;
+
+ -- At this point the refinement might be dummy, but must be
+ -- well-formed, to prevent cascaded errors.
+
+ pragma Assert (Has_Null_Refinement (State_Id)
+ xor
+ Has_Non_Null_Refinement (State_Id));
end Analyze_Refinement_Clause;
-----------------------------
@@ -29048,16 +29185,31 @@ package body Sem_Prag is
-- Single and multiple contract cases must appear in aggregate form. If
-- this is not the case, then either the parser of the analysis of the
- -- pragma failed to produce an aggregate.
+ -- pragma failed to produce an aggregate, e.g. when the contract is
+ -- "null" or a "(null record)".
- pragma Assert (Nkind (Variants) = N_Aggregate);
+ pragma Assert
+ (if Nkind (Variants) = N_Aggregate
+ then Null_Record_Present (Variants)
+ xor (Present (Component_Associations (Variants))
+ or
+ Present (Expressions (Variants)))
+ else Nkind (Variants) = N_Null);
-- Only "change_direction => discrete_expression" clauses are allowed
- if Present (Component_Associations (Variants))
+ if Nkind (Variants) = N_Aggregate
+ and then Present (Component_Associations (Variants))
and then No (Expressions (Variants))
then
+ -- Check that the expression is a proper aggregate (no parentheses)
+
+ if Paren_Count (Variants) /= 0 then
+ Error_Msg -- CODEFIX
+ ("redundant parentheses", First_Sloc (Variants));
+ end if;
+
-- Ensure that the formal parameters are visible when analyzing all
-- clauses. This falls out of the general rule of aspects pertaining
-- to subprogram declarations.
@@ -30096,13 +30248,23 @@ package body Sem_Prag is
Formal := First_Entity (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;
if Ekind (Formal) in E_In_Out_Parameter | E_Out_Parameter then
Append_New_Elmt (Formal, Subp_Outputs);
- -- Out parameters can act as inputs when the related type is
+ -- OUT parameters can act as inputs when the related type is
-- tagged, unconstrained array, unconstrained record, or record
-- with unconstrained components.
@@ -30137,7 +30299,7 @@ package body Sem_Prag is
Global := Get_Pragma (Subp_Id, Pragma_Refined_Global);
-- Subprogram declaration or stand-alone body case, look for pragmas
- -- Depends and Global
+ -- Depends and Global.
else
Depends := Get_Pragma (Spec_Id, Pragma_Depends);
@@ -30381,11 +30543,11 @@ package body Sem_Prag is
if From_Aspect_Specification (Prag) then
Error_Msg_N
- ("aspect % cannot apply to a stand alone expression function",
+ ("aspect % cannot apply to a standalone expression function",
Prag);
else
Error_Msg_N
- ("pragma % cannot apply to a stand alone expression function",
+ ("pragma % cannot apply to a standalone expression function",
Prag);
end if;
end Expression_Function_Error;
@@ -30519,8 +30681,10 @@ package body Sem_Prag is
-- The pragma appears inside the statements of a subprogram body. This
-- placement is the result of subprogram contract expansion.
- elsif Nkind (Context) = N_Handled_Sequence_Of_Statements then
- return Parent (Context);
+ elsif Is_Statement (Context)
+ and then Present (Enclosing_HSS (Context))
+ then
+ return Parent (Enclosing_HSS (Context));
-- The pragma appears inside the declarative part of a package body
@@ -31417,7 +31581,6 @@ package body Sem_Prag is
-- RM defined
Name_Assert
- | Name_Assertion_Policy
| Name_Static_Predicate
| Name_Dynamic_Predicate
| Name_Pre
diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index a24c9c2..f6e0eab 100644
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -2155,6 +2155,10 @@ package body Sem_Res is
N_Real_Literal => Aspect_Real_Literal,
N_String_Literal => Aspect_String_Literal);
+ Named_Number_Aspect_Map : constant array (Named_Kind) of Aspect_Id :=
+ (E_Named_Integer => Aspect_Integer_Literal,
+ E_Named_Real => Aspect_Real_Literal);
+
-- Start of processing for Resolve
begin
@@ -2294,11 +2298,8 @@ package body Sem_Res is
-- Declare_Expression and requires scope management.
if Nkind (N) = N_Expression_With_Actions then
- if Comes_From_Source (N)
- and then N = Original_Node (N)
- then
+ if Comes_From_Source (N) and then N = Original_Node (N) then
Resolve_Declare_Expression (N, Typ);
-
else
Resolve (Expression (N), Typ);
end if;
@@ -2880,58 +2881,102 @@ package body Sem_Res is
-- Rewrite Literal as a call if the corresponding literal aspect
-- is set.
- if Nkind (N) in N_Numeric_Or_String_Literal
- and then Present
- (Find_Aspect (Typ, Literal_Aspect_Map (Nkind (N))))
+ if (Nkind (N) in N_Numeric_Or_String_Literal
+ and then
+ Present
+ (Find_Aspect (Typ, Literal_Aspect_Map (Nkind (N)))))
+ or else
+ (Nkind (N) = N_Identifier
+ and then Is_Named_Number (Entity (N))
+ and then
+ Present
+ (Find_Aspect
+ (Typ, Named_Number_Aspect_Map (Ekind (Entity (N))))))
then
declare
- function Literal_Text (N : Node_Id) return String_Id;
- -- Returns the text of a literal node
+ Lit_Aspect : constant Aspect_Id :=
+ (if Nkind (N) = N_Identifier
+ then Named_Number_Aspect_Map (Ekind (Entity (N)))
+ else Literal_Aspect_Map (Nkind (N)));
- -------------------
- -- Literal_Text --
- -------------------
+ Loc : constant Source_Ptr := Sloc (N);
- function Literal_Text (N : Node_Id) return String_Id is
- begin
- pragma Assert (Nkind (N) in N_Numeric_Or_String_Literal);
+ Callee : Entity_Id :=
+ Entity (Expression (Find_Aspect (Typ, Lit_Aspect)));
- if Nkind (N) = N_String_Literal then
- return Strval (N);
- else
- return String_From_Numeric_Literal (N);
- end if;
- end Literal_Text;
+ Name : constant Node_Id :=
+ Make_Identifier (Loc, Chars (Callee));
- Lit_Aspect : constant Aspect_Id :=
- Literal_Aspect_Map (Nkind (N));
+ Param1 : Node_Id;
+ Param2 : Node_Id;
+ Params : List_Id;
+ Call : Node_Id;
+ Expr : Node_Id;
- Callee : constant Entity_Id :=
- Entity (Expression (Find_Aspect (Typ, Lit_Aspect)));
+ begin
+ if Nkind (N) = N_Identifier then
+ Expr := Expression (Declaration_Node (Entity (N)));
- Loc : constant Source_Ptr := Sloc (N);
+ if Ekind (Entity (N)) = E_Named_Integer then
+ UI_Image (Expr_Value (Expr), Decimal);
+ Start_String;
+ Store_String_Chars
+ (UI_Image_Buffer (1 .. UI_Image_Length));
+ Param1 := Make_String_Literal (Loc, End_String);
+ Params := New_List (Param1);
- Name : constant Node_Id :=
- Make_Identifier (Loc, Chars (Callee));
+ else
+ UI_Image (Norm_Num (Expr_Value_R (Expr)), Decimal);
+ Start_String;
+ Store_String_Chars
+ (UI_Image_Buffer (1 .. UI_Image_Length));
+ Param1 := Make_String_Literal (Loc, End_String);
+
+ -- Note: Set_Etype is called below on Param1
- Param : constant Node_Id :=
- Make_String_Literal (Loc, Literal_Text (N));
+ UI_Image (Norm_Den (Expr_Value_R (Expr)), Decimal);
+ Start_String;
+ Store_String_Chars
+ (UI_Image_Buffer (1 .. UI_Image_Length));
+ Param2 := Make_String_Literal (Loc, End_String);
+ Set_Etype (Param2, Standard_String);
- Params : constant List_Id := New_List (Param);
+ Params := New_List (Param1, Param2);
+
+ if Present (Related_Expression (Callee)) then
+ Callee := Related_Expression (Callee);
+ else
+ Error_Msg_NE
+ ("cannot resolve & for a named real", N, Callee);
+ return;
+ end if;
+ end if;
+
+ elsif Nkind (N) = N_String_Literal then
+ Param1 := Make_String_Literal (Loc, Strval (N));
+ Params := New_List (Param1);
+ else
+ Param1 :=
+ Make_String_Literal
+ (Loc, String_From_Numeric_Literal (N));
+ Params := New_List (Param1);
+ end if;
- Call : Node_Id :=
+ Call :=
Make_Function_Call
(Sloc => Loc,
Name => Name,
Parameter_Associations => Params);
- begin
+
Set_Entity (Name, Callee);
Set_Is_Overloaded (Name, False);
+
if Lit_Aspect = Aspect_String_Literal then
- Set_Etype (Param, Standard_Wide_Wide_String);
+ Set_Etype (Param1, Standard_Wide_Wide_String);
else
- Set_Etype (Param, Standard_String);
+ Set_Etype (Param1, Standard_String);
end if;
+
Set_Etype (Call, Etype (Callee));
-- Conversion needed in case of an inherited aspect
@@ -2947,6 +2992,7 @@ package body Sem_Res is
Rewrite (N, Call);
end;
+
Analyze_And_Resolve (N, Typ);
return;
end if;
@@ -4634,7 +4680,7 @@ package body Sem_Res is
elsif Ada_Version >= Ada_2005 then
Apply_Compile_Time_Constraint_Error
(N => A,
- Msg => "(Ada 2005) null not allowed in "
+ Msg => "(Ada 2005) NULL not allowed in "
& "null-excluding formal??",
Reason => CE_Null_Not_Allowed);
end if;
@@ -5402,9 +5448,12 @@ package body Sem_Res is
-- Do not apply Ada 2005 accessibility checks on a class-wide
-- allocator if the type given in the allocator is a formal
- -- type. A run-time check will be performed in the instance.
+ -- type or within a formal package. A run-time check will be
+ -- performed in the instance.
- elsif not Is_Generic_Type (Exp_Typ) then
+ elsif not Is_Generic_Type (Exp_Typ)
+ and then not In_Generic_Formal_Package (Exp_Typ)
+ then
Error_Msg_N
("type in allocator has deeper level than designated "
& "class-wide type", E);
@@ -6244,7 +6293,7 @@ package body Sem_Res is
-- Normal subprogram call with name established in Resolve
- elsif not (Is_Type (Entity (Subp))) then
+ elsif not Is_Type (Entity (Subp)) then
Nam := Entity (Subp);
Set_Entity_With_Checks (Subp, Nam);
@@ -7073,10 +7122,9 @@ package body Sem_Res is
-- on expression functions.
elsif In_Assertion_Expr /= 0 then
- if Present (Body_Id) then
- Cannot_Inline
- ("cannot inline & (in assertion expression)?", N, Nam_UA);
- end if;
+ Cannot_Inline
+ ("cannot inline & (in assertion expression)?", N, Nam_UA,
+ Suppress_Info => No (Body_Id));
-- Calls cannot be inlined inside default expressions
@@ -7408,21 +7456,7 @@ package body Sem_Res is
Analyze_Dimension (N);
- -- Evaluate the relation (note we do this after the above check since
- -- this Eval call may change N to True/False. Skip this evaluation
- -- inside assertions, in order to keep assertions as written by users
- -- for tools that rely on these, e.g. GNATprove for loop invariants.
- -- Except evaluation is still performed even inside assertions for
- -- comparisons between values of universal type, which are useless
- -- for static analysis tools, and not supported even by GNATprove.
-
- if In_Assertion_Expr = 0
- or else (Is_Universal_Numeric_Type (Etype (L))
- and then
- Is_Universal_Numeric_Type (Etype (R)))
- then
- Eval_Relational_Op (N);
- end if;
+ Eval_Relational_Op (N);
end Resolve_Comparison_Op;
--------------------------------
@@ -7433,7 +7467,8 @@ package body Sem_Res is
(N : Node_Id;
Typ : Entity_Id)
is
- Decl : Node_Id;
+ Decl : Node_Id;
+ Need_Transient_Scope : Boolean := False;
begin
-- Install the scope created for local declarations, if
-- any. The syntax allows a Declare_Expression with no
@@ -7442,7 +7477,6 @@ package body Sem_Res is
-- appears as the scope of all entities declared therein.
Decl := First (Actions (N));
-
while Present (Decl) loop
exit when Nkind (Decl)
in N_Object_Declaration | N_Object_Renaming_Declaration;
@@ -7450,11 +7484,35 @@ package body Sem_Res is
end loop;
if Present (Decl) then
- Push_Scope (Scope (Defining_Identifier (Decl)));
+
+ -- Need to establish a transient scope in case Expression (N)
+ -- requires actions to be wrapped.
declare
- E : Entity_Id := First_Entity (Current_Scope);
+ Node : Node_Id;
+ begin
+ Node := First (Actions (N));
+ while Present (Node) loop
+ if Nkind (Node) = N_Object_Declaration
+ and then Requires_Transient_Scope
+ (Etype (Defining_Identifier (Node)))
+ then
+ Need_Transient_Scope := True;
+ exit;
+ end if;
+
+ Next (Node);
+ end loop;
+ end;
+
+ if Need_Transient_Scope then
+ Establish_Transient_Scope (Decl, True);
+ else
+ Push_Scope (Scope (Defining_Identifier (Decl)));
+ end if;
+ declare
+ E : Entity_Id := First_Entity (Current_Scope);
begin
while Present (E) loop
Set_Current_Entity (E);
@@ -8369,6 +8427,11 @@ package body Sem_Res is
-- This is semantically dubious, and of no interest to any real code,
-- but c48008a makes it all worthwhile.
+ function Suspicious_Prio_For_Equality return Boolean;
+ -- Returns True iff the parent node is a and/or/xor operation that
+ -- could be the cause of confused priorities. Note that if the not is
+ -- in parens, then False is returned.
+
-------------------------
-- Check_If_Expression --
-------------------------
@@ -8498,6 +8561,47 @@ package body Sem_Res is
return Empty;
end Find_Unique_Access_Type;
+ ----------------------------------
+ -- Suspicious_Prio_For_Equality --
+ ----------------------------------
+
+ function Suspicious_Prio_For_Equality return Boolean is
+ Par : constant Node_Id := Parent (N);
+
+ begin
+ -- Check if parent node is one of and/or/xor, not parenthesized
+ -- explicitly, and its own parent is not of this kind. Otherwise,
+ -- it's a case of chained Boolean conditions which is likely well
+ -- parenthesized.
+
+ if Nkind (Par) in N_Op_And | N_Op_Or | N_Op_Xor
+ and then Paren_Count (N) = 0
+ and then Nkind (Parent (Par)) not in N_Op_And | N_Op_Or | N_Op_Xor
+ then
+ declare
+ Compar : Node_Id :=
+ (if Left_Opnd (Par) = N then
+ Right_Opnd (Par)
+ else
+ Left_Opnd (Par));
+ begin
+ -- Compar may have been rewritten, for example from (a /= b)
+ -- into not (a = b). Use the Original_Node instead.
+
+ Compar := Original_Node (Compar);
+
+ -- If the other argument of the and/or/xor is also a
+ -- comparison, or another and/or/xor then most likely
+ -- the priorities are correctly set.
+
+ return Nkind (Compar) not in N_Op_Boolean;
+ end;
+
+ else
+ return False;
+ end if;
+ end Suspicious_Prio_For_Equality;
+
-- Start of processing for Resolve_Equality_Op
begin
@@ -8578,6 +8682,24 @@ package body Sem_Res is
Explain_Redundancy (Original_Node (R));
end if;
+ -- Warn on a (in)equality between boolean values which is not
+ -- parenthesized when the parent expression is one of and/or/xor, as
+ -- this is interpreted as (a = b) op c where most likely a = (b op c)
+ -- was intended. Do not generate a warning in generic instances, as
+ -- the problematic expression may be implicitly parenthesized in
+ -- the generic itself if one of the operators is a generic formal.
+ -- Also do not generate a warning for generated equality, for
+ -- example from rewritting a membership test.
+
+ if Warn_On_Questionable_Missing_Parens
+ and then not In_Instance
+ and then Comes_From_Source (N)
+ and then Is_Boolean_Type (T)
+ and then Suspicious_Prio_For_Equality
+ then
+ Error_Msg_N ("?q?equality should be parenthesized here!", N);
+ end if;
+
-- If the equality is overloaded and the operands have resolved
-- properly, set the proper equality operator on the node. The
-- current setting is the first one found during analysis, which
@@ -8800,8 +8922,7 @@ package body Sem_Res is
-- actual subtype. We also exclude generated code (which builds actual
-- subtypes directly if they are needed).
- if Is_Array_Type (Etype (N))
- and then Is_Packed (Etype (N))
+ if Is_Packed_Array (Etype (N))
and then not Is_Constrained (Etype (N))
and then Nkind (Parent (N)) /= N_Attribute_Reference
and then Comes_From_Source (N)
@@ -9507,7 +9628,7 @@ package body Sem_Res is
-- universal types applies.
procedure Resolve_Membership_Op (N : Node_Id; Typ : Entity_Id) is
- pragma Warnings (Off, Typ);
+ pragma Assert (Is_Boolean_Type (Typ));
L : constant Node_Id := Left_Opnd (N);
R : constant Node_Id := Right_Opnd (N);
@@ -9724,13 +9845,13 @@ package body Sem_Res is
if Nkind (Parent (N)) in N_Subprogram_Call then
Error_Msg_N
- ("null is not allowed as argument for an access parameter", N);
+ ("NULL is not allowed as argument for an access parameter", N);
-- Standard message for all other cases (are there any?)
else
Error_Msg_N
- ("null cannot be of an anonymous access type", N);
+ ("NULL cannot be of an anonymous access type", N);
end if;
end if;
@@ -9777,7 +9898,7 @@ package body Sem_Res is
else
Insert_Action
(Compile_Time_Constraint_Error (N,
- "(Ada 2005) null not allowed in null-excluding objects??"),
+ "(Ada 2005) NULL not allowed in null-excluding objects??"),
Make_Raise_Constraint_Error (Loc,
Reason => CE_Access_Check_Failed));
end if;
@@ -10130,8 +10251,6 @@ package body Sem_Res is
--------------------
procedure Resolve_Op_Not (N : Node_Id; Typ : Entity_Id) is
- B_Typ : Entity_Id;
-
function Parent_Is_Boolean return Boolean;
-- This function determines if the parent node is a boolean operator or
-- operation (comparison op, membership test, or short circuit form) and
@@ -10144,32 +10263,16 @@ package body Sem_Res is
function Parent_Is_Boolean return Boolean is
begin
- if Paren_Count (N) /= 0 then
- return False;
+ return Paren_Count (N) = 0
+ and then Nkind (Parent (N)) in N_Membership_Test
+ | N_Op_Boolean
+ | N_Short_Circuit
+ and then Left_Opnd (Parent (N)) = N;
+ end Parent_Is_Boolean;
- else
- case Nkind (Parent (N)) is
- when N_And_Then
- | N_In
- | N_Not_In
- | 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_Or_Else
- =>
- return Left_Opnd (Parent (N)) = N;
+ -- Local variables
- when others =>
- return False;
- end case;
- end if;
- end Parent_Is_Boolean;
+ B_Typ : Entity_Id;
-- Start of processing for Resolve_Op_Not
@@ -10196,7 +10299,7 @@ package body Sem_Res is
elsif Typ = Universal_Integer or else Typ = Any_Modular then
if Parent_Is_Boolean then
Error_Msg_N
- ("operand of not must be enclosed in parentheses",
+ ("operand of NOT must be enclosed in parentheses",
Right_Opnd (N));
else
Error_Msg_N
@@ -10809,30 +10912,34 @@ package body Sem_Res is
Set_Etype (N, Base_Type (Typ));
end if;
- -- Note: No Eval processing is required, because the prefix is of a
- -- record type, or protected type, and neither can possibly be static.
+ -- Eval_Selected_Component may e.g. fold statically known discriminants.
- -- If the record type is atomic and the component is not, then this is
- -- worth a warning before Ada 2020, since we have a situation where the
- -- access to the component may cause extra read/writes of the atomic
- -- object, or partial word accesses, both of which may be unexpected.
+ Eval_Selected_Component (N);
- if Nkind (N) = N_Selected_Component
- and then Is_Atomic_Ref_With_Address (N)
- and then not Is_Atomic (Entity (S))
- and then not Is_Atomic (Etype (Entity (S)))
- and then Ada_Version < Ada_2020
- then
- Error_Msg_N
- ("??access to non-atomic component of atomic record",
- Prefix (N));
- Error_Msg_N
- ("\??may cause unexpected accesses to atomic object",
- Prefix (N));
- end if;
+ if Nkind (N) = N_Selected_Component then
- Resolve_Implicit_Dereference (Prefix (N));
- Analyze_Dimension (N);
+ -- If the record type is atomic and the component is not, then this
+ -- is worth a warning before Ada 2020, since we have a situation
+ -- where the access to the component may cause extra read/writes of
+ -- the atomic object, or partial word accesses, both of which may be
+ -- unexpected.
+
+ if Is_Atomic_Ref_With_Address (N)
+ and then not Is_Atomic (Entity (S))
+ and then not Is_Atomic (Etype (Entity (S)))
+ and then Ada_Version < Ada_2020
+ then
+ Error_Msg_N
+ ("??access to non-atomic component of atomic record",
+ Prefix (N));
+ Error_Msg_N
+ ("\??may cause unexpected accesses to atomic object",
+ Prefix (N));
+ end if;
+
+ Resolve_Implicit_Dereference (Prefix (N));
+ Analyze_Dimension (N);
+ end if;
end Resolve_Selected_Component;
-------------------
@@ -11635,16 +11742,14 @@ package body Sem_Res is
Simplify_Type_Conversion (N);
-- If after evaluation we still have a type conversion, then we may need
- -- to apply checks required for a subtype conversion.
-
- -- Skip these type conversion checks if universal fixed operands
- -- are involved, since range checks are handled separately for
- -- these cases (in the appropriate Expand routines in unit Exp_Fixd).
+ -- to apply checks required for a subtype conversion. But skip them if
+ -- universal fixed operands are involved, since range checks are handled
+ -- separately for these cases, after the expansion done by Exp_Fixd.
if Nkind (N) = N_Type_Conversion
and then not Is_Generic_Type (Root_Type (Target_Typ))
and then Target_Typ /= Universal_Fixed
- and then Operand_Typ /= Universal_Fixed
+ and then Etype (Operand) /= Universal_Fixed
then
Apply_Type_Conversion_Checks (N);
end if;
@@ -11883,11 +11988,12 @@ package body Sem_Res is
(N, Target_Typ, Static_Failure_Is_Error => True);
end if;
- -- If at this stage we have a fixed point to integer conversion, make
- -- sure that the Do_Range_Check flag is set which is not always done
- -- by exp_fixd.adb.
+ -- If at this stage we have a fixed to integer conversion, make sure the
+ -- Do_Range_Check flag is set, because such conversions in general need
+ -- a range check. We only need this if expansion is off, see above why.
if Nkind (N) = N_Type_Conversion
+ and then not Expander_Active
and then Is_Integer_Type (Target_Typ)
and then Is_Fixed_Point_Type (Operand_Typ)
and then not Range_Checks_Suppressed (Target_Typ)
@@ -12390,9 +12496,10 @@ 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.
+ -- to be done only if expansion is enabled, or in GNATprove mode to
+ -- capture the associated run-time exceptions if any.
- elsif Expander_Active then
+ elsif Expander_Active or GNATprove_Mode then
Ensure_Defined (Typ => Slice_Subtype, N => N);
end if;
end Set_Slice_Subtype;
diff --git a/gcc/ada/sem_type.adb b/gcc/ada/sem_type.adb
index 3b1f48e..8dbfa18 100644
--- a/gcc/ada/sem_type.adb
+++ b/gcc/ada/sem_type.adb
@@ -326,8 +326,19 @@ package body Sem_Type is
return False;
elsif Nkind (N) in N_Binary_Op then
- return Present (Universal_Interpretation (Left_Opnd (N)))
- and then Present (Universal_Interpretation (Right_Opnd (N)));
+ if Present (Universal_Interpretation (Left_Opnd (N)))
+ and then Present (Universal_Interpretation (Right_Opnd (N)))
+ then
+ return True;
+ elsif Nkind (N) in N_Op_Eq | N_Op_Ne
+ and then
+ (Is_Anonymous_Access_Type (Etype (Left_Opnd (N)))
+ or else Is_Anonymous_Access_Type (Etype (Right_Opnd (N))))
+ then
+ return True;
+ else
+ return False;
+ end if;
elsif Nkind (N) in N_Unary_Op then
return Present (Universal_Interpretation (Right_Opnd (N)));
@@ -1156,16 +1167,14 @@ package body Sem_Type is
-- useless unchecked conversions, and since this can only arise in
-- (known correct) expanded code, no harm is done.
- elsif Is_Array_Type (T2)
- and then Is_Packed (T2)
+ elsif Is_Packed_Array (T2)
and then T1 = Packed_Array_Impl_Type (T2)
then
return True;
-- Similarly an array type covers its corresponding packed array type
- elsif Is_Array_Type (T1)
- and then Is_Packed (T1)
+ elsif Is_Packed_Array (T1)
and then T2 = Packed_Array_Impl_Type (T1)
then
return True;
@@ -1338,6 +1347,13 @@ package body Sem_Type is
-- for special handling of expressions with universal operands, see
-- comments to Has_Abstract_Interpretation below.
+ function Is_User_Defined_Anonymous_Access_Equality
+ (User_Subp, Predef_Subp : Entity_Id) return Boolean;
+ -- Check for Ada 2005, AI-020: If the context involves an anonymous
+ -- access operand, recognize a user-defined equality (User_Subp) with
+ -- the proper signature, declared in the same declarative list as the
+ -- type and not hiding a predefined equality Predef_Subp.
+
---------------------------
-- Inherited_From_Actual --
---------------------------
@@ -1743,6 +1759,37 @@ package body Sem_Type is
end if;
end Standard_Operator;
+ -----------------------------------------------
+ -- Is_User_Defined_Anonymous_Access_Equality --
+ -----------------------------------------------
+
+ function Is_User_Defined_Anonymous_Access_Equality
+ (User_Subp, Predef_Subp : Entity_Id) return Boolean is
+ begin
+ return Present (User_Subp)
+
+ -- Check for Ada 2005 and use of anonymous access
+
+ and then Ada_Version >= Ada_2005
+ and then Etype (User_Subp) = Standard_Boolean
+ and then Is_Anonymous_Access_Type (Operand_Type)
+
+ -- This check is only relevant if User_Subp is visible and not in
+ -- an instance
+
+ and then (In_Open_Scopes (Scope (User_Subp))
+ or else Is_Potentially_Use_Visible (User_Subp))
+ and then not In_Instance
+ and then not Hides_Op (User_Subp, Predef_Subp)
+
+ -- Is User_Subp declared in the same declarative list as the type?
+
+ and then
+ In_Same_Declaration_List
+ (Designated_Type (Operand_Type),
+ Unit_Declaration_Node (User_Subp));
+ end Is_User_Defined_Anonymous_Access_Equality;
+
-- Start of processing for Disambiguate
begin
@@ -1856,17 +1903,41 @@ package body Sem_Type is
Arg2 := Next_Actual (Arg1);
end if;
- if Present (Arg2)
- and then Present (Universal_Interpretation (Arg1))
- and then Universal_Interpretation (Arg2) =
- Universal_Interpretation (Arg1)
- then
- Get_First_Interp (N, I, It);
- while Scope (It.Nam) /= Standard_Standard loop
- Get_Next_Interp (I, It);
- end loop;
+ if Present (Arg2) then
+ if Ekind (Nam1) = E_Operator then
+ Predef_Subp := Nam1;
+ User_Subp := Nam2;
+ elsif Ekind (Nam2) = E_Operator then
+ Predef_Subp := Nam2;
+ User_Subp := Nam1;
+ else
+ Predef_Subp := Empty;
+ User_Subp := Empty;
+ end if;
- return It;
+ -- Take into account universal interpretation as well as
+ -- universal_access equality, as long as AI05-0020 does not
+ -- trigger.
+
+ if (Present (Universal_Interpretation (Arg1))
+ and then Universal_Interpretation (Arg2) =
+ Universal_Interpretation (Arg1))
+ or else
+ (Nkind (N) in N_Op_Eq | N_Op_Ne
+ and then (Is_Anonymous_Access_Type (Etype (Arg1))
+ or else
+ Is_Anonymous_Access_Type (Etype (Arg2)))
+ and then not
+ Is_User_Defined_Anonymous_Access_Equality
+ (User_Subp, Predef_Subp))
+ then
+ Get_First_Interp (N, I, It);
+ while Scope (It.Nam) /= Standard_Standard loop
+ Get_Next_Interp (I, It);
+ end loop;
+
+ return It;
+ end if;
end if;
end;
end if;
@@ -2117,20 +2188,11 @@ package body Sem_Type is
return It2;
end if;
- -- Ada 2005, AI-420: preference rule for "=" on Universal_Access
- -- states that the operator defined in Standard is not available
- -- if there is a user-defined equality with the proper signature,
- -- declared in the same declarative list as the type. The node
- -- may be an operator or a function call.
+ -- Check for AI05-020
elsif Chars (Nam1) in Name_Op_Eq | Name_Op_Ne
- and then Ada_Version >= Ada_2005
- and then Etype (User_Subp) = Standard_Boolean
- and then Is_Anonymous_Access_Type (Operand_Type)
- and then
- In_Same_Declaration_List
- (Designated_Type (Operand_Type),
- Unit_Declaration_Node (User_Subp))
+ and then Is_User_Defined_Anonymous_Access_Equality
+ (User_Subp, Predef_Subp)
then
if It2.Nam = Predef_Subp then
return It1;
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 0eb4905..1cf5c69 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -23,8 +23,6 @@
-- --
------------------------------------------------------------------------------
-with Treepr; -- ???For debugging code below
-
with Casing; use Casing;
with Checks; use Checks;
with Debug; use Debug;
@@ -170,24 +168,6 @@ package body Sem_Util is
-- routine does not take simple flow diagnostics into account, it relies on
-- static facts such as the presence of null exclusions.
- function Old_Requires_Transient_Scope (Id : Entity_Id) return Boolean;
- function New_Requires_Transient_Scope (Id : Entity_Id) return Boolean;
- -- ???We retain the old and new algorithms for Requires_Transient_Scope for
- -- the time being. New_Requires_Transient_Scope is used by default; the
- -- debug switch -gnatdQ can be used to do Old_Requires_Transient_Scope
- -- instead. The intent is to use this temporarily to measure before/after
- -- efficiency. Note: when this temporary code is removed, the documentation
- -- of dQ in debug.adb should be removed.
-
- procedure Results_Differ
- (Id : Entity_Id;
- Old_Val : Boolean;
- New_Val : Boolean);
- -- ???Debugging code. Called when the Old_Val and New_Val differ. This
- -- routine will be removed eventially when New_Requires_Transient_Scope
- -- becomes Requires_Transient_Scope and Old_Requires_Transient_Scope is
- -- eliminated.
-
function Subprogram_Name (N : Node_Id) return String;
-- Return the fully qualified name of the enclosing subprogram for the
-- given node N, with file:line:col information appended, e.g.
@@ -2492,7 +2472,7 @@ package body Sem_Util is
function Build_Discriminal_Array_Constraint return List_Id;
-- If one or more of the bounds of the component depends on
- -- discriminants, build actual constraint using the discriminants
+ -- discriminants, build actual constraint using the discriminants
-- of the prefix.
function Build_Discriminal_Record_Constraint return List_Id;
@@ -6454,11 +6434,7 @@ package body Sem_Util is
and then Etype (First_Formal (Id)) =
Etype (Next_Formal (First_Formal (Id)))
then
- if No (Eq_Prims_List) then
- Eq_Prims_List := New_Elmt_List;
- end if;
-
- Append_Elmt (Id, Eq_Prims_List);
+ Append_New_Elmt (Id, Eq_Prims_List);
end if;
end if;
end if;
@@ -7859,6 +7835,8 @@ package body Sem_Util is
or else
Nkind (Decl) in N_Later_Decl_Item
or else
+ Nkind (Decl) in N_Renaming_Declaration
+ or else
Nkind (Decl) = N_Number_Declaration)
loop
Decl := Parent (Decl);
@@ -7933,6 +7911,34 @@ package body Sem_Util is
return Empty;
end Enclosing_Generic_Unit;
+ -------------------
+ -- Enclosing_HSS --
+ -------------------
+
+ function Enclosing_HSS (Stmt : Node_Id) return Node_Id is
+ Par : Node_Id;
+ begin
+ pragma Assert (Is_Statement (Stmt));
+
+ Par := Parent (Stmt);
+ while Present (Par) loop
+
+ if Nkind (Par) = N_Handled_Sequence_Of_Statements then
+ return Par;
+
+ -- Prevent the search from going too far
+
+ elsif Is_Body_Or_Package_Declaration (Par) then
+ return Empty;
+
+ end if;
+
+ Par := Parent (Par);
+ end loop;
+
+ return Par;
+ end Enclosing_HSS;
+
-------------------------------
-- Enclosing_Lib_Unit_Entity --
-------------------------------
@@ -8290,6 +8296,13 @@ package body Sem_Util is
else
Set_Name_Entity_Id (Chars (E), Homonym (E));
end if;
+
+ -- The inherited operation cannot be retrieved
+ -- by name, even though it may remain accesssible
+ -- in some cases involving subprogram bodies without
+ -- specs appearing in with_clauses..
+
+ Set_Is_Immediately_Visible (E, False);
end if;
end;
@@ -9863,11 +9876,13 @@ package body Sem_Util is
-----------------------
procedure Gather_Components
- (Typ : Entity_Id;
- Comp_List : Node_Id;
- Governed_By : List_Id;
- Into : Elist_Id;
- Report_Errors : out Boolean)
+ (Typ : Entity_Id;
+ Comp_List : Node_Id;
+ Governed_By : List_Id;
+ Into : Elist_Id;
+ Report_Errors : out Boolean;
+ Allow_Compile_Time : Boolean := False;
+ Include_Interface_Tag : Boolean := False)
is
Assoc : Node_Id;
Variant : Node_Id;
@@ -9899,15 +9914,20 @@ package body Sem_Util is
while Present (Comp_Item) loop
- -- Skip the tag of a tagged record, the interface tags, as well
- -- as all items that are not user components (anonymous types,
- -- rep clauses, Parent field, controller field).
+ -- Skip the tag of a tagged record, as well as all items that are not
+ -- user components (anonymous types, rep clauses, Parent field,
+ -- controller field).
if Nkind (Comp_Item) = N_Component_Declaration then
declare
Comp : constant Entity_Id := Defining_Identifier (Comp_Item);
begin
- if not Is_Tag (Comp) and then Chars (Comp) /= Name_uParent then
+ if not (Is_Tag (Comp)
+ and then not
+ (Include_Interface_Tag
+ and then Etype (Comp) = RTE (RE_Interface_Tag)))
+ and then Chars (Comp) /= Name_uParent
+ then
Append_Elmt (Comp, Into);
end if;
end;
@@ -10016,7 +10036,11 @@ package body Sem_Util is
end loop Find_Constraint;
Discrim_Value := Expression (Assoc);
- if Is_OK_Static_Expression (Discrim_Value) then
+
+ if Is_OK_Static_Expression (Discrim_Value)
+ or else (Allow_Compile_Time
+ and then Compile_Time_Known_Value (Discrim_Value))
+ then
Discrim_Value_Status := Static_Expr;
else
if Ada_Version >= Ada_2020 then
@@ -10195,7 +10219,8 @@ package body Sem_Util is
end if;
Gather_Components
- (Typ, Component_List (Variant), Governed_By, Into, Report_Errors);
+ (Typ, Component_List (Variant), Governed_By, Into,
+ Report_Errors, Allow_Compile_Time);
end if;
end Gather_Components;
@@ -10430,7 +10455,7 @@ package body Sem_Util is
then
if Cursor /= Any_Type then
Error_Msg_N
- ("Operation First for iterable type must be unique", Aspect);
+ ("operation First for iterable type must be unique", Aspect);
return Any_Type;
else
Cursor := Etype (Func);
@@ -10548,7 +10573,7 @@ package body Sem_Util is
-- Position in the enumeration type starts at 0
- if UI_To_Int (Pos) < 0 then
+ if Pos < 0 then
raise Constraint_Error;
end if;
@@ -10584,6 +10609,12 @@ package body Sem_Util is
function Get_Fullest_View
(E : Entity_Id; Include_PAT : Boolean := True) return Entity_Id is
begin
+ -- Prevent cascaded errors
+
+ if No (E) then
+ return E;
+ end if;
+
-- Strictly speaking, the recursion below isn't necessary, but
-- it's both simplest and safest.
@@ -11394,7 +11425,7 @@ package body Sem_Util is
Comp : Entity_Id;
begin
- -- Loop to Check components
+ -- Loop to check components
Comp := First_Component_Or_Discriminant (Typ);
while Present (Comp) loop
@@ -12727,12 +12758,11 @@ package body Sem_Util is
----------------------------------
function Has_Non_Trivial_Precondition (Subp : Entity_Id) return Boolean is
- Pre : constant Node_Id := Find_Aspect (Subp, Aspect_Pre);
-
+ Pre : constant Node_Id := Find_Aspect (Subp, Aspect_Pre,
+ Class_Present => True);
begin
return
Present (Pre)
- and then Class_Present (Pre)
and then not Is_Entity_Name (Expression (Pre));
end Has_Non_Trivial_Precondition;
@@ -13823,6 +13853,52 @@ package body Sem_Util is
and then Assertion_Expression_Pragma (Get_Pragma_Id (Prag));
end In_Assertion_Expression_Pragma;
+ -------------------
+ -- In_Check_Node --
+ -------------------
+
+ function In_Check_Node (N : Node_Id) return Boolean is
+ Par : Node_Id := Parent (N);
+ begin
+ while Present (Par) loop
+ if Nkind (Par) in N_Raise_xxx_Error then
+ return True;
+
+ -- Prevent the search from going too far
+
+ elsif Is_Body_Or_Package_Declaration (Par) then
+ return False;
+
+ else
+ Par := Parent (Par);
+ end if;
+ end loop;
+
+ return False;
+ end In_Check_Node;
+
+ -------------------------------
+ -- In_Generic_Formal_Package --
+ -------------------------------
+
+ function In_Generic_Formal_Package (E : Entity_Id) return Boolean is
+ Par : Node_Id;
+
+ begin
+ Par := Parent (E);
+ while Present (Par) loop
+ if Nkind (Par) = N_Formal_Package_Declaration
+ or else Nkind (Original_Node (Par)) = N_Formal_Package_Declaration
+ then
+ return True;
+ end if;
+
+ Par := Parent (Par);
+ end loop;
+
+ return False;
+ end In_Generic_Formal_Package;
+
----------------------
-- In_Generic_Scope --
----------------------
@@ -14565,7 +14641,9 @@ package body Sem_Util is
procedure Inherit_Predicate_Flags (Subt, Par : Entity_Id) is
begin
- if Present (Predicate_Function (Subt)) then
+ if Ada_Version < Ada_2012
+ or else Present (Predicate_Function (Subt))
+ then
return;
end if;
@@ -15148,6 +15226,19 @@ package body Sem_Util is
return Present (Formal) and then Ekind (Formal) = E_In_Out_Parameter;
end Is_Actual_In_Out_Parameter;
+ ---------------------------------------
+ -- Is_Actual_Out_Or_In_Out_Parameter --
+ ---------------------------------------
+
+ function Is_Actual_Out_Or_In_Out_Parameter (N : Node_Id) return Boolean is
+ Formal : Entity_Id;
+ Call : Node_Id;
+ begin
+ Find_Actual (N, Formal, Call);
+ return Present (Formal)
+ and then Ekind (Formal) in E_Out_Parameter | E_In_Out_Parameter;
+ end Is_Actual_Out_Or_In_Out_Parameter;
+
-------------------------
-- Is_Actual_Parameter --
-------------------------
@@ -16250,7 +16341,7 @@ package body Sem_Util is
P_Aliased : Boolean := False;
Comp : Entity_Id;
- Deref : Node_Id := Object;
+ Deref : Node_Id := Original_Node (Object);
-- Dereference node, in something like X.all.Y(2)
-- Start of processing for Is_Dependent_Component_Of_Mutable_Object
@@ -16261,11 +16352,9 @@ package body Sem_Util is
while Nkind (Deref) in
N_Indexed_Component | N_Selected_Component | N_Slice
loop
- Deref := Prefix (Deref);
+ Deref := Original_Node (Prefix (Deref));
end loop;
- Deref := Original_Node (Deref);
-
-- If the prefix is a qualified expression of a variable, then function
-- Is_Variable will return False for that because a qualified expression
-- denotes a constant view, so we need to get the name being qualified
@@ -16441,14 +16530,16 @@ package body Sem_Util is
elsif Nkind (Object) = N_Indexed_Component
or else Nkind (Object) = N_Slice
then
- return Is_Dependent_Component_Of_Mutable_Object (Prefix (Object));
+ return Is_Dependent_Component_Of_Mutable_Object
+ (Original_Node (Prefix (Object)));
-- A type conversion that Is_Variable is a view conversion:
-- go back to the denoted object.
elsif Nkind (Object) = N_Type_Conversion then
return
- Is_Dependent_Component_Of_Mutable_Object (Expression (Object));
+ Is_Dependent_Component_Of_Mutable_Object
+ (Original_Node (Expression (Object)));
end if;
end if;
@@ -16582,7 +16673,9 @@ package body Sem_Util is
-- Is_Effectively_Volatile --
-----------------------------
- function Is_Effectively_Volatile (Id : Entity_Id) return Boolean is
+ function Is_Effectively_Volatile
+ (Id : Entity_Id;
+ Ignore_Protected : Boolean := False) return Boolean is
begin
if Is_Type (Id) then
@@ -16610,15 +16703,16 @@ package body Sem_Util is
-- Test for presence of ancestor, as the full view of a
-- private type may be missing in case of error.
- return
- Present (Anc)
- and then Is_Effectively_Volatile (Component_Type (Anc));
+ return Present (Anc)
+ and then Is_Effectively_Volatile
+ (Component_Type (Anc), Ignore_Protected);
end;
end if;
- -- A protected type is always volatile
+ -- A protected type is always volatile unless Ignore_Protected is
+ -- True.
- elsif Is_Protected_Type (Id) then
+ elsif Is_Protected_Type (Id) and then not Ignore_Protected then
return True;
-- A descendant of Ada.Synchronous_Task_Control.Suspension_Object is
@@ -16644,7 +16738,7 @@ package body Sem_Util is
and then not
(Ekind (Id) = E_Variable and then No_Caching_Enabled (Id)))
or else Has_Volatile_Components (Id)
- or else Is_Effectively_Volatile (Etype (Id));
+ or else Is_Effectively_Volatile (Etype (Id), Ignore_Protected);
end if;
end Is_Effectively_Volatile;
@@ -16653,15 +16747,19 @@ package body Sem_Util is
-----------------------------------------
function Is_Effectively_Volatile_For_Reading
- (Id : Entity_Id) return Boolean
+ (Id : Entity_Id;
+ Ignore_Protected : Boolean := False) return Boolean
is
begin
- -- A concurrent type is effectively volatile for reading
+ -- A concurrent type is effectively volatile for reading, except for a
+ -- protected type when Ignore_Protected is True.
- if Is_Concurrent_Type (Id) then
+ if Is_Task_Type (Id)
+ or else (Is_Protected_Type (Id) and then not Ignore_Protected)
+ then
return True;
- elsif Is_Effectively_Volatile (Id) then
+ elsif Is_Effectively_Volatile (Id, Ignore_Protected) then
-- Other volatile types and objects are effectively volatile for
-- reading when they have property Async_Writers or Effective_Reads
@@ -16689,10 +16787,9 @@ package body Sem_Util is
-- Test for presence of ancestor, as the full view of a
-- private type may be missing in case of error.
- return
- Present (Anc)
- and then Is_Effectively_Volatile_For_Reading
- (Component_Type (Anc));
+ return Present (Anc)
+ and then Is_Effectively_Volatile_For_Reading
+ (Component_Type (Anc), Ignore_Protected);
end;
end if;
end if;
@@ -16706,6 +16803,9 @@ package body Sem_Util is
------------------------------------
function Is_Effectively_Volatile_Object (N : Node_Id) return Boolean is
+ function Is_Effectively_Volatile (E : Entity_Id) return Boolean is
+ (Is_Effectively_Volatile (E, Ignore_Protected => False));
+
function Is_Effectively_Volatile_Object_Inst
is new Is_Effectively_Volatile_Object_Shared (Is_Effectively_Volatile);
begin
@@ -16719,6 +16819,10 @@ package body Sem_Util is
function Is_Effectively_Volatile_Object_For_Reading
(N : Node_Id) return Boolean
is
+ function Is_Effectively_Volatile_For_Reading
+ (E : Entity_Id) return Boolean
+ is (Is_Effectively_Volatile_For_Reading (E, Ignore_Protected => False));
+
function Is_Effectively_Volatile_Object_For_Reading_Inst
is new Is_Effectively_Volatile_Object_Shared
(Is_Effectively_Volatile_For_Reading);
@@ -18221,6 +18325,23 @@ package body Sem_Util is
-------------------------
function Is_Object_Reference (N : Node_Id) return Boolean is
+ function Safe_Prefix (N : Node_Id) return Node_Id;
+ -- Return Prefix (N) unless it has been rewritten as an
+ -- N_Raise_xxx_Error node, in which case return its original node.
+
+ -----------------
+ -- Safe_Prefix --
+ -----------------
+
+ function Safe_Prefix (N : Node_Id) return Node_Id is
+ begin
+ if Nkind (Prefix (N)) in N_Raise_xxx_Error then
+ return Original_Node (Prefix (N));
+ else
+ return Prefix (N);
+ end if;
+ end Safe_Prefix;
+
begin
-- AI12-0068: Note that a current instance reference in a type or
-- subtype's aspect_specification is considered a value, not an object
@@ -18236,8 +18357,8 @@ package body Sem_Util is
| N_Slice
=>
return
- Is_Object_Reference (Prefix (N))
- or else Is_Access_Type (Etype (Prefix (N)));
+ Is_Object_Reference (Safe_Prefix (N))
+ or else Is_Access_Type (Etype (Safe_Prefix (N)));
-- In Ada 95, a function call is a constant object; a procedure
-- call is not.
@@ -18265,8 +18386,8 @@ package body Sem_Util is
return
Is_Object_Reference (Selector_Name (N))
and then
- (Is_Object_Reference (Prefix (N))
- or else Is_Access_Type (Etype (Prefix (N))));
+ (Is_Object_Reference (Safe_Prefix (N))
+ or else Is_Access_Type (Etype (Safe_Prefix (N))));
-- An explicit dereference denotes an object, except that a
-- conditional expression gets turned into an explicit dereference
@@ -18311,7 +18432,10 @@ package body Sem_Util is
-- In Ada 95 an aggregate is an object reference
- when N_Aggregate =>
+ when N_Aggregate
+ | N_Delta_Aggregate
+ | N_Extension_Aggregate
+ =>
return Ada_Version >= Ada_95;
-- A string literal is not an object reference, but it might come
@@ -19876,6 +20000,22 @@ package body Sem_Util is
or else Nkind (N) = N_Procedure_Call_Statement;
end Is_Statement;
+ --------------------------------------
+ -- Is_Static_Discriminant_Component --
+ --------------------------------------
+
+ function Is_Static_Discriminant_Component (N : Node_Id) return Boolean is
+ begin
+ return Nkind (N) = N_Selected_Component
+ and then not Is_In_Discriminant_Check (N)
+ and then Present (Etype (Prefix (N)))
+ and then Ekind (Etype (Prefix (N))) = E_Record_Subtype
+ and then Has_Static_Discriminants (Etype (Prefix (N)))
+ and then Present (Entity (Selector_Name (N)))
+ and then Ekind (Entity (Selector_Name (N))) = E_Discriminant
+ and then not In_Check_Node (N);
+ end Is_Static_Discriminant_Component;
+
------------------------
-- Is_Static_Function --
------------------------
@@ -20434,8 +20574,7 @@ package body Sem_Util is
elsif Nkind (P) = N_Type_Conversion
and then not Comes_From_Source (P)
- and then Is_Array_Type (Etype (P))
- and then Is_Packed (Etype (P))
+ and then Is_Packed_Array (Etype (P))
then
return Is_Variable (Expression (P));
@@ -22439,11 +22578,7 @@ package body Sem_Util is
function Search_Decl (N : Node_Id) return Traverse_Result is
begin
if Nkind (N) in N_Declaration then
- if No (Decls) then
- Decls := New_Elmt_List;
- end if;
-
- Append_Elmt (N, Decls);
+ Append_New_Elmt (N, Decls);
end if;
return OK;
@@ -24265,228 +24400,6 @@ package body Sem_Util is
Node := Next_Global (Node);
end Next_Global;
- ----------------------------------
- -- New_Requires_Transient_Scope --
- ----------------------------------
-
- function New_Requires_Transient_Scope (Id : Entity_Id) return Boolean is
- 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
- -- results is known at the call site, False otherwise. Returns False
- -- if there is a variant part that depends on the discriminants of
- -- this type, or if there is an array constrained by the discriminants
- -- of this type. ???Currently, this is overly conservative (the array
- -- could be nested inside some other record that is constrained by
- -- nondiscriminants). That is, the recursive calls are too conservative.
-
- function Large_Max_Size_Mutable (Typ : Entity_Id) return Boolean;
- -- Returns True if Typ is a nonlimited record with defaulted
- -- discriminants whose max size makes it unsuitable for allocating on
- -- the primary stack.
-
- ------------------------------
- -- Caller_Known_Size_Record --
- ------------------------------
-
- function Caller_Known_Size_Record (Typ : Entity_Id) return Boolean is
- pragma Assert (Typ = Underlying_Type (Typ));
-
- begin
- if Has_Variant_Part (Typ) and then not Is_Definite_Subtype (Typ) then
- return False;
- end if;
-
- declare
- Comp : Entity_Id;
-
- begin
- Comp := First_Component (Typ);
- while Present (Comp) loop
-
- -- Only look at E_Component entities. No need to look at
- -- E_Discriminant entities, and we must ignore internal
- -- subtypes generated for constrained components.
-
- declare
- Comp_Type : constant Entity_Id :=
- Underlying_Type (Etype (Comp));
-
- begin
- if Is_Record_Type (Comp_Type)
- or else
- Is_Protected_Type (Comp_Type)
- then
- if not Caller_Known_Size_Record (Comp_Type) then
- return False;
- end if;
-
- elsif Is_Array_Type (Comp_Type) then
- if Size_Depends_On_Discriminant (Comp_Type) then
- return False;
- end if;
- end if;
- end;
-
- Next_Component (Comp);
- end loop;
- end;
-
- return True;
- end Caller_Known_Size_Record;
-
- ------------------------------
- -- Large_Max_Size_Mutable --
- ------------------------------
-
- function Large_Max_Size_Mutable (Typ : Entity_Id) return Boolean is
- pragma Assert (Typ = Underlying_Type (Typ));
-
- function Is_Large_Discrete_Type (T : Entity_Id) return Boolean;
- -- Returns true if the discrete type T has a large range
-
- ----------------------------
- -- Is_Large_Discrete_Type --
- ----------------------------
-
- function Is_Large_Discrete_Type (T : Entity_Id) return Boolean is
- Threshold : constant Int := 16;
- -- Arbitrary threshold above which we consider it "large". We want
- -- a fairly large threshold, because these large types really
- -- shouldn't have default discriminants in the first place, in
- -- most cases.
-
- begin
- return UI_To_Int (RM_Size (T)) > Threshold;
- end Is_Large_Discrete_Type;
-
- -- Start of processing for Large_Max_Size_Mutable
-
- begin
- if Is_Record_Type (Typ)
- and then not Is_Limited_View (Typ)
- and then Has_Defaulted_Discriminants (Typ)
- then
- -- Loop through the components, looking for an array whose upper
- -- bound(s) depends on discriminants, where both the subtype of
- -- the discriminant and the index subtype are too large.
-
- declare
- Comp : Entity_Id;
-
- begin
- Comp := First_Component (Typ);
- while Present (Comp) loop
- declare
- Comp_Type : constant Entity_Id :=
- Underlying_Type (Etype (Comp));
-
- Hi : Node_Id;
- Indx : Node_Id;
- Ityp : Entity_Id;
-
- begin
- if Is_Array_Type (Comp_Type) then
- Indx := First_Index (Comp_Type);
-
- while Present (Indx) loop
- Ityp := Etype (Indx);
- Hi := Type_High_Bound (Ityp);
-
- if Nkind (Hi) = N_Identifier
- and then Ekind (Entity (Hi)) = E_Discriminant
- and then Is_Large_Discrete_Type (Ityp)
- and then Is_Large_Discrete_Type
- (Etype (Entity (Hi)))
- then
- return True;
- end if;
-
- Next_Index (Indx);
- end loop;
- end if;
- end;
-
- Next_Component (Comp);
- end loop;
- end;
- end if;
-
- return False;
- end Large_Max_Size_Mutable;
-
- -- Local declarations
-
- Typ : constant Entity_Id := Underlying_Type (Id);
-
- -- Start of processing for New_Requires_Transient_Scope
-
- begin
- -- 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;
-
- -- Do not expand transient scope for non-existent procedure return or
- -- string literal types.
-
- elsif Typ = Standard_Void_Type
- or else Ekind (Typ) = E_String_Literal_Subtype
- then
- return False;
-
- -- If Typ is a generic formal incomplete type, then we want to look at
- -- the actual type.
-
- elsif Ekind (Typ) = E_Record_Subtype
- and then Present (Cloned_Subtype (Typ))
- then
- return New_Requires_Transient_Scope (Cloned_Subtype (Typ));
-
- -- Functions returning specific tagged types may dispatch on result, so
- -- their returned value is allocated on the secondary stack, even in the
- -- definite case. We must treat nondispatching functions the same way,
- -- because access-to-function types can point at both, so the calling
- -- conventions must be compatible. Is_Tagged_Type includes controlled
- -- types and class-wide types. Controlled type temporaries need
- -- finalization.
-
- -- ???It's not clear why we need to return noncontrolled types with
- -- controlled components on the secondary stack.
-
- elsif Is_Tagged_Type (Typ) or else Has_Controlled_Component (Typ) then
- return True;
-
- -- Untagged definite subtypes are known size. This includes all
- -- elementary [sub]types. Tasks are known size even if they have
- -- discriminants. So we return False here, with one exception:
- -- For a type like:
- -- type T (Last : Natural := 0) is
- -- X : String (1 .. Last);
- -- end record;
- -- we return True. That's because for "P(F(...));", where F returns T,
- -- we don't know the size of the result at the call site, so if we
- -- allocated it on the primary stack, we would have to allocate the
- -- maximum size, which is way too big.
-
- elsif Is_Definite_Subtype (Typ) or else Is_Task_Type (Typ) then
- return Large_Max_Size_Mutable (Typ);
-
- -- Indefinite (discriminated) untagged record or protected type
-
- elsif Is_Record_Type (Typ) or else Is_Protected_Type (Typ) then
- return not Caller_Known_Size_Record (Typ);
-
- -- Unconstrained array
-
- else
- pragma Assert (Is_Array_Type (Typ) and not Is_Definite_Subtype (Typ));
- return True;
- end if;
- end New_Requires_Transient_Scope;
-
------------------------
-- No_Caching_Enabled --
------------------------
@@ -25361,105 +25274,6 @@ package body Sem_Util is
return Num;
end Number_Of_Elements_In_Array;
- ----------------------------------
- -- Old_Requires_Transient_Scope --
- ----------------------------------
-
- function Old_Requires_Transient_Scope (Id : Entity_Id) return Boolean is
- Typ : constant Entity_Id := Underlying_Type (Id);
-
- begin
- -- 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;
-
- -- Do not expand transient scope for non-existent procedure return
-
- elsif Typ = Standard_Void_Type then
- return False;
-
- -- Elementary types do not require a transient scope
-
- elsif Is_Elementary_Type (Typ) then
- return False;
-
- -- Generally, indefinite subtypes require a transient scope, since the
- -- back end cannot generate temporaries, since this is not a valid type
- -- for declaring an object. It might be possible to relax this in the
- -- future, e.g. by declaring the maximum possible space for the type.
-
- elsif not Is_Definite_Subtype (Typ) then
- return True;
-
- -- Functions returning tagged types may dispatch on result so their
- -- returned value is allocated on the secondary stack. Controlled
- -- type temporaries need finalization.
-
- elsif Is_Tagged_Type (Typ) or else Has_Controlled_Component (Typ) then
- return True;
-
- -- Record type
-
- elsif Is_Record_Type (Typ) then
- declare
- Comp : Entity_Id;
-
- begin
- Comp := First_Entity (Typ);
- while Present (Comp) loop
- if Ekind (Comp) = E_Component then
-
- -- ???It's not clear we need a full recursive call to
- -- Old_Requires_Transient_Scope here. Note that the
- -- following can't happen.
-
- pragma Assert (Is_Definite_Subtype (Etype (Comp)));
- pragma Assert (not Has_Controlled_Component (Etype (Comp)));
-
- if Old_Requires_Transient_Scope (Etype (Comp)) then
- return True;
- end if;
- end if;
-
- Next_Entity (Comp);
- end loop;
- end;
-
- return False;
-
- -- String literal types never require transient scope
-
- elsif Ekind (Typ) = E_String_Literal_Subtype then
- return False;
-
- -- Array type. Note that we already know that this is a constrained
- -- array, since unconstrained arrays will fail the indefinite test.
-
- elsif Is_Array_Type (Typ) then
-
- -- If component type requires a transient scope, the array does too
-
- if Old_Requires_Transient_Scope (Component_Type (Typ)) then
- return True;
-
- -- Otherwise, we only need a transient scope if the size depends on
- -- the value of one or more discriminants.
-
- else
- return Size_Depends_On_Discriminant (Typ);
- end if;
-
- -- All other cases do not require a transient scope
-
- else
- pragma Assert (Is_Protected_Type (Typ) or else Is_Task_Type (Typ));
- return False;
- end if;
- end Old_Requires_Transient_Scope;
-
---------------------------------
-- Original_Aspect_Pragma_Name --
---------------------------------
@@ -25678,7 +25492,7 @@ package body Sem_Util is
end if;
end if;
- return (Empty);
+ return Empty;
end Param_Entity;
----------------------
@@ -26169,7 +25983,8 @@ package body Sem_Util is
(Typ : Entity_Id;
From_Typ : Entity_Id)
is
- DIC_Proc : Entity_Id;
+ DIC_Proc : Entity_Id;
+ Partial_DIC_Proc : Entity_Id;
begin
if Present (Typ) and then Present (From_Typ) then
@@ -26190,6 +26005,7 @@ package body Sem_Util is
end if;
DIC_Proc := DIC_Procedure (From_Typ);
+ Partial_DIC_Proc := Partial_DIC_Procedure (From_Typ);
-- The setting of the attributes is intentionally conservative. This
-- prevents accidental clobbering of enabled attributes.
@@ -26205,6 +26021,12 @@ package body Sem_Util is
if Present (DIC_Proc) and then No (DIC_Procedure (Typ)) then
Set_DIC_Procedure (Typ, DIC_Proc);
end if;
+
+ if Present (Partial_DIC_Proc)
+ and then No (Partial_DIC_Procedure (Typ))
+ then
+ Set_Partial_DIC_Procedure (Typ, Partial_DIC_Proc);
+ end if;
end if;
end Propagate_DIC_Attributes;
@@ -26245,7 +26067,7 @@ package body Sem_Util is
end if;
if Has_Own_Invariants (From_Typ) then
- Set_Has_Own_Invariants (Typ);
+ Set_Has_Own_Invariants (Base_Type (Typ));
end if;
if Present (Full_IP) and then No (Invariant_Procedure (Typ)) then
@@ -26549,18 +26371,82 @@ package body Sem_Util is
-- generated before the next instruction.
function Requires_Transient_Scope (Id : Entity_Id) return Boolean is
- Old_Result : constant Boolean := Old_Requires_Transient_Scope (Id);
+ 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
+ -- results is known at the call site, False otherwise. Returns False
+ -- if there is a variant part that depends on the discriminants of
+ -- this type, or if there is an array constrained by the discriminants
+ -- of this type. ???Currently, this is overly conservative (the array
+ -- could be nested inside some other record that is constrained by
+ -- nondiscriminants). That is, the recursive calls are too conservative.
procedure Ensure_Minimum_Decoration (Typ : Entity_Id);
-- If Typ is not frozen then add to Typ the minimum decoration required
-- by Requires_Transient_Scope to reliably provide its functionality;
-- otherwise no action is performed.
+ function Large_Max_Size_Mutable (Typ : Entity_Id) return Boolean;
+ -- Returns True if Typ is a nonlimited record with defaulted
+ -- discriminants whose max size makes it unsuitable for allocating on
+ -- the primary stack.
+
+ ------------------------------
+ -- Caller_Known_Size_Record --
+ ------------------------------
+
+ function Caller_Known_Size_Record (Typ : Entity_Id) return Boolean is
+ pragma Assert (Typ = Underlying_Type (Typ));
+
+ begin
+ if Has_Variant_Part (Typ) and then not Is_Definite_Subtype (Typ) then
+ return False;
+ end if;
+
+ declare
+ Comp : Entity_Id;
+
+ begin
+ Comp := First_Component (Typ);
+ while Present (Comp) loop
+
+ -- Only look at E_Component entities. No need to look at
+ -- E_Discriminant entities, and we must ignore internal
+ -- subtypes generated for constrained components.
+
+ declare
+ Comp_Type : constant Entity_Id :=
+ Underlying_Type (Etype (Comp));
+
+ begin
+ if Is_Record_Type (Comp_Type)
+ or else
+ Is_Protected_Type (Comp_Type)
+ then
+ if not Caller_Known_Size_Record (Comp_Type) then
+ return False;
+ end if;
+
+ elsif Is_Array_Type (Comp_Type) then
+ if Size_Depends_On_Discriminant (Comp_Type) then
+ return False;
+ end if;
+ end if;
+ end;
+
+ Next_Component (Comp);
+ end loop;
+ end;
+
+ return True;
+ end Caller_Known_Size_Record;
+
-------------------------------
-- Ensure_Minimum_Decoration --
-------------------------------
procedure Ensure_Minimum_Decoration (Typ : Entity_Id) is
+ Comp : Entity_Id;
begin
-- Do not set Has_Controlled_Component on a class-wide equivalent
-- type. See Make_CW_Equivalent_Type.
@@ -26572,82 +26458,182 @@ package body Sem_Util is
or else Is_Incomplete_Or_Private_Type (Typ))
and then not Is_Class_Wide_Equivalent_Type (Typ)
then
+ Comp := First_Component (Typ);
+ while Present (Comp) loop
+ if Has_Controlled_Component (Etype (Comp))
+ or else
+ (Chars (Comp) /= Name_uParent
+ and then Is_Controlled (Etype (Comp)))
+ or else
+ (Is_Protected_Type (Etype (Comp))
+ and then
+ Present (Corresponding_Record_Type (Etype (Comp)))
+ and then
+ Has_Controlled_Component
+ (Corresponding_Record_Type (Etype (Comp))))
+ then
+ Set_Has_Controlled_Component (Typ);
+ exit;
+ end if;
+
+ Next_Component (Comp);
+ end loop;
+ end if;
+ end Ensure_Minimum_Decoration;
+
+ ------------------------------
+ -- Large_Max_Size_Mutable --
+ ------------------------------
+
+ function Large_Max_Size_Mutable (Typ : Entity_Id) return Boolean is
+ pragma Assert (Typ = Underlying_Type (Typ));
+
+ function Is_Large_Discrete_Type (T : Entity_Id) return Boolean;
+ -- Returns true if the discrete type T has a large range
+
+ ----------------------------
+ -- Is_Large_Discrete_Type --
+ ----------------------------
+
+ function Is_Large_Discrete_Type (T : Entity_Id) return Boolean is
+ Threshold : constant Int := 16;
+ -- Arbitrary threshold above which we consider it "large". We want
+ -- a fairly large threshold, because these large types really
+ -- shouldn't have default discriminants in the first place, in
+ -- most cases.
+
+ begin
+ return UI_To_Int (RM_Size (T)) > Threshold;
+ end Is_Large_Discrete_Type;
+
+ -- Start of processing for Large_Max_Size_Mutable
+
+ begin
+ if Is_Record_Type (Typ)
+ and then not Is_Limited_View (Typ)
+ and then Has_Defaulted_Discriminants (Typ)
+ then
+ -- Loop through the components, looking for an array whose upper
+ -- bound(s) depends on discriminants, where both the subtype of
+ -- the discriminant and the index subtype are too large.
+
declare
Comp : Entity_Id;
begin
Comp := First_Component (Typ);
while Present (Comp) loop
- if Has_Controlled_Component (Etype (Comp))
- or else
- (Chars (Comp) /= Name_uParent
- and then Is_Controlled (Etype (Comp)))
- or else
- (Is_Protected_Type (Etype (Comp))
- and then
- Present (Corresponding_Record_Type (Etype (Comp)))
- and then
- Has_Controlled_Component
- (Corresponding_Record_Type (Etype (Comp))))
- then
- Set_Has_Controlled_Component (Typ);
- exit;
- end if;
+ declare
+ Comp_Type : constant Entity_Id :=
+ Underlying_Type (Etype (Comp));
+
+ Hi : Node_Id;
+ Indx : Node_Id;
+ Ityp : Entity_Id;
+
+ begin
+ if Is_Array_Type (Comp_Type) then
+ Indx := First_Index (Comp_Type);
+
+ while Present (Indx) loop
+ Ityp := Etype (Indx);
+ Hi := Type_High_Bound (Ityp);
+
+ if Nkind (Hi) = N_Identifier
+ and then Ekind (Entity (Hi)) = E_Discriminant
+ and then Is_Large_Discrete_Type (Ityp)
+ and then Is_Large_Discrete_Type
+ (Etype (Entity (Hi)))
+ then
+ return True;
+ end if;
+
+ Next_Index (Indx);
+ end loop;
+ end if;
+ end;
Next_Component (Comp);
end loop;
end;
end if;
- end Ensure_Minimum_Decoration;
+
+ return False;
+ end Large_Max_Size_Mutable;
+
+ -- Local declarations
+
+ Typ : constant Entity_Id := Underlying_Type (Id);
-- Start of processing for Requires_Transient_Scope
begin
- if Debug_Flag_QQ then
- return Old_Result;
- end if;
-
Ensure_Minimum_Decoration (Id);
- declare
- New_Result : constant Boolean := New_Requires_Transient_Scope (Id);
+ -- 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.
- begin
- -- Assert that we're not putting things on the secondary stack if we
- -- didn't before; we are trying to AVOID secondary stack when
- -- possible.
+ if No (Typ) then
+ return False;
- if not Old_Result then
- pragma Assert (not New_Result);
- null;
- end if;
+ -- Do not expand transient scope for non-existent procedure return or
+ -- string literal types.
- if New_Result /= Old_Result then
- Results_Differ (Id, Old_Result, New_Result);
- end if;
+ elsif Typ = Standard_Void_Type
+ or else Ekind (Typ) = E_String_Literal_Subtype
+ then
+ return False;
- return New_Result;
- end;
- end Requires_Transient_Scope;
+ -- If Typ is a generic formal incomplete type, then we want to look at
+ -- the actual type.
- --------------------
- -- Results_Differ --
- --------------------
+ elsif Ekind (Typ) = E_Record_Subtype
+ and then Present (Cloned_Subtype (Typ))
+ then
+ return Requires_Transient_Scope (Cloned_Subtype (Typ));
- procedure Results_Differ
- (Id : Entity_Id;
- Old_Val : Boolean;
- New_Val : Boolean)
- is
- begin
- if False then -- False to disable; True for debugging
- Treepr.Print_Tree_Node (Id);
+ -- Functions returning specific tagged types may dispatch on result, so
+ -- their returned value is allocated on the secondary stack, even in the
+ -- definite case. We must treat nondispatching functions the same way,
+ -- because access-to-function types can point at both, so the calling
+ -- conventions must be compatible. Is_Tagged_Type includes controlled
+ -- types and class-wide types. Controlled type temporaries need
+ -- finalization.
- if Old_Val = New_Val then
- raise Program_Error;
- end if;
+ -- ???It's not clear why we need to return noncontrolled types with
+ -- controlled components on the secondary stack.
+
+ elsif Is_Tagged_Type (Typ) or else Has_Controlled_Component (Typ) then
+ return True;
+
+ -- Untagged definite subtypes are known size. This includes all
+ -- elementary [sub]types. Tasks are known size even if they have
+ -- discriminants. So we return False here, with one exception:
+ -- For a type like:
+ -- type T (Last : Natural := 0) is
+ -- X : String (1 .. Last);
+ -- end record;
+ -- we return True. That's because for "P(F(...));", where F returns T,
+ -- we don't know the size of the result at the call site, so if we
+ -- allocated it on the primary stack, we would have to allocate the
+ -- maximum size, which is way too big.
+
+ elsif Is_Definite_Subtype (Typ) or else Is_Task_Type (Typ) then
+ return Large_Max_Size_Mutable (Typ);
+
+ -- Indefinite (discriminated) untagged record or protected type
+
+ elsif Is_Record_Type (Typ) or else Is_Protected_Type (Typ) then
+ return not Caller_Known_Size_Record (Typ);
+
+ -- Unconstrained array
+
+ else
+ pragma Assert (Is_Array_Type (Typ) and not Is_Definite_Subtype (Typ));
+ return True;
end if;
- end Results_Differ;
+ end Requires_Transient_Scope;
--------------------------
-- Reset_Analyzed_Flags --
@@ -27583,8 +27569,6 @@ package body Sem_Util is
Style.Check_Identifier (Nod, Val_Actual);
end if;
end if;
-
- Set_Entity (N, Val);
end Set_Entity_With_Checks;
------------------------------
@@ -29626,10 +29610,10 @@ package body Sem_Util is
and then Covers
(Designated_Type (Expec_Type), Designated_Type (Found_Type))
then
- Error_Msg_N -- CODEFIX
+ Error_Msg_N
("result must be general access type!", Expr);
Error_Msg_NE -- CODEFIX
- ("add ALL to }!", Expr, Expec_Type);
+ ("\add ALL to }!", Expr, Expec_Type);
-- Another special check, if the expected type is an integer type,
-- but the expression is of type System.Address, and the parent is
@@ -31077,7 +31061,7 @@ package body Sem_Util is
--
-- See Large_Max_Size_Mutable function elsewhere in this
-- file (currently declared inside of
- -- New_Requires_Transient_Scope, so it would have to be
+ -- Requires_Transient_Scope, so it would have to be
-- moved if we want it to be callable from here).
end Indirect_Temp_Needed;
@@ -31131,9 +31115,9 @@ package body Sem_Util is
-- If the prefix is of an anonymous access type, then returns
-- the designated type of that type.
- -----------------------------
+ -----------------------------
-- Designated_Subtype_Mark --
- -----------------------------
+ -----------------------------
function Designated_Subtype_Mark return Node_Id is
Typ : Entity_Id := Prefix_Type;
@@ -31171,6 +31155,16 @@ package body Sem_Util is
Append_Item (Temp_Decl, Is_Eval_Stmt => False);
end if;
+ -- When a type associated with an indirect temporary gets
+ -- created for a 'Old attribute reference we need to mark
+ -- the type as such. This allows, for example, finalization
+ -- masters associated with them to be finalized in the correct
+ -- order after postcondition checks.
+
+ if Attribute_Name (Parent (Attr_Prefix)) = Name_Old then
+ Set_Stores_Attribute_Old_Prefix (Access_Type_Id);
+ end if;
+
Analyze (Access_Type_Decl);
Analyze (Temp_Decl);
diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads
index 1b993f9..6560180 100644
--- a/gcc/ada/sem_util.ads
+++ b/gcc/ada/sem_util.ads
@@ -765,6 +765,10 @@ package Sem_Util is
-- Returns the Node_Id associated with the innermost enclosing generic
-- unit, if any. If none, then returns Empty.
+ function Enclosing_HSS (Stmt : Node_Id) return Node_Id;
+ -- Returns the nearest handled sequence of statements that encloses a given
+ -- statement, or Empty.
+
function Enclosing_Lib_Unit_Entity
(E : Entity_Id := Current_Scope) return Entity_Id;
-- Returns the entity of enclosing library unit node which is the root of
@@ -1045,11 +1049,13 @@ package Sem_Util is
-- be installed on the scope stack to prevent spurious visibility errors.
procedure Gather_Components
- (Typ : Entity_Id;
- Comp_List : Node_Id;
- Governed_By : List_Id;
- Into : Elist_Id;
- Report_Errors : out Boolean);
+ (Typ : Entity_Id;
+ Comp_List : Node_Id;
+ Governed_By : List_Id;
+ Into : Elist_Id;
+ Report_Errors : out Boolean;
+ Allow_Compile_Time : Boolean := False;
+ Include_Interface_Tag : Boolean := False);
-- The purpose of this procedure is to gather the valid components in a
-- record type according to the values of its discriminants, in order to
-- validate the components of a record aggregate.
@@ -1072,6 +1078,12 @@ package Sem_Util is
-- Report_Errors is set to True if the values of the discriminants are
-- non-static.
--
+ -- Allow_Compile_Time if set to True, allows compile time known values in
+ -- Governed_By expressions in addition to static expressions.
+ --
+ -- Include_Interface_Tag if set to True, gather any interface tag
+ -- component, otherwise exclude them.
+ --
-- This procedure is also used when building a record subtype. If the
-- discriminant constraint of the subtype is static, the components of the
-- subtype are only those of the variants selected by the values of the
@@ -1503,9 +1515,7 @@ package Sem_Util is
function Has_Tagged_Component (Typ : Entity_Id) return Boolean;
-- Returns True if Typ is a composite type (array or record) that is either
-- a tagged type or has a subcomponent that is tagged. Returns False for a
- -- noncomposite type, or if no tagged subcomponents are present. This
- -- function is used to check if "=" has to be expanded into a bunch
- -- component comparisons.
+ -- noncomposite type, or if no tagged subcomponents are present.
function Has_Unconstrained_Access_Discriminants
(Subtyp : Entity_Id) return Boolean;
@@ -1540,6 +1550,12 @@ package Sem_Util is
-- Returns True if node N appears within a pragma that acts as an assertion
-- expression. See Sem_Prag for the list of qualifying pragmas.
+ function In_Check_Node (N : Node_Id) return Boolean;
+ -- Return True if N is part of a N_Raise_xxx_Error node
+
+ function In_Generic_Formal_Package (E : Entity_Id) return Boolean;
+ -- Returns True if entity E is inside a generic formal package
+
function In_Generic_Scope (E : Entity_Id) return Boolean;
-- Returns True if entity E is inside a generic scope
@@ -1691,6 +1707,10 @@ package Sem_Util is
function Is_Actual_Out_Parameter (N : Node_Id) return Boolean;
-- Determines if N is an actual parameter of out mode in a subprogram call
+ function Is_Actual_Out_Or_In_Out_Parameter (N : Node_Id) return Boolean;
+ -- Determines if N is an actual parameter of out or in out mode in a
+ -- subprogram call.
+
function Is_Actual_Parameter (N : Node_Id) return Boolean;
-- Determines if N is an actual parameter in a subprogram call
@@ -1879,7 +1899,9 @@ package Sem_Util is
-- . machine_emax = 2**10
-- . machine_emin = 3 - machine_emax
- function Is_Effectively_Volatile (Id : Entity_Id) return Boolean;
+ function Is_Effectively_Volatile
+ (Id : Entity_Id;
+ Ignore_Protected : Boolean := False) return Boolean;
-- Determine whether a type or object denoted by entity Id is effectively
-- volatile (SPARK RM 7.1.2). To qualify as such, the entity must be either
-- * Volatile without No_Caching
@@ -1887,9 +1909,14 @@ package Sem_Util is
-- * An array type whose component type is effectively volatile
-- * A protected type
-- * Descendant of type Ada.Synchronous_Task_Control.Suspension_Object
+ --
+ -- If Ignore_Protected is True, then a protected object/type is treated
+ -- like a non-protected record object/type for computing the result of
+ -- this query.
function Is_Effectively_Volatile_For_Reading
- (Id : Entity_Id) return Boolean;
+ (Id : Entity_Id;
+ Ignore_Protected : Boolean := False) return Boolean;
-- Determine whether a type or object denoted by entity Id is effectively
-- volatile for reading (SPARK RM 7.1.2). To qualify as such, the entity
-- must be either
@@ -1901,6 +1928,10 @@ package Sem_Util is
-- reading
-- * A protected type
-- * Descendant of type Ada.Synchronous_Task_Control.Suspension_Object
+ --
+ -- If Ignore_Protected is True, then a protected object/type is treated
+ -- like a non-protected record object/type for computing the result of
+ -- this query.
function Is_Effectively_Volatile_Object
(N : Node_Id) return Boolean;
@@ -2220,6 +2251,13 @@ package Sem_Util is
-- the N_Statement_Other_Than_Procedure_Call subtype from Sinfo).
-- Note that a label is *not* a statement, and will return False.
+ function Is_Static_Discriminant_Component (N : Node_Id) return Boolean;
+ -- Return True if N is guaranteed to a selected component containing a
+ -- statically known discriminant.
+ -- Note that this routine takes a conservative view and may return False
+ -- in some cases where N would match the criteria. In other words this
+ -- routine should be used to simplify or optimize the expanded code.
+
function Is_Static_Function (Subp : Entity_Id) return Boolean;
-- Determine whether subprogram Subp denotes a static function,
-- which is a function with the aspect Static with value True.
@@ -2479,7 +2517,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 this requires finalization
+ -- Determine whether type Typ is controlled and thus requires finalization
-- actions.
function Needs_One_Actual (E : Entity_Id) return Boolean;
diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb
index d1acf2f..b5275a8 100644
--- a/gcc/ada/sem_warn.adb
+++ b/gcc/ada/sem_warn.adb
@@ -750,9 +750,7 @@ package body Sem_Warn is
Fstm : constant Node_Id :=
Original_Node (First (Statements (Loop_Statement)));
begin
- if Nkind (Fstm) = N_Delay_Relative_Statement
- or else Nkind (Fstm) = N_Delay_Until_Statement
- then
+ if Nkind (Fstm) in N_Delay_Statement then
return;
end if;
end;
@@ -3077,14 +3075,14 @@ package body Sem_Warn is
-- Here we generate the warning
else
- -- If -gnatwc is set then output message that we could be IN
+ -- If -gnatwk is set then output message that we could be IN
if not Is_Trivial_Subprogram (Scope (E1)) then
if Warn_On_Constant then
Error_Msg_N
- ("?u?formal parameter & is not modified!", E1);
+ ("?k?formal parameter & is not modified!", E1);
Error_Msg_N
- ("\?u?mode could be IN instead of `IN OUT`!", E1);
+ ("\?k?mode could be IN instead of `IN OUT`!", E1);
-- We do not generate warnings for IN OUT parameters
-- unless we have at least -gnatwu. This is deliberately
@@ -4421,23 +4419,30 @@ package body Sem_Warn is
end if;
declare
- B : constant Node_Id := Parent (Parent (Scope (E)));
- S : Entity_Id := Empty;
+ S : Node_Id := Scope (E);
begin
- if Nkind (B) in
- N_Expression_Function |
- N_Subprogram_Body |
- N_Subprogram_Renaming_Declaration
- then
- S := Corresponding_Spec (B);
+ if Ekind (S) = E_Subprogram_Body then
+ S := Parent (S);
+
+ while Nkind (S) not in
+ N_Expression_Function |
+ N_Subprogram_Body |
+ N_Subprogram_Renaming_Declaration |
+ N_Empty
+ loop
+ S := Parent (S);
+ end loop;
+
+ if Present (S) then
+ S := Corresponding_Spec (S);
+ end if;
end if;
-- Do not warn for dispatching operations, because
-- that causes too much noise. Also do not warn for
- -- trivial subprograms.
+ -- trivial subprograms (e.g. stubs).
- if (not Present (S)
- or else not Is_Dispatching_Operation (S))
+ if (No (S) or else not Is_Dispatching_Operation (S))
and then not Is_Trivial_Subprogram (Scope (E))
then
Error_Msg_NE -- CODEFIX
diff --git a/gcc/ada/sinfo.adb b/gcc/ada/sinfo.adb
index c88d9a9..2d0a957 100644
--- a/gcc/ada/sinfo.adb
+++ b/gcc/ada/sinfo.adb
@@ -3535,6 +3535,14 @@ package body Sinfo is
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
@@ -7036,6 +7044,14 @@ package body Sinfo is
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
diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads
index 439eef4..f9b0667 100644
--- a/gcc/ada/sinfo.ads
+++ b/gcc/ada/sinfo.ads
@@ -2412,6 +2412,11 @@ package Sinfo is
-- 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)
-- Present in N_Subprogram_Body. True if the original source had an
-- N_Expression_Function, which was converted to the N_Subprogram_Body
@@ -4120,6 +4125,7 @@ package Sinfo is
-- Expression (Node3) (empty if Box_Present)
-- Loop_Actions (List5-Sem)
-- Box_Present (Flag15)
+ -- Was_Default_Init_Box_Association (Flag14)
-- Inherited_Discriminant (Flag13)
-- Note: this structure is used for both record component associations
@@ -4128,7 +4134,9 @@ 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).
+ -- 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.
----------------------------------
-- 4.3.1 Component Choice List --
@@ -10254,6 +10262,9 @@ package Sinfo is
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
@@ -11366,6 +11377,9 @@ package Sinfo is
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
@@ -13477,6 +13491,7 @@ package Sinfo is
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);
@@ -13842,6 +13857,7 @@ package Sinfo is
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);
diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl
index a9fd7c5..715a53a 100644
--- a/gcc/ada/snames.ads-tmpl
+++ b/gcc/ada/snames.ads-tmpl
@@ -147,6 +147,7 @@ package Snames is
Name_Integer_Literal : 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 + $;
Name_Static_Predicate : constant Name_Id := N + $;
Name_String_Literal : constant Name_Id := N + $;
Name_Synchronization : constant Name_Id := N + $;
@@ -167,6 +168,8 @@ package Snames is
Name_uEntry_Bodies : constant Name_Id := N + $;
Name_uExpunge : constant Name_Id := N + $;
Name_uFinalizer : constant Name_Id := N + $;
+ Name_uFinalizer_Old : constant Name_Id := N + $;
+ Name_uFinalization_Controller : constant Name_Id := N + $;
Name_uIdepth : constant Name_Id := N + $;
Name_uInit : constant Name_Id := N + $;
Name_uInit_Level : constant Name_Id := N + $;
@@ -175,11 +178,14 @@ package Snames is
Name_uObject : constant Name_Id := N + $;
Name_uPost : constant Name_Id := N + $;
Name_uPostconditions : constant Name_Id := N + $;
+ Name_uPostcond_Enabled : constant Name_Id := N + $;
Name_uPre : constant Name_Id := N + $;
Name_uPriority : constant Name_Id := N + $;
Name_uProcess_ATSD : constant Name_Id := N + $;
Name_uRelative_Deadline : constant Name_Id := N + $;
Name_uResult : constant Name_Id := N + $;
+ Name_uResult_Object_For_Postcond : constant Name_Id := N + $;
+ Name_uReturn_Success_For_Postcond : constant Name_Id := N + $;
Name_uSecondary_Stack : constant Name_Id := N + $;
Name_uSecondary_Stack_Size : constant Name_Id := N + $;
Name_uService : constant Name_Id := N + $;
@@ -756,8 +762,9 @@ package Snames is
Name_DLL : constant Name_Id := N + $;
Name_Win32 : constant Name_Id := N + $;
- -- Other special names used in processing attributes and pragmas
+ -- Other special names used in processing attributes, aspects, and pragmas
+ Name_Aggregate : constant Name_Id := N + $;
Name_Allow : constant Name_Id := N + $;
Name_Amount : constant Name_Id := N + $;
Name_As_Is : constant Name_Id := N + $;
@@ -839,9 +846,12 @@ package Snames is
Name_No_Use_Of_Entity : constant Name_Id := N + $;
Name_No_Use_Of_Pragma : constant Name_Id := N + $;
Name_No_Unroll : constant Name_Id := N + $;
+ Name_No_Unrecognized_Aspects : constant Name_Id := N + $;
+ Name_No_Unrecognized_Pragmas : constant Name_Id := N + $;
Name_No_Vector : constant Name_Id := N + $;
Name_Nominal : constant Name_Id := N + $;
Name_Non_Volatile : constant Name_Id := N + $;
+ Name_None : constant Name_Id := N + $;
Name_On : constant Name_Id := N + $;
Name_Optional : constant Name_Id := N + $;
Name_Policy : constant Name_Id := N + $;
@@ -1019,6 +1029,8 @@ package Snames is
Name_Signed_Zeros : constant Name_Id := N + $;
Name_Size : constant Name_Id := N + $;
Name_Small : constant Name_Id := N + $; -- Ada 83
+ Name_Small_Denominator : constant Name_Id := N + $; -- GNAT
+ Name_Small_Numerator : constant Name_Id := N + $; -- GNAT
Name_Storage_Size : constant Name_Id := N + $;
Name_Storage_Unit : constant Name_Id := N + $; -- GNAT
Name_Stream_Size : constant Name_Id := N + $; -- Ada 05
@@ -1356,186 +1368,17 @@ package Snames is
Name_Raise_Exception : constant Name_Id := N + $;
- -- Additional reserved words and identifiers used in GNAT Project Files
- -- Note that Name_External is already previously declared.
-
- -- Names with a -- GB annotation are only used in gprbuild or gprclean
-
- Name_Active : constant Name_Id := N + $;
- Name_Aggregate : constant Name_Id := N + $;
- Name_Archive_Builder : constant Name_Id := N + $;
- Name_Archive_Builder_Append_Option : constant Name_Id := N + $;
- Name_Archive_Indexer : constant Name_Id := N + $;
- Name_Archive_Suffix : constant Name_Id := N + $;
- Name_Artifacts : constant Name_Id := N + $;
- Name_Artifacts_In_Exec_Dir : constant Name_Id := N + $; -- GB
- Name_Artifacts_In_Object_Dir : constant Name_Id := N + $; -- GB
- Name_Binder : constant Name_Id := N + $;
- Name_Body_Suffix : constant Name_Id := N + $;
- Name_Builder : constant Name_Id := N + $;
- Name_Clean : constant Name_Id := N + $;
- Name_Compiler : constant Name_Id := N + $;
- Name_Compiler_Command : constant Name_Id := N + $; -- GB
- Name_Config_Body_File_Name : constant Name_Id := N + $;
- Name_Config_Body_File_Name_Index : constant Name_Id := N + $;
- Name_Config_Body_File_Name_Pattern : constant Name_Id := N + $;
- Name_Config_File_Switches : constant Name_Id := N + $;
- Name_Config_File_Unique : constant Name_Id := N + $;
- Name_Config_Spec_File_Name : constant Name_Id := N + $;
- Name_Config_Spec_File_Name_Index : constant Name_Id := N + $;
- Name_Config_Spec_File_Name_Pattern : constant Name_Id := N + $;
- Name_Configuration : constant Name_Id := N + $;
- Name_Cross_Reference : constant Name_Id := N + $;
- Name_Default_Language : constant Name_Id := N + $;
- Name_Default_Switches : constant Name_Id := N + $;
- Name_Dependency_Driver : constant Name_Id := N + $;
- Name_Dependency_Kind : constant Name_Id := N + $;
- Name_Dependency_Switches : constant Name_Id := N + $;
- Name_Driver : constant Name_Id := N + $;
- Name_Excluded_Source_Dirs : constant Name_Id := N + $;
- Name_Excluded_Source_Files : constant Name_Id := N + $;
- Name_Excluded_Source_List_File : constant Name_Id := N + $;
- Name_Exec_Dir : constant Name_Id := N + $;
- Name_Exec_Subdir : constant Name_Id := N + $;
- Name_Excluded_Patterns : constant Name_Id := N + $;
- Name_Executable : constant Name_Id := N + $;
- Name_Executable_Suffix : constant Name_Id := N + $;
- Name_Extends : constant Name_Id := N + $;
- Name_External_As_List : constant Name_Id := N + $;
- Name_Externally_Built : constant Name_Id := N + $;
- Name_Finder : constant Name_Id := N + $;
- Name_Global_Compilation_Switches : constant Name_Id := N + $;
- Name_Global_Configuration_Pragmas : constant Name_Id := N + $;
- Name_Global_Config_File : constant Name_Id := N + $; -- GB
- Name_Gnatls : constant Name_Id := N + $;
- Name_Gnatstub : constant Name_Id := N + $;
- Name_Gnu : constant Name_Id := N + $;
- Name_Ide : constant Name_Id := N + $;
- Name_Ignore_Source_Sub_Dirs : constant Name_Id := N + $;
- Name_Implementation : constant Name_Id := N + $;
- Name_Implementation_Exceptions : constant Name_Id := N + $;
- Name_Implementation_Suffix : constant Name_Id := N + $;
- Name_Included_Artifact_Patterns : constant Name_Id := N + $;
- Name_Included_Patterns : constant Name_Id := N + $;
- Name_Include_Switches : constant Name_Id := N + $;
- Name_Include_Path : constant Name_Id := N + $;
- Name_Include_Path_File : constant Name_Id := N + $;
- Name_Inherit_Source_Path : constant Name_Id := N + $;
- Name_Install : constant Name_Id := N + $;
- Name_Install_Name : constant Name_Id := N + $;
- Name_Languages : constant Name_Id := N + $;
- Name_Language_Kind : constant Name_Id := N + $;
- Name_Leading_Library_Options : constant Name_Id := N + $;
- Name_Leading_Required_Switches : constant Name_Id := N + $;
- Name_Leading_Switches : constant Name_Id := N + $;
- Name_Lib_Subdir : constant Name_Id := N + $;
- Name_Link_Lib_Subdir : constant Name_Id := N + $;
- Name_Library : constant Name_Id := N + $;
- Name_Library_Ali_Dir : constant Name_Id := N + $;
- Name_Library_Auto_Init : constant Name_Id := N + $;
- Name_Library_Auto_Init_Supported : constant Name_Id := N + $;
- Name_Library_Builder : constant Name_Id := N + $;
- Name_Library_Dir : constant Name_Id := N + $;
- Name_Library_GCC : constant Name_Id := N + $;
- Name_Library_Install_Name_Option : constant Name_Id := N + $;
- Name_Library_Interface : constant Name_Id := N + $;
- Name_Library_Kind : constant Name_Id := N + $;
- Name_Library_Name : constant Name_Id := N + $;
- Name_Library_Major_Minor_Id_Supported : constant Name_Id := N + $;
- Name_Library_Options : constant Name_Id := N + $;
- Name_Library_Partial_Linker : constant Name_Id := N + $;
- Name_Library_Reference_Symbol_File : constant Name_Id := N + $;
- Name_Library_Rpath_Options : constant Name_Id := N + $; -- GB
- Name_Library_Standalone : constant Name_Id := N + $;
- Name_Library_Encapsulated_Options : constant Name_Id := N + $; -- GB
- Name_Library_Encapsulated_Supported : constant Name_Id := N + $; -- GB
- Name_Library_Src_Dir : constant Name_Id := N + $;
- Name_Library_Support : constant Name_Id := N + $;
- Name_Library_Symbol_File : constant Name_Id := N + $;
- Name_Library_Symbol_Policy : constant Name_Id := N + $;
- Name_Library_Version : constant Name_Id := N + $;
- Name_Library_Version_Switches : constant Name_Id := N + $;
- Name_Linker : constant Name_Id := N + $;
- Name_Linker_Executable_Option : constant Name_Id := N + $;
- Name_Linker_Lib_Dir_Option : constant Name_Id := N + $;
- Name_Linker_Lib_Name_Option : constant Name_Id := N + $;
- Name_Local_Config_File : constant Name_Id := N + $; -- GB
- Name_Local_Configuration_Pragmas : constant Name_Id := N + $;
- Name_Locally_Removed_Files : constant Name_Id := N + $;
- Name_Map_File_Option : constant Name_Id := N + $;
- Name_Mapping_File_Switches : constant Name_Id := N + $;
- Name_Mapping_Spec_Suffix : constant Name_Id := N + $;
- Name_Mapping_Body_Suffix : constant Name_Id := N + $;
- Name_Max_Command_Line_Length : constant Name_Id := N + $;
- Name_Metrics : constant Name_Id := N + $;
- Name_Multi_Unit_Object_Separator : constant Name_Id := N + $;
- Name_Multi_Unit_Switches : constant Name_Id := N + $;
- Name_Naming : constant Name_Id := N + $;
- Name_None : constant Name_Id := N + $;
- Name_Object_Artifact_Extensions : constant Name_Id := N + $;
- Name_Object_File_Suffix : constant Name_Id := N + $;
- Name_Object_File_Switches : constant Name_Id := N + $;
- Name_Object_Generated : constant Name_Id := N + $;
- Name_Object_List : constant Name_Id := N + $;
- Name_Object_Path_Switches : constant Name_Id := N + $;
- Name_Objects_Linked : constant Name_Id := N + $;
- Name_Objects_Path : constant Name_Id := N + $;
- Name_Objects_Path_File : constant Name_Id := N + $;
- Name_Object_Dir : constant Name_Id := N + $;
- Name_Option_List : constant Name_Id := N + $;
- Name_Path_Syntax : constant Name_Id := N + $;
- Name_Pic_Option : constant Name_Id := N + $;
- Name_Pretty_Printer : constant Name_Id := N + $;
- Name_Prefix : constant Name_Id := N + $;
- Name_Project : constant Name_Id := N + $;
- Name_Project_Dir : constant Name_Id := N + $;
- Name_Project_Files : constant Name_Id := N + $;
- Name_Project_Path : constant Name_Id := N + $;
- Name_Project_Subdir : constant Name_Id := N + $;
- Name_Remote : constant Name_Id := N + $;
- Name_Required_Artifacts : constant Name_Id := N + $;
- Name_Response_File_Format : constant Name_Id := N + $;
- Name_Response_File_Switches : constant Name_Id := N + $;
- Name_Root_Dir : constant Name_Id := N + $;
- Name_Roots : constant Name_Id := N + $; -- GB
- Name_Required_Switches : constant Name_Id := N + $;
- Name_Run_Path_Option : constant Name_Id := N + $;
- Name_Run_Path_Origin : constant Name_Id := N + $;
- Name_Separate_Run_Path_Options : constant Name_Id := N + $;
- Name_Shared_Library_Minimum_Switches : constant Name_Id := N + $;
- Name_Shared_Library_Prefix : constant Name_Id := N + $;
- Name_Shared_Library_Suffix : constant Name_Id := N + $;
- Name_Separate_Suffix : constant Name_Id := N + $;
- Name_Source_Artifact_Extensions : constant Name_Id := N + $;
- Name_Source_Dirs : constant Name_Id := N + $;
- Name_Source_File_Switches : constant Name_Id := N + $;
- Name_Source_Files : constant Name_Id := N + $;
- Name_Source_List_File : constant Name_Id := N + $;
- Name_Sources_Subdir : constant Name_Id := N + $;
- Name_Spec : constant Name_Id := N + $;
- Name_Spec_Suffix : constant Name_Id := N + $;
- Name_Specification : constant Name_Id := N + $;
- Name_Specification_Exceptions : constant Name_Id := N + $;
- Name_Specification_Suffix : constant Name_Id := N + $;
- Name_Stack : constant Name_Id := N + $;
- Name_Switches : constant Name_Id := N + $;
- Name_Symbolic_Link_Supported : constant Name_Id := N + $;
- Name_Synchronize : constant Name_Id := N + $;
- Name_Toolchain_Description : constant Name_Id := N + $;
- Name_Toolchain_Version : constant Name_Id := N + $;
- Name_Trailing_Required_Switches : constant Name_Id := N + $;
- Name_Trailing_Switches : constant Name_Id := N + $;
- Name_Runtime_Library_Dir : constant Name_Id := N + $;
- Name_Runtime_Source_Dir : constant Name_Id := N + $;
-
-- Additional names used by the Repinfo unit
Name_Discriminant : constant Name_Id := N + $;
Name_Operands : constant Name_Id := N + $;
-- Other miscellaneous names used in front end
+ -- Note that the UP_ prefix means use the rest of the name in uppercase,
+ -- e.g. Name_UP_RESULT corresponds to the name "RESULT".
Name_Unaligned_Valid : constant Name_Id := N + $;
+ Name_UP_RESULT : constant Name_Id := N + $;
Name_Suspension_Object : constant Name_Id := N + $;
Name_Synchronous_Task_Control : constant Name_Id := N + $;
@@ -1715,6 +1558,8 @@ package Snames is
Attribute_Signed_Zeros,
Attribute_Size,
Attribute_Small,
+ Attribute_Small_Denominator,
+ Attribute_Small_Numerator,
Attribute_Storage_Size,
Attribute_Storage_Unit,
Attribute_Stream_Size,
diff --git a/gcc/ada/spark_xrefs.ads b/gcc/ada/spark_xrefs.ads
index 88a34c5..ffd7268 100644
--- a/gcc/ada/spark_xrefs.ads
+++ b/gcc/ada/spark_xrefs.ads
@@ -57,7 +57,8 @@ package SPARK_Xrefs is
Heap : Entity_Id := Empty;
-- A special entity which denotes the heap object; it should be considered
-- constant, but needs to be variable, because it can only be initialized
- -- after the node tables are created.
+ -- after the node tables are created. Also, it is only created if there is
+ -- an actual need for it, and remains Empty otherwise.
-----------------
-- Subprograms --
diff --git a/gcc/ada/stand.ads b/gcc/ada/stand.ads
index 5742e51..848239f 100644
--- a/gcc/ada/stand.ads
+++ b/gcc/ada/stand.ads
@@ -451,10 +451,11 @@ package Stand is
-- universal integer and universal real, it is never used for runtime
-- calculations).
- Standard_Integer_8 : Entity_Id;
- Standard_Integer_16 : Entity_Id;
- Standard_Integer_32 : Entity_Id;
- Standard_Integer_64 : Entity_Id;
+ Standard_Integer_8 : Entity_Id;
+ Standard_Integer_16 : Entity_Id;
+ Standard_Integer_32 : Entity_Id;
+ Standard_Integer_64 : Entity_Id;
+ Standard_Integer_128 : Entity_Id;
-- These are signed integer types with the indicated sizes. Used for the
-- underlying implementation types for fixed-point and enumeration types.
diff --git a/gcc/ada/switch-c.adb b/gcc/ada/switch-c.adb
index e086a5d..c6eb063 100644
--- a/gcc/ada/switch-c.adb
+++ b/gcc/ada/switch-c.adb
@@ -486,6 +486,12 @@ package body Switch.C is
Ptr := Ptr + 1;
Check_Aliasing_Of_Parameters := True;
+ -- -gnateb (config file basenames and checksums in ALI)
+
+ when 'b' =>
+ Ptr := Ptr + 1;
+ Config_Files_Store_Basename := True;
+
-- -gnatec (configuration pragmas)
when 'c' =>
diff --git a/gcc/ada/symbols.adb b/gcc/ada/symbols.adb
deleted file mode 100644
index d8d4992..0000000
--- a/gcc/ada/symbols.adb
+++ /dev/null
@@ -1,90 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- S Y M B O L S --
--- --
--- B o d y --
--- --
--- Copyright (C) 2003-2020, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- 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 is the default version of this package, used when the creation
--- of symbol files is not supported.
-
-with Ada.Text_IO; use Ada.Text_IO;
-
-package body Symbols is
-
- ----------------
- -- Initialize --
- ----------------
-
- procedure Initialize
- (Symbol_File : String;
- Reference : String;
- Symbol_Policy : Policy;
- Quiet : Boolean;
- Version : String;
- Success : out Boolean)
- is
- pragma Unreferenced (Symbol_File);
- pragma Unreferenced (Reference);
- pragma Unreferenced (Symbol_Policy);
- pragma Unreferenced (Quiet);
- pragma Unreferenced (Version);
- begin
- Put_Line
- ("creation of symbol files are not supported on this platform");
- Success := False;
- end Initialize;
-
- ----------------
- -- Processing --
- ----------------
-
- package body Processing is
-
- -------------
- -- Process --
- -------------
-
- procedure Process
- (Object_File : String;
- Success : out Boolean)
- is
- pragma Unreferenced (Object_File);
- begin
- Success := False;
- end Process;
-
- end Processing;
-
- --------------
- -- Finalize --
- --------------
-
- procedure Finalize
- (Quiet : Boolean;
- Success : out Boolean)
- is
- pragma Unreferenced (Quiet);
- begin
- Success := False;
- end Finalize;
-
-end Symbols;
diff --git a/gcc/ada/symbols.ads b/gcc/ada/symbols.ads
deleted file mode 100644
index 0193830..0000000
--- a/gcc/ada/symbols.ads
+++ /dev/null
@@ -1,115 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- S Y M B O L S --
--- --
--- S p e c --
--- --
--- Copyright (C) 2003-2020, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- 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 package allows the creation of symbol files to be used for linking
--- libraries. The format of symbol files depends on the platform, so there is
--- several implementations of the body.
-
-with GNAT.Dynamic_Tables;
-
-with System.OS_Lib; use System.OS_Lib;
-
-package Symbols is
-
- type Policy is
- -- Symbol policy
-
- (Autonomous,
- -- Create a symbol file without considering any reference
-
- Compliant,
- -- Either create a symbol file with the same major and minor IDs if
- -- all symbols are already found in the reference file or with an
- -- incremented minor ID, if not.
-
- Controlled,
- -- Fail if symbols are not the same as those in the reference file
-
- Restricted,
- -- Restrict the symbols to those in the symbol file. Fail if some
- -- symbols in the symbol file are not exported from the object files.
-
- Direct);
- -- The reference symbol file is copied to the symbol file
-
- type Symbol_Kind is (Data, Proc);
- -- To distinguish between the different kinds of symbols
-
- type Symbol_Data is record
- Name : String_Access;
- Kind : Symbol_Kind := Data;
- Present : Boolean := True;
- end record;
- -- Data (name and kind) for each of the symbols
-
- package Symbol_Table is new GNAT.Dynamic_Tables
- (Table_Component_Type => Symbol_Data,
- Table_Index_Type => Natural,
- Table_Low_Bound => 0,
- Table_Initial => 100,
- Table_Increment => 100);
- -- The symbol tables
-
- Original_Symbols : Symbol_Table.Instance;
- -- The symbols, if any, found in the reference symbol table
-
- Complete_Symbols : Symbol_Table.Instance;
- -- The symbols, if any, found in the objects files
-
- procedure Initialize
- (Symbol_File : String;
- Reference : String;
- Symbol_Policy : Policy;
- Quiet : Boolean;
- Version : String;
- Success : out Boolean);
- -- Initialize a symbol file. This procedure must be called before
- -- Processing any object file. Depending on the platforms and the
- -- circumstances, additional messages may be issued if Quiet is False.
-
- package Processing is
-
- -- This package, containing a single visible procedure Process, exists
- -- so that it can be a subunits, for some platforms, the body of package
- -- Symbols is common, while the subunit Processing is not.
-
- procedure Process
- (Object_File : String;
- Success : out Boolean);
- -- Get the symbols from an object file. Success is set to True if the
- -- object file exists and has the expected format.
-
- end Processing;
-
- procedure Finalize
- (Quiet : Boolean;
- Success : out Boolean);
- -- Finalize the symbol file. This procedure should be called after
- -- Initialize (once) and Process (one or more times). If Success is
- -- True, the symbol file is written and closed, ready to be used for
- -- linking the library. Depending on the platforms and the circumstances,
- -- additional messages may be issued if Quiet is False.
-
-end Symbols;
diff --git a/gcc/ada/targparm.adb b/gcc/ada/targparm.adb
index 0be05ae..cbc3f89 100644
--- a/gcc/ada/targparm.adb
+++ b/gcc/ada/targparm.adb
@@ -39,8 +39,7 @@ package body Targparm is
-- The following array defines a tag name for each entry
type Targparm_Tags is
- (AAM, -- AAMP
- ACR, -- Always_Compatible_Rep
+ (ACR, -- Always_Compatible_Rep
ASD, -- Atomic_Sync_Default
BDC, -- Backend_Divide_Checks
BOC, -- Backend_Overflow_Checks
@@ -49,9 +48,7 @@ package body Targparm is
D32, -- Duration_32_Bits
DEN, -- Denorm
EXS, -- Exit_Status_Supported
- FEL, -- Frontend_Layout
FEX, -- Frontend_Exceptions
- FFO, -- Fractional_Fixed_Ops
MOV, -- Machine_Overflows
MRN, -- Machine_Rounds
PAS, -- Preallocated_Stacks
@@ -73,7 +70,6 @@ package body Targparm is
-- The following list of string constants gives the parameter names
- AAM_Str : aliased constant Source_Buffer := "AAMP";
ACR_Str : aliased constant Source_Buffer := "Always_Compatible_Rep";
ASD_Str : aliased constant Source_Buffer := "Atomic_Sync_Default";
BDC_Str : aliased constant Source_Buffer := "Backend_Divide_Checks";
@@ -83,9 +79,7 @@ package body Targparm is
D32_Str : aliased constant Source_Buffer := "Duration_32_Bits";
DEN_Str : aliased constant Source_Buffer := "Denorm";
EXS_Str : aliased constant Source_Buffer := "Exit_Status_Supported";
- FEL_Str : aliased constant Source_Buffer := "Frontend_Layout";
FEX_Str : aliased constant Source_Buffer := "Frontend_Exceptions";
- FFO_Str : aliased constant Source_Buffer := "Fractional_Fixed_Ops";
MOV_Str : aliased constant Source_Buffer := "Machine_Overflows";
MRN_Str : aliased constant Source_Buffer := "Machine_Rounds";
PAS_Str : aliased constant Source_Buffer := "Preallocated_Stacks";
@@ -107,8 +101,7 @@ package body Targparm is
type Buffer_Ptr is access constant Source_Buffer;
Targparm_Str : constant array (Targparm_Tags) of Buffer_Ptr :=
- (AAM => AAM_Str'Access,
- ACR => ACR_Str'Access,
+ (ACR => ACR_Str'Access,
ASD => ASD_Str'Access,
BDC => BDC_Str'Access,
BOC => BOC_Str'Access,
@@ -117,9 +110,7 @@ package body Targparm is
D32 => D32_Str'Access,
DEN => DEN_Str'Access,
EXS => EXS_Str'Access,
- FEL => FEL_Str'Access,
FEX => FEX_Str'Access,
- FFO => FFO_Str'Access,
MOV => MOV_Str'Access,
MRN => MRN_Str'Access,
PAS => PAS_Str'Access,
@@ -803,7 +794,6 @@ package body Targparm is
Result := (System_Text (P) = 'T');
case K is
- when AAM => null;
when ACR => Always_Compatible_Rep_On_Target := Result;
when ASD => Atomic_Sync_Default_On_Target := Result;
when BDC => Backend_Divide_Checks_On_Target := Result;
@@ -813,9 +803,7 @@ package body Targparm is
when D32 => Duration_32_Bits_On_Target := Result;
when DEN => Denorm_On_Target := Result;
when EXS => Exit_Status_Supported_On_Target := Result;
- when FEL => null;
when FEX => Frontend_Exceptions_On_Target := Result;
- when FFO => Fractional_Fixed_Ops_On_Target := Result;
when MOV => Machine_Overflows_On_Target := Result;
when MRN => Machine_Rounds_On_Target := Result;
when PAS => Preallocated_Stacks_On_Target := Result;
diff --git a/gcc/ada/targparm.ads b/gcc/ada/targparm.ads
index 60b2367..5195a39 100644
--- a/gcc/ada/targparm.ads
+++ b/gcc/ada/targparm.ads
@@ -544,16 +544,6 @@ package Targparm is
-- WARNING: There is a matching C declaration of this variable in fe.h
- -------------------------------------------
- -- Boolean-Valued Fixed-Point Attributes --
- -------------------------------------------
-
- Fractional_Fixed_Ops_On_Target : Boolean := False;
- -- Set to True for targets that support fixed-by-fixed multiplication
- -- and division for fixed-point types with a small value equal to
- -- 2 ** (-(T'Object_Size - 1)) and whose values have an absolute
- -- value less than 1.0.
-
-----------------
-- Subprograms --
-----------------
diff --git a/gcc/ada/terminals.c b/gcc/ada/terminals.c
index 81388a7..ec9db3a 100644
--- a/gcc/ada/terminals.c
+++ b/gcc/ada/terminals.c
@@ -1244,7 +1244,7 @@ allocate_pty_desc (pty_desc **desc) {
result->slave_fd = slave_fd;
/* the string returned by ptsname or _getpty is a static allocated string. So
we should make a copy */
- strncpy (result->slave_name, slave_name, sizeof (result->slave_name));
+ strncpy (result->slave_name, slave_name, sizeof (result->slave_name) - 1);
result->slave_name[sizeof (result->slave_name) - 1] = '\0';
result->child_pid = -1;
*desc=result;
diff --git a/gcc/ada/tracebak.c b/gcc/ada/tracebak.c
index d643cfc..23ed8da 100644
--- a/gcc/ada/tracebak.c
+++ b/gcc/ada/tracebak.c
@@ -309,6 +309,13 @@ __gnat_backtrace (void **array,
#define USING_ARM_UNWINDING 1
#endif
+/*---------------------- ARM Linux ------------------------------------ -*/
+#elif (defined (__ARMEL__) && defined (__linux))
+
+#define USE_GCC_UNWINDER
+#define PC_ADJUST -2
+#define USING_ARM_UNWINDING 1
+
/*---------------------- PPC AIX/PPC Lynx 178/Older Darwin --------------*/
#elif ((defined (_POWER) && defined (_AIX)) || \
(defined (__powerpc__) && defined (__Lynx__) && !defined(__ELF__)) || \
diff --git a/gcc/ada/ttypes.ads b/gcc/ada/ttypes.ads
index ebd02b3..46f9698 100644
--- a/gcc/ada/ttypes.ads
+++ b/gcc/ada/ttypes.ads
@@ -26,7 +26,6 @@
-- This package contains constants describing target properties
with Types; use Types;
-with Get_Targ;
with Set_Targ;
package Ttypes is
@@ -102,63 +101,33 @@ package Ttypes is
Standard_Short_Short_Integer_Size : constant Pos :=
Set_Targ.Char_Size;
- Standard_Short_Short_Integer_Width : constant Pos :=
- Get_Targ.Width_From_Size
- (Standard_Short_Short_Integer_Size);
Standard_Short_Integer_Size : constant Pos :=
Set_Targ.Short_Size;
- Standard_Short_Integer_Width : constant Pos :=
- Get_Targ.Width_From_Size
- (Standard_Short_Integer_Size);
Standard_Integer_Size : constant Pos :=
Set_Targ.Int_Size;
- Standard_Integer_Width : constant Pos :=
- Get_Targ.Width_From_Size
- (Standard_Integer_Size);
Standard_Long_Integer_Size : constant Pos :=
Set_Targ.Long_Size;
- Standard_Long_Integer_Width : constant Pos :=
- Get_Targ.Width_From_Size
- (Standard_Long_Integer_Size);
Standard_Long_Long_Integer_Size : constant Pos :=
Set_Targ.Long_Long_Size;
- Standard_Long_Long_Integer_Width : constant Pos :=
- Get_Targ.Width_From_Size
- (Standard_Long_Long_Integer_Size);
Standard_Long_Long_Long_Integer_Size : Pos :=
Set_Targ.Long_Long_Long_Size;
- Standard_Long_Long_Long_Integer_Width : Pos :=
- Get_Targ.Width_From_Size
- (Standard_Long_Long_Long_Integer_Size);
Standard_Short_Float_Size : constant Pos :=
Set_Targ.Float_Size;
- Standard_Short_Float_Digits : constant Pos :=
- Get_Targ.Digits_From_Size
- (Standard_Short_Float_Size);
Standard_Float_Size : constant Pos :=
Set_Targ.Float_Size;
- Standard_Float_Digits : constant Pos :=
- Get_Targ.Digits_From_Size
- (Standard_Float_Size);
Standard_Long_Float_Size : constant Pos :=
Set_Targ.Double_Size;
- Standard_Long_Float_Digits : constant Pos :=
- Get_Targ.Digits_From_Size
- (Standard_Long_Float_Size);
Standard_Long_Long_Float_Size : constant Pos :=
Set_Targ.Long_Double_Size;
- Standard_Long_Long_Float_Digits : constant Pos :=
- Get_Targ.Digits_From_Size
- (Standard_Long_Long_Float_Size);
Standard_Character_Size : constant Pos := Set_Targ.Char_Size;
diff --git a/gcc/ada/uintp.ads b/gcc/ada/uintp.ads
index 648ee31..5f1f759 100644
--- a/gcc/ada/uintp.ads
+++ b/gcc/ada/uintp.ads
@@ -63,6 +63,7 @@ package Uintp is
Uint_15 : constant Uint;
Uint_16 : constant Uint;
Uint_24 : constant Uint;
+ Uint_31 : constant Uint;
Uint_32 : constant Uint;
Uint_63 : constant Uint;
Uint_64 : constant Uint;
@@ -80,9 +81,13 @@ package Uintp is
Uint_Minus_8 : constant Uint;
Uint_Minus_9 : constant Uint;
Uint_Minus_12 : constant Uint;
+ Uint_Minus_18 : constant Uint;
+ Uint_Minus_31 : constant Uint;
Uint_Minus_36 : constant Uint;
Uint_Minus_63 : constant Uint;
+ Uint_Minus_76 : constant Uint;
Uint_Minus_80 : constant Uint;
+ Uint_Minus_127 : constant Uint;
Uint_Minus_128 : constant Uint;
type UI_Vector is array (Pos range <>) of Int;
@@ -281,7 +286,7 @@ package Uintp is
-- or decimal format. Auto, the default setting, lets the routine make a
-- decision based on the value.
- UI_Image_Max : constant := 48; -- Enough for a 128-bit number
+ UI_Image_Max : constant := 1024;
UI_Image_Buffer : String (1 .. UI_Image_Max);
UI_Image_Length : Natural;
-- Buffer used for UI_Image as described below
@@ -470,6 +475,7 @@ private
Uint_15 : constant Uint := Uint (Uint_Direct_Bias + 15);
Uint_16 : constant Uint := Uint (Uint_Direct_Bias + 16);
Uint_24 : constant Uint := Uint (Uint_Direct_Bias + 24);
+ Uint_31 : constant Uint := Uint (Uint_Direct_Bias + 31);
Uint_32 : constant Uint := Uint (Uint_Direct_Bias + 32);
Uint_63 : constant Uint := Uint (Uint_Direct_Bias + 63);
Uint_64 : constant Uint := Uint (Uint_Direct_Bias + 64);
@@ -487,9 +493,13 @@ private
Uint_Minus_8 : constant Uint := Uint (Uint_Direct_Bias - 8);
Uint_Minus_9 : constant Uint := Uint (Uint_Direct_Bias - 9);
Uint_Minus_12 : constant Uint := Uint (Uint_Direct_Bias - 12);
+ Uint_Minus_18 : constant Uint := Uint (Uint_Direct_Bias - 18);
+ Uint_Minus_31 : constant Uint := Uint (Uint_Direct_Bias - 31);
Uint_Minus_36 : constant Uint := Uint (Uint_Direct_Bias - 36);
Uint_Minus_63 : constant Uint := Uint (Uint_Direct_Bias - 63);
+ Uint_Minus_76 : constant Uint := Uint (Uint_Direct_Bias - 76);
Uint_Minus_80 : constant Uint := Uint (Uint_Direct_Bias - 80);
+ Uint_Minus_127 : constant Uint := Uint (Uint_Direct_Bias - 127);
Uint_Minus_128 : constant Uint := Uint (Uint_Direct_Bias - 128);
Uint_Max_Simple_Mul : constant := Uint_Direct_Bias + 2**15;
diff --git a/gcc/ada/urealp.adb b/gcc/ada/urealp.adb
index f45f261..88cb681 100644
--- a/gcc/ada/urealp.adb
+++ b/gcc/ada/urealp.adb
@@ -73,20 +73,28 @@ package body Urealp is
-- The following universal reals are the values returned by the constant
-- functions. They are initialized by the initialization procedure.
- UR_0 : Ureal;
- UR_M_0 : Ureal;
- UR_Tenth : Ureal;
- UR_Half : Ureal;
- UR_1 : Ureal;
- UR_2 : Ureal;
- UR_10 : Ureal;
- UR_10_36 : Ureal;
- UR_M_10_36 : Ureal;
- UR_100 : Ureal;
- UR_2_128 : Ureal;
- UR_2_80 : Ureal;
- UR_2_M_128 : Ureal;
- UR_2_M_80 : Ureal;
+ UR_0 : Ureal;
+ UR_M_0 : Ureal;
+ UR_Tenth : Ureal;
+ UR_Half : Ureal;
+ UR_1 : Ureal;
+ UR_2 : Ureal;
+ UR_10 : Ureal;
+ UR_2_10_18 : Ureal;
+ UR_9_10_36 : Ureal;
+ UR_10_76 : Ureal;
+ UR_M_2_10_18 : Ureal;
+ UR_M_9_10_36 : Ureal;
+ UR_M_10_76 : Ureal;
+ UR_100 : Ureal;
+ UR_2_127 : Ureal;
+ UR_2_128 : Ureal;
+ UR_2_31 : Ureal;
+ UR_2_63 : Ureal;
+ UR_2_80 : Ureal;
+ UR_2_M_127 : Ureal;
+ UR_2_M_128 : Ureal;
+ UR_2_M_80 : Ureal;
Normalized_Real : Ureal := No_Ureal;
-- Used to memoize Norm_Num and Norm_Den, if either of these functions
@@ -288,20 +296,28 @@ package body Urealp is
procedure Initialize is
begin
Ureals.Init;
- UR_0 := UR_From_Components (Uint_0, Uint_1, 0, False);
- UR_M_0 := UR_From_Components (Uint_0, Uint_1, 0, True);
- UR_Half := UR_From_Components (Uint_1, Uint_1, 2, False);
- UR_Tenth := UR_From_Components (Uint_1, Uint_1, 10, False);
- UR_1 := UR_From_Components (Uint_1, Uint_1, 0, False);
- UR_2 := UR_From_Components (Uint_1, Uint_Minus_1, 2, False);
- UR_10 := UR_From_Components (Uint_1, Uint_Minus_1, 10, False);
- UR_10_36 := UR_From_Components (Uint_1, Uint_Minus_36, 10, False);
- UR_M_10_36 := UR_From_Components (Uint_1, Uint_Minus_36, 10, True);
- UR_100 := UR_From_Components (Uint_1, Uint_Minus_2, 10, False);
- UR_2_128 := UR_From_Components (Uint_1, Uint_Minus_128, 2, False);
- UR_2_M_128 := UR_From_Components (Uint_1, Uint_128, 2, False);
- UR_2_80 := UR_From_Components (Uint_1, Uint_Minus_80, 2, False);
- UR_2_M_80 := UR_From_Components (Uint_1, Uint_80, 2, False);
+ UR_0 := UR_From_Components (Uint_0, Uint_1, 0, False);
+ UR_M_0 := UR_From_Components (Uint_0, Uint_1, 0, True);
+ UR_Half := UR_From_Components (Uint_1, Uint_1, 2, False);
+ UR_Tenth := UR_From_Components (Uint_1, Uint_1, 10, False);
+ UR_1 := UR_From_Components (Uint_1, Uint_1, 0, False);
+ UR_2 := UR_From_Components (Uint_1, Uint_Minus_1, 2, False);
+ UR_10 := UR_From_Components (Uint_1, Uint_Minus_1, 10, False);
+ UR_2_10_18 := UR_From_Components (Uint_2, Uint_Minus_18, 10, False);
+ UR_9_10_36 := UR_From_Components (Uint_9, Uint_Minus_36, 10, False);
+ UR_10_76 := UR_From_Components (Uint_1, Uint_Minus_76, 10, False);
+ UR_M_2_10_18 := UR_From_Components (Uint_2, Uint_Minus_18, 10, True);
+ UR_M_9_10_36 := UR_From_Components (Uint_9, Uint_Minus_36, 10, True);
+ UR_M_10_76 := UR_From_Components (Uint_1, Uint_Minus_76, 10, True);
+ UR_100 := UR_From_Components (Uint_1, Uint_Minus_2, 10, False);
+ UR_2_127 := UR_From_Components (Uint_1, Uint_Minus_127, 2, False);
+ UR_2_M_127 := UR_From_Components (Uint_1, Uint_127, 2, False);
+ UR_2_128 := UR_From_Components (Uint_1, Uint_Minus_128, 2, False);
+ UR_2_M_128 := UR_From_Components (Uint_1, Uint_128, 2, False);
+ UR_2_31 := UR_From_Components (Uint_1, Uint_Minus_31, 2, False);
+ UR_2_63 := UR_From_Components (Uint_1, Uint_Minus_63, 2, False);
+ UR_2_80 := UR_From_Components (Uint_1, Uint_Minus_80, 2, False);
+ UR_2_M_80 := UR_From_Components (Uint_1, Uint_80, 2, False);
end Initialize;
----------------
@@ -1408,14 +1424,6 @@ package body Urealp is
UI_Write (Int (UI_Image_Length - 1) - Val.Den, Decimal);
end if;
- -- Constants in a base other than 10 can still be easily written in
- -- normal Ada literal style if the numerator is one.
-
- elsif Val.Rbase /= 0 and then Val.Num = 1 then
- Write_Int (Val.Rbase);
- Write_Str ("#1.0#E");
- UI_Write (-Val.Den);
-
-- Other constants with a base other than 10 are written using one of
-- the following forms, depending on the sign of the number and the
-- sign of the exponent (= minus denominator value). See that we are
@@ -1525,14 +1533,50 @@ package body Urealp is
return UR_100;
end Ureal_100;
+ -------------------
+ -- Ureal_2_10_18 --
+ -------------------
+
+ function Ureal_2_10_18 return Ureal is
+ begin
+ return UR_2_10_18;
+ end Ureal_2_10_18;
+
+ -------------------
+ -- Ureal_9_10_36 --
+ -------------------
+
+ function Ureal_9_10_36 return Ureal is
+ begin
+ return UR_9_10_36;
+ end Ureal_9_10_36;
+
-----------------
- -- Ureal_10_36 --
+ -- Ureal_10_76 --
-----------------
- function Ureal_10_36 return Ureal is
+ function Ureal_10_76 return Ureal is
+ begin
+ return UR_10_76;
+ end Ureal_10_76;
+
+ ----------------
+ -- Ureal_2_31 --
+ ----------------
+
+ function Ureal_2_31 return Ureal is
+ begin
+ return UR_2_31;
+ end Ureal_2_31;
+
+ ----------------
+ -- Ureal_2_63 --
+ ----------------
+
+ function Ureal_2_63 return Ureal is
begin
- return UR_10_36;
- end Ureal_10_36;
+ return UR_2_63;
+ end Ureal_2_63;
----------------
-- Ureal_2_80 --
@@ -1544,6 +1588,15 @@ package body Urealp is
end Ureal_2_80;
-----------------
+ -- Ureal_2_127 --
+ -----------------
+
+ function Ureal_2_127 return Ureal is
+ begin
+ return UR_2_127;
+ end Ureal_2_127;
+
+ -----------------
-- Ureal_2_128 --
-----------------
@@ -1562,6 +1615,15 @@ package body Urealp is
end Ureal_2_M_80;
-------------------
+ -- Ureal_2_M_127 --
+ -------------------
+
+ function Ureal_2_M_127 return Ureal is
+ begin
+ return UR_2_M_127;
+ end Ureal_2_M_127;
+
+ -------------------
-- Ureal_2_M_128 --
-------------------
@@ -1588,14 +1650,32 @@ package body Urealp is
return UR_M_0;
end Ureal_M_0;
+ ---------------------
+ -- Ureal_M_2_10_18 --
+ ---------------------
+
+ function Ureal_M_2_10_18 return Ureal is
+ begin
+ return UR_M_2_10_18;
+ end Ureal_M_2_10_18;
+
+ ---------------------
+ -- Ureal_M_9_10_36 --
+ ---------------------
+
+ function Ureal_M_9_10_36 return Ureal is
+ begin
+ return UR_M_9_10_36;
+ end Ureal_M_9_10_36;
+
-------------------
- -- Ureal_M_10_36 --
+ -- Ureal_M_10_76 --
-------------------
- function Ureal_M_10_36 return Ureal is
+ function Ureal_M_10_76 return Ureal is
begin
- return UR_M_10_36;
- end Ureal_M_10_36;
+ return UR_M_10_76;
+ end Ureal_M_10_76;
-----------------
-- Ureal_Tenth --
diff --git a/gcc/ada/urealp.ads b/gcc/ada/urealp.ads
index 5c511ef..3f74735 100644
--- a/gcc/ada/urealp.ads
+++ b/gcc/ada/urealp.ads
@@ -106,23 +106,47 @@ package Urealp is
function Ureal_100 return Ureal;
-- Returns value 100.0
+ function Ureal_2_31 return Ureal;
+ -- Returns value 2.0 ** 31
+
+ function Ureal_2_63 return Ureal;
+ -- Returns value 2.0 ** 63
+
function Ureal_2_80 return Ureal;
-- Returns value 2.0 ** 80
function Ureal_2_M_80 return Ureal;
-- Returns value 2.0 ** (-80)
+ function Ureal_2_127 return Ureal;
+ -- Returns value 2.0 ** 127
+
+ function Ureal_2_M_127 return Ureal;
+ -- Returns value 2.0 ** (-127)
+
function Ureal_2_128 return Ureal;
-- Returns value 2.0 ** 128
function Ureal_2_M_128 return Ureal;
-- Returns value 2.0 ** (-128)
- function Ureal_10_36 return Ureal;
- -- Returns value 10.0 ** 36
+ function Ureal_2_10_18 return Ureal;
+ -- Returns value 2.0 * 10.0 ** 18
+
+ function Ureal_M_2_10_18 return Ureal;
+ -- Returns value -2.0 * 10.0 ** 18
+
+ function Ureal_9_10_36 return Ureal;
+ -- Returns value 9.0 * 10.0 ** 36
+
+ function Ureal_M_9_10_36 return Ureal;
+ -- Returns value -9.0 * 10.0 ** 36
+
+ function Ureal_10_76 return Ureal;
+ -- Returns value 10.0 ** 76
- function Ureal_M_10_36 return Ureal;
- -- Returns value -10.0 ** 36
+ function Ureal_M_10_76 return Ureal;
+ -- Returns value -10.0 ** 76
-----------------
-- Subprograms --
diff --git a/gcc/ada/validsw.adb b/gcc/ada/validsw.adb
index dd3b6a0..2f8d769 100644
--- a/gcc/ada/validsw.adb
+++ b/gcc/ada/validsw.adb
@@ -47,56 +47,6 @@ package body Validsw is
Validity_Check_Tests := False;
end Reset_Validity_Check_Options;
- ---------------------------------
- -- Save_Validity_Check_Options --
- ---------------------------------
-
- procedure Save_Validity_Check_Options
- (Options : out Validity_Check_Options)
- is
- P : Natural := 0;
-
- procedure Add (C : Character; S : Boolean);
- -- Add given character C to string if switch S is true
-
- procedure Add (C : Character; S : Boolean) is
- begin
- if S then
- P := P + 1;
- Options (P) := C;
- end if;
- end Add;
-
- -- Start of processing for Save_Validity_Check_Options
-
- begin
- for K in Options'Range loop
- Options (K) := ' ';
- end loop;
-
- Add ('e', Validity_Check_Components);
- Add ('c', Validity_Check_Copies);
- Add ('d', Validity_Check_Default);
- Add ('f', Validity_Check_Floating_Point);
- Add ('i', Validity_Check_In_Params);
- Add ('m', Validity_Check_In_Out_Params);
- Add ('o', Validity_Check_Operands);
- Add ('p', Validity_Check_Parameters);
- Add ('r', Validity_Check_Returns);
- Add ('s', Validity_Check_Subscripts);
- Add ('t', Validity_Check_Tests);
- end Save_Validity_Check_Options;
-
- ----------------------------------------
- -- Set_Default_Validity_Check_Options --
- ----------------------------------------
-
- procedure Set_Default_Validity_Check_Options is
- begin
- Reset_Validity_Check_Options;
- Set_Validity_Check_Options ("d");
- end Set_Default_Validity_Check_Options;
-
--------------------------------
-- Set_Validity_Check_Options --
--------------------------------
diff --git a/gcc/ada/validsw.ads b/gcc/ada/validsw.ads
index 4b2e4b7..6af95d4 100644
--- a/gcc/ada/validsw.ads
+++ b/gcc/ada/validsw.ads
@@ -126,10 +126,6 @@ package Validsw is
-- Subprograms --
-----------------
- procedure Set_Default_Validity_Check_Options;
- -- This procedure is called to set the default validity checking options
- -- that apply if no Validity_Check switches or pragma is given.
-
procedure Set_Validity_Check_Options
(Options : String;
OK : out Boolean;
@@ -146,8 +142,7 @@ package Validsw is
procedure Set_Validity_Check_Options (Options : String);
-- Like the above procedure, except that the call is simply ignored if
-- there are any error conditions, this is for example appropriate for
- -- calls where the string is known to be valid, e.g. because it was
- -- obtained by Save_Validity_Check_Options.
+ -- calls where the string is known to be valid.
procedure Reset_Validity_Check_Options;
-- Sets all validity check options to off
@@ -155,10 +150,4 @@ package Validsw is
subtype Validity_Check_Options is String (1 .. 16);
-- Long enough string to hold all options from Save call below
- procedure Save_Validity_Check_Options
- (Options : out Validity_Check_Options);
- -- Sets Options to represent current selection of options. This
- -- set can be restored by first calling Reset_Validity_Check_Options,
- -- and then calling Set_Validity_Check_Options with the Options string.
-
end Validsw;
diff --git a/gcc/ada/vxworks7-cert-rtp-link.spec b/gcc/ada/vxworks7-cert-rtp-link.spec
new file mode 100644
index 0000000..0e0440f
--- /dev/null
+++ b/gcc/ada/vxworks7-cert-rtp-link.spec
@@ -0,0 +1,9 @@
+*self_spec:
++ %{!nostdlib:-nodefaultlibs -nostartfiles}
+
+*link:
++ %{!nostdlib:%{mrtp:%{!shared: \
+ -l:certRtp.o \
+ -L%:getenv(VSB_DIR /usr/lib/common/objcert) \
+ -T%:getenv(VSB_DIR /usr/ldscripts/rtp.ld) \
+ }}}
diff --git a/gcc/ada/xsnamest.adb b/gcc/ada/xsnamest.adb
index 834d3c4..941e2e8 100644
--- a/gcc/ada/xsnamest.adb
+++ b/gcc/ada/xsnamest.adb
@@ -260,11 +260,14 @@ begin
Replace (M, Translate (A, Xlate_U_Und));
Translate (Name0, Lower_Case_Map);
- elsif not Match (Name0, "Op_", "") then
- Translate (Name0, Lower_Case_Map);
+ elsif Match (Name0, "UP_", "") then
+ Translate (Name0, Upper_Case_Map);
- else
+ elsif Match (Name0, "Op_", "") then
Name0 := 'O' & Translate (Name0, Lower_Case_Map);
+
+ else
+ Translate (Name0, Lower_Case_Map);
end if;
if not Match (Name0, Chk_Low) then