aboutsummaryrefslogtreecommitdiff
path: root/gcc/ada
diff options
context:
space:
mode:
Diffstat (limited to 'gcc/ada')
-rw-r--r--gcc/ada/ChangeLog1810
-rw-r--r--gcc/ada/Make-generated.in18
-rw-r--r--gcc/ada/Makefile.rtl117
-rw-r--r--gcc/ada/accessibility.adb11
-rw-r--r--gcc/ada/ada_get_targ.adb9
-rw-r--r--gcc/ada/adaint.c7
-rw-r--r--gcc/ada/ali.ads4
-rw-r--r--gcc/ada/aspects.ads15
-rw-r--r--gcc/ada/atree.adb4
-rw-r--r--gcc/ada/atree.ads50
-rw-r--r--gcc/ada/bindgen.adb20
-rw-r--r--gcc/ada/checks.adb15
-rw-r--r--gcc/ada/clean.adb7
-rw-r--r--gcc/ada/comperr.adb18
-rw-r--r--gcc/ada/contracts.adb125
-rw-r--r--gcc/ada/contracts.ads4
-rw-r--r--gcc/ada/cstand.adb53
-rw-r--r--gcc/ada/cstand.ads2
-rw-r--r--gcc/ada/debug.adb13
-rw-r--r--gcc/ada/debug_a.adb7
-rw-r--r--gcc/ada/diagnostics-brief_emitter.adb137
-rw-r--r--gcc/ada/diagnostics-brief_emitter.ads28
-rw-r--r--gcc/ada/diagnostics-constructors.adb514
-rw-r--r--gcc/ada/diagnostics-constructors.ads143
-rw-r--r--gcc/ada/diagnostics-converter.adb254
-rw-r--r--gcc/ada/diagnostics-converter.ads31
-rw-r--r--gcc/ada/diagnostics-switch_repository.ads39
-rw-r--r--gcc/ada/diagnostics-utils.adb357
-rw-r--r--gcc/ada/diagnostics-utils.ads91
-rw-r--r--gcc/ada/diagnostics.adb539
-rw-r--r--gcc/ada/diagnostics.ads477
-rw-r--r--gcc/ada/doc/gnat_rm.rst2
-rw-r--r--gcc/ada/doc/gnat_rm/about_this_guide.rst6
-rw-r--r--gcc/ada/doc/gnat_rm/compatibility_and_porting_guide.rst6
-rw-r--r--gcc/ada/doc/gnat_rm/gnat_language_extensions.rst377
-rw-r--r--gcc/ada/doc/gnat_rm/implementation_advice.rst6
-rw-r--r--gcc/ada/doc/gnat_rm/implementation_defined_aspects.rst6
-rw-r--r--gcc/ada/doc/gnat_rm/implementation_defined_attributes.rst6
-rw-r--r--gcc/ada/doc/gnat_rm/implementation_defined_characteristics.rst20
-rw-r--r--gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst42
-rw-r--r--gcc/ada/doc/gnat_rm/implementation_of_ada_2012_features.rst1330
-rw-r--r--gcc/ada/doc/gnat_rm/implementation_of_ada_2022_features.rst2249
-rw-r--r--gcc/ada/doc/gnat_rm/representation_clauses_and_pragmas.rst2
-rw-r--r--gcc/ada/doc/gnat_rm/specialized_needs_annexes.rst10
-rw-r--r--gcc/ada/doc/gnat_rm/the_gnat_library.rst2
-rw-r--r--gcc/ada/doc/gnat_ugn/building_executable_programs_with_gnat.rst32
-rw-r--r--gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst382
-rw-r--r--gcc/ada/doc/gnat_ugn/platform_specific_information.rst7
-rw-r--r--gcc/ada/doc/gnat_ugn/the_gnat_compilation_model.rst4
-rw-r--r--gcc/ada/einfo-utils.adb69
-rw-r--r--gcc/ada/einfo-utils.ads1
-rw-r--r--gcc/ada/einfo.ads107
-rw-r--r--gcc/ada/errid.adb (renamed from gcc/ada/diagnostics-repository.adb)23
-rw-r--r--gcc/ada/errid.ads (renamed from gcc/ada/diagnostics-repository.ads)77
-rw-r--r--gcc/ada/errout.adb999
-rw-r--r--gcc/ada/errout.ads111
-rw-r--r--gcc/ada/erroutc-pretty_emitter.adb (renamed from gcc/ada/diagnostics-pretty_emitter.adb)812
-rw-r--r--gcc/ada/erroutc-pretty_emitter.ads (renamed from gcc/ada/diagnostics-pretty_emitter.ads)6
-rw-r--r--gcc/ada/erroutc-sarif_emitter.adb (renamed from gcc/ada/diagnostics-sarif_emitter.adb)641
-rw-r--r--gcc/ada/erroutc-sarif_emitter.ads (renamed from gcc/ada/diagnostics-sarif_emitter.ads)6
-rw-r--r--gcc/ada/erroutc.adb461
-rw-r--r--gcc/ada/erroutc.ads221
-rw-r--r--gcc/ada/errsw.adb (renamed from gcc/ada/diagnostics-switch_repository.adb)35
-rw-r--r--gcc/ada/errsw.ads154
-rw-r--r--gcc/ada/errutil.adb12
-rw-r--r--gcc/ada/exp_aggr.adb835
-rw-r--r--gcc/ada/exp_aggr.ads4
-rw-r--r--gcc/ada/exp_attr.adb397
-rw-r--r--gcc/ada/exp_ch11.adb4
-rw-r--r--gcc/ada/exp_ch3.adb160
-rw-r--r--gcc/ada/exp_ch4.adb191
-rw-r--r--gcc/ada/exp_ch4.ads6
-rw-r--r--gcc/ada/exp_ch5.adb148
-rw-r--r--gcc/ada/exp_ch5.ads1
-rw-r--r--gcc/ada/exp_ch6.adb187
-rw-r--r--gcc/ada/exp_ch7.adb181
-rw-r--r--gcc/ada/exp_ch9.adb17
-rw-r--r--gcc/ada/exp_disp.adb4
-rw-r--r--gcc/ada/exp_dist.adb2
-rw-r--r--gcc/ada/exp_fixd.adb14
-rw-r--r--gcc/ada/exp_pakd.adb34
-rw-r--r--gcc/ada/exp_prag.adb10
-rw-r--r--gcc/ada/exp_prag.ads4
-rw-r--r--gcc/ada/exp_put_image.adb55
-rw-r--r--gcc/ada/exp_spark.adb8
-rw-r--r--gcc/ada/exp_util.adb771
-rw-r--r--gcc/ada/exp_util.ads38
-rw-r--r--gcc/ada/expander.adb3
-rw-r--r--gcc/ada/fe.h4
-rw-r--r--gcc/ada/fname-uf.adb11
-rw-r--r--gcc/ada/freeze.adb37
-rw-r--r--gcc/ada/frontend.adb7
-rw-r--r--gcc/ada/gcc-interface/Make-lang.in56
-rw-r--r--gcc/ada/gcc-interface/Makefile.in21
-rw-r--r--gcc/ada/gcc-interface/decl.cc20
-rw-r--r--gcc/ada/gcc-interface/misc.cc2
-rw-r--r--gcc/ada/gen_il-fields.ads16
-rw-r--r--gcc/ada/gen_il-gen-gen_entities.adb32
-rw-r--r--gcc/ada/gen_il-gen-gen_nodes.adb22
-rw-r--r--gcc/ada/gen_il-types.ads2
-rw-r--r--gcc/ada/generate_minimal_reproducer.adb84
-rw-r--r--gcc/ada/get_targ.ads2
-rw-r--r--gcc/ada/ghost.adb96
-rw-r--r--gcc/ada/gnat-style.texi4
-rw-r--r--gcc/ada/gnat1drv.adb36
-rw-r--r--gcc/ada/gnat_rm.texi5205
-rw-r--r--gcc/ada/gnat_ugn.texi893
-rw-r--r--gcc/ada/gnatcmd.adb2
-rw-r--r--gcc/ada/gnatls.adb43
-rw-r--r--gcc/ada/init.c1
-rw-r--r--gcc/ada/inline.adb74
-rw-r--r--gcc/ada/json_utils.adb (renamed from gcc/ada/diagnostics-json_utils.adb)143
-rw-r--r--gcc/ada/json_utils.ads (renamed from gcc/ada/diagnostics-json_utils.ads)10
-rw-r--r--gcc/ada/lib-load.adb6
-rw-r--r--gcc/ada/lib-writ.adb4
-rw-r--r--gcc/ada/lib.adb9
-rw-r--r--gcc/ada/lib.ads54
-rw-r--r--gcc/ada/libgnarl/s-linux__android-aarch64.ads20
-rw-r--r--gcc/ada/libgnarl/s-linux__android-arm.ads18
-rw-r--r--gcc/ada/libgnarl/s-osinte__android.ads104
-rw-r--r--gcc/ada/libgnarl/s-stusta.adb5
-rw-r--r--gcc/ada/libgnat/a-except.adb18
-rw-r--r--gcc/ada/libgnat/a-nbnbig.adb81
-rw-r--r--gcc/ada/libgnat/a-nbnbig.ads241
-rw-r--r--gcc/ada/libgnat/a-ngelfu.adb13
-rw-r--r--gcc/ada/libgnat/a-nudira.ads42
-rw-r--r--gcc/ada/libgnat/a-nuflra.ads34
-rw-r--r--gcc/ada/libgnat/a-strfix.adb239
-rw-r--r--gcc/ada/libgnat/a-strmap.adb313
-rw-r--r--gcc/ada/libgnat/a-strsea.adb144
-rw-r--r--gcc/ada/libgnat/a-strsup.adb276
-rw-r--r--gcc/ada/libgnat/a-strsup.ads9
-rw-r--r--gcc/ada/libgnat/g-dyntab.ads5
-rw-r--r--gcc/ada/libgnat/i-c.adb426
-rw-r--r--gcc/ada/libgnat/i-c.ads4
-rw-r--r--gcc/ada/libgnat/i-cheri.adb24
-rw-r--r--gcc/ada/libgnat/i-cheri.ads6
-rw-r--r--gcc/ada/libgnat/i-cpoint.adb2
-rw-r--r--gcc/ada/libgnat/i-cstrin.adb102
-rw-r--r--gcc/ada/libgnat/s-aridou.adb3196
-rw-r--r--gcc/ada/libgnat/s-aridou.ads107
-rw-r--r--gcc/ada/libgnat/s-arit128.adb1
-rw-r--r--gcc/ada/libgnat/s-arit128.ads96
-rw-r--r--gcc/ada/libgnat/s-arit32.adb398
-rw-r--r--gcc/ada/libgnat/s-arit32.ads62
-rw-r--r--gcc/ada/libgnat/s-arit64.adb5
-rw-r--r--gcc/ada/libgnat/s-arit64.ads96
-rw-r--r--gcc/ada/libgnat/s-casuti.adb80
-rw-r--r--gcc/ada/libgnat/s-casuti.ads49
-rw-r--r--gcc/ada/libgnat/s-cautns.adb (renamed from gcc/ada/libgnat/s-valspe.adb)106
-rw-r--r--gcc/ada/libgnat/s-cautns.ads106
-rw-r--r--gcc/ada/libgnat/s-dorepr.adb4
-rw-r--r--gcc/ada/libgnat/s-dorepr__fma.adb2
-rw-r--r--gcc/ada/libgnat/s-dourea.adb18
-rw-r--r--gcc/ada/libgnat/s-exnint.ads11
-rw-r--r--gcc/ada/libgnat/s-exnlli.ads11
-rw-r--r--gcc/ada/libgnat/s-exnllli.ads12
-rw-r--r--gcc/ada/libgnat/s-expint.ads12
-rw-r--r--gcc/ada/libgnat/s-explli.ads12
-rw-r--r--gcc/ada/libgnat/s-expllli.ads12
-rw-r--r--gcc/ada/libgnat/s-explllu.ads12
-rw-r--r--gcc/ada/libgnat/s-expllu.ads12
-rw-r--r--gcc/ada/libgnat/s-expmod.adb276
-rw-r--r--gcc/ada/libgnat/s-expmod.ads35
-rw-r--r--gcc/ada/libgnat/s-exponn.adb185
-rw-r--r--gcc/ada/libgnat/s-exponn.ads33
-rw-r--r--gcc/ada/libgnat/s-expont.adb185
-rw-r--r--gcc/ada/libgnat/s-expont.ads33
-rw-r--r--gcc/ada/libgnat/s-exponu.adb24
-rw-r--r--gcc/ada/libgnat/s-exponu.ads17
-rw-r--r--gcc/ada/libgnat/s-expuns.ads12
-rw-r--r--gcc/ada/libgnat/s-imaged.adb26
-rw-r--r--gcc/ada/libgnat/s-imaged.ads3
-rw-r--r--gcc/ada/libgnat/s-imagef.adb26
-rw-r--r--gcc/ada/libgnat/s-imagef.ads2
-rw-r--r--gcc/ada/libgnat/s-imagei.adb345
-rw-r--r--gcc/ada/libgnat/s-imagei.ads62
-rw-r--r--gcc/ada/libgnat/s-imageu.adb274
-rw-r--r--gcc/ada/libgnat/s-imageu.ads45
-rw-r--r--gcc/ada/libgnat/s-imde128.ads3
-rw-r--r--gcc/ada/libgnat/s-imde32.ads3
-rw-r--r--gcc/ada/libgnat/s-imde64.ads3
-rw-r--r--gcc/ada/libgnat/s-imfi128.ads3
-rw-r--r--gcc/ada/libgnat/s-imfi32.ads3
-rw-r--r--gcc/ada/libgnat/s-imfi64.ads3
-rw-r--r--gcc/ada/libgnat/s-imgboo.adb25
-rw-r--r--gcc/ada/libgnat/s-imgboo.ads21
-rw-r--r--gcc/ada/libgnat/s-imgint.ads23
-rw-r--r--gcc/ada/libgnat/s-imglli.ads23
-rw-r--r--gcc/ada/libgnat/s-imgllli.ads23
-rw-r--r--gcc/ada/libgnat/s-imglllu.ads17
-rw-r--r--gcc/ada/libgnat/s-imgllu.ads17
-rw-r--r--gcc/ada/libgnat/s-imguns.ads17
-rw-r--r--gcc/ada/libgnat/s-secsta.adb9
-rw-r--r--gcc/ada/libgnat/s-secsta__cheri.adb9
-rw-r--r--gcc/ada/libgnat/s-spark.ads39
-rw-r--r--gcc/ada/libgnat/s-spcuop.adb42
-rw-r--r--gcc/ada/libgnat/s-spcuop.ads57
-rw-r--r--gcc/ada/libgnat/s-trasym__dwarf.adb18
-rw-r--r--gcc/ada/libgnat/s-vafi128.ads6
-rw-r--r--gcc/ada/libgnat/s-vafi32.ads6
-rw-r--r--gcc/ada/libgnat/s-vafi64.ads6
-rw-r--r--gcc/ada/libgnat/s-vaispe.adb87
-rw-r--r--gcc/ada/libgnat/s-vaispe.ads185
-rw-r--r--gcc/ada/libgnat/s-valboo.adb11
-rw-r--r--gcc/ada/libgnat/s-valboo.ads22
-rw-r--r--gcc/ada/libgnat/s-valint.ads18
-rw-r--r--gcc/ada/libgnat/s-vallli.ads18
-rw-r--r--gcc/ada/libgnat/s-valllli.ads18
-rw-r--r--gcc/ada/libgnat/s-vallllu.ads15
-rw-r--r--gcc/ada/libgnat/s-valllu.ads15
-rw-r--r--gcc/ada/libgnat/s-valrea.adb17
-rw-r--r--gcc/ada/libgnat/s-valspe.ads246
-rw-r--r--gcc/ada/libgnat/s-valued.adb101
-rw-r--r--gcc/ada/libgnat/s-valuef.adb131
-rw-r--r--gcc/ada/libgnat/s-valuei.adb70
-rw-r--r--gcc/ada/libgnat/s-valuei.ads64
-rw-r--r--gcc/ada/libgnat/s-valuen.ads4
-rw-r--r--gcc/ada/libgnat/s-valuer.adb249
-rw-r--r--gcc/ada/libgnat/s-valuer.ads34
-rw-r--r--gcc/ada/libgnat/s-valueu.adb333
-rw-r--r--gcc/ada/libgnat/s-valueu.ads74
-rw-r--r--gcc/ada/libgnat/s-valuns.ads15
-rw-r--r--gcc/ada/libgnat/s-valuti.adb87
-rw-r--r--gcc/ada/libgnat/s-valuti.ads131
-rw-r--r--gcc/ada/libgnat/s-vauspe.adb203
-rw-r--r--gcc/ada/libgnat/s-vauspe.ads629
-rw-r--r--gcc/ada/libgnat/s-veboop.adb102
-rw-r--r--gcc/ada/libgnat/s-veboop.ads111
-rw-r--r--gcc/ada/libgnat/s-vs_int.ads59
-rw-r--r--gcc/ada/libgnat/s-vs_lli.ads60
-rw-r--r--gcc/ada/libgnat/s-vs_llu.ads58
-rw-r--r--gcc/ada/libgnat/s-vs_uns.ads57
-rw-r--r--gcc/ada/libgnat/s-vsllli.ads60
-rw-r--r--gcc/ada/libgnat/s-vslllu.ads58
-rw-r--r--gcc/ada/libgnat/s-widint.ads13
-rw-r--r--gcc/ada/libgnat/s-widlli.ads13
-rw-r--r--gcc/ada/libgnat/s-widllli.ads13
-rw-r--r--gcc/ada/libgnat/s-widlllu.ads11
-rw-r--r--gcc/ada/libgnat/s-widllu.ads11
-rw-r--r--gcc/ada/libgnat/s-widthi.adb131
-rw-r--r--gcc/ada/libgnat/s-widthu.adb120
-rw-r--r--gcc/ada/libgnat/s-widthu.ads53
-rw-r--r--gcc/ada/libgnat/s-widuns.ads11
-rw-r--r--gcc/ada/namet.adb18
-rw-r--r--gcc/ada/namet.ads12
-rw-r--r--gcc/ada/nlists.adb11
-rw-r--r--gcc/ada/opt.ads33
-rw-r--r--gcc/ada/osint.adb132
-rw-r--r--gcc/ada/osint.ads15
-rw-r--r--gcc/ada/par-ch13.adb7
-rw-r--r--gcc/ada/par-ch2.adb15
-rw-r--r--gcc/ada/par-ch4.adb195
-rw-r--r--gcc/ada/par-ch5.adb141
-rw-r--r--gcc/ada/par-ch6.adb3
-rw-r--r--gcc/ada/par-endh.adb57
-rw-r--r--gcc/ada/par-prag.adb1
-rw-r--r--gcc/ada/par-util.adb15
-rw-r--r--gcc/ada/par.adb6
-rw-r--r--gcc/ada/prepcomp.adb4
-rw-r--r--gcc/ada/repinfo.adb315
-rw-r--r--gcc/ada/rtsfind.adb4
-rw-r--r--gcc/ada/rtsfind.ads3
-rw-r--r--gcc/ada/scos.ads3
-rw-r--r--gcc/ada/scos.h89
-rw-r--r--gcc/ada/sem.adb8
-rw-r--r--gcc/ada/sem.ads12
-rw-r--r--gcc/ada/sem_aggr.adb86
-rw-r--r--gcc/ada/sem_attr.adb165
-rw-r--r--gcc/ada/sem_attr.ads6
-rw-r--r--gcc/ada/sem_case.adb8
-rw-r--r--gcc/ada/sem_ch10.adb20
-rw-r--r--gcc/ada/sem_ch10.ads9
-rw-r--r--gcc/ada/sem_ch12.adb529
-rw-r--r--gcc/ada/sem_ch13.adb308
-rw-r--r--gcc/ada/sem_ch3.adb850
-rw-r--r--gcc/ada/sem_ch3.ads27
-rw-r--r--gcc/ada/sem_ch4.adb1033
-rw-r--r--gcc/ada/sem_ch5.adb331
-rw-r--r--gcc/ada/sem_ch5.ads1
-rw-r--r--gcc/ada/sem_ch6.adb486
-rw-r--r--gcc/ada/sem_ch6.ads14
-rw-r--r--gcc/ada/sem_ch8.adb68
-rw-r--r--gcc/ada/sem_ch8.ads5
-rw-r--r--gcc/ada/sem_ch9.adb67
-rw-r--r--gcc/ada/sem_disp.adb20
-rw-r--r--gcc/ada/sem_eval.adb116
-rw-r--r--gcc/ada/sem_eval.ads93
-rw-r--r--gcc/ada/sem_prag.adb530
-rw-r--r--gcc/ada/sem_prag.ads11
-rw-r--r--gcc/ada/sem_res.adb32
-rw-r--r--gcc/ada/sem_util.adb398
-rw-r--r--gcc/ada/sem_util.ads93
-rw-r--r--gcc/ada/sem_warn.adb42
-rw-r--r--gcc/ada/sem_warn.ads9
-rw-r--r--gcc/ada/set_targ.ads2
-rw-r--r--gcc/ada/sinfo-utils.adb13
-rw-r--r--gcc/ada/sinfo-utils.ads4
-rw-r--r--gcc/ada/sinfo.ads48
-rw-r--r--gcc/ada/sinput.ads50
-rw-r--r--gcc/ada/snames.ads-tmpl6
-rw-r--r--gcc/ada/socket.c12
-rw-r--r--gcc/ada/sprint.adb8
-rw-r--r--gcc/ada/switch-c.adb22
-rw-r--r--gcc/ada/switch.adb2
-rw-r--r--gcc/ada/sysdep.c7
-rw-r--r--gcc/ada/treepr.adb64
-rw-r--r--gcc/ada/treepr.ads14
-rw-r--r--gcc/ada/types.ads4
-rw-r--r--gcc/ada/types.h5
-rw-r--r--gcc/ada/urealp.adb27
-rw-r--r--gcc/ada/urealp.ads4
-rw-r--r--gcc/ada/usage.adb12
-rw-r--r--gcc/ada/vast.adb592
-rw-r--r--gcc/ada/vast.ads7
315 files changed, 19464 insertions, 23231 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 128ea05..88b27a8 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,1813 @@
+2025-06-30 Eric Botcazou <ebotcazou@adacore.com>
+
+ PR ada/120106
+ * Make-generated.in (GNATMAKE_FOR_BUILD): Define.
+
+2025-06-30 Viljar Indus <indus@adacore.com>
+
+ * comperr.adb (Compiler_Abort): Pass the exit code in calls to
+ Output_Messages.
+ * errout.adb (Output_Messages): Add new parameter for the
+ Exit_Code and store its value.
+ * errout.ads (Output_Messages): Likewise.
+ * erroutc-sarif_emitter.adb (Print_Invocations): Set
+ Execution_Successful based on the exit code.
+ * erroutc.ads (Exit_Code): Store the exit code value.
+ * gnat1drv.adb (Gnat1drv): Pass the exit code in calls to
+ Output_Messages.
+ * prepcomp.adb (Parse_Preprocessing_Data_File, Prpare_To_Preprocess):
+ Likewise.
+
+2025-06-30 Ronan Desplanques <desplanques@adacore.com>
+
+ * gen_il-gen-gen_entities.adb (Gen_Entities): Tweak Has_Exit.
+
+2025-06-30 Bob Duff <duff@adacore.com>
+
+ * exp_attr.adb (Attribute_Max_Size_In_Storage_Elements):
+ Return Storage_Count'Last converted to universal_integer.
+
+2025-06-30 Tonu Naks <naks@adacore.com>
+
+ * doc/gnat_rm.rst: add entry point for the new chapter
+ * doc/gnat_rm/about_this_guide.rst: add reference to the new
+ chapter
+ * doc/gnat_rm/implementation_of_ada_2022_features.rst: new file
+ * doc/gnat_rm/implementation_of_ada_2012_features.rst: update
+ explanation about RM references
+ * gnat_rm.texi: Regenerate.
+ * gnat_ugn.texi: Regenerate.
+
+2025-06-30 Ronan Desplanques <desplanques@adacore.com>
+
+ * par-util.adb (Check_Future_Keyword): Use Snames subtypes. Extend
+ comment.
+
+2025-06-30 Ronan Desplanques <desplanques@adacore.com>
+
+ * sem_ch5.adb (Analyze_Loop_Statement): Remove obsolete comment.
+
+2025-06-30 Bob Duff <duff@adacore.com>
+
+ * sem_warn.adb (Warn_On_Useless_Assignments):
+ Enable Warn_On_Useless_Assignment in the case of
+ Warn_On_All_Unread_Out_Parameters.
+
+2025-06-30 Ronan Desplanques <desplanques@adacore.com>
+
+ * sem_ch3.adb (Analyze_Subtype_Declaration): Remove uses of E_Void.
+ (Copy_Parent_Attributes): New procedure.
+
+2025-06-30 Ronan Desplanques <desplanques@adacore.com>
+
+ * cstand.adb (Make_Aliased_Component, Make_Formal, New_Operator,
+ Create_Standard): Remove useless calls.
+
+2025-06-30 Eric Botcazou <ebotcazou@adacore.com>
+
+ * libgnat/s-valuer.adb (Scan_Decimal_Digits): Also pretend that the
+ precision limit was just reached if it was already reached.
+ (Scan_Integral_Digits): Add Extra_Rounded out parameter, set it to
+ False on entry and to True when Extra is rounded.
+ (Scan_Raw_Real): New Extra_Rounded local variable. Pass it in the
+ calls to Scan_Integral_Digits. If it is True, pass a dummy extra
+ digit to Scan_Decimal_Digits.
+
+2025-06-30 Claire Dross <dross@adacore.com>
+
+ * libgnat/a-strsup.ads: Ignore Ghost_Predicate in the assertion policy.
+
+2025-06-30 Javier Miranda <miranda@adacore.com>
+
+ * sem_aggr.adb (Resolve_Record_Aggregate): Adjust the code to
+ handle mutably tagged class-wide types since they don't have
+ discriminants, but all class-wide types are considered to have
+ unknown discriminants. Initialize mutably tagged class-wide
+ type components calling their IP subprogram.
+ * exp_aggr.adb (Gen_Assign): Handle mutably tagged class-wide type
+ components that have an initializing qualified expression, and
+ mutably tagged class-wide components default initialization.
+ (Gen_Loop): Handle mutably tagged class-wide types.
+ (Gen_Assign): ditto.
+ (Build_Record_Aggr_Code): Default initialization of mutably tagged
+ class-wide types is performed by their IP subprogram.
+ * exp_ch3.adb (Init_Component): Generate code to raise Program_Error
+ in the IP subprogram of arrays when the type of their components is
+ a mutably tagged abstract class-wide type.
+ (Build_Init_Procedure): ditto for the init procedure of record types.
+ (Build_Init_Statements): Ensure that the type of the expression
+ initializing a mutably class-wide tagged type component is frozen.
+ (Requires_Init_Proc): Mutably tagged class-wide types require the
+ init-proc since it takes care of their default initialization.
+ * sem_util.adb (Needs_Simple_Initialization): Mutably tagged class-wide
+ types don't require simple initialization.
+ * types.ads (PE_Abstract_Type_Component): New reason for Program_Error.
+ * types.h (PE_Abstract_Type_Component): ditto.
+ * exp_ch11.adb (Get_RT_Exception_Name): Handle new reason for
+ Program_Error.
+ * libgnat/a-except.adb (Rcheck_PE_Abstract_Type_Component): New
+ subprogram.
+
+2025-06-30 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_util.ads (Get_Enclosing_Object, Get_Enum_Lit_From_Pos,
+ Is_Universal_Numeric_Type): Reorder declarations.
+
+2025-06-30 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_util.adb (Get_Enclosing_Object): Traverse unchecked type
+ conversions since they from the compiler and should be transparent for
+ semantic reasoning.
+
+2025-06-30 Steve Baird <baird@adacore.com>
+
+ * einfo-utils.adb (Predicate_Function): Look through an Itype if
+ that takes us to another subtype of the same type.
+
+2025-06-30 Gary Dismukes <dismukes@adacore.com>
+
+ * exp_util.adb (Must_Map_Call_To_Parent_Primitive): Change function
+ name (was Call_To_Parent_Dispatching_Op_Must_Be_Mapped). Move logic
+ for attributes and dereferences, plus testing for controlled formals,
+ into new function Expr_Has_Ctrl_Formal_Ref. Add handling for
+ access attributes, multiple levels of attributes/dereferences,
+ conditional_expressions, and declare_expressions. Properly account
+ for function calls with multiple operands and enclosing calls.
+ (Expr_Has_Ctrl_Formal_Ref): New function to determine whether
+ an expression is a reference to a controlling formal or has
+ a prefix that is such a reference.
+ (Is_Controlling_Formal_Ref): New function in Expr_Has_Ctrl_Formal_Ref
+ to determine if a node is a direct reference to a controlling formal.
+ * freeze.adb (Build_DTW_Body): Create an unchecked conversion instead
+ of a regular type conversion for converting actuals in calls to parent
+ inherited primitives that are wrapped for inherited pre/postconditions.
+ Avoids generating unnecessary checks (such as accessibility checks on
+ conversions for anonymous access formals).
+
+2025-06-30 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_util.ads (Get_Enclosing_Ghost_Entity): Rename spec.
+ * sem_util.adb (Get_Enclosing_Ghost_Object): Rename body; reorder
+ alphabetically; adapt recursive call.
+ * ghost.adb: Adapt calls to Get_Enclosing_Ghost_Object.
+
+2025-06-30 Piotr Trojanek <trojanek@adacore.com>
+
+ * ghost.adb (Ghost_Entity): Remove; use Get_Enclosing_Ghost_Object
+ instead; adapt callers.
+
+2025-06-30 Eric Botcazou <ebotcazou@adacore.com>
+
+ * sem_prag.adb (Analyze_Pragma) <Pragma_No_Component_Reordering>:
+ Call Find_Type on the first argument of the pragma.
+
+2025-06-30 Tonu Naks <naks@adacore.com>
+
+ * gnatls.adb: remove -l switch
+
+2025-06-30 Steve Baird <baird@adacore.com>
+
+ * doc/gnat_rm/gnat_language_extensions.rst: Update documentation for
+ mutably tagged types and the Size'Class aspect.
+ * gnat_rm.texi: Regenerate.
+
+2025-06-30 Piotr Trojanek <trojanek@adacore.com>
+
+ * ghost.adb
+ (Whole_Object_Ref): Remove; use Get_Enclosing_Ghost_Object instead.
+ (Is_Ghost_Assignment): Handle more than object identifiers.
+ (Mark_And_Set_Ghost_Assignment): Likewise.
+ * sem_util.adb (Get_Enclosing_Ghost_Object): Detect more expressions
+ as ghost references; rename to better match the intended meaning.
+ * sem_util.ads (Get_Enclosing_Ghost_Object): Rename; adjust comment.
+
+2025-06-30 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_aggr.adb (Backend_Processing_Possible.Component_Check): Return
+ False for delayed conditional expressions.
+
+2025-06-30 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_aggr.ads (Parent_Is_Regular_Aggregate): New predicate.
+ * exp_aggr.adb (In_Place_Assign_OK.Safe_Component): Implement more
+ accurate criterion for function calls.
+ (Convert_To_Assignments): Use Parent_Is_Regular_Aggregate predicate.
+ (Expand_Array_Aggregate): Likewise. Remove obsolete comment.
+ (Initialize_Component): Do not adjust when the expression is a naked
+ function call and Back_End_Return_Slot is True.
+ (Parent_Is_Regular_Aggregate): New predicate.
+ * exp_ch3.adb (Build_Record_Init_Proc.Build_Assignment): Add test of
+ Back_End_Return_Slot in conjunction with a function call.
+ * exp_ch4.adb (Expand_Allocator_Expression): Likewise. Use the
+ Is_Container_Aggregate predicate to detect container aggregates.
+ (Expand_N_Case_Expression): Delay the expansion if the parent is a
+ regular aggregate and the type should not be copied.
+ (Expand_N_If_Expression): Likewise.
+ (New_Assign_Copy): New function.
+ * exp_ch6.adb (Expand_Ctrl_Function_Call): Bail out when the parent
+ is a regular aggregate.
+ * sem_util.adb (Check_Function_Writable_Actuals): Do not take into
+ account attribute references created by the compiler.
+
+2025-06-30 Alexandre Oliva <oliva@adacore.com>
+
+ * socket.c [__vxworks]
+ (__gnat_gethostbyname): Drop excess '&'.
+ (__gnat_gethostbyaddr): Likewise.
+
+2025-06-30 Alexandre Oliva <oliva@adacore.com>
+
+ * adaint.c [__vxworks]: Include ctype.h.
+
+2025-06-30 Steve Baird <baird@adacore.com>
+
+ * exp_put_image.adb (Build_Record_Put_Image_Procedure): If
+ Discriminant_Specifications takes us from the full view of a type
+ to an (intentionally) unanalyzed subtree, then instead find
+ discriminant entities by calling Discriminant_Specifications on
+ the partial view of the type.
+
+2025-06-30 Ronan Desplanques <desplanques@adacore.com>
+
+ * sem_ch6.adb (Check_Delayed_Subprogram, Possible_Freeze): Restrict
+ cases where freezing is delayed.
+ * sem_ch6.ads (Check_Delayed_Subprogram): Improve documentation
+ comment.
+ * sprint.adb (Write_Itype): Improve output.
+
+2025-06-30 Eric Botcazou <ebotcazou@adacore.com>
+
+ * libgnat/s-valrea.adb (Integer_to_Real): Rename to...
+ (Integer_To_Real): ...this. Remove the second condition of the
+ conjunction in the test for the zero value.
+ (Scan_Real): Adjust to above renaming.
+ (Value_Real): Likewise.
+ * libgnat/s-valuer.ads (Scan_Raw_Real): Add note about Val.
+
+2025-06-30 Jose Ruiz <ruiz@adacore.com>
+
+ * doc/gnat_ugn/gnat_and_program_execution.rst: Fix a
+ couple of minor formatting issues.
+ * gnat_ugn.texi: Regenerate.
+
+2025-06-30 Ronan Desplanques <desplanques@adacore.com>
+
+ * treepr.ads (Print_Entity_Chain, pec, rpec): New subprograms.
+ * treepr.adb (Print_Entity_Chain, pec, rpec): Likewise.
+
+2025-06-30 Ronan Desplanques <desplanques@adacore.com>
+
+ * atree.ads (Parent_Or_List_Containing): Fix typo.
+
+2025-06-30 Ronan Desplanques <desplanques@adacore.com>
+
+ * treepr.adb (Print_Node): Tweak Parent field printing.
+
+2025-06-30 Jose Ruiz <ruiz@adacore.com>
+
+ * doc/gnat_ugn/gnat_and_program_execution.rst: Add the
+ documentation about using sanitizers with Ada code.
+ * gnat_ugn.texi: Regenerate.
+
+2025-06-30 Jose Ruiz <ruiz@adacore.com>
+
+ * doc/gnat_ugn/gnat_and_program_execution.rst: Add the
+ documentation about using sanitizers with Ada code.
+ * gnat_ugn.texi: Regenerate.
+
+2025-06-30 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_util.adb (Get_Enclosing_Object): Remove dead code.
+
+2025-06-30 Steve Baird <baird@adacore.com>
+
+ * einfo-utils.adb (Predicate_Function): Improve handling of a case
+ where a predicate specified for a subtype of a partial view of a
+ type was incorrectly ignored.
+ (Set_Predicate_Function): If the attribute has already been set to
+ the same value, then do nothing (instead of raising P_E).
+ * sem_ch13.adb (Build_Predicate_Function): Add new function
+ Has_Source_Predicate. If a subtype inherits a predicate but also
+ has its own explicitly specified predicate, then avoid
+ misinterpreting the presence of the function built for the
+ inherited predicate to mean that no additional predicate function
+ is needed.
+ * sem_util.adb (Build_Subtype): In the case where we are given a
+ constrained record or array subtype and we need to construct a
+ different subtype, subject to a different constraint, the
+ subtype_mark of the constructed subtype needs to reference an
+ unconstrained subtype (because a new constraint is going to be
+ imposed). If the Predicated_Parent attribute of the given subtype
+ is present and refers to a suitable unconstrained subtype, then
+ use that subtype instead of setting the Predicated_Parent
+ attribute on a new node (and performing the associated attribute
+ copying).
+
+2025-06-30 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_ch7.adb (Process_Transient_In_Scope): Bail out if the object
+ is an ignored ghost entity.
+
+2025-06-30 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_util.adb (Insert_Actions): Extend special treatment applied
+ to freeze nodes to the case of blocks generated for aggregates.
+
+2025-06-30 Johannes Kliemann <kliemann@adacore.com>
+
+ * libgnat/s-valuer.adb: Switch missing if-statements to
+ short-circuit form.
+ * libgnat/i-cpoint.adb: Ditto.
+
+2025-06-28 Eric Botcazou <ebotcazou@adacore.com>
+
+ PR ada/120854
+ * sem_eval.adb (Get_String_Val): Be prepared for an integer literal
+ after a serious error is detected, and raise PE on other nodes.
+
+2025-06-26 David Malcolm <dmalcolm@redhat.com>
+
+ * gcc-interface/misc.cc (gnat_init): Use
+ diagnostic_context::set_internal_error_callback.
+
+2025-06-22 Nicolas Boulenguez <nicolas@debian.org>
+
+ PR ada/120106
+ * gcc-interface/Make-lang.in: Set GNAT{MAKE,BIND,LINK_LS}_FOR_HOST
+ from GNAT{MAKE,BIND} instead of using hardcoded commands.
+
+2025-06-22 Eric Botcazou <ebotcazou@adacore.com>
+
+ * Make-generated.in: Remove obsolete stuff.
+
+2025-06-22 Nicolas Boulenguez <nicolas@debian.org>
+
+ PR ada/120106
+ PR ada/120106
+ * Make-generated.in: Use GNATMAKE_FOR_BUILD instead of gnatmake.
+ * gcc-interface/Makefile.in: Likewise.
+
+2025-06-17 Eric Botcazou <ebotcazou@adacore.com>
+
+ PR ada/120665
+ * sem_aggr.adb (Resolve_Container_Aggregate): Use robust guards.
+
+2025-06-12 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/decl.cc (gnat_to_gnu_entity) <E_Variable>: Generate
+ a zero-initialization for the anonymous object of a small aggregate
+ allocated on the stack.
+ (inline_status_for_subprog): Minor tweak.
+
+2025-06-12 Tonu Naks <naks@adacore.com>
+
+ * comperr.adb: update support instructions
+ * switch.adb: update support instructions
+
+2025-06-12 Ronan Desplanques <desplanques@adacore.com>
+
+ * sinfo.ads: Fix RM reference.
+
+2025-06-12 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_ch3.adb (Apply_External_Initialization): Reuse local constant.
+
+2025-06-12 Eric Botcazou <ebotcazou@adacore.com>
+
+ * doc/gnat_rm/gnat_language_extensions.rst
+ (Generalized Finalization): Document the actual implementation.
+ (No_Raise): Move to separate section.
+ * gnat_rm.texi: Regenerate.
+
+2025-06-12 Ronan Desplanques <desplanques@adacore.com>
+
+ * libgnat/s-valuer.adb (Scan_Raw_Real): Apply tweak.
+
+2025-06-12 Tonu Naks <naks@adacore.com>
+
+ * comperr.adb: replace report@ with support@
+ * gnatcmd.adb: replace report@ with support@
+
+2025-06-12 Ronan Desplanques <desplanques@adacore.com>
+
+ * sem_ch3.adb (Build_Derived_Private_Type): Fix test.
+ (Build_Derived_Record_Type): Adjust error recovery paths.
+
+2025-06-12 Eric Botcazou <ebotcazou@adacore.com>
+
+ * einfo.ads (Has_Homonym): Fix inaccuracy in description.
+ * sem_ch8.ads (Find_Direct_Name): Remove obsolete description.
+ * sem_ch12.adb (Analyze_Associations): Rename I_Node parameter
+ into N and adjust description.
+ (Analyze_Subprogram_Instantiation): Add missing description.
+ (Contains_Instance_Of): Fix description.
+ (Associations): Rename Generic_Actual_Rec into Actual_Rec and
+ Gen_Assocs_Rec into Match_Rec.
+ (Analyze_One_Association): Rename I_Node parameter into N.
+ (Check_Fixed_Point_Warning): Rename Gen_Assocs parameter into
+ Match.
+ (Body of Associations): Minor cleanups and tweaks.
+ (Analyze_Associations): Rename I_Node parameter into N and
+ adjust implementation.
+ (Analyze_One_Association): Likewise.
+ (Analyze_Package_Instantiation): Remove obsolete code and clean up.
+ (Check_Fixed_Point_Warning): Rename Gen_Assocs parameter into
+ Match and adjust implementation.
+ (Freeze_Package_Instance): Simplify condition.
+ (Get_Unit_Instantiation_Node): Add support for instantiations of
+ subprograms and stop the loop properly in case of errors.
+ * sem_util.ads (Add_Global_Declaration): Rename N parameter into
+ Decl and fix description.
+ * sem_util.adb (Add_Global_Declaration): Rename N parameter into
+ Decl and adjust implementation.
+
+2025-06-12 Ronan Desplanques <desplanques@adacore.com>
+
+ * libgnat/s-valuer.adb (Scan_Raw_Real): Add RM reference.
+
+2025-06-12 Ronan Desplanques <desplanques@adacore.com>
+
+ * libgnat/s-valuer.adb (Scan_Raw_Real): Remove subexpression. Improve
+ surrounding comments.
+
+2025-06-12 Bob Duff <duff@adacore.com>
+
+ * vast.adb: Check basic tree properties.
+ * atree.adb (Traverse_Field): Minor.
+ * treepr.adb (Destroy): Minor comment.
+
+2025-06-12 Eric Botcazou <ebotcazou@adacore.com>
+
+ * libgnat/s-valuer.adb (Round_Extra): Use multiplicative test.
+
+2025-06-12 Ronan Desplanques <desplanques@adacore.com>
+
+ * einfo-utils.adb (Set_Convention): Remove obsolete test.
+
+2025-06-12 Ronan Desplanques <desplanques@adacore.com>
+
+ * sem_ch3.adb (Process_Discriminants): Set Ekind earlier.
+ * sem_util.adb (Enter_Name): Adjust error processing.
+
+2025-06-12 Eric Botcazou <ebotcazou@adacore.com>
+
+ * libgnat/s-valuef.adb (Integer_To_Fixed): Enable overflow checks.
+ Deal specifically with Val = 2**(Int'Size - 1) if Minus is not set.
+ Exit the loop when V saturates to 0 in the case of (huge) negative
+ exponents.
+
+2025-06-12 Ronan Desplanques <desplanques@adacore.com>
+
+ * exp_util.adb (Insert_Actions): Refine test.
+
+2025-06-12 Eric Botcazou <ebotcazou@adacore.com>
+
+ * doc/gnat_ugn/building_executable_programs_with_gnat.rst (Compiler
+ switches) <-O>: Fix long line.
+ * gnat_ugn.texi: Regenerate.
+
+2025-06-12 Eric Botcazou <ebotcazou@adacore.com>
+
+ * doc/gnat_ugn/building_executable_programs_with_gnat.rst (List of
+ all switches): Add -gnatRh subswitch.
+ (Debugging Control): Document -gnatRh subswitch.
+ * opt.ads (List_Representation_Info_Holes): New boolean variable.
+ * repinfo.adb: Add with clause for GNAT.Heap_Sort_G.
+ (List_Common_Type_Info): Relax assertion.
+ (List_Object_Info): Replace assertion with additional test.
+ (List_Record_Layout): If -gnatRh is specified, make sure that the
+ components are ordered by increasing offsets. Output a comment
+ line giving the number of unused bits if there is a hole between
+ consecutive components. Streamline the control flow of the loop.
+ (List_Record_Info): Use the original record type giving the layout
+ of components, if any, to display the layout of the record.
+ * switch-c.adb (Scan_Front_End_Switches) <-gnatR>: Add support for
+ -gnatRh subswitch.
+ * usage.adb (Usage): Document -gnatRh subswitch.
+ * gnat_ugn.texi: Regenerate.
+
+2025-06-12 Johannes Kliemann <kliemann@adacore.com>
+
+ * libgnat/s-secsta.adb (SS_Allocate): Add comment about
+ conservative alignment padding calculation.
+ * libgnat/s-secsta__cheri.adb (SS_Allocate): Add comment about
+ conservative alignment padding calculation.
+
+2025-06-12 Ronan Desplanques <desplanques@adacore.com>
+
+ * sem_warn.adb (Check_References): Rewrite expression
+
+2025-06-12 Ronan Desplanques <desplanques@adacore.com>
+
+ * sem_ch3.adb (Constrain_Index, Make_Index, Array_Type_Declaration,
+ Analyze_Number_Declaration): Remove uses of E_Void.
+
+2025-06-12 Eric Botcazou <ebotcazou@adacore.com>
+
+ * usage.adb (Usage): Justify the documentation of common switches
+ like that of other switches. Rework that of the -O switch.
+ * doc/gnat_ugn/building_executable_programs_with_gnat.rst (Compiler
+ switches) <-O>: Rework and document 'z' and 'g' operands.
+ * doc/gnat_ugn/gnat_and_program_execution.rst (Optimization Levels):
+ Rework and document -Oz and -Og switches.
+ * gnat_ugn.texi: Regenerate.
+
+2025-06-12 Ronan Desplanques <desplanques@adacore.com>
+
+ * sem_ch3.adb (Constrain_Index): Avoid unused itypes.
+
+2025-06-12 Ronan Desplanques <desplanques@adacore.com>
+
+ * sem_ch3.adb (Constrain_Index): Factorize return statement.
+
+2025-06-12 Ronan Desplanques <desplanques@adacore.com>
+
+ * sem_ch3.adb (Build_Derived_Numeric_Type): Remove duplicate call.
+
+2025-06-10 Piotr Trojanek <trojanek@adacore.com>
+
+ * gen_il-gen-gen_entities.adb (Formal_Object_Kind): Remove
+ Entry_Component field.
+
+2025-06-10 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_attr.adb (Resolve_Attribute): Remove redundant guard.
+
+2025-06-10 Eric Botcazou <ebotcazou@adacore.com>
+
+ * inline.adb (Analyze_Inlined_Bodies): Minor comment tweak.
+
+2025-06-10 Eric Botcazou <ebotcazou@adacore.com>
+
+ * inline.adb (Instantiate_Body): Do not call Add_Scope_To_Clean if
+ the main unit is generic.
+ (Instantiate_Bodies): Do not deal with generic main units here.
+ * sem_ch12.adb (Need_Subprogram_Instance_Body): Return false if the
+ main unit is generic.
+
+2025-06-10 Eric Botcazou <ebotcazou@adacore.com>
+
+ * Makefile.rtl (ADA_EXCLUDE_SRCS): Add the 128-bit support files.
+
+2025-06-10 Ronan Desplanques <desplanques@adacore.com>
+
+ * sem_ch3.adb (Process_Subtype): Factorize code.
+
+2025-06-10 Bob Duff <duff@adacore.com>
+
+ * einfo.ads (Associated_Node_For_Itype): Document that
+ Parent field may be empty.
+ * vast.adb: Allow empty Parent in Itypes.
+
+2025-06-10 Gary Dismukes <dismukes@adacore.com>
+
+ * einfo.ads: Revise comment about Dynamic_Predicate flag to make it
+ more accurate.
+ * sem_case.adb (Check_Choices): Test "not Has_Static_Predicate_Aspect"
+ as additional guard for error about use of subtype with nonstatic
+ predicate as a case choice. Improve related error message.
+
+2025-06-10 Tonu Naks <naks@adacore.com>
+
+ * libgnat/s-valueu.adb: add explict raise
+ * libgnat/s-valueu.ads: update annotation
+
+2025-06-10 Ronan Desplanques <desplanques@adacore.com>
+
+ * sem_ch6.adb, sem_ch6.ads (Check_Discriminant_Conformance): Move to …
+ * sem_ch3.adb (Check_Discriminant_Conformance): … here.
+
+2025-06-10 Eric Botcazou <ebotcazou@adacore.com>
+
+ * freeze.adb (Freeze_Static_Object): Do not issue any error message
+ for compiler-generated entities.
+
+2025-06-10 Bob Duff <duff@adacore.com>
+
+ * vast.adb: Implement two checks. Improve debugging
+ outputs.
+
+2025-06-10 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_ch4.adb (Insert_Conditional_Object_Declaration): Deal with a
+ transient scope being created around the declaration.
+ * freeze.adb (Freeze_Entity): Do not call Freeze_Static_Object for
+ a renaming declaration.
+
+2025-06-10 Eric Botcazou <ebotcazou@adacore.com>
+
+ * libgnat/s-vafi32.ads: Fix head description.
+ * libgnat/s-vafi64.ads: Likewise.
+ * libgnat/s-vafi128.ads: Likewise.
+
+2025-06-10 Bob Duff <duff@adacore.com>
+
+ * vast.adb: Initial implementation.
+ * vast.ads: Rename procedure. Remove parameter; body should decide
+ what to do.
+ * lib.ads (ipu): Minor: Rewrite comment for brevity, and because
+ of an inconvenient misspelling.
+ (Num_Units): Not used; remove.
+ (Remove_Unit): Minor: Remove "Currently" (which was current a decade
+ ago from) comment.
+ * lib.adb (Num_Units): Not used; remove.
+ * debug_a.adb (Debug_A_Entry): Fix bug: Use Write_Name_For_Debug,
+ so this won't crash on the Error node.
+ * debug.adb: Document -gnatd_V and -gnatd_W compiler switches.
+ * exp_ch6.adb (Validate_Subprogram_Calls): Remove redundant check for
+ Serious_Errors_Detected. (We turn off code gen when errors are
+ detected.)
+ * frontend.adb: Move decisions into VAST body.
+ * namet.ads (Present): Remove unnecessary overriding; these are
+ inherited by the derived types.
+ * namet.adb (Present): Likewise.
+
+2025-06-10 Gary Dismukes <dismukes@adacore.com>
+
+ * exp_aggr.adb (Build_Container_Aggr_Code.To_Int): Apply Enumeration_Pos
+ to Entity (Expr) rather than Expr.
+
+2025-06-10 Ronan Desplanques <desplanques@adacore.com>
+
+ * sem_ch3.adb (Find_Type_Of_Object): Fix comment.
+
+2025-06-10 Ronan Desplanques <desplanques@adacore.com>
+
+ * sem_ch3.adb (Analyze_Component_Declaration): Rename constant.
+
+2025-06-10 Ronan Desplanques <desplanques@adacore.com>
+
+ * sem_ch3.adb (Constrain_Array): Simplify.
+ (Process_Subtype): Adjust.
+
+2025-06-10 Eric Botcazou <ebotcazou@adacore.com>
+
+ * sem_ch12.adb (Copy_Generic_Node): Do not call Root_Type to find
+ the root type of an aggregate of a derived tagged type.
+
+2025-06-10 Ronan Desplanques <desplanques@adacore.com>
+
+ * libgnarl/s-stusta.adb (Compute_All_Tasks): Skip terminated tasks.
+
+2025-06-10 Viljar Indus <indus@adacore.com>
+
+ * sem_prag.adb (Is_Configuration_Pragma): Check that nodes
+ preceding the pragma are pragma nodes or originally were
+ pragma nodes.
+
+2025-06-10 Eric Botcazou <ebotcazou@adacore.com>
+
+ * libgnat/s-valued.adb (Integer_to_Decimal): Add Extra parameter and
+ use its value to call Bad_Value on boundary values.
+ (Scan_Decimal): Adjust call to Integer_to_Decimal.
+ (Value_Decimal): Likewise.
+
+2025-06-10 Ronan Desplanques <desplanques@adacore.com>
+
+ * sem_ch3.ads (Process_Subtype): New formal.
+ * sem_ch3.adb (Process_Subtype): Likewise.
+ (Analyze_Subtype_Declaration, Access_Type_Declaration): Use new
+ formal.
+
+2025-06-10 Ronan Desplanques <desplanques@adacore.com>
+
+ * sem_ch3.adb (Process_Subtype): Fix recursive call.
+
+2025-06-10 Eric Botcazou <ebotcazou@adacore.com>
+
+ * par-ch5.adb (P_Declare_Statement): Rename local variable.
+ (P_Begin_Statement): Likewise.
+
+2025-06-10 Piotr Trojanek <trojanek@adacore.com>
+
+ * einfo.ads (Overridden_Operation, Static_Initialization): Remove
+ comments about a reused entity field.
+
+2025-06-10 Ronan Desplanques <desplanques@adacore.com>
+
+ * sem_ch3.adb (Process_Subtype): Tweak formatting.
+
+2025-06-10 Ronan Desplanques <desplanques@adacore.com>
+
+ * sem_ch3.adb (Process_Subtype): Add assertion.
+
+2025-06-10 Ronan Desplanques <desplanques@adacore.com>
+
+ * sem_ch3.adb (Process_Subtype): Factorize initialization of variable.
+
+2025-06-09 Gary Dismukes <dismukes@adacore.com>
+
+ * sem_ch3.adb (Constrain_Index): In the case of a fixed-lower-bound index,
+ set Etype of the newly created itype's Scalar_Range from the index's Etype.
+ * sem_ch12.adb (Validate_Array_Type_Instance): If the actual subtype is
+ a fixed-lower-bound type, then check again the Etype of its Scalar_Range.
+
+2025-06-09 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_prag.adb (Analyze_Pragma): Fix conditions for legality checks on
+ formal type declarations.
+
+2025-06-09 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_prag.adb (Analyze_Pragma): If pragmas apply to a formal array
+ type, then set the flags on the base type.
+
+2025-06-09 Ronan Desplanques <desplanques@adacore.com>
+
+ * sem_ch3.adb (Process_Subtype): Clarify code.
+
+2025-06-09 Ronan Desplanques <desplanques@adacore.com>
+
+ * sem_ch3.ads (Process_Subtype): Add formal.
+ * sem_ch3.adb (Process_Subtype): Use new formal.
+ (Analyze_Subtype_Declaration, Array_Type_Declaration,
+ Build_Derived_Access_Type): Pass new actual.
+ * sem_ch4.adb (Find_Type_Of_Object): Likewise.
+
+2025-06-09 Ronan Desplanques <desplanques@adacore.com>
+
+ * sem_ch6.adb (Set_Formal_Mode): Extend profile. Move parts of the
+ body…
+ (Process_Formals): … here. Move call to Set_Formal_Mode earlier. Call
+ Set_Is_Not_Self_Hidden in second traversal.
+
+2025-06-09 Gary Dismukes <dismukes@adacore.com>
+
+ * exp_aggr.adb (Expand_Container_Aggregate): Use the Base_Type of the
+ subtype provided by the context as the subtype of the temporary object
+ initialized by the aggregate.
+
+2025-06-09 Eric Botcazou <ebotcazou@adacore.com>
+
+ * par-ch4.adb (P_Function_Name): Delete body.
+ (P_Qualified_Simple_Name_Resync): Do not raise Error_Resync on an
+ operator symbol followed by something else than a dot.
+ * par-ch6.adb (P_Subprogram): Do not call P_Function_Name.
+ * par.adb (P_Function_Name): Delete declaration.
+
+2025-06-09 Ronan Desplanques <desplanques@adacore.com>
+
+ * sem.adb (Analyze): Adapt to new Ekinds.
+ * sem_ch3.adb (Analyze_Component_Declaration): Set Ekind early.
+ (Is_Visible_Component, Record_Type_Definition): Adjust.
+
+2025-06-09 Ronan Desplanques <desplanques@adacore.com>
+
+ * sem.adb (Analyze): Fix comment.
+
+2025-06-09 Eric Botcazou <ebotcazou@adacore.com>
+
+ * par-ch4.adb (P_Name): Remove obsolete references in comments.
+ (P_Qualified_Simple_Name): Call P_Qualified_Simple_Name_Resync.
+ (P_Qualified_Simple_Name_Resync): Adjust a couple of comments.
+
+2025-06-09 Gary Dismukes <dismukes@adacore.com>
+
+ * exp_util.adb (Call_To_Parent_Dispatching_Op_Must_Be_Mapped): Replace
+ test of Covers with test of Is_Controlling_Formal. Add handling for
+ 'Result actuals. Remove Actual_Type and its uses.
+
+2025-06-09 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_util.adb (Is_Name_Reference): Remove check for selector_name of a
+ selected_component; reuse existing code for indexed components and
+ slices.
+ (Statically_Names_Object): Remove dead code.
+
+2025-06-09 Eric Botcazou <ebotcazou@adacore.com>
+
+ * einfo.ads (Overlays_Constant): Define in constants and variables.
+ * gen_il-gen-gen_entities.adb (Entity_Kind): Move Overlays_Constant
+ semantic flag to...
+ (Constant_Or_Variable_Kind): ...here.
+ * sem_util.adb (Note_Possible_Modification): Add guard.
+
+2025-06-09 Bob Duff <duff@adacore.com>
+
+ * exp_ch6.adb: (Make_Build_In_Place_Call_In_Object_Declaration):
+ Deal with renamings transformed into object declarations.
+ * sem_ch8.adb (Analyze_Object_Renaming):
+ Reinstate transformation of a renaming into
+ an object declaration.
+
+2025-06-09 Ronan Desplanques <desplanques@adacore.com>
+
+ * sem_ch3.adb (Analyze_Object_Declaration): Call Mutate_Ekind earlier.
+
+2025-06-09 Ronan Desplanques <desplanques@adacore.com>
+
+ * sem_ch3.adb (Analyze_Object_Declaration): Tweak error handling.
+
+2025-06-09 Piotr Trojanek <trojanek@adacore.com>
+
+ * par-ch13.adb (Get_Aspect_Specifications): Save and restore flag while
+ parsing aspect Abstract_State.
+ * par-ch2.adb (P_Pragma): Same while parsing pragma Abstract_State.
+ * par-ch4.adb (P_Aggregate_Or_Paren_Expr): Specialize error message
+ for contract Abstract_State and extended aggregate.
+ * par.adb (Inside_Abstract_State): Add new context flag.
+
+2025-06-09 Ronan Desplanques <desplanques@adacore.com>
+
+ * sem_ch10.adb (Analyze_Compilation_Unit): Check for generic bodies.
+ * exp_disp.adb (Build_Dispatch_Tables): Likewise.
+
+2025-06-09 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_util.adb (Find_Overlaid_Entity): Don't call Etype on empty Ent;
+ tune style; move computation of Overl_Typ out of the loop.
+
+2025-06-09 Javier Miranda <miranda@adacore.com>
+
+ * doc/gnat_rm/implementation_defined_pragmas.rst: Adding
+ documentation.
+ * doc/gnat_ugn/the_gnat_compilation_model.rst: ditto.
+ * gnat_rm.texi: Regenerate.
+ * gnat_ugn.texi: Regenerate.
+
+2025-06-09 Ronan Desplanques <desplanques@adacore.com>
+
+ * sem_attr.adb (Analyze_Attribute): Remove test.
+
+2025-06-09 Ronan Desplanques <desplanques@adacore.com>
+
+ * sem_util.adb (Enter_Name): Remove special handling.
+
+2025-06-09 Ronan Desplanques <desplanques@adacore.com>
+
+ * sem_util.adb (Enter_Name): Remove comment.
+
+2025-06-09 Bob Duff <duff@adacore.com>
+
+ * exp_ch6.adb: Remove a couple of "???" suggesting something that
+ we will likely never do.
+ (Make_Build_In_Place_Call_In_Object_Declaration):
+ When a constraint check is needed, do the check.
+ Do it at the call site for now.
+ The check is still missing in the untagged case,
+ because the caller allocates in that case.
+ * sem_ch8.adb (Analyze_Object_Renaming):
+ Remove obsolete transformation of a renaming into
+ an object declaration. Given that we also (sometimes) tranform
+ object declarations into renamings, this transformation was
+ adding complexity; the new code in
+ Make_Build_In_Place_Call_In_Object_Declaration above
+ would need to explicitly avoid the run-time check in the case of
+ renamings, because renamings are supposed to ignore the nominal
+ subtype. Anyway, it is no longer needed.
+ * exp_ch3.adb (Expand_N_Object_Declaration): Rewrite comment;
+ it IS clear how to do it, but we haven't done it right yet.
+
+2025-06-09 Ronan Desplanques <desplanques@adacore.com>
+
+ * atree.ads (Copy_Node): Fix comment.
+
+2025-06-09 Piotr Trojanek <trojanek@adacore.com>
+
+ * exp_attr.adb (Expand_N_Attribute_Reference): When expanding attribute
+ Valid, use signedness from the validated view, not from its base type.
+
+2025-06-09 Marc Poulhiès <poulhies@adacore.com>
+
+ * sem_util.adb (Find_Overlaid_Entity): Add extra parameter to
+ extract the type being overlaid.
+ (Note_Possible_Modification): Adjust call to Find_Overlaid_Entity.
+ (Ultimate_Overlaid_Entity): Likewise.
+ * sem_ch13.adb (Analyze_Attribute_Definition_Clause): Likewise.
+ * sem_util.ads (Find_Overlaid_Entity): Add extra parameter to
+ extract the type being overlaid.
+ * freeze.adb (Check_Address_Clause): Likewise.
+
+2025-06-09 Gary Dismukes <dismukes@adacore.com>
+
+ * contracts.adb (Inherit_Condition): Remove Assoc_List and its uses
+ along with function Check_Condition, since mapping of formals will
+ effectively be done in Build_Class_Wide_Expression (by Replace_Entity).
+ * exp_util.adb (Replace_Entity): Only rewrite entity references in
+ function calls that qualify according to the result of calling the
+ new function Call_To_Parent_Dispatching_Op_Must_Be_Mapped.
+ (Call_To_Parent_Dispatching_Op_Must_Be_Mapped): New function that
+ determines whether a function call to a primitive of Par_Subp
+ associated tagged type needs to be mapped (according to whether
+ it has any actuals that reference controlling formals of the
+ primitive).
+
+2025-06-09 Ronan Desplanques <desplanques@adacore.com>
+
+ * sem_ch3.adb (Analyze_Object_Declaration): Remove comment.
+
+2025-06-09 Ronan Desplanques <desplanques@adacore.com>
+
+ * sem_util.ads (Current_Entity_In_Scope): Add example in comment.
+
+2025-06-09 Ronan Desplanques <desplanques@adacore.com>
+
+ * atree.ads (Rewrite, Replace): Clarify comments.
+
+2025-06-09 Ronan Desplanques <desplanques@adacore.com>
+
+ * atree.ads (Rewrite): Remove comment.
+
+2025-06-09 Ronan Desplanques <desplanques@adacore.com>
+
+ * atree.adb (Rewrite): Improve readability.
+
+2025-06-09 Ronan Desplanques <desplanques@adacore.com>
+
+ * sem_util.adb (Kill_Current_Values): Tweak condition.
+
+2025-06-09 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_ch4.adb (Insert_Conditional_Object_Declaration): Remove Decl
+ formal parameter, add Typ and Const formal parameters.
+ (Expand_N_Case_Expression): Fix pasto in comment. Adjust call to
+ Insert_Conditional_Object_Declaration and tidy up surrounding code.
+ (Expand_N_If_Expression): Adjust couple of calls to
+ Insert_Conditional_Object_Declaration.
+
+2025-06-09 Ronan Desplanques <desplanques@adacore.com>
+
+ * sem_ch8.adb (Find_Selected_Component): Fix error path.
+
+2025-06-09 Eric Botcazou <ebotcazou@adacore.com>
+
+ * libgnat/s-dourea.adb (Is_Infinity): Rename to...
+ (Is_Infinity_Or_NaN): ...this.
+ ("*"): Adjust accordingly.
+ ("/"): Likewise.
+ (Sqr): Likewise.
+ * libgnat/s-dorepr.adb (Two_Prod): Likewise.
+ (Two_Sqr): Likewise.
+ * libgnat/s-dorepr__fma.adb (Two_Prod): Likewise.
+
+2025-06-09 Daniel King <dmking@adacore.com>
+
+ * libgnat/i-cheri.ads
+ (Set_Bounds, Set_Exact_Bounds): Remove wrong intrinsic binding.
+ * libgnat/i-cheri.adb
+ (Set_Bounds, Set_Exact_Bounds): New subprogram bodies.
+
+2025-06-09 Ronan Desplanques <desplanques@adacore.com>
+
+ * sem_ch8.adb (Find_Selected_Component): Add mention.
+
+2025-06-06 Piotr Trojanek <trojanek@adacore.com>
+
+ * urealp.adb (UR_Negate): Capture array element in a local constant.
+
+2025-06-06 Piotr Trojanek <trojanek@adacore.com>
+
+ * urealp.adb (UR_Exponentiate): Use local variable.
+
+2025-06-06 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_ch13.adb (Analyze_Attribute_Definition_Clause): Tune code for
+ attribute Small.
+ * sem_prag.adb (Analyze_Attribute): Tune code for pragma Time_Slice.
+
+2025-06-06 Piotr Trojanek <trojanek@adacore.com>
+
+ * ada_get_targ.adb, cstand.ads, cstand.adb, sem_eval.adb, sem_eval.ads,
+ urealp.adb, urealp.ads: Tune style.
+
+2025-06-06 Piotr Trojanek <trojanek@adacore.com>
+
+ * get_targ.ads (Register_Proc_Type): Add null exclusion.
+
+2025-06-06 Piotr Trojanek <trojanek@adacore.com>
+
+ * cstand.adb (Build_Float_Type, Register_Float_Type): Refine
+ parameter subtypes.
+ * set_targ.ads (FPT_Mode_Entry): Refine component subtype.
+
+2025-06-06 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_prag.adb (Analyze_Pragma): Add dependency of Program_Exit on
+ Global and Depends contracts.
+ (Analyze_Program_Exit_In_Decl_Part): Check references to subprogram
+ outputs.
+
+2025-06-06 Claire Dross <dross@adacore.com>
+
+ * doc/gnat_rm/implementation_defined_pragmas.rst
+ (Pragma Exit_Cases): Update the documentation for Exit_Cases.
+ * sem_prag.adb
+ (Anlayze_Pragma): Accept Program_Exit as an exit kind.
+ * gnat_rm.texi: Regenerate.
+ * gnat_ugn.texi: Regenerate.
+
+2025-06-06 Piotr Trojanek <trojanek@adacore.com>
+
+ * aspects.ads (Aspect_Argument): Argument for Program_Exit is now
+ optional.
+ * doc/gnat_rm/implementation_defined_pragmas.rst
+ (Pragma Program_Exit): Change documentation for pragma syntax.
+ * sem_prag.adb (Analyze_Pragma): Argument for Program_Exit is now
+ optional.
+ (Analyze_Program_Exit_In_Decl_Part): Likewise.
+ * gnat_rm.texi: Regenerate.
+ * gnat_ugn.texi: Regenerate.
+
+2025-06-06 Piotr Trojanek <trojanek@adacore.com>
+
+ * aspects.ads (Aspect_Id): Add new aspect identifier.
+ (Aspect_Argument): Specify argument for the new aspect.
+ (Is_Representation_Aspect): New aspect is not a representation aspect.
+ (Aspect_Names): Map new aspect to name.
+ (Aspect_Delay): New aspect is always delayed.
+ * contracts.adb (Expand_Subprogram_Contract)
+ (Add_Pre_Post_Condition, Add_Contract_Item)
+ (Analyze_Entry_Or_Subprogram_Contract)
+ (Analyze_Entry_Or_Subprogram_Body_Contract)
+ (Analyze_Subprogram_Body_Stub_Contract): Support new aspect.
+ * contracts.ads (Add_Contract_Item,
+ Analyze_Entry_Or_Subprogram_Contract,
+ Analyze_Entry_Or_Subprogram_Body_Contract,
+ Analyze_Subprogram_Body_Stub_Contract): Mention new contract in
+ comment.
+ * doc/gnat_rm/implementation_defined_aspects.rst
+ (Aspect Program_Exit): Document new aspect.
+ * doc/gnat_rm/implementation_defined_pragmas.rst
+ (Pragma Program_Exit): Document new pragma.
+ * einfo-utils.adb (Get_Pragma): Support new pragma.
+ * einfo-utils.ads (Get_Pragma): Mention new pragma in comment.
+ * exp_prag.adb (Expand_Pragma_Program_Exit): Expand new pragma;
+ body.
+ * exp_prag.ads (Expand_Pragma_Program_Exit): Expand new pragma;
+ spec.
+ * inline.adb (Remove_Aspects_And_Pragmas): Support new pragma.
+ * par-prag.adb (Prag): Support new pragma.
+ * sem_attr.adb (Analyze_Attribute_Old_Result): Accept attribute
+ Old in new pragma.
+ * sem_ch12.adb (Implementation of Generic Contracts): Mention new
+ aspect in comment.
+ * sem_ch13.adb (Insert_Pragma, Analyze_Aspect_Specifications):
+ Convert new new aspect to pragma.
+ * sem_ch6.adb (Analyze_Subprogram_Body_Helper): Renumber
+ subsequent rule in comment.
+ * sem_prag.adb (Check_Postcondition_Use_In_Inlined_Subprogram)
+ (Contract_Freeze_Error): Mention new pragma in comment.
+ (Analyze_Pragma): Support new pragma; renumber subsequent rule in
+ comment.
+ (Analyze_Program_Exit_In_Decl_Part): Analyze new pragma; body.
+ (Sig_Flags): References in new pragma are significant when
+ detecting unreferenced objects.
+ * sem_prag.ads (Aspect_Specifying_Pragma)
+ (Assertion_Expression_Pragma, Pragma_Significant_To_Subprograms):
+ Support new aspect and pragma.
+ (Analyze_Program_Exit_In_Decl_Part): Analyze new pragma; spec.
+ (Find_Related_Package_Or_Body): Mention new pragma in comment.
+ * sem_util.adb (Is_Subprogram_Contract_Annotation): Support new
+ pragma.
+ * sem_util.ads (Is_Subprogram_Contract_Annotation): Mention new
+ pragma in comment.
+ * sinfo.ads (Is_Generic_Contract_Pragma): Mention new pragma in
+ comment.
+ * snames.ads-tmpl (Preset Names, Pragma_Id): Add name and pragma
+ identifiers.
+ * gnat_rm.texi: Regenerate.
+
+2025-06-06 Piotr Trojanek <trojanek@adacore.com>
+
+ * libgnat/g-dyntab.ads (Instance): Update and extend comment.
+ * scos.ads: Remove comment about the corresponding C header.
+ * scos.h: Remove.
+
+2025-06-06 Steve Baird <baird@adacore.com>
+
+ * sem_util.adb (Collect_Primitive_Operations): When collecting
+ primitive operations, do not include child unit subprograms.
+
+2025-06-06 Javier Miranda <miranda@adacore.com>
+
+ * sem_ch4.adb (Constant_Indexing_OK): Add missing support for
+ RM 4.1.6(13/3), and improve performance to avoid climbing more
+ than needed. Add documentation.
+ (Try_Indexing_Function): New subprogram.
+ (Expr_Matches_In_Formal): Added new formals.
+ (Handle_Selected_Component): New subprogram.
+ (Has_IN_Mode): New subprogram.
+ (Try_Container_Indexing): Add documentation, code reorganization
+ and extend its functionality to improve its support for prefixed
+ notation calls.
+
+2025-06-06 Viljar Indus <indus@adacore.com>
+
+ * debug.adb: Mark -gnatd_D as unused.
+ * diagnostics-repository.adb: Move to...
+ * errid.adb: ...here.
+ * diagnostics-repository.ads: Move to...
+ * errid.ads: ...here.
+ * errout.adb (Error_Msg_Internal): Add new arguments for the new
+ attributes of Error_Msg_Objects.
+ (Error_Msg): Likewise.
+ (Error_Msg_N): Likewise.
+ (Labeled_Span): New method for creating Labeled_Span-s
+ (Primary_Label_Span): New method for creating primary Labeled_Spans.
+ (Secondary_Labeled_Span): New method for creating secondary
+ Labeled_Spans.
+ (Edit): New method for creating Edit elements.
+ (Fix): New method for creating Fix elements.
+ (Error_Msg_F): Simplify code for evaluating the span.
+ (Error_Msg_FE): Likewise.
+ (Error_Msg_NE): Likewise.
+ (Error_Msg_NEL): Likewise.
+ (Error_Msg_N_Gigi): New method that is used as a wrapper for the
+ Error_Msg_xxx methods that have the new arguments. This function
+ is later mapped to the Error_Msg method used inside gigi.
+ (Error_Msg_NE_Gigi): Likewise.
+ (Write_JSON_Span): Ensure that the Style prefix is included that is
+ removed when parsing the message is reinserted to the JSON report.
+ (Output_Messages): Use the new Pretty_Printer and Sarif_Printer
+ packages to print the messages and remove the old implementation
+ for the pretty printer.
+ (Set_Msg_Text): Remove message kind insertion characters from the
+ final message text to avoid some message kinds being duplicated.
+ (To_Full_Span_First): New method for creating a span for a node.
+ (To_Full_Span): Likewise.
+ * errout.ads: Add the specs for all of the newly added functions.
+ * diagnostics-pretty_emitter.adb: Move to...
+ * erroutc-pretty_emitter.adb: ...here.
+ * diagnostics-pretty_emitter.ads: Move to...
+ * erroutc-pretty_emitter.ads: ...here.
+ * diagnostics-sarif_emitter.adb: Move to...
+ * erroutc-sarif_emitter.adb: ...here.
+ * diagnostics-sarif_emitter.ads: Move to...
+ * erroutc-sarif_emitter.ads: ...here.
+ * erroutc.adb (Next_Error_Msg): New method for iterating to the
+ next error message.
+ (Next_Continuation_Msg): New method for iterating to the next
+ continuation message.
+ (Primary_Location): New method for returning the first primary
+ location for the error message.
+ (Get_Human_Id): New method for returning the human readable
+ name for the switch associated with this error message.
+ (Get_Doc_Switch): New method for creating the tag for the switch
+ used in the error message.
+ (Output_Text_Within): Change the method to operating on Strings
+ instead of String pointers.
+ (Output_Msg_Text): Simplify implementation for generating the
+ error message.
+ (Prescan_Message): Make the String handling more error proof.
+ * erroutc.ads (Error_Msg_Object): Add new attributes that were
+ added to Diagnostic objects to Error_Msg_Objects.
+ Add new methods for handling the new error objects.
+ * diagnostics-switch_repository.adb: Move to...
+ * errsw.adb: ...here.
+ * errutil.adb (Error_Msg): Initialize all of the new attributes
+ added to Error_Msg_Object-s.
+ * fe.h (Error_Msg_N): Update the binding.
+ (Error_Msg_NE): Update the binding.
+ For now the error_msg methods in gigi will use the old
+ simplified interface for those methods.
+ * diagnostics-json_utils.adb: Move to...
+ * json_utils.adb: ...here.
+ * diagnostics-json_utils.ads: Move to...
+ * json_utils.ads: ...here.
+ * par-endh.adb: Replace the old error_msg
+ calls with the updated interface.
+ * sem_aggr.adb: Likewise.
+ * sem_ch13.adb: Likewise.
+ * sem_ch4.adb: Likewise.
+ * sem_ch9.adb: Likewise.
+ * diagnostics-brief_emitter.adb: Removed.
+ * diagnostics-brief_emitter.ads: Removed.
+ * diagnostics-constructors.adb: Removed.
+ * diagnostics-constructors.ads: Removed.
+ * diagnostics-converter.adb: Removed.
+ * diagnostics-converter.ads: Removed.
+ * diagnostics-switch_repository.ads: Removed.
+ * diagnostics-utils.adb: Removed.
+ * diagnostics-utils.ads: Removed.
+ * diagnostics.adb: Removed.
+ * diagnostics.ads: Removed.
+ * errsw.ads: New file. Based on diagnostics-switch_repository.ads.
+ It additionally contains all the switch enumerations.
+ * gcc-interface/Make-lang.in: Update compilation dependencies.
+ * gcc-interface/Makefile.in: Likewise.
+
+2025-06-06 Ronan Desplanques <desplanques@adacore.com>
+
+ * contracts.adb (Add_Invariant_And_Predicate_Checks): Assign Ekind.
+ * inline.adb (Expand_Inlined_Call): Likewise.
+ * exp_ch9.adb (Build_Simple_Entry_Call): Likewise.
+ * exp_dist.adb (Append_Array_Traversal): Likewise.
+ * exp_fixd.adb (Build_Double_Divide_Code, Build_Scaled_Divide_Code):
+ Likewise.
+
+2025-06-06 Olivier Hainque <hainque@adacore.com>
+
+ * libgnarl/s-linux__android-aarch64.ads: Provide an
+ Android_Sigaction generic package to expose an aarch64
+ version of struct_sigation, using a provided sigset_t
+ for sa_flags.
+ * libgnarl/s-linux__android-arm.ads: Likewise, for ARM
+ rather than aarch64.
+ * libgnarl/s-osinte__android.ads: Move sigset_t definition
+ to the visible part and use it to instantiate the Android_Sigation
+ generic provided by System.Linux, which is specialized for ARM vs
+ aarch64. Define struct_sigaction out of the Android_Sigaction
+ instance, remove the local representation clauses.
+
+2025-06-06 Olivier Hainque <hainque@adacore.com>
+
+ * Makefile.rtl: Rework the Android pairs to match those of a
+ regular Linux port rather than a generic posix one.
+ * libgnarl/s-osinte__android.ads: Import pcrtl and add bindings
+ for the pthread_rwlock entry points, used by the Linux units now
+ in the libgnat target pairs.
+ * sysdep.c (__gnat_has_cap_sys_nice): Define for Android,
+ conservative return 0.
+ * adaint.c (__gnat_cpu_alloc): Define for Android as for Linux.
+
+2025-06-06 Piotr Trojanek <trojanek@adacore.com>
+
+ * namet.ads (Name_Entry): Update comments to explain the current needs.
+
+2025-06-06 Piotr Trojanek <trojanek@adacore.com>
+
+ * lib.ads (Unit_Record): Remove representation clauses and filler
+ components
+ * lib-load.adb, lib-writ.adb: Remove initialization of data fillers.
+ * nlists.adb (Allocate_List_Tables): Remove explicit initialization.
+ * repinfo.adb (Exp_Node): Remove representation clauses.
+ * sinput.ads (Source_File_Record): Likewise.
+ * urealp.adb (Ureal_Entry): Likewise.
+
+2025-06-06 Piotr Trojanek <trojanek@adacore.com>
+
+ * doc/gnat_rm/representation_clauses_and_pragmas.rst
+ (Effect of Convention on Representation): Fix number of list items.
+ * gnat_rm.texi: Regenerate.
+ * gnat_ugn.texi: Regenerate.
+
+2025-06-06 Eric Botcazou <ebotcazou@adacore.com>
+
+ * sem_ch10.adb (Install_Siblings.In_Context): Add missing guard.
+
+2025-06-06 Ronan Desplanques <desplanques@adacore.com>
+
+ * sem_ch4.adb (Analyze_Selected_Component): Tweak condition.
+
+2025-06-06 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_ch4.adb (Insert_Conditional_Object_Declaration): Make sure the
+ object is allocated properly by the code generator at library level.
+
+2025-06-06 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_eval.adb (Check_Non_Static_Context): Remove special handling of
+ floating-point zero.
+
+2025-06-06 Piotr Trojanek <trojanek@adacore.com>
+
+ * einfo.ads (Incomplete_View): Move from Sinfo; adapt wording.
+ * exp_ch3.adb (Build_Record_Init_Proc): Adapt retrieval of
+ Incomplete_View.
+ * gen_il-fields.ads (Opt_Field_Enum): Move Incomplete_View from node
+ to entity field.
+ * gen_il-gen-gen_entities.adb (Gen_Entities): Add field.
+ * gen_il-gen-gen_nodes.adb (Gen_Nodes): Remove field.
+ * sem_ch3.adb (Analyze_Full_Type_Declaration,
+ Check_Anonymous_Access_Component): Adapt setting of Incomplete_View.
+ * sem_ch6.adb (Analyze_Subprogram_Body_Helper): Adapt retrieval of
+ Incomplete_View for class-wide types; no longer rely on class-wide
+ type being attached to non-classwide type declaration.
+ * sem_util.adb (Collect_Primitive_Operations): Adapt retrieval of
+ Incomplete_View.
+ * sinfo.ads (Incomplete_View): Move to Einfo.
+
+2025-06-06 squirek <squirek@adacore.com>
+
+ * aspects.ads: Add support for constructors.
+ * exp_aggr.adb: Likewise.
+ * exp_attr.adb: Likewise.
+ * exp_ch3.adb: Likewise.
+ * exp_ch4.adb: Likewise.
+ * exp_util.adb: Likewise.
+ * gen_il-fields.ads: Likewise.
+ * gen_il-gen-gen_entities.adb: Likewise.
+ * gen_il-gen-gen_nodes.adb: Likewise.
+ * par-ch4.adb: Likewise.
+ * sem_aggr.adb: Likewise.
+ * sem_attr.adb, sem_attr.ads: Likewise.
+ * sem_ch13.adb: Likewise.
+ * sem_ch3.adb: Likewise.
+ * sem_ch5.adb: Likewise.
+ * sem_ch6.adb: Likewise.
+ * sem_res.adb: Likewise.
+ * sem_util.adb, sem_util.ads: Likewise.
+ * snames.ads-tmpl: Likewise.
+
+2025-06-06 squirek <squirek@adacore.com>
+
+ * doc/gnat_rm/gnat_language_extensions.rst: Add documentation.
+ * gnat_rm.texi: Regenerate.
+
+2025-06-06 Eric Botcazou <ebotcazou@adacore.com>
+
+ * einfo.ads (Modulus): Change to implementation base type only.
+ * gen_il-gen-gen_entities.adb (Modular_Integer_Kind): Change type
+ of Modulus field to Impl_Base_Type_Only.
+
+2025-06-06 Eric Botcazou <ebotcazou@adacore.com>
+
+ * einfo.ads (Original_Access_Type): Restore.
+ * gen_il-fields.ads (Opt_Field_Enum): Restore Original_Access_Type.
+ * gen_il-gen-gen_entities.adb: Adjust accordingly.
+ * exp_ch9.adb (Expand_Access_Protected_Subprogram_Type): Restore the
+ call to Set_Original_Access_Type.
+
+2025-06-06 Eric Botcazou <ebotcazou@adacore.com>
+
+ * einfo.ads (Default_Expr_Function): Delete.
+ (Dependent_Instances): Likewise.
+ (Handler_Records): Likewise.
+ (Needs_Activation_Record): Likewise.
+ (Original_Access_Type): Likewise.
+ (Register_Exception_Call): Likewise.
+ * sinfo.ads (Accept_Handler_Records): Likewise.
+ * gen_il-fields.ads (Opt_Field_Enum): Remove Accept_Handler_Records,
+ Default_Expr_Function, Dependent_Instances, Handler_Records,
+ Needs_Activation_Record, Original_Access_Type and
+ Register_Exception_Call.
+ * gen_il-gen-gen_entities.adb: Adjust accordingly.
+ * gen_il-gen-gen_nodes.adb: Likewise.
+ * exp_ch9.adb (Expand_Access_Protected_Subprogram_Type): Remove call
+ to Set_Original_Access_Type.
+ (Expand_N_Selective_Accept): Remove call to Set_Handler_Records.
+ * exp_ch11.adb (Expand_N_Exception_Declaration): Remove call to
+ Set_Register_Exception_Call.
+ * sem_ch3.adb (Access_Subprogram_Declaration): Remove call to
+ Set_Needs_Activation_Record.
+ * sem_ch12.adb (Instantiate_Package_Body): Remove call to
+ Set_Handler_Records.
+
+2025-06-06 Steve Baird <baird@adacore.com>
+
+ * sem_ch4.adb
+ (Find_Unary_Types): Because we reanalyze names in an instance,
+ we sometimes have to take steps to filter out extraneous name
+ resolution candidates that happen to be visible at the point of the
+ instance declaration. Remove some code that appears to have been
+ written with this in mind. This is done for two reasons. First, the
+ code sometimes doesn't work (possibly because the In_Instance test
+ is not specific enough - it probably should be testing to see whether
+ we are in an instance of the particular generic in which the result
+ of calling Corresponding_Generic_Type was declared) and causes correct
+ code to be rejected. Second, the code seems to no longer be necessary
+ (possibly because of subsequent fixes in this area which are not
+ specific to unary operators).
+
+2025-06-06 Ronan Desplanques <desplanques@adacore.com>
+
+ * sem_ch8.adb (Premature_Usage): Remove dead code.
+
+2025-06-06 Eric Botcazou <ebotcazou@adacore.com>
+
+ * einfo.ads (Size_Check_Code): Delete.
+ * gen_il-fields.ads (Opt_Field_Enum): Remove Size_Check_Code.
+ * gen_il-gen-gen_entities.adb (Constant_Or_Variable_Kind): Likewise.
+ * sem_ch13.adb (Analyze_Attribute_Definition_Clause): Remove call
+ to Kill_Size_Check_Code.
+ * sem_prag.adb (Analyze_Pragma): Likewise.
+ * sem_util.ads (Kill_Size_Check_Code): Delete.
+ * sem_util.adb (Kill_Size_Check_Code): Likewise.
+
+2025-06-06 Claire Dross <dross@adacore.com>
+
+ * sem_ch6.adb (Analyze_SPARK_Subprogram_Specification):
+ Allow the first parameter of functions whose return type is
+ an anonymous access-to-variable type to have mode IN OUT.
+
+2025-06-06 Ronan Desplanques <desplanques@adacore.com>
+
+ * gen_il-fields.ads: New field.
+ * gen_il-gen-gen_entities.adb: New field.
+ * einfo.ads: Document new field.
+ * sem_res.adb (Check_Discriminant_Use): Record relevant uses in new
+ field. Move warning emission to...
+ * sem_ch3.adb (Analyze_Full_Type_Declaration): ... Here.
+
+2025-06-06 Steve Baird <baird@adacore.com>
+
+ * sem_disp.adb
+ (Check_Dispatching_Operation): Delete code to generate
+ "missing overriding indicator" warning. Update comments.
+
+2025-06-06 Ronan Desplanques <desplanques@adacore.com>
+
+ * cstand.adb (Create_Standard): Delay declaration generation for
+ Natural and Positive.
+
+2025-06-06 Ronan Desplanques <desplanques@adacore.com>
+
+ * cstand.adb (Create_Standard): Remove useless calls.
+
+2025-06-06 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_aggr.adb (Expand_Record_Aggregate): Use the named form for the
+ second actual parameter in the call to Duplicate_Subexpr.
+ * exp_attr.adb (Expand_Size_Attribute): Likewise.
+ * exp_ch5.adb (Expand_Assign_Array): Likewise.
+ (Expand_Assign_Array_Bitfield): Likewise.
+ (Expand_Assign_Array_Bitfield_Fast): Likewise.
+ * exp_util.ads (Duplicate_Subexpr): Add New_Scope formal parameter.
+ (Duplicate_Subexpr_No_Checks): Likewise.
+ (Duplicate_Subexpr_Move_Checks): Likewise.
+ * exp_util.adb (Build_Allocate_Deallocate_Proc): Pass Proc_Id as the
+ actual for New_Scope in the calls to Duplicate_Subexpr_No_Checks.
+ (Duplicate_Subexpr): Add New_Scope formal parameter and forward it
+ in the call to New_Copy_Tree.
+ (Duplicate_Subexpr_No_Checks): Likewise.
+ (Duplicate_Subexpr_Move_Checks): Likewise.
+
+2025-06-06 Piotr Trojanek <trojanek@adacore.com>
+
+ * checks.adb (Insert_Valid_Check): Set flag Assignment_OK in the object
+ declaration inserted for the validity checks.
+
+2025-06-05 squirek <squirek@adacore.com>
+
+ * sem_warn.adb
+ (Warn_On_Useless_Assignment): Disable out value "overwritten" warning
+ when we are not warning on unread out parameters (e.g. "-gnatw.o").
+
+2025-06-05 Tonu Naks <naks@adacore.com>
+
+ * libgnat/i-cstrin.adb: null pointer check in Update
+
+2025-06-05 Arnaud Charlet <charlet@adacore.com>
+
+ * exp_util.adb, rtsfind.adb, rtsfind.ads, sem_prag.adb: Remove
+ references to RO_GH_Big_Integer and
+ Ada_Numerics_Big_Numbers_Big_Integers_Ghost.
+ * libgnat/a-strfix.adb, libgnat/a-strmap.adb,
+ libgnat/a-strsea.adb, libgnat/a-strsup.adb,
+ libgnat/i-c.ads, libgnat/i-c.adb, libgnat/s-aridou.adb,
+ libgnat/s-aridou.ads, libgnat/s-arit128.adb,
+ libgnat/s-arit128.ads, libgnat/s-arit32.adb,
+ libgnat/s-arit32.ads, libgnat/s-arit64.adb,
+ libgnat/s-arit64.ads, libgnat/s-casuti.adb,
+ libgnat/s-exnint.ads, libgnat/s-exnlli.ads,
+ libgnat/s-exnllli.ads, libgnat/s-expint.ads,
+ libgnat/s-explli.ads, libgnat/s-expllli.ads,
+ libgnat/s-explllu.ads, libgnat/s-expllu.ads,
+ libgnat/s-expmod.adb, libgnat/s-expmod.ads,
+ libgnat/s-exponn.adb, libgnat/s-exponn.ads,
+ libgnat/s-expont.adb, libgnat/s-expont.ads,
+ libgnat/s-exponu.adb, libgnat/s-exponu.ads,
+ libgnat/s-imaged.ads, libgnat/s-imaged.adb,
+ libgnat/s-expuns.ads, libgnat/s-imagef.ads,
+ libgnat/s-imagef.adb, libgnat/s-imagei.adb,
+ libgnat/s-imagei.ads, libgnat/s-imageu.adb,
+ libgnat/s-imageu.ads, libgnat/s-imgboo.adb,
+ libgnat/s-imde128.ads, libgnat/s-imde32.ads,
+ libgnat/s-imde64.ads, libgnat/s-imfi128.ads,
+ libgnat/s-imfi32.ads, libgnat/s-imfi64.ads,
+ libgnat/s-imgboo.ads, libgnat/s-imgint.ads,
+ libgnat/s-imglli.ads, libgnat/s-imgllli.ads,
+ libgnat/s-imglllu.ads, libgnat/s-imgllu.ads,
+ libgnat/s-imguns.ads, libgnat/s-valboo.adb,
+ libgnat/s-valboo.ads, libgnat/s-valint.ads,
+ libgnat/s-vallli.ads, libgnat/s-valllli.ads,
+ libgnat/s-vallllu.ads, libgnat/s-valllu.ads,
+ libgnat/s-valuns.ads, libgnat/s-valuti.adb,
+ libgnat/s-valuti.ads, libgnat/s-valuei.adb,
+ libgnat/s-valuei.ads, libgnat/s-valueu.ads,
+ libgnat/s-valueu.adb, libgnat/s-veboop.adb,
+ libgnat/s-veboop.ads, libgnat/s-widint.ads,
+ libgnat/s-widlli.ads, libgnat/s-widllli.ads,
+ libgnat/s-widlllu.ads, libgnat/s-widllu.ads,
+ libgnat/s-widthi.adb, libgnat/s-widthu.adb,
+ libgnat/s-widthu.ads, libgnat/s-widuns.ads: Remove ghost code
+ and SPARK annotations.
+ * libgnat/a-nbnbig.ads, libgnat/a-nbnbig.adb,
+ libgnat/s-spark.ads, libgnat/s-spcuop.adb,
+ libgnat/s-spcuop.ads, libgnat/s-vaispe.adb,
+ libgnat/s-vaispe.ads, libgnat/s-vauspe.adb,
+ libgnat/s-vauspe.ads, libgnat/s-vs_int.ads,
+ libgnat/s-vs_lli.ads, libgnat/s-vs_llu.ads,
+ libgnat/s-vs_uns.ads, libgnat/s-valspe.adb,
+ libgnat/s-valspe.ads, libgnat/s-vsllli.ads,
+ libgnat/s-vslllu.ads: Removed.
+ * Makefile.rtl: Update list of runtime units.
+ * gcc-interface/Make-lang.in: Remove object files.
+
+2025-06-05 Ronan Desplanques <desplanques@adacore.com>
+
+ * fname-uf.adb: Fix documentation comment.
+ (Get_Default_File_Name): Fix indices of default patterns.
+
+2025-06-05 Ronan Desplanques <desplanques@adacore.com>
+
+ * atree.ads (New_Copy, Relocate_Node): Tweak documentation comments.
+
+2025-06-05 Andres Toom <toom@adacore.com>
+
+ * libgnat/a-nudira.ads: Activate SPARK mode and add missing
+ basic contracts. Mark the unit as always terminating.
+ * libgnat/a-nuflra.ads: Idem.
+
+2025-06-05 Javier Miranda <miranda@adacore.com>
+
+ * exp_ch7.adb (Process_Object_Declaration): Avoid generating
+ duplicate names for master nodes.
+
+2025-06-05 Ronan Desplanques <desplanques@adacore.com>
+
+ * opt.ads: Remove useless variable.
+ * sem_ch9.adb (Analyze_Abort_Statement, Analyze_Accept_Alternative,
+ Analyze_Accept_Statement, Analyze_Asynchronous_Select,
+ Analyze_Conditional_Entry_Call, Analyze_Delay_Alternative,
+ Analyze_Delay_Relative, Analyze_Delay_Until, Analyze_Entry_Body,
+ Analyze_Entry_Body_Formal_Part, Analyze_Entry_Call_Alternative,
+ Analyze_Entry_Declaration, Analyze_Entry_Index_Specification,
+ Analyze_Protected_Body, Analyze_Protected_Definition,
+ Analyze_Protected_Type_Declaration, Analyze_Requeue,
+ Analyze_Selective_Accept, Analyze_Single_Protected_Declaration,
+ Analyze_Single_Task_Declaration, Analyze_Task_Body,
+ Analyze_Task_Definition, Analyze_Task_Type_Declaration,
+ Analyze_Terminate_Alternative, Analyze_Timed_Entry_Call,
+ Analyze_Triggering_Alternative): Remove useless assignments.
+
+2025-06-05 Steve Baird <baird@adacore.com>
+
+ * sem_util.adb
+ (Side_Effect_Free_Statements): Return False if the statement list
+ includes an explicit (i.e. Comes_From_Source) raise statement.
+
+2025-06-05 Javier Miranda <miranda@adacore.com>
+
+ * sem_ch6.adb (Analyze_Expression_Function): Add missing check
+ on premature use of incomplete type.
+
+2025-06-05 Aleksandra Pasek <pasek@adacore.com>
+
+ * libgnat/s-arit32.adb: Add Ghost aspect to Lo.
+
+2025-06-05 Ronan Desplanques <desplanques@adacore.com>
+
+ * exp_ch4.adb (Tagged_Membership): Fix for protected types.
+
+2025-06-05 Bob Duff <duff@adacore.com>
+
+ * sem_eval.adb (Fold_Shift): If the Amount parameter is greater
+ than the size in bits, use the size. For example, if we are
+ shifting an Unsigned_8 value, then Amount => 1_000_001 gives the
+ same result as Amount => 8. This change avoids computing the value
+ of 2**1_000_000, which takes too long and uses too much memory.
+ Note that the computation we're talking about is a compile-time
+ computation. Minor cleanup. DRY.
+ * sem_eval.ads (Fold_Str, Fold_Uint, Fold_Ureal): Fold the
+ comments into one comment, because DRY. Remove useless
+ verbiage.
+
+2025-06-05 Ronan Desplanques <desplanques@adacore.com>
+
+ * exp_attr.adb (Interunit_Ref_OK): Tweak categorization of compilation
+ units.
+
+2025-06-05 Aleksandra Pasek <pasek@adacore.com>
+
+ * libgnat/s-aridou.adb: Add missing Ghost aspect to
+ Lemma_Not_In_Range_Big2xx64.
+
+2025-06-05 Ronan Desplanques <desplanques@adacore.com>
+
+ * libgnat/s-trasym__dwarf.adb (Init_Module): Add mitigation.
+
+2025-06-05 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_aggr.adb (Build_Two_Pass_Aggr_Code): New function containing
+ most of the code initially present in Two_Pass_Aggregate_Expansion.
+ (Two_Pass_Aggregate_Expansion): Remove redundant N parameter.
+ Implement built-in-place expansion for (static) object declarations
+ and allocators, using Build_Two_Pass_Aggr_Code for the main work.
+ (Expand_Array_Aggregate): Adjust Two_Pass_Aggregate_Expansion call.
+ Replace Etype (N) by Typ in a couple of places.
+ * exp_ch3.adb (Expand_Freeze_Array_Type): Remove special case for
+ two-pass array aggregates.
+ (Expand_N_Object_Declaration): Do not adjust the object when it is
+ initialized by a two-pass array aggregate.
+ * exp_ch4.adb (Expand_Allocator_Expression): Apply the processing
+ used for container aggregates to two-pass array aggregates.
+ * exp_ch6.adb (Validate_Subprogram_Calls): Skip calls present in
+ initialization expressions of N_Object_Declaration nodes that have
+ No_Initialization set.
+ * sem_ch3.adb (Analyze_Object_Declaration): Detect the cases of an
+ array originally initialized by an aggregate consistently.
+
+2025-06-05 Johannes Kliemann <kliemann@adacore.com>
+
+ * libgnat/s-arit32.adb (Lemma_Not_In_Range_Big2xx32): Add missing
+ Ghost aspect.
+
+2025-06-05 Ronan Desplanques <desplanques@adacore.com>
+
+ * generate_minimal_reproducer.adb (Generate_Minimal_Reproducer): Fix
+ handling of preprocessing dependencies.
+
+2025-06-05 Viljar Indus <indus@adacore.com>
+
+ * doc/gnat_rm/implementation_defined_attributes.rst: Update the
+ documentation for Valid_Value.
+ * sem_attr.adb (Analyze_Attribute): Reject types where
+ the root type originates from Standard.
+ * gnat_rm.texi: Regenerate.
+ * gnat_ugn.texi: Regenerate.
+
+2025-06-05 Gary Dismukes <dismukes@adacore.com>
+
+ * exp_aggr.adb (Two_Pass_Aggregate_Expansion): Change call to Make_Assignment
+ for the indexed aggregate object to call Change_Make_OK_Assignment instead.
+
+2025-06-05 Steve Baird <baird@adacore.com>
+
+ * sem_prag.adb
+ (Analyze_Constituent): In the specific case case of a defined-too-late
+ abstract state constituent, generate an additional error message.
+
+2025-06-05 Viljar Indus <indus@adacore.com>
+
+ * diagnostics-sarif_emitter.adb (Print_Invocations): fix
+ commandLine and executionSuccessful nodes.
+ Fix typo in the name for startLine.
+ * osint.adb (Modified Get_Current_Dir) Fix generation of
+ the current directory.
+ (Relative_Path): Avoid relative paths starting with a
+ path separator.
+ * osint.ads: Update the documentation for Relative_Path.
+
+2025-06-05 Ronan Desplanques <desplanques@adacore.com>
+
+ * libgnat/i-cstrin.adb (New_String): Fix size of allocation.
+
+2025-06-05 squirek <squirek@adacore.com>
+
+ * sem_ch8.adb (Analyze_Package_Name): Add code to expand use
+ clauses such that they have an implicit with associated with them
+ when extensions are enabled.
+ * sem_ch10.ads (Analyze_With_Clause): New.
+ * sem_ch10.adb (Analyze_With_Clause): Add comes from source check
+ for warning.
+ (Expand_With_Clause): Moved to the spec.
+ * sem_util.adb, sem_util.ads
+ (Is_In_Context_Clause): Moved from sem_prag.
+ * sem_prag.adb (Analyze_Pragma): Update calls to
+ Is_In_Context_Clause.
+ (Is_In_Context_Clause): Moved to sem_util.
+
+2025-06-05 Piotr Trojanek <trojanek@adacore.com>
+
+ * doc/gnat_ugn/platform_specific_information.rst
+ (Setting Stack Size from gnatlink): Improve documentation.
+ * gnat-style.texi: Regenerate.
+ * gnat_rm.texi: Regenerate.
+ * gnat_ugn.texi: Regenerate.
+
+2025-06-05 squirek <squirek@adacore.com>
+
+ * accessibility.adb (Check_Return_Construct_Accessibility):
+ Disable check generation when we are only checking semantics.
+ * opt.ads: Add new flag for -gnatc mode
+ * switch-c.adb (Scan_Front_End_Switches): Set flag for -gnatc mode
+
+2025-06-05 Viljar Indus <indus@adacore.com>
+
+ * sem_ch8.adb (Mark_Use_Type): Additionally mark the types
+ of the parameters and return values as used when analyzing an
+ operator.
+
+2025-06-05 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_ch9.adb (Build_Dispatching_Requeue): Take 'Tag of the
+ concurrent object instead of doing an unchecked conversion.
+ * exp_pakd.adb (Expand_Packed_Address_Reference): Perform address
+ arithmetic using an operator of System.Storage_Elements.
+
+2025-06-05 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_ch6.adb (Expand_Actuals): Remove obsolete comment.
+ (Make_Build_In_Place_Call_In_Anonymous_Context): Always use a proper
+ object declaration initialized with the function call in the cases
+ where a temporary is needed, with Assignment_OK set on it.
+ * sem_util.adb (Entity_Of): Deal with rewritten function call first.
+
+2025-06-05 Ronan Desplanques <desplanques@adacore.com>
+
+ * libgnat/i-cstrin.adb (Position_Of_Nul): Change specification and
+ adjust body accordingly.
+ (New_Char_Array): Fix size of allocation.
+ (To_Chars_Ptr): Adapt to Position_Of_Nul change.
+
+2025-06-05 Ronan Desplanques <desplanques@adacore.com>
+
+ * generate_minimal_reproducer.adb (Generate_Minimal_Reproducer): Fix
+ oracle generation.
+
+2025-06-05 Ronan Desplanques <desplanques@adacore.com>
+
+ * generate_minimal_reproducer.adb (Generate_Minimal_Reproducer):
+ Fix when main library item is an instantiation.
+
+2025-06-05 Steve Baird <baird@adacore.com>
+
+ * exp_attr.adb (Expand_N_Attribute_Reference): When accessing the
+ maps declared in package Cached_Attribute_Ops, the key value
+ passed to Get or to Set should never be the entity node for a
+ subtype. Use the entity of the corresponding type declaration
+ instead.
+
+2025-06-05 Viljar Indus <indus@adacore.com>
+
+ * sem_res.adb (Resolve_Declare_Expression): Mark used
+ local variables inside a declare expression as referenced.
+
+2025-06-05 Javier Miranda <miranda@adacore.com>
+
+ * sem.ads: Update reference to renamed subprogram in documentation.
+ * sem_ch3.ads (Preanalyze_Assert_Expression): Renamed.
+ (Preanalyze_Spec_Expression): Renamed.
+ * sem_ch3.adb (Preanalyze_Assert_Expression): Renamed and code cleanup.
+ (Preanalyze_Spec_Expression): Renamed.
+ (Preanalyze_Default_Expression): Renamed.
+ * contracts.adb: Update calls to renamed subprograms.
+ * exp_pakd.adb: Ditto.
+ * exp_util.adb: Ditto.
+ * freeze.adb: Ditto.
+ * sem_ch12.adb: Ditto.
+ * sem_ch13.adb: Ditto.
+ * sem_ch6.adb: Ditto.
+ * sem_prag.adb: Ditto.
+ * sem_res.adb (Preanalyze_And_Resolve): Add to the version without
+ context type the special handling for GNATprove mode provided by
+ the version with context type; required to cleanup the body of
+ Preanalyze_Assert_Expression.
+
+2025-06-05 squirek <squirek@adacore.com>
+
+ * accessibility.adb
+ (Check_Return_Construct_Accessibility): Disable check generation
+ when we are only checking semantics.
+
+2025-06-05 Viljar Indus <indus@adacore.com>
+
+ * diagnostics-json_utils.adb: Add new method To_File_Uri to
+ convert any path to the URI standard.
+ * diagnostics-json_utils.ads: Likewise.
+ * diagnostics-sarif_emitter.adb: Converted Artifact_Change
+ types to use the Source_File_Index instead of the file name
+ to store the source file.
+ Removed the body from Destroy (Elem : in out Artifact_Change)
+ since it no longer contained elements with dynamic memory.
+ Updated the implementation of Equals (L, R : Artifact_Change)
+ to take into account the changes for Artifact_Change.
+ Print_Artifact_Location: Use the Source_File_Index as an
+ input argument. Now prints the uriBaseId attribute and a
+ relative path from the uriBaseId to the file in question as
+ the value of the uri attribute.
+ New method Print_Original_Uri_Base_Ids to print the
+ originalUriBaseIds node.
+ Print_Run no prints the originalUriBaseIds node.
+ Use constants instead of strings for all the SARIF attributes.
+ * osint.adb: Add new method Relative_Path to calculate the
+ relative path from a base directory.
+ Add new method Root to calculate the root of each directory.
+ Add new method Get_Current_Dir to get the current working
+ directory for the execution environment.
+ * osint.ads: Likewise.
+ * clean.adb: Use full names for calls to Get_Current_Dir.
+ * gnatls.adb: Likewise.
+
+2025-06-05 Steve Baird <baird@adacore.com>
+
+ * sem_res.adb
+ (Set_Mixed_Mode_Operand): If we are about to call Resolve
+ passing in Any_Fixed as the expected type, then instead pass in
+ the fixed point type of the other operand (i.e., B_Typ).
+
+2025-06-05 Gary Dismukes <dismukes@adacore.com>
+
+ * sem_util.adb (Check_Function_Writable_Actuals): Add handling for
+ N_Iterated_Component_Association and N_Iterated_Element_Association.
+ Fix a typo in an RM reference (6.4.1(20/3) => 6.4.1(6.20/3)).
+ (Collect_Expression_Ids): New procedure factoring code for collecting
+ identifiers from expressions of aggregate associations.
+ (Handle_Association_Choices): New procedure factoring code for handling
+ id collection for expressions of aggregate associations with multiple
+ choices. Removed redundant test of Box_Present from original code.
+
+2025-05-24 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/Make-lang.in (ACATSDIR): Use acats-2 directory.
+
+2025-05-13 Nicolas Boulenguez <nicolas@debian.org>
+
+ PR ada/87778
+ * Make-generated.in: Remove -q gnatmake option.
+ * gcc-interface/Makefile.in: Likewise.
+
2025-05-05 Eric Botcazou <ebotcazou@adacore.com>
PR ada/120104
diff --git a/gcc/ada/Make-generated.in b/gcc/ada/Make-generated.in
index 95c2a1d..4d42eef 100644
--- a/gcc/ada/Make-generated.in
+++ b/gcc/ada/Make-generated.in
@@ -1,14 +1,6 @@
-# Dependencies for compiler sources that are generated at build time
-
-# Note: can't use ?= here, not supported by older versions of GNU Make
+GNATMAKE_FOR_BUILD = gnatmake
-ifeq ($(origin CP), undefined)
-CP=cp
-endif
-
-ifeq ($(origin MKDIR), undefined)
-MKDIR=mkdir -p
-endif
+# Dependencies for compiler sources that are generated at build time
fsrcdir := $(shell cd $(srcdir);${PWD_COMMAND})
@@ -18,7 +10,7 @@ GEN_IL_FLAGS = -gnata -gnat2012 -gnatw.g -gnatyg -gnatU $(GEN_IL_INCLUDES)
ada/seinfo_tables.ads ada/seinfo_tables.adb ada/sinfo.h ada/einfo.h ada/nmake.ads ada/nmake.adb ada/seinfo.ads ada/sinfo-nodes.ads ada/sinfo-nodes.adb ada/einfo-entities.ads ada/einfo-entities.adb: ada/stamp-gen_il ; @true
ada/stamp-gen_il: $(fsrcdir)/ada/gen_il*
$(MKDIR) ada/gen_il
- cd ada/gen_il; gnatmake -q -g $(GEN_IL_FLAGS) gen_il-main
+ cd ada/gen_il; $(GNATMAKE_FOR_BUILD) $(GEN_IL_FLAGS) gen_il-main
# Ignore errors to work around finalization issues in older compilers
- cd ada/gen_il; ./gen_il-main
$(fsrcdir)/../move-if-change ada/gen_il/seinfo_tables.ads ada/seinfo_tables.ads
@@ -39,14 +31,14 @@ ada/stamp-gen_il: $(fsrcdir)/ada/gen_il*
# would cause bootstrapping with older compilers to fail. You can call it by
# hand, as a sanity check that these files are legal.
ada/seinfo_tables.o: ada/seinfo_tables.ads ada/seinfo_tables.adb
- cd ada ; gnatmake $(GEN_IL_INCLUDES) seinfo_tables.adb -gnatU -gnatX
+ cd ada ; $(GNATMAKE_FOR_BUILD) $(GEN_IL_INCLUDES) seinfo_tables.adb -gnatX
ada/snames.h ada/snames.ads ada/snames.adb : ada/stamp-snames ; @true
ada/stamp-snames : ada/snames.ads-tmpl ada/snames.adb-tmpl ada/snames.h-tmpl ada/xsnamest.adb ada/xutil.ads ada/xutil.adb
-$(MKDIR) ada/bldtools/snamest
$(RM) $(addprefix ada/bldtools/snamest/,$(notdir $^))
$(CP) $^ ada/bldtools/snamest
- cd ada/bldtools/snamest && gnatmake -q xsnamest && ./xsnamest
+ cd ada/bldtools/snamest && $(GNATMAKE_FOR_BUILD) xsnamest && ./xsnamest
$(fsrcdir)/../move-if-change ada/bldtools/snamest/snames.ns ada/snames.ads
$(fsrcdir)/../move-if-change ada/bldtools/snamest/snames.nb ada/snames.adb
$(fsrcdir)/../move-if-change ada/bldtools/snamest/snames.nh ada/snames.h
diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl
index cb41e68..8f925fc 100644
--- a/gcc/ada/Makefile.rtl
+++ b/gcc/ada/Makefile.rtl
@@ -211,7 +211,6 @@ GNATRTL_NONTASKING_OBJS= \
a-nallfl$(objext) \
a-nalofl$(objext) \
a-nashfl$(objext) \
- a-nbnbig$(objext) \
a-nbnbin$(objext) \
a-nbnbre$(objext) \
a-ncelfu$(objext) \
@@ -545,6 +544,7 @@ GNATRTL_NONTASKING_OBJS= \
s-caun16$(objext) \
s-caun32$(objext) \
s-caun64$(objext) \
+ s-cautns$(objext) \
s-chepoo$(objext) \
s-commun$(objext) \
s-conca2$(objext) \
@@ -745,8 +745,6 @@ GNATRTL_NONTASKING_OBJS= \
s-shasto$(objext) \
s-soflin$(objext) \
s-soliin$(objext) \
- s-spark$(objext) \
- s-spcuop$(objext) \
s-spsufi$(objext) \
s-stache$(objext) \
s-stalib$(objext) \
@@ -772,7 +770,6 @@ GNATRTL_NONTASKING_OBJS= \
s-vaenu8$(objext) \
s-vafi32$(objext) \
s-vafi64$(objext) \
- s-vaispe$(objext) \
s-valboo$(objext) \
s-valcha$(objext) \
s-valflt$(objext) \
@@ -782,7 +779,6 @@ GNATRTL_NONTASKING_OBJS= \
s-vallli$(objext) \
s-valllu$(objext) \
s-valrea$(objext) \
- s-valspe$(objext) \
s-valued$(objext) \
s-valuef$(objext) \
s-valuei$(objext) \
@@ -792,14 +788,9 @@ GNATRTL_NONTASKING_OBJS= \
s-valuns$(objext) \
s-valuti$(objext) \
s-valwch$(objext) \
- s-vauspe$(objext) \
s-veboop$(objext) \
s-vector$(objext) \
s-vercon$(objext) \
- s-vs_int$(objext) \
- s-vs_lli$(objext) \
- s-vs_llu$(objext) \
- s-vs_uns$(objext) \
s-wchcnv$(objext) \
s-wchcon$(objext) \
s-wchjis$(objext) \
@@ -1046,8 +1037,6 @@ GNATRTL_128BIT_OBJS = \
s-vafi128$(objext) \
s-valllli$(objext) \
s-vallllu$(objext) \
- s-vsllli$(objext) \
- s-vslllu$(objext) \
s-widllli$(objext) \
s-widlllu$(objext)
@@ -1419,24 +1408,32 @@ ifeq ($(SELECTED_PAIRS),PAIRS_NONE)
ifeq ($(strip $(filter-out arm% aarch64 linux-android%,$(target_cpu) $(target_os))),)
LIBGNAT_TARGET_PAIRS = \
+ a-exetim.adb<libgnarl/a-exetim__posix.adb \
+ a-exetim.ads<libgnarl/a-exetim__default.ads \
a-intnam.ads<libgnarl/a-intnam__linux.ads \
+ a-nallfl.ads<libgnat/a-nallfl__wraplf.ads \
+ a-synbar.adb<libgnarl/a-synbar__posix.adb \
+ a-synbar.ads<libgnarl/a-synbar__posix.ads \
+ s-dorepr.adb<libgnat/s-dorepr__fma.adb \
s-inmaop.adb<libgnarl/s-inmaop__posix.adb \
s-intman.adb<libgnarl/s-intman__android.adb \
- s-osinte.adb<libgnarl/s-osinte__android.adb \
s-osinte.ads<libgnarl/s-osinte__android.ads \
+ s-osinte.adb<libgnarl/s-osinte__android.adb \
s-oslock.ads<libgnat/s-oslock__posix.ads \
s-osprim.adb<libgnat/s-osprim__posix.adb \
- s-taprop.adb<libgnarl/s-taprop__posix.adb \
+ s-parame.adb<libgnat/s-parame__aarch64-linux.adb \
+ s-taprop.adb<libgnarl/s-taprop__linux.adb \
+ s-tasinf.ads<libgnarl/s-tasinf__linux.ads \
+ s-tasinf.adb<libgnarl/s-tasinf__linux.adb \
+ s-tpopsp.adb<libgnarl/s-tpopsp__tls.adb \
s-taspri.ads<libgnarl/s-taspri__posix.ads \
- s-tpopsp.adb<libgnarl/s-tpopsp__posix-foreign.adb \
- a-nallfl.ads<libgnat/a-nallfl__wraplf.ads \
$(ATOMICS_TARGET_PAIRS) \
$(ATOMICS_BUILTINS_TARGET_PAIRS) \
system.ads<libgnat/system-linux-arm.ads
TOOLS_TARGET_PAIRS = indepsw.adb<indepsw-gnu.adb
- EXTRA_GNATRTL_TASKING_OBJS=s-linux.o
+ EXTRA_GNATRTL_TASKING_OBJS=s-linux.o a-exetim.o
# ARM and aarch64 rely on different unwinding mechanisms, and as
# a 64bit target, aarch64 can also incorporate support for 128bit
@@ -3246,8 +3243,92 @@ ADA_EXCLUDE_SRCS =\
i-vxwoio.adb i-vxwoio.ads i-vxwork.ads \
s-linux.ads s-vxwext.adb s-vxwext.ads s-win32.ads s-winext.ads \
s-stchop.ads s-stchop.adb \
- s-strcom.adb s-strcom.ads s-thread.ads \
+ s-strcom.ads s-strcom.adb \
+ s-thread.ads \
s-qnx.ads \
+ s-arit128.ads s-arit128.adb \
+ s-casi128.ads s-casi128.adb \
+ s-caun128.ads s-caun128.adb \
+ s-exnllli.ads \
+ s-expllli.ads \
+ s-explllu.ads \
+ s-fode128.ads \
+ s-fofi128.ads \
+ s-imde128.ads \
+ s-imfi128.ads \
+ s-imglllb.ads \
+ s-imgllli.ads \
+ s-imglllu.ads \
+ s-imglllw.ads \
+ s-pack65.ads s-pack65.adb \
+ s-pack66.ads s-pack66.adb \
+ s-pack67.ads s-pack67.adb \
+ s-pack68.ads s-pack68.adb \
+ s-pack69.ads s-pack69.adb \
+ s-pack70.ads s-pack70.adb \
+ s-pack71.ads s-pack71.adb \
+ s-pack72.ads s-pack72.adb \
+ s-pack73.ads s-pack73.adb \
+ s-pack74.ads s-pack74.adb \
+ s-pack75.ads s-pack75.adb \
+ s-pack76.ads s-pack76.adb \
+ s-pack77.ads s-pack77.adb \
+ s-pack78.ads s-pack78.adb \
+ s-pack79.ads s-pack79.adb \
+ s-pack80.ads s-pack80.adb \
+ s-pack81.ads s-pack81.adb \
+ s-pack82.ads s-pack82.adb \
+ s-pack83.ads s-pack83.adb \
+ s-pack84.ads s-pack84.adb \
+ s-pack85.ads s-pack85.adb \
+ s-pack86.ads s-pack86.adb \
+ s-pack87.ads s-pack87.adb \
+ s-pack88.ads s-pack88.adb \
+ s-pack89.ads s-pack89.adb \
+ s-pack90.ads s-pack90.adb \
+ s-pack91.ads s-pack91.adb \
+ s-pack92.ads s-pack92.adb \
+ s-pack93.ads s-pack93.adb \
+ s-pack94.ads s-pack94.adb \
+ s-pack95.ads s-pack95.adb \
+ s-pack96.ads s-pack96.adb \
+ s-pack97.ads s-pack97.adb \
+ s-pack98.ads s-pack98.adb \
+ s-pack99.ads s-pack99.adb \
+ s-pack100.ads s-pack100.adb \
+ s-pack101.ads s-pack101.adb \
+ s-pack102.ads s-pack102.adb \
+ s-pack103.ads s-pack103.adb \
+ s-pack104.ads s-pack104.adb \
+ s-pack105.ads s-pack105.adb \
+ s-pack106.ads s-pack106.adb \
+ s-pack107.ads s-pack107.adb \
+ s-pack108.ads s-pack108.adb \
+ s-pack109.ads s-pack109.adb \
+ s-pack110.ads s-pack110.adb \
+ s-pack111.ads s-pack111.adb \
+ s-pack112.ads s-pack112.adb \
+ s-pack113.ads s-pack113.adb \
+ s-pack114.ads s-pack114.adb \
+ s-pack115.ads s-pack115.adb \
+ s-pack116.ads s-pack116.adb \
+ s-pack117.ads s-pack117.adb \
+ s-pack118.ads s-pack118.adb \
+ s-pack119.ads s-pack119.adb \
+ s-pack120.ads s-pack120.adb \
+ s-pack121.ads s-pack121.adb \
+ s-pack122.ads s-pack122.adb \
+ s-pack123.ads s-pack123.adb \
+ s-pack124.ads s-pack124.adb \
+ s-pack125.ads s-pack125.adb \
+ s-pack126.ads s-pack126.adb \
+ s-pack127.ads s-pack127.adb \
+ s-vade128.ads \
+ s-vafi128.ads \
+ s-valllli.ads \
+ s-vallllu.ads \
+ s-widllli.ads \
+ s-widlllu.ads
# ADA_EXCLUDE_SRCS without the sources used by the target
ADA_EXCLUDE_FILES=$(filter-out \
diff --git a/gcc/ada/accessibility.adb b/gcc/ada/accessibility.adb
index 8c85173..0b8d3f7 100644
--- a/gcc/ada/accessibility.adb
+++ b/gcc/ada/accessibility.adb
@@ -1642,6 +1642,13 @@ package body Accessibility is
(No (Extra_Accessibility_Of_Result (Scope_Id))
and then Is_Formal_Of_Current_Function (Assoc_Expr)
and then Is_Tagged_Type (Etype (Scope_Id)))
+
+ -- Disable the check generation when we are only checking semantics
+ -- since required locals do not get generated (e.g. extra
+ -- accessibility of result), and constant folding can occur and
+ -- lead to spurious errors.
+
+ and then not Check_Semantics_Only_Mode
then
-- Generate a dynamic check based on the extra accessibility of
-- the result or the scope of the current function.
@@ -1684,8 +1691,8 @@ package body Accessibility is
and then Entity (Check_Cond) = Standard_True
then
Error_Msg_N
- ("access discriminant in return object would be a dangling"
- & " reference", Return_Stmt);
+ ("access discriminant in return object could be a dangling"
+ & " reference??", Return_Stmt);
end if;
end if;
diff --git a/gcc/ada/ada_get_targ.adb b/gcc/ada/ada_get_targ.adb
index 72e5452..853197a 100644
--- a/gcc/ada/ada_get_targ.adb
+++ b/gcc/ada/ada_get_targ.adb
@@ -219,9 +219,14 @@ package body Get_Targ is
begin
Float_Str (Float_Str'First .. Float_Str'First + 4) := "float";
Call_Back
- (C_Name => Float_Str, Digs => 6, Complex => False, Count => 0,
+ (C_Name => Float_Str,
+ Digs => 6,
+ Complex => False,
+ Count => 0,
Float_Rep => IEEE_Binary,
- Precision => 32, Size => 32, Alignment => 32);
+ Precision => 32,
+ Size => 32,
+ Alignment => 32);
Double_Str (Double_Str'First .. Double_Str'First + 5) := "double";
Call_Back
diff --git a/gcc/ada/adaint.c b/gcc/ada/adaint.c
index 1fcfae1..adc3951 100644
--- a/gcc/ada/adaint.c
+++ b/gcc/ada/adaint.c
@@ -61,6 +61,11 @@
#define POSIX
#include "vxWorks.h"
#include <sys/time.h>
+#include <ctype.h> /* for isalpha */
+
+#ifndef alloca
+#define alloca(n) __builtin_alloca(n)
+#endif
#if defined (__mips_vxworks)
#include "cacheLib.h"
@@ -3475,7 +3480,7 @@ __gnat_lwp_self (void)
}
#endif
-#if defined (__linux__)
+#if defined (__linux__) || defined (__ANDROID__)
#include <sched.h>
/* glibc versions earlier than 2.7 do not define the routines to handle
diff --git a/gcc/ada/ali.ads b/gcc/ada/ali.ads
index 2f90b88..da71c51 100644
--- a/gcc/ada/ali.ads
+++ b/gcc/ada/ali.ads
@@ -358,8 +358,8 @@ package ALI is
-- Indicates presence of PR parameter for a preelaborated package
No_Elab : Boolean;
- -- Indicates presence of NE parameter for a unit that has does not
- -- have an elaboration routine (since it has no elaboration code).
+ -- Indicates presence of NE parameter for a unit that does not have an
+ -- elaboration routine (since it has no elaboration code).
Pure : Boolean;
-- Indicates presence of PU parameter for a package having pragma Pure
diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads
index 70ea120..5e61450 100644
--- a/gcc/ada/aspects.ads
+++ b/gcc/ada/aspects.ads
@@ -81,6 +81,7 @@ package Aspects is
Aspect_Bit_Order,
Aspect_Component_Size,
Aspect_Constant_Indexing,
+ Aspect_Constructor, -- GNAT
Aspect_Contract_Cases, -- GNAT
Aspect_Convention,
Aspect_CPU,
@@ -106,6 +107,7 @@ package Aspects is
Aspect_GNAT_Annotate, -- GNAT
Aspect_Implicit_Dereference,
Aspect_Initial_Condition, -- GNAT
+ Aspect_Initialize, -- GNAT
Aspect_Initializes, -- GNAT
Aspect_Input,
Aspect_Integer_Literal,
@@ -130,6 +132,7 @@ package Aspects is
Aspect_Predicate, -- GNAT
Aspect_Predicate_Failure,
Aspect_Priority,
+ Aspect_Program_Exit,
Aspect_Put_Image,
Aspect_Read,
Aspect_Real_Literal,
@@ -428,6 +431,7 @@ package Aspects is
Aspect_Bit_Order => Expression,
Aspect_Component_Size => Expression,
Aspect_Constant_Indexing => Name,
+ Aspect_Constructor => Name,
Aspect_Contract_Cases => Expression,
Aspect_Convention => Name,
Aspect_CPU => Expression,
@@ -453,6 +457,7 @@ package Aspects is
Aspect_GNAT_Annotate => Expression,
Aspect_Implicit_Dereference => Name,
Aspect_Initial_Condition => Expression,
+ Aspect_Initialize => Expression,
Aspect_Initializes => Expression,
Aspect_Input => Name,
Aspect_Integer_Literal => Name,
@@ -477,6 +482,7 @@ package Aspects is
Aspect_Predicate => Expression,
Aspect_Predicate_Failure => Expression,
Aspect_Priority => Expression,
+ Aspect_Program_Exit => Optional_Expression,
Aspect_Put_Image => Name,
Aspect_Read => Name,
Aspect_Real_Literal => Name,
@@ -529,6 +535,7 @@ package Aspects is
Aspect_Component_Size => True,
Aspect_Constant_Indexing => False,
Aspect_Contract_Cases => False,
+ Aspect_Constructor => False,
Aspect_Convention => True,
Aspect_CPU => False,
Aspect_Default_Component_Value => True,
@@ -556,6 +563,7 @@ package Aspects is
Aspect_GNAT_Annotate => False,
Aspect_Implicit_Dereference => False,
Aspect_Initial_Condition => False,
+ Aspect_Initialize => False,
Aspect_Initializes => False,
Aspect_Input => False,
Aspect_Integer_Literal => False,
@@ -580,6 +588,7 @@ package Aspects is
Aspect_Predicate => False,
Aspect_Predicate_Failure => False,
Aspect_Priority => False,
+ Aspect_Program_Exit => False,
Aspect_Put_Image => False,
Aspect_Read => False,
Aspect_Real_Literal => False,
@@ -698,6 +707,7 @@ package Aspects is
Aspect_Constant_After_Elaboration => Name_Constant_After_Elaboration,
Aspect_Constant_Indexing => Name_Constant_Indexing,
Aspect_Contract_Cases => Name_Contract_Cases,
+ Aspect_Constructor => Name_Constructor,
Aspect_Convention => Name_Convention,
Aspect_CPU => Name_CPU,
Aspect_CUDA_Device => Name_CUDA_Device,
@@ -742,6 +752,7 @@ package Aspects is
Aspect_Inline => Name_Inline,
Aspect_Inline_Always => Name_Inline_Always,
Aspect_Initial_Condition => Name_Initial_Condition,
+ Aspect_Initialize => Name_Initialize,
Aspect_Initializes => Name_Initializes,
Aspect_Input => Name_Input,
Aspect_Integer_Literal => Name_Integer_Literal,
@@ -780,6 +791,7 @@ package Aspects is
Aspect_Preelaborable_Initialization => Name_Preelaborable_Initialization,
Aspect_Preelaborate => Name_Preelaborate,
Aspect_Priority => Name_Priority,
+ Aspect_Program_Exit => Name_Program_Exit,
Aspect_Pure => Name_Pure,
Aspect_Pure_Function => Name_Pure_Function,
Aspect_Put_Image => Name_Put_Image,
@@ -965,6 +977,7 @@ package Aspects is
Aspect_Asynchronous => Always_Delay,
Aspect_Attach_Handler => Always_Delay,
Aspect_Constant_Indexing => Always_Delay,
+ Aspect_Constructor => Always_Delay,
Aspect_CPU => Always_Delay,
Aspect_CUDA_Device => Always_Delay,
Aspect_CUDA_Global => Always_Delay,
@@ -1009,6 +1022,7 @@ package Aspects is
Aspect_Preelaborable_Initialization => Always_Delay,
Aspect_Preelaborate => Always_Delay,
Aspect_Priority => Always_Delay,
+ Aspect_Program_Exit => Always_Delay,
Aspect_Pure => Always_Delay,
Aspect_Pure_Function => Always_Delay,
Aspect_Put_Image => Always_Delay,
@@ -1070,6 +1084,7 @@ package Aspects is
Aspect_Import => Never_Delay,
Aspect_Initial_Condition => Never_Delay,
Aspect_Local_Restrictions => Never_Delay,
+ Aspect_Initialize => Never_Delay,
Aspect_Initializes => Never_Delay,
Aspect_Max_Entry_Queue_Length => Never_Delay,
Aspect_Max_Queue_Length => Never_Delay,
diff --git a/gcc/ada/atree.adb b/gcc/ada/atree.adb
index 8a69a0c..17538de 100644
--- a/gcc/ada/atree.adb
+++ b/gcc/ada/atree.adb
@@ -2271,10 +2271,10 @@ package body Atree is
-- Copy substitute node into place, preserving old fields as required
Copy_Node (Source => New_Node, Destination => Old_Node);
- Set_Error_Posted (Old_Node, Old_Error_Posted);
Set_Check_Actuals (Old_Node, Old_CA);
Set_Is_Ignored_Ghost_Node (Old_Node, Old_Is_IGN);
+ Set_Error_Posted (Old_Node, Old_Error_Posted);
if Nkind (New_Node) in N_Subexpr then
Set_Paren_Count (Old_Node, Old_Paren_Count);
@@ -2702,9 +2702,9 @@ package body Atree is
-- tail recursive step won't go past the end.
declare
- Cur_Field : Offset_Array_Index := Traversed_Offset_Array'First;
Offsets : Traversed_Offset_Array renames
Traversed_Fields (Nkind (Cur_Node));
+ Cur_Field : Offset_Array_Index := Traversed_Offset_Array'First;
begin
if Offsets (Traversed_Offset_Array'First) /= No_Field_Offset then
diff --git a/gcc/ada/atree.ads b/gcc/ada/atree.ads
index dc5fe0d..802db87 100644
--- a/gcc/ada/atree.ads
+++ b/gcc/ada/atree.ads
@@ -285,34 +285,29 @@ package Atree is
procedure Copy_Node (Source, Destination : Node_Or_Entity_Id);
-- Copy the entire contents of the source node to the destination node.
- -- The contents of the source node is not affected. If the source node
- -- has an extension, then the destination must have an extension also.
- -- The parent pointer of the destination and its list link, if any, are
- -- not affected by the copy. Note that parent pointers of descendants
- -- are not adjusted, so the descendants of the destination node after
- -- the Copy_Node is completed have dubious parent pointers. Note that
- -- this routine does NOT copy aspect specifications, the Has_Aspects
- -- flag in the returned node will always be False. The caller must deal
- -- with copying aspect specifications where this is required.
+ -- The contents of the source node is not affected. The parent pointer of
+ -- the destination and its list link, if any, are not affected by the copy.
+ -- Note that parent pointers of descendants are not adjusted, so the
+ -- descendants of the destination node after the Copy_Node is completed
+ -- have dubious parent pointers.
function New_Copy (Source : Node_Id) return Node_Id;
-- This function allocates a new node, and then initializes it by copying
-- the contents of the source node into it. The contents of the source node
-- is not affected. The target node is always marked as not being in a list
- -- (even if the source is a list member), and not overloaded. The new node
- -- will have an extension if the source has an extension. New_Copy (Empty)
- -- returns Empty, and New_Copy (Error) returns Error. Note that, unlike
- -- Copy_Separate_Tree, New_Copy does not recursively copy any descendants,
- -- so in general parent pointers are not set correctly for the descendants
- -- of the copied node.
+ -- (even if the source is a list member), and not overloaded.
+ -- New_Copy (Empty) returns Empty, and New_Copy (Error) returns Error. Note
+ -- that, unlike Copy_Separate_Tree, New_Copy does not recursively copy any
+ -- descendants, so in general parent pointers are not set correctly for the
+ -- descendants of the copied node.
function Relocate_Node (Source : Node_Id) return Node_Id;
-- Source is a non-entity node that is to be relocated. A new node is
-- allocated, and the contents of Source are copied to this node, using
-- New_Copy. The parent pointers of descendants of the node are then
-- adjusted to point to the relocated copy. The original node is not
- -- modified, but the parent pointers of its descendants are no longer
- -- valid. The new copy is always marked as not overloaded. This routine is
+ -- modified, but the parent pointers of its children no longer point back
+ -- at it. The new copy is always marked as not overloaded. This routine is
-- used in conjunction with the tree rewrite routines (see descriptions of
-- Replace/Rewrite).
--
@@ -458,7 +453,7 @@ package Atree is
function Parent_Or_List_Containing (X : Union_Id) return Union_Id;
-- X must be in Node_Range or in List_Range. If X is in Node_Range and is
- -- contained in a list, returns that list, otherwise return the parent of
+ -- contained in a list, returns that list, otherwise returns the parent of
-- the list or node represented by X.
function Paren_Count (N : Node_Id) return Nat;
@@ -537,16 +532,13 @@ package Atree is
procedure Rewrite (Old_Node, New_Node : Node_Id);
-- This is used when a complete subtree is to be replaced. Old_Node is the
-- root of the old subtree to be replaced, and New_Node is the root of the
- -- newly constructed replacement subtree. The actual mechanism is to swap
- -- the contents of these two nodes fixing up the parent pointers of the
- -- replaced node (we do not attempt to preserve parent pointers for the
- -- original node).
- -- ??? The above explanation is incorrect, instead Copy_Node is called.
+ -- newly constructed replacement subtree.
--
-- Note: New_Node may not contain references to Old_Node, for example as
- -- descendants, since the rewrite would make such references invalid. If
- -- New_Node does need to reference Old_Node, then these references should
- -- be to a relocated copy of Old_Node (see Relocate_Node procedure).
+ -- descendants, since the rewrite would turn them into cyclic
+ -- self-references. If New_Node does need to reference Old_Node, then these
+ -- references should be to a relocated copy of Old_Node (see Relocate_Node
+ -- procedure).
--
-- Note: The Original_Node function applied to Old_Node (which has now
-- been replaced by the contents of New_Node), can be used to obtain the
@@ -560,10 +552,8 @@ package Atree is
-- original contents of the Old_Node, but rather the New_Node value.
-- Replace also preserves the setting of Comes_From_Source.
--
- -- Note that New_Node must not contain references to Old_Node, for example
- -- as descendants, since the rewrite would make such references invalid. If
- -- New_Node does need to reference Old_Node, then these references should
- -- be to a relocated copy of Old_Node (see Relocate_Node procedure).
+ -- The note in the documentation of Rewrite about the risk of creating
+ -- cyclic references also applies here.
--
-- Replace is used in certain circumstances where it is desirable to
-- suppress any history of the rewriting operation. Notably, it is used
diff --git a/gcc/ada/bindgen.adb b/gcc/ada/bindgen.adb
index bc47ec1..cb39af6 100644
--- a/gcc/ada/bindgen.adb
+++ b/gcc/ada/bindgen.adb
@@ -53,13 +53,6 @@ package body Bindgen is
-- Flag which indicates whether the program uses the GNARL library
-- (presence of the unit System.OS_Interface)
- Num_Elab_Calls : Nat := 0;
- -- Number of generated calls to elaboration routines
-
- Num_Primary_Stacks : Nat := 0;
- -- Number of default-sized primary stacks the binder needs to allocate for
- -- task objects declared in the program.
-
Num_Sec_Stacks : Nat := 0;
-- Number of default-sized primary stacks the binder needs to allocate for
-- task objects declared in the program.
@@ -2483,16 +2476,6 @@ package body Bindgen is
ALIs.Table (ALIs.First).Time_Slice_Value := Opt.Time_Slice_Value;
end if;
- -- Count number of elaboration calls
-
- for E in Elab_Order'Range loop
- if Units.Table (Elab_Order (E)).No_Elab then
- null;
- else
- Num_Elab_Calls := Num_Elab_Calls + 1;
- end if;
- end loop;
-
-- Count the number of statically allocated stacks to be generated by
-- the binder. If the user has specified the number of default-sized
-- secondary stacks, use that number. Otherwise start the count at one
@@ -2506,9 +2489,6 @@ package body Bindgen is
end if;
for J in Units.First .. Units.Last loop
- Num_Primary_Stacks :=
- Num_Primary_Stacks + Units.Table (J).Primary_Stack_Count;
-
Num_Sec_Stacks :=
Num_Sec_Stacks + Units.Table (J).Sec_Stack_Count;
end loop;
diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb
index dcfcaa3..6a98292 100644
--- a/gcc/ada/checks.adb
+++ b/gcc/ada/checks.adb
@@ -8163,6 +8163,7 @@ package body Checks is
end if;
declare
+ Decl : Node_Id;
CE : Node_Id;
PV : Node_Id;
Var_Id : Entity_Id;
@@ -8215,12 +8216,20 @@ package body Checks is
Mutate_Ekind (Var_Id, E_Variable);
Set_Etype (Var_Id, Typ);
- Insert_Action (Exp,
+ Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Var_Id,
Object_Definition => New_Occurrence_Of (Typ, Loc),
- Expression => New_Copy_Tree (Exp)),
- Suppress => Validity_Check);
+ Expression => New_Copy_Tree (Exp));
+
+ -- We might be validity-checking object whose type is declared as
+ -- limited but completion is a scalar type. We need to explicitly
+ -- flag its assignment as OK, as otherwise it would be rejected by
+ -- the language rules.
+
+ Set_Assignment_OK (Decl);
+
+ Insert_Action (Exp, Decl, Suppress => Validity_Check);
Set_Validated_Object (Var_Id, New_Copy_Tree (Exp));
diff --git a/gcc/ada/clean.adb b/gcc/ada/clean.adb
index f28cf69..dcbeffe 100644
--- a/gcc/ada/clean.adb
+++ b/gcc/ada/clean.adb
@@ -319,7 +319,9 @@ package body Clean is
Delete ("", Executable);
end if;
- Delete_Binder_Generated_Files (Get_Current_Dir, Source);
+ Delete_Binder_Generated_Files
+ (GNAT.Directory_Operations.Get_Current_Dir,
+ Source);
end;
end if;
end loop;
@@ -405,7 +407,8 @@ package body Clean is
Source : File_Name_Type)
is
Source_Name : constant String := Get_Name_String (Source);
- Current : constant String := Get_Current_Dir;
+ Current : constant String :=
+ GNAT.Directory_Operations.Get_Current_Dir;
Last : constant Positive := B_Start'Length + Source_Name'Length;
File_Name : String (1 .. Last + 4);
diff --git a/gcc/ada/comperr.adb b/gcc/ada/comperr.adb
index 180ea94..c6285e9 100644
--- a/gcc/ada/comperr.adb
+++ b/gcc/ada/comperr.adb
@@ -146,7 +146,7 @@ package body Comperr is
if Serious_Errors_Detected /= 0 and then not Debug_Flag_K then
Errout.Finalize (Last_Call => True);
- Errout.Output_Messages;
+ Errout.Output_Messages (E_Errors);
Set_Standard_Error;
Write_Str ("compilation abandoned due to previous error");
@@ -307,16 +307,16 @@ package body Comperr is
Write_Str
("| Please submit a bug report by email " &
- "to report@adacore.com.");
+ "to support@adacore.com.");
End_Line;
Write_Str
- ("| GAP members can alternatively use GNAT Tracker:");
+ ("| GAP members can alternatively use GNATtracker:");
End_Line;
Write_Str
- ("| https://www.adacore.com/login?mode=gap " &
- "section 'Create New Ticket'.");
+ ("| https://support.adacore.com/csm " &
+ "by using the button 'Create A New Case'.");
End_Line;
Write_Str
@@ -326,17 +326,17 @@ package body Comperr is
else
Write_Str
- ("| Please submit a bug report using GNAT Tracker:");
+ ("| Please submit a bug report using GNATtracker at");
End_Line;
Write_Str
- ("| https://www.adacore.com/login " &
- "section 'Create New Ticket'.");
+ ("| https://support.adacore.com/csm " &
+ "by using the button 'Create New Case'.");
End_Line;
Write_Str
("| Or submit a bug report by email " &
- "to report@adacore.com");
+ "to support@adacore.com");
End_Line;
Write_Str
diff --git a/gcc/ada/contracts.adb b/gcc/ada/contracts.adb
index 8b94a67..70e9487 100644
--- a/gcc/ada/contracts.adb
+++ b/gcc/ada/contracts.adb
@@ -110,8 +110,8 @@ package body Contracts is
-- Expand the contracts of a subprogram body and its correspoding spec (if
-- any). This routine processes all [refined] pre- and postconditions as
-- well as Always_Terminates, Contract_Cases, Exceptional_Cases,
- -- Subprogram_Variant, invariants and predicates. Body_Id denotes the
- -- entity of the subprogram body.
+ -- Program_Exit, Subprogram_Variant, invariants and predicates. Body_Id
+ -- denotes the entity of the subprogram body.
procedure Preanalyze_Condition
(Subp : Entity_Id;
@@ -235,6 +235,7 @@ package body Contracts is
-- Interrupt_Handler
-- Postcondition
-- Precondition
+ -- Program_Exit
-- Side_Effects
-- Subprogram_Variant
-- Test_Case
@@ -267,6 +268,7 @@ package body Contracts is
| Name_Contract_Cases
| Name_Exceptional_Cases
| Name_Exit_Cases
+ | Name_Program_Exit
| Name_Subprogram_Variant
| Name_Test_Case
then
@@ -647,9 +649,9 @@ package body Contracts is
end if;
-- Deal with preconditions, [refined] postconditions, Always_Terminates,
- -- Contract_Cases, Exceptional_Cases, Subprogram_Variant, invariants and
- -- predicates associated with body and its spec. Do not expand the
- -- contract of subprogram body stubs.
+ -- Contract_Cases, Exceptional_Cases, Program_Exit, Subprogram_Variant,
+ -- invariants and predicates associated with body and its spec. Do not
+ -- expand the contract of subprogram body stubs.
if Nkind (Body_Decl) = N_Subprogram_Body then
Expand_Subprogram_Contract (Body_Id);
@@ -797,6 +799,9 @@ package body Contracts is
elsif Prag_Nam = Name_Exceptional_Cases then
Analyze_Exceptional_Cases_In_Decl_Part (Prag);
+ elsif Prag_Nam = Name_Program_Exit then
+ Analyze_Program_Exit_In_Decl_Part (Prag);
+
elsif Prag_Nam = Name_Subprogram_Variant then
Analyze_Subprogram_Variant_In_Decl_Part (Prag);
@@ -1413,6 +1418,7 @@ package body Contracts is
-- Global
-- Postcondition
-- Precondition
+ -- Program_Exit
-- Subprogram_Variant
-- Test_Case
@@ -2422,6 +2428,7 @@ package body Contracts is
-- verify the return value.
Result := Make_Defining_Identifier (Loc, Name_uResult);
+ Mutate_Ekind (Result, E_Constant);
Set_Etype (Result, Typ);
-- Add an invariant check when the return type has invariants and
@@ -2761,6 +2768,9 @@ package body Contracts is
elsif Pragma_Name (Prag) = Name_Exit_Cases then
Expand_Pragma_Exit_Cases (Prag);
+ elsif Pragma_Name (Prag) = Name_Program_Exit then
+ Expand_Pragma_Program_Exit (Prag);
+
elsif Pragma_Name (Prag) = Name_Subprogram_Variant then
Expand_Pragma_Subprogram_Variant
(Prag => Prag,
@@ -4389,10 +4399,10 @@ package body Contracts is
Seen : Subprogram_List (Subps'Range) := (others => Empty);
function Inherit_Condition
- (Par_Subp : Entity_Id;
- Subp : Entity_Id) return Node_Id;
- -- Inherit the class-wide condition from Par_Subp to Subp and adjust
- -- all the references to formals in the inherited condition.
+ (Par_Subp : Entity_Id) return Node_Id;
+ -- Inherit the class-wide condition from Par_Subp. Simply makes
+ -- a copy of the condition in preparation for later mapping of
+ -- referenced formals and functions by Build_Class_Wide_Expression.
procedure Merge_Conditions (From : Node_Id; Into : Node_Id);
-- Merge two class-wide preconditions or postconditions (the former
@@ -4407,92 +4417,11 @@ package body Contracts is
-----------------------
function Inherit_Condition
- (Par_Subp : Entity_Id;
- Subp : Entity_Id) return Node_Id
- is
- function Check_Condition (Expr : Node_Id) return Boolean;
- -- Used in assertion to check that Expr has no reference to the
- -- formals of Par_Subp.
-
- ---------------------
- -- Check_Condition --
- ---------------------
-
- function Check_Condition (Expr : Node_Id) return Boolean is
- Par_Formal_Id : Entity_Id;
-
- function Check_Entity (N : Node_Id) return Traverse_Result;
- -- Check occurrence of Par_Formal_Id
-
- ------------------
- -- Check_Entity --
- ------------------
-
- function Check_Entity (N : Node_Id) return Traverse_Result is
- begin
- if Nkind (N) = N_Identifier
- and then Present (Entity (N))
- and then Entity (N) = Par_Formal_Id
- then
- return Abandon;
- end if;
-
- return OK;
- end Check_Entity;
-
- function Check_Expression is new Traverse_Func (Check_Entity);
-
- -- Start of processing for Check_Condition
-
- begin
- Par_Formal_Id := First_Formal (Par_Subp);
-
- while Present (Par_Formal_Id) loop
- if Check_Expression (Expr) = Abandon then
- return False;
- end if;
-
- Next_Formal (Par_Formal_Id);
- end loop;
-
- return True;
- end Check_Condition;
-
- -- Local variables
-
- Assoc_List : constant Elist_Id := New_Elmt_List;
- Par_Formal_Id : Entity_Id := First_Formal (Par_Subp);
- Subp_Formal_Id : Entity_Id := First_Formal (Subp);
- New_Condition : Node_Id;
-
+ (Par_Subp : Entity_Id) return Node_Id is
begin
- while Present (Par_Formal_Id) loop
- Append_Elmt (Par_Formal_Id, Assoc_List);
- Append_Elmt (Subp_Formal_Id, Assoc_List);
-
- Next_Formal (Par_Formal_Id);
- Next_Formal (Subp_Formal_Id);
- end loop;
-
- -- Check that Parent field of all the nodes have their correct
- -- decoration; required because otherwise mapped nodes with
- -- wrong Parent field are left unmodified in the copied tree
- -- and cause reporting wrong errors at later stages.
-
- pragma Assert
- (Check_Parents (Class_Condition (Kind, Par_Subp), Assoc_List));
-
- New_Condition :=
+ return
New_Copy_Tree
- (Source => Class_Condition (Kind, Par_Subp),
- Map => Assoc_List);
-
- -- Ensure that the inherited condition has no reference to the
- -- formals of the parent subprogram.
-
- pragma Assert (Check_Condition (New_Condition));
-
- return New_Condition;
+ (Source => Class_Condition (Kind, Par_Subp));
end Inherit_Condition;
----------------------
@@ -4606,9 +4535,7 @@ package body Contracts is
Par_Prim := Subp_Id;
Par_Iface_Prims := Covered_Interface_Primitives (Par_Prim);
- Cond := Inherit_Condition
- (Subp => Spec_Id,
- Par_Subp => Subp_Id);
+ Cond := Inherit_Condition (Par_Subp => Subp_Id);
if Present (Class_Cond) then
Merge_Conditions (Cond, Class_Cond);
@@ -4652,9 +4579,7 @@ package body Contracts is
then
Seen (Index) := Subp_Id;
- Cond := Inherit_Condition
- (Subp => Spec_Id,
- Par_Subp => Subp_Id);
+ Cond := Inherit_Condition (Par_Subp => Subp_Id);
Check_Class_Condition
(Cond => Cond,
@@ -4909,7 +4834,7 @@ package body Contracts is
Install_Formals (Subp);
Inside_Class_Condition_Preanalysis := True;
- Preanalyze_Spec_Expression (Expr, Standard_Boolean);
+ Preanalyze_And_Resolve_Spec_Expression (Expr, Standard_Boolean);
Inside_Class_Condition_Preanalysis := False;
End_Scope;
diff --git a/gcc/ada/contracts.ads b/gcc/ada/contracts.ads
index ca9f84f..8b82037 100644
--- a/gcc/ada/contracts.ads
+++ b/gcc/ada/contracts.ads
@@ -56,6 +56,7 @@ package Contracts is
-- Part_Of
-- Postcondition
-- Precondition
+ -- Program_Exit
-- Refined_Depends
-- Refined_Global
-- Refined_Post
@@ -90,6 +91,7 @@ package Contracts is
-- Global (stand alone subprogram body)
-- Postcondition (stand alone subprogram body)
-- Precondition (stand alone subprogram body)
+ -- Program_Exit (stand alone subprogram body)
-- Refined_Depends
-- Refined_Global
-- Refined_Post
@@ -110,6 +112,7 @@ package Contracts is
-- Global
-- Postcondition
-- Precondition
+ -- Program_Exit
-- Subprogram_Variant
-- Test_Case
--
@@ -186,6 +189,7 @@ package Contracts is
-- Global
-- Postcondition
-- Precondition
+ -- Program_Exit
-- Refined_Depends
-- Refined_Global
-- Refined_Post
diff --git a/gcc/ada/cstand.adb b/gcc/ada/cstand.adb
index 5ba88b9..79e7083 100644
--- a/gcc/ada/cstand.adb
+++ b/gcc/ada/cstand.adb
@@ -67,10 +67,10 @@ package body CStand is
procedure Build_Float_Type
(E : Entity_Id;
- Digs : Int;
+ Digs : Pos;
Rep : Float_Rep_Kind;
Siz : Int;
- Align : Int);
+ Align : Nat);
-- Procedure to build standard predefined float base type. The first
-- parameter is the entity for the type. The second parameter is the
-- digits value. The third parameter indicates the representation to
@@ -192,10 +192,10 @@ package body CStand is
procedure Build_Float_Type
(E : Entity_Id;
- Digs : Int;
+ Digs : Pos;
Rep : Float_Rep_Kind;
Siz : Int;
- Align : Int)
+ Align : Nat)
is
begin
Set_Type_Definition (Parent (E),
@@ -612,27 +612,14 @@ package body CStand is
Set_Is_Pure (Standard_Standard);
Set_Is_Compilation_Unit (Standard_Standard);
- -- Create type/subtype declaration nodes for standard types
+ -- Create type declaration nodes for standard types
for S in S_Types loop
-
- -- Subtype declaration case
-
- if S = S_Natural or else S = S_Positive then
- Decl := New_Node (N_Subtype_Declaration, Stloc);
- Set_Subtype_Indication (Decl,
- New_Occurrence_Of (Standard_Integer, Stloc));
-
- -- Full type declaration case
-
- else
+ if S not in S_Natural | S_Positive then
Decl := New_Node (N_Full_Type_Declaration, Stloc);
+ Set_Defining_Identifier (Decl, Standard_Entity (S));
+ Append (Decl, Decl_S);
end if;
-
- Set_Is_Frozen (Standard_Entity (S));
- Set_Is_Public (Standard_Entity (S));
- Set_Defining_Identifier (Decl, Standard_Entity (S));
- Append (Decl, Decl_S);
end loop;
Create_Back_End_Float_Types;
@@ -1023,6 +1010,14 @@ package body CStand is
Hb => Intval (High_Bound (Scalar_Range (Standard_Integer))));
Set_Is_Constrained (Standard_Natural);
+ Append_To
+ (Decl_S,
+ Make_Subtype_Declaration
+ (Stloc,
+ Standard_Natural,
+ Subtype_Indication =>
+ New_Occurrence_Of (Standard_Integer, Stloc)));
+
-- Setup entity for Positive
Mutate_Ekind (Standard_Positive, E_Signed_Integer_Subtype);
@@ -1040,6 +1035,14 @@ package body CStand is
Hb => Intval (High_Bound (Scalar_Range (Standard_Integer))));
Set_Is_Constrained (Standard_Positive);
+ Append_To
+ (Decl_S,
+ Make_Subtype_Declaration
+ (Stloc,
+ Standard_Positive,
+ Subtype_Indication =>
+ New_Occurrence_Of (Standard_Integer, Stloc)));
+
-- Create declaration for package ASCII
Decl := New_Node (N_Package_Declaration, Stloc);
@@ -1073,7 +1076,6 @@ package body CStand is
Set_Never_Set_In_Source (A_Char, True);
Set_Is_True_Constant (A_Char, True);
Set_Etype (A_Char, Standard_Character);
- Set_Scope (A_Char, Standard_Entity (S_ASCII));
Set_Is_Immediately_Visible (A_Char, False);
Set_Is_Public (A_Char, True);
Set_Is_Known_Valid (A_Char, True);
@@ -1729,7 +1731,6 @@ package body CStand is
begin
Mutate_Ekind (Id, E_Component);
Set_Etype (Id, Typ);
- Set_Scope (Id, Rec);
Reinit_Component_Location (Id);
Set_Original_Record_Component (Id, Id);
Set_Is_Aliased (Id);
@@ -1747,7 +1748,6 @@ package body CStand is
begin
Mutate_Ekind (Formal, E_In_Parameter);
Set_Mechanism (Formal, Default_Mechanism);
- Set_Scope (Formal, Standard_Standard);
Set_Etype (Formal, Typ);
return Formal;
@@ -1777,7 +1777,6 @@ package body CStand is
Set_Is_Pure (Ident_Node, True);
Mutate_Ekind (Ident_Node, E_Operator);
Set_Etype (Ident_Node, Typ);
- Set_Scope (Ident_Node, Standard_Standard);
Set_Homonym (Ident_Node, Get_Name_Entity_Id (Op));
Set_Convention (Ident_Node, Convention_Intrinsic);
@@ -2083,7 +2082,7 @@ package body CStand is
Set_Defining_Identifier (New_Node (N_Full_Type_Declaration, Stloc), Ent);
Set_Scope (Ent, Standard_Standard);
Build_Float_Type
- (Ent, Pos (Digs), Float_Rep, Int (Size), Int (Alignment / 8));
+ (Ent, Pos (Digs), Float_Rep, Int (Size), Nat (Alignment / 8));
Append_New_Elmt (Ent, Back_End_Float_Types);
end Register_Float_Type;
@@ -2092,7 +2091,7 @@ package body CStand is
-- Set_Float_Bounds --
----------------------
- procedure Set_Float_Bounds (Id : Entity_Id) is
+ procedure Set_Float_Bounds (Id : Entity_Id) is
L : Node_Id;
H : Node_Id;
-- Low and high bounds of literal value
diff --git a/gcc/ada/cstand.ads b/gcc/ada/cstand.ads
index 62644fe..bfd3052 100644
--- a/gcc/ada/cstand.ads
+++ b/gcc/ada/cstand.ads
@@ -42,7 +42,7 @@ package CStand is
-- The semantics info is in the format given by Entity_Info. The global
-- variables Last_Standard_Node_Id and Last_Standard_List_Id are also set.
- procedure Set_Float_Bounds (Id : Entity_Id);
+ procedure Set_Float_Bounds (Id : Entity_Id);
-- Procedure to set bounds for float type or subtype. Id is the entity
-- whose bounds and type are to be set (a floating-point type).
diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb
index ac3ce41..f250d74 100644
--- a/gcc/ada/debug.adb
+++ b/gcc/ada/debug.adb
@@ -168,7 +168,7 @@ package body Debug is
-- d_A Stop generation of ALI file
-- d_B Warn on build-in-place function calls
-- d_C
- -- d_D Use improved diagnostics
+ -- d_D
-- d_E Print diagnostics and switch repository
-- d_F Encode full invocation paths in ALI files
-- d_G
@@ -186,8 +186,8 @@ package body Debug is
-- d_S
-- d_T Output trace information on invocation path recording
-- d_U Disable prepending messages with "error:".
- -- d_V Enable verifications on the expanded tree
- -- d_W
+ -- d_V Enable VAST (verifications on the expanded tree)
+ -- d_W Enable VAST in verbose mode
-- d_X Disable assertions to check matching of extra formals
-- d_Y
-- d_Z
@@ -1065,8 +1065,11 @@ package body Debug is
-- d_U Disable prepending 'error:' to error messages. This used to be the
-- default and can be seen as the opposite of -gnatU.
- -- d_V Enable verification of the expanded code before calling the backend
- -- and generate error messages on each inconsistency found.
+ -- d_V Enable VAST (Verifier for the Ada Semantic Tree). This does
+ -- verification of the expanded code before calling the backend.
+
+ -- d_W Same as d_V, but also prints lots of tracing/debugging output
+ -- as it walks the tree.
-- d_X Disable assertions to check matching of extra formals; switch added
-- temporarily to disable these checks until this work is complete if
diff --git a/gcc/ada/debug_a.adb b/gcc/ada/debug_a.adb
index d36ae69..8d68fc8 100644
--- a/gcc/ada/debug_a.adb
+++ b/gcc/ada/debug_a.adb
@@ -83,11 +83,8 @@ package body Debug_A is
case Nkind (N) is
when N_Has_Chars =>
- Write_Str (" """);
- if Present (Chars (N)) then
- Write_Str (Get_Name_String (Chars (N)));
- end if;
- Write_Str ("""");
+ Write_Str (" ");
+ Write_Name_For_Debug (Chars (N));
when others => null;
end case;
diff --git a/gcc/ada/diagnostics-brief_emitter.adb b/gcc/ada/diagnostics-brief_emitter.adb
deleted file mode 100644
index 0315b53..0000000
--- a/gcc/ada/diagnostics-brief_emitter.adb
+++ /dev/null
@@ -1,137 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- D I A G N O S T I C S . B R I E F _ E M I T T E R --
--- --
--- B o d y --
--- --
--- Copyright (C) 1992-2025, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-with Diagnostics.Utils; use Diagnostics.Utils;
-with Erroutc; use Erroutc;
-with Opt; use Opt;
-with Output; use Output;
-
-package body Diagnostics.Brief_Emitter is
-
- procedure Print_Sub_Diagnostic
- (Sub_Diag : Sub_Diagnostic_Type;
- Diag : Diagnostic_Type);
-
- --------------------------
- -- Print_Sub_Diagnostic --
- --------------------------
-
- procedure Print_Sub_Diagnostic
- (Sub_Diag : Sub_Diagnostic_Type;
- Diag : Diagnostic_Type)
- is
- -- In GNAT sub messages were grouped by the main messages by also having
- -- the same location. In the brief printer we use the primary location
- -- of the main diagnostic for all of the subdiagnostics.
- Prim_Loc : constant Labeled_Span_Type := Primary_Location (Diag);
-
- Sptr : constant Source_Ptr := Prim_Loc.Span.Ptr;
-
- Text : String_Ptr;
-
- Line_Length : constant Nat := (if Error_Msg_Line_Length = 0 then Nat'Last
- else Error_Msg_Line_Length);
-
- Switch_Str : constant String := Get_Doc_Switch (Diag);
- begin
- Text := new String'(To_String (Sptr) & ": "
- & Kind_To_String (Sub_Diag, Diag) & ": "
- & Sub_Diag.Message.all);
-
- if Switch_Str /= "" then
- Text := new String'(Text.all & " " & Switch_Str);
- end if;
-
- if Diag.Warn_Err then
- Text := new String'(Text.all & " [warning-as-error]");
- end if;
-
- Output_Text_Within (Text, Line_Length);
- Write_Eol;
- end Print_Sub_Diagnostic;
-
- ----------------------
- -- Print_Diagnostic --
- ----------------------
-
- procedure Print_Diagnostic (Diag : Diagnostic_Type) is
- use Sub_Diagnostic_Lists;
-
- Prim_Loc : constant Labeled_Span_Type := Primary_Location (Diag);
-
- Sptr : constant Source_Ptr := Prim_Loc.Span.Ptr;
-
- Text : String_Ptr;
-
- Line_Length : constant Nat := (if Error_Msg_Line_Length = 0 then Nat'Last
- else Error_Msg_Line_Length);
-
- Switch_Str : constant String := Get_Doc_Switch (Diag);
- begin
- Write_Str (To_String (Sptr) & ": ");
-
- -- Ignore the message prefix on Style messages. They will use
- -- the (style) prefix within the message.
- --
- -- Also disable the "error:" prefix if Unique_Error_Tag is unset.
-
- if (Diag.Kind = Style and then not Diag.Warn_Err)
- or else (Diag.Kind = Error and then not Unique_Error_Tag)
- then
- Text := new String'("");
- else
- Text := new String'(Kind_To_String (Diag) & ": ");
- end if;
-
- Text := new String'(Text.all & Diag.Message.all);
-
- if Switch_Str /= "" then
- Text := new String'(Text.all & " " & Switch_Str);
- end if;
-
- if Diag.Warn_Err then
- Text := new String'(Text.all & " [warning-as-error]");
- end if;
-
- Output_Text_Within (Text, Line_Length);
- Write_Eol;
-
- if Present (Diag.Sub_Diagnostics) then
- declare
-
- Sub_Diag : Sub_Diagnostic_Type;
-
- It : Iterator := Iterate (Diag.Sub_Diagnostics);
- begin
- while Has_Next (It) loop
- Next (It, Sub_Diag);
-
- Print_Sub_Diagnostic (Sub_Diag, Diag);
- end loop;
- end;
- end if;
-
- end Print_Diagnostic;
-end Diagnostics.Brief_Emitter;
diff --git a/gcc/ada/diagnostics-brief_emitter.ads b/gcc/ada/diagnostics-brief_emitter.ads
deleted file mode 100644
index 706293e..0000000
--- a/gcc/ada/diagnostics-brief_emitter.ads
+++ /dev/null
@@ -1,28 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- D I A G N O S T I C S . B R I E F _ E M I T T E R --
--- --
--- S p e c --
--- --
--- Copyright (C) 1992-2025, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-package Diagnostics.Brief_Emitter is
- procedure Print_Diagnostic (Diag : Diagnostic_Type);
-end Diagnostics.Brief_Emitter;
diff --git a/gcc/ada/diagnostics-constructors.adb b/gcc/ada/diagnostics-constructors.adb
deleted file mode 100644
index 0bc8750..0000000
--- a/gcc/ada/diagnostics-constructors.adb
+++ /dev/null
@@ -1,514 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- D I A G N O S T I C S . C O N S T R U C T O R S --
--- --
--- B o d y --
--- --
--- Copyright (C) 1992-2025, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-with Sinfo.Nodes; use Sinfo.Nodes;
-with Diagnostics.Utils; use Diagnostics.Utils;
-
-package body Diagnostics.Constructors is
-
- -----------------------------------------------
- -- Make_Default_Iterator_Not_Primitive_Error --
- -----------------------------------------------
-
- function Make_Default_Iterator_Not_Primitive_Error
- (Expr : Node_Id;
- Subp : Entity_Id) return Diagnostic_Type
- is
- begin
- return
- Make_Diagnostic
- (Msg => "improper function for default iterator",
- Location => Primary_Labeled_Span (Expr),
- Id => GNAT0001,
- Kind => Diagnostics.Error,
- Sub_Diags =>
- (1 =>
- Continuation
- (Msg =>
- "default iterator defined " &
- Sloc_To_String (Subp, Sloc (Expr)) &
- " must be a local primitive or class-wide function",
- Locations =>
- (1 => Primary_Labeled_Span (Subp)))));
- end Make_Default_Iterator_Not_Primitive_Error;
-
- -------------------------------------------------
- -- Record_Default_Iterator_Not_Primitive_Error --
- -------------------------------------------------
-
- procedure Record_Default_Iterator_Not_Primitive_Error
- (Expr : Node_Id;
- Subp : Entity_Id)
- is
- begin
- Record_Diagnostic
- (Make_Default_Iterator_Not_Primitive_Error (Expr, Subp));
- end Record_Default_Iterator_Not_Primitive_Error;
-
- ---------------------------------------------------
- -- Make_Invalid_Operand_Types_For_Operator_Error --
- ---------------------------------------------------
-
- function Make_Invalid_Operand_Types_For_Operator_Error
- (Op : Node_Id;
- L : Node_Id;
- L_Type : Node_Id;
- R : Node_Id;
- R_Type : Node_Id) return Diagnostic_Type
- is
- begin
- return
- Make_Diagnostic
- (Msg => "invalid operand types for operator " & To_Name (Op),
- Location => Primary_Labeled_Span (Op),
- Id => GNAT0002,
- Kind => Diagnostics.Error,
- Spans =>
- (1 =>
- (Secondary_Labeled_Span
- (N => L,
- Label => To_Type_Name (L_Type))),
- 2 =>
- Secondary_Labeled_Span
- (N => R,
- Label => To_Type_Name (R_Type))));
- end Make_Invalid_Operand_Types_For_Operator_Error;
-
- -----------------------------------------------------
- -- Record_Invalid_Operand_Types_For_Operator_Error --
- -----------------------------------------------------
-
- procedure Record_Invalid_Operand_Types_For_Operator_Error
- (Op : Node_Id;
- L : Node_Id;
- L_Type : Node_Id;
- R : Node_Id;
- R_Type : Node_Id)
- is
-
- begin
- Record_Diagnostic
- (Make_Invalid_Operand_Types_For_Operator_Error
- (Op, L, L_Type, R, R_Type));
- end Record_Invalid_Operand_Types_For_Operator_Error;
-
- ---------------------------------------------------------
- -- Make_Invalid_Operand_Types_For_Operator_L_Int_Error --
- ---------------------------------------------------------
-
- function Make_Invalid_Operand_Types_For_Operator_L_Int_Error
- (Op : Node_Id;
- L : Node_Id;
- L_Type : Node_Id;
- R : Node_Id;
- R_Type : Node_Id) return Diagnostic_Type
- is
- begin
- return
- Make_Diagnostic
- (Msg => "invalid operand types for operator " & To_Name (Op),
- Location => Primary_Labeled_Span (Op),
- Id => GNAT0003,
- Kind => Diagnostics.Error,
- Spans =>
- (1 =>
- (Secondary_Labeled_Span
- (N => L,
- Label =>
- "left operand has type " &
- To_Name (L_Type))),
- 2 =>
- Secondary_Labeled_Span
- (N => R,
- Label =>
- "right operand has type " &
- To_Name (R_Type))),
- Sub_Diags =>
- (1 => Suggestion (Msg => "Convert left operand to ""Integer""")
- )
- );
- end Make_Invalid_Operand_Types_For_Operator_L_Int_Error;
-
- -----------------------------------------------------------
- -- Record_Invalid_Operand_Types_For_Operator_L_Int_Error --
- -----------------------------------------------------------
-
- procedure Record_Invalid_Operand_Types_For_Operator_L_Int_Error
- (Op : Node_Id;
- L : Node_Id;
- L_Type : Node_Id;
- R : Node_Id;
- R_Type : Node_Id)
- is
-
- begin
- Record_Diagnostic
- (Make_Invalid_Operand_Types_For_Operator_L_Int_Error
- (Op, L, L_Type, R, R_Type));
- end Record_Invalid_Operand_Types_For_Operator_L_Int_Error;
-
- ---------------------------------------------------------
- -- Make_Invalid_Operand_Types_For_Operator_R_Int_Error --
- ---------------------------------------------------------
-
- function Make_Invalid_Operand_Types_For_Operator_R_Int_Error
- (Op : Node_Id;
- L : Node_Id;
- L_Type : Node_Id;
- R : Node_Id;
- R_Type : Node_Id) return Diagnostic_Type
- is
- begin
- return
- Make_Diagnostic
- (Msg => "invalid operand types for operator " & To_Name (Op),
- Location => Primary_Labeled_Span (Op),
- Id => GNAT0004,
- Kind => Diagnostics.Error,
- Spans =>
- (1 =>
- Secondary_Labeled_Span
- (N => L,
- Label =>
- "left operand has type " &
- To_Name (L_Type)),
- 2 =>
- Secondary_Labeled_Span
- (N => R,
- Label =>
- "right operand has type " &
- To_Name (R_Type))),
- Sub_Diags =>
- (1 => Suggestion (Msg => "Convert right operand to ""Integer""")
- )
- );
- end Make_Invalid_Operand_Types_For_Operator_R_Int_Error;
-
- -----------------------------------------------------------
- -- Record_Invalid_Operand_Types_For_Operator_R_Int_Error --
- -----------------------------------------------------------
-
- procedure Record_Invalid_Operand_Types_For_Operator_R_Int_Error
- (Op : Node_Id;
- L : Node_Id;
- L_Type : Node_Id;
- R : Node_Id;
- R_Type : Node_Id)
- is
-
- begin
- Record_Diagnostic
- (Make_Invalid_Operand_Types_For_Operator_R_Int_Error
- (Op, L, L_Type, R, R_Type));
- end Record_Invalid_Operand_Types_For_Operator_R_Int_Error;
-
- ---------------------------------------------------------
- -- Make_Invalid_Operand_Types_For_Operator_L_Acc_Error --
- ---------------------------------------------------------
-
- function Make_Invalid_Operand_Types_For_Operator_L_Acc_Error
- (Op : Node_Id;
- L : Node_Id) return Diagnostic_Type
- is
-
- begin
- return
- Make_Diagnostic
- (Msg => "invalid operand types for operator " & To_Name (Op),
- Location => Primary_Labeled_Span (Op),
- Id => GNAT0005,
- Kind => Diagnostics.Error,
- Spans =>
- (1 =>
- Secondary_Labeled_Span
- (N => L,
- Label =>
- "left operand is access type ")
- )
- );
- end Make_Invalid_Operand_Types_For_Operator_L_Acc_Error;
-
- -----------------------------------------------------------
- -- Record_Invalid_Operand_Types_For_Operator_L_Acc_Error --
- -----------------------------------------------------------
-
- procedure Record_Invalid_Operand_Types_For_Operator_L_Acc_Error
- (Op : Node_Id;
- L : Node_Id)
- is
- begin
- Record_Diagnostic
- (Make_Invalid_Operand_Types_For_Operator_R_Acc_Error
- (Op, L));
- end Record_Invalid_Operand_Types_For_Operator_L_Acc_Error;
-
- ---------------------------------------------------------
- -- Make_Invalid_Operand_Types_For_Operator_L_Acc_Error --
- ---------------------------------------------------------
-
- function Make_Invalid_Operand_Types_For_Operator_R_Acc_Error
- (Op : Node_Id;
- R : Node_Id) return Diagnostic_Type
- is
-
- begin
- return
- Make_Diagnostic
- (Msg => "invalid operand types for operator " & To_Name (Op),
- Location => Primary_Labeled_Span (Op),
- Id => GNAT0006,
- Kind => Diagnostics.Error,
- Spans =>
- (1 =>
- Secondary_Labeled_Span
- (N => R,
- Label =>
- "right operand is access type ")
- )
- );
- end Make_Invalid_Operand_Types_For_Operator_R_Acc_Error;
-
- -----------------------------------------------------------
- -- Record_Invalid_Operand_Types_For_Operator_R_Acc_Error --
- -----------------------------------------------------------
-
- procedure Record_Invalid_Operand_Types_For_Operator_R_Acc_Error
- (Op : Node_Id;
- R : Node_Id)
- is
- begin
- Record_Diagnostic
- (Make_Invalid_Operand_Types_For_Operator_R_Acc_Error
- (Op, R));
- end Record_Invalid_Operand_Types_For_Operator_R_Acc_Error;
-
- -----------------------------------------------------------
- -- Make_Invalid_Operand_Types_For_Operator_General_Error --
- -----------------------------------------------------------
-
- function Make_Invalid_Operand_Types_For_Operator_General_Error
- (Op : Node_Id) return Diagnostic_Type
- is
-
- begin
- return
- Make_Diagnostic
- (Msg => "invalid operand types for operator " & To_Name (Op),
- Location => Primary_Labeled_Span (Op),
- Id => GNAT0007,
- Kind => Diagnostics.Error
- );
- end Make_Invalid_Operand_Types_For_Operator_General_Error;
-
- -------------------------------------------------------------
- -- Record_Invalid_Operand_Types_For_Operator_General_Error --
- -------------------------------------------------------------
-
- procedure Record_Invalid_Operand_Types_For_Operator_General_Error
- (Op : Node_Id)
- is
- begin
- Record_Diagnostic
- (Make_Invalid_Operand_Types_For_Operator_General_Error (Op));
- end Record_Invalid_Operand_Types_For_Operator_General_Error;
-
- --------------------------------------------------
- -- Make_Pragma_No_Effect_With_Lock_Free_Warning --
- --------------------------------------------------
-
- function Make_Pragma_No_Effect_With_Lock_Free_Warning
- (Pragma_Node : Node_Id; Pragma_Name : Name_Id;
- Lock_Free_Node : Node_Id; Lock_Free_Range : Node_Id)
- return Diagnostic_Type
- is
- begin
- return
- Make_Diagnostic
- (Msg =>
- "pragma " & '"' & Get_Name_String (Pragma_Name) & '"' &
- " for " & To_Name (Lock_Free_Node) &
- " has no effect when Lock_Free given",
- Location => Primary_Labeled_Span (Pragma_Node, "No effect"),
- Id => GNAT0008,
- Kind => Diagnostics.Warning,
- Spans =>
- (1 =>
- Labeled_Span
- (Span => To_Full_Span (Lock_Free_Range),
- Label => "Lock_Free in effect here",
- Is_Primary => False,
- Is_Region => True)));
- end Make_Pragma_No_Effect_With_Lock_Free_Warning;
-
- --------------------------------------------
- -- Record_Pragma_No_Effect_With_Lock_Free --
- --------------------------------------------
-
- procedure Record_Pragma_No_Effect_With_Lock_Free_Warning
- (Pragma_Node : Node_Id;
- Pragma_Name : Name_Id;
- Lock_Free_Node : Node_Id;
- Lock_Free_Range : Node_Id)
- is
- begin
- Record_Diagnostic
- (Make_Pragma_No_Effect_With_Lock_Free_Warning
- (Pragma_Node, Pragma_Name, Lock_Free_Node, Lock_Free_Range));
- end Record_Pragma_No_Effect_With_Lock_Free_Warning;
-
- ----------------------------------
- -- Make_End_Loop_Expected_Error --
- ----------------------------------
-
- function Make_End_Loop_Expected_Error
- (End_Loc : Source_Span;
- Start_Loc : Source_Ptr) return Diagnostic_Type
- is
- begin
- return
- Make_Diagnostic
- (Msg =>
- """end loop;"" expected for ""loop"" " &
- Sloc_To_String (Start_Loc, End_Loc.Ptr),
- Location => Primary_Labeled_Span (End_Loc),
- Id => GNAT0009,
- Kind => Diagnostics.Error,
- Spans => (1 => Secondary_Labeled_Span (To_Span (Start_Loc))),
- Fixes =>
- (1 =>
- Fix
- (Description => "Replace with 'end loop;'",
- Edits =>
- (1 => Edit (Text => "end loop;", Span => End_Loc)),
- Applicability => Legal)));
- end Make_End_Loop_Expected_Error;
-
- ------------------------------------
- -- Record_End_Loop_Expected_Error --
- ------------------------------------
-
- procedure Record_End_Loop_Expected_Error
- (End_Loc : Source_Span; Start_Loc : Source_Ptr)
- is
- begin
- Record_Diagnostic (Make_End_Loop_Expected_Error (End_Loc, Start_Loc));
- end Record_End_Loop_Expected_Error;
-
- ----------------------------------------
- -- Make_Representation_Too_Late_Error --
- ----------------------------------------
-
- function Make_Representation_Too_Late_Error
- (Rep : Node_Id;
- Freeze : Node_Id;
- Def : Node_Id)
- return Diagnostic_Type
- is
- begin
- return
- Make_Diagnostic
- (Msg =>
- "record representation cannot be specified" &
- " after the type is frozen",
- Location =>
- Primary_Labeled_Span
- (N => Rep,
- Label => "record representation clause specified here"),
- Id => GNAT0010,
- Kind => Error,
- Spans =>
- (1 =>
- Secondary_Labeled_Span
- (N => Freeze,
- Label =>
- "Type " & To_Name (Def) & " is frozen here"),
- 2 =>
- Secondary_Labeled_Span
- (N => Def,
- Label =>
- "Type " & To_Name (Def) & " is declared here")),
- Sub_Diags =>
- (1 =>
- Suggestion
- (Msg =>
- "move the record representation clause" &
- " before the freeze point " &
- Sloc_To_String (Sloc (Freeze), Sloc (Rep)))));
- end Make_Representation_Too_Late_Error;
-
- ------------------------------------------
- -- Record_Representation_Too_Late_Error --
- ------------------------------------------
-
- procedure Record_Representation_Too_Late_Error
- (Rep : Node_Id;
- Freeze : Node_Id;
- Def : Node_Id)
- is
- begin
- Record_Diagnostic
- (Make_Representation_Too_Late_Error (Rep, Freeze, Def));
- end Record_Representation_Too_Late_Error;
-
- ------------------------------------------
- -- Make_Mixed_Container_Aggregate_Error --
- ------------------------------------------
-
- function Make_Mixed_Container_Aggregate_Error
- (Aggr : Node_Id;
- Pos_Elem : Node_Id;
- Named_Elem : Node_Id) return Diagnostic_Type
- is
-
- begin
- return
- Make_Diagnostic
- (Msg =>
- "container aggregate cannot be both positional and named",
- Location => Primary_Labeled_Span (Aggr),
- Id => GNAT0011,
- Kind => Diagnostics.Error,
- Spans =>
- (1 => Secondary_Labeled_Span
- (Pos_Elem, "positional element "),
- 2 => Secondary_Labeled_Span
- (Named_Elem, "named element")));
- end Make_Mixed_Container_Aggregate_Error;
-
- --------------------------------------------
- -- Record_Mixed_Container_Aggregate_Error --
- --------------------------------------------
-
- procedure Record_Mixed_Container_Aggregate_Error
- (Aggr : Node_Id;
- Pos_Elem : Node_Id;
- Named_Elem : Node_Id)
- is
- begin
- Record_Diagnostic
- (Make_Mixed_Container_Aggregate_Error (Aggr, Pos_Elem, Named_Elem));
- end Record_Mixed_Container_Aggregate_Error;
-
-end Diagnostics.Constructors;
diff --git a/gcc/ada/diagnostics-constructors.ads b/gcc/ada/diagnostics-constructors.ads
deleted file mode 100644
index a568f0f..0000000
--- a/gcc/ada/diagnostics-constructors.ads
+++ /dev/null
@@ -1,143 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- D I A G N O S T I C S . C O N S T R U C T O R S --
--- --
--- S p e c --
--- --
--- Copyright (C) 1992-2025, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-with Namet; use Namet;
-
-package Diagnostics.Constructors is
-
- function Make_Default_Iterator_Not_Primitive_Error
- (Expr : Node_Id;
- Subp : Entity_Id) return Diagnostic_Type;
-
- procedure Record_Default_Iterator_Not_Primitive_Error
- (Expr : Node_Id;
- Subp : Entity_Id);
-
- function Make_Invalid_Operand_Types_For_Operator_Error
- (Op : Node_Id;
- L : Node_Id;
- L_Type : Node_Id;
- R : Node_Id;
- R_Type : Node_Id) return Diagnostic_Type;
-
- procedure Record_Invalid_Operand_Types_For_Operator_Error
- (Op : Node_Id;
- L : Node_Id;
- L_Type : Node_Id;
- R : Node_Id;
- R_Type : Node_Id);
-
- function Make_Invalid_Operand_Types_For_Operator_L_Int_Error
- (Op : Node_Id;
- L : Node_Id;
- L_Type : Node_Id;
- R : Node_Id;
- R_Type : Node_Id) return Diagnostic_Type;
-
- procedure Record_Invalid_Operand_Types_For_Operator_L_Int_Error
- (Op : Node_Id;
- L : Node_Id;
- L_Type : Node_Id;
- R : Node_Id;
- R_Type : Node_Id);
-
- function Make_Invalid_Operand_Types_For_Operator_R_Int_Error
- (Op : Node_Id;
- L : Node_Id;
- L_Type : Node_Id;
- R : Node_Id;
- R_Type : Node_Id) return Diagnostic_Type;
-
- procedure Record_Invalid_Operand_Types_For_Operator_R_Int_Error
- (Op : Node_Id;
- L : Node_Id;
- L_Type : Node_Id;
- R : Node_Id;
- R_Type : Node_Id);
-
- function Make_Invalid_Operand_Types_For_Operator_L_Acc_Error
- (Op : Node_Id;
- L : Node_Id) return Diagnostic_Type;
-
- procedure Record_Invalid_Operand_Types_For_Operator_L_Acc_Error
- (Op : Node_Id;
- L : Node_Id);
-
- function Make_Invalid_Operand_Types_For_Operator_R_Acc_Error
- (Op : Node_Id;
- R : Node_Id) return Diagnostic_Type;
-
- procedure Record_Invalid_Operand_Types_For_Operator_R_Acc_Error
- (Op : Node_Id;
- R : Node_Id);
-
- function Make_Invalid_Operand_Types_For_Operator_General_Error
- (Op : Node_Id) return Diagnostic_Type;
-
- procedure Record_Invalid_Operand_Types_For_Operator_General_Error
- (Op : Node_Id);
-
- function Make_Pragma_No_Effect_With_Lock_Free_Warning
- (Pragma_Node : Node_Id;
- Pragma_Name : Name_Id;
- Lock_Free_Node : Node_Id;
- Lock_Free_Range : Node_Id)
- return Diagnostic_Type;
-
- procedure Record_Pragma_No_Effect_With_Lock_Free_Warning
- (Pragma_Node : Node_Id;
- Pragma_Name : Name_Id;
- Lock_Free_Node : Node_Id;
- Lock_Free_Range : Node_Id);
-
- function Make_End_Loop_Expected_Error
- (End_Loc : Source_Span;
- Start_Loc : Source_Ptr) return Diagnostic_Type;
-
- procedure Record_End_Loop_Expected_Error
- (End_Loc : Source_Span;
- Start_Loc : Source_Ptr);
-
- function Make_Representation_Too_Late_Error
- (Rep : Node_Id;
- Freeze : Node_Id;
- Def : Node_Id)
- return Diagnostic_Type;
-
- procedure Record_Representation_Too_Late_Error
- (Rep : Node_Id;
- Freeze : Node_Id;
- Def : Node_Id);
-
- function Make_Mixed_Container_Aggregate_Error
- (Aggr : Node_Id;
- Pos_Elem : Node_Id;
- Named_Elem : Node_Id) return Diagnostic_Type;
-
- procedure Record_Mixed_Container_Aggregate_Error
- (Aggr : Node_Id;
- Pos_Elem : Node_Id;
- Named_Elem : Node_Id);
-
-end Diagnostics.Constructors;
diff --git a/gcc/ada/diagnostics-converter.adb b/gcc/ada/diagnostics-converter.adb
deleted file mode 100644
index b3d9edf..0000000
--- a/gcc/ada/diagnostics-converter.adb
+++ /dev/null
@@ -1,254 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- D I A G N O S T I C S . C O N V E R T E R --
--- --
--- B o d y --
--- --
--- Copyright (C) 1992-2025, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-with Erroutc; use Erroutc;
-with Debug; use Debug;
-with Diagnostics.Repository; use Diagnostics.Repository;
-with Diagnostics.SARIF_Emitter; use Diagnostics.SARIF_Emitter;
-with Diagnostics.Switch_Repository; use Diagnostics.Switch_Repository;
-with Opt; use Opt;
-with Osint; use Osint;
-with Output; use Output;
-use Diagnostics.Diagnostics_Lists;
-with System.OS_Lib; use System.OS_Lib;
-
-package body Diagnostics.Converter is
-
- function Convert (E_Id : Error_Msg_Id) return Diagnostic_Type;
-
- function Convert_Sub_Diagnostic
- (E_Id : Error_Msg_Id) return Sub_Diagnostic_Type;
-
- function Get_Warning_Kind (E_Msg : Error_Msg_Object) return Diagnostic_Kind
- is (if E_Msg.Warn_Chr = "* " then Restriction_Warning
- elsif E_Msg.Warn_Chr = "? " then Default_Warning
- elsif E_Msg.Warn_Chr = " " then Tagless_Warning
- else Warning);
- -- NOTE: Some messages have both info and warning set to true. The old
- -- printer added the warning switch label but treated the message as
- -- an info message.
-
- function Get_Diagnostics_Kind (E_Msg : Error_Msg_Object)
- return Diagnostic_Kind
- is (if E_Msg.Kind = Erroutc.Warning then Get_Warning_Kind (E_Msg)
- elsif E_Msg.Kind = Erroutc.Style then Style
- elsif E_Msg.Kind = Erroutc.Info then Info
- elsif E_Msg.Kind = Erroutc.Non_Serious_Error then Non_Serious_Error
- else Error);
-
- -----------------------------------
- -- Convert_Errors_To_Diagnostics --
- -----------------------------------
-
- procedure Convert_Errors_To_Diagnostics
- is
- E : Error_Msg_Id;
- begin
- E := First_Error_Msg;
- while E /= No_Error_Msg loop
-
- if not Errors.Table (E).Deleted
- and then not Errors.Table (E).Msg_Cont
- then
-
- -- We do not need to update the count of converted error messages
- -- since they are accounted for in their creation.
-
- Record_Diagnostic (Convert (E), Update_Count => False);
- end if;
-
- E := Errors.Table (E).Next;
- end loop;
-
- end Convert_Errors_To_Diagnostics;
-
- ----------------------------
- -- Convert_Sub_Diagnostic --
- ----------------------------
-
- function Convert_Sub_Diagnostic
- (E_Id : Error_Msg_Id) return Sub_Diagnostic_Type
- is
- E_Msg : constant Error_Msg_Object := Errors.Table (E_Id);
- D : Sub_Diagnostic_Type;
- begin
- D.Message := E_Msg.Text;
-
- -- All converted sub-diagnostics are continuations. When emitted they
- -- shall be printed with the same kind token as the main diagnostic.
- D.Kind := Continuation;
-
- Add_Location (D,
- Primary_Labeled_Span
- (if E_Msg.Insertion_Sloc /= No_Location
- then To_Span (E_Msg.Insertion_Sloc)
- else E_Msg.Sptr));
-
- if E_Msg.Optr.Ptr /= E_Msg.Sptr.Ptr then
- Add_Location (D, Secondary_Labeled_Span (E_Msg.Optr));
- end if;
-
- return D;
- end Convert_Sub_Diagnostic;
-
- -------------
- -- Convert --
- -------------
-
- function Convert (E_Id : Error_Msg_Id) return Diagnostic_Type is
-
- E_Next_Id : Error_Msg_Id;
-
- E_Msg : constant Error_Msg_Object := Errors.Table (E_Id);
- D : Diagnostic_Type;
- begin
- D.Message := E_Msg.Text;
-
- D.Kind := Get_Diagnostics_Kind (E_Msg);
-
- if E_Msg.Kind in Erroutc.Warning | Erroutc.Style | Erroutc.Info then
- D.Switch := Get_Switch_Id (E_Msg);
- end if;
-
- D.Warn_Err := E_Msg.Warn_Err;
-
- -- Convert the primary location
-
- Add_Location (D, Primary_Labeled_Span (E_Msg.Sptr));
-
- -- Convert the secondary location if it is different from the primary
-
- if E_Msg.Optr.Ptr /= E_Msg.Sptr.Ptr then
- Add_Location (D, Secondary_Labeled_Span (E_Msg.Optr));
- end if;
-
- E_Next_Id := Errors.Table (E_Id).Next;
- while E_Next_Id /= No_Error_Msg
- and then Errors.Table (E_Next_Id).Msg_Cont
- loop
- Add_Sub_Diagnostic (D, Convert_Sub_Diagnostic (E_Next_Id));
- E_Next_Id := Errors.Table (E_Next_Id).Next;
- end loop;
-
- return D;
- end Convert;
-
- ----------------------
- -- Emit_Diagnostics --
- ----------------------
-
- procedure Emit_Diagnostics is
- D : Diagnostic_Type;
-
- It : Iterator := Iterate (All_Diagnostics);
-
- Sarif_File_Name : constant String :=
- Get_First_Main_File_Name & ".gnat.sarif";
-
- Switches_File_Name : constant String := "gnat_switches.json";
-
- Diagnostics_File_Name : constant String := "gnat_diagnostics.json";
-
- Dummy : Boolean;
- begin
- if Opt.SARIF_Output then
- Set_Standard_Error;
-
- Print_SARIF_Report (All_Diagnostics);
-
- Set_Standard_Output;
- elsif Opt.SARIF_File then
- Delete_File (Sarif_File_Name, Dummy);
- declare
- Output_FD : constant File_Descriptor :=
- Create_New_File
- (Sarif_File_Name,
- Fmode => Text);
-
- begin
- Set_Output (Output_FD);
-
- Print_SARIF_Report (All_Diagnostics);
-
- Set_Standard_Output;
-
- Close (Output_FD);
- end;
- else
- Set_Standard_Error;
-
- while Has_Next (It) loop
- Next (It, D);
-
- Print_Diagnostic (D);
- end loop;
-
- Set_Standard_Output;
- end if;
-
- if Debug_Flag_Underscore_EE then
-
- -- Print the switch repository to a file
-
- Delete_File (Switches_File_Name, Dummy);
- declare
- Output_FD : constant File_Descriptor :=
- Create_New_File
- (Switches_File_Name,
- Fmode => Text);
-
- begin
- Set_Output (Output_FD);
-
- Print_Switch_Repository;
-
- Set_Standard_Output;
-
- Close (Output_FD);
- end;
-
- -- Print the diagnostics repository to a file
-
- Delete_File (Diagnostics_File_Name, Dummy);
- declare
- Output_FD : constant File_Descriptor :=
- Create_New_File
- (Diagnostics_File_Name,
- Fmode => Text);
-
- begin
- Set_Output (Output_FD);
-
- Print_Diagnostic_Repository;
-
- Set_Standard_Output;
-
- Close (Output_FD);
- end;
- end if;
-
- Destroy (All_Diagnostics);
- end Emit_Diagnostics;
-
-end Diagnostics.Converter;
diff --git a/gcc/ada/diagnostics-converter.ads b/gcc/ada/diagnostics-converter.ads
deleted file mode 100644
index a3b1579..0000000
--- a/gcc/ada/diagnostics-converter.ads
+++ /dev/null
@@ -1,31 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- D I A G N O S T I C S . C O N V E R T E R --
--- --
--- S p e c --
--- --
--- Copyright (C) 1992-2025, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-package Diagnostics.Converter is
-
- procedure Convert_Errors_To_Diagnostics;
-
- procedure Emit_Diagnostics;
-end Diagnostics.Converter;
diff --git a/gcc/ada/diagnostics-switch_repository.ads b/gcc/ada/diagnostics-switch_repository.ads
deleted file mode 100644
index afc4d1f..0000000
--- a/gcc/ada/diagnostics-switch_repository.ads
+++ /dev/null
@@ -1,39 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- D I A G N O S T I C S . D I A G N O S T I C S _ R E P O S I T O R Y --
--- --
--- S p e c --
--- --
--- Copyright (C) 1992-2025, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-with Erroutc; use Erroutc;
-
-package Diagnostics.Switch_Repository is
-
- function Get_Switch (Id : Switch_Id) return Switch_Type;
-
- function Get_Switch (Diag : Diagnostic_Type) return Switch_Type;
-
- function Get_Switch_Id (E : Error_Msg_Object) return Switch_Id;
-
- function Get_Switch_Id (Name : String) return Switch_Id;
-
- procedure Print_Switch_Repository;
-
-end Diagnostics.Switch_Repository;
diff --git a/gcc/ada/diagnostics-utils.adb b/gcc/ada/diagnostics-utils.adb
deleted file mode 100644
index abde955..0000000
--- a/gcc/ada/diagnostics-utils.adb
+++ /dev/null
@@ -1,357 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- D I A G N O S T I C S . U T I L S --
--- --
--- B o d y --
--- --
--- Copyright (C) 1992-2025, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-with Diagnostics.Repository; use Diagnostics.Repository;
-with Diagnostics.Switch_Repository; use Diagnostics.Switch_Repository;
-with Errout; use Errout;
-with Erroutc; use Erroutc;
-with Namet; use Namet;
-with Opt; use Opt;
-with Sinput; use Sinput;
-with Sinfo.Nodes; use Sinfo.Nodes;
-with Warnsw; use Warnsw;
-
-package body Diagnostics.Utils is
-
- ------------------
- -- Get_Human_Id --
- ------------------
-
- function Get_Human_Id (D : Diagnostic_Type) return String_Ptr is
- begin
- if D.Switch = No_Switch_Id then
- return Diagnostic_Entries (D.Id).Human_Id;
- else
- return Get_Switch (D).Human_Id;
- end if;
- end Get_Human_Id;
-
- ------------------
- -- To_File_Name --
- ------------------
-
- function To_File_Name (Sptr : Source_Ptr) return String is
- Sfile : constant Source_File_Index := Get_Source_File_Index (Sptr);
- Ref_Name : constant File_Name_Type :=
- (if Full_Path_Name_For_Brief_Errors then Full_Ref_Name (Sfile)
- else Reference_Name (Sfile));
-
- begin
- return Get_Name_String (Ref_Name);
- end To_File_Name;
-
- --------------------
- -- Line_To_String --
- --------------------
-
- function Line_To_String (Sptr : Source_Ptr) return String is
- Line : constant Logical_Line_Number := Get_Logical_Line_Number (Sptr);
- Img_Raw : constant String := Int'Image (Int (Line));
-
- begin
- return Img_Raw (Img_Raw'First + 1 .. Img_Raw'Last);
- end Line_To_String;
-
- ----------------------
- -- Column_To_String --
- ----------------------
-
- function Column_To_String (Sptr : Source_Ptr) return String is
- Col : constant Column_Number := Get_Column_Number (Sptr);
- Img_Raw : constant String := Int'Image (Int (Col));
-
- begin
- return
- (if Col < 10 then "0" else "")
- & Img_Raw (Img_Raw'First + 1 .. Img_Raw'Last);
- end Column_To_String;
-
- ---------------
- -- To_String --
- ---------------
-
- function To_String (Sptr : Source_Ptr) return String is
- begin
- return
- To_File_Name (Sptr) & ":" & Line_To_String (Sptr) & ":"
- & Column_To_String (Sptr);
- end To_String;
-
- --------------------
- -- Sloc_To_String --
- --------------------
-
- function Sloc_To_String
- (N : Node_Or_Entity_Id; Ref : Source_Ptr) return String
- is
-
- begin
- return Sloc_To_String (Sloc (N), Ref);
- end Sloc_To_String;
-
- --------------------
- -- Sloc_To_String --
- --------------------
-
- function Sloc_To_String (Sptr : Source_Ptr; Ref : Source_Ptr) return String
- is
-
- begin
- if Sptr = No_Location then
- return "at unknown location";
-
- elsif Sptr = System_Location then
- return "in package System";
-
- elsif Sptr = Standard_Location then
- return "in package Standard";
-
- elsif Sptr = Standard_ASCII_Location then
- return "in package Standard.ASCII";
-
- else
- if Full_File_Name (Get_Source_File_Index (Sptr))
- /= Full_File_Name (Get_Source_File_Index (Ref))
- then
- return "at " & To_String (Sptr);
- else
- return "at line " & Line_To_String (Sptr);
- end if;
- end if;
- end Sloc_To_String;
-
- ------------------
- -- To_Full_Span --
- ------------------
-
- function To_Full_Span (N : Node_Id) return Source_Span
- is
- Fst, Lst : Node_Id;
- begin
- First_And_Last_Nodes (N, Fst, Lst);
- return To_Span (Ptr => Sloc (N),
- First => First_Sloc (Fst),
- Last => Last_Sloc (Lst));
- end To_Full_Span;
-
- ---------------
- -- To_String --
- ---------------
-
- function To_String (Id : Diagnostic_Id) return String is
- begin
- if Id = No_Diagnostic_Id then
- return "GNAT0000";
- else
- return Id'Img;
- end if;
- end To_String;
-
- -------------
- -- To_Name --
- -------------
-
- function To_Name (E : Entity_Id) return String is
- begin
- -- The name of the node operator "&" has many special cases. Reuse the
- -- node to name conversion implementation from the errout package for
- -- now.
-
- Error_Msg_Node_1 := E;
- Set_Msg_Text ("&", Sloc (E));
-
- return Msg_Buffer (1 .. Msglen);
- end To_Name;
-
- ------------------
- -- To_Type_Name --
- ------------------
-
- function To_Type_Name (E : Entity_Id) return String is
- begin
- Error_Msg_Node_1 := E;
- Set_Msg_Text ("}", Sloc (E));
-
- return Msg_Buffer (1 .. Msglen);
- end To_Type_Name;
-
- --------------------
- -- Kind_To_String --
- --------------------
-
- function Kind_To_String
- (D : Sub_Diagnostic_Type;
- Parent : Diagnostic_Type) return String
- is
- (case D.Kind is
- when Continuation => Kind_To_String (Parent),
- when Help => "help",
- when Note => "note",
- when Suggestion => "suggestion");
-
- --------------------
- -- Kind_To_String --
- --------------------
-
- function Kind_To_String (D : Diagnostic_Type) return String is
- (if D.Warn_Err then "error"
- else
- (case D.Kind is
- when Diagnostics.Error | Non_Serious_Error => "error",
- when Warning | Restriction_Warning | Default_Warning |
- Tagless_Warning => "warning",
- when Style => "style",
- when Info => "info"));
-
- ------------------------------
- -- Get_Primary_Labeled_Span --
- ------------------------------
-
- function Get_Primary_Labeled_Span (Spans : Labeled_Span_List)
- return Labeled_Span_Type
- is
- use Labeled_Span_Lists;
-
- S : Labeled_Span_Type;
- It : Iterator;
- begin
- if Present (Spans) then
- It := Iterate (Spans);
- while Has_Next (It) loop
- Next (It, S);
- if S.Is_Primary then
- return S;
- end if;
- end loop;
- end if;
-
- return No_Labeled_Span;
- end Get_Primary_Labeled_Span;
-
- --------------------
- -- Get_Doc_Switch --
- --------------------
-
- function Get_Doc_Switch (Diag : Diagnostic_Type) return String is
- begin
- if Warning_Doc_Switch
- and then Diag.Kind in Default_Warning
- | Info
- | Restriction_Warning
- | Style
- | Warning
- then
- if Diag.Switch = No_Switch_Id then
- if Diag.Kind = Restriction_Warning then
- return "[restriction warning]";
-
- -- Info messages can have a switch tag but they should not have
- -- a default switch tag.
-
- elsif Diag.Kind /= Info then
-
- -- For Default_Warning
-
- return "[enabled by default]";
- end if;
- else
- declare
- S : constant Switch_Type := Get_Switch (Diag);
- begin
- return "[-" & S.Short_Name.all & "]";
- end;
- end if;
- end if;
-
- return "";
- end Get_Doc_Switch;
-
- --------------------
- -- Appears_Before --
- --------------------
-
- function Appears_Before (D1, D2 : Diagnostic_Type) return Boolean is
-
- begin
- return Appears_Before (Primary_Location (D1).Span.Ptr,
- Primary_Location (D2).Span.Ptr);
- end Appears_Before;
-
- --------------------
- -- Appears_Before --
- --------------------
-
- function Appears_Before (P1, P2 : Source_Ptr) return Boolean is
-
- begin
- if Get_Source_File_Index (P1) = Get_Source_File_Index (P2) then
- if Get_Logical_Line_Number (P1) = Get_Logical_Line_Number (P2) then
- return Get_Column_Number (P1) < Get_Column_Number (P2);
- else
- return Get_Logical_Line_Number (P1) < Get_Logical_Line_Number (P2);
- end if;
- else
- return Get_Source_File_Index (P1) < Get_Source_File_Index (P2);
- end if;
- end Appears_Before;
-
- ------------------------------
- -- Insert_Based_On_Location --
- ------------------------------
-
- procedure Insert_Based_On_Location
- (List : Diagnostic_List;
- Diagnostic : Diagnostic_Type)
- is
- use Diagnostics_Lists;
-
- It : Iterator := Iterate (List);
- D : Diagnostic_Type;
- begin
- -- This is the common scenario where the error is reported at the
- -- natural order the tree is processed. This saves a lot of time when
- -- looking for the correct position in the list when there are a lot of
- -- diagnostics.
-
- if Present (List) and then
- not Is_Empty (List) and then
- Appears_Before (Last (List), Diagnostic)
- then
- Append (List, Diagnostic);
- else
- while Has_Next (It) loop
- Next (It, D);
-
- if Appears_Before (Diagnostic, D) then
- Insert_Before (List, D, Diagnostic);
- return;
- end if;
- end loop;
-
- Append (List, Diagnostic);
- end if;
- end Insert_Based_On_Location;
-
-end Diagnostics.Utils;
diff --git a/gcc/ada/diagnostics-utils.ads b/gcc/ada/diagnostics-utils.ads
deleted file mode 100644
index 33cd67f..0000000
--- a/gcc/ada/diagnostics-utils.ads
+++ /dev/null
@@ -1,91 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- D I A G N O S T I C S . U T I L S --
--- --
--- S p e c --
--- --
--- Copyright (C) 1992-2025, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-package Diagnostics.Utils is
-
- function Get_Human_Id (D : Diagnostic_Type) return String_Ptr;
-
- function Sloc_To_String (Sptr : Source_Ptr; Ref : Source_Ptr) return String;
- -- Convert the source pointer to a string and prefix it with the correct
- -- preposition.
- --
- -- * If the location is in one of the standard locations,
- -- then it yields "in package <LOCATION>". The explicit standard
- -- locations are:
- -- * System
- -- * Standard
- -- * Standard.ASCII
- -- * if the location is missing the the sloc yields "at unknown location"
- -- * if the location is in the same file as the current file,
- -- then it yields "at line <line>".
- -- * Otherwise sloc yields "at <file>:<line>:<column>"
-
- function Sloc_To_String (N : Node_Or_Entity_Id;
- Ref : Source_Ptr)
- return String;
- -- Converts the Sloc of the node or entity to a Sloc string.
-
- function To_String (Sptr : Source_Ptr) return String;
- -- Convert the source pointer to a string of the form: "file:line:column"
-
- function To_File_Name (Sptr : Source_Ptr) return String;
- -- Converts the file name of the Sptr to a string.
-
- function Line_To_String (Sptr : Source_Ptr) return String;
- -- Converts the logical line number of the Sptr to a string.
-
- function Column_To_String (Sptr : Source_Ptr) return String;
- -- Converts the column number of the Sptr to a string. Column values less
- -- than 10 are prefixed with a 0.
-
- function To_Full_Span (N : Node_Id) return Source_Span;
-
- function To_String (Id : Diagnostic_Id) return String;
- -- Convert the diagnostic ID to a 4 character string padded with 0-s.
-
- function To_Name (E : Entity_Id) return String;
-
- function To_Type_Name (E : Entity_Id) return String;
-
- function Kind_To_String (D : Diagnostic_Type) return String;
-
- function Kind_To_String
- (D : Sub_Diagnostic_Type;
- Parent : Diagnostic_Type) return String;
-
- function Get_Primary_Labeled_Span (Spans : Labeled_Span_List)
- return Labeled_Span_Type;
-
- function Get_Doc_Switch (Diag : Diagnostic_Type) return String;
-
- function Appears_Before (D1, D2 : Diagnostic_Type) return Boolean;
-
- function Appears_Before (P1, P2 : Source_Ptr) return Boolean;
-
- procedure Insert_Based_On_Location
- (List : Diagnostic_List;
- Diagnostic : Diagnostic_Type);
-
-end Diagnostics.Utils;
diff --git a/gcc/ada/diagnostics.adb b/gcc/ada/diagnostics.adb
deleted file mode 100644
index c98eda2..0000000
--- a/gcc/ada/diagnostics.adb
+++ /dev/null
@@ -1,539 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- D I A G N O S T I C S --
--- --
--- B o d y --
--- --
--- Copyright (C) 1992-2025, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-with Atree; use Atree;
-with Debug; use Debug;
-with Diagnostics.Brief_Emitter;
-with Diagnostics.Pretty_Emitter;
-with Diagnostics.Repository; use Diagnostics.Repository;
-with Diagnostics.Utils; use Diagnostics.Utils;
-with Lib; use Lib;
-with Opt; use Opt;
-with Sinput; use Sinput;
-with Warnsw;
-
-package body Diagnostics is
-
- -------------
- -- Destroy --
- -------------
-
- procedure Destroy (Elem : in out Labeled_Span_Type) is
- begin
- Free (Elem.Label);
- end Destroy;
-
- -------------
- -- Destroy --
- -------------
-
- procedure Destroy (Elem : in out Sub_Diagnostic_Type) is
- begin
- Free (Elem.Message);
- if Labeled_Span_Lists.Present (Elem.Locations) then
- Labeled_Span_Lists.Destroy (Elem.Locations);
- end if;
- end Destroy;
-
- -------------
- -- Destroy --
- -------------
-
- procedure Destroy (Elem : in out Edit_Type) is
- begin
- Free (Elem.Text);
- end Destroy;
-
- -------------
- -- Destroy --
- -------------
-
- procedure Destroy (Elem : in out Fix_Type) is
- begin
- Free (Elem.Description);
- if Edit_Lists.Present (Elem.Edits) then
- Edit_Lists.Destroy (Elem.Edits);
- end if;
- end Destroy;
-
- -------------
- -- Destroy --
- -------------
-
- procedure Destroy (Elem : in out Diagnostic_Type) is
- begin
- Free (Elem.Message);
- if Labeled_Span_Lists.Present (Elem.Locations) then
- Labeled_Span_Lists.Destroy (Elem.Locations);
- end if;
- if Sub_Diagnostic_Lists.Present (Elem.Sub_Diagnostics) then
- Sub_Diagnostic_Lists.Destroy (Elem.Sub_Diagnostics);
- end if;
- if Fix_Lists.Present (Elem.Fixes) then
- Fix_Lists.Destroy (Elem.Fixes);
- end if;
- end Destroy;
-
- ------------------
- -- Add_Location --
- ------------------
-
- procedure Add_Location
- (Diagnostic : in out Sub_Diagnostic_Type; Location : Labeled_Span_Type)
- is
- use Labeled_Span_Lists;
- begin
- if not Present (Diagnostic.Locations) then
- Diagnostic.Locations := Create;
- end if;
-
- Append (Diagnostic.Locations, Location);
- end Add_Location;
-
- ----------------------
- -- Primary_Location --
- ----------------------
-
- function Primary_Location
- (Diagnostic : Sub_Diagnostic_Type) return Labeled_Span_Type
- is
- begin
- return Get_Primary_Labeled_Span (Diagnostic.Locations);
- end Primary_Location;
-
- ------------------
- -- Add_Location --
- ------------------
-
- procedure Add_Location
- (Diagnostic : in out Diagnostic_Type; Location : Labeled_Span_Type)
- is
- use Labeled_Span_Lists;
- begin
- if not Present (Diagnostic.Locations) then
- Diagnostic.Locations := Create;
- end if;
-
- Append (Diagnostic.Locations, Location);
- end Add_Location;
-
- ------------------------
- -- Add_Sub_Diagnostic --
- ------------------------
-
- procedure Add_Sub_Diagnostic
- (Diagnostic : in out Diagnostic_Type;
- Sub_Diagnostic : Sub_Diagnostic_Type)
- is
- use Sub_Diagnostic_Lists;
- begin
- if not Present (Diagnostic.Sub_Diagnostics) then
- Diagnostic.Sub_Diagnostics := Create;
- end if;
-
- Append (Diagnostic.Sub_Diagnostics, Sub_Diagnostic);
- end Add_Sub_Diagnostic;
-
- procedure Add_Edit (Fix : in out Fix_Type; Edit : Edit_Type) is
- use Edit_Lists;
- begin
- if not Present (Fix.Edits) then
- Fix.Edits := Create;
- end if;
-
- Append (Fix.Edits, Edit);
- end Add_Edit;
-
- -------------
- -- Add_Fix --
- -------------
-
- procedure Add_Fix (Diagnostic : in out Diagnostic_Type; Fix : Fix_Type) is
- use Fix_Lists;
- begin
- if not Present (Diagnostic.Fixes) then
- Diagnostic.Fixes := Create;
- end if;
-
- Append (Diagnostic.Fixes, Fix);
- end Add_Fix;
-
- -----------------------
- -- Record_Diagnostic --
- -----------------------
-
- procedure Record_Diagnostic (Diagnostic : Diagnostic_Type;
- Update_Count : Boolean := True)
- is
-
- procedure Update_Diagnostic_Count (Diagnostic : Diagnostic_Type);
-
- -----------------------------
- -- Update_Diagnostic_Count --
- -----------------------------
-
- procedure Update_Diagnostic_Count (Diagnostic : Diagnostic_Type) is
-
- begin
- case Diagnostic.Kind is
- when Error =>
- Total_Errors_Detected := Total_Errors_Detected + 1;
- Serious_Errors_Detected := Serious_Errors_Detected + 1;
-
- when Non_Serious_Error =>
- Total_Errors_Detected := Total_Errors_Detected + 1;
-
- when Warning
- | Default_Warning
- | Tagless_Warning
- | Restriction_Warning
- | Style
- =>
- Warnings_Detected := Warnings_Detected + 1;
-
- if Diagnostic.Warn_Err then
- Warnings_Treated_As_Errors := Warnings_Treated_As_Errors + 1;
- end if;
-
- when Info =>
- Info_Messages := Info_Messages + 1;
- end case;
- end Update_Diagnostic_Count;
-
- procedure Handle_Serious_Error;
- -- Internal procedure to do all error message handling for a serious
- -- error message, other than bumping the error counts and arranging
- -- for the message to be output.
-
- procedure Handle_Serious_Error is
- begin
- -- Turn off code generation if not done already
-
- if Operating_Mode = Generate_Code then
- Operating_Mode := Check_Semantics;
- Expander_Active := False;
- end if;
-
- -- Set the fatal error flag in the unit table unless we are in
- -- Try_Semantics mode (in which case we set ignored mode if not
- -- currently set. This stops the semantics from being performed
- -- if we find a serious error. This is skipped if we are currently
- -- dealing with the configuration pragma file.
-
- if Current_Source_Unit /= No_Unit then
- declare
- U : constant Unit_Number_Type :=
- Get_Source_Unit
- (Primary_Location (Diagnostic).Span.Ptr);
- begin
- if Try_Semantics then
- if Fatal_Error (U) = None then
- Set_Fatal_Error (U, Error_Ignored);
- end if;
- else
- Set_Fatal_Error (U, Error_Detected);
- end if;
- end;
- end if;
-
- -- Disable warnings on unused use clauses and the like. Otherwise, an
- -- error might hide a reference to an entity in a used package, so
- -- after fixing the error, the use clause no longer looks like it was
- -- unused.
-
- Warnsw.Check_Unreferenced := False;
- Warnsw.Check_Unreferenced_Formals := False;
- end Handle_Serious_Error;
- begin
- Insert_Based_On_Location (All_Diagnostics, Diagnostic);
-
- if Update_Count then
- Update_Diagnostic_Count (Diagnostic);
- end if;
-
- if Diagnostic.Kind = Error then
- Handle_Serious_Error;
- end if;
- end Record_Diagnostic;
-
- ----------------------
- -- Print_Diagnostic --
- ----------------------
-
- procedure Print_Diagnostic (Diagnostic : Diagnostic_Type) is
-
- begin
- if Debug_Flag_FF then
- Diagnostics.Pretty_Emitter.Print_Diagnostic (Diagnostic);
- else
- Diagnostics.Brief_Emitter.Print_Diagnostic (Diagnostic);
- end if;
- end Print_Diagnostic;
-
- ----------------------
- -- Primary_Location --
- ----------------------
-
- function Primary_Location
- (Diagnostic : Diagnostic_Type) return Labeled_Span_Type
- is
- begin
- return Get_Primary_Labeled_Span (Diagnostic.Locations);
- end Primary_Location;
-
- ---------------------
- -- Make_Diagnostic --
- ---------------------
-
- function Make_Diagnostic
- (Msg : String;
- Location : Labeled_Span_Type;
- Id : Diagnostic_Id := No_Diagnostic_Id;
- Kind : Diagnostic_Kind := Diagnostics.Error;
- Switch : Switch_Id := No_Switch_Id;
- Spans : Labeled_Span_Array := No_Locations;
- Sub_Diags : Sub_Diagnostic_Array := No_Sub_Diags;
- Fixes : Fix_Array := No_Fixes)
- return Diagnostic_Type
- is
- D : Diagnostic_Type;
- begin
- D.Message := new String'(Msg);
- D.Id := Id;
- D.Kind := Kind;
-
- if Id /= No_Diagnostic_Id then
- pragma Assert (Switch = Diagnostic_Entries (Id).Switch,
- "Provided switch must be the same as in the registry");
- end if;
- D.Switch := Switch;
-
- pragma Assert (Location.Is_Primary, "Main location must be primary");
- Add_Location (D, Location);
-
- for I in Spans'Range loop
- Add_Location (D, Spans (I));
- end loop;
-
- for I in Sub_Diags'Range loop
- Add_Sub_Diagnostic (D, Sub_Diags (I));
- end loop;
-
- for I in Fixes'Range loop
- Add_Fix (D, Fixes (I));
- end loop;
-
- return D;
- end Make_Diagnostic;
-
- -----------------------
- -- Record_Diagnostic --
- -----------------------
-
- procedure Record_Diagnostic
- (Msg : String;
- Location : Labeled_Span_Type;
- Id : Diagnostic_Id := No_Diagnostic_Id;
- Kind : Diagnostic_Kind := Diagnostics.Error;
- Switch : Switch_Id := No_Switch_Id;
- Spans : Labeled_Span_Array := No_Locations;
- Sub_Diags : Sub_Diagnostic_Array := No_Sub_Diags;
- Fixes : Fix_Array := No_Fixes)
- is
-
- begin
- Record_Diagnostic
- (Make_Diagnostic
- (Msg => Msg,
- Location => Location,
- Id => Id,
- Kind => Kind,
- Switch => Switch,
- Spans => Spans,
- Sub_Diags => Sub_Diags,
- Fixes => Fixes));
- end Record_Diagnostic;
-
- ------------------
- -- Labeled_Span --
- ------------------
-
- function Labeled_Span (Span : Source_Span;
- Label : String := "";
- Is_Primary : Boolean := True;
- Is_Region : Boolean := False)
- return Labeled_Span_Type
- is
- L : Labeled_Span_Type;
- begin
- L.Span := Span;
- if Label /= "" then
- L.Label := new String'(Label);
- end if;
- L.Is_Primary := Is_Primary;
- L.Is_Region := Is_Region;
-
- return L;
- end Labeled_Span;
-
- --------------------------
- -- Primary_Labeled_Span --
- --------------------------
-
- function Primary_Labeled_Span (Span : Source_Span;
- Label : String := "")
- return Labeled_Span_Type
- is begin
- return Labeled_Span (Span => Span, Label => Label, Is_Primary => True);
- end Primary_Labeled_Span;
-
- --------------------------
- -- Primary_Labeled_Span --
- --------------------------
-
- function Primary_Labeled_Span (N : Node_Or_Entity_Id;
- Label : String := "")
- return Labeled_Span_Type
- is
- begin
- return Primary_Labeled_Span (To_Full_Span (N), Label);
- end Primary_Labeled_Span;
-
- ----------------------------
- -- Secondary_Labeled_Span --
- ----------------------------
-
- function Secondary_Labeled_Span
- (Span : Source_Span;
- Label : String := "")
- return Labeled_Span_Type
- is
- begin
- return Labeled_Span (Span => Span, Label => Label, Is_Primary => False);
- end Secondary_Labeled_Span;
-
- ----------------------------
- -- Secondary_Labeled_Span --
- ----------------------------
-
- function Secondary_Labeled_Span (N : Node_Or_Entity_Id;
- Label : String := "")
- return Labeled_Span_Type
- is
- begin
- return Secondary_Labeled_Span (To_Full_Span (N), Label);
- end Secondary_Labeled_Span;
-
- --------------
- -- Sub_Diag --
- --------------
-
- function Sub_Diag (Msg : String;
- Kind : Sub_Diagnostic_Kind :=
- Diagnostics.Continuation;
- Locations : Labeled_Span_Array := No_Locations)
- return Sub_Diagnostic_Type
- is
- S : Sub_Diagnostic_Type;
- begin
- S.Message := new String'(Msg);
- S.Kind := Kind;
-
- for I in Locations'Range loop
- Add_Location (S, Locations (I));
- end loop;
-
- return S;
- end Sub_Diag;
-
- ------------------
- -- Continuation --
- ------------------
-
- function Continuation (Msg : String;
- Locations : Labeled_Span_Array := No_Locations)
- return Sub_Diagnostic_Type
- is
- begin
- return Sub_Diag (Msg, Diagnostics.Continuation, Locations);
- end Continuation;
-
- ----------
- -- Help --
- ----------
-
- function Help (Msg : String;
- Locations : Labeled_Span_Array := No_Locations)
- return Sub_Diagnostic_Type
- is
- begin
- return Sub_Diag (Msg, Diagnostics.Help, Locations);
- end Help;
-
- ----------------
- -- Suggestion --
- ----------------
-
- function Suggestion (Msg : String;
- Locations : Labeled_Span_Array := No_Locations)
- return Sub_Diagnostic_Type
- is
- begin
- return Sub_Diag (Msg, Diagnostics.Suggestion, Locations);
- end Suggestion;
-
- ---------
- -- Fix --
- ---------
-
- function Fix
- (Description : String;
- Edits : Edit_Array;
- Applicability : Applicability_Type := Unspecified) return Fix_Type
- is
- F : Fix_Type;
- begin
- F.Description := new String'(Description);
-
- for I in Edits'Range loop
- Add_Edit (F, Edits (I));
- end loop;
-
- F.Applicability := Applicability;
-
- return F;
- end Fix;
-
- ----------
- -- Edit --
- ----------
-
- function Edit (Text : String; Span : Source_Span) return Edit_Type is
-
- begin
- return (Text => new String'(Text), Span => Span);
- end Edit;
-
-end Diagnostics;
diff --git a/gcc/ada/diagnostics.ads b/gcc/ada/diagnostics.ads
deleted file mode 100644
index 67a8c20..0000000
--- a/gcc/ada/diagnostics.ads
+++ /dev/null
@@ -1,477 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- D I A G N O S T I C S --
--- --
--- S p e c --
--- --
--- Copyright (C) 1992-2025, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-with Types; use Types;
-with GNAT.Lists; use GNAT.Lists;
-
-package Diagnostics is
-
- type Diagnostic_Id is
- (No_Diagnostic_Id,
- GNAT0001,
- GNAT0002,
- GNAT0003,
- GNAT0004,
- GNAT0005,
- GNAT0006,
- GNAT0007,
- GNAT0008,
- GNAT0009,
- GNAT0010,
- GNAT0011);
-
- -- Labeled_Span_Type represents a span of source code that is associated
- -- with a textual label. Primary spans indicate the primary location of the
- -- diagnostic. Non-primary spans are used to indicate secondary locations.
- --
- -- Spans can contain labels that are used to annotate the highlighted span.
- -- Usually, the label is a short and concise message that provide
- -- additional allthough non-critical information about the span. This is
- -- an important since labels are not printed in the brief output and are
- -- only present in the pretty and structural outputs. That is an important
- -- distintion when choosing between a label and a sub-diagnostic.
- type Labeled_Span_Type is record
- Label : String_Ptr := null;
- -- Text associated with the span
-
- Span : Source_Span := (others => No_Location);
- -- Textual region in the source code
-
- Is_Primary : Boolean := True;
- -- Primary spans are used to indicate the primary location of the
- -- diagnostic. Typically there should just be one primary span per
- -- diagnostic.
- -- Non-primary spans are used to indicate secondary locations and
- -- typically are formatted in a different way or omitted in some
- -- contexts.
-
- Is_Region : Boolean := False;
- -- Regional spans are multiline spans that have a unique way of being
- -- displayed in the pretty output.
- end record;
-
- No_Labeled_Span : constant Labeled_Span_Type := (others => <>);
-
- procedure Destroy (Elem : in out Labeled_Span_Type);
- pragma Inline (Destroy);
-
- package Labeled_Span_Lists is new Doubly_Linked_Lists
- (Element_Type => Labeled_Span_Type,
- "=" => "=",
- Destroy_Element => Destroy,
- Check_Tampering => False);
- subtype Labeled_Span_List is Labeled_Span_Lists.Doubly_Linked_List;
-
- type Sub_Diagnostic_Kind is
- (Continuation,
- Help,
- Note,
- Suggestion);
-
- -- Sub_Diagnostic_Type represents a sub-diagnostic message that is meant
- -- to provide additional information about the primary diagnostic message.
- --
- -- Sub-diagnostics are usually constructed with a full sentence as the
- -- message and provide important context to the main diagnostic message or
- -- some concrete action to the user.
- --
- -- This is different from the labels of labeled spans which are meant to be
- -- short and concise and are mostly there to annotate the higlighted span.
-
- type Sub_Diagnostic_Type is record
- Kind : Sub_Diagnostic_Kind;
-
- Message : String_Ptr;
-
- Locations : Labeled_Span_List;
- end record;
-
- procedure Add_Location
- (Diagnostic : in out Sub_Diagnostic_Type; Location : Labeled_Span_Type);
-
- function Primary_Location
- (Diagnostic : Sub_Diagnostic_Type) return Labeled_Span_Type;
-
- procedure Destroy (Elem : in out Sub_Diagnostic_Type);
- pragma Inline (Destroy);
-
- package Sub_Diagnostic_Lists is new Doubly_Linked_Lists
- (Element_Type => Sub_Diagnostic_Type,
- "=" => "=",
- Destroy_Element => Destroy,
- Check_Tampering => False);
-
- subtype Sub_Diagnostic_List is Sub_Diagnostic_Lists.Doubly_Linked_List;
-
- -- An Edit_Type represents a textual edit that is associated with a Fix.
- type Edit_Type is record
- Span : Source_Span;
- -- Region of the file to be removed
-
- Text : String_Ptr;
- -- Text to be inserted at the start location of the span
- end record;
-
- procedure Destroy (Elem : in out Edit_Type);
- pragma Inline (Destroy);
-
- package Edit_Lists is new Doubly_Linked_Lists
- (Element_Type => Edit_Type,
- "=" => "=",
- Destroy_Element => Destroy,
- Check_Tampering => False);
-
- subtype Edit_List is Edit_Lists.Doubly_Linked_List;
-
- -- Type Applicability_Type will indicate the state of the resulting code
- -- after applying a fix.
- -- * Option Has_Placeholders indicates that the fix contains placeholders
- -- that the user would need to fill.
- -- * Option Legal indicates that applying the fix will result in legal Ada
- -- code.
- -- * Option Possibly_Illegal indicates that applying the fix will result in
- -- possibly legal, but also possibly illegal Ada code.
- type Applicability_Type is
- (Has_Placeholders,
- Legal,
- Possibly_Illegal,
- Unspecified);
-
- type Fix_Type is record
- Description : String_Ptr := null;
- -- Message describing the fix that will be displayed to the user.
-
- Applicability : Applicability_Type := Unspecified;
-
- Edits : Edit_List;
- -- File changes for the fix.
- end record;
-
- procedure Destroy (Elem : in out Fix_Type);
- pragma Inline (Destroy);
-
- package Fix_Lists is new Doubly_Linked_Lists
- (Element_Type => Fix_Type,
- "=" => "=",
- Destroy_Element => Destroy,
- Check_Tampering => False);
-
- subtype Fix_List is Fix_Lists.Doubly_Linked_List;
-
- procedure Add_Edit (Fix : in out Fix_Type; Edit : Edit_Type);
-
- type Status_Type is
- (Active,
- Deprecated);
-
- type Switch_Id is (
- No_Switch_Id,
- gnatwb,
- gnatwc,
- gnatwd,
- gnatwf,
- gnatwg,
- gnatwh,
- gnatwi,
- gnatwj,
- gnatwk,
- gnatwl,
- gnatwm,
- gnatwo,
- gnatwp,
- gnatwq,
- gnatwr,
- gnatwt,
- gnatwu,
- gnatwv,
- gnatww,
- gnatwx,
- gnatwy,
- gnatwz,
- gnatw_dot_a,
- gnatw_dot_b,
- gnatw_dot_c,
- gnatw_dot_f,
- gnatw_dot_h,
- gnatw_dot_i,
- gnatw_dot_j,
- gnatw_dot_k,
- gnatw_dot_l,
- gnatw_dot_m,
- gnatw_dot_n,
- gnatw_dot_o,
- gnatw_dot_p,
- gnatw_dot_q,
- gnatw_dot_r,
- gnatw_dot_s,
- gnatw_dot_t,
- gnatw_dot_u,
- gnatw_dot_v,
- gnatw_dot_w,
- gnatw_dot_x,
- gnatw_dot_y,
- gnatw_dot_z,
- gnatw_underscore_a,
- gnatw_underscore_c,
- gnatw_underscore_j,
- gnatw_underscore_l,
- gnatw_underscore_p,
- gnatw_underscore_q,
- gnatw_underscore_r,
- gnatw_underscore_s,
- gnaty,
- gnatya,
- gnatyb,
- gnatyc,
- gnatyd,
- gnatye,
- gnatyf,
- gnatyh,
- gnatyi,
- gnatyk,
- gnatyl,
- gnatym,
- gnatyn,
- gnatyo,
- gnatyp,
- gnatyr,
- gnatys,
- gnatyu,
- gnatyx,
- gnatyz,
- gnatyaa,
- gnatybb,
- gnatycc,
- gnatydd,
- gnatyii,
- gnatyll,
- gnatymm,
- gnatyoo,
- gnatyss,
- gnatytt,
- gnatel
- );
-
- subtype Active_Switch_Id is Switch_Id range gnatwb .. gnatel;
- -- The range of switch ids that represent switches that trigger a specific
- -- diagnostic check.
-
- type Switch_Type is record
-
- Status : Status_Type := Active;
- -- The status will indicate whether the switch is currently active,
- -- or has been deprecated. A deprecated switch will not control
- -- diagnostics, and will not be emitted by the GNAT usage.
-
- Human_Id : String_Ptr := null;
- -- The Human_Id will be a unique and stable string-based ID which
- -- identifies the content of the switch within the switch registry.
- -- This ID will appear in SARIF readers.
-
- Short_Name : String_Ptr := null;
- -- The Short_Name will denote the -gnatXX name of the switch.
-
- Description : String_Ptr := null;
- -- The description will contain the description of the switch, as it is
- -- currently emitted by the GNAT usage.
-
- Documentation_Url : String_Ptr := null;
- -- The documentation_url will point to the AdaCore documentation site
- -- for the switch.
-
- end record;
-
- type Diagnostic_Kind is
- (Error,
- Non_Serious_Error,
- -- Typically all errors are considered serious and the compiler should
- -- stop its processing since the tree is essentially invalid. However,
- -- some errors are not serious and the compiler can continue its
- -- processing to discover more critical errors.
- Warning,
- Default_Warning,
- -- Warning representing the old warnings created with the '??' insertion
- -- character. These warning have the [enabled by default] tag.
- Restriction_Warning,
- -- Warning representing the old warnings created with the '?*?'
- -- insertion character. These warning have the [restriction warning]
- -- tag.
- Style,
- Tagless_Warning,
- -- Warning representing the old warnings created with the '?' insertion
- -- character.
- Info
- );
-
- type Diagnostic_Entry_Type is record
- Status : Status_Type := Active;
-
- Human_Id : String_Ptr := null;
- -- A human readable code for the diagnostic. If the diagnostic has a
- -- switch with a human id then the human_id of the switch shall be used
- -- in SARIF reports.
-
- Documentation : String_Ptr := null;
-
- Switch : Switch_Id := No_Switch_Id;
- -- The switch that controls the diagnostic message.
- end record;
-
- type Diagnostic_Type is record
-
- Id : Diagnostic_Id := No_Diagnostic_Id;
-
- Kind : Diagnostic_Kind := Error;
-
- Switch : Switch_Id := No_Switch_Id;
-
- Message : String_Ptr := null;
-
- Warn_Err : Boolean := False;
- -- Signal whether the diagnostic was converted from a warning to an
- -- error. This needs to be set during the message emission as this
- -- behavior depends on the context of the code.
-
- Locations : Labeled_Span_List := Labeled_Span_Lists.Nil;
-
- Sub_Diagnostics : Sub_Diagnostic_List := Sub_Diagnostic_Lists.Nil;
-
- Fixes : Fix_List := Fix_Lists.Nil;
- end record;
-
- procedure Destroy (Elem : in out Diagnostic_Type);
- pragma Inline (Destroy);
-
- package Diagnostics_Lists is new Doubly_Linked_Lists
- (Element_Type => Diagnostic_Type,
- "=" => "=",
- Destroy_Element => Destroy,
- Check_Tampering => False);
-
- subtype Diagnostic_List is Diagnostics_Lists.Doubly_Linked_List;
-
- All_Diagnostics : Diagnostic_List := Diagnostics_Lists.Create;
-
- procedure Add_Location
- (Diagnostic : in out Diagnostic_Type; Location : Labeled_Span_Type);
-
- procedure Add_Sub_Diagnostic
- (Diagnostic : in out Diagnostic_Type;
- Sub_Diagnostic : Sub_Diagnostic_Type);
-
- procedure Add_Fix (Diagnostic : in out Diagnostic_Type; Fix : Fix_Type);
-
- procedure Record_Diagnostic (Diagnostic : Diagnostic_Type;
- Update_Count : Boolean := True);
-
- procedure Print_Diagnostic (Diagnostic : Diagnostic_Type);
-
- function Primary_Location
- (Diagnostic : Diagnostic_Type) return Labeled_Span_Type;
-
- type Labeled_Span_Array is
- array (Positive range <>) of Labeled_Span_Type;
- type Sub_Diagnostic_Array is
- array (Positive range <>) of Sub_Diagnostic_Type;
- type Fix_Array is
- array (Positive range <>) of Fix_Type;
- type Edit_Array is
- array (Positive range <>) of Edit_Type;
-
- No_Locations : constant Labeled_Span_Array (1 .. 0) := (others => <>);
- No_Sub_Diags : constant Sub_Diagnostic_Array (1 .. 0) := (others => <>);
- No_Fixes : constant Fix_Array (1 .. 0) := (others => <>);
- No_Edits : constant Edit_Array (1 .. 0) := (others => <>);
-
- function Make_Diagnostic
- (Msg : String;
- Location : Labeled_Span_Type;
- Id : Diagnostic_Id := No_Diagnostic_Id;
- Kind : Diagnostic_Kind := Diagnostics.Error;
- Switch : Switch_Id := No_Switch_Id;
- Spans : Labeled_Span_Array := No_Locations;
- Sub_Diags : Sub_Diagnostic_Array := No_Sub_Diags;
- Fixes : Fix_Array := No_Fixes)
- return Diagnostic_Type;
-
- procedure Record_Diagnostic
- (Msg : String;
- Location : Labeled_Span_Type;
- Id : Diagnostic_Id := No_Diagnostic_Id;
- Kind : Diagnostic_Kind := Diagnostics.Error;
- Switch : Switch_Id := No_Switch_Id;
- Spans : Labeled_Span_Array := No_Locations;
- Sub_Diags : Sub_Diagnostic_Array := No_Sub_Diags;
- Fixes : Fix_Array := No_Fixes);
-
- function Labeled_Span (Span : Source_Span;
- Label : String := "";
- Is_Primary : Boolean := True;
- Is_Region : Boolean := False)
- return Labeled_Span_Type;
-
- function Primary_Labeled_Span (Span : Source_Span;
- Label : String := "")
- return Labeled_Span_Type;
-
- function Primary_Labeled_Span (N : Node_Or_Entity_Id;
- Label : String := "")
- return Labeled_Span_Type;
-
- function Secondary_Labeled_Span (Span : Source_Span;
- Label : String := "")
- return Labeled_Span_Type;
-
- function Secondary_Labeled_Span (N : Node_Or_Entity_Id;
- Label : String := "")
- return Labeled_Span_Type;
-
- function Sub_Diag (Msg : String;
- Kind : Sub_Diagnostic_Kind :=
- Diagnostics.Continuation;
- Locations : Labeled_Span_Array := No_Locations)
- return Sub_Diagnostic_Type;
-
- function Continuation (Msg : String;
- Locations : Labeled_Span_Array := No_Locations)
- return Sub_Diagnostic_Type;
-
- function Help (Msg : String;
- Locations : Labeled_Span_Array := No_Locations)
- return Sub_Diagnostic_Type;
-
- function Suggestion (Msg : String;
- Locations : Labeled_Span_Array := No_Locations)
- return Sub_Diagnostic_Type;
-
- function Fix (Description : String;
- Edits : Edit_Array;
- Applicability : Applicability_Type := Unspecified)
- return Fix_Type;
-
- function Edit (Text : String;
- Span : Source_Span)
- return Edit_Type;
-end Diagnostics;
diff --git a/gcc/ada/doc/gnat_rm.rst b/gcc/ada/doc/gnat_rm.rst
index e52f2a6..27551ca 100644
--- a/gcc/ada/doc/gnat_rm.rst
+++ b/gcc/ada/doc/gnat_rm.rst
@@ -54,7 +54,7 @@ GNAT Reference Manual
gnat_rm/interfacing_to_other_languages
gnat_rm/specialized_needs_annexes
gnat_rm/implementation_of_specific_ada_features
- gnat_rm/implementation_of_ada_2012_features
+ gnat_rm/implementation_of_ada_2022_features
gnat_rm/gnat_language_extensions
gnat_rm/security_hardening_features
gnat_rm/obsolescent_features
diff --git a/gcc/ada/doc/gnat_rm/about_this_guide.rst b/gcc/ada/doc/gnat_rm/about_this_guide.rst
index 9defee8..ff72194 100644
--- a/gcc/ada/doc/gnat_rm/about_this_guide.rst
+++ b/gcc/ada/doc/gnat_rm/about_this_guide.rst
@@ -14,7 +14,7 @@ GNAT compiler. It includes information on implementation dependent
characteristics of GNAT, including all the information required by
Annex M of the Ada language standard.
-GNAT implements Ada 95, Ada 2005 and Ada 2012, and it may also be
+GNAT implements Ada 95, Ada 2005, Ada 2012 and Ada 2022, and it may also be
invoked in Ada 83 compatibility mode.
By default, GNAT assumes Ada 2012,
but you can override with a compiler switch
@@ -93,8 +93,8 @@ This reference manual contains the following chapters:
to GNAT's implementation of machine code insertions, tasking, and several
other features.
-* :ref:`Implementation_of_Ada_2012_Features`, describes the status of the
- GNAT implementation of the Ada 2012 language standard.
+* :ref:`Implementation_of_Ada_2022_Features`, describes the status of the
+ GNAT implementation of the Ada 2022 language standard.
* :ref:`Security_Hardening_Features` documents GNAT extensions aimed
at security hardening.
diff --git a/gcc/ada/doc/gnat_rm/compatibility_and_porting_guide.rst b/gcc/ada/doc/gnat_rm/compatibility_and_porting_guide.rst
index 5a20995..3da2b32 100644
--- a/gcc/ada/doc/gnat_rm/compatibility_and_porting_guide.rst
+++ b/gcc/ada/doc/gnat_rm/compatibility_and_porting_guide.rst
@@ -134,9 +134,9 @@ types will be portable.
Compatibility with Ada 83
=========================
-.. index:: Compatibility (between Ada 83 and Ada 95 / Ada 2005 / Ada 2012)
+.. index:: Compatibility (between Ada 83 and Ada 95 / Ada 2005 / Ada 2012 / Ada 2022)
-Ada 95 and the subsequent revisions Ada 2005 and Ada 2012
+Ada 95 and the subsequent revisions Ada 2005, Ada 2012, Ada 2022
are highly upwards compatible with Ada 83. In
particular, the design intention was that the difficulties associated
with moving from Ada 83 to later versions of the standard should be no greater
@@ -505,7 +505,7 @@ such an Ada 83 application is being ported to different target hardware (for
example where the byte endianness has changed) then you will need to
carefully examine the program logic; the porting effort will heavily depend
on the robustness of the original design. Moreover, Ada 95 (and thus
-Ada 2005 and Ada 2012) are sometimes
+Ada 2005, Ada 2012, and Ada 2022) 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:`Representation_Clauses`.
diff --git a/gcc/ada/doc/gnat_rm/gnat_language_extensions.rst b/gcc/ada/doc/gnat_rm/gnat_language_extensions.rst
index ee2df66..f313179 100644
--- a/gcc/ada/doc/gnat_rm/gnat_language_extensions.rst
+++ b/gcc/ada/doc/gnat_rm/gnat_language_extensions.rst
@@ -657,6 +657,22 @@ An exception message can also be added:
when Imported_C_Func /= 0;
end;
+Implicit With
+-------------
+
+This feature allows a standalone ``use`` clause in the context clause of a
+compilation unit to imply an implicit ``with`` of the same library unit where
+an equivalent ``with`` clause would be allowed.
+
+.. code-block:: ada
+
+ use Ada.Text_IO;
+ procedure Main is
+ begin
+ Put_Line ("Hello");
+ end;
+
+
Storage Model
-------------
@@ -1334,113 +1350,150 @@ case statement with composite selector type".
Mutably Tagged Types with Size'Class Aspect
-------------------------------------------
-The ``Size'Class`` aspect can be applied to a tagged type to specify a size
-constraint for the type and its descendants. When this aspect is specified
-on a tagged type, the class-wide type of that type is considered to be a
-"mutably tagged" type - meaning that objects of the class-wide type can have
-their tag changed by assignment from objects with a different tag.
+For a specific tagged nonformal type T that satisfies some conditions
+described later in this section, the universal-integer-valued type-related
+representation aspect ``Size'Class`` may be specified; any such specified
+aspect value shall be static.
-Example:
+Specifying this aspect imposes an upper bound on the sizes of all specific
+descendants of T (including T itself). T'Class (but not T) is then said to be
+a "mutably tagged" type - meaning that T'Class is a definite subtype and that
+the tag of a variable of type T'Class may be modified by assignment in some
+cases described later in this section. An inherited ``Size'Class`` aspect
+value may be overridden, but not with a larger value.
-.. code-block:: ada
+If the ``Size'Class`` aspect is specified for a type T, then every specific
+descendant of T (including T itself)
- type Base is tagged null record
- with Size'Class => 16 * 8; -- Size in bits (128 bits, or 16 bytes)
+* shall have a Size that does not exceed the specified value; and
- type Derived_Type is new Base with record
- Data_Field : Integer;
- end record; -- ERROR if Derived_Type exceeds 16 bytes
+* shall have a (possibly inherited) ``Size'Class`` aspect that does not exceed
+ the specifed value; and
+
+* shall be undiscriminated; and
-Class-wide types with a specified ``Size'Class`` can be used as the type of
-array components, record components, and stand-alone objects.
+* shall have no composite subcomponent whose subtype is subject to a nonstatic
+ constraint; and
+
+* shall not have a tagged partial view other than a private extension; and
+
+* shall not be a descendant of an interface type; and
+
+* shall not have a statically deeper accessibility level than that of T.
+
+If the ``Size'Class`` aspect is not specified for a type T (either explicitly
+or by inheritance), then it shall not be specified for any descendant of T.
+
+Example:
.. code-block:: ada
- Inst : Base'Class;
- type Array_of_Base is array (Positive range <>) of Base'Class;
+ type Root_Type is tagged null record with Size'Class => 16 * 8;
+
+ type Derived_Type is new Root_Type with record
+ Stuff : Some_Type;
+ end record; -- ERROR if Derived_Type exceeds 16 bytes
-If the ``Size'Class`` aspect is specified for a type ``T``, then every
-specific descendant of ``T`` [redundant: (including ``T``)]
+Because any subtype of a mutably tagged type is definite, it can be used as a
+component subtype for enclosing array or record types, as the subtype of a
+default-initialized stand-alone object, or as the subtype of an uninitialized
+allocator, as in this example:
-- shall have a Size that does not exceed the specified value; and
+.. code-block:: ada
-- shall be undiscriminated; and
+ Obj : Root_Type'Class;
+ type Array_of_Roots is array (Positive range <>) of Root_Type'Class;
-- shall have no composite subcomponent whose subtype is subject to a
- dynamic constraint; and
+Default initialization of an object of such a definite subtype proceeds as
+for the corresponding specific type, except that Program_Error is raised if
+the specific type is abstract. In particular, the initial tag of the object
+is that of the corresponding specific type.
-- shall have no interface progenitors; and
+There is a general design principle that if a type has a tagged partial view,
+then the type's ``Size'Class`` aspect (or lack thereof) should be determinable
+by looking only at the partial view. That provides the motivation for the
+rules of the next two paragraphs.
-- shall not have a tagged partial view other than a private extension; and
+If a type has a tagged partial view, then a ``Size'Class`` aspect specification
+may be provided only at the point of the partial view declaration (in other
+words, no such aspect specification may be provided when the full view of
+the type is declared). All of the above rules (in particular, the rule that
+an overriding ``Size'Class`` aspect value shall not be larger than the
+overridden inherited value) are also enforced when the full view (which may
+have a different ancestor type than that of the partial view) is declared.
+If a partial view for a type inherits a ``Size'Class`` aspect value and does
+not override that value with an explicit aspect specification, then the
+(static) aspect values inherited by the partial view and by the full view
+shall be equal.
-- shall not have a statically deeper accessibility level than that of ``T``.
+An actual parameter of an instantiation whose corresponding formal parameter
+is a formal tagged private type shall not be either mutably tagged or the
+corresponding specific type of a mutably tagged type.
-In addition to the places where Legality Rules normally apply (see 12.3),
-these legality rules apply also in the private part and in the body of an
-instance of a generic unit.
+For the legality rules in this section, the RM 12.3(11) rule about legality
+checking in the visible part and formal part of an instance is extended (in
+the same way that it is extended in many other places in the RM) to include
+the private part of an instance.
-For any subtype ``S`` that is a subtype of a descendant of ``T``, ``S'Class'Size`` is
-defined to yield the specified value [redundant:, although ``S'Class'Size`` is
-not a static expression].
+An object (or a view thereof) of a tagged type is defined to be
+"tag-constrained" if it is
-A class-wide descendant of a type with a specified ``Size'Class`` aspect is
-defined to be a "mutably tagged" type. Any subtype of a mutably tagged type is,
-by definition, a definite subtype (RM 3.3 notwithstanding). Default
-initialization of an object of such a definite subtype proceeds as for the
-corresponding specific type, except that ``Program_Error`` is raised if the
-specific type is abstract. [In particular, the initial tag of the object is
-that of the corresponding specific type.]
+* an object whose type is not mutably tagged; or
-An object of a tagged type is defined to be "tag-constrained" if it is
+* a constant object; or
-- an object whose type is not mutably tagged; or
+* a view conversion of a tag-constrained object; or
-- a constant object; or
+* a view conversion to a type that is not a descendant of the operand's
+ type; or
-- a view conversion of a tag-constrained object; or
+* a formal in out or out parameter whose corresponding actual parameter is
+ tag-constrained; or
-- a formal ``in out`` or ``out`` parameter whose corresponding
- actual parameter is tag-constrained.
+* a dereference of an access value.
-In the case of an assignment to a tagged variable that
-is not tag-constrained, no check is performed that the tag of the value of
-the expression is the same as that of the target (RM 5.2 notwithstanding).
+In the case of an assignment to a tagged variable that is not
+tag-constrained, no check is performed that the tag of the value
+of the expression is the same as that of the target (RM 5.2 notwithstanding).
Instead, the tag of the target object becomes that of the source object of
-the assignment.
+the assignment. Note that the tag of an object of a mutably tagged type MT
+will always be the tag of some specific type that is a descendant of MT.
An assignment to a composite object similarly copies the tags of any
-subcomponents of the source object that have a mutably-tagged type.
-
-The ``Constrained`` attribute is defined for any name denoting an object of a
-mutably tagged type (RM 3.7.2 notwithstanding). In this case, the Constrained
-attribute yields the value True if the object is tag-constrained and False
-otherwise.
-
-Renaming is not allowed (see 8.5.1) for a type conversion having an operand of
-a mutably tagged type ``MT`` and a target type ``TT`` such that ``TT'Class``
-does not cover ``MT``, nor for any part of such an object, nor for any slice
-of such an object. This rule also applies in any context where a name is
-required to be one for which "renaming is allowed" (for example, see RM 12.4).
-
-A name denoting a view of a variable of a mutably tagged type shall not
-occur as an operative constituent of the prefix of a name denoting a
-prefixed view of a callable entity, except as the callee name in a call to
-the callable entity.
-
-For a type conversion between two general access types, either both or neither
-of the designated types shall be mutably tagged. For an ``Access`` (or
-``Unchecked_Access``) attribute reference, the designated type of the type of the
-attribute reference and the type of the prefix of the attribute shall either
-both or neither be mutably tagged.
+subcomponents of the source object that have a mutably tagged type.
+
+The Constrained attribute is defined for any name denoting an object of a
+mutably tagged type (RM 3.7.2 notwithstanding). In this case, the
+Constrained attribute yields the value True if the object is
+tag-constrained and False otherwise.
+
+Renaming is not allowed (see RM 8.5.1) for a type conversion having an operand
+of a mutably tagged type MT and a target type TT such that TT (or its
+corresponding specific type if TT is class-wide) is not an ancestor of MT
+(this is sometimes called a "downward" conversion), nor for any part of
+such an object, nor for any slice of any part of such an object. This
+rule also applies in any context where a name is required to be one for
+which "renaming is allowed" (for example, see RM 12.4).
+[This is analogous to the way that renaming is not allowed for a
+discriminant-dependent component of an unconstrained variable.]
+
+A name denoting a view of a variable of a mutably tagged type shall not occur
+as an operative constituent of the prefix of a name denoting a prefixed
+view of a callable entity, except as the callee name in a call to the
+callable entity. This disallows, for example, renaming such a prefixed view,
+passing the prefixed view name as a generic actual parameter, or using the
+prefixed view name as the prefix of an attribute.
The execution of a construct is erroneous if the construct has a constituent
that is a name denoting a subcomponent of a tagged object and the object's
-tag is changed by this execution between evaluating the name and the last use
-(within this execution) of the subcomponent denoted by the name.
+tag is changed by this execution between evaluating the name and the last
+use (within this execution) of the subcomponent denoted by the name.
+This is analogous to the RM 3.7.2(4) rule about discriminant-dependent
+subcomponents.
-If the type of a formal parameter is a specific tagged type then the execution
+If the type of a formal parameter is a specific tagged type, then the execution
of the call is erroneous if the tag of the actual is changed while the formal
-parameter exists (that is, before leaving the corresponding callable
-construct).
+parameter exists (that is, before leaving the corresponding callable construct).
+This is analogous to the RM 6.4.1(18) rule about discriminated parameters.
Generalized Finalization
------------------------
@@ -1453,97 +1506,60 @@ that the record type must be a root type, in other words not a derived type.
The aspect additionally makes it possible to specify relaxed semantics for
the finalization operations by means of the ``Relaxed_Finalization`` setting.
-
-Example:
+Here is the archetypal example:
.. code-block:: ada
- type Ctrl is record
- Id : Natural := 0;
+ type T is record
+ ...
end record
with Finalizable => (Initialize => Initialize,
Adjust => Adjust,
Finalize => Finalize,
Relaxed_Finalization => True);
- procedure Adjust (Obj : in out Ctrl);
- procedure Finalize (Obj : in out Ctrl);
- procedure Initialize (Obj : in out Ctrl);
-
-The three procedures have the same profile, taking a single ``in out T``
-parameter.
+ procedure Adjust (Obj : in out T);
+ procedure Finalize (Obj : in out T);
+ procedure Initialize (Obj : in out T);
-We follow the same dynamic semantics as controlled objects:
+The three procedures have the same profile, with a single ``in out`` parameter,
+and also have the same dynamic semantics as for controlled types:
- ``Initialize`` is called when an object of type ``T`` is declared without
- default expression.
+ initialization expression.
- ``Adjust`` is called after an object of type ``T`` is assigned a new value.
- ``Finalize`` is called when an object of type ``T`` goes out of scope (for
- stack-allocated objects) or is explicitly deallocated (for heap-allocated
- objects). It is also called when on the value being replaced in an
- assignment.
-
-However the following differences are enforced by default when compared to the
-current Ada controlled-objects finalization model:
+ stack-allocated objects) or is deallocated (for heap-allocated objects).
+ It is also called when the value is replaced by an assignment.
-* No automatic finalization of heap allocated objects: ``Finalize`` is only
- called when an object is implicitly deallocated. As a consequence, no-runtime
- support is needed for the implicit case, and no header will be maintained for
- this in heap-allocated controlled objects.
+However, when ``Relaxed_Finalization`` is either ``True`` or not explicitly
+specified, the following differences are implemented relative to the semantics
+of controlled types:
- Heap-allocated objects allocated through a nested access type definition will
- hence **not** be deallocated either. The result is simply that memory will be
- leaked in those cases.
+* The compiler has permission to perform no automatic finalization of
+ heap-allocated objects: ``Finalize`` is only called when such an object
+ is explicitly deallocated, or when the designated object is assigned a new
+ value. As a consequence, no runtime support is needed for performing
+ implicit deallocation. In particular, no per-object header data is needed
+ for heap-allocated objects.
-* The ``Finalize`` procedure should have have the :ref:`No_Raise_Aspect` specified.
- If that's not the case, a compilation error will be raised.
+ Heap-allocated objects allocated through a nested access type will therefore
+ **not** be deallocated either. The result is simply that memory will be leaked
+ in this case.
-Additionally, two other configuration aspects are added,
-``Legacy_Heap_Finalization`` and ``Exceptions_In_Finalize``:
+* The ``Adjust`` and ``Finalize`` procedures are automatically considered as
+ having the :ref:`No_Raise_Aspect` specified for them. In particular, the
+ compiler has permission to enforce none of the guarantees specified by the
+ RM 7.6.1 (14/1) and subsequent subclauses.
-* ``Legacy_Heap_Finalization``: Uses the legacy automatic finalization of
- heap-allocated objects
-
-* ``Exceptions_In_Finalize``: Allow users to have a finalizer that raises exceptions
- **NB!** note that using this aspect introduces execution time penalities.
-
-.. _No_Raise_Aspect:
-
-No_Raise aspect
-----------------
-
-The ``No_Raise`` aspect can be applied to a subprogram to declare that this subprogram is not
-expected to raise any exceptions. Should an exception still occur during the execution of
-this subprogram, ``Program_Error`` is raised.
-
-New specification for ``Ada.Finalization.Controlled``
-^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-
-``Ada.Finalization.Controlled`` is now specified as:
-
-.. code-block:: ada
-
- type Controlled is abstract tagged null record
- with Initialize => Initialize,
- Adjust => Adjust,
- Finalize => Finalize,
- Legacy_Heap_Finalization, Exceptions_In_Finalize;
-
- procedure Initialize (Self : in out Controlled) is abstract;
- procedure Adjust (Self : in out Controlled) is abstract;
- procedure Finalize (Self : in out Controlled) is abstract;
-
-
-### Examples
-
-A simple example of a ref-counted type:
+Simple example of ref-counted type:
.. code-block:: ada
type T is record
- Value : Integer;
+ Value : Integer;
Ref_Count : Natural := 0;
end record;
@@ -1555,8 +1571,8 @@ A simple example of a ref-counted type:
type T_Ref is record
Value : T_Access;
end record
- with Adjust => Adjust,
- Finalize => Finalize;
+ with Finalizable => (Adjust => Adjust,
+ Finalize => Finalize);
procedure Adjust (Ref : in out T_Ref) is
begin
@@ -1568,8 +1584,7 @@ A simple example of a ref-counted type:
Def_Ref (Ref.Value);
end Finalize;
-
-A simple file handle that ensures resources are properly released:
+Simple file handle that ensures resources are properly released:
.. code-block:: ada
@@ -1579,51 +1594,47 @@ A simple file handle that ensures resources are properly released:
function Open (Path : String) return File;
procedure Close (F : in out File);
+
private
type File is limited record
Handle : ...;
end record
- with Finalize => Close;
-
-
-Finalized tagged types
-^^^^^^^^^^^^^^^^^^^^^^^
+ with Finalizable (Finalize => Close);
+ end P;
-Aspects are inherited by derived types and optionally overriden by those. The
-compiler-generated calls to the user-defined operations are then
-dispatching whenever it makes sense, i.e. the object in question is of
-class-wide type and the class includes at least one finalized tagged type.
+Finalizable tagged types
+^^^^^^^^^^^^^^^^^^^^^^^^
-However note that for simplicity, it is forbidden to change the value of any of
-those new aspects in derived types.
+The aspect is inherited by derived types and the primitives may be overridden
+by the derivation. The compiler-generated calls to these operations are then
+dispatching whenever it makes sense, i.e. when the object in question is of a
+class-wide type and the class includes at least one finalizable tagged type.
Composite types
^^^^^^^^^^^^^^^
-When a finalized type is used as a component of a composite type, the latter
-becomes finalized as well. The three primitives are derived automatically
-in order to call the primitives of their components.
-
-If that composite type was already user-finalized, then the compiler
-calls the primitives of the components so as to stay consistent with today's
-controlled types's behavior.
-
-So, ``Initialize`` and ``Adjust`` are called on components before they
-are called on the composite object, but ``Finalize`` is called on the composite
-object first.
+When a finalizable type is used as a component of a composite type, the latter
+becomes finalizable as well. The three primitives are derived automatically
+in order to call the primitives of their components. The dynamic semantics is
+the same as for controlled components of composite types.
Interoperability with controlled types
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-As a consequence of the redefinition of the ``Controlled`` type as a base type
-with the new aspects defined, interoperability with controlled type naturally
-follows the definition of the above rules. In particular:
+Finalizable types are fully interoperable with controlled types, in particular
+it is possible for a finalizable type to have a controlled component and vice
+versa, but the stricter dynamic semantics, in other words that of controlled
+types, is applied in this case.
-* It is possible to have a new finalized type have a controlled type
- component
-* It is possible to have a controlled type have a finalized type
- component
+.. _No_Raise_Aspect:
+No_Raise aspect
+----------------
+
+The ``No_Raise`` aspect can be applied to a subprogram to declare that this
+subprogram is not expected to raise an exception. Should an exception still
+be raised during the execution of the subprogram, it is caught at the end of
+this execution and ``Program_Error`` is propagated to the caller.
Inference of Dependent Types in Generic Instantiations
------------------------------------------------------
@@ -1766,3 +1777,19 @@ If an exception is raised in the finally part, it cannot be caught by the ``exce
Abort/ATC (asynchronous transfer of control) cannot interrupt a finally block, nor prevent its
execution, that is the finally block must be executed in full even if the containing task is
aborted, or if the control is transferred out of the block.
+
+Continue statement
+------------------
+
+The ``continue`` keyword makes it possible to stop execution of a loop iteration
+and continue with the next one. A continue statement has the same syntax
+(except "exit" is replaced with "continue"), static semantics, and legality
+rules as an exit statement. The difference is in the dynamic semantics: where an
+exit statement would cause a transfer of control that completes the (implicitly
+or explicitly) specified loop_statement, a continue statement would instead
+cause a transfer of control that completes only the current iteration of that
+loop_statement, like a goto statement targeting a label following the last
+statement in the sequence of statements of the specified loop_statement.
+
+Note that ``continue`` is a keyword but it is not a reserved word. This is a
+configuration that does not exist in standard Ada.
diff --git a/gcc/ada/doc/gnat_rm/implementation_advice.rst b/gcc/ada/doc/gnat_rm/implementation_advice.rst
index 435cfa4..d4fdd09 100644
--- a/gcc/ada/doc/gnat_rm/implementation_advice.rst
+++ b/gcc/ada/doc/gnat_rm/implementation_advice.rst
@@ -1218,16 +1218,12 @@ RM E.5(28-29): Partition Communication Subsystem
should allow them to block until the corresponding subprogram body
returns."
-Followed by GLADE, a separately supplied PCS that can be used with
-GNAT.
+A separately supplied PCS that can be used with GNAT when combined with the PolyORB product.
"The ``Write`` operation on a stream of type ``Params_Stream_Type``
should raise ``Storage_Error`` if it runs out of space trying to
write the ``Item`` into the stream."
-Followed by GLADE, a separately supplied PCS that can be used with
-GNAT.
-
.. index:: COBOL support
RM F(7): COBOL Support
diff --git a/gcc/ada/doc/gnat_rm/implementation_defined_aspects.rst b/gcc/ada/doc/gnat_rm/implementation_defined_aspects.rst
index 61ea10c..a80da47 100644
--- a/gcc/ada/doc/gnat_rm/implementation_defined_aspects.rst
+++ b/gcc/ada/doc/gnat_rm/implementation_defined_aspects.rst
@@ -549,6 +549,12 @@ predicate is static or dynamic is controlled by the form of the
expression. It is also separately controllable using pragma
``Assertion_Policy``.
+Aspect Program_Exit
+===================
+.. index:: Program_Exit
+
+This boolean aspect is equivalent to :ref:`pragma Program_Exit<Pragma-Program_Exit>`.
+
Aspect Pure_Function
====================
.. index:: Pure_Function
diff --git a/gcc/ada/doc/gnat_rm/implementation_defined_attributes.rst b/gcc/ada/doc/gnat_rm/implementation_defined_attributes.rst
index f051810..86d2a81 100644
--- a/gcc/ada/doc/gnat_rm/implementation_defined_attributes.rst
+++ b/gcc/ada/doc/gnat_rm/implementation_defined_attributes.rst
@@ -1629,9 +1629,9 @@ Attribute Valid_Value
.. index:: Valid_Value
The ``'Valid_Value`` attribute is defined for enumeration types other than
-those in package Standard. This attribute is a function that takes
-a String, and returns Boolean. ``T'Valid_Value (S)`` returns True
-if and only if ``T'Value (S)`` would not raise Constraint_Error.
+those in package Standard or types derived from those types. This attribute is
+a function that takes a String, and returns Boolean. ``T'Valid_Value (S)``
+returns True if and only if ``T'Value (S)`` would not raise Constraint_Error.
Attribute Valid_Scalars
=======================
diff --git a/gcc/ada/doc/gnat_rm/implementation_defined_characteristics.rst b/gcc/ada/doc/gnat_rm/implementation_defined_characteristics.rst
index 3e41899..563f62a 100644
--- a/gcc/ada/doc/gnat_rm/implementation_defined_characteristics.rst
+++ b/gcc/ada/doc/gnat_rm/implementation_defined_characteristics.rst
@@ -377,11 +377,7 @@ may have been set by a call to ``Ada.Command_Line.Set_Exit_Status``).
*
"The mechanisms for building and running partitions. See 10.2(24)."
-GNAT itself supports programs with only a single partition. The GNATDIST
-tool provided with the GLADE package (which also includes an implementation
-of the PCS) provides a completely flexible method for building and running
-programs consisting of multiple partitions. See the separate GLADE manual
-for details.
+GNAT itself supports programs with only a single partition. The PolyORB product (which also includes an implementation of the PCS) provides a completely flexible method for building and running programs consisting of multiple partitions. See the separate PolyORB user guide for details.
*
"The details of program execution, including program
@@ -394,7 +390,7 @@ See separate section on compilation model.
implementation. See 10.2(28)."
Passive partitions are supported on targets where shared memory is
-provided by the operating system. See the GLADE reference manual for
+provided by the operating system. See the PolyORB user guide for
further details.
*
@@ -1188,27 +1184,27 @@ Unknown.
"The means for creating and executing distributed
programs. See E(5)."
-The GLADE package provides a utility GNATDIST for creating and executing
-distributed programs. See the GLADE reference manual for further details.
+The PolyORB product provides means creating and executing
+distributed programs. See the PolyORB user guide for further details.
*
"Any events that can result in a partition becoming
inaccessible. See E.1(7)."
-See the GLADE reference manual for full details on such events.
+See the PolyORB user guide for full details on such events.
*
"The scheduling policies, treatment of priorities, and management of
shared resources between partitions in certain cases. See E.1(11)."
-See the GLADE reference manual for full details on these aspects of
+See the PolyORB user guide for full details on these aspects of
multi-partition execution.
*
"Whether the execution of the remote subprogram is
immediately aborted as a result of cancellation. See E.4(13)."
-See the GLADE reference manual for details on the effect of abort in
+See the PolyORB user guide for details on the effect of abort in
a distributed application.
*
@@ -1219,7 +1215,7 @@ System.RPC.Partition_ID'Last is Integer'Last. See source file :file:`s-rpc.ads`.
*
"Implementation-defined interfaces in the PCS. See E.5(26)."
-See the GLADE reference manual for a full description of all
+See the PolyORB user guide for a full description of all
implementation defined interfaces.
*
diff --git a/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst b/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst
index d18ce36..02013f1 100644
--- a/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst
+++ b/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst
@@ -123,6 +123,11 @@ and generics may name types with unknown discriminants without using
the ``(<>)`` notation. In addition, some but not all of the additional
restrictions of Ada 83 are enforced.
+Like all configuration pragmas, if the pragma is placed before a library
+level package specification it is not propagated to the corresponding
+package body (see RM 10.1.5(8)); it must be added explicitly to the
+package body.
+
Ada 83 mode is intended for two purposes. Firstly, it allows existing
Ada 83 code to be compiled and adapted to GNAT with less effort.
Secondly, it aids in keeping code backwards compatible with Ada 83.
@@ -149,6 +154,11 @@ contexts. This pragma is useful when writing a reusable component that
itself uses Ada 95 features, but which is intended to be usable from
either Ada 83 or Ada 95 programs.
+Like all configuration pragmas, if the pragma is placed before a library
+level package specification it is not propagated to the corresponding
+package body (see RM 10.1.5(8)); it must be added explicitly to the
+package body.
+
Pragma Ada_05
=============
@@ -166,6 +176,11 @@ This pragma is useful when writing a reusable component that
itself uses Ada 2005 features, but which is intended to be usable from
either Ada 83 or Ada 95 programs.
+Like all configuration pragmas, if the pragma is placed before a library
+level package specification it is not propagated to the corresponding
+package body (see RM 10.1.5(8)); it must be added explicitly to the
+package body.
+
The one argument form (which is not a configuration pragma)
is used for managing the transition from
Ada 95 to Ada 2005 in the run-time library. If an entity is marked
@@ -209,6 +224,11 @@ contexts. This pragma is useful when writing a reusable component that
itself uses Ada 2012 features, but which is intended to be usable from
Ada 83, Ada 95, or Ada 2005 programs.
+Like all configuration pragmas, if the pragma is placed before a library
+level package specification it is not propagated to the corresponding
+package body (see RM 10.1.5(8)); it must be added explicitly to the
+package body.
+
The one argument form, which is not a configuration pragma,
is used for managing the transition from Ada
2005 to Ada 2012 in the run-time library. If an entity is marked
@@ -252,6 +272,11 @@ contexts. This pragma is useful when writing a reusable component that
itself uses Ada 2022 features, but which is intended to be usable from
Ada 83, Ada 95, Ada 2005 or Ada 2012 programs.
+Like all configuration pragmas, if the pragma is placed before a library
+level package specification it is not propagated to the corresponding
+package body (see RM 10.1.5(8)); it must be added explicitly to the
+package body.
+
The one argument form, which is not a configuration pragma,
is used for managing the transition from Ada
2012 to Ada 2022 in the run-time library. If an entity is marked
@@ -1940,7 +1965,8 @@ Syntax:
EXIT_CASE ::= GUARD => EXIT_KIND
EXIT_KIND ::= Normal_Return
| Exception_Raised
- | (Exception_Raised => exception_name)
+ | (Exception_Raised => exception_name)
+ | Program_Exit
GUARD ::= Boolean_expression
For the semantics of this aspect, see the SPARK 2014 Reference Manual, section
@@ -5285,6 +5311,20 @@ generating ``Restrictions`` pragmas, it generates
violations of the profile generate warning messages instead
of error messages.
+.. _Pragma-Program_Exit:
+
+Pragma Program_Exit
+===================
+
+Syntax:
+
+.. code-block:: ada
+
+ pragma Program_Exit [ (boolean_EXPRESSION) ];
+
+For the semantics of this pragma, see the entry for aspect ``Program_Exit``
+in the SPARK 2014 Reference Manual, section 6.1.10.
+
Pragma Propagate_Exceptions
===========================
.. index:: Interfacing to C++
diff --git a/gcc/ada/doc/gnat_rm/implementation_of_ada_2012_features.rst b/gcc/ada/doc/gnat_rm/implementation_of_ada_2012_features.rst
deleted file mode 100644
index 9708e15..0000000
--- a/gcc/ada/doc/gnat_rm/implementation_of_ada_2012_features.rst
+++ /dev/null
@@ -1,1330 +0,0 @@
-.. _Implementation_of_Ada_2012_Features:
-
-***********************************
-Implementation of Ada 2012 Features
-***********************************
-
-.. index:: Ada 2012 implementation status
-
-.. index:: -gnat12 option (gcc)
-
-.. index:: pragma Ada_2012
-
-.. index:: configuration pragma Ada_2012
-
-.. index:: Ada_2012 configuration pragma
-
-This chapter contains a complete list of Ada 2012 features that have been
-implemented.
-Generally, these features are only
-available if the *-gnat12* (Ada 2012 features enabled) option is set,
-which is the default behavior,
-or if the configuration pragma ``Ada_2012`` is used.
-
-However, new pragmas, attributes, and restrictions are
-unconditionally available, since the Ada 95 standard allows the addition of
-new pragmas, attributes, and restrictions (there are exceptions, which are
-documented in the individual descriptions), and also certain packages
-were made available in earlier versions of Ada.
-
-An ISO date (YYYY-MM-DD) appears in parentheses on the description line.
-This date shows the implementation date of the feature. Any wavefront
-subsequent to this date will contain the indicated feature, as will any
-subsequent releases. A date of 0000-00-00 means that GNAT has always
-implemented the feature, or implemented it as soon as it appeared as a
-binding interpretation.
-
-Each feature corresponds to an Ada Issue ('AI') approved by the Ada
-standardization group (ISO/IEC JTC1/SC22/WG9) for inclusion in Ada 2012.
-The features are ordered based on the relevant sections of the Ada
-Reference Manual ("RM"). When a given AI relates to multiple points
-in the RM, the earliest is used.
-
-A complete description of the AIs may be found in
-http://www.ada-auth.org/ai05-summary.html.
-
-.. index:: AI-0002 (Ada 2012 feature)
-
-* *AI-0002 Export C with unconstrained arrays (0000-00-00)*
-
- The compiler is not required to support exporting an Ada subprogram with
- convention C if there are parameters or a return type of an unconstrained
- array type (such as ``String``). GNAT allows such declarations but
- generates warnings. It is possible, but complicated, to write the
- corresponding C code and certainly such code would be specific to GNAT and
- non-portable.
-
- RM References: B.01 (17) B.03 (62) B.03 (71.1/2)
-
-.. index:: AI-0003 (Ada 2012 feature)
-
-* *AI-0003 Qualified expressions as names (2010-07-11)*
-
- In Ada 2012, a qualified expression is considered to be syntactically a name,
- meaning that constructs such as ``A'(F(X)).B`` are now legal. This is
- useful in disambiguating some cases of overloading.
-
- RM References: 3.03 (11) 3.03 (21) 4.01 (2) 4.04 (7) 4.07 (3)
- 5.04 (7)
-
-.. index:: AI-0007 (Ada 2012 feature)
-
-* *AI-0007 Stream read and private scalar types (0000-00-00)*
-
- The RM as written appeared to limit the possibilities of declaring read
- attribute procedures for private scalar types. This limitation was not
- intended, and has never been enforced by GNAT.
-
- RM References: 13.13.02 (50/2) 13.13.02 (51/2)
-
-.. index:: AI-0008 (Ada 2012 feature)
-
-* *AI-0008 General access to constrained objects (0000-00-00)*
-
- The wording in the RM implied that if you have a general access to a
- constrained object, it could be used to modify the discriminants. This was
- obviously not intended. ``Constraint_Error`` should be raised, and GNAT
- has always done so in this situation.
-
- RM References: 3.03 (23) 3.10.02 (26/2) 4.01 (9) 6.04.01 (17) 8.05.01 (5/2)
-
-.. index:: AI-0009 (Ada 2012 feature)
-
-* *AI-0009 Pragma Independent[_Components] (2010-07-23)*
-
- This AI introduces the new pragmas ``Independent`` and
- ``Independent_Components``,
- which control guaranteeing independence of access to objects and components.
- The AI also requires independence not unaffected by confirming rep clauses.
-
- RM References: 9.10 (1) 13.01 (15/1) 13.02 (9) 13.03 (13) C.06 (2)
- C.06 (4) C.06 (6) C.06 (9) C.06 (13) C.06 (14)
-
-.. index:: AI-0012 (Ada 2012 feature)
-
-* *AI-0012 Pack/Component_Size for aliased/atomic (2010-07-15)*
-
- It is now illegal to give an inappropriate component size or a pragma
- ``Pack`` that attempts to change the component size in the case of atomic
- or aliased components. Previously GNAT ignored such an attempt with a
- warning.
-
- RM References: 13.02 (6.1/2) 13.02 (7) C.06 (10) C.06 (11) C.06 (21)
-
-.. index:: AI-0015 (Ada 2012 feature)
-
-* *AI-0015 Constant return objects (0000-00-00)*
-
- The return object declared in an *extended_return_statement* may be
- declared constant. This was always intended, and GNAT has always allowed it.
-
- RM References: 6.05 (2.1/2) 3.03 (10/2) 3.03 (21) 6.05 (5/2)
- 6.05 (5.7/2)
-
-.. index:: AI-0017 (Ada 2012 feature)
-
-* *AI-0017 Freezing and incomplete types (0000-00-00)*
-
- So-called 'Taft-amendment types' (i.e., types that are completed in package
- bodies) are not frozen by the occurrence of bodies in the
- enclosing declarative part. GNAT always implemented this properly.
-
- RM References: 13.14 (3/1)
-
-.. index:: AI-0019 (Ada 2012 feature)
-
-* *AI-0019 Freezing of primitives for tagged types (0000-00-00)*
-
- The RM suggests that primitive subprograms of a specific tagged type are
- frozen when the tagged type is frozen. This would be an incompatible change
- and is not intended. GNAT has never attempted this kind of freezing and its
- behavior is consistent with the recommendation of this AI.
-
- RM References: 13.14 (2) 13.14 (3/1) 13.14 (8.1/1) 13.14 (10) 13.14 (14) 13.14 (15.1/2)
-
-.. index:: AI-0026 (Ada 2012 feature)
-
-* *AI-0026 Missing rules for Unchecked_Union (2010-07-07)*
-
- Record representation clauses concerning Unchecked_Union types cannot mention
- the discriminant of the type. The type of a component declared in the variant
- part of an Unchecked_Union cannot be controlled, have controlled components,
- nor have protected or task parts. If an Unchecked_Union type is declared
- within the body of a generic unit or its descendants, then the type of a
- component declared in the variant part cannot be a formal private type or a
- formal private extension declared within the same generic unit.
-
- RM References: 7.06 (9.4/2) B.03.03 (9/2) B.03.03 (10/2)
-
-.. index:: AI-0030 (Ada 2012 feature)
-
-* *AI-0030 Requeue on synchronized interfaces (2010-07-19)*
-
- Requeue is permitted to a protected, synchronized or task interface primitive
- providing it is known that the overriding operation is an entry. Otherwise
- the requeue statement has the same effect as a procedure call. Use of pragma
- ``Implemented`` provides a way to impose a static requirement on the
- overriding operation by adhering to one of the implementation kinds: entry,
- protected procedure or any of the above.
-
- RM References: 9.05 (9) 9.05.04 (2) 9.05.04 (3) 9.05.04 (5)
- 9.05.04 (6) 9.05.04 (7) 9.05.04 (12)
-
-.. index:: AI-0031 (Ada 2012 feature)
-
-* *AI-0031 Add From parameter to Find_Token (2010-07-25)*
-
- A new version of ``Find_Token`` is added to all relevant string packages,
- with an extra parameter ``From``. Instead of starting at the first
- character of the string, the search for a matching Token starts at the
- character indexed by the value of ``From``.
- These procedures are available in all versions of Ada
- but if used in versions earlier than Ada 2012 they will generate a warning
- that an Ada 2012 subprogram is being used.
-
- RM References: A.04.03 (16) A.04.03 (67) A.04.03 (68/1) A.04.04 (51)
- A.04.05 (46)
-
-.. index:: AI-0032 (Ada 2012 feature)
-
-* *AI-0032 Extended return for class-wide functions (0000-00-00)*
-
- If a function returns a class-wide type, the object of an extended return
- statement can be declared with a specific type that is covered by the class-
- wide type. This has been implemented in GNAT since the introduction of
- extended returns. Note AI-0103 complements this AI by imposing matching
- rules for constrained return types.
-
- RM References: 6.05 (5.2/2) 6.05 (5.3/2) 6.05 (5.6/2) 6.05 (5.8/2)
- 6.05 (8/2)
-
-.. index:: AI-0033 (Ada 2012 feature)
-
-* *AI-0033 Attach/Interrupt_Handler in generic (2010-07-24)*
-
- Neither of these two pragmas may appear within a generic template, because
- the generic might be instantiated at other than the library level.
-
- RM References: 13.11.02 (16) C.03.01 (7/2) C.03.01 (8/2)
-
-.. index:: AI-0034 (Ada 2012 feature)
-
-* *AI-0034 Categorization of limited views (0000-00-00)*
-
- The RM makes certain limited with clauses illegal because of categorization
- considerations, when the corresponding normal with would be legal. This is
- not intended, and GNAT has always implemented the recommended behavior.
-
- RM References: 10.02.01 (11/1) 10.02.01 (17/2)
-
-.. index:: AI-0035 (Ada 2012 feature)
-
-* *AI-0035 Inconsistencies with Pure units (0000-00-00)*
-
- This AI remedies some inconsistencies in the legality rules for Pure units.
- Derived access types are legal in a pure unit (on the assumption that the
- rule for a zero storage pool size has been enforced on the ancestor type).
- The rules are enforced in generic instances and in subunits. GNAT has always
- implemented the recommended behavior.
-
- RM References: 10.02.01 (15.1/2) 10.02.01 (15.4/2) 10.02.01 (15.5/2) 10.02.01 (17/2)
-
-.. index:: AI-0037 (Ada 2012 feature)
-
-* *AI-0037 Out-of-range box associations in aggregate (0000-00-00)*
-
- This AI confirms that an association of the form ``Indx => <>`` in an
- array aggregate must raise ``Constraint_Error`` if ``Indx``
- is out of range. The RM specified a range check on other associations, but
- not when the value of the association was defaulted. GNAT has always inserted
- a constraint check on the index value.
-
- RM References: 4.03.03 (29)
-
-.. index:: AI-0038 (Ada 2012 feature)
-
-* *AI-0038 Minor errors in Text_IO (0000-00-00)*
-
- These are minor errors in the description on three points. The intent on
- all these points has always been clear, and GNAT has always implemented the
- correct intended semantics.
-
- RM References: A.10.05 (37) A.10.07 (8/1) A.10.07 (10) A.10.07 (12) A.10.08 (10) A.10.08 (24)
-
-.. index:: AI-0039 (Ada 2012 feature)
-
-* *AI-0039 Stream attributes cannot be dynamic (0000-00-00)*
-
- The RM permitted the use of dynamic expressions (such as ``ptr.all``)
- for stream attributes, but these were never useful and are now illegal. GNAT
- has always regarded such expressions as illegal.
-
- RM References: 13.03 (4) 13.03 (6) 13.13.02 (38/2)
-
-.. index:: AI-0040 (Ada 2012 feature)
-
-* *AI-0040 Limited with clauses on descendant (0000-00-00)*
-
- This AI confirms that a limited with clause in a child unit cannot name
- an ancestor of the unit. This has always been checked in GNAT.
-
- RM References: 10.01.02 (20/2)
-
-.. index:: AI-0042 (Ada 2012 feature)
-
-* *AI-0042 Overriding versus implemented-by (0000-00-00)*
-
- This AI fixes a wording gap in the RM. An operation of a synchronized
- interface can be implemented by a protected or task entry, but the abstract
- operation is not being overridden in the usual sense, and it must be stated
- separately that this implementation is legal. This has always been the case
- in GNAT.
-
- RM References: 9.01 (9.2/2) 9.04 (11.1/2)
-
-.. index:: AI-0043 (Ada 2012 feature)
-
-* *AI-0043 Rules about raising exceptions (0000-00-00)*
-
- This AI covers various omissions in the RM regarding the raising of
- exceptions. GNAT has always implemented the intended semantics.
-
- RM References: 11.04.01 (10.1/2) 11 (2)
-
-.. index:: AI-0044 (Ada 2012 feature)
-
-* *AI-0044 Restrictions on container instantiations (0000-00-00)*
-
- This AI places restrictions on allowed instantiations of generic containers.
- These restrictions are not checked by the compiler, so there is nothing to
- change in the implementation. This affects only the RM documentation.
-
- RM References: A.18 (4/2) A.18.02 (231/2) A.18.03 (145/2) A.18.06 (56/2) A.18.08 (66/2) A.18.09 (79/2) A.18.26 (5/2) A.18.26 (9/2)
-
-.. index:: AI-0046 (Ada 2012 feature)
-
-* *AI-0046 Null exclusion match for full conformance (2010-07-17)*
-
- For full conformance, in the case of access parameters, the null exclusion
- must match (either both or neither must have ``not null``).
-
- RM References: 6.03.02 (18)
-
-.. index:: AI-0050 (Ada 2012 feature)
-
-* *AI-0050 Raising Constraint_Error early for function call (0000-00-00)*
-
- The implementation permissions for raising ``Constraint_Error`` early on a function call
- when it was clear an exception would be raised were over-permissive and allowed
- mishandling of discriminants in some cases. GNAT did
- not take advantage of these incorrect permissions in any case.
-
- RM References: 6.05 (24/2)
-
-.. index:: AI-0056 (Ada 2012 feature)
-
-* *AI-0056 Index on null string returns zero (0000-00-00)*
-
- The wording in the Ada 2005 RM implied an incompatible handling of the
- ``Index`` functions, resulting in raising an exception instead of
- returning zero in some situations.
- This was not intended and has been corrected.
- GNAT always returned zero, and is thus consistent with this AI.
-
- RM References: A.04.03 (56.2/2) A.04.03 (58.5/2)
-
-.. index:: AI-0058 (Ada 2012 feature)
-
-* *AI-0058 Abnormal completion of an extended return (0000-00-00)*
-
- The RM had some incorrect wording implying wrong treatment of abnormal
- completion in an extended return. GNAT has always implemented the intended
- correct semantics as described by this AI.
-
- RM References: 6.05 (22/2)
-
-.. index:: AI-0060 (Ada 2012 feature)
-
-* *AI-0060 Extended definition of remote access types (0000-00-00)*
-
- This AI extends the definition of remote access types to include access
- to limited, synchronized, protected or task class-wide interface types.
- GNAT already implemented this extension.
-
- RM References: A (4) E.02.02 (9/1) E.02.02 (9.2/1) E.02.02 (14/2) E.02.02 (18)
-
-.. index:: AI-0062 (Ada 2012 feature)
-
-* *AI-0062 Null exclusions and deferred constants (0000-00-00)*
-
- A full constant may have a null exclusion even if its associated deferred
- constant does not. GNAT has always allowed this.
-
- RM References: 7.04 (6/2) 7.04 (7.1/2)
-
-.. index:: AI-0064 (Ada 2012 feature)
-
-* *AI-0064 Redundant finalization rule (0000-00-00)*
-
- This is an editorial change only. The intended behavior is already checked
- by an existing ACATS test, which GNAT has always executed correctly.
-
- RM References: 7.06.01 (17.1/1)
-
-.. index:: AI-0065 (Ada 2012 feature)
-
-* *AI-0065 Remote access types and external streaming (0000-00-00)*
-
- This AI clarifies the fact that all remote access types support external
- streaming. This fixes an obvious oversight in the definition of the
- language, and GNAT always implemented the intended correct rules.
-
- RM References: 13.13.02 (52/2)
-
-.. index:: AI-0070 (Ada 2012 feature)
-
-* *AI-0070 Elaboration of interface types (0000-00-00)*
-
- This is an editorial change only, there are no testable consequences short of
- checking for the absence of generated code for an interface declaration.
-
- RM References: 3.09.04 (18/2)
-
-.. index:: AI-0072 (Ada 2012 feature)
-
-* *AI-0072 Task signalling using 'Terminated (0000-00-00)*
-
- This AI clarifies that task signalling for reading ``'Terminated`` only
- occurs if the result is True. GNAT semantics has always been consistent with
- this notion of task signalling.
-
- RM References: 9.10 (6.1/1)
-
-.. index:: AI-0073 (Ada 2012 feature)
-
-* *AI-0073 Functions returning abstract types (2010-07-10)*
-
- This AI covers a number of issues regarding returning abstract types. In
- particular generic functions cannot have abstract result types or access
- result types designated an abstract type. There are some other cases which
- are detailed in the AI. Note that this binding interpretation has not been
- retrofitted to operate before Ada 2012 mode, since it caused a significant
- number of regressions.
-
- RM References: 3.09.03 (8) 3.09.03 (10) 6.05 (8/2)
-
-.. index:: AI-0076 (Ada 2012 feature)
-
-* *AI-0076 function with controlling result (0000-00-00)*
-
- This is an editorial change only. The RM defines calls with controlling
- results, but uses the term 'function with controlling result' without an
- explicit definition.
-
- RM References: 3.09.02 (2/2)
-
-.. index:: AI-0077 (Ada 2012 feature)
-
-* *AI-0077 Limited withs and scope of declarations (0000-00-00)*
-
- This AI clarifies that a declaration does not include a context clause,
- and confirms that it is illegal to have a context in which both a limited
- and a nonlimited view of a package are accessible. Such double visibility
- was always rejected by GNAT.
-
- RM References: 10.01.02 (12/2) 10.01.02 (21/2) 10.01.02 (22/2)
-
-.. index:: AI-0078 (Ada 2012 feature)
-
-* *AI-0078 Relax Unchecked_Conversion alignment rules (0000-00-00)*
-
- In Ada 2012, compilers are required to support unchecked conversion where the
- target alignment is a multiple of the source alignment. GNAT always supported
- this case (and indeed all cases of differing alignments, doing copies where
- required if the alignment was reduced).
-
- RM References: 13.09 (7)
-
-.. index:: AI-0079 (Ada 2012 feature)
-
-* *AI-0079 Allow other_format characters in source (2010-07-10)*
-
- Wide characters in the unicode category *other_format* are now allowed in
- source programs between tokens, but not within a token such as an identifier.
-
- RM References: 2.01 (4/2) 2.02 (7)
-
-.. index:: AI-0080 (Ada 2012 feature)
-
-* *AI-0080 'View of' not needed if clear from context (0000-00-00)*
-
- This is an editorial change only, described as non-testable in the AI.
-
- RM References: 3.01 (7)
-
-.. index:: AI-0087 (Ada 2012 feature)
-
-* *AI-0087 Actual for formal nonlimited derived type (2010-07-15)*
-
- The actual for a formal nonlimited derived type cannot be limited. In
- particular, a formal derived type that extends a limited interface but which
- is not explicitly limited cannot be instantiated with a limited type.
-
- RM References: 7.05 (5/2) 12.05.01 (5.1/2)
-
-.. index:: AI-0088 (Ada 2012 feature)
-
-* *AI-0088 The value of exponentiation (0000-00-00)*
-
- This AI clarifies the equivalence rule given for the dynamic semantics of
- exponentiation: the value of the operation can be obtained by repeated
- multiplication, but the operation can be implemented otherwise (for example
- using the familiar divide-by-two-and-square algorithm, even if this is less
- accurate), and does not imply repeated reads of a volatile base.
-
- RM References: 4.05.06 (11)
-
-.. index:: AI-0091 (Ada 2012 feature)
-
-* *AI-0091 Do not allow other_format in identifiers (0000-00-00)*
-
- Wide characters in the unicode category *other_format* are not permitted
- within an identifier, since this can be a security problem. The error
- message for this case has been improved to be more specific, but GNAT has
- never allowed such characters to appear in identifiers.
-
- RM References: 2.03 (3.1/2) 2.03 (4/2) 2.03 (5/2) 2.03 (5.1/2) 2.03 (5.2/2) 2.03 (5.3/2) 2.09 (2/2)
-
-.. index:: AI-0093 (Ada 2012 feature)
-
-* *AI-0093 Additional rules use immutably limited (0000-00-00)*
-
- This is an editorial change only, to make more widespread use of the Ada 2012
- 'immutably limited'.
-
- RM References: 3.03 (23.4/3)
-
-.. index:: AI-0095 (Ada 2012 feature)
-
-* *AI-0095 Address of intrinsic subprograms (0000-00-00)*
-
- The prefix of ``'Address`` cannot statically denote a subprogram with
- convention ``Intrinsic``. The use of the ``Address`` attribute raises
- ``Program_Error`` if the prefix denotes a subprogram with convention
- ``Intrinsic``.
-
- RM References: 13.03 (11/1)
-
-.. index:: AI-0096 (Ada 2012 feature)
-
-* *AI-0096 Deriving from formal private types (2010-07-20)*
-
- In general it is illegal for a type derived from a formal limited type to be
- nonlimited. This AI makes an exception to this rule: derivation is legal
- if it appears in the private part of the generic, and the formal type is not
- tagged. If the type is tagged, the legality check must be applied to the
- private part of the package.
-
- RM References: 3.04 (5.1/2) 6.02 (7)
-
-.. index:: AI-0097 (Ada 2012 feature)
-
-* *AI-0097 Treatment of abstract null extension (2010-07-19)*
-
- The RM as written implied that in some cases it was possible to create an
- object of an abstract type, by having an abstract extension inherit a non-
- abstract constructor from its parent type. This mistake has been corrected
- in GNAT and in the RM, and this construct is now illegal.
-
- RM References: 3.09.03 (4/2)
-
-.. index:: AI-0098 (Ada 2012 feature)
-
-* *AI-0098 Anonymous subprogram access restrictions (0000-00-00)*
-
- An unintentional omission in the RM implied some inconsistent restrictions on
- the use of anonymous access to subprogram values. These restrictions were not
- intentional, and have never been enforced by GNAT.
-
- RM References: 3.10.01 (6) 3.10.01 (9.2/2)
-
-.. index:: AI-0099 (Ada 2012 feature)
-
-* *AI-0099 Tag determines whether finalization needed (0000-00-00)*
-
- This AI clarifies that 'needs finalization' is part of dynamic semantics,
- and therefore depends on the run-time characteristics of an object (i.e. its
- tag) and not on its nominal type. As the AI indicates: "we do not expect
- this to affect any implementation".
-
- RM References: 7.06.01 (6) 7.06.01 (7) 7.06.01 (8) 7.06.01 (9/2)
-
-.. index:: AI-0100 (Ada 2012 feature)
-
-* *AI-0100 Placement of pragmas (2010-07-01)*
-
- This AI is an earlier version of AI-163. It simplifies the rules
- for legal placement of pragmas. In the case of lists that allow pragmas, if
- the list may have no elements, then the list may consist solely of pragmas.
-
- RM References: 2.08 (7)
-
-.. index:: AI-0102 (Ada 2012 feature)
-
-* *AI-0102 Some implicit conversions are illegal (0000-00-00)*
-
- It is illegal to assign an anonymous access constant to an anonymous access
- variable. The RM did not have a clear rule to prevent this, but GNAT has
- always generated an error for this usage.
-
- RM References: 3.07 (16) 3.07.01 (9) 6.04.01 (6) 8.06 (27/2)
-
-.. index:: AI-0103 (Ada 2012 feature)
-
-* *AI-0103 Static matching for extended return (2010-07-23)*
-
- If the return subtype of a function is an elementary type or a constrained
- type, the subtype indication in an extended return statement must match
- statically this return subtype.
-
- RM References: 6.05 (5.2/2)
-
-.. index:: AI-0104 (Ada 2012 feature)
-
-* *AI-0104 Null exclusion and uninitialized allocator (2010-07-15)*
-
- The assignment ``Ptr := new not null Some_Ptr;`` will raise
- ``Constraint_Error`` because the default value of the allocated object is
- **null**. This useless construct is illegal in Ada 2012.
-
- RM References: 4.08 (2)
-
-.. index:: AI-0106 (Ada 2012 feature)
-
-* *AI-0106 No representation pragmas on generic formals (0000-00-00)*
-
- The RM appeared to allow representation pragmas on generic formal parameters,
- but this was not intended, and GNAT has never permitted this usage.
-
- RM References: 13.01 (9.1/1)
-
-.. index:: AI-0108 (Ada 2012 feature)
-
-* *AI-0108 Limited incomplete view and discriminants (0000-00-00)*
-
- This AI confirms that an incomplete type from a limited view does not have
- discriminants. This has always been the case in GNAT.
-
- RM References: 10.01.01 (12.3/2)
-
-.. index:: AI-0109 (Ada 2012 feature)
-
-* *AI-0109 Redundant check in S'Class'Input (0000-00-00)*
-
- This AI is an editorial change only. It removes the need for a tag check
- that can never fail.
-
- RM References: 13.13.02 (34/2)
-
-.. index:: AI-0112 (Ada 2012 feature)
-
-* *AI-0112 Detection of duplicate pragmas (2010-07-24)*
-
- This AI concerns giving names to various representation aspects, but the
- practical effect is simply to make the use of duplicate
- ``Atomic[_Components]``,
- ``Volatile[_Components]``, and
- ``Independent[_Components]`` pragmas illegal, and GNAT
- now performs this required check.
-
- RM References: 13.01 (8)
-
-.. index:: AI-0114 (Ada 2012 feature)
-
-* *AI-0114 Classification of letters (0000-00-00)*
-
- The code points 170 (``FEMININE ORDINAL INDICATOR``),
- 181 (``MICRO SIGN``), and
- 186 (``MASCULINE ORDINAL INDICATOR``) are technically considered
- lower case letters by Unicode.
- However, they are not allowed in identifiers, and they
- return ``False`` to ``Ada.Characters.Handling.Is_Letter/Is_Lower``.
- This behavior is consistent with that defined in Ada 95.
-
- RM References: A.03.02 (59) A.04.06 (7)
-
-.. index:: AI-0116 (Ada 2012 feature)
-
-* *AI-0116 Alignment of class-wide objects (0000-00-00)*
-
- This AI requires that the alignment of a class-wide object be no greater
- than the alignment of any type in the class. GNAT has always followed this
- recommendation.
-
- RM References: 13.03 (29) 13.11 (16)
-
-.. index:: AI-0118 (Ada 2012 feature)
-
-* *AI-0118 The association of parameter associations (0000-00-00)*
-
- This AI clarifies the rules for named associations in subprogram calls and
- generic instantiations. The rules have been in place since Ada 83.
-
- RM References: 6.04.01 (2) 12.03 (9)
-
-.. index:: AI-0120 (Ada 2012 feature)
-
-* *AI-0120 Constant instance of protected object (0000-00-00)*
-
- This is an RM editorial change only. The section that lists objects that are
- constant failed to include the current instance of a protected object
- within a protected function. This has always been treated as a constant
- in GNAT.
-
- RM References: 3.03 (21)
-
-.. index:: AI-0122 (Ada 2012 feature)
-
-* *AI-0122 Private with and children of generics (0000-00-00)*
-
- This AI clarifies the visibility of private children of generic units within
- instantiations of a parent. GNAT has always handled this correctly.
-
- RM References: 10.01.02 (12/2)
-
-.. index:: AI-0123 (Ada 2012 feature)
-
-* *AI-0123 Composability of equality (2010-04-13)*
-
- Equality of untagged record composes, so that the predefined equality for a
- composite type that includes a component of some untagged record type
- ``R`` uses the equality operation of ``R`` (which may be user-defined
- or predefined). This makes the behavior of untagged records identical to that
- of tagged types in this respect.
-
- This change is an incompatibility with previous versions of Ada, but it
- corrects a non-uniformity that was often a source of confusion. Analysis of
- a large number of industrial programs indicates that in those rare cases
- where a composite type had an untagged record component with a user-defined
- equality, either there was no use of the composite equality, or else the code
- expected the same composability as for tagged types, and thus had a bug that
- would be fixed by this change.
-
- RM References: 4.05.02 (9.7/2) 4.05.02 (14) 4.05.02 (15) 4.05.02 (24)
- 8.05.04 (8)
-
-.. index:: AI-0125 (Ada 2012 feature)
-
-* *AI-0125 Nonoverridable operations of an ancestor (2010-09-28)*
-
- In Ada 2012, the declaration of a primitive operation of a type extension
- or private extension can also override an inherited primitive that is not
- visible at the point of this declaration.
-
- RM References: 7.03.01 (6) 8.03 (23) 8.03.01 (5/2) 8.03.01 (6/2)
-
-.. index:: AI-0126 (Ada 2012 feature)
-
-* *AI-0126 Dispatching with no declared operation (0000-00-00)*
-
- This AI clarifies dispatching rules, and simply confirms that dispatching
- executes the operation of the parent type when there is no explicitly or
- implicitly declared operation for the descendant type. This has always been
- the case in all versions of GNAT.
-
- RM References: 3.09.02 (20/2) 3.09.02 (20.1/2) 3.09.02 (20.2/2)
-
-.. index:: AI-0127 (Ada 2012 feature)
-
-* *AI-0127 Adding Locale Capabilities (2010-09-29)*
-
- This package provides an interface for identifying the current locale.
-
- RM References: A.19 A.19.01 A.19.02 A.19.03 A.19.05 A.19.06
- A.19.07 A.19.08 A.19.09 A.19.10 A.19.11 A.19.12 A.19.13
-
-.. index:: AI-0128 (Ada 2012 feature)
-
-* *AI-0128 Inequality is a primitive operation (0000-00-00)*
-
- If an equality operator ("=") is declared for a type, then the implicitly
- declared inequality operator ("/=") is a primitive operation of the type.
- This is the only reasonable interpretation, and is the one always implemented
- by GNAT, but the RM was not entirely clear in making this point.
-
- RM References: 3.02.03 (6) 6.06 (6)
-
-.. index:: AI-0129 (Ada 2012 feature)
-
-* *AI-0129 Limited views and incomplete types (0000-00-00)*
-
- This AI clarifies the description of limited views: a limited view of a
- package includes only one view of a type that has an incomplete declaration
- and a full declaration (there is no possible ambiguity in a client package).
- This AI also fixes an omission: a nested package in the private part has no
- limited view. GNAT always implemented this correctly.
-
- RM References: 10.01.01 (12.2/2) 10.01.01 (12.3/2)
-
-.. index:: AI-0132 (Ada 2012 feature)
-
-* *AI-0132 Placement of library unit pragmas (0000-00-00)*
-
- This AI fills a gap in the description of library unit pragmas. The pragma
- clearly must apply to a library unit, even if it does not carry the name
- of the enclosing unit. GNAT has always enforced the required check.
-
- RM References: 10.01.05 (7)
-
-.. index:: AI-0134 (Ada 2012 feature)
-
-* *AI-0134 Profiles must match for full conformance (0000-00-00)*
-
- For full conformance, the profiles of anonymous-access-to-subprogram
- parameters must match. GNAT has always enforced this rule.
-
- RM References: 6.03.01 (18)
-
-.. index:: AI-0137 (Ada 2012 feature)
-
-* *AI-0137 String encoding package (2010-03-25)*
-
- The packages ``Ada.Strings.UTF_Encoding``, together with its child
- packages, ``Conversions``, ``Strings``, ``Wide_Strings``,
- and ``Wide_Wide_Strings`` have been
- implemented. These packages (whose documentation can be found in the spec
- files :file:`a-stuten.ads`, :file:`a-suenco.ads`, :file:`a-suenst.ads`,
- :file:`a-suewst.ads`, :file:`a-suezst.ads`) allow encoding and decoding of
- ``String``, ``Wide_String``, and ``Wide_Wide_String``
- values using UTF coding schemes (including UTF-8, UTF-16LE, UTF-16BE, and
- UTF-16), as well as conversions between the different UTF encodings. With
- the exception of ``Wide_Wide_Strings``, these packages are available in
- Ada 95 and Ada 2005 mode as well as Ada 2012 mode.
- The ``Wide_Wide_Strings`` package
- is available in Ada 2005 mode as well as Ada 2012 mode (but not in Ada 95
- mode since it uses ``Wide_Wide_Character``).
-
- RM References: A.04.11
-
-.. index:: AI-0139-2 (Ada 2012 feature)
-
-* *AI-0139-2 Syntactic sugar for iterators (2010-09-29)*
-
- The new syntax for iterating over arrays and containers is now implemented.
- Iteration over containers is for now limited to read-only iterators. Only
- default iterators are supported, with the syntax: ``for Elem of C``.
-
- RM References: 5.05
-
-.. index:: AI-0146 (Ada 2012 feature)
-
-* *AI-0146 Type invariants (2009-09-21)*
-
- Type invariants may be specified for private types using the aspect notation.
- Aspect ``Type_Invariant`` may be specified for any private type,
- ``Type_Invariant'Class`` can
- only be specified for tagged types, and is inherited by any descendent of the
- tagged types. The invariant is a boolean expression that is tested for being
- true in the following situations: conversions to the private type, object
- declarations for the private type that are default initialized, and
- [**in**] **out**
- parameters and returned result on return from any primitive operation for
- the type that is visible to a client.
- GNAT defines the synonyms ``Invariant`` for ``Type_Invariant`` and
- ``Invariant'Class`` for ``Type_Invariant'Class``.
-
- RM References: 13.03.03 (00)
-
-.. index:: AI-0147 (Ada 2012 feature)
-
-* *AI-0147 Conditional expressions (2009-03-29)*
-
- Conditional expressions are permitted. The form of such an expression is:
-
- ::
-
- (if expr then expr {elsif expr then expr} [else expr])
-
- The parentheses can be omitted in contexts where parentheses are present
- anyway, such as subprogram arguments and pragma arguments. If the **else**
- clause is omitted, **else** *True* is assumed;
- thus ``(if A then B)`` is a way to conveniently represent
- *(A implies B)* in standard logic.
-
- RM References: 4.03.03 (15) 4.04 (1) 4.04 (7) 4.05.07 (0) 4.07 (2)
- 4.07 (3) 4.09 (12) 4.09 (33) 5.03 (3) 5.03 (4) 7.05 (2.1/2)
-
-.. index:: AI-0152 (Ada 2012 feature)
-
-* *AI-0152 Restriction No_Anonymous_Allocators (2010-09-08)*
-
- Restriction ``No_Anonymous_Allocators`` prevents the use of allocators
- where the type of the returned value is an anonymous access type.
-
- RM References: H.04 (8/1)
-
-.. index:: AI-0157 (Ada 2012 feature)
-
-* *AI-0157 Allocation/Deallocation from empty pool (2010-07-11)*
-
- Allocation and Deallocation from an empty storage pool (i.e. allocation or
- deallocation of a pointer for which a static storage size clause of zero
- has been given) is now illegal and is detected as such. GNAT
- previously gave a warning but not an error.
-
- RM References: 4.08 (5.3/2) 13.11.02 (4) 13.11.02 (17)
-
-.. index:: AI-0158 (Ada 2012 feature)
-
-* *AI-0158 Generalizing membership tests (2010-09-16)*
-
- This AI extends the syntax of membership tests to simplify complex conditions
- that can be expressed as membership in a subset of values of any type. It
- introduces syntax for a list of expressions that may be used in loop contexts
- as well.
-
- RM References: 3.08.01 (5) 4.04 (3) 4.05.02 (3) 4.05.02 (5) 4.05.02 (27)
-
-.. index:: AI-0161 (Ada 2012 feature)
-
-* *AI-0161 Restriction No_Default_Stream_Attributes (2010-09-11)*
-
- A new restriction ``No_Default_Stream_Attributes`` prevents the use of any
- of the default stream attributes for elementary types. If this restriction is
- in force, then it is necessary to provide explicit subprograms for any
- stream attributes used.
-
- RM References: 13.12.01 (4/2) 13.13.02 (40/2) 13.13.02 (52/2)
-
-.. index:: AI-0162 (Ada 2012 feature)
-
-* *AI-0162 Incomplete type completed by partial view (2010-09-15)*
-
- Incomplete types are made more useful by allowing them to be completed by
- private types and private extensions.
-
- RM References: 3.10.01 (2.5/2) 3.10.01 (2.6/2) 3.10.01 (3) 3.10.01 (4/2)
-
-.. index:: AI-0163 (Ada 2012 feature)
-
-* *AI-0163 Pragmas in place of null (2010-07-01)*
-
- A statement sequence may be composed entirely of pragmas. It is no longer
- necessary to add a dummy ``null`` statement to make the sequence legal.
-
- RM References: 2.08 (7) 2.08 (16)
-
-.. index:: AI-0171 (Ada 2012 feature)
-
-* *AI-0171 Pragma CPU and Ravenscar Profile (2010-09-24)*
-
- A new package ``System.Multiprocessors`` is added, together with the
- definition of pragma ``CPU`` for controlling task affinity. A new no
- dependence restriction, on ``System.Multiprocessors.Dispatching_Domains``,
- is added to the Ravenscar profile.
-
- RM References: D.13.01 (4/2) D.16
-
-.. index:: AI-0173 (Ada 2012 feature)
-
-* *AI-0173 Testing if tags represent abstract types (2010-07-03)*
-
- The function ``Ada.Tags.Type_Is_Abstract`` returns ``True`` if invoked
- with the tag of an abstract type, and ``False`` otherwise.
-
- RM References: 3.09 (7.4/2) 3.09 (12.4/2)
-
-.. index:: AI-0176 (Ada 2012 feature)
-
-* *AI-0176 Quantified expressions (2010-09-29)*
-
- Both universally and existentially quantified expressions are implemented.
- They use the new syntax for iterators proposed in AI05-139-2, as well as
- the standard Ada loop syntax.
-
- RM References: 1.01.04 (12) 2.09 (2/2) 4.04 (7) 4.05.09 (0)
-
-.. index:: AI-0177 (Ada 2012 feature)
-
-* *AI-0177 Parameterized expressions (2010-07-10)*
-
- The new Ada 2012 notion of parameterized expressions is implemented. The form
- is:
-
- .. code-block:: ada
-
- function-specification is (expression)
-
- This is exactly equivalent to the
- corresponding function body that returns the expression, but it can appear
- in a package spec. Note that the expression must be parenthesized.
-
- RM References: 13.11.01 (3/2)
-
-.. index:: AI-0178 (Ada 2012 feature)
-
-* *AI-0178 Incomplete views are limited (0000-00-00)*
-
- This AI clarifies the role of incomplete views and plugs an omission in the
- RM. GNAT always correctly restricted the use of incomplete views and types.
-
- RM References: 7.05 (3/2) 7.05 (6/2)
-
-.. index:: AI-0179 (Ada 2012 feature)
-
-* *AI-0179 Statement not required after label (2010-04-10)*
-
- It is not necessary to have a statement following a label, so a label
- can appear at the end of a statement sequence without the need for putting a
- null statement afterwards, but it is not allowable to have only labels and
- no real statements in a statement sequence.
-
- RM References: 5.01 (2)
-
-.. index:: AI-0181 (Ada 2012 feature)
-
-* *AI-0181 Soft hyphen is a non-graphic character (2010-07-23)*
-
- From Ada 2005 on, soft hyphen is considered a non-graphic character, which
- means that it has a special name (``SOFT_HYPHEN``) in conjunction with the
- ``Image`` and ``Value`` attributes for the character types. Strictly
- speaking this is an inconsistency with Ada 95, but in practice the use of
- these attributes is so obscure that it will not cause problems.
-
- RM References: 3.05.02 (2/2) A.01 (35/2) A.03.03 (21)
-
-.. index:: AI-0182 (Ada 2012 feature)
-
-* *AI-0182 Additional forms for* ``Character'Value`` *(0000-00-00)*
-
- This AI allows ``Character'Value`` to accept the string ``'?'`` where
- ``?`` is any character including non-graphic control characters. GNAT has
- always accepted such strings. It also allows strings such as
- ``HEX_00000041`` to be accepted, but GNAT does not take advantage of this
- permission and raises ``Constraint_Error``, as is certainly still
- permitted.
-
- RM References: 3.05 (56/2)
-
-.. index:: AI-0183 (Ada 2012 feature)
-
-* *AI-0183 Aspect specifications (2010-08-16)*
-
- Aspect specifications have been fully implemented except for pre and post-
- conditions, and type invariants, which have their own separate AI's. All
- forms of declarations listed in the AI are supported. The following is a
- list of the aspects supported (with GNAT implementation aspects marked)
-
-==================================== ===========
-Supported Aspect Source
-==================================== ===========
- ``Ada_2005`` -- GNAT
- ``Ada_2012`` -- GNAT
- ``Address``
- ``Alignment``
- ``Atomic``
- ``Atomic_Components``
- ``Bit_Order``
- ``Component_Size``
- ``Contract_Cases`` -- GNAT
- ``Discard_Names``
- ``External_Tag``
- ``Favor_Top_Level`` -- GNAT
- ``Inline``
- ``Inline_Always`` -- GNAT
- ``Invariant`` -- GNAT
- ``Machine_Radix``
- ``No_Return``
- ``Object_Size`` -- GNAT
- ``Pack``
- ``Persistent_BSS`` -- GNAT
- ``Post``
- ``Pre``
- ``Predicate``
- ``Preelaborable_Initialization``
- ``Pure_Function`` -- GNAT
- ``Remote_Access_Type`` -- GNAT
- ``Shared`` -- GNAT
- ``Size``
- ``Storage_Pool``
- ``Storage_Size``
- ``Stream_Size``
- ``Suppress``
- ``Suppress_Debug_Info`` -- GNAT
- ``Test_Case`` -- GNAT
- ``Thread_Local_Storage`` -- GNAT
- ``Type_Invariant``
- ``Unchecked_Union``
- ``Universal_Aliasing`` -- GNAT
- ``Unmodified`` -- GNAT
- ``Unreferenced`` -- GNAT
- ``Unreferenced_Objects`` -- GNAT
- ``Unsuppress``
- ``Value_Size`` -- GNAT
- ``Volatile``
- ``Volatile_Components``
- ``Warnings`` -- GNAT
-==================================== ===========
-
- Note that for aspects with an expression, e.g. ``Size``, the expression is
- treated like a default expression (visibility is analyzed at the point of
- occurrence of the aspect, but evaluation of the expression occurs at the
- freeze point of the entity involved).
-
- RM References: 3.02.01 (3) 3.02.02 (2) 3.03.01 (2/2) 3.08 (6)
- 3.09.03 (1.1/2) 6.01 (2/2) 6.07 (2/2) 9.05.02 (2/2) 7.01 (3) 7.03
- (2) 7.03 (3) 9.01 (2/2) 9.01 (3/2) 9.04 (2/2) 9.04 (3/2)
- 9.05.02 (2/2) 11.01 (2) 12.01 (3) 12.03 (2/2) 12.04 (2/2) 12.05 (2)
- 12.06 (2.1/2) 12.06 (2.2/2) 12.07 (2) 13.01 (0.1/2) 13.03 (5/1)
- 13.03.01 (0)
-
-.. index:: AI-0185 (Ada 2012 feature)
-
-* *AI-0185 Ada.Wide_[Wide_]Characters.Handling (2010-07-06)*
-
- Two new packages ``Ada.Wide_[Wide_]Characters.Handling`` provide
- classification functions for ``Wide_Character`` and
- ``Wide_Wide_Character``, as well as providing
- case folding routines for ``Wide_[Wide_]Character`` and
- ``Wide_[Wide_]String``.
-
- RM References: A.03.05 (0) A.03.06 (0)
-
-.. index:: AI-0188 (Ada 2012 feature)
-
-* *AI-0188 Case expressions (2010-01-09)*
-
- Case expressions are permitted. This allows use of constructs such as:
-
- .. code-block:: ada
-
- X := (case Y is when 1 => 2, when 2 => 3, when others => 31)
-
- RM References: 4.05.07 (0) 4.05.08 (0) 4.09 (12) 4.09 (33)
-
-.. index:: AI-0189 (Ada 2012 feature)
-
-* *AI-0189 No_Allocators_After_Elaboration (2010-01-23)*
-
- This AI introduces a new restriction ``No_Allocators_After_Elaboration``,
- which says that no dynamic allocation will occur once elaboration is
- completed.
- In general this requires a run-time check, which is not required, and which
- GNAT does not attempt. But the static cases of allocators in a task body or
- in the body of the main program are detected and flagged at compile or bind
- time.
-
- RM References: D.07 (19.1/2) H.04 (23.3/2)
-
-.. index:: AI-0190 (Ada 2012 feature)
-
-* *AI-0190 pragma Default_Storage_Pool (2010-09-15)*
-
- This AI introduces a new pragma ``Default_Storage_Pool``, which can be
- used to control storage pools globally.
- In particular, you can force every access
- type that is used for allocation (**new**) to have an explicit storage pool,
- or you can declare a pool globally to be used for all access types that lack
- an explicit one.
-
- RM References: D.07 (8)
-
-.. index:: AI-0193 (Ada 2012 feature)
-
-* *AI-0193 Alignment of allocators (2010-09-16)*
-
- This AI introduces a new attribute ``Max_Alignment_For_Allocation``,
- analogous to ``Max_Size_In_Storage_Elements``, but for alignment instead
- of size.
-
- RM References: 13.11 (16) 13.11 (21) 13.11.01 (0) 13.11.01 (1)
- 13.11.01 (2) 13.11.01 (3)
-
-.. index:: AI-0194 (Ada 2012 feature)
-
-* *AI-0194 Value of Stream_Size attribute (0000-00-00)*
-
- The ``Stream_Size`` attribute returns the default number of bits in the
- stream representation of the given type.
- This value is not affected by the presence
- of stream subprogram attributes for the type. GNAT has always implemented
- this interpretation.
-
- RM References: 13.13.02 (1.2/2)
-
-.. index:: AI-0195 (Ada 2012 feature)
-
-* *AI-0195 Invalid value handling is implementation defined (2010-07-03)*
-
- The handling of invalid values is now designated to be implementation
- defined. This is a documentation change only, requiring Annex M in the GNAT
- Reference Manual to document this handling.
- In GNAT, checks for invalid values are made
- only when necessary to avoid erroneous behavior. Operations like assignments
- which cannot cause erroneous behavior ignore the possibility of invalid
- values and do not do a check. The date given above applies only to the
- documentation change, this behavior has always been implemented by GNAT.
-
- RM References: 13.09.01 (10)
-
-.. index:: AI-0196 (Ada 2012 feature)
-
-* *AI-0196 Null exclusion tests for out parameters (0000-00-00)*
-
- Null exclusion checks are not made for ``out`` parameters when
- evaluating the actual parameters. GNAT has never generated these checks.
-
- RM References: 6.04.01 (13)
-
-.. index:: AI-0198 (Ada 2012 feature)
-
-* *AI-0198 Inheriting abstract operators (0000-00-00)*
-
- This AI resolves a conflict between two rules involving inherited abstract
- operations and predefined operators. If a derived numeric type inherits
- an abstract operator, it overrides the predefined one. This interpretation
- was always the one implemented in GNAT.
-
- RM References: 3.09.03 (4/3)
-
-.. index:: AI-0199 (Ada 2012 feature)
-
-* *AI-0199 Aggregate with anonymous access components (2010-07-14)*
-
- A choice list in a record aggregate can include several components of
- (distinct) anonymous access types as long as they have matching designated
- subtypes.
-
- RM References: 4.03.01 (16)
-
-.. index:: AI-0200 (Ada 2012 feature)
-
-* *AI-0200 Mismatches in formal package declarations (0000-00-00)*
-
- This AI plugs a gap in the RM which appeared to allow some obviously intended
- illegal instantiations. GNAT has never allowed these instantiations.
-
- RM References: 12.07 (16)
-
-.. index:: AI-0201 (Ada 2012 feature)
-
-* *AI-0201 Independence of atomic object components (2010-07-22)*
-
- If an Atomic object has a pragma ``Pack`` or a ``Component_Size``
- attribute, then individual components may not be addressable by independent
- tasks. However, if the representation clause has no effect (is confirming),
- then independence is not compromised. Furthermore, in GNAT, specification of
- other appropriately addressable component sizes (e.g. 16 for 8-bit
- characters) also preserves independence. GNAT now gives very clear warnings
- both for the declaration of such a type, and for any assignment to its components.
-
- RM References: 9.10 (1/3) C.06 (22/2) C.06 (23/2)
-
-.. index:: AI-0203 (Ada 2012 feature)
-
-* *AI-0203 Extended return cannot be abstract (0000-00-00)*
-
- A return_subtype_indication cannot denote an abstract subtype. GNAT has never
- permitted such usage.
-
- RM References: 3.09.03 (8/3)
-
-.. index:: AI-0205 (Ada 2012 feature)
-
-* *AI-0205 Extended return declares visible name (0000-00-00)*
-
- This AI corrects a simple omission in the RM. Return objects have always
- been visible within an extended return statement.
-
- RM References: 8.03 (17)
-
-.. index:: AI-0206 (Ada 2012 feature)
-
-* *AI-0206 Remote types packages and preelaborate (2010-07-24)*
-
- Remote types packages are now allowed to depend on preelaborated packages.
- This was formerly considered illegal.
-
- RM References: E.02.02 (6)
-
-.. index:: AI-0207 (Ada 2012 feature)
-
-* *AI-0207 Mode conformance and access constant (0000-00-00)*
-
- This AI confirms that access_to_constant indication must match for mode
- conformance. This was implemented in GNAT when the qualifier was originally
- introduced in Ada 2005.
-
- RM References: 6.03.01 (16/2)
-
-.. index:: AI-0208 (Ada 2012 feature)
-
-* *AI-0208 Characteristics of incomplete views (0000-00-00)*
-
- The wording in the Ada 2005 RM concerning characteristics of incomplete views
- was incorrect and implied that some programs intended to be legal were now
- illegal. GNAT had never considered such programs illegal, so it has always
- implemented the intent of this AI.
-
- RM References: 3.10.01 (2.4/2) 3.10.01 (2.6/2)
-
-.. index:: AI-0210 (Ada 2012 feature)
-
-* *AI-0210 Correct Timing_Events metric (0000-00-00)*
-
- This is a documentation only issue regarding wording of metric requirements,
- that does not affect the implementation of the compiler.
-
- RM References: D.15 (24/2)
-
-.. index:: AI-0211 (Ada 2012 feature)
-
-* *AI-0211 No_Relative_Delays forbids Set_Handler use (2010-07-09)*
-
- The restriction ``No_Relative_Delays`` forbids any calls to the subprogram
- ``Ada.Real_Time.Timing_Events.Set_Handler``.
-
- RM References: D.07 (5) D.07 (10/2) D.07 (10.4/2) D.07 (10.7/2)
-
-.. index:: AI-0214 (Ada 2012 feature)
-
-* *AI-0214 Defaulted discriminants for limited tagged (2010-10-01)*
-
- Ada 2012 relaxes the restriction that forbids discriminants of tagged types
- to have default expressions by allowing them when the type is limited. It
- is often useful to define a default value for a discriminant even though
- it can't be changed by assignment.
-
- RM References: 3.07 (9.1/2) 3.07.02 (3)
-
-.. index:: AI-0216 (Ada 2012 feature)
-
-* *AI-0216 No_Task_Hierarchy forbids local tasks (0000-00-00)*
-
- It is clearly the intention that ``No_Task_Hierarchy`` is intended to
- forbid tasks declared locally within subprograms, or functions returning task
- objects, and that is the implementation that GNAT has always provided.
- However the language in the RM was not sufficiently clear on this point.
- Thus this is a documentation change in the RM only.
-
- RM References: D.07 (3/3)
-
-.. index:: AI-0219 (Ada 2012 feature)
-
-* *AI-0219 Pure permissions and limited parameters (2010-05-25)*
-
- This AI refines the rules for the cases with limited parameters which do not
- allow the implementations to omit 'redundant'. GNAT now properly conforms
- to the requirements of this binding interpretation.
-
- RM References: 10.02.01 (18/2)
-
-.. index:: AI-0220 (Ada 2012 feature)
-
-* *AI-0220 Needed components for aggregates (0000-00-00)*
-
- This AI addresses a wording problem in the RM that appears to permit some
- complex cases of aggregates with nonstatic discriminants. GNAT has always
- implemented the intended semantics.
-
- RM References: 4.03.01 (17)
diff --git a/gcc/ada/doc/gnat_rm/implementation_of_ada_2022_features.rst b/gcc/ada/doc/gnat_rm/implementation_of_ada_2022_features.rst
new file mode 100644
index 0000000..f9ff068
--- /dev/null
+++ b/gcc/ada/doc/gnat_rm/implementation_of_ada_2022_features.rst
@@ -0,0 +1,2249 @@
+.. _Implementation_of_Ada_2022_Features:
+
+***********************************
+Implementation of Ada 2022 Features
+***********************************
+
+.. index:: Ada 2022 implementation status
+
+.. index:: -gnat22 option (gcc)
+
+.. index:: pragma Ada_2022
+
+.. index:: configuration pragma Ada_2022
+
+.. index:: Ada_2022 configuration pragma
+
+This chapter contains a complete list of Ada 2022 features that have been
+implemented. Generally, these features are only available if the *-gnat22* (Ada 2022 features enabled) option is set, or if the configuration pragma ``Ada_2022`` is used.
+
+However, new pragmas, attributes, and restrictions are unconditionally available, since the Ada standard allows the addition of new pragmas, attributes, and restrictions (there are exceptions, which are
+documented in the individual descriptions), and also certain packages
+were made available in earlier versions of Ada.
+
+An ISO date (YYYY-MM-DD) appears in parentheses on the description line.
+This date shows the implementation date of the feature. Any wavefront
+subsequent to this date will contain the indicated feature, as will any
+subsequent releases. A date of 0000-00-00 means that GNAT has always
+implemented the feature, or implemented it as soon as it appeared as a
+binding interpretation.
+
+Each feature corresponds to an Ada Issue ('AI') approved by the Ada
+standardization group (ISO/IEC JTC1/SC22/WG9) for inclusion in Ada 2022.
+
+The section "RM references" lists all modified paragraphs in the Ada 2012 reference manual. The details of each modification as well as a complete description of the AIs may be found in
+http://www.ada-auth.org/AI12-SUMMARY.HTML.
+
+.. index:: AI12-0001 (Ada 2022 feature)
+
+* *AI12-0001 Independence and Representation clauses for atomic objects (2019-11-27)*
+
+ The compiler accepts packing clauses in all cases, even if they have effectively no influence on the layout. Types, where packing is essentially infeasible are, for instance atomic, aliased and by-reference types.
+
+ RM references: 13.02 (6.1/2) 13.02 (7) 13.02 (8) 13.02 (9/3) C.06 (8.1/3)
+ C.06 (10) C.06 (11) C.06 (21) C.06 (24)
+
+.. index:: AI12-0003 (Ada 2022 feature)
+
+* *AI12-0003 Specifying the standard storage pool (2020-06-25)*
+
+ Allows the standard storage pool being specified with a ``Default_Storage_Pool`` pragma or aspect.
+
+ RM references: 8.02 (11) 13.11.03 (1/3) 13.11.03 (3.1/3) 13.11.03 (4/3)
+ 13.11.03 (4.1/3) 13.11.03 (5/3) 13.11.03 (6.2/3) 13.11.03
+ (6.3/3)
+
+.. index:: AI12-0004 (Ada 2022 feature)
+
+* *AI12-0004 Normalization and allowed characters for identifiers (2020-06-11)*
+
+ This AI clarifies that Ada identifiers containing characters which are not
+ allowed in Normalization Form KC are illegal.
+
+ RM references: 2.01 (4.1/3) 2.03 (4/3) A.03.02 (4/3) A.03.02 (32.5/3)
+ A.03.05 (18/3) A.03.05 (51/3)
+
+.. index:: AI12-0020 (Ada 2022 feature)
+
+* *AI12-0020 'Image for all types (2020-03-30)*
+
+ Put_Image prints out a human-readable representation of an object. The
+ functionality in Ada2022 RM is fully implemented except the support for
+ types in the ``Remote_Types`` packages.
+
+ RM references: 4.10 (0) 3.05 (27.1/2) 3.05 (27.2/2) 3.05 (27.3/2) 3.05
+ (27.4/2) 3.05 (27.5/2) 3.05 (27.6/2) 3.05 (27.7/2) 3.05 (28) 3.05
+ (29) 3.05 (30/3) 3.05 (31) 3.05 (32) 3.05 (33/3) 3.05 (37.1/2)
+ 3.05 (38) 3.05 (39) 3.05 (43/3) 3.05 (55/3) 3.05 (55.1/5) 3.05
+ (55.2/4) 3.05 (55.3/4) 3.05 (55.4/4) 3.05 (59) H.04 (23) H.04 (23.8/2)
+
+.. index:: AI12-0022 (Ada 2022 feature)
+
+* *AI12-0022 Raise_Expressions (2013-01-27)*
+
+ This feature allows you to write "raise NAME [with STRING]" in an
+ expression to rise given exception. It is particularly useful in the case of
+ assertions such as preconditions allowing to specify which exception a
+ precondition raises if it fails.
+
+ RM references: 4.04 (3/3) 11.02 (6) 11.03 (2/2) 11.03 (3) 11.03 (3.1/2)
+ 11.03 (4/2) 11.04.01 (10.1/3)
+
+.. index:: AI12-0027 (Ada 2022 feature)
+
+* *AI12-0027 Access values should never designate unaliased components (2020-06-15)*
+
+ AI12-0027 adds a requirement for a value conversion that converts from an array of unaliased components to an array of aliased components to make a copy. It defines such conversions to have a local accessibility, effectively preventing the possibility of unsafe accesses to unaliased components.
+
+ RM references: 4.06 (24.17/3) 4.06 (24.21/2) 4.06 (58) 6.02 (10/3) 3.10.02 (10/3)
+
+.. index:: AI12-0028 (Ada 2022 feature)
+
+* *AI12-0028 Import of variadic C functions (2020-03-03)*
+
+ Ada programs can now properly call variadic C functions by means of the
+ conventions C_Variadic_<n>, for small integer values <n>.
+
+ RM references: B.03 (1/3) B.03 (60.15/3) B.03 (75)
+
+.. index:: AI12-0030 (Ada 2022 feature)
+
+* *AI12-0030 Formal derived types and stream attribute availability (2020-08-21)*
+
+ Corner cases involving streaming operations for formal derived limited types
+ that are now defined to raise Program_Error. Before, behavior in these cases
+ was undefined. Stream attribute availability is more precisely computed in cases where a derived type declaration occurs ahead of a streaming attribute specification for the parent type.
+
+ RM references: 12.05.01 (21/3) 13.13.02 (49/2)
+
+.. index:: AI12-0031 (Ada 2022 feature)
+
+* *AI12-0031 All_Calls_Remote and indirect calls (0000-00-00)*
+
+ Remote indirect calls (i.e., calls through a remote access-to-subprogram type)
+ behave the same as remote direct calls.
+
+ RM references: E.02.03 (19/3)
+
+.. index:: AI12-0032 (Ada 2022 feature)
+
+* *AI12-0032 Questions on 'Old (2020-04-24)*
+
+ AI12-0032 resolves several issues related to the 'Old attribute. The GNAT
+ compiler already implemented what the AI requires in most of those cases, but two having to do with static and dynamic checking of the accessibility level of the constant object implicitly declared for an 'Old attribute reference were not yet implemented. Accessibility checking for these constants is now implemented as defined in the AI.
+
+ RM references: 4.01.03 (9/3) 6.01.01 (22/3) 6.01.01 (26/3) 6.01.01 (35/3)
+
+.. index:: AI12-0033 (Ada 2022 feature)
+
+* *AI12-0033 Sets of CPUs when defining dispatching domains (0000-00-00)*
+
+ The set of CPUs associated with a dispatching domain is no longer required
+ to be a contiguous range of CPU values.
+
+ RM references: D.16.01 (7/3) D.16.01 (9/3) D.16.01 (20/3) D.16.01 (23/3)
+ D.16.01 (24/3) D.16.01 (26/3)
+
+.. index:: AI12-0035 (Ada 2022 feature)
+
+* *AI12-0035 Accessibility checks for indefinite elements of containers (0000-00-00)*
+
+ If the element type for an instance of one of the indefinite container generics has an access discriminant, then accessibility checks (at run-time) prevent inserting a value into a container object if the value's discriminant designates an object that is too short-lived (that is, if the designated object has an accessibility level that is deeper than that of the instance). Without this check, dangling references would be possible. GNAT handled this correctly already before this AI was issued.
+
+ RM references: A.18 (5/3) A.18.11 (8/2) A.18.12 (7/2) A.18.13 (8/2)
+ A.18.14 (8/2) A.18.15 (4/2) A.18.16 (4/2) A.18.17 (7/3) A.18.18
+ (39/3) A.18.18 (47/3)
+
+.. index:: AI12-0036 (Ada 2022 feature)
+
+* *AI12-0036 The actual for an untagged formal derived type cannot be tagged (2019-10-21)*
+
+ AI12-0036 is a binding interpretation that adds the following legality rule:
+ The actual type for a formal derived type shall be tagged if and only if the
+ formal derived type is a private extension. The check is implemented for all Ada dialects, not just Ada 2022.
+
+ RM references: 12.05.01 (5.1/3)
+
+.. index:: AI12-0037 (Ada 2022 feature)
+
+* *AI12-0037 New types in Ada.Locales can't be converted to/from strings (2016-09-10)*
+
+ The type definitions for Language_Code and Country_Code are now using dynamic
+ predicates.
+
+ RM references: A.19 (4/3)
+
+.. index:: AI12-0039 (Ada 2022 feature)
+
+* *AI12-0039 Ambiguity in syntax for membership expression removed (0000-00-00)*
+
+ An ambiguity in the syntax for membership expressions was resolved. For example, "A in B and C" can be parsed in only one way because of this AI.
+
+ RM references: 4.04 (3/3) 4.04 (3.2/3) 4.05.02 (3.1/3) 4.05.02 (4) 4.05.02
+ (4.1/3) 4.05.02 (27/3) 4.05.02 (27.1/3) 4.05.02 (28.1/3) 4.05.02
+ (28.2/3) 4.05.02 (29/3) 4.05.02 (30/3) 4.05.02 (30.1/3) 4.05.02
+ (30.2/3) 4.05.02 (30.3/3) 4.09 (11/3) 4.09 (32.6/3) 8.06 (27.1/3)
+ 3.02.04 (17/3)
+
+.. index:: AI12-0040 (Ada 2022 feature)
+
+* *AI12-0040 Resolving the selecting_expression of a case_expression (0000-00-00)*
+
+ The definition of "complete context" is corrected so that selectors of case expressions
+ and of case statements are treated uniformly.
+
+ RM references: 8.06 (9)
+
+.. index:: AI12-0041 (Ada 2022 feature)
+
+* *AI12-0041 Type_Invariant'Class for interface types (2016-12-12)*
+
+ Subprogram calls within class-wide type invariant expressions get resolved
+ as primitive operations instead of being dynamically dispatched.
+
+ RM references: 7.03.02 (1/3) 7.03.02 (3/3)
+
+.. index:: AI12-0042 (Ada 2022 feature)
+
+* *AI12-0042 Type invariant checking rules (2020-06-05)*
+
+ AI12-0042 adds rules for type invariants.
+ Specifically, when inheriting a private dispatching operation when the ancestor operation is visible at the point of the type extension, the operation must be abstract or else overridden. In addition, for a class-wide view conversion from an object of a specific type T to which a type invariant applies, an invariant check is performed when the conversion is within the immediate scope of T.
+
+ RM references: 7.03.02 (6/3) 7.03.02 (17/3) 7.03.02 (18/3) 7.03.02 (19/3)
+ 7.03.02 (20/3)
+
+.. index:: AI12-0043 (Ada 2022 feature)
+
+* *AI12-0043 Details of the storage pool used when Storage_Size is specified (0000-00-00)*
+
+ Clarify that a Storage_Size specification for an access type specifies both an upper bound and a lower bound (not just a lower bound) of the amount of storage allowed for allocated objects.
+
+ RM references: 13.11 (18)
+
+.. index:: AI12-0044 (Ada 2022 feature)
+
+* *AI12-0044 Calling visible functions from type invariant expressions (2020-05-11)*
+
+ AI05-0289-1 extends invariant checking to `in` parameters. However, this makes
+ it impossible to call a public function of the type from an invariant
+ expression, as that public function will attempt to check the invariant,
+ resulting in an infinite recursion.
+
+ This AI specifies, that type-invariant checking is performed on parameters
+ of mode `in` upon return from procedure calls, but not of `in`-mode
+ parameters in functions.
+
+ RM references: 7.03.02 (19/3)
+
+.. index:: AI12-0045 (Ada 2022 feature)
+
+* *AI12-0045 Pre- and Postconditions are allowed on generic subprograms (2015-03-17)*
+
+ The SPARK toolset now supports contracts on generic subprograms, packages and
+ their respective bodies.
+
+ RM references: 6.01.01 (1/3)
+
+.. index:: AI12-0046 (Ada 2022 feature)
+
+* *AI12-0046 Enforcing legality for anonymous access components in record aggregates (0000-00-00)*
+
+ For a record aggregate of the form (X | Y => ....), any relevant legality rules are checked for both for X and Y.
+
+ For example,
+
+ .. code::
+
+ X : aliased constant String := ... ;
+ type R is record
+ F1 : access constant String;
+ F2 : access String;
+ end record;
+ Obj : R := (F1 | F2 => X'Access); -- ok for F1, but illegal for F2
+
+ RM references: 4.03.01 (16/3)
+
+.. index:: AI12-0047 (Ada 2022 feature)
+
+* *AI12-0047 Generalized iterators and discriminant-dependent components (0000-00-00)*
+
+ Iterating over the elements of an array is subject to the same legality checks as renaming the array. For example, if an assignment to an enclosing discriminated object could cause an array object to cease to exist then we don't allow renaming the array. So it is similarly not allowed to iterate over the elements of such an array.
+
+ RM references: 5.05.02 (6/3)
+
+.. index:: AI12-0048 (Ada 2022 feature)
+
+* *AI12-0048 Default behavior of tasks on a multiprocessor with a specified dispatching policy (0000-00-00)*
+
+ Clarify that if the user does not impose requirements about what CPUs a given task might execute on, then the implementation does not get to impose such requirements. This avoids potential problems with priority inversion.
+
+ RM references: D.16.01 (30/3)
+
+.. index:: AI12-0049 (Ada 2022 feature)
+
+* *AI12-0049 Invariants need to be checked on the initialization of deferred constants (0000-00-00)*
+
+ Invariant checking for deferred constants (and subcomponents thereof) is performed. Corrects a clear oversight in the previous RM wording.
+
+ RM references: 7.03.02 (10/3)
+
+.. index:: AI12-0050 (Ada 2022 feature)
+
+* *AI12-0050 Conformance of quantified expressions (2016-07-22)*
+
+ Compiler rejects a subprogram body when an expression for a boolean formal
+ parameter includes a quantified expression, and the subprogram declaration
+ contains a textual copy of the same.
+
+ RM references: 6.03.01 (20) 6.03.01 (21)
+
+.. index:: AI12-0051 (Ada 2022 feature)
+
+* *AI12-0051 The Priority aspect can be specified when Attach_Handler is specified (0000-00-00)*
+
+ Previous RM wording had two contradictory rules for determining (in some cases) the priority of a protected subprogram that is attached to an interrupt. The AI clarifies which one of the rules takes precedence.
+
+ RM references: D.03 (10/3)
+
+.. index:: AI12-0052 (Ada 2022 feature)
+
+* *AI12-0052 Implicit objects are considered overlapping (0000-00-00)*
+
+ Clarify that the rules about unsynchronized concurrent access apply as one would expect in the case of predefined routines that access Text_IO's default input and default output files. There was no compiler changes needed to implement this.
+
+ RM references: A (3/2) A.10.03 (21)
+
+.. index:: AI12-0054-2 (Ada 2022 feature)
+
+* *AI12-0054-2 Aspect Predicate_Failure (0000-00-00)*
+
+ New aspect Predicate_Failure is defined. A solution for the problem that a predicate like
+
+ .. code::
+
+ subtype Open_File is File with Dynamic_Predicate =\> Is_Open (Open_File) or else (raise File_Not_Open);
+
+ does the wrong thing in the case of a membership test.
+
+ RM references: 3.02.04 (14/3) 3.02.04 (31/3) 3.02.04 (35/3)
+
+.. index:: AI12-0055 (Ada 2022 feature)
+
+* *AI12-0055 All properties of a usage profile are defined by pragmas (2020-06-09)*
+
+ AI12-0055 allows the use of the No_Dynamic_CPU_Assignment restriction in pragmas Restrictions and Restrictions_Warnings.
+
+ RM references: D.07 (10/3) D.13 (6/3) D.13 (8/3) D.13 (10/3)
+
+.. index:: AI12-0059 (Ada 2022 feature)
+
+* *AI12-0059 Object_Size attribute (2019-12-02)*
+
+ AI12-0059 brings GNAT-defined attribute Object_Size to Ada standard
+ and clarifies its semantics. Given that the attribute already existed in
+ GNAT compiler, the feature is supported for all language versions.
+
+ RM references: 4.09.01 (2/3) 13.01 (14) 13.01 (23) 13.03 (9/3) 13.03
+ (50/2) 13.03 (51) 13.03 (52) 13.03 (58)
+
+.. index:: AI12-0061 (Ada 2022 feature)
+
+* *AI12-0061 Iterated component associations in array aggregates (2016-09-01)*
+
+ Ada issue AI12-061 introduces a new construct in array aggregates allowing
+ component associations to be parameterized by a loop variable, for example:
+
+ .. code::
+
+ Array (1 .. 10) of Integer :=
+ (for I in 1 .. 10 => I ** 2);
+ type Matrix is
+ array
+ (Positive range <>, Positive range <>) of Float;
+ G : constant Matrix
+ :=
+ (for I in 1 .. 4 =>
+ (for J in 1 .. 4 =>
+ (if I=J then
+ 1.0 else 0.0))); -- Identity matrix
+
+ The expression in such an association can also be a function that returns a
+ limited type, and the range can be specified by the 'others' choice.
+
+ RM references: 4.03.03 (5/2) 4.03.03 (6) 4.03.03 (17/3) 4.03.03 (20)
+ 4.03.03 (23.1/4) 4.03.03 (32/3) 4.03.03 (43) 3.01 (6/3) 3.03 (6)
+ 3.03 (18.1/3) 3.03.01 (23/3) 5.05 (6) 8.01 (2.1/4)
+
+.. index:: AI12-0062 (Ada 2022 feature)
+
+* *AI12-0062 Raise exception with failing string function (0000-00-00)*
+
+ Clarify that if raising exception E1 is accompanied with a String-valued
+ expression whose evaluation raises exception E2, then E2 is what gets propagated.
+
+ RM references: 11.03 (4/2)
+
+.. index:: AI12-0065 (Ada 2022 feature)
+
+* *AI12-0065 Descendants of incomplete views (0000-00-00)*
+
+ This AI is a clarification of potentially confusing wording. GNAT correctly handles the example given in AARM 7.3.1(5.b-5.d), which illustrates the topic of this AI.
+
+ RM references: 7.03.01 (5.2/3)
+
+.. index:: AI12-0067 (Ada 2022 feature)
+
+* *AI12-0067 Accessibility level of explicitly aliased parameters of procedures and entries (0000-00-00)*
+
+ The AI fixes a case where the intent was fairly obvious but the RM wording failed to mention a case (with the result that the accessibility level of an explicitly aliased parameter of a procedure or entry was undefined even though the intent was clear).
+
+ RM references: 3.10.02 (7/3)
+
+.. index:: AI12-0068 (Ada 2022 feature)
+
+* *AI12-0068 Predicates and the current instance of a subtype (2020-05-06)*
+
+ AI12-0068 is a binding interpretation that defines the current instance name in a type or subtype aspect to be a value rather than an object. This affects
+ attributes whose prefix is a current instance in predicates, type invariants, and ``Default_Initial_Condition`` aspects. In particular, in the case of the ``Constrained`` attribute the value will always be True, and formerly legal attributes that require an object as their prefix (such as ``Size``, ``Access``, ``Address``, etc.) are illegal when applied to a current instance in type and subtype aspects.
+
+ RM references: 8.06 (17/3)
+
+.. index:: AI12-0069 (Ada 2022 feature)
+
+* *AI12-0069 Inconsistency in Tree container definition (0000-00-00)*
+
+ The description of how iteration over a Tree container's elements was contradictory in some cases regarding whether a cursor designating the Root node is included in the iteration. This contradiction was resolved. In the "!ACATS Test" section of the AI, it says that if an implementation were to get this wrong then almost any attempt to iterate over any tree would fail at runtime.
+
+ RM references: A.18.10 (153/3) A.18.10 (155/3) A.18.10 (157/3) A.18.10 (159/3)
+
+.. index:: AI12-0070 (Ada 2022 feature)
+
+* *AI12-0070 9.3(2) does not work for anonymous access types (0000-00-00)*
+
+ The RM contained some old wording about the master of an allocated object that only made sense for named access types. The AI clarifies the wording to clearly state the scope of validity and ensures that the paragraph does not contradict 3.10.2's rules for anonymous access types.
+
+ RM references: 3.10.02 (13.1/3) 9.03 (2)
+
+.. index:: AI12-0071 (Ada 2022 feature)
+
+* *AI12-0071 Order of evaluation when multiple predicates apply (2015-08-10)*
+
+ AI12-0071 specifies the semantics of multiple/inherited predicates on a
+ single subtype.
+
+ RM references: 3.02.04 (4/3) 3.02.04 (6/3) 3.02.04 (30/3) 3.02.04 (31/3)
+ 3.02.04 (32/3) 3.02.04 (33/3) 3.02.04 (35/3) 3.05.05 (7.1/3)
+ 3.05.05 (7.2/3) 3.05.05 (7.3/3) 3.08.01 (10.1/3) 3.08.01 (15/3)
+ 4.05.02 (29/3) 4.05.02 (30/3) 4.06 (51/3) 4.09.01 (10/3) 5.04
+ (7/3) 5.05 (9/3) 13.09.02 (3/3) 13.09.02 (12)
+
+.. index:: AI12-0072 (Ada 2022 feature)
+
+* *AI12-0072 Missing rules for Discard_Names aspect (0000-00-00)*
+
+ Clarify that Discard_Names is an aspect, not just a pragma.
+
+ RM references: C.05 (1) C.05 (5) C.05 (7/2) C.05 (8)
+
+.. index:: AI12-0073 (Ada 2022 feature)
+
+* *AI12-0073 Synchronous Barriers are not allowed with Ravenscar (2020-02-24)*
+
+ Ada 2022 adds (as a binding interpretation) a ``No_Dependence =>
+ Ada.Synchronous_Barriers`` restriction to the Ravenscar profile.
+
+ RM references: D.13 (6/3)
+
+.. index:: AI12-0074 (Ada 2022 feature)
+
+* *AI12-0074 View conversions and out parameters passed by copy (2020-03-26)*
+
+ This Ada 2022 AI makes illegal some cases of out parameters whose type has a
+ ``Default_Value`` aspect.
+
+ RM references: 4.06 (56) 6.04.01 (6.25/3) 6.04.01 (13.1/3)
+
+.. index:: AI12-0075 (Ada 2022 feature)
+
+* *AI12-0075 Static expression functions (2020-04-13)*
+
+ Ada 2022 defines a new aspect ``Static`` that can be specified on expression
+ functions. Such an expression function can be called in contexts requiring static expressions when the actual parameters are all static, allowing for greater abstraction in complex static expressions.
+
+ RM references: 4.09 (21) 6.08 (3/4) 6.08 (5/4) 6.08 (6/4) 7.03.02 (8.2/5)
+ 7.03.02 (15/4) 7.03.02 (16/4) 7.03.02 (17/4) 7.03.02 (19/4)
+ 7.03.02 (20/5)
+
+.. index:: AI12-0076 (Ada 2022 feature)
+
+* *AI12-0076 Variable state in pure packages (0000-00-00)*
+
+ Defines an obscure constant-modifying construct to be erroneous. The issue is that the current instance of a type is a variable object, so the following is legal:
+
+ .. code::
+
+ type T;
+ type T_Ref (Access_To_Variable : access T) is null record;
+ type T is limited record
+ Self : T_Ref (T'Access);
+ Int : Integer;
+ end record;
+
+ Obj : constant T := (Self => <>, Int => 123);
+ begin
+ Obj.Self.Access_To_Variable.Int := 456; -- modifying a component of a constant
+
+ In cases where constancy is really needed (e.g., for an object declared in a Pure context), such a case needs to be erroneous.
+
+ RM references: 10.02.01 (17/3) E.02.02 (17/2)
+
+.. index:: AI12-0077 (Ada 2022 feature)
+
+* *AI12-0077 Has_Same_Storage on objects of size zero (2020-03-30)*
+
+ This binding interpretation requires the Has_Same_Storage attribute
+ to return always `false` for objects that have a size of zero.
+
+ RM references: 13.03 (73.4/3)
+
+.. index:: AI12-0078 (Ada 2022 feature)
+
+* *AI12-0078 Definition of node for tree container is confusing (0000-00-00)*
+
+ Clarifies the expected behavior in processing tree containers.
+
+ RM references: A.18.10 (2/3) A.18.10 (3/3)
+
+.. index:: AI12-0081 (Ada 2022 feature)
+
+* *AI12-0081 Real-time aspects need to specify when they are evaluated (0000-00-00)*
+
+ Clarify the point at which Priority and Interrupt_Priority aspect expressions are evaluated.
+
+ RM references: D.01 (17/3) D.16 (9/3)
+
+.. index:: AI12-0084 (Ada 2022 feature)
+
+* *AI12-0084 Box expressions in array aggregates (2014-12-15)*
+
+ This AI addresses an issue where compiler used to fail to initialize
+ components of a multidimensional aggregates with box initialization when
+ scalar components have a specified default value. The AI clarifies that
+ in an array aggregate with box (i.e., ``<>``) component values, the
+ ``Default_Component_Value`` of the array type (if any) should not be ignored.
+
+ RM references: 4.03.03 (23.1/2)
+
+.. index:: AI12-0085 (Ada 2022 feature)
+
+* *AI12-0085 Missing aspect cases for Remote_Types (0000-00-00)*
+
+ A distributed systems annex (Annex E) clarification. Aspect specifications
+ that are forbidden using attribute definition clause syntax are also forbidden
+ using aspect_specification syntax.
+
+ RM references: E.02.02 (17/2)
+
+.. index:: AI12-0086 (Ada 2022 feature)
+
+* *AI12-0086 Aggregates and variant parts (2019-08-14)*
+
+ In Ada 2012, a discriminant value that governs an active variant part in an
+ aggregate had to be static. AI12-0086 relaxes this restriction: If the subtype of the discriminant value is a static subtype all of whose values select the same variant, then the expression for the discriminant is allowed to be nonstatic.
+
+ RM references: 4.03.01 (17/3) 4.03.01 (19/3)
+
+.. index:: AI12-0088 (Ada 2022 feature)
+
+* *AI12-0088 UTF_Encoding.Conversions and overlong characters on input (0000-00-00)*
+
+ Clarify that overlong characters are acceptable on input even if we never generate them as output.
+
+ RM references: A.04.11 (54/3) A.04.11 (55/3)
+
+.. index:: AI12-0089 (Ada 2022 feature)
+
+* *AI12-0089 Accessibility rules need to take into account that a generic function is not a (0000-00-00)*
+
+ Fix cases in RM wording where the accessibility rules for a function failed to take into account the fact that a generic function is not a function. For example, a generic function with an explicitly aliased parameter should be able to return references to that parameter in the same ways that a (non-generic) function can. The previous wording did not allow that.
+
+ RM references: 3.10.02 (7/3) 3.10.02 (19.2/3) 3.10.02 (19.3/3) 6.05 (4/3)
+
+.. index:: AI12-0093 (Ada 2022 feature)
+
+* *AI12-0093 Iterator with indefinite cursor (0000-00-00)*
+
+ A clarification that confirms what GNAT is already doing.
+
+ RM references: 5.05.02 (8/3) 5.05.02 (10/3)
+
+.. index:: AI12-0094 (Ada 2022 feature)
+
+* *AI12-0094 An access_definition should be a declarative region (0000-00-00)*
+
+ Fixes wording omission in the RM, confirming that the behaviour of GNAT is
+ correct.
+
+ RM references: 8.03 (2) 8.03 (26/3)
+
+.. index:: AI12-0095 (Ada 2022 feature)
+
+* *AI12-0095 Generic formal types and constrained partial views (0000-00-00)*
+
+ Deciding whether an actual parameter corresponding to an explicitly aliased formal parameter is legal depends on (among other things) whether the parameter type has a constrained partial view. The AI clarifies how this compile-time checking works in the case of a generic formal type (assume the best in the spec and recheck each instance, assume the worst in a generic body).
+
+ RM references: 3.10.02 (27.2/3) 4.06 (24.16/2) 6.04.01 (6.2/3) 12.05.01 (15)
+
+.. index:: AI12-0096 (Ada 2022 feature)
+
+* *AI12-0096 The exception raised when a subtype conversion fails a predicate check (0000-00-00)*
+
+ Clarify that the Predicate_Failure aspect works the same in a subtype conversion as in any other context.
+
+ RM references: 4.06 (57/3)
+
+.. index:: AI12-0097 (Ada 2022 feature)
+
+* *AI12-0097 Tag of the return object of a simple return expression (0000-00-00)*
+
+ Clarify wording about the tag of a function result in the case of a simple (i.e. not extended) return statement in a function with a class-wide result type.
+
+ RM references: 6.05 (8/3)
+
+.. index:: AI12-0098 (Ada 2022 feature)
+
+* *AI12-0098 Problematic examples for ATC (0000-00-00)*
+
+ The AI clarifies reference manual examples, there is no compiler impact.
+
+ RM references: 9.07.04 (13)
+
+.. index:: AI12-0099 (Ada 2022 feature)
+
+* *AI12-0099 Wording problems with predicates (2020-05-04)*
+
+ When extending a task or protected type from an ancestor interface subtype with a predicate, a link error can occur due to the compiler failing to generate the predicate-checking function. This AI clarifies the requirement for such predicate inheritance for concurrent types.
+
+ RM references: 3.02.04 (4/4) 3.02.04 (12/3) 3.02.04 (20/3)
+
+.. index:: AI12-0100 (Ada 2022 feature)
+
+* *AI12-0100 A qualified expression makes a predicate check (2020-02-17)*
+
+ The compiler now enforces predicate checks on qualified expressions when the
+ qualifying subtype imposes a predicate.
+
+ RM references: 4.07 (4)
+
+.. index:: AI12-0101 (Ada 2022 feature)
+
+* *AI12-0101 Incompatibility of hidden untagged record equality (2019-10-31)*
+
+ AI12-0101 is a binding interpretation that removes a legality rule that
+ prohibited the declaration of a primitive equality function for a private type in the private part of its enclosing package (either before or after the completion of the type) when the type is completed as an untagged record type. Such declarations are now accepted in Ada 2012 and later Ada versions.
+
+ As a consequence of this work, some cases where the implementation of AI05-0123 was incomplete were corrected.
+ More specifically, if a user-defined equality operator is present for an untagged record type in an Ada 2012 program, that user-defined equality operator will be (correctly) executed in some difficult-to-characterize cases where the predefined component-by-component comparison was previously being (incorrectly) executed. This can arise, for example, in the case of the predefined equality operation for an enclosing composite type that has a component of the user-defined primitive equality op's operand type.
+ This correction means that the impact of this change is not limited solely to code that was previously rejected at compile time.
+
+ RM references: 4.05.02 (9.8/3)
+
+.. index:: AI12-0102 (Ada 2022 feature)
+
+* *AI12-0102 Stream_IO.File_Type has Preelaborable_Initialization (0000-00-00)*
+
+ Modifies the declaration of one type in a predefined package. GNAT's version of ``Ada.Streams.Stream_IO`` already had this modification (the ``Preelaborable__Initialization`` pragma).
+
+ RM references: A.12.01 (5)
+
+.. index:: AI12-0103 (Ada 2022 feature)
+
+* *AI12-0103 Expression functions that are completions in package specifications (0000-00-00)*
+
+ Clarifies that expression functions that are completions do not cause "general" freeze-everybody-in-sight freezing like a subprogram body.
+
+ RM references: 13.14 (3/3) 13.14 (5/3)
+
+.. index:: AI12-0104 (Ada 2022 feature)
+
+* *AI12-0104 Overriding an aspect is undefined (0000-00-00)*
+
+ A clarification of the wording in RM, no compiler impact.
+
+ RM references: 4.01.06 (4/3) 4.01.06 (17/3)
+
+.. index:: AI12-0105 (Ada 2022 feature)
+
+* *AI12-0105 Pre and Post are not allowed on any subprogram completion (0000-00-00)*
+
+ Language-defined aspects (e.g., ``Post``) cannot be specified as part of the completion of a subprogram declaration. Fix a hole in the RM wording to clarify that this general rule applies even in the special cases where the completion is either an expression function or a null procedure.
+
+ RM references: 13.01.01 (18/3)
+
+.. index:: AI12-0106 (Ada 2022 feature)
+
+* *AI12-0106 Write'Class aspect (0000-00-00)*
+
+ Clarify that the syntax used in an ACATS test BDD2005 for specifying a class-wide streaming aspect is correct.
+
+ RM references: 13.01.01 (28/3) 13.13.02 (38/3)
+
+.. index:: AI12-0107 (Ada 2022 feature)
+
+* *AI12-0107 A prefixed view of a By_Protected_Procedure interface has convention protected (2020-06-05)*
+
+ A prefixed view of a subprogram with aspect Synchronization set to
+ By_Protected_Procedure has convention protected.
+
+ RM references: 6.03.01 (10.1/2) 6.03.01 (12) 6.03.01 (13)
+
+.. index:: AI12-0109 (Ada 2022 feature)
+
+* *AI12-0109 Representation of untagged derived types (2019-11-12)*
+
+ Ada disallows a nonconforming specification of a type-related representation
+ aspect of an untagged by-reference type. The motivation for this rule is to ensure that a parent type and a later type derived from the parent agree with respect to such aspects. AI12-0109 disallows a construct that otherwise could be used to get around this rule: an aspect specification for the parent type that occurs after the declaration of the derived type.
+
+ RM references: 13.01 (10/3)
+
+.. index:: AI12-0110 (Ada 2022 feature)
+
+* *AI12-0110 Tampering checks are performed first (2020-04-14)*
+
+ AI12-0110 requires tampering checks in the containers library to be
+ performed first, before any other checks.
+
+ RM references: A.18.02 (97.1/3) A.18.03 (69.1/3) A.18.04 (15.1/3) A.18.07
+ (14.1/3) A.18.10 (90/3) A.18.18 (35/3)
+
+.. index:: AI12-0112 (Ada 2022 feature)
+
+* *AI12-0112 Contracts for container operations (0000-00-00)*
+
+ A representation change replacing english descriptions of contracts for
+ operations on predefined container types with pre/post-conditions. No compiler
+ impact.
+
+ RM references: A.18.02 (99/3) 11.04.02 (23.1/3) 11.05 (23) 11.05 (26) A
+ (4) A.18 (10)
+
+.. index:: AI12-0114 (Ada 2022 feature)
+
+* *AI12-0114 Overlapping objects designated by access parameters are not thread-safe (0000-00-00)*
+
+ There are rules saying that concurrent calls to predefined subprograms don't interfere with each other unless actual parameters overlap. The AI clarifies that such an interference is also possible if overlapping objects are reachable via access dereferencing from actual parameters of the two calls.
+
+ RM references: A (3/2)
+
+.. index:: AI12-0116 (Ada 2022 feature)
+
+* *AI12-0116 Private types and predicates (0000-00-00)*
+
+ Clarify that the same aspect cannot be specified twice for the same type. ``Dynamic_Predicate``, for example, can be specified on either the partial view of a type or on the completion in the private part, but not on both.
+
+ RM references: 13.01 (9/3) 13.01 (9.1/3)
+
+.. index:: AI12-0117 (Ada 2022 feature)
+
+* *AI12-0117 Restriction No_Tasks_Unassigned_To_CPU (2020-06-12)*
+
+ This AI adds a restriction No_Tasks_Unassigned_To_CPU to provide safe
+ use of Ravenscar.
+
+ The CPU aspect is specified for the environment task. No CPU aspect is
+ specified to be statically equal to ``Not_A_Specific_CPU``. If aspect CPU
+ is specified (dynamically) to the value ``Not_A_Specific_CPU``, then
+ Program_Error is raised. If Set_CPU or ``Delay_Until_And_Set_CPU`` are called
+ with the CPU parameter equal to ``Not_A_Specific_CPU``, then ``Program_Error`` is raised.
+
+ RM references: D.07 (10.8/3)
+
+.. index:: AI12-0120 (Ada 2022 feature)
+
+* *AI12-0120 Legality and exceptions of generalized loop iteration (0000-00-00)*
+
+ Clarify that the expansion-based definition of generalized loop iteration
+ includes legality checking. If the expansion would be illegal (for example,
+ because of passing a constant actual parameter in a call when the mode of
+ the corresponding formal parameter is in-out), then the loop is illegal too.
+
+ RM references: 5.05.02 (6.1/4) 5.05.02 (10/3) 5.05.02 (13/3)
+
+.. index:: AI12-0121 (Ada 2022 feature)
+
+* *AI12-0121 Stream-oriented aspects (0000-00-00)*
+
+ Clarify that streaming-oriented aspects (e.g., Read) can be specified using
+ aspect_specification syntax, not just via an attribute definition clause.
+
+ RM references: 13.13.02 (38/3)
+
+.. index:: AI12-0124 (Ada 2022 feature)
+
+* *AI12-0124 Add Object'Image (2017-03-24)*
+
+ The corrigendum of Ada 2012 extends attribute ``'Image following`` the syntax for the GNAT ``'Img`` attribute. This AI fixes a gap in the earlier implementation, which did not recognize function calls and attributes that are functions as valid object prefixes.
+
+ RM references: 3.05 (55/3)
+
+.. index:: AI12-0125-3 (Ada 2022 feature)
+
+* *AI12-0125-3 Add @ as an abbreviation for the LHS of an assignment (2016-11-11)*
+
+ This AI introduces the use of the character '@' as an abbreviation for the left-hand side of an assignment statement, usable anywhere within the expression on the right-hand side. To use this feature the compilation flag -gnat2022 must be specified.
+
+ RM references: 5.02.01 (0) 2.02 (9) 3.03 (21.1/3) 4.01 (2/3) 8.06 (9/4)
+
+.. index:: AI12-0127 (Ada 2022 feature)
+
+* *AI12-0127 Partial aggregate notation (2016-10-12)*
+
+ This AI describes a new constructor for aggregates, in terms of an existing record or array object, and a series of component-wise modifications of its value, given by named associations for the modified components. To use this feature the compilation flag ``-gnat2022`` must be specified.
+
+ RM references: 4.03 (2) 4.03 (3/2) 4.03 (4) 4.03.01 (9) 4.03.01 (15/3)
+ 4.03.01 (16/4) 4.03.01 (17/5) 4.03.01 (17.1/2) 4.03.03 (4) 4.03.03
+ (14) 4.03.03 (17/5) 4.03.04 (0) 7.05 (2.6/2)
+
+.. index:: AI12-0128 (Ada 2022 feature)
+
+* *AI12-0128 Exact size access to parts of composite atomic objects (2019-11-24)*
+
+ According to this AI, the compiler generates full access to atomic composite objects even if the access is only partial in the source code. To use this feature the compilation flag ``-gnat2022`` must be specified.
+
+ RM references: C.06 (13.2/3) C.06 (19) C.06 (20) C.06 (22/2) C.06 (25/4)
+
+.. index:: AI12-0129 (Ada 2022 feature)
+
+* *AI12-0129 Make protected objects more protecting (2020-07-01)*
+
+ A new aspect Exclusive_Functions has been added to the language to force the
+ use of read/write locks on protected functions when needed.
+
+ RM references: 9.05.01 (2) 9.05.01 (4) 9.05.01 (5) 9.05.01 (7) 9.05.03
+ (15) 9.05.03 (23)
+
+.. index:: AI12-0130 (Ada 2022 feature)
+
+* *AI12-0130 All I/O packages should have Flush (2016-07-03)*
+
+ The Flush routine has been added for the ``Sequential_IO`` and ``Direct_IO`` standard packages in the Ada 2012 COR.1:2016. The Flush routine here is equivalent to the one found in ``Text_IO``. The ``Flush`` procedure synchronizes the external file with the internal file (by flushing any internal buffers) without closing the file.
+
+ RM references: A.08.01 (10) A.08.02 (28/3) A.08.04 (10) A.10.03 (21)
+ A.12.01 (28/2) A.12.01 (28.6/1)
+
+.. index:: AI12-0131 (Ada 2022 feature)
+
+* *AI12-0131 Inherited Pre'Class when unspecified on initial subprogram (0000-00-00)*
+
+ If T1 is a tagged type with a primitive P that has no class-wide precondition,
+ and if T2 is an extension of T1 which overrides the inherited primitive P, then that overriding P is not allowed to have a class-wide precondition. Allowing it would be ineffective except in corner cases where it would be confusing.
+
+ RM references: 6.01.01 (17/3) 6.01.01 (18/3)
+
+.. index:: AI12-0132 (Ada 2022 feature)
+
+* *AI12-0132 Freezing of renames-as-body (2020-06-13)*
+
+ This AI clarifies that a renames-as-body freezes the expression of any
+ expression function that it renames.
+
+ RM references: 13.14 (5/3)
+
+.. index:: AI12-0133 (Ada 2022 feature)
+
+* *AI12-0133 Type invariants and default initialized objects (0000-00-00)*
+
+ Clarify that invariant checking for a default-initialized object is performed regardless of where the object is declared (in particular, even when the full view of the type is visible).
+
+ RM references: 7.03.02 (10.3/3)
+
+.. index:: AI12-0135 (Ada 2022 feature)
+
+* *AI12-0135 Enumeration types should be eligible for convention C (0000-00-00)*
+
+ Ada previously allowed but did not require supporting specifying convention C for an enumeration type. Now it is required that an implementation shall support it.
+
+ RM references: B.01 (14/3) B.01 (41/3) B.03 (65)
+
+.. index:: AI12-0136 (Ada 2022 feature)
+
+* *AI12-0136 Language-defined packages and aspect Default_Storage_Pool (0000-00-00)*
+
+ Clarify that the effect of specifying Default_Storage_Pool for an instance of a predefined generic is implementation-defined. No compiler impact.
+
+ RM references: 13.11.03 (5/3)
+
+.. index:: AI12-0137 (Ada 2022 feature)
+
+* *AI12-0137 Incomplete views and access to class-wide types (0000-00-00)*
+
+ If the designated type of an access type is incomplete when the access type is declared, then we have rules about whether we get a complete view when a value of the access type is dereferenced. Clarify that analogous rules apply if the designated type is class-wide.
+
+ RM references: 3.10.01 (2.1/2)
+
+.. index:: AI12-0138 (Ada 2022 feature)
+
+* *AI12-0138 Iterators of formal derived types (2021-02-11)*
+
+ AI12-0138 specifies the legality rules for confirming specifications of
+ nonoverridable aspects. This completes the legality checks for aspect ``Implicit_Dereference`` and simplifies the checks for those aspects that are inherited operations.
+
+ RM references: 13.01.01 (18/4) 13.01.01 (34/3) 4.01.05 (6/3) 4.01.06 (5/3)
+ 4.01.06 (6/3) 4.01.06 (7/3) 4.01.06 (8/3) 4.01.06 (9/3) 5.05.01 (11/3)
+
+.. index:: AI12-0140 (Ada 2022 feature)
+
+* *AI12-0140 Access to unconstrained partial view when full view is constrained (0000-00-00)*
+
+ Clarify some confusion about about whether what matters when checking whether designated subtypes statically match is the view of the designated type that is currently available v.s. the view that was available when the access type was declared.
+
+ RM references: 3.02 (7/2) 7.03.01 (5/1)
+
+.. index:: AI12-0143 (Ada 2022 feature)
+
+* *AI12-0143 Using an entry index of a family in a precondition (2022-04-05)*
+
+ Ada 2022 adds the ``Index`` attribute, which allows the use of the entry family index of an entry call within preconditions and post-conditions.
+
+ RM references: 6.01.01 (30/3) 9.05.04 (5/3)
+
+.. index:: AI12-0144 (Ada 2022 feature)
+
+* *AI12-0144 Make Discrete_Random more flexible (2020-01-31)*
+
+ A new function Random with First/Last parameters is provided in the
+ ``Ada.Numerics.Discrete_Random`` package.
+
+ RM references: A.05.02 (20) A.05.02 (32) A.05.02 (41) A.05.02 (42)
+
+.. index:: AI12-0145 (Ada 2022 feature)
+
+* *AI12-0145 Pool_of_Subpool returns null when called too early (0000-00-00)*
+
+ Clarify that if you ask for the pool of a subpool (by calling ``Pool_Of_Subpool``) before ``Set_Pool_of_Subpool`` is called, then the result is null.
+
+ RM references: 13.11.04 (20/3)
+
+.. index:: AI12-0147 (Ada 2022 feature)
+
+* *AI12-0147 Expression functions and null procedures can be declared in a protected_body (2015-03-05)*
+
+ AI12-0147 specifies that null procedures and expression functions are now
+ allowed in protected bodies.
+
+ RM references: 9.04 (8/1)
+
+.. index:: AI12-0149 (Ada 2022 feature)
+
+* *AI12-0149 Type invariants are checked for functions returning access-to-type (0000-00-00)*
+
+ Extend the rule saying that ``Type_Invariant`` checks are performed for access-to-T parameters (where T has a specified ``Type_Invariant``) so that the rule also applies to function results.
+
+ RM references: 7.03.02 (19.3/4)
+
+.. index:: AI12-0150 (Ada 2022 feature)
+
+* *AI12-0150 Class-wide type invariants and statically bound calls (0000-00-00)*
+
+ The same approach used in AI12-0113 to ensure that contract-related calls associated with a call to a subprogram "match" with respect to dispatching also applies to ``Type_Invariant`` checking.
+
+ RM references: 7.03.02 (3/3) 7.03.02 (5/3) 7.03.02 (9/3) 7.03.02 (22/3)
+
+.. index:: AI12-0154 (Ada 2022 feature)
+
+* *AI12-0154 Aspects of library units (0000-00-00)*
+
+ Clarify that an aspect_specification for a library unit is equivalent to a corresponding aspect-specifying pragma.
+
+ RM references: 13.01.01 (32/3)
+
+.. index:: AI12-0156 (Ada 2022 feature)
+
+* *AI12-0156 Use subtype_indication in generalized iterators (0000-00-00)*
+
+ For iterating over an array, we already allow (but do not require) explicitly providing a subtype indication in an iterator_specification. Tee AI generalizes this to handle the case where the element type of the array is of an anonymous access type. This also allows (but does not require) explicitly naming the cursor subtype in a generalized iterator.
+ The main motivation for allowing these new cases is improving readability by making it easy to infer the (sub)type of the iteration object just by looking at the loop.
+
+ RM references: 5.05.02 (2/3) 5.05.02 (5/4) 5.05.02 (7/3) 3.10.02 (11.1/2)
+
+.. index:: AI12-0157 (Ada 2022 feature)
+
+* *AI12-0157 Missing rules for expression functions (0000-00-00)*
+
+ Clarify that an expression function behaves like a single-return-statement
+ function in more cases: it can return an aggregate without extra parens, the expression has an applicable index constraint, and the same accessibility rules apply in both cases.
+
+ For instance, the code below is legal:
+
+ .. code::
+
+ subtype S is String (1 .. 10);
+ function f return S is (others => '?');
+
+ RM references: 3.10.02 (19.2/4) 3.10.02 (19.3/4) 4.03.03 (11/2) 6.08 (2/3)
+ 6.08 (3/3) 6.08 (5/3) 6.08 (6/3) 6.08 (7/3) 7.05 (2.9/3) 13.14
+ (5.1/4) 13.14 (5.2/4) 13.14 (8/3) 13.14 (10.1/3) 13.14 (10.2/3)
+ 13.14 (10.3/3)
+
+.. index:: AI12-0160 (Ada 2022 feature)
+
+* *AI12-0160 Adding an indexing aspect to an indexable container type (0000-00-00)*
+
+ If the parent type of a derived type has exactly one of the two indexing aspects (that is, constant_indexing and variable_indexing) specified, then the derived type cannot have a specification for the other one.
+
+ RM references: 4.01.06 (6/4) 4.01.06 (9/4) 3.06 (22.2/3)
+
+.. index:: AI12-0162 (Ada 2022 feature)
+
+* *AI12-0162 Memberships and Unchecked_Unions (0000-00-00)*
+
+ Clarify that membership tests for unchecked_union types work consistently when
+ testing membership in more than one subtype (X in AA | BB | CC) as when
+ testing for one.
+
+ RM references: B.03.03 (25/2)
+
+.. index:: AI12-0164 (Ada 2022 feature)
+
+* *AI12-0164 Max_Entry_Queue_Length aspect for entries (2019-06-11)*
+
+ AI12-0164 defines pragma and aspect ``Max_Entry_Queue_Length`` in addition
+ to the GNAT-specific equivalents ``Max_Queue_Length`` and ``Max_Entry_Queue_Depth``.
+
+ RM references: D.04 (16)
+
+.. index:: AI12-0165 (Ada 2022 feature)
+
+* *AI12-0165 Operations of class-wide types and formal abstract subprograms (2021-10-19)*
+
+ Ada 2022 specifies that when the controlling type of a formal abstract
+ subprogram declaration is a formal type, and the actual type is a class-wide type T'Class, the actual subprogram can be an implicitly declared subprogram corresponding to a primitive operation of type T.
+
+ RM references: 12.06 (8.5/2)
+
+.. index:: AI12-0166 (Ada 2022 feature)
+
+* *AI12-0166 External calls to protected functions that appear to be internal calls (2016-11-15)*
+
+ According to this AI, the compiler rejects a call to a protected operation when the call appears within a precondition for another protected operation.
+
+ RM references: 6.01.01 (34/3) 9.05 (3/3) 9.05 (7.1/3)
+
+.. index:: AI12-0167 (Ada 2022 feature)
+
+* *AI12-0167 Type_Invariants and tagged-type View Conversions (0000-00-00)*
+
+ This AI clarifies that no invariant check is performed in a case where an invariant-violating value is assigned to a component. This confirms the current compiler behavior.
+
+ RM references: 7.03.02 (9/4)
+
+.. index:: AI12-0168 (Ada 2022 feature)
+
+* *AI12-0168 Freezing of generic instantiations of generics with bodies (0000-00-00)*
+
+ Adjust freezing rules to be compatible with AI12-0103-1. The change confirms the current compiler behavior.
+
+ RM references: 13.14 (3/4)
+
+.. index:: AI12-0169 (Ada 2022 feature)
+
+* *AI12-0169 Aspect specifications for entry bodies (0000-00-00)*
+
+ Change syntax to allow aspect specifications for implementation-defined aspects on entry bodies. The change doesn't influence any of the language-defined aspects and is solely required for SPARK.
+
+ RM references: 9.05.02 (5)
+
+.. index:: AI12-0170 (Ada 2022 feature)
+
+* *AI12-0170 Abstract subprogram calls in class-wide precondition expressions (2020-07-06)*
+
+ This AI specifies rules for calls to abstract functions within class-wide preconditions and postconditions.
+
+ RM references: 3.09.03 (7) 6.01.01 (7/4) 6.01.01 (18/4) 6.01.01 (18.2/4)
+
+.. index:: AI12-0172 (Ada 2022 feature)
+
+* *AI12-0172 Raise expressions in limited contexts (2019-07-29)*
+
+ The compiler has been enhanced to support the use of raise expressions in
+ limited contexts.
+
+ RM references: 7.05 (2.1/3)
+
+.. index:: AI12-0173 (Ada 2022 feature)
+
+* *AI12-0173 Expression of an extended return statement (0000-00-00)*
+
+ Fix the wording related to expression of an extended return statement that was made ambiguous by changes of syntax in other AI's. No compiler changes involved.
+
+ RM references: 6.05 (3/2) 6.05 (5/3)
+
+.. index:: AI12-0174 (Ada 2022 feature)
+
+* *AI12-0174 Aggregates of Unchecked_Unions using named notation (0000-00-00)*
+
+ In many cases, it is illegal to name a discriminant of an unchecked_union type. Relax this rule to allow the use of named notation in an aggregate of an unchecked_union type.
+
+ RM references: B.03.03 (9/3)
+
+.. index:: AI12-0175 (Ada 2022 feature)
+
+* *AI12-0175 Preelaborable packages with address clauses (2020-03-20)*
+
+ The compiler nows accepts calls to certain functions that are essentially unchecked conversions in preelaborated library units. To use this feature the compilation flag ``-gnat2022`` must be specified.
+
+ RM references: 10.02.01 (7)
+
+.. index:: AI12-0179 (Ada 2022 feature)
+
+* *AI12-0179 Failure of postconditions of language-defined units (0000-00-00)*
+
+ A clarification that expressing postconditions for predefined units via RM wording or via ``Post`` aspect specifications are equivalent. In particular, the expression in such a ``Post`` aspect specification should not yield False. No implementation changes needed.
+
+ RM references: 1.01.03 (17/3) 11.04.02 (23.1/3)
+
+.. index:: AI12-0180 (Ada 2022 feature)
+
+* *AI12-0180 Using protected subprograms and entries within an invariant (2020-06-22)*
+
+ AI12-0180 makes entries and protected subprograms directly visible within Invariant aspects of a task or protected type.
+
+ RM references: 13.01.01 (12/3)
+
+.. index:: AI12-0181 (Ada 2022 feature)
+
+* *AI12-0181 Self-referencing representation aspects (0000-00-00)*
+
+ Clarify that a name or expression which freezes an entity cannot occur in an aspect specification for that entity.
+
+ RM references: 13.01 (9/4) 13.01 (9.1/4) 13.14 (19)
+
+.. index:: AI12-0182 (Ada 2022 feature)
+
+* *AI12-0182 Pre'Class and protected operations (0000-00-00)*
+
+ Confirm that Pre'Class and Post'Class cannot be specified for a protected operation. No language change.
+
+ RM references: 13.01.01 (16/3)
+
+.. index:: AI12-0184 (Ada 2022 feature)
+
+* *AI12-0184 Long Long C Data Types (2020-01-30)*
+
+ Two new types ``long_long`` and ``unsigned_long_long`` are introduced in the package ``Interfaces.C``.
+
+ RM references: B.03 (71.3/3)
+
+.. index:: AI12-0185 (Ada 2022 feature)
+
+* *AI12-0185 Resolution of postcondition-specific attributes (0000-00-00)*
+
+ Clarify resolution rules for ``'Old`` and ``'Result`` attribute references to match original intent.
+
+ RM references: 6.01.01 (7/4) 6.01.01 (8/3) 6.01.01 (26.10/4) 6.01.01 (29/3)
+
+.. index:: AI12-0186 (Ada 2022 feature)
+
+* *AI12-0186 Profile freezing for the Access attribute (0000-00-00)*
+
+ Clarify that the use of Some_Subprogram'Access does not freeze the profile of Some_Subprogram.
+
+ RM references: 13.14 (15)
+
+.. index:: AI12-0187 (Ada 2022 feature)
+
+* *AI12-0187 Stable properties of abstract data types (2020-11-04)*
+
+ Ada 2022 defines a new aspect, ``Stable_Properties``, for use in
+ generating additional postcondition checks for subprograms.
+
+ RM references: 7.03.04 (0) 13.01.01 (4/3)
+
+.. index:: AI12-0191 (Ada 2022 feature)
+
+* *AI12-0191 Clarify "part" for type invariants (0000-00-00)*
+
+ Clarify that for purposes of determining whether an invariant check is required for a "part" of an object, we do not look at "parts" which do not correspond to "parts" of the nominal type of the object. For example, if we have a parameter Param of a tagged type T1 (or equivalently of type T1'Class), and type T2 is an extension of T1 which declares a component Foo, and T1'Class (Param)'Tag = T2'Tag, then no invariant check is performed for Param's Foo component (or any subcomponent thereof).
+
+ RM references: 3.03 (23/5) 3.09.01 (4.1/2) 6.08 (5.8/5) 7.03.02 (8.3/5)
+ 7.03.02 (8.4/5) 7.03.02 (8.5/5) 7.03.02 (8.6/5) 7.03.02 (8.7/5)
+ 7.03.02 (8.8/5) 7.03.02 (8.9/5) 7.03.02 (8.10/5) 7.03.02 (8.11/5)
+ 7.03.02 (8.12/5) 7.03.02 (10.1/4) 7.03.02 (15/5) 7.03.02 (17/4)
+ 7.03.02 (18/4) 7.03.02 (19/4) 13.13.02 (9/3)
+
+.. index:: AI12-0192 (Ada 2022 feature)
+
+* *AI12-0192 "requires late initialization" and protected types (2020-03-11)*
+
+ This AI clarifies that components of a protected type require late initialization when their initialization references (implicitly) the current instance of the type.
+
+ RM references: 3.03.01 (8.1/2)
+
+.. index:: AI12-0194 (Ada 2022 feature)
+
+* *AI12-0194 Language-defined aspects and entry bodies (0000-00-00)*
+
+ The AI Includes entry bodies on the list of bodies for which no language-defined aspects can be specified (although specifying an implementation-defined aspect may be allowed).
+
+ A wording change, no implementation impact.
+
+ RM references: 13.01.01 (17/3)
+
+.. index:: AI12-0195 (Ada 2022 feature)
+
+* *AI12-0195 Inheriting body but overriding precondition or postcondition (2021-08-11)*
+
+ Ada 2022 specifies that if a primitive with a class-wide precondition or
+ postcondition is inherited, and some primitive function called in the class-wide precondition or postcondition is overridden, then a dispatching call to the first primitive with a controlling operand that has the tag of the overriding type is required to check both the interpretation using the overriding function and the interpretation using the original overridden function.
+
+ RM references: 6.01.01 (38/4)
+
+.. index:: AI12-0196 (Ada 2022 feature)
+
+* *AI12-0196 Concurrent access to Ada container libraries (0000-00-00)*
+
+ Clarify that parallel execution of operations which use cursors to refer to different elements of the same container does not violate the rules about erroneous concurrent access in some cases. That is, if C1 and C2 are cursors that refer to different elements of some container, then it is ok to concurrently execute an operation that is passed C1 and which accesses one element of the container, with another operation (perhaps the same operation, perhaps not) that is passed C2 and which accesses another element of the container.
+
+ RM references: A.18 (2/2) A.18.02 (125/2) A.18.02 (133/3) A.18.02 (135/3)
+ A.18.03 (81/3) A.18.04 (36/3) A.18.07 (34/2) A.18.10 (116/3)
+
+.. index:: AI12-0198 (Ada 2022 feature)
+
+* *AI12-0198 Potentially unevaluated components of array aggregates (2020-05-13)*
+
+ Ada 2022 enforces the detection of components that belong to a nonstatic or
+ null range of index values of an array aggregate.
+
+ RM references: 6.01.01 (22.1/4)
+
+.. index:: AI12-0199 (Ada 2022 feature)
+
+* *AI12-0199 Abstract subprogram calls in class-wide invariant expressions (0000-00-00)*
+
+ Class-wide type invariants do not apply to abstract types, to avoid various
+ problems. Define the notion of a "corresponding expression" for a class-wide
+ type invariant, replacing references to components as appropriate, taking into
+ account rules for corresponding and specified discriminants when applying them
+ to a nonabstract descendant.
+
+ RM references: 7.03.02 (5/4) 7.03.02 (8/3)
+
+.. index:: AI12-0201 (Ada 2022 feature)
+
+* *AI12-0201 Missing operations of static string types (2020-02-25)*
+
+ Relational operators and type conversions of static string types are now static in Ada 2022.
+
+ RM references: 4.09 (9) 4.09 (19) 4.09 (20) 4.09 (24)
+
+.. index:: AI12-0203 (Ada 2022 feature)
+
+* *AI12-0203 Overriding a nonoverridable aspect (0000-00-00)*
+
+ A corner case wording clarification that has no impact on compilers.
+
+ RM references: 4.01.05 (5.1/4) 4.01.05 (7/3)
+
+.. index:: AI12-0204 (Ada 2022 feature)
+
+* *AI12-0204 Renaming of a prefixed view (2020-02-24)*
+
+ AI12-0204 clarifies that the prefix of a prefixed view that is renamed or
+ passed as a formal subprogram must be renameable as an object.
+
+ RM references: 8.05.04 (5.2/2) 12.06 (8.3/2) 4.01.03 (13.1/2) 4.01.06 (9/5)
+
+.. index:: AI12-0205 (Ada 2022 feature)
+
+* *AI12-0205 Defaults for generic formal types (2021-04-01)*
+
+ AI12-0205 specifies syntax and semantics that provide defaults for formal types of generic units. The legality rules guarantee that the default subtype_mark that is specified for a formal type would be a legal actual in any instantiation of the generic unit.
+
+ RM references: 12.03 (7/3) 12.03 (10) 12.05 (2.1/3) 12.05 (2.2/3) 12.05 (7/2)
+
+.. index:: AI12-0206 (Ada 2022 feature)
+
+* *AI12-0206 Nonoverridable should allow arbitrary kinds of aspects (0000-00-00)*
+
+ A non-overridable aspect can have a value other than a name; for example, ``Max_Entry_Queue_Length`` is non-overridable and it has a scalar value.
+ Part of adding support for ``Max_Entry_Queue_Length`` (which is already supported by GNAT).
+
+ RM references: 13.01.01 (18.2/4) 13.01.01 (18.3/4) 13.01.01 (18.6/4)
+
+.. index:: AI12-0207 (Ada 2022 feature)
+
+* *AI12-0207 Convention of anonymous access types (2020-02-01)*
+
+ The convention of anonymous access elements of arrays now have the same convention as the array instead of convention Ada.
+
+ RM references: 6.03.01 (13.1/3) B.01 (19) B.01 (21/3)
+
+.. index:: AI12-0208 (Ada 2022 feature)
+
+* *AI12-0208 Predefined Big numbers support (0000-00-00)*
+
+ Add predefined package ``Ada.Numerics.Big_Numbers``.
+
+ RM references: A.05.05 (0) A.05.06 (0) A.05.07 (0)
+
+.. index:: AI12-0211 (Ada 2022 feature)
+
+* *AI12-0211 Interface types and inherited nonoverridable aspects (2020-08-24)*
+
+ AI12-0211 introduces two new legality rules for Ada 2022. The first says that
+ if a nonoverridable aspect is explicitly specified for a type that also inherits that aspect from another type (an ancestor or a progenitor), then the explicit aspect specification shall be confirming. The second says that if a type inherits a nonoverridable aspect from two different sources (this can only occur if at least one of the two is an interface type), then the two sources shall agree with respect to the given aspect. This AI is a binding interpretation, so these checks are performed even for earlier Ada versions. Because of compatibility concerns, an escape mechanism for suppressing these legality checks is provided: these new checks always pass if the ``-gnatd.M`` switch (relaxed RM semantics) is specified.
+
+ RM references: 13.01.01 (18.3/5) 13.01.01 (18.4/4)
+
+.. index:: AI12-0212 (Ada 2022 feature)
+
+* *AI12-0212 Container aggregates; generalized array aggregates (0000-00-00)*
+
+ The AI defines a new feature: generalized array aggregates that already exists in GNAT.
+
+ RM references: 4.03.05 (0) 1.01.04 (12) 1.01.04 (13) 2.01 (15) 2.02 (9/5)
+ 3.07.01 (3) 3.08.01 (4) 4.03 (2/5) 4.03 (3/5) 4.03.01 (5) 4.03.03
+ (3/2) 4.03.03 (4/5) 4.03.03 (5.1/5) 4.03.03 (9) 4.03.03 (17/5)
+ 4.03.03 (21) 4.03.03 (23.2/5) 4.03.03 (26) 4.03.03 (27) 4.03.03
+ (31) 4.03.04 (4/5) 4.04 (3.1/3) 11.02 (3) 13.01.01 (5/3)
+ 13.01.01 (7/3) A.18.02 (8/3) A.18.02 (14/2) A.18.02 (47/2) A.18.02
+ (175/2) A.18.03 (6/3) A.18.05 (3/3) A.18.06 (4/3) A.18.08 (3/3)
+ A.18.09 (4/3)
+
+.. index:: AI12-0216 (Ada 2022 feature)
+
+* *AI12-0216 6.4.1(6.16-17/3) should never apply to composite objects (0000-00-00)*
+
+ Fix wording so that parameter passing cases where there isn't really any aliasing problems or evaluation order dependency are classified as acceptable.
+
+ No compiler impact.
+
+ RM references: 6.04.01 (6.17/3)
+
+.. index:: AI12-0217 (Ada 2022 feature)
+
+* *AI12-0217 Rules regarding restrictions on the use of the Old attribute are too strict (2020-03-25)*
+
+ AI12-0217 loosens the rules regarding what is allowed as the prefix of a 'Old
+ attribute reference. In particular, a prefix is now only required to "statically name" (as opposed to the previous "statically denote") an object. This means that components of composite objects that previously would have been illegal are now legal prefixes.
+
+ RM references: 6.01.01 (24/3) 6.01.01 (27/3)
+
+.. index:: AI12-0220 (Ada 2022 feature)
+
+* *AI12-0220 Pre/Post for access-to-subprogram types (2020-04-14)*
+
+ Contract aspects can now be specified for access-to-subprogram types, as
+ defined for Ada 2022 in this AI.
+
+ RM references: 6.01.01 (1/4) 6.01.01 (2/3) 6.01.01 (4/3) 6.01.01 (19/3)
+ 6.01.01 (28/3) 6.01.01 (29/3) 6.01.01 (39/3) 13.01.01 (12/5)
+
+.. index:: AI12-0222 (Ada 2022 feature)
+
+* *AI12-0222 Representation aspects and private types (0000-00-00)*
+
+ Clarify that the rule against specifying a representation aspect for a type before the type is completely defined also applies in the case where aspect_specification syntax is used (not just in the case where a pragma or some other kind of representation item is used).
+
+ GNAT already implements this.
+
+ RM references: 13.01 (9/5) 13.01 (9.1/4) 13.01 (9.2/5)
+
+.. index:: AI12-0225 (Ada 2022 feature)
+
+* *AI12-0225 Prefix of Obj'Image (0000-00-00)*
+
+ Clarify some Object vs. Value corner cases to allow names that do not denote objects in more contexts, such as a qualified expression as a prefix of an Image attribute.
+
+ RM references: 3.05 (55.1/4)
+
+.. index:: AI12-0226 (Ada 2022 feature)
+
+* *AI12-0226 Make objects more consistent (0000-00-00)*
+
+ Allow value conversions as objects. For instance this example becomes legal: ``Long_Integer (Duration'Last)'Image``.
+
+ RM references: 3.03 (11.1/3) 3.03 (21.1/3) 3.03 (23.8/5) 4.06 (58.1/4)
+ 4.06 (58.3/4)
+
+.. index:: AI12-0227 (Ada 2022 feature)
+
+* *AI12-0227 Evaluation of nonstatic universal expressions when no operators are involved (0000-00-00)*
+
+ Nonstatic universal integer expressions are always evaluated at runtime as values of type root_integer; similarly, nonstatic universal real expressions are always evaluated at runtime as values of type root_real.
+ This AI corrects a wording oversight. Previously, the above was only true if a call to operator was involved. With this change it is true in all cases.
+
+ No compiler impact.
+
+ RM references: 4.04 (10) 8.06 (29)
+
+.. index:: AI12-0228 (Ada 2022 feature)
+
+* *AI12-0228 Properties of qualified expressions used as names (2020-02-19)*
+
+ This AI clarifies that properties of a qualified object pass through a
+ qualified expression used as a name. Specifically, "aliased" and "known to be
+ constrained" are not changed by a qualified expression.
+
+ RM references: 3.03 (23.7/3) 3.10 (9/3)
+
+.. index:: AI12-0231 (Ada 2022 feature)
+
+* *AI12-0231 Null_Task_Id and Activation_Is_Complete (0000-00-00)*
+
+ Add ``Activation_Is_Complete`` to the list of functions that raise P_E if passed ``Null_Task_Id``, correcting an oversight.
+
+ RM references: C.07.01 (15)
+
+.. index:: AI12-0232 (Ada 2022 feature)
+
+* *AI12-0232 Rules for pure generic bodies (0000-00-00)*
+
+ Clarify the rules for a generic body nested in a pure library unit.
+
+ RM references: 10.02.01 (9/3) 10.02.01 (15.1/3) 10.02.01 (15.5/3)
+
+.. index:: AI12-0233 (Ada 2022 feature)
+
+* *AI12-0233 Pre'Class for hidden operations of private types (0000-00-00)*
+
+ Clarify how ``Pre'Class`` checking interacts with private-part overriding of inherited subprograms. A class-wide precondition can be checked at runtime even if it is specified in a private part that the caller cannot see into.
+
+ RM references: 6.01.01 (38/4)
+
+.. index:: AI12-0234 (Ada 2022 feature)
+
+* *AI12-0234 Compare-and-swap for atomic objects (0000-00-00)*
+
+ New predefined units for atomic operations (``System.Atomic_Operations`` and child units thereof).
+
+ RM references: C.06.01 (0) C.06.02 (0)
+
+.. index:: AI12-0235 (Ada 2022 feature)
+
+* *AI12-0235 System.Storage_Pools should be pure (0000-00-00)*
+
+ Change the predefined package System.Storage_Pools from preelaborated to pure.
+
+ RM references: 13.11 (5)
+
+.. index:: AI12-0236 (Ada 2022 feature)
+
+* *AI12-0236 declare expressions (2020-04-08)*
+
+ A ``declare expression`` allows constant objects and renamings to be
+ declared within an expression.
+
+ RM references: 2.08 (6) 3.09.02 (3) 3.10.02 (9.1/3) 3.10.02 (16.1/3)
+ 3.10.02 (32.2/3) 4.03.02 (5.4/3) 4.03.03 (15.1/3) 4.04 (7/3)
+ 4.05.09 (0) 6.02 (10/4) 7.05 (2.1/5) 8.01 (2.1/4)
+
+.. index:: AI12-0237 (Ada 2022 feature)
+
+* *AI12-0237 Getting the representation of an enumeration value (2020-01-31)*
+
+ The GNAT-specific attributes ``Enum_Rep`` and ``Enum_Val`` have been standardized and are now also supported as Ada 2022 attributes.
+
+ RM references: 13.04 (10) 13.04 (11/3)
+
+.. index:: AI12-0242 (Ada 2022 feature)
+
+* *AI12-0242 Shorthand Reduction Expressions for Objects (0000-00-00)*
+
+ Allow reduction expressions to iterate over an an array or an iterable object without having to explicitly create a value sequence.
+
+ This allows, for instance, writing ``A'Reduce("+", 0)`` instead of the equivalent (but more verbose) ``[for Value of A => Value]'Reduce("+", 0);``.
+
+ RM references: 4.05.10 (0) 4.01.04 (6)
+
+.. index:: AI12-0247 (Ada 2022 feature)
+
+* *AI12-0247 Potentially Blocking goes too far for Detect_Blocking (0000-00-00)*
+
+ During a protected action, a call on a subprogram that contains a potentially blocking operation is considered a bounded error (so raising P_E is optional).
+ This rule imposed an unreasonable implementation burden.
+ The new rule introduced by this AI allows ignoring (i.e., not detecting) the problem until execution of a potentially blocking operation is actually attempted.
+
+ RM references: 9.05 (55/5) 9.05 (56/5) 9.05.01 (18/5) H.05 (5/2)
+
+.. index:: AI12-0249 (Ada 2022 feature)
+
+* *AI12-0249 User-defined numeric literals (2020-04-07)*
+
+ Compiler support is added for three new aspects (``Integer_Literal``, ``Real_Literal``, and ``String_Literal``) as described in AI12-0249 (for ``Integer_Literal`` and ``Real_Literal``), AI12-0295 (for ``String_Literal``), and in two follow-up AIs (AI12-0325 and AI12-0342). For pre-Ada 2022 versions of Ada, these are treated as implementation-defined
+ aspects. Some implementation work remains, particularly in the interactions between these aspects and tagged types.
+
+ RM references: 4.02 (9) 4.02.01 (0) 4.09 (3)
+
+.. index:: AI12-0250 (Ada 2022 feature)
+
+* *AI12-0250 Iterator Filters (2020-05-19)*
+
+ This AI defines Ada 2022 feature of iterator filters, which can be
+ applied to loop parameter specifications and iterator specifications.
+
+ RM references: 4.03.03 (21) 4.03.03 (26) 4.03.03 (31) 4.03.05 (0) 4.05.10
+ (0) 5.05 (4) 5.05 (7) 5.05 (9/4) 5.05 (9.1/4) 5.05 (10)
+ 5.05.02 (2/3) 5.05.02 (10/3) 5.05.02 (11/3)
+
+.. index:: AI12-0252 (Ada 2022 feature)
+
+* *AI12-0252 Duplicate interrupt handlers under Ravenscar (2018-07-05)*
+
+ Ada Issue AI12-0252 requires that the runtime shall terminate with a
+ Program_Error when more than one interrupt handler is attached to the same interrupt and the restriction No_Dynamic_Attachment is in effect.
+
+ RM references: C.03.01 (13)
+
+.. index:: AI12-0256 (Ada 2022 feature)
+
+* *AI12-0256 Aspect No_Controlled_Parts (2021-01-26)*
+
+ The compiler now supports the Ada 2022 aspect No_Controlled_Parts (see
+ AI12-0256). When specified for a type, this aspect requires that the type and any of its ancestors must not have any controlled parts.
+
+ RM references: H.04.01 (0) 13.01.01 (18.7/5)
+
+.. index:: AI12-0258 (Ada 2022 feature)
+
+* *AI12-0258 Containers and controlled element types (0000-00-00)*
+
+ Most predefined containers are allowed to defer finalization of container elements until the finalization of the container. This allows implementation flexibility but causes problems in some cases. AI12-0258 tightens up the rules for the indefinite containers to say that finalization happens earlier - if a client needs the tighter finalization guarantees, then it can use the indefinite containers (even if the element subtype in question is definite). Other solutions involving the holder generic are also possible.
+
+ GNAT implements these tighter element finalization requirements for instances of the indefinite container generics.
+
+ RM references: A.18 (10/4)
+
+.. index:: AI12-0259 (Ada 2022 feature)
+
+* *AI12-0259 Lower bound of strings returned from Ada.Command_Line (0000-00-00)*
+
+ Specify that the low-bound of a couple of predefined String-valued functions will always be one.
+
+ RM references: A.15 (14) A.15 (16/3)
+
+.. index:: AI12-0260 (Ada 2022 feature)
+
+* *AI12-0260 Functions Is_Basic and To_Basic in Wide_Characters.Handling (2020-04-01)*
+
+ AI12-0260 is implemented for Ada 2022, providing the new functions ``Is_Basic`` and ``To_Basic`` in package ``Ada.Wide_Characters.Handling``.
+
+ RM references: 1.02 (8/3) A.03.05 (8/3) A.03.05 (20/3) A.03.05 (21/3)
+ A.03.05 (33/3) A.03.05 (61/3)
+
+.. index:: AI12-0261 (Ada 2022 feature)
+
+* *AI12-0261 Conflict in "private with" rules (0000-00-00)*
+
+ If a library unit is only visible at some point because of a "private with", there are legality rules about a name denoting that entity. The AI cleans up the wording so that it captures the intent in a corner case involving a private-child library-unit subprogram. The previous wording incorrectly caused this case to be illegal.
+
+ RM references: 10.01.02 (12/3) 10.01.02 (13/2) 10.01.02 (14/2) 10.01.02
+ (15/2) 10.01.02 (16/2)
+
+.. index:: AI12-0262 (Ada 2022 feature)
+
+* *AI12-0262 Map-Reduce attribute (0000-00-00)*
+
+ The AI defines Reduction Expressions to allow the programmer to apply the
+ Map-Reduce paradigm to map/transform a set of values to a new set of values,
+ and then summarize/reduce the transformed values into a single result value.
+
+ RM references: 4.01.04 (1) 4.01.04 (6) 4.01.04 (11) 4.05.10 (0)
+
+.. index:: AI12-0263 (Ada 2022 feature)
+
+* *AI12-0263 Update references to ISO/IEC 10646 (0000-00-00)*
+
+ Change RM references to ISO/IEC 10646:2011 to instead refer to ISO/IEC 10646:2017. No compiler impact.
+
+ RM references: 1.01.04 (14.2/3) 2.01 (1/3) 2.01 (3.1/3) 2.01 (4/3) 2.01
+ (4.1/5) 2.01 (5/3) 2.01 (15/3) 2.01 (4.1/5) 2.01 (5/3) 2.03
+ (4.1/5) 2.03 (5/3) 3.05.02 (2/3) 3.05.02 (3/3) 3.05.02 (4/3) A.01
+ (36.1/3) A.01 (36.2/3) A.03.02 (32.6/5) A.03.05 (51.2/5) A.03.05
+ (55/3) A.03.05 (59/3) A.04.10 (3/3) B.05 (21/5)
+
+.. index:: AI12-0264 (Ada 2022 feature)
+
+* *AI12-0264 Overshifting and overrotating (0000-00-00)*
+
+ Clarify Shift and Rotate op behavior with large shift/rotate amounts.
+
+ RM references: B.02 (9)
+
+.. index:: AI12-0265 (Ada 2022 feature)
+
+* *AI12-0265 Default_Initial_Condition for types (2020-11-13)*
+
+ The aspect ``Default_Initial_Condition``, originally proposed by SPARK and
+ supported in GNAT, is now also included in Ada 2022. One change from the
+ original implementation is that when the aspect is specified on ancestor types of a derived type, the ancestors' check expressions also apply to the derived type.
+ ``Default_Initial_Condition`` checks are also now applied in cases of default
+ initialization of components, allocators, ancestor parts of extension aggregates, and box associations of aggregates.
+
+ RM references: 7.03.03 (0) 1.01.03 (17.1/5) 11.04.02 (23.2/5) 11.04.02 (23.3/5)
+
+.. index:: AI12-0269 (Ada 2022 feature)
+
+* *AI12-0269 Aspect No_Return for functions reprise (2020-03-19)*
+
+ This amendment has been implemented under the ``-gnat2022`` switch, and the
+ compiler now accepts the aspect/pragma No_Return for functions and generic
+ functions.
+
+ RM references: 6.05.01 (0) 6.05.01 (1/3) 6.05.01 (3.1/3) 6.05.01 (3.4/3)
+ 6.05.01 (5/2) 6.05.01 (6/2) 6.05.01 (7/2) J.15.02 (2/3) J.15.02
+ (3/3) J.15.02 (4/3)
+
+.. index:: AI12-0272 (Ada 2022 feature)
+
+* *AI12-0272 (part 1) Pre/Postconditions for formal subprograms (0000-00-00)*
+
+ Pre and Post aspects can be specified for a generic formal subprogram. ``Default_Initial_Condition`` can be specified for a generic formal private type.
+
+ GNAT implements this with an exception of the part related to ``Default_Initial_Condition``.
+
+ RM references: 6.01.01 (1/5) 6.01.01 (39/5) 7.03.03 (1/5) 7.03.03 (2/5)
+ 7.03.03 (8/5) 7.03.04 (5/5) F.01 (1)
+
+.. index:: AI12-0275 (Ada 2022 feature)
+
+* *AI12-0275 Make subtype_mark optional in object renames (2020-01-28)*
+
+ AI12-0275 allows object renamings to be declared without an explicit
+ subtype_mark or access_definition. This feature can be used by compiling
+ with the switch ``-gnat2022``.
+
+ RM references: 8.05.01 (2/3) 8.05.01 (3/2)
+
+.. index:: AI12-0277 (Ada 2022 feature)
+
+* *AI12-0277 The meaning of "accessibility level of the body of F" (0000-00-00)*
+
+ Clarify that the only time that an explicitly aliased formal parameter has different accessibility properties than an aliased part of a "normal" parameter is for the accessibility checking associated with a return statement.
+
+ RM references: 3.10.02 (19.2/4)
+
+.. index:: AI12-0278 (Ada 2022 feature)
+
+* *AI12-0278 Implicit conversions of anonymous return types (0000-00-00)*
+
+ If a call to a function with an anonymous-access-type result is converted to a named access type, it doesn't matter whether the conversion is implicit or explicit. the AI fixes hole where the previous rules didn't cover the implicit conversion case.
+
+ RM references: 3.10.02 (10.3/3)
+
+.. index:: AI12-0279 (Ada 2022 feature)
+
+* *AI12-0279 Nonpreemptive dispatching needs more dispatching points (2020-04-17)*
+
+ Ada 2022 defines a new aspect `Yield` that can be specified in the declaration of a noninstance subprogram (including a generic formal subprogram), a generic subprogram, or an entry, to ensure that the associated subprogram has at least one task dispatching point during each invocation.
+
+ RM references: D.02.01 (1.5/2) D.02.01 (7/5)
+
+.. index:: AI12-0280-2 (Ada 2022 feature)
+
+* *AI12-0280-2 Making 'Old more flexible (2020-07-24)*
+
+ For Ada 2022, AI12-0280-2 relaxes Ada's restrictions on 'Old attribute
+ references whose attribute prefix does not statically name an entity. Previously, it was required that such an attribute reference must be unconditionally evaluated when the postcondition is evaluated; with the new rule, conditional evaluation is permitted if the relevant conditions can be evaluated upon entry to the subprogram with the same results as evaluation at the time of the postcondition's evaluation. In this case, the 'Old attribute prefix is evaluated conditionally (more specifically, the prefix is evaluated only if the result of that evaluation is going to be referenced later when the
+ postcondition is evaluated).
+
+ RM references: 6.01.01 (20/3) 6.01.01 (21/3) 6.01.01 (22/3) 6.01.01
+ (22.1/4) 6.01.01 (22.2/5) 6.01.01 (23/3) 6.01.01 (24/3) 6.01.01
+ (26/4) 6.01.01 (27/5) 6.01.01 (39/5)
+
+.. index:: AI12-0282 (Ada 2022 feature)
+
+* *AI12-0282 Atomic, Volatile, and Independent generic formal types (0000-00-00)*
+
+ The AI specifies that the aspects ``Atomic``, ``Volatile``, ``Independent``, ``Atomic_Components``, ``Volatile_Components``, and ``Independent_Components`` are specifiable for generic formal types. The actual type must have a matching specification.
+
+ RM references: C.06 (6.1/3) C.06 (6.3/3) C.06 (6.5/3) C.06 (6.8/3) C.06
+ (12/3) C.06 (12.1/3) C.06 (21/4)
+
+.. index:: AI12-0285 (Ada 2022 feature)
+
+* *AI12-0285 Syntax for Stable_Properties aspects (0000-00-00)*
+
+ The AI establishes the required named notation for a Stable_Properties aspect specification in order to avoid syntactic ambiguities.
+
+ With the old syntax, an example like
+
+ .. code::
+
+ type Ugh is ...
+ with Stable_Properties =\> Foo, Bar, Nonblocking, Pack;
+
+ was problematic; ``Nonblocking`` and ``Pack`` are other aspects, while ``Foo`` and ``Bar`` are ``Stable_Properties`` functions. With the clarified syntax, the example above shall be written as:
+
+ .. code::
+
+ type Ugh is ...
+ with Stable_Properties => (Foo, Bar), Nonblocking, Pack;
+
+ RM references: 7.03.04 (2/5) 7.03.04 (3/5) 7.03.04 (4/5) 7.03.04 (6/5)
+ 7.03.04 (7/5) 7.03.04 (9/5) 7.03.04 (10/5) 7.03.04 (14/5) 13.01.01 (4/5)
+
+.. index:: AI12-0287 (Ada 2022 feature)
+
+* *AI12-0287 Legality Rules for null exclusions in renaming are too fierce (2020-02-17)*
+
+ The null exclusion legality rules for generic formal object matching and object renaming now only apply to generic formal objects with mode in out.
+
+ RM references: 8.05.01 (4.4/2) 8.05.01 (4.5/2) 8.05.01 (4.6/2) 8.05.04
+ (4.2/2) 12.04 (8.3/2) 12.04 (8.4/2) 12.04 (8.5/2) 12.04 (8.2/5)
+ 12.06 (8.2/5)
+
+.. index:: AI12-0289 (Ada 2022 feature)
+
+* *AI12-0289 Implicitly null excluding anonymous access types and conformance (2020-06-09)*
+
+ AI12-0289 is implemented for Ada 2022, allowing safer use of access parameters
+ when the partial view of the designated type is untagged, but the full view is
+ tagged.
+
+ RM references: 3.10 (26)
+
+.. index:: AI12-0290 (Ada 2022 feature)
+
+* *AI12-0290 Restriction Pure_Barriers (2020-02-18)*
+
+ The GNAT implementation of the Pure_Barriers restriction has
+ been updated to match the Ada RM's definition as specified
+ in this AI. Some constructs that were accepted by the previous
+ implementation are now rejected, and vice versa. In
+ particular, the use of a component of a component of a
+ protected record in a barrier expression, as in "when
+ Some_Component.Another_Component =>", formerly was (at least
+ in some cases) not considered to be a violation of the
+ Pure_Barriers restriction; that is no longer the case.
+
+ RM references: D.07 (2) D.07 (10.10/4)
+
+.. index:: AI12-0291 (Ada 2022 feature)
+
+* *AI12-0291 Jorvik Profile (2020-02-19)*
+
+ The Jorvik profile is now implemented, as defined in this AI.
+ For Ada 2012 and earlier versions of Ada, Jorvik is an implementation-defined
+ profile whose definition matches its Ada 2022 definition.
+
+ RM references: D.13 (0) D.13 (1/3) D.13 (4/3) D.13 (6/4) D.13 (9/3) D.13
+ (10/3) D.13 (11/4) D.13 (12/4)
+
+.. index:: AI12-0293 (Ada 2022 feature)
+
+* *AI12-0293 Add predefined FIFO_Streams packages (0000-00-00)*
+
+ The AI adds ``Ada.Streams.Storage`` and its two subunits ``Bounded`` and ``Unbounded``.
+
+ RM references: 13.13.01 (1) 13.13.01 (9) 13.13.01 (9.1/1)
+
+.. index:: AI12-0295 (Ada 2022 feature)
+
+* *AI12-0295 User-defined string (2020-04-07)*
+
+ Compiler support is added for three new aspects (``Integer_Literal``, ``Real_Literal``, and ``String_Literal``) as described in AI12-0249 (for ``Integer_Literal`` and ``Real_Literal``), AI12-0295 (for ``String_Literal``), and in two follow-up AIs (AI12-0325 and AI12-0342). For pre-Ada 2022 versions of Ada, these are treated as implementation-defined aspects. Some implementation work remains, particularly in the interactions between these aspects and tagged types.
+
+ RM references: 4.02 (6) 4.02 (10) 4.02 (11) 3.06.03 (1) 4.02.01 (0) 4.09 (26/3)
+
+.. index:: AI12-0301 (Ada 2022 feature)
+
+* *AI12-0301 Predicates should be checked like constraints for types with Default_Value (2020-02-25)*
+
+ This AI clarifies that predicate checks apply for objects that are initialized
+ by default and that are of a type that has any components whose subtypes specify ``Default_Value`` or ``Default_Component_Value``.
+
+ RM references: 3.02.04 (31/4)
+
+.. index:: AI12-0304 (Ada 2022 feature)
+
+* *AI12-0304 Image attributes of language-defined types (2020-07-07)*
+
+ According to this AI, ``Put_Image`` (and therefore ``'Image``) is provided for
+ the containers and for unbounded strings.
+
+ RM references: 4.10 (0)
+
+.. index:: AI12-0306 (Ada 2022 feature)
+
+* *AI12-0306 Split null array aggregates from positional array aggregates (0000-00-00)*
+
+ The AI clarifies the wording of the references RM paragraphs without introducing any language changes.
+
+ RM references: 4.03.03 (2) 4.03.03 (3/2) 4.03.03 (9/5) 4.03.03 (26/5)
+ 4.03.03 (26.1/5) 4.03.03 (33/3) 4.03.03 (38) 4.03.03 (39) 4.03.03 (42)
+
+.. index:: AI12-0307 (Ada 2022 feature)
+
+* *AI12-0307 Resolution of aggregates (2020-08-13)*
+
+ The proposed new syntax for aggregates in Ada 2022 uses square brackets as
+ delimiters, and in particular allows ``[]`` as a notation for empty array and container aggregates. This syntax is currently available as an experimental feature under the ``-gnatX`` flag.
+
+ RM references: 4.03 (3/5)
+
+.. index:: AI12-0309 (Ada 2022 feature)
+
+* *AI12-0309 Missing checks for pragma Suppress (0000-00-00)*
+
+ The AI includes some previously overlooked run-time checks in the list of checks that are potentially suppressed via a pragma ``Suppress``. For example, AI12-0251-1 adds a check that the number of chunks in a chunk_specification is not zero or negative. Clarify that suppressing ``Program_Error_Check`` suppresses that check too.
+
+ RM references: 11.05 (10) 11.05 (19) 11.05 (20) 11.05 (22) 11.05 (24)
+
+.. index:: AI12-0311 (Ada 2022 feature)
+
+* *AI12-0311 Suppressing client-side assertions for language-defined units (0000-00-00)*
+
+ The AI defines some new assertion policies that can be given as arguments in a Suppress pragma (e.g., Calendar_Assertion_Check). GNAT recognizes and ignores those new policies, the checks are not implemented.
+
+ RM references: 11.04.02 (23.5/5) 11.05 (23) 11.05 (26)
+
+.. index:: AI12-0315 (Ada 2022 feature)
+
+* *AI12-0315 Image Attributes subclause improvements (0000-00-00)*
+
+ Clarify that a named number or similar can be the prefix of an Image attribute reference.
+
+ RM references: 4.10 (0)
+
+.. index:: AI12-0318 (Ada 2022 feature)
+
+* *AI12-0318 No_IO should apply to Ada.Directories (2020-01-31)*
+
+ The restriction No_IO now applies to and prevents the use of the
+ ``Ada.Directories package``.
+
+ RM references: H.04 (20/2) H.04 (24/3)
+
+.. index:: AI12-0321 (Ada 2022 feature)
+
+* *AI12-0321 Support for Arithmetic Atomic Operations and Test and Set (0000-00-00)*
+
+ The AI adds some predefined atomic operations, e.g. package System.``Atomic_Operations.Test_And_Set``.
+
+ RM references: C.06.03 (0) C.06.04 (0)
+
+.. index:: AI12-0325 (Ada 2022 feature)
+
+* *AI12-0325 Various issues with user-defined literals (2020-04-07)*
+
+ Compiler support is added for three new aspects (``Integer_Literal``, ``Real_Literal``, and ``String_Literal``) as described in AI12-0249 (for ``Integer_Literal`` and ``Real_Literal``), AI12-0295 (for ``String_Literal``), and in two follow-up AIs (AI12-0325 and AI12-0342). For pre-Ada 2022 versions of Ada, these are treated as implementation-defined aspects. Some implementation work remains, particularly in the interactions between these aspects and tagged types.
+
+ RM references: 4.02 (6) 4.02 (10) 4.02 (11) 4.02.01 (0)
+
+.. index:: AI12-0329 (Ada 2022 feature)
+
+* *AI12-0329 Naming of FIFO_Streams packages (0000-00-00)*
+
+ The AI changes the name of predefined package ``Ada.Streams.FIFO_Streams`` to ``Ada.Streams.Storage``.
+
+ RM references: 13.13.01 (9/5) 13.13.01 (9.1/5)
+
+.. index:: AI12-0331 (Ada 2022 feature)
+
+* *AI12-0331 Order of finalization of a subpool (0000-00-00)*
+
+ Clarify that when a subpool is being finalized, objects allocated from that subpool are finalized before (not after) they cease to exist (i.e. object's storage has been reclaimed).
+
+ RM references: 13.11.05 (5/3) 13.11.05 (6/3) 13.11.05 (7/3) 13.11.05
+ (7.1/4) 13.11.05 (8/3) 13.11.05 (9/3)
+
+.. index:: AI12-0333 (Ada 2022 feature)
+
+* *AI12-0333 Predicate checks on out parameters (0000-00-00)*
+
+ If a view conversion is passed as an actual parameter corresponding to an out-mode formal parameter, and if the subtype of the formal parameter has a predicate, then no predicate check associated with the conversion is performed.
+
+ RM references: 3.02.04 (31/5) 4.06 (51/4) 6.04.01 (14)
+
+.. index:: AI12-0335 (Ada 2022 feature)
+
+* *AI12-0335 Dynamic accessibility check needed for some requeue targets (0000-00-00)*
+
+ Define a new runtime accessibility check for a corner case involving requeue statements.
+
+ RM references: 9.05.04 (7/4)
+
+.. index:: AI12-0336 (Ada 2022 feature)
+
+* *AI12-0336 Meaning of Time_Offset (0000-00-00)*
+
+ The AI introduces changes to the predefined package ``Ada.Calendar.Time_Zones``.
+
+ RM references: 9.06.01 (6/2) 9.06.01 (35/2) 9.06.01 (40/2) 9.06.01 (41/2)
+ 9.06.01 (42/3) 9.06.01 (90/2) 9.06.01 (91/2)
+
+.. index:: AI12-0337 (Ada 2022 feature)
+
+* *AI12-0337 Simple_Name("/") in Ada.Directories (0000-00-00)*
+
+ Clarify behavior of subprograms in the predefined package ``Ada.Directories``. In particular, Simple_Name ("/") should return "/" on Unix-like systems.
+
+ RM references: A.16 (47/2) A.16 (74/2) A.16 (82/3)
+
+.. index:: AI12-0338 (Ada 2022 feature)
+
+* *AI12-0338 Type invariant checking and incomplete types (0000-00-00)*
+
+ Clarify that type invariants for type T are not checked for incomplete types whose completion is not available, even if that completion has components of type T.
+
+ RM references: 7.03.02 (20/5)
+
+.. index:: AI12-0339 (Ada 2022 feature)
+
+* *AI12-0339 Empty function for Container aggregates (2020-08-06)*
+
+ To provide uniform support for container aggregates, all standard container
+ libraries have been enhanced with a function Empty, to be used when initializing an aggregate prior to inserting the specified elements in the object being constructed. All products have been updated to remove the ambiguities that may have arisen from previous uses of entities named Empty in our sources, and the expansion of container aggregates uses Empty wherever needed.
+
+ RM references: A.18.02 (8/5) A.18.02 (12.3/5) A.18.02 (78.2/5) A.18.02
+ (98.6/5) A.18.03 (6/5) A.18.03 (10.2/5) A.18.03 (50.2/5) A.18.05
+ (3/5) A.18.05 (7.2/5) A.18.05 (37.3/5) A.18.05 (46/2) A.18.06
+ (4/5) A.18.06 (8.2/5) A.18.06 (51.4/5) A.18.08 (3/5) A.18.08
+ (8.1/5) A.18.08 (59.2/5) A.18.08 (68/2) A.18.09 (4/5) A.18.09
+ (9.1/5) A.18.09 (74.2/5) A.18.10 (15.2/5) A.18.18 (8.1/5) A.18.19
+ (6.1/5) A.18.20 (6/3) A.18.21 (6/3) A.18.22 (6/3) A.18.23 (6/3)
+ A.18.24 (6/3) A.18.25 (8/3)
+
+.. index:: AI12-0340 (Ada 2022 feature)
+
+* *AI12-0340 Put_Image should use a Text_Buffer (0000-00-00)*
+
+ Add a new predefined package Ada.Strings.Text_Buffers (along with child units) and change the definition of Put_Image attribute to refer to it.
+
+ RM references: A.04.12 (0) 4.10 (3.1/5) 4.10 (3.2/5) 4.10 (6/5) 4.10
+ (25.2/5) 4.10 (28/5) 4.10 (31/5) 4.10 (41/5) H.04 (23.2/5) H.04 (23.11/5)
+
+.. index:: AI12-0342 (Ada 2022 feature)
+
+* *AI12-0342 Various issues with user-defined literals (part 2) (2020-04-07)*
+
+ Compiler support is added for three new aspects (``Integer_Literal``, ``Real_Literal``, and ``String_Literal``) as described in AI12-0249 (for ``Integer_Literal`` and ``Real_Literal``), AI12-0295 (for ``String_Literal``), and in two follow-up AIs (AI12-0325 and AI12-0342). For pre-Ada 2022 versions of Ada, these are treated as implementation-defined aspects. Some implementation work remains, particularly in the interactions between these aspects and tagged types.
+
+ RM references: 4.02.01 (0) 3.09.02 (1/2) 6.03.01 (22)
+
+.. index:: AI12-0343 (Ada 2022 feature)
+
+* *AI12-0343 Return Statement Checks (2020-04-02)*
+
+ This binding interpretation has been implemented and the accessibility,
+ predicate, and tag checks prescribed by RM 6.5 are now performed at the appropriate points, as required by this AI.
+
+ RM references: 6.05 (5.12/5) 6.05 (8/4) 6.05 (8.1/3) 6.05 (21/3)
+
+.. index:: AI12-0345 (Ada 2022 feature)
+
+* *AI12-0345 Dynamic accessibility of explicitly aliased parameters (0000-00-00)*
+
+ Further clarify (after AI12-0277) accessibility rules for explicitly aliased parameters.
+
+ RM references: 3.10.02 (5) 3.10.02 (7/4) 3.10.02 (10.5/3) 3.10.02 (13.4/4)
+ 3.10.02 (19.2/5) 3.10.02 (21)
+
+.. index:: AI12-0350 (Ada 2022 feature)
+
+* *AI12-0350 Swap for Indefinite_Holders (0000-00-00)*
+
+ Add a ``Swap`` procedure to the predefined package
+ ``Ada.Containers.Indefinite_Holders``. The AI also contains implementation advice for ``Ada.Containers.Bounded_Indefinite_Holders``, a package that is not implemented by GNAT.
+
+ RM references: A.18.18 (22/5) A.18.18 (67/5) A.18.18 (73/3) A.18.32 (13/5)
+
+.. index:: AI12-0351 (Ada 2022 feature)
+
+* *AI12-0351 Matching for actuals for formal derived types (2020-04-03)*
+
+ This binding interpretation requires the compiler to checks
+ that an actual subtype in a generic parameter association of an instantiation is statically compatible (even when the actual is unconstrained) with the ancestor of an associated nondiscriminated generic formal derived type.
+
+ RM references: 12.05.01 (7) 12.05.01 (8)
+
+.. index:: AI12-0352 (Ada 2022 feature)
+
+* *AI12-0352 Early derivation and equality of untagged types (2020-07-09)*
+
+ AI12-0352 clarifies that declaring a user-defined primitive equality operation for a record type T is illegal if it occurs after a type has been derived from T.
+
+ RM references: 4.05.02 (9.8/4)
+
+.. index:: AI12-0356 (Ada 2022 feature)
+
+* *AI12-0356 Root_Storage_Pool_With_Subpools should have Preelaborable_Initialization (0000-00-00)*
+
+ Add Preelaborable_Initialization pragmas for predefined types ``Root_Storage_Pool_With_Subpools`` and ``Root_Subpool``.
+
+ RM references: 13.11.04 (4/3) 13.11.04 (5/3)
+
+.. index:: AI12-0363 (Ada 2022 feature)
+
+* *AI12-0363 Fixes for Atomic and Volatile (2020-09-08)*
+
+ This amendment has been implemented under the ``-gnat2022`` switch and the compiler now supports the ``Full_Access_Only`` aspect, which is mostly equivalent to GNAT's ``Volatile_Full_Access``.
+
+ RM references: 3.10.02 (26/3) 9.10 (1/5) C.06 (6.4/3) C.06 (6.10/3) C.06
+ (8.1/4) C.06 (12/5) C.06 (12.1/5) C.06 (13.3/5) C.06 (19.1/5)
+
+.. index:: AI12-0364 (Ada 2022 feature)
+
+* *AI12-0364 Add a modular atomic arithmetic package (0000-00-00)*
+
+ Generalize support for atomic integer operations to extend to modular types. Add new predefined generic package,
+ ``System.Atomic_Operations.Modular_Arithmetic``.
+
+ RM references: C.06.05 (0) C.06.04 (1/5) C.06.04 (2/5) C.06.04 (3/5)
+ C.06.04 (9/5)
+
+.. index:: AI12-0366 (Ada 2022 feature)
+
+* *AI12-0366 Changes to Big_Integer and Big_Real (0000-00-00)*
+
+ Simplify ``Big_Integer ``and ``Big_Real`` specs by eliminating explicit support for creating "invalid" values. No more
+ ``Optional_Big_[Integer,Real]`` types.
+
+ RM references: A.05.06 (0) A.05.07 (0)
+
+.. index:: AI12-0367 (Ada 2022 feature)
+
+* *AI12-0367 Glitches in aspect specifications (0000-00-00)*
+
+ The AI clarifies a few wording omissions. For example, a specified Small value for a fixed point type has to be positive.
+
+ RM references: 3.05.09 (8/2) 3.05.10 (2/1) 13.01 (9.1/5) 13.14 (10)
+
+.. index:: AI12-0368 (Ada 2022 feature)
+
+* *AI12-0368 Declare expressions can be static (2020-05-30)*
+
+ AI12-0368 allows declare expressions to be static in Ada 2022.
+
+ RM references: 4.09 (8) 4.09 (12.1/3) 4.09 (17) 6.01.01 (24.2/5) 6.01.01
+ (24.3/5) 6.01.01 (24.4/5) 6.01.01 (24.5/5) C.04 (9)
+
+.. index:: AI12-0369 (Ada 2022 feature)
+
+* *AI12-0369 Relaxing barrier restrictions (2020-03-25)*
+
+ The definitions of the ``Simple_Barriers`` and ``Pure_Barriers`` restrictions were modified by this AI, replacing uses of "statically denotes" with "statically names". This means that in many cases (but not all) a barrier expression that references a subcomponent of a component of the protected type while subject to either of the two restrictions is now allowed; with the previous restriction definitions, such a barrier expression would not have been legal.
+
+ RM references: D.07 (1.3/5) D.07 (10.12/5)
+
+.. index:: AI12-0372 (Ada 2022 feature)
+
+* *AI12-0372 Static accessibility of "master of the call" (0000-00-00)*
+
+ Add an extra compile-time accessibility check for explicitly aliased parameters needed to prevent dangling references.
+
+ RM references: 3.10.02 (10.5/5) 3.10.02 (19.3/4) 6.04.01 (6.4/3)
+
+.. index:: AI12-0373 (Ada 2022 feature)
+
+* *AI12-0373 Bunch of fixes (0000-00-00)*
+
+ Small clarifications to various RM entries with minor impact on compiler implementation.
+
+ RM references: 3.01 (1) 4.02 (4) 4.02 (8/2) 4.02.01 (3/5) 4.02.01 (4/5)
+ 4.02.01 (5/5) 4.09 (17.3/5) 6.01.01 (41/5) 8.05.04 (4/3) 13.01.01
+ (4/3) 13.01.01 (11/3) 13.14 (3/5)
+
+.. index:: AI12-0376 (Ada 2022 feature)
+
+* *AI12-0376 Representation changes finally allowed for untagged derived types (0000-00-00)*
+
+ A change of representation for a derived type is allowed in some previously-illegal cases where a change of representation is required to implement a call to a derived subprogram.
+
+ RM references: 13.01 (10/4)
+
+.. index:: AI12-0377 (Ada 2022 feature)
+
+* *AI12-0377 View conversions and out parameters of types with Default_Value revisited (2020-06-17)*
+
+ This AI clarifies that an actual of an out parameter that is a view conversion
+ is illegal if either the target or operand type has Default_Value specified while the other does not.
+
+ RM references: 6.04.01 (5.1/4) 6.04.01 (5.2/4) 6.04.01 (5.3/4) 6.04.01
+ (13.1/4) 6.04.01 (13.2/4) 6.04.01 (13.3/4) 6.04.01 (13.4/4) 6.04.01 (15/3)
+
+.. index:: AI12-0381 (Ada 2022 feature)
+
+* *AI12-0381 Tag of a delta aggregate (0000-00-00)*
+
+ In the case of a delta aggregate of a specific tagged type, the tag of the aggregate comes from the specific type (as opposed to somehow from the base object).
+
+ RM references: 4.03.04 (14/5)
+
+.. index:: AI12-0382 (Ada 2022 feature)
+
+* *AI12-0382 Loosen type-invariant overriding requirement of AI12-0042-1 (0000-00-00)*
+
+ The AI relaxes some corner-case legality rules about type invariants that were added by AI12-0042-1.
+
+ RM references: 7.3.2(6.1/4)
+
+.. index:: AI12-0383 (Ada 2022 feature)
+
+* *AI12-0383 Renaming values (2020-06-17)*
+
+ This AI allow names that denote values rather than objects to nevertheless be
+ renamed using an object renaming.
+
+ RM references: 8.05.01 (1) 8.05.01 (4) 8.05.01 (4.1/2) 8.05.01 (6/2) 8.05.01 (8)
+
+.. index:: AI12-0384-2 (Ada 2022 feature)
+
+* *AI12-0384-2 Fixups for Put_Image and Text_Buffers (2021-04-29)*
+
+ In GNAT's initial implementation of the Ada 2022 ``Put_Image`` aspect and
+ attribute, buffering was performed using a GNAT-defined package,
+ ``Ada.Strings.Text_Output``. Ada 2022 requires a different package, Ada.``Strings.Text_Buffers``, for this role, and that package is now provided, and the older package is eliminated.
+
+ RM references: 4.10 (0) A.04.12 (0)
+
+.. index:: AI12-0385 (Ada 2022 feature)
+
+* *AI12-0385 Predefined shifts and rotates should be static (0000-00-00)*
+
+ This AI allows Shift and Rotate operations in static expressions. GNAT implements this AI partially.
+
+ RM references: 4.09 (20)
+
+.. index:: AI12-0389 (Ada 2022 feature)
+
+* *AI12-0389 Ignoring unrecognized aspects (2020-10-08)*
+
+ Two new restrictions, ``No_Unrecognized_Aspects`` and ``No_Unrecognized_Pragmas``, are available to make the compiler emit error messages on unrecognized pragmas and aspects.
+
+ RM references: 13.01.01 (38/3) 13.12.01 (6.3/3)
+
+.. index:: AI12-0394 (Ada 2022 feature)
+
+* *AI12-0394 Named Numbers and User-Defined Numeric Literals (2020-10-05)*
+
+ Ada 2022 allows using integer named numbers with types that have an
+ ``Integer_Literal`` aspect. Similarly, real named numbers may now be used with types that have a ``Real_Literal`` aspect with an overloading that takes two strings, to be used in particular with
+ ``Ada.Numerics.Big_Numbers.Big_Reals``.
+
+ RM references: 3.03.02 (3) 4.02.01 (4/5) 4.02.01 (8/5) 4.02.01 (12/5)
+ 4.02.01 (13/5) 4.09 (5)
+
+.. index:: AI12-0395 (Ada 2022 feature)
+
+* *AI12-0395 Allow aspect_specifications on formal parameters (0000-00-00)*
+
+ Change syntax rules to allow aspect_specifications on formal parameters, if an implementation if an implementation wants to define one. Currently, GNAT doesn't define any such aspect_specifications.
+
+ RM references: 6.01 (15/3)
+
+.. index:: AI12-0397 (Ada 2022 feature)
+
+* *AI12-0397 Default_Initial_Condition applied to derived type (2020-12-09)*
+
+ The compiler now implements the rules for resolving ``Default_Initial_Condition``
+ expressions that involve references to the current instance of types with the aspect, as specified by this AI. The type of the current instance is defined to be like a formal derived type, so for a derived type that inherits the aspect, a call passing the current instance to a primitive means that the call will resolve to invoke the corresponding primitive of the descendant type. This also now permits calls to abstract primitives to occur within the aspect expression of an abstract type.
+
+ RM references: 7.03.03 (3/5) 7.03.03 (6/5) 7.03.03 (8/5)
+
+.. index:: AI12-0398 (Ada 2022 feature)
+
+* *AI12-0398 Most declarations should have aspect specifications (2020-11-19)*
+
+ It is now possible to specify aspects for discriminant specifications, extended return object declarations, and entry index specifications. This is an extension added for Ada 2022 by this AI.
+
+ RM references: 3.07 (5/2) 6.03.01 (25) 6.05 (2.1/3) 9.05.02 (8)
+
+.. index:: AI12-0399 (Ada 2022 feature)
+
+* *AI12-0399 Aspect specification for Preelaborable_Initialization (0000-00-00)*
+
+ Semantics-preserving presentation change. Replace ``Preelaborable_Initialization`` pragmas with equivalent aspect specs in the listed predefined packages. GNAT follows the guidance of this AI partially.
+
+ RM references: 9.05 (53/5) 3.09 (6/5) 7.06 (5/2) 7.06 (7/2) 11.04.01 (2/5)
+ 11.04.01 (3/2) 13.11 (6/2) 13.11.04 (4/5) 13.11.04 (5/5) 13.13.01
+ (3/2) A.04.02 (4/2) A.04.02 (20/2) A.04.05 (4/2) A.04.07 (4/2)
+ A.04.07 (20/2) A.04.08 (4/2) A.04.08 (20/2) A.12.01 (5/4) A.18.02
+ (8/5) A.18.02 (9/2) A.18.02 (79.2/5) A.18.02 (79.3/5) A.18.03
+ (6/5) A.18.03 (7/2) A.18.03 (50.2/5) A.18.03 (50.3/5) A.18.05
+ (3/5) A.18.05 (4/2) A.18.05 (37.3/5) A.18.05 (37.4/5) A.18.06
+ (4/5) A.18.06 (5/2) A.18.06 (51.4/5) A.18.06 (51.5/5) A.18.08
+ (3/5) A.18.08 (4/2) A.18.08 (58.2/5) A.18.08 (58.3/5) A.18.09
+ (4/5) A.18.09 (5/2) A.18.09 (74.2/5) A.18.09 (74.3/5) A.18.10
+ (8/5) A.18.10 (9/3) A.18.10 (70.2/5) A.18.10 (70.3/5) A.18.18
+ (6/5) B.03.01 (5/2) C.07.01 (2/5) G.01.01 (4/2)
+
+.. index:: AI12-0400 (Ada 2022 feature)
+
+* *AI12-0400 Ambiguities associated with Vector Append and container aggregates (0000-00-00)*
+
+ Change the names of subprograms in the predefined Vector containers from ``Append`` to ``Append_Vector`` and from ``Prepend`` to ``Prepend_Vector`` in order to resolve some ambiguity problems. GNAT adds the subprograms with new names but also keeps the old ones for backward compatibility.
+
+ RM references: A.18.02 (8/5) A.18.02 (36/5) A.18.02 (37/5) A.18.02 (38/5)
+ A.18.02 (44/5) A.18.02 (46/5) A.18.02 (47/5) A.18.02 (58/5)
+ A.18.02 (79.2/5) A.18.02 (150/5) A.18.02 (151/5) A.18.02 (152/5)
+ A.18.02 (153/5) A.18.02 (154/5) A.18.02 (155/5) A.18.02 (156/5)
+ A.18.02 (168/5) A.18.02 (169/5) A.18.02 (172/5) A.18.02 (173/5)
+ A.18.02 (174/5) A.18.02 (175.1/5) A.18.03 (23/5) A.18.03 (23.1/5)
+ A.18.03 (58.2/5) A.18.03 (96/5) A.18.03 (97.1/5)
+
+.. index:: AI12-0401 (Ada 2022 feature)
+
+* *AI12-0401 Renaming of qualified expression of variable (2020-10-31)*
+
+ Ada 2022 AI12-0401 restricts renaming of a qualified expression to cases where
+ the operand is a constant, or the target subtype statically matches the nominal subtype of the operand, or is unconstrained with no predicates, to prevent setting variables to values outside their range or constraints.
+
+ RM references: 3.03 (23.2/3) 8.05.01 (4.7/5) 8.05.01 (5/3)
+
+.. index:: AI12-0409 (Ada 2022 feature)
+
+* *AI12-0409 Preelaborable_Initialization and bounded containers (2021-06-23)*
+
+ As defined by this AI, the ``Preelaborable_Initializatio`` aspect now has a
+ corresponding attribute of the same name. Types declared within a generic package specification are permitted to specify the expression of a ``Prelaborable_Initialization`` aspect by including one or more references to the attribute applied to a formal private or formal derived type conjoined by ``and`` operators. This permits the full type of a private type with such an aspect expression to have components of the named formal types, and such a type will have preelaborable initialization in an instance when the
+ actual types for all referenced formal types have preelaborable initialization.
+
+ RM references: 10.02.01 (4.1/2) 10.02.01 (4.2/2) 10.02.01 (11.1/2)
+ 10.02.01 (11.2/2) 10.02.01 (11.6/2) 10.02.01 (11.7/2) 10.02.01
+ (11.8/2) 13.01 (11/3) A.18.19 (5/5) A.18.20 (5/5) A.18.21 (5/5)
+ A.18.22 (5/5) A.18.23 (5/5) A.18.24 (5/5) A.18.25 (5/5) A.18.32
+ (6/5) J.15.14 (0)
+
+.. index:: AI12-0411 (Ada 2022 feature)
+
+* *AI12-0411 Add "bool" to Interfaces.C (0000-00-00)*
+
+ RM references: B.03 (13) B.03 (43/2) B.03 (65.1/4)
+
+.. index:: AI12-0412 (Ada 2022 feature)
+
+* *AI12-0412 Abstract Pre/Post'Class on primitive of abstract type (2021-05-19)*
+
+ In Ada 2022, by AI12-0412, it's legal to specify Pre'Class and Post'Class
+ aspects on nonabstract primitive subprograms of an abstract type, but if the
+ expression of such an aspect is nonstatic, then it's illegal to make a nondispatching call to such a primitive, to apply ``'Access`` to it, or to pass such a primitive as an actual subprogram for a concrete formal subprogram in a generic instantiation.
+
+ RM references: 6.01.01 (18.2/4)
+
+.. index:: AI12-0413 (Ada 2022 feature)
+
+* *AI12-0413 Reemergence of "=" when defined to be abstract (0000-00-00)*
+
+ The AI clarifies rules about operator reemergence in instances, and nondispatching calls to abstract subprograms.
+
+ RM references: 3.09.03 (7) 4.05.02 (14.1/3) 4.05.02 (24.1/3) 12.05 (8/3)
+
+.. index:: AI12-0423 (Ada 2022 feature)
+
+* *AI12-0423 Aspect inheritance fixups (0000-00-00)*
+
+ Clarify that the No_Return aspect behaves as one would expect for an inherited subprogram and that inheritance works as one would expect for a multi-part aspect whose value is specified via an aggregate (e.g., the Aggregate aspect).
+
+ RM references: 6.05.01 (3.3/3) 13.01 (15.7/5) 13.01 (15.8/5)
+
+.. index:: AI12-0432 (Ada 2022 feature)
+
+* *AI12-0432 View conversions of assignments and predicate checks (2021-05-05)*
+
+ When a predicate applies to a tagged type, a view conversion to that type
+ normally requires a predicate check. However, as specified by AI12-0432, when the view conversion appears as the target of an assignment, a predicate check is not applied to the object in the conversion.
+
+ RM references: 3.02.04 (31/5) 4.06 (51.1/5)
diff --git a/gcc/ada/doc/gnat_rm/representation_clauses_and_pragmas.rst b/gcc/ada/doc/gnat_rm/representation_clauses_and_pragmas.rst
index b0e131f..7250f65 100644
--- a/gcc/ada/doc/gnat_rm/representation_clauses_and_pragmas.rst
+++ b/gcc/ada/doc/gnat_rm/representation_clauses_and_pragmas.rst
@@ -1872,7 +1872,7 @@ conventions, and for example records are laid out in a manner that is
consistent with C. This means that specifying convention C (for example)
has no effect.
-There are four exceptions to this general rule:
+There are three exceptions to this general rule:
* *Convention Fortran and array subtypes*.
diff --git a/gcc/ada/doc/gnat_rm/specialized_needs_annexes.rst b/gcc/ada/doc/gnat_rm/specialized_needs_annexes.rst
index 15b4a94..f34368c 100644
--- a/gcc/ada/doc/gnat_rm/specialized_needs_annexes.rst
+++ b/gcc/ada/doc/gnat_rm/specialized_needs_annexes.rst
@@ -4,9 +4,7 @@
Specialized Needs Annexes
*************************
-Ada 95, Ada 2005, and Ada 2012 define a number of Specialized Needs Annexes, which are not
-required in all implementations. However, as described in this chapter,
-GNAT implements all of these annexes:
+Ada 95, Ada 2005, Ada 2012, and Ada 2022 define a number of Specialized Needs Annexes, which are not required in all implementations. However, as described in this chapter, GNAT implements all of these annexes:
*Systems Programming (Annex C)*
The Systems Programming Annex is fully implemented.
@@ -18,9 +16,8 @@ GNAT implements all of these annexes:
*Distributed Systems (Annex E)*
Stub generation is fully implemented in the GNAT compiler. In addition,
- a complete compatible PCS is available as part of the GLADE system,
- a separate product. When the two
- products are used in conjunction, this annex is fully implemented.
+ a complete compatible PCS is available as part of ``PolyORB``,
+ a separate product. Note, that PolyORB is a deprecated product and will be eventually replaced with other technologies such as ``RTI``.
*Information Systems (Annex F)*
@@ -34,4 +31,3 @@ GNAT implements all of these annexes:
*Safety and Security / High-Integrity Systems (Annex H)*
The Safety and Security Annex (termed the High-Integrity Systems Annex
in Ada 2005) is fully implemented.
-
diff --git a/gcc/ada/doc/gnat_rm/the_gnat_library.rst b/gcc/ada/doc/gnat_rm/the_gnat_library.rst
index ac45b5e..d041090 100644
--- a/gcc/ada/doc/gnat_rm/the_gnat_library.rst
+++ b/gcc/ada/doc/gnat_rm/the_gnat_library.rst
@@ -2037,7 +2037,7 @@ technically an implementation-defined addition).
This package provides facilities for partition interfacing. It
is used primarily in a distribution context when using Annex E
-with ``GLADE``.
+with ``PolyORB``.
.. _`System.Pool_Global_(s-pooglo.ads)`:
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 4f46fba..fdf1948 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
@@ -2112,7 +2112,7 @@ Alphabetical List of All Switches
.. index:: -gnatR (gcc)
-:switch:`-gnatR[0|1|2|3|4][e][j][m][s]`
+:switch:`-gnatR[0|1|2|3|4][e][h][m][j][s]`
Output representation information for declared types, objects and
subprograms. Note that this switch is not allowed if a previous
:switch:`-gnatD` switch has been given, since these two switches
@@ -2259,15 +2259,16 @@ Alphabetical List of All Switches
======= ==================================================================
*n* Effect
------- ------------------------------------------------------------------
- *0* No optimization, the default setting if no :switch:`-O` appears
- *1* Normal optimization, the default if you specify :switch:`-O` without an
- operand. A good compromise between code quality and compilation
- time.
- *2* Extensive optimization, may improve execution time, possibly at
+ *0* No optimization, the default setting if no :switch:`-O` appears.
+ *1* Moderate optimization, same as :switch:`-O` without an operand.
+ A good compromise between code quality and compilation time.
+ *2* Extensive optimization, should improve execution time, possibly at
the cost of substantially increased compilation time.
- *3* Same as :switch:`-O2`, and also includes inline expansion for small
- subprograms in the same unit.
- *s* Optimize space usage
+ *3* Full optimization, may further improve execution time, possibly at
+ the cost of substantially larger generated code.
+ *s* Optimize for size (code and data) rather than speed.
+ *z* Optimize aggressively for size (code and data) rather than speed.
+ *g* Optimize for debugging experience rather than speed.
======= ==================================================================
See also :ref:`Optimization_Levels`.
@@ -6088,7 +6089,7 @@ Debugging Control
.. index:: -gnatR (gcc)
-:switch:`-gnatR[0|1|2|3|4][e][j][m][s]`
+:switch:`-gnatR[0|1|2|3|4][e][h][m][j][s]`
This switch controls output from the compiler of a listing showing
representation information for declared types, objects and subprograms.
For :switch:`-gnatR0`, no information is output (equivalent to omitting
@@ -6116,17 +6117,21 @@ Debugging Control
extended representation information for record sub-components of records
is included.
+ If the switch is followed by a ``h`` (e.g. :switch:`-gnatR3h`), then
+ the components of records are sorted by increasing offsets and holes
+ between consecutive components are flagged.
+
If the switch is followed by an ``m`` (e.g. :switch:`-gnatRm`), then
subprogram conventions and parameter passing mechanisms for all the
subprograms are included.
- If the switch is followed by a ``j`` (e.g., :switch:`-gnatRj`), then
+ If the switch is followed by a ``j`` (e.g. :switch:`-gnatRj`), then
the output is in the JSON data interchange format specified by the
ECMA-404 standard. The semantic description of this JSON output is
available in the specification of the Repinfo unit present in the
compiler sources.
- If the switch is followed by an ``s`` (e.g., :switch:`-gnatR3s`), then
+ If the switch is followed by an ``s`` (e.g. :switch:`-gnatR3s`), then
the output is to a file with the name :file:`file.rep` where ``file`` is
the name of the corresponding source file, except if ``j`` is also
specified, in which case the file name is :file:`file.json`.
@@ -8123,6 +8128,9 @@ We provide two options that you can use to build code with GNAT LLVM:
which version of GNAT built that file because it contains either
:code:`GNAT` or :code:`GNAT-LLVM`.
+ You can also explicitly select GNAT LLVM in your existing GPR project
+ file by adding :code:`for Toolchain_Name("Ada") use "GNAT_LLVM";`
+
.. only:: PRO
If your project uses one of the libraries packaged with the GCC
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 756bc74..031fafc 100644
--- a/gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst
+++ b/gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst
@@ -23,6 +23,7 @@ This chapter covers several topics:
* `Performing Dimensionality Analysis in GNAT`_
* `Stack Related Facilities`_
* `Memory Management Issues`_
+* `Sanitizers for Ada`_
.. _Running_and_Debugging_Ada_Programs:
@@ -1584,18 +1585,16 @@ Turning on optimization makes the compiler attempt to improve the
performance and/or code size at the expense of compilation time and
possibly the ability to debug the program.
-If you use multiple :switch:`-O` switches, with or without level
-numbers, the last such switch is the one that's used.
-
-You can use the
-:switch:`-O` switch (the permitted forms are :switch:`-O0`, :switch:`-O1`
-:switch:`-O2`, :switch:`-O3`, and :switch:`-Os`)
-to ``gcc`` to control the optimization level:
+You can pass the :switch:`-O` switch, with or without an operand
+(the permitted forms with an operand are :switch:`-O0`, :switch:`-O1`,
+:switch:`-O2`, :switch:`-O3`, :switch:`-Os`, :switch:`-Oz`, and
+:switch:`-Og`) to ``gcc`` to control the optimization level. If you
+pass multiple :switch:`-O` switches, with or without an operand,
+the last such switch is the one that's used:
* :switch:`-O0`
- No optimization (the default);
- generates unoptimized code but has
+ No optimization (the default); generates unoptimized code but has
the fastest compilation time. Debugging is easiest with this switch.
Note that many other compilers do substantial optimization even if
@@ -1606,32 +1605,45 @@ to ``gcc`` to control the optimization level:
mind when doing performance comparisons.
* :switch:`-O1`
- Moderate optimization; optimizes reasonably well but does not
- degrade compilation time significantly. You may not be able to see
- some variables in the debugger and changing the value of some
- variables in the debugger may not have the effect you desire.
+ Moderate optimization (same as :switch:`-O` without an operand);
+ optimizes reasonably well but does not degrade compilation time
+ significantly. You may not be able to see some variables in the
+ debugger, and changing the value of some variables in the debugger
+ may not have the effect you desire.
* :switch:`-O2`
- Full optimization;
- generates highly optimized code and has
- the slowest compilation time. You may see significant impacts on
+ Extensive optimization; generates highly optimized code but has
+ an increased compilation time. You may see significant impacts on
your ability to display and modify variables in the debugger.
* :switch:`-O3`
- Full optimization as in :switch:`-O2`;
- also uses more aggressive automatic inlining of subprograms within a unit
- (:ref:`Inlining_of_Subprograms`) and attempts to vectorize loops.
-
+ Full optimization; attempts more sophisticated transformations, in
+ particular on loops, possibly at the cost of larger generated code.
+ You may be hardly able to use the debugger at this optimization level.
* :switch:`-Os`
- Optimize space usage (code and data) of resulting program.
+ Optimize for size (code and data) of resulting binary rather than
+ speed; based on the :switch:`-O2` optimization level, but disables
+ some of its transformations that often increase code size, as well
+ as performs further optimizations designed to reduce code size.
+
+* :switch:`-Oz`
+ Optimize aggressively for size (code and data) of resulting binary
+ rather than speed; may increase the number of instructions executed
+ if these instructions require fewer bytes to be encoded.
+
+* :switch:`-Og`
+ Optimize for debugging experience rather than speed; based on the
+ :switch:`-O1` optimization level, but attempts to eliminate all the
+ negative effects of optimization on debugging.
+
Higher optimization levels perform more global transformations on the
program and apply more expensive analysis algorithms in order to generate
faster and more compact code. The price in compilation time, and the
-resulting improvement in execution time,
-both depend on the particular application and the hardware environment.
-You should experiment to find the best level for your application.
+resulting improvement in execution time, both depend on the particular
+application and the hardware environment. You should experiment to find
+the best level for your application.
Since the precise set of optimizations done at each level will vary from
release to release (and sometime from target to target), it is best to think
@@ -4122,3 +4134,325 @@ execution of this erroneous program:
The allocation root #1 of the first example has been split in 2 roots #1
and #3, thanks to the more precise associated backtrace.
+
+.. _Sanitizers_for_Ada:
+
+Sanitizers for Ada
+==================
+
+.. index:: Sanitizers
+
+This section explains how to use sanitizers with Ada code. Sanitizers offer code
+instrumentation and run-time libraries that detect certain memory issues and
+undefined behaviors during execution. They provide dynamic analysis capabilities
+useful for debugging and testing.
+
+While many sanitizer capabilities overlap with Ada's built-in runtime checks,
+they are particularly valuable for identifying issues that arise from unchecked
+features or low-level operations.
+
+.. _AddressSanitizer:
+
+AddressSanitizer
+----------------
+
+.. index:: AddressSanitizer
+.. index:: ASan
+.. index:: -fsanitize=address
+
+AddressSanitizer (aka ASan) is a memory error detector activated with the
+:switch:`-fsanitize=address` switch. Note that many of the typical memory errors,
+such as use after free or buffer overflow, are detected by Ada’s ``Access_Check``
+and ``Index_Check``.
+
+It can detect the following types of problems:
+
+* Wrong memory overlay
+
+ A memory overlay is a situation in which an object of one type is placed at the
+ same memory location as a distinct object of a different type, thus overlaying
+ one object over the other in memory. When there is an overflow because the
+ objects do not overlap (like in the following example), the sanitizer can signal
+ it.
+
+ .. code-block:: ada
+
+ procedure Wrong_Size_Overlay is
+ type Block is array (Natural range <>) of Integer;
+
+ Block4 : aliased Block := (1 .. 4 => 4);
+ Block5 : Block (1 .. 5) with Address => Block4'Address;
+ begin
+ Block5 (Block5'Last) := 5; -- Outside the object
+ end Wrong_Size_Overlay;
+
+ If the code is built with the :switch:`-fsanitize=address` and :switch:`-g` options,
+ the following error is shown at execution time:
+
+ ::
+
+ ...
+ SUMMARY: AddressSanitizer: stack-buffer-overflow wrong_size_overlay.adb:7 in _ada_wrong_size_overlay
+ ...
+
+* Buffer overflow
+
+ Ada’s ``Index_Check`` detects buffer overflows caused by out-of-bounds array
+ access. If run-time checks are disabled, the sanitizer can still detect such
+ overflows at execution time the same way as it signalled the previous wrong
+ memory overlay. Note that if both the Ada run-time checks and the sanitizer
+ are enabled, the Ada run-time exception takes precedence.
+
+ .. code-block:: ada
+
+ procedure Buffer_Overrun is
+ Size : constant := 100;
+ Buffer : array (1 .. Size) of Integer := (others => 0);
+ Wrong_Index : Integer := Size + 1 with Export;
+ begin
+ -- Access outside the boundaries
+ Put_Line ("Value: " & Integer'Image (Buffer (Wrong_Index)));
+ end Buffer_Overrun;
+
+* Use after lifetime
+
+ Ada’s ``Accessibility_Check`` helps prevent use-after-return and
+ use-after-scope errors by enforcing lifetime rules. When these checks are
+ bypassed using ``Unchecked_Access``, sanitizers can still detect such
+ violations during execution.
+
+ .. code-block:: ada
+
+ with Ada.Text_IO; use Ada.Text_IO;
+
+ procedure Use_After_Return is
+ type Integer_Access is access all Integer;
+ Ptr : Integer_Access;
+
+ procedure Inner;
+
+ procedure Inner is
+ Local : aliased Integer := 42;
+ begin
+ Ptr := Local'Unchecked_Access;
+ end Inner;
+
+ begin
+ Inner;
+ -- Accessing Local after it has gone out of scope
+ Put_Line ("Value: " & Integer'Image (Ptr.all));
+ end Use_After_Return;
+
+ If the code is built with the :switch:`-fsanitize=address` and :switch:`-g`
+ options, the following error is shown at execution time:
+
+ ::
+
+ ...
+ ==1793927==ERROR: AddressSanitizer: stack-use-after-return on address 0xf6fa1a409060 at pc 0xb20b6cb6cac0 bp 0xffffcc89c8b0 sp 0xffffcc89c8c8
+ READ of size 4 at 0xf6fa1a409060 thread T0
+ #0 0xb20b6cb6cabc in _ada_use_after_return use_after_return.adb:18
+ ...
+
+ Address 0xf6fa1a409060 is located in stack of thread T0 at offset 32 in frame
+ #0 0xb20b6cb6c794 in use_after_return__inner use_after_return.adb:9
+
+ This frame has 1 object(s):
+ [32, 36) 'local' (line 10) <== Memory access at offset 32 is inside this variable
+ SUMMARY: AddressSanitizer: stack-use-after-return use_after_return.adb:18 in _ada_use_after_return
+ ...
+
+* Memory leak
+
+ A memory leak happens when a program allocates memory from the heap but fails
+ to release it after it is no longer needed and loses all references to it like
+ in the following example.
+
+ .. code-block:: ada
+
+ procedure Memory_Leak is
+ type Integer_Access is access Integer;
+
+ procedure Allocate is
+ Ptr : Integer_Access := new Integer'(42);
+ begin
+ null;
+ end Allocate;
+ begin
+ -- Memory leak occurs in the following procedure
+ Allocate;
+ end Memory_Leak;
+
+ If the code is built with the :switch:`-fsanitize=address` and :switch:`-g`
+ options, the following error is emitted at execution time showing the
+ location of the offending allocation.
+
+ ::
+
+ ==1810634==ERROR: LeakSanitizer: detected memory leaks
+
+ Direct leak of 4 byte(s) in 1 object(s) allocated from:
+ #0 0xe3cbee4bb4a8 in __interceptor_malloc asan_malloc_linux.cpp:69
+ #1 0xc15bb25d0af8 in __gnat_malloc (memory_leak+0x10af8) (BuildId: f5914a6eac10824f81d512de50b514e7d5f733be)
+ #2 0xc15bb25c9060 in memory_leak__allocate memory_leak.adb:5
+ ...
+
+ SUMMARY: AddressSanitizer: 4 byte(s) leaked in 1 allocation(s).
+
+.. _UndefinedBehaviorSanitizer:
+
+UndefinedBehaviorSanitizer
+--------------------------
+
+.. index:: UndefinedBehaviorSanitizer
+.. index:: UBSan
+.. index:: -fsanitize=undefined
+
+UndefinedBehaviorSanitizer (aka UBSan) modifies the program at compile-time to
+catch various kinds of undefined behavior during program execution.
+
+Different sanitize options (:switch:`-fsanitize=alignment,float-cast-overflow,signed-integer-overflow`)
+detect the following types of problems:
+
+* Wrong alignment
+
+ The :switch:`-fsanitize=alignment` flag (included also in
+ :switch:`-fsanitize=undefined`) enables run-time checks for misaligned memory
+ accesses, ensuring that objects are accessed at addresses that conform to the
+ alignment constraints of their declared types. Violations may lead to crashes
+ or performance penalties on certain architectures.
+
+ In the following example:
+
+ .. code-block:: ada
+
+ with Ada.Text_IO; use Ada.Text_IO;
+ with System.Storage_Elements; use System.Storage_Elements;
+
+ procedure Misaligned_Address is
+ type Aligned_Integer is new Integer with
+ Alignment => 4; -- Ensure 4-byte alignment
+
+ Reference : Aligned_Integer := 42; -- Properly aligned object
+
+ -- Create a misaligned object by modifying the address manually
+ Misaligned : Aligned_Integer with Address => Reference'Address + 1;
+
+ begin
+ -- This causes undefined behavior or an alignment exception on strict architectures
+ Put_Line ("Misaligned Value: " & Aligned_Integer'Image (Misaligned));
+ end Misaligned_Address;
+
+ If the code is built with the :switch:`-fsanitize=alignment` and :switch:`-g`
+ options, the following error is shown at execution time.
+
+ ::
+
+ misaligned_address.adb:15:51: runtime error: load of misaligned address 0xffffd836dd45 for type 'volatile misaligned_address__aligned_integer', which requires 4 byte alignment
+
+* Signed integer overflow
+
+ Ada performs range checks at runtime in arithmetic operation on signed integers
+ to ensure the value is within the target type's bounds. If this check is removed,
+ the :switch:`-fsanitize=signed-integer-overflow` flag (included also in
+ :switch:`-fsanitize=undefined`) enables run-time checks for signed integer
+ overflows.
+
+ In the following example:
+
+ .. code-block:: ada
+
+ procedure Signed_Integer_Overflow is
+ type Small_Int is range -128 .. 127;
+ X, Y, Z : Small_Int with Export;
+ begin
+ X := 100;
+ Y := 50;
+ -- This addition will exceed 127, causing an overflow
+ Z := X + Y;
+ end Signed_Integer_Overflow;
+
+ If the code is built with the :switch:`-fsanitize=signed-integer-overflow` and
+ :switch:`-g` options, the following error is shown at execution time.
+
+ ::
+
+ signed_integer_overflow.adb:8:11: runtime error: signed integer overflow: 100 + 50 cannot be represented in type 'signed_integer_overflow__small_int'
+
+* Float to integer overflow
+
+ When converting a floating-point value to an integer type, Ada performs a range
+ check at runtime to ensure the value is within the target type's bounds. If this
+ check is removed, the sanitizer can detect overflows in conversions from
+ floating point to integer types.
+
+ In the following code:
+
+ .. code-block:: ada
+
+ procedure Float_Cast_Overflow is
+ Flt : Float := Float'Last with Export;
+ Int : Integer;
+ begin
+ Int := Integer (Flt); -- Overflow
+ end Float_Cast_Overflow;
+
+ If the code is built with the :switch:`-fsanitize=float-cast-overflow` and
+ :switch:`-g` options, the following error is shown at execution time.
+
+ ::
+
+ float_cast_overflow.adb:5:20: runtime error: 3.40282e+38 is outside the range of representable values of type 'integer'
+
+Sanitizers in mixed-language applications
+-----------------------------------------
+
+Most of the checks performed by sanitizers operate at a global level, which
+means they can detect issues even when they span across language boundaries.
+This applies notably to:
+
+* All checks performed by the AddressSanitizer: wrong memory overlays, buffer
+ overflows, uses after lifetime, memory leaks. These checks apply globally,
+ regardless of where the objects are allocated or defined, or where they are
+ destroyed
+
+* Wrong alignment checks performed by the UndefinedBehaviorSanitizer. It will
+ check whether an object created in a given language is accessed in another
+ with an incompatible alignment
+
+An interesting case that highlights the benefit of global sanitization is a
+buffer overflow caused by a mismatch in language bindings. Consider the
+following C function, which allocates an array of 4 characters:
+
+ .. code-block:: c
+
+ char *get_str (void) {
+ char *str = malloc (4 * sizeof (char));
+ }
+
+This function is then bound to Ada code, which incorrectly assumes the buffer
+is of size 5:
+
+ .. code-block:: ada
+
+ type Buffer is array (1 .. 5) of Character;
+
+ function Get_Str return access Buffer
+ with Import => True, Convention => C, External_Name => "get_str";
+
+ Str : access Buffer := Get_Str;
+ Ch : Character := S (S'Last); -- Detected by AddressSanitizer as erroneous
+
+On the Ada side, accessing ``Str (5)`` appears valid because the array type
+declares five elements. However, the actual memory allocated in C only holds
+four. This mismatch is not detectable by Ada run-time checks, because Ada has
+no visibility into how the memory was allocated.
+
+However, the AddressSanitizer will detect the heap buffer overflow at runtime,
+halting execution and providing a clear diagnostic:
+
+ ::
+
+ ...
+ SUMMARY: AddressSanitizer: heap-buffer-overflow buffer_overflow.adb:20 in _ada_buffer_overflow
+ ...
diff --git a/gcc/ada/doc/gnat_ugn/platform_specific_information.rst b/gcc/ada/doc/gnat_ugn/platform_specific_information.rst
index f2fc737..6493a06 100644
--- a/gcc/ada/doc/gnat_ugn/platform_specific_information.rst
+++ b/gcc/ada/doc/gnat_ugn/platform_specific_information.rst
@@ -2212,11 +2212,12 @@ Setting Stack Size from ``gnatlink``
You can specify the program stack size at link time. On most versions
of Windows, starting with XP, this is mostly useful to set the size of
the main stack (environment task). The other task stacks are set with
-pragma Storage_Size or with the *gnatbind -d* command.
+pragma Storage_Size or with the *gnatbind -d* command. The specified size will
+become the reserved memory size of the underlying thread.
Since very old versions of Windows (2000, NT4, etc.) don't allow setting the
-reserve size of individual tasks, the link-time stack size applies to all
-tasks, and pragma Storage_Size has no effect.
+reserve size of individual tasks, for those versions the link-time stack size
+applies to all tasks, and pragma Storage_Size has no effect.
In particular, Stack Overflow checks are made against this
link-time specified size.
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 64a3631..891886b 100644
--- a/gcc/ada/doc/gnat_ugn/the_gnat_compilation_model.rst
+++ b/gcc/ada/doc/gnat_ugn/the_gnat_compilation_model.rst
@@ -1477,6 +1477,10 @@ You can place configuration pragmas either appear at the start of a compilation
unit or in a configuration pragma file that applies to
all compilations performed in a given compilation environment.
+Configuration pragmas placed before a library level package specification
+are not propagated to the corresponding package body (see RM 10.1.5(8));
+they must be added explicitly to the package body.
+
GNAT includes the ``gnatchop`` utility to provide an automatic
way to handle configuration pragmas that follows the semantics for
compilations (that is, files with multiple units) described in the RM.
diff --git a/gcc/ada/einfo-utils.adb b/gcc/ada/einfo-utils.adb
index ec1087d..417da6e 100644
--- a/gcc/ada/einfo-utils.adb
+++ b/gcc/ada/einfo-utils.adb
@@ -1037,6 +1037,7 @@ package body Einfo.Utils is
Id = Pragma_Contract_Cases or else
Id = Pragma_Exceptional_Cases or else
Id = Pragma_Exit_Cases or else
+ Id = Pragma_Program_Exit or else
Id = Pragma_Subprogram_Variant or else
Id = Pragma_Test_Case;
@@ -2344,6 +2345,25 @@ package body Einfo.Utils is
begin
pragma Assert (Is_Type (Id));
+ if Nkind (Associated_Node_For_Itype (Id)) = N_Subtype_Declaration then
+ declare
+ Associated_Id : constant Entity_Id :=
+ Defining_Identifier (Associated_Node_For_Itype (Id));
+ begin
+ -- Avoid Itype/predicate problems by looking through Itypes.
+ -- We never introduce new predicates for Itypes, so doing this
+ -- will never cause us to incorrectly overlook a predicate.
+ -- It is not clear whether the FE needs this fix, but
+ -- GNATProve does (note that GNATProve calls Predicate_Function).
+
+ if Id /= Associated_Id
+ and then Base_Type (Id) = Base_Type (Associated_Id)
+ then
+ return Predicate_Function (Associated_Id);
+ end if;
+ end;
+ end if;
+
-- If type is private and has a completion, predicate may be defined on
-- the full view.
@@ -2375,6 +2395,37 @@ package body Einfo.Utils is
if Ekind (Subp_Id) = E_Function
and then Is_Predicate_Function (Subp_Id)
then
+ -- We may have incorrectly looked through predicate-bearing
+ -- subtypes when going from a private subtype to its full
+ -- view, so compensate for that case. Unfortunately,
+ -- Subp_Id might not be analyzed at this point, so we
+ -- use a crude works-most-of-the-time text-based
+ -- test to detect the case where Id is a subtype (declared by
+ -- a subtype declaration) and no predicate was explicitly
+ -- specified for Id. Ugh. ???
+
+ if Nkind (Parent (Id)) = N_Subtype_Declaration
+ -- 1st choice ...
+ -- and then Etype (First_Entity (Subp_Id)) /= Id
+ -- but that doesn't work if Subp_Id is not analyzed.
+
+ -- so we settle for 2nd choice, ignoring cases like
+ -- "subtype Foo is Pkg.Foo;" where distinct subtypes
+ -- have the same identifier:
+ --
+ and then Get_Name_String (Chars (Subp_Id)) /=
+ Get_Name_String (Chars (Id)) & "Predicate"
+ then
+ declare
+ Mark : Node_Id := Subtype_Indication (Parent (Id));
+ begin
+ if Nkind (Mark) = N_Subtype_Indication then
+ Mark := Subtype_Mark (Mark);
+ end if;
+ return Predicate_Function (Entity (Mark));
+ end;
+ end if;
+
return Subp_Id;
end if;
@@ -2638,14 +2689,7 @@ package body Einfo.Utils is
-- anonymous protected types, since protected types always have the
-- default convention.
- if Present (Etype (E))
- and then (Is_Object (E)
-
- -- Allow E_Void (happens for pragma Convention appearing
- -- in the middle of a record applying to a component)
-
- or else Ekind (E) = E_Void)
- then
+ if Present (Etype (E)) and then Is_Object (E) then
declare
Typ : constant Entity_Id := Etype (E);
@@ -2809,7 +2853,6 @@ package body Einfo.Utils is
end if;
Subp_Elmt := First_Elmt (Subps);
- Prepend_Elmt (V, Subps);
-- Check for a duplicate predication function
@@ -2819,11 +2862,17 @@ package body Einfo.Utils is
if Ekind (Subp_Id) = E_Function
and then Is_Predicate_Function (Subp_Id)
then
- raise Program_Error;
+ if V = Subp_Id then
+ return;
+ else
+ raise Program_Error;
+ end if;
end if;
Next_Elmt (Subp_Elmt);
end loop;
+
+ Prepend_Elmt (V, Subps);
end Set_Predicate_Function;
-----------------
diff --git a/gcc/ada/einfo-utils.ads b/gcc/ada/einfo-utils.ads
index ed1f153..78b4989 100644
--- a/gcc/ada/einfo-utils.ads
+++ b/gcc/ada/einfo-utils.ads
@@ -456,6 +456,7 @@ package Einfo.Utils is
-- No_Caching
-- Part_Of
-- Precondition
+ -- Program_Exit
-- Postcondition
-- Refined_Depends
-- Refined_Global
diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads
index f154e7f..ba79fe4 100644
--- a/gcc/ada/einfo.ads
+++ b/gcc/ada/einfo.ads
@@ -463,11 +463,13 @@ package Einfo is
-- For an access_to_protected_subprogram parameter it is the declaration
-- of the corresponding formal parameter.
---
--- Itypes have no explicit declaration, and therefore are not attached to
--- the tree: their Parent field is always empty. The Associated_Node_For_
--- Itype is the only way to determine the construct that leads to the
--- creation of a given itype entity.
+
+-- Itypes need not have an explicit declaration, in which case they are
+-- not attached to the tree through the Parent field, which is empty. In
+-- other cases, they have one and are attached to the tree through the
+-- Parent field as usual. Associated_Node_For_Itype should be used to
+-- determine the construct that leads to the creation of a given itype
+-- entity.
-- Associated_Storage_Pool [root type only]
-- Defined in simple and general access type entities. References the
@@ -714,6 +716,14 @@ package Einfo is
-- bodies. Set if the entity contains any ignored Ghost code in the form
-- of declaration, procedure call, assignment statement or pragma.
+-- Continue_Mark
+-- Defined in loop entities. It points to the loop's statement after
+-- which the label for continue statements must be inserted if one is
+-- needed. This is not always the last statement in the loop's list; it
+-- can notably be followed by assignment statements generated by
+-- expansion of iterator specifications, which continue statements must
+-- not jump past.
+
-- Contract
-- Defined in constant, entry, entry family, operator, [generic] package,
-- package body, protected unit, [generic] subprogram, subprogram body,
@@ -832,12 +842,6 @@ package Einfo is
-- Default_Value aspect specification for the type, or inherited
-- on derivation.
--- Default_Expr_Function
--- Defined in parameters. It holds the entity of the parameterless
--- function that is built to evaluate the default expression if it is
--- more complex than a simple identifier or literal. For the latter
--- simple cases or if there is no default value, this field is Empty.
-
-- Default_Expressions_Processed
-- A flag in subprograms (functions, operators, procedures) and in
-- entries and entry families used to indicate that default expressions
@@ -864,12 +868,6 @@ package Einfo is
-- that holds value of delta for the type, as given in the declaration
-- or as inherited by a subtype or derived type.
--- Dependent_Instances
--- Defined in packages that are instances. Holds list of instances
--- of inner generics. Used to place freeze nodes for those instances
--- after that of the current one, i.e. after the corresponding generic
--- bodies.
-
-- Depends_On_Private
-- Defined in all type entities. Set if the type is private or if it
-- depends on a private type.
@@ -1462,11 +1460,6 @@ package Einfo is
-- associates generic parameters with the corresponding instances, in
-- those cases where the instance is an entity.
--- Handler_Records
--- Defined in subprogram and package entities. Points to a list of
--- identifiers referencing the handler record entities for the
--- corresponding unit.
-
-- Has_Aliased_Components [implementation base type only]
-- Defined in array type entities. Indicates that the component type
-- of the array is aliased. Should this also be set for records to
@@ -1623,7 +1616,7 @@ package Einfo is
-- Has_Dynamic_Predicate_Aspect
-- Defined in all types and subtypes. Set if a Dynamic_Predicate aspect
--- was explicitly applied to the type. Generally we treat predicates as
+-- was applied to the type or subtype. Generally we treat predicates as
-- static if possible, regardless of whether they are specified using
-- Predicate, Static_Predicate, or Dynamic_Predicate. And if a predicate
-- can be treated as static (i.e. its expression is predicate-static),
@@ -1704,7 +1697,7 @@ package Einfo is
--
-- Has_Homonym
-- Defined in all entities. Set if an entity has a homonym in the same
--- scope. Used by the backend to generate unique names for all entities.
+-- scope. Used by Exp_Dbug to generate unique names for all entities.
-- Has_Implicit_Dereference
-- Defined in types and discriminants. Set if the type has an aspect
@@ -2262,6 +2255,11 @@ package Einfo is
-- is relocated to the corresponding package body, which must have a
-- corresponding nonlimited with_clause.
+-- Incomplete_View
+-- Defined in all entities. Present in those that are completions of
+-- incomplete types. Denotes the corresponding incomplete view declared
+-- by the incomplete declaration.
+
-- Indirect_Call_Wrapper
-- Defined on subprogram entities. Set if the subprogram has class-wide
-- preconditions. Denotes the internal wrapper that checks preconditions
@@ -2967,6 +2965,11 @@ package Einfo is
-- fully constructed, since it simply indicates the last state.
-- Thus this flag has no meaning to the backend.
+-- Is_Large_Unconstrained_Definite
+-- Defined in record types. Used to detect types with default
+-- discriminant values that have exaggerated sizes and emit warnings
+-- about them.
+
-- Is_Limited_Composite
-- Defined in all entities. Set for composite types that have a limited
-- component. Used to enforce the rule that operations on the composite
@@ -3638,7 +3641,7 @@ package Einfo is
-- subprogram or the formal's Extra_Accessibility - whichever one is
-- lesser. The Minimum_Accessibility field then points to this object.
--- Modulus [base type only]
+-- Modulus [implementation base type only]
-- Defined in modular types. Contains the modulus. For the binary case,
-- this will be a power of 2, but if Non_Binary_Modulus is set, then it
-- will not be a power of 2.
@@ -3658,11 +3661,6 @@ package Einfo is
-- preelaborable initialization at freeze time (this has to be deferred
-- to the freeze point because of the rule about overriding Initialize).
--- Needs_Activation_Record
--- Defined on generated subprogram types. Indicates that a call through
--- a named or anonymous access to subprogram requires an activation
--- record when compiling with unnesting for C or LLVM.
-
-- Needs_Debug_Info
-- Defined in all entities. Set if the entity requires normal debugging
-- information to be generated. This is true of all entities that have
@@ -3904,7 +3902,7 @@ package Einfo is
-- Defined in E_Access_Subprogram_Type entities. Set only if the access
-- type was generated by the expander as part of processing an access-
-- to-protected-subprogram type. Points to the access-to-protected-
--- subprogram type.
+-- subprogram type. Read by CodePeer.
-- Original_Array_Type
-- Defined in modular types and array types and subtypes. Set only if
@@ -3939,17 +3937,12 @@ package Einfo is
-- Points to the component in the base type.
-- Overlays_Constant
--- Defined in all entities. Set only for E_Constant or E_Variable for
--- which there is an address clause that causes the entity to overlay
--- a constant object.
+-- Defined in constants and variables. Set if there is an address clause
+-- that causes the entity to overlay a constant object.
-- Overridden_Operation
-- Defined in subprograms. For overriding operations, points to the
--- user-defined parent subprogram that is being overridden. Note: this
--- attribute uses the same field as Static_Initialization. The latter
--- is only defined for internal initialization procedures, for which
--- Overridden_Operation is irrelevant. Thus this attribute must not be
--- set for init_procs.
+-- user-defined parent subprogram that is being overridden.
-- Package_Instantiation
-- Defined in packages and generic packages. When defined, this field
@@ -4176,14 +4169,6 @@ package Einfo is
-- refine the state, in other words, all the hidden states that appear in
-- the constituent_list of aspect/pragma Refined_State.
--- Register_Exception_Call
--- Defined in exception entities. When an exception is declared,
--- a call is expanded to Register_Exception. This field points to
--- the expanded N_Procedure_Call_Statement node for this call. It
--- is used for Import/Export_Exception processing to modify the
--- register call to make appropriate entries in the special tables
--- used for handling these pragmas at run time.
-
-- Related_Array_Object
-- Defined in array types and subtypes. Used only for the base type
-- and subtype created for an anonymous array object. Set to point
@@ -4383,11 +4368,6 @@ package Einfo is
-- set, in which case this is the entity for the associated instance of
-- System.Shared_Storage.Shared_Var_Procs. See Exp_Smem for full details.
--- Size_Check_Code
--- Defined in constants and variables. Normally Empty. Set if code is
--- generated to check the size of the object. This field is used to
--- suppress this code if a subsequent address clause is encountered.
-
-- Size_Clause (synthesized)
-- Applies to all entities. If a size or value size clause is present in
-- the rep item chain for an entity then that attribute definition clause
@@ -4516,9 +4496,7 @@ package Einfo is
-- initialized statically. The value of this attribute is a positional
-- aggregate whose components are compile-time static values. Used
-- when available in object declarations to eliminate the call to the
--- initialization procedure, and to minimize elaboration code. Note:
--- This attribute uses the same field as Overridden_Operation, which is
--- irrelevant in init_procs.
+-- initialization procedure, and to minimize elaboration code.
-- Static_Real_Or_String_Predicate
-- Defined in real types/subtypes with static predicates (with the two
@@ -4986,7 +4964,6 @@ package Einfo is
-- Materialize_Entity
-- Needs_Debug_Info
-- Never_Set_In_Source
- -- Overlays_Constant
-- Referenced
-- Referenced_As_LHS
-- Referenced_As_Out_Parameter
@@ -5158,10 +5135,9 @@ package Einfo is
-- E_Access_Subprogram_Type
-- Equivalent_Type (remote types only)
-- Directly_Designated_Type
- -- Needs_No_Actuals
-- Original_Access_Type
+ -- Needs_No_Actuals
-- Can_Use_Internal_Rep
- -- Needs_Activation_Record
-- Associated_Storage_Pool $$$
-- Interface_Name $$$
-- (plus type attributes)
@@ -5200,7 +5176,6 @@ package Einfo is
-- Directly_Designated_Type
-- Storage_Size_Variable is this needed ???
-- Can_Use_Internal_Rep
- -- Needs_Activation_Record
-- (plus type attributes)
-- E_Anonymous_Access_Type
@@ -5311,12 +5286,11 @@ package Einfo is
-- Actual_Subtype
-- Renamed_Object
-- Renamed_Entity $$$
- -- Size_Check_Code (constants only)
-- Prival_Link (privals only)
-- Interface_Name (constants only)
-- Related_Type (constants only)
-- Initialization_Statements
- -- BIP_Initialization_Call
+ -- BIP_Initialization_Call (constants only)
-- Finalization_Master_Node
-- Last_Aggregate_Assignment
-- Activation_Record_Component
@@ -5346,6 +5320,7 @@ package Einfo is
-- Is_Volatile_Full_Access
-- Optimize_Alignment_Space (constants only)
-- Optimize_Alignment_Time (constants only)
+ -- Overlays_Constant (constants only)
-- SPARK_Pragma_Inherited (constants only)
-- Stores_Attribute_Old_Prefix (constants only)
-- Treat_As_Volatile
@@ -5472,7 +5447,6 @@ package Einfo is
-- Esize
-- Alignment
-- Renamed_Entity
- -- Register_Exception_Call
-- Interface_Name
-- Activation_Record_Component
-- Discard_Names
@@ -5508,7 +5482,6 @@ package Einfo is
-- E_Function
-- E_Generic_Function
-- Mechanism (Mechanism_Type)
- -- Handler_Records (non-generic case only)
-- Protected_Body_Subprogram
-- Next_Inlined_Subprogram
-- Elaboration_Entity (not implicit /=)
@@ -5662,7 +5635,6 @@ package Einfo is
-- Renamed_Object
-- Spec_Entity
-- Default_Value
- -- Default_Expr_Function
-- Protected_Formal
-- Extra_Constrained
-- Minimum_Accessibility
@@ -5773,8 +5745,6 @@ package Einfo is
-- E_Package
-- E_Generic_Package
- -- Dependent_Instances (for an instance)
- -- Handler_Records (non-generic case only)
-- Generic_Homonym (generic case only)
-- Associated_Formal_Package
-- Elaboration_Entity
@@ -5834,7 +5804,6 @@ package Einfo is
-- Scope_Depth (synth)
-- E_Package_Body
- -- Handler_Records (non-generic case only)
-- Related_Instance (non-generic case only)
-- First_Entity
-- Spec_Entity
@@ -5869,7 +5838,6 @@ package Einfo is
-- E_Procedure
-- E_Generic_Procedure
-- Associated_Node_For_Itype $$$ E_Procedure
- -- Handler_Records (non-generic case only)
-- Protected_Body_Subprogram
-- Next_Inlined_Subprogram
-- Elaboration_Entity
@@ -6197,7 +6165,6 @@ package Einfo is
-- Renamed_Object
-- Renamed_Entity $$$
-- Discriminal_Link $$$
- -- Size_Check_Code
-- Prival_Link
-- Interface_Name
-- Shared_Var_Procs_Instance
@@ -6241,6 +6208,7 @@ package Einfo is
-- OK_To_Rename
-- Optimize_Alignment_Space
-- Optimize_Alignment_Time
+ -- Overlays_Constant
-- SPARK_Pragma_Inherited
-- Suppress_Initialization
-- Treat_As_Volatile
@@ -6269,7 +6237,6 @@ package Einfo is
-- Entry_Formal $$$
-- Esize $$$
-- First_Entity $$$
- -- Handler_Records $$$
-- Interface_Name $$$
-- Last_Entity $$$
-- Renamed_Entity $$$
diff --git a/gcc/ada/diagnostics-repository.adb b/gcc/ada/errid.adb
index f01a2df..a661fcf 100644
--- a/gcc/ada/diagnostics-repository.adb
+++ b/gcc/ada/errid.adb
@@ -22,12 +22,23 @@
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-with Diagnostics.JSON_Utils; use Diagnostics.JSON_Utils;
-with Diagnostics.Utils; use Diagnostics.Utils;
-with Diagnostics.Switch_Repository; use Diagnostics.Switch_Repository;
-with Output; use Output;
+with JSON_Utils; use JSON_Utils;
+with Output; use Output;
-package body Diagnostics.Repository is
+package body Errid is
+
+ ---------------
+ -- To_String --
+ ---------------
+
+ function To_String (Id : Diagnostic_Id) return String is
+ begin
+ if Id = No_Diagnostic_Id then
+ return "GNAT0000";
+ else
+ return Id'Img;
+ end if;
+ end To_String;
---------------------------------
-- Print_Diagnostic_Repository --
@@ -119,4 +130,4 @@ package body Diagnostics.Repository is
Write_Eol;
end Print_Diagnostic_Repository;
-end Diagnostics.Repository;
+end Errid;
diff --git a/gcc/ada/diagnostics-repository.ads b/gcc/ada/errid.ads
index 778c991..21ef79c 100644
--- a/gcc/ada/diagnostics-repository.ads
+++ b/gcc/ada/errid.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2025, Free Software Foundation, Inc. --
+-- Copyright (C) 19925, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -22,7 +22,40 @@
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-package Diagnostics.Repository is
+with Types; use Types;
+with Errsw; use Errsw;
+
+package Errid is
+
+ type Status_Type is
+ (Active,
+ Deprecated);
+
+ type Diagnostic_Id is
+ (No_Diagnostic_Id,
+ GNAT0001,
+ GNAT0002,
+ GNAT0003,
+ GNAT0004,
+ GNAT0005,
+ GNAT0006);
+
+ function To_String (Id : Diagnostic_Id) return String;
+ -- Convert the diagnostic ID to a 4 character string padded with 0-s.
+
+ type Diagnostic_Entry_Type is record
+ Status : Status_Type := Active;
+
+ Human_Id : String_Ptr := null;
+ -- A human readable code for the diagnostic. If the diagnostic has a
+ -- switch with a human id then the human_id of the switch shall be used
+ -- in SARIF reports.
+
+ Documentation : String_Ptr := null;
+
+ Switch : Switch_Id := No_Switch_Id;
+ -- The switch that controls the diagnostic message.
+ end record;
type Diagnostics_Registry_Type is
array (Diagnostic_Id) of Diagnostic_Entry_Type;
@@ -53,56 +86,26 @@ package Diagnostics.Repository is
GNAT0002 =>
(Status => Active,
Human_Id =>
- new String'("Invalid_Operand_Types_For_Operator_Error"),
- Documentation => new String'("./error_codes/GNAT0002.md"),
- Switch => No_Switch_Id),
- GNAT0003 =>
- (Status => Active,
- Human_Id =>
- new String'("Invalid_Operand_Types_Left_To_Int_Error"),
- Documentation => new String'("./error_codes/GNAT0003.md"),
- Switch => No_Switch_Id),
- GNAT0004 =>
- (Status => Active,
- Human_Id =>
- new String'("Invalid_Operand_Types_Right_To_Int_Error"),
- Documentation => new String'("./error_codes/GNAT0004.md"),
- Switch => No_Switch_Id),
- GNAT0005 =>
- (Status => Active,
- Human_Id =>
- new String'("Invalid_Operand_Types_Left_Acc_Error"),
- Documentation => new String'("./error_codes/GNAT0005.md"),
- Switch => No_Switch_Id),
- GNAT0006 =>
- (Status => Active,
- Human_Id =>
- new String'("Invalid_Operand_Types_Right_Acc_Error"),
- Documentation => new String'("./error_codes/GNAT0006.md"),
- Switch => No_Switch_Id),
- GNAT0007 =>
- (Status => Active,
- Human_Id =>
new String'("Invalid_Operand_Types_General_Error"),
Documentation => new String'("./error_codes/GNAT0007.md"),
Switch => No_Switch_Id),
- GNAT0008 =>
+ GNAT0003 =>
(Status => Active,
Human_Id =>
new String'("Pragma_No_Effect_With_Lock_Free_Warning"),
Documentation => new String'("./error_codes/GNAT0008.md"),
Switch => No_Switch_Id),
- GNAT0009 =>
+ GNAT0004 =>
(Status => Active,
Human_Id => new String'("End_Loop_Expected_Error"),
Documentation => new String'("./error_codes/GNAT0009.md"),
Switch => No_Switch_Id),
- GNAT0010 =>
+ GNAT0005 =>
(Status => Active,
Human_Id => new String'("Representation_Too_Late_Error"),
Documentation => new String'("./error_codes/GNAT0010.md"),
Switch => No_Switch_Id),
- GNAT0011 =>
+ GNAT0006 =>
(Status => Active,
Human_Id => new String'("Mixed_Container_Aggregate_Error"),
Documentation => new String'("./error_codes/GNAT0011.md"),
@@ -110,4 +113,4 @@ package Diagnostics.Repository is
procedure Print_Diagnostic_Repository;
-end Diagnostics.Repository;
+end Errid;
diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb
index 23c6b88..472fbbe 100644
--- a/gcc/ada/errout.adb
+++ b/gcc/ada/errout.adb
@@ -33,11 +33,13 @@ with Atree; use Atree;
with Casing; use Casing;
with Csets; use Csets;
with Debug; use Debug;
-with Diagnostics.Converter; use Diagnostics.Converter;
with Einfo; use Einfo;
with Einfo.Entities; use Einfo.Entities;
with Einfo.Utils; use Einfo.Utils;
with Erroutc; use Erroutc;
+with Erroutc.Pretty_Emitter;
+with Erroutc.SARIF_Emitter;
+with Errsw; use Errsw;
with Gnatvsn; use Gnatvsn;
with Lib; use Lib;
with Opt; use Opt;
@@ -97,10 +99,14 @@ package body Errout is
-----------------------
procedure Error_Msg_Internal
- (Msg : String;
- Span : Source_Span;
- Opan : Source_Span;
- Msg_Cont : Boolean);
+ (Msg : String;
+ Span : Source_Span;
+ Opan : Source_Span;
+ Msg_Cont : Boolean;
+ Error_Code : Diagnostic_Id := No_Diagnostic_Id;
+ Label : String := "";
+ Spans : Labeled_Span_Array := No_Locations;
+ Fixes : Fix_Array := No_Fixes);
-- This is the low-level routine used to post messages after dealing with
-- the issue of messages placed on instantiations (which get broken up
-- into separate calls in Error_Msg). Span is the location on which the
@@ -271,11 +277,7 @@ package body Errout is
begin
if not M.Deleted then
M.Deleted := True;
- Warnings_Detected := Warnings_Detected - 1;
-
- if M.Warn_Err then
- Warnings_Treated_As_Errors := Warnings_Treated_As_Errors - 1;
- end if;
+ Decrease_Error_Msg_Count (M);
end if;
Id := M.Next;
@@ -285,6 +287,115 @@ package body Errout is
end loop;
end Delete_Warning_And_Continuations;
+ ------------------
+ -- Labeled_Span --
+ ------------------
+
+ function Labeled_Span
+ (Span : Source_Span;
+ Label : String := "";
+ Is_Primary : Boolean := True;
+ Is_Region : Boolean := False)
+ return Labeled_Span_Type
+ is
+ L : Labeled_Span_Type;
+ begin
+ L.Span := Span;
+ if Label /= "" then
+ L.Label := new String'(Label);
+ end if;
+ L.Is_Primary := Is_Primary;
+ L.Is_Region := Is_Region;
+ L.Next := No_Labeled_Span;
+
+ return L;
+ end Labeled_Span;
+
+ --------------------------
+ -- Primary_Labeled_Span --
+ --------------------------
+
+ function Primary_Labeled_Span
+ (Span : Source_Span;
+ Label : String := "") return Labeled_Span_Type
+ is
+ begin
+ return Labeled_Span (Span => Span, Label => Label, Is_Primary => True);
+ end Primary_Labeled_Span;
+
+ --------------------------
+ -- Primary_Labeled_Span --
+ --------------------------
+
+ function Primary_Labeled_Span
+ (N : Node_Or_Entity_Id;
+ Label : String := "") return Labeled_Span_Type
+ is
+ begin
+ return Primary_Labeled_Span (To_Full_Span (N), Label);
+ end Primary_Labeled_Span;
+
+ ----------------------------
+ -- Secondary_Labeled_Span --
+ ----------------------------
+
+ function Secondary_Labeled_Span
+ (Span : Source_Span;
+ Label : String := "") return Labeled_Span_Type
+ is
+ begin
+ return Labeled_Span (Span => Span, Label => Label, Is_Primary => False);
+ end Secondary_Labeled_Span;
+
+ ----------------------------
+ -- Secondary_Labeled_Span --
+ ----------------------------
+
+ function Secondary_Labeled_Span
+ (N : Node_Or_Entity_Id;
+ Label : String := "") return Labeled_Span_Type
+ is
+ begin
+ return Secondary_Labeled_Span (To_Full_Span (N), Label);
+ end Secondary_Labeled_Span;
+
+ ----------
+ -- Edit --
+ ----------
+
+ function Edit (Text : String; Span : Source_Span) return Edit_Type is
+ begin
+ return (Text => new String'(Text), Span => Span, Next => No_Edit);
+ end Edit;
+
+ ---------
+ -- Fix --
+ ---------
+
+ function Fix (Description : String; Edits : Edit_Array) return Fix_Type is
+ First_Edit : Edit_Id := No_Edit;
+ Last_Edit : Edit_Id := No_Edit;
+ begin
+ for I in Edits'Range loop
+ Erroutc.Edits.Append (Edits (I));
+
+ if Last_Edit /= No_Edit then
+ Erroutc.Edits.Table (Last_Edit).Next := Erroutc.Edits.Last;
+ end if;
+ Last_Edit := Erroutc.Edits.Last;
+
+ -- Store the first element in the edit chain
+
+ if First_Edit = No_Edit then
+ First_Edit := Last_Edit;
+ end if;
+ end loop;
+
+ return (Description => new String'(Description),
+ Edits => First_Edit,
+ Next => No_Fix);
+ end Fix;
+
---------------
-- Error_Msg --
---------------
@@ -328,9 +439,13 @@ package body Errout is
end Error_Msg;
procedure Error_Msg
- (Msg : String;
- Flag_Span : Source_Span;
- N : Node_Id)
+ (Msg : String;
+ Flag_Span : Source_Span;
+ N : Node_Id;
+ Error_Code : Diagnostic_Id := No_Diagnostic_Id;
+ Label : String := "";
+ Spans : Labeled_Span_Array := No_Locations;
+ Fixes : Fix_Array := No_Fixes)
is
Flag_Location : constant Source_Ptr := Flag_Span.Ptr;
@@ -459,7 +574,15 @@ package body Errout is
-- Error_Msg_Internal to place the message in the requested location.
if Instantiation (Sindex) = No_Location then
- Error_Msg_Internal (Msg, Flag_Span, Flag_Span, False);
+ Error_Msg_Internal
+ (Msg => Msg,
+ Span => Flag_Span,
+ Opan => Flag_Span,
+ Msg_Cont => False,
+ Error_Code => Error_Code,
+ Label => Label,
+ Spans => Spans,
+ Fixes => Fixes);
return;
end if;
@@ -626,10 +749,14 @@ package body Errout is
-- Here we output the original message on the outer instantiation
Error_Msg_Internal
- (Msg => Msg,
- Span => To_Span (Actual_Error_Loc),
- Opan => Flag_Span,
- Msg_Cont => Msg_Cont_Status);
+ (Msg => Msg,
+ Span => To_Span (Actual_Error_Loc),
+ Opan => Flag_Span,
+ Msg_Cont => Msg_Cont_Status,
+ Error_Code => Error_Code,
+ Label => Label,
+ Spans => Spans,
+ Fixes => Fixes);
end;
end Error_Msg;
@@ -715,7 +842,7 @@ package body Errout is
-- error flag in this situation.
S1 := Prev_Token_Ptr;
- C := Source (S1);
+ C := Sinput.Source (S1);
-- If the previous token is a string literal, we need a special approach
-- since there may be white space inside the literal and we don't want
@@ -728,10 +855,10 @@ package body Errout is
loop
S1 := S1 + 1;
- if Source (S1) = C then
+ if Sinput.Source (S1) = C then
S1 := S1 + 1;
- exit when Source (S1) /= C;
- elsif Source (S1) in Line_Terminator then
+ exit when Sinput.Source (S1) /= C;
+ elsif Sinput.Source (S1) in Line_Terminator then
exit;
end if;
end loop;
@@ -749,10 +876,11 @@ package body Errout is
-- characters in this context, since this is only for error recovery.
else
- while Source (S1) not in Line_Terminator
- and then Source (S1) /= ' '
- and then Source (S1) /= ASCII.HT
- and then (Source (S1) /= '-' or else Source (S1 + 1) /= '-')
+ while Sinput.Source (S1) not in Line_Terminator
+ and then Sinput.Source (S1) /= ' '
+ and then Sinput.Source (S1) /= ASCII.HT
+ and then (Sinput.Source (S1) /= '-'
+ or else Sinput.Source (S1 + 1) /= '-')
and then S1 /= Token_Ptr
loop
S1 := S1 + 1;
@@ -785,8 +913,8 @@ package body Errout is
-- we would really like to place it in the "last" character of the tab
-- space, but that it too much trouble to worry about).
- elsif Source (Token_Ptr - 1) = ' '
- or else Source (Token_Ptr - 1) = ASCII.HT
+ elsif Sinput.Source (Token_Ptr - 1) = ' '
+ or else Sinput.Source (Token_Ptr - 1) = ASCII.HT
then
Error_Msg (Msg, Token_Ptr - 1);
@@ -842,13 +970,8 @@ package body Errout is
-----------------
procedure Error_Msg_F (Msg : String; N : Node_Id) is
- Fst, Lst : Node_Id;
begin
- First_And_Last_Nodes (N, Fst, Lst);
- Error_Msg_NEL (Msg, N, N,
- To_Span (Ptr => Sloc (Fst),
- First => First_Sloc (Fst),
- Last => Last_Sloc (Lst)));
+ Error_Msg_NEL (Msg, N, N, To_Full_Span_First (N));
end Error_Msg_F;
------------------
@@ -860,13 +983,8 @@ package body Errout is
N : Node_Id;
E : Node_Or_Entity_Id)
is
- Fst, Lst : Node_Id;
begin
- First_And_Last_Nodes (N, Fst, Lst);
- Error_Msg_NEL (Msg, N, E,
- To_Span (Ptr => Sloc (Fst),
- First => First_Sloc (Fst),
- Last => Last_Sloc (Lst)));
+ Error_Msg_NEL (Msg, N, E, To_Full_Span_First (N));
end Error_Msg_FE;
------------------------------
@@ -918,10 +1036,14 @@ package body Errout is
------------------------
procedure Error_Msg_Internal
- (Msg : String;
- Span : Source_Span;
- Opan : Source_Span;
- Msg_Cont : Boolean)
+ (Msg : String;
+ Span : Source_Span;
+ Opan : Source_Span;
+ Msg_Cont : Boolean;
+ Error_Code : Diagnostic_Id := No_Diagnostic_Id;
+ Label : String := "";
+ Spans : Labeled_Span_Array := No_Locations;
+ Fixes : Fix_Array := No_Fixes)
is
Sptr : constant Source_Ptr := Span.Ptr;
Optr : constant Source_Ptr := Opan.Ptr;
@@ -934,8 +1056,11 @@ package body Errout is
Temp_Msg : Error_Msg_Id;
- Warn_Err : Boolean;
- -- Set if warning to be treated as error
+ First_Fix : Fix_Id := No_Fix;
+ Last_Fix : Fix_Id := No_Fix;
+
+ Primary_Loc : Labeled_Span_Id := No_Labeled_Span;
+ Last_Loc : Labeled_Span_Id := No_Labeled_Span;
procedure Handle_Serious_Error;
-- Internal procedure to do all error message handling for a serious
@@ -1156,11 +1281,15 @@ package body Errout is
-- Remove (style) or info: at start of message
- if Msglen > 8 and then Msg_Buffer (1 .. 8) = "(style) " then
- M := 9;
+ if Msglen > Style_Prefix'Length
+ and then Msg_Buffer (1 .. Style_Prefix'Length) = Style_Prefix
+ then
+ M := Style_Prefix'Length + 1;
- elsif Msglen > 6 and then Msg_Buffer (1 .. 6) = "info: " then
- M := 7;
+ elsif Msglen > Info_Prefix'Length
+ and then Msg_Buffer (1 .. Info_Prefix'Length) = Info_Prefix
+ then
+ M := Info_Prefix'Length + 1;
else
M := 1;
@@ -1226,6 +1355,37 @@ package body Errout is
return;
end if;
+ if Continuation and then Has_Insertion_Line then
+ Erroutc.Locations.Append
+ (Primary_Labeled_Span (To_Span (Error_Msg_Sloc), Label));
+ else
+ Erroutc.Locations.Append (Primary_Labeled_Span (Span, Label));
+ end if;
+
+ Primary_Loc := Erroutc.Locations.Last;
+
+ Last_Loc := Primary_Loc;
+
+ for Span of Spans loop
+ Erroutc.Locations.Append (Span);
+ Erroutc.Locations.Table (Last_Loc).Next := Erroutc.Locations.Last;
+ Last_Loc := Erroutc.Locations.Last;
+ end loop;
+
+ for Fix of Fixes loop
+ Erroutc.Fixes.Append (Fix);
+ if Last_Fix /= No_Fix then
+ Erroutc.Fixes.Table (Last_Fix).Next := Erroutc.Fixes.Last;
+ end if;
+ Last_Fix := Erroutc.Fixes.Last;
+
+ -- Store the first element in the fix chain
+
+ if First_Fix = No_Fix then
+ First_Fix := Last_Fix;
+ end if;
+ end loop;
+
-- Here we build a new error object
Errors.Append
@@ -1240,29 +1400,38 @@ package body Errout is
Line => Get_Physical_Line_Number (Sptr),
Col => Get_Column_Number (Sptr),
Compile_Time_Pragma => Is_Compile_Time_Msg,
- Warn_Err => False, -- reset below
+ Warn_Err => None, -- reset below
Warn_Chr => Warning_Msg_Char,
Uncond => Is_Unconditional_Msg,
Msg_Cont => Continuation,
Deleted => False,
- Kind => Error_Msg_Kind));
+ Kind => Error_Msg_Kind,
+ Locations => Primary_Loc,
+ Id => Error_Code,
+ Switch =>
+ Get_Switch_Id (Error_Msg_Kind, Warning_Msg_Char),
+ Fixes => First_Fix));
Cur_Msg := Errors.Last;
- -- Test if warning to be treated as error
-
- Warn_Err :=
- Error_Msg_Kind in Warning | Style
- and then (Warning_Treated_As_Error (Msg_Buffer (1 .. Msglen))
- or else Warning_Treated_As_Error (Get_Warning_Tag (Cur_Msg))
- or else Is_Runtime_Raise);
-
- -- Propagate Warn_Err to this message and preceding continuations.
-
- for J in reverse 1 .. Errors.Last loop
- Errors.Table (J).Warn_Err := Warn_Err;
-
- exit when not Errors.Table (J).Msg_Cont;
- end loop;
+ -- Test if a warning is to be treated as error:
+ -- * It is marked by a pragma Warning_As_Error
+ -- * Warning_Mode is Treat_Run_Time_Warnings_As_Errors and we are
+ -- dealing with a runtime warning.
+ -- * Warning_Mode is Warnings_As_Errors and it is not a compile time
+ -- message.
+
+ if Error_Msg_Kind in Warning | Style then
+ if Warning_Treated_As_Error (Errors.Table (Cur_Msg)) then
+ Errors.Table (Cur_Msg).Warn_Err := From_Pragma;
+ elsif Warning_Mode = Treat_Run_Time_Warnings_As_Errors
+ and then Is_Runtime_Raise_Msg
+ then
+ Errors.Table (Cur_Msg).Warn_Err := From_Run_Time_As_Err;
+ elsif Warning_Mode = Treat_As_Error and then not Is_Compile_Time_Msg
+ then
+ Errors.Table (Cur_Msg).Warn_Err := From_Warn_As_Err;
+ end if;
+ end if;
-- If immediate errors mode set, output error message now. Also output
-- now if the -d1 debug flag is set (so node number message comes out
@@ -1416,33 +1585,72 @@ package body Errout is
-- Error_Msg_N --
-----------------
- procedure Error_Msg_N (Msg : String; N : Node_Or_Entity_Id) is
- Fst, Lst : Node_Id;
+ procedure Error_Msg_N
+ (Msg : String;
+ N : Node_Or_Entity_Id;
+ Error_Code : Diagnostic_Id := No_Diagnostic_Id;
+ Label : String := "";
+ Spans : Labeled_Span_Array := No_Locations;
+ Fixes : Fix_Array := No_Fixes)
+ is
begin
- First_And_Last_Nodes (N, Fst, Lst);
- Error_Msg_NEL (Msg, N, N,
- To_Span (Ptr => Sloc (N),
- First => First_Sloc (Fst),
- Last => Last_Sloc (Lst)));
+ Error_Msg_NEL
+ (Msg => Msg,
+ N => N,
+ E => N,
+ Flag_Span => To_Full_Span (N),
+ Error_Code => Error_Code,
+ Label => Label,
+ Spans => Spans,
+ Fixes => Fixes);
end Error_Msg_N;
+ ----------------------
+ -- Error_Msg_N_Gigi --
+ ----------------------
+
+ procedure Error_Msg_N_Gigi (Msg : String; N : Node_Or_Entity_Id) is
+ begin
+ Error_Msg_N (Msg, N);
+ end Error_Msg_N_Gigi;
+
------------------
-- Error_Msg_NE --
------------------
procedure Error_Msg_NE
+ (Msg : String;
+ N : Node_Or_Entity_Id;
+ E : Node_Or_Entity_Id;
+ Error_Code : Diagnostic_Id := No_Diagnostic_Id;
+ Label : String := "";
+ Spans : Labeled_Span_Array := No_Locations;
+ Fixes : Fix_Array := No_Fixes)
+ is
+ begin
+ Error_Msg_NEL
+ (Msg => Msg,
+ N => N,
+ E => E,
+ Flag_Span => To_Full_Span (N),
+ Error_Code => Error_Code,
+ Label => Label,
+ Spans => Spans,
+ Fixes => Fixes);
+ end Error_Msg_NE;
+
+ -----------------------
+ -- Error_Msg_NE_Gigi --
+ -----------------------
+
+ procedure Error_Msg_NE_Gigi
(Msg : String;
N : Node_Or_Entity_Id;
E : Node_Or_Entity_Id)
is
- Fst, Lst : Node_Id;
begin
- First_And_Last_Nodes (N, Fst, Lst);
- Error_Msg_NEL (Msg, N, E,
- To_Span (Ptr => Sloc (N),
- First => First_Sloc (Fst),
- Last => Last_Sloc (Lst)));
- end Error_Msg_NE;
+ Error_Msg_NE (Msg, N, E);
+ end Error_Msg_NE_Gigi;
-------------------
-- Error_Msg_NEL --
@@ -1465,10 +1673,14 @@ package body Errout is
end Error_Msg_NEL;
procedure Error_Msg_NEL
- (Msg : String;
- N : Node_Or_Entity_Id;
- E : Node_Or_Entity_Id;
- Flag_Span : Source_Span)
+ (Msg : String;
+ N : Node_Or_Entity_Id;
+ E : Node_Or_Entity_Id;
+ Flag_Span : Source_Span;
+ Error_Code : Diagnostic_Id := No_Diagnostic_Id;
+ Label : String := "";
+ Spans : Labeled_Span_Array := No_Locations;
+ Fixes : Fix_Array := No_Fixes)
is
begin
if Special_Msg_Delete (Msg, N, E) then
@@ -1502,7 +1714,14 @@ package body Errout is
then
Debug_Output (N);
Error_Msg_Node_1 := E;
- Error_Msg (Msg, Flag_Span, N);
+ Error_Msg
+ (Msg => Msg,
+ Flag_Span => Flag_Span,
+ N => N,
+ Error_Code => Error_Code,
+ Label => Label,
+ Spans => Spans,
+ Fixes => Fixes);
else
Last_Killed := True;
@@ -1522,17 +1741,12 @@ package body Errout is
Msg : String;
N : Node_Or_Entity_Id)
is
- Fst, Lst : Node_Id;
begin
if Eflag
and then In_Extended_Main_Source_Unit (N)
and then Comes_From_Source (N)
then
- First_And_Last_Nodes (N, Fst, Lst);
- Error_Msg_NEL (Msg, N, N,
- To_Span (Ptr => Sloc (N),
- First => First_Sloc (Fst),
- Last => Last_Sloc (Lst)));
+ Error_Msg_NEL (Msg, N, N, To_Full_Span (N));
end if;
end Error_Msg_NW;
@@ -1597,7 +1811,7 @@ package body Errout is
begin
if not Errors.Table (E).Deleted then
Errors.Table (E).Deleted := True;
- Warnings_Detected := Warnings_Detected - 1;
+ Decrease_Error_Msg_Count (Errors.Table (E));
end if;
end Delete_Warning;
@@ -2425,7 +2639,8 @@ package body Errout is
Write_Str ("{""kind"":");
- if Errors.Table (E).Kind = Warning and then not Errors.Table (E).Warn_Err
+ if Errors.Table (E).Kind = Warning
+ and then Errors.Table (E).Warn_Err = None
then
Write_Str ("""warning""");
elsif Errors.Table (E).Kind in
@@ -2457,9 +2672,13 @@ package body Errout is
Write_Str (",""option"":""" & Option & """");
end if;
- -- Print message content
+ -- Print message content and ensure that the removed style prefix is
+ -- still in the message.
Write_Str (",""message"":""");
+ if Errors.Table (E).Kind = Style then
+ Write_JSON_Escaped_String (Style_Prefix);
+ end if;
Write_JSON_Escaped_String (Errors.Table (E).Text);
Write_Str ("""");
@@ -2488,7 +2707,7 @@ package body Errout is
-- Output_Messages --
---------------------
- procedure Output_Messages is
+ procedure Output_Messages (Exit_Code : Exit_Code_Type) is
-- Local subprograms
@@ -2502,109 +2721,21 @@ package body Errout is
procedure Write_Max_Errors;
-- Write message if max errors reached
- procedure Write_Source_Code_Lines
- (Span : Source_Span;
- SGR_Span : String);
- -- Write the source code line corresponding to Span, as follows when
- -- Span in on one line:
- --
- -- line | actual code line here with Span somewhere
- -- | ~~~~~^~~~
- --
- -- where the caret on the line points to location Span.Ptr, and the
- -- range Span.First..Span.Last is underlined.
- --
- -- or when the span is over multiple lines:
- --
- -- line | beginning of the Span on this line
- -- ... | ...
- -- line>| actual code line here with Span.Ptr somewhere
- -- ... | ...
- -- line | end of the Span on this line
- --
- -- or when the span is a simple location, as follows:
- --
- -- line | actual code line here with Span somewhere
- -- | ^ here
- --
- -- where the caret on the line points to location Span.Ptr
- --
- -- SGR_Span is the SGR string to start the section of code in the span,
- -- that should be closed with SGR_Reset.
-
--------------------
-- Emit_Error_Msgs --
---------------------
procedure Emit_Error_Msgs is
- Use_Prefix : Boolean;
- E : Error_Msg_Id;
+ E : Error_Msg_Id;
begin
Set_Standard_Error;
E := First_Error_Msg;
while E /= No_Error_Msg loop
-
- -- If -gnatdF is used, separate main messages from previous
- -- messages with a newline (unless it is an info message) and
- -- make continuation messages follow the main message with only
- -- an indentation of two space characters, without repeating
- -- file:line:col: prefix.
-
- Use_Prefix :=
- not (Debug_Flag_FF and then Errors.Table (E).Msg_Cont);
-
if not Errors.Table (E).Deleted then
-
- if Debug_Flag_FF then
- if Errors.Table (E).Msg_Cont then
- Write_Str (" ");
- elsif Errors.Table (E).Kind /= Info then
- Write_Eol;
- end if;
- end if;
-
- if Use_Prefix then
- Output_Msg_Location (E);
- end if;
-
+ Output_Msg_Location (E);
Output_Msg_Text (E);
Write_Eol;
-
- -- If -gnatdF is used, write the source code line
- -- corresponding to the location of the main message (unless
- -- it is an info message). Also write the source code line
- -- corresponding to an insertion location inside
- -- continuation messages.
-
- if Debug_Flag_FF
- and then Errors.Table (E).Kind /= Info
- then
- if Errors.Table (E).Msg_Cont then
- declare
- Loc : constant Source_Ptr :=
- Errors.Table (E).Insertion_Sloc;
- begin
- if Loc /= No_Location then
- Write_Source_Code_Lines
- (To_Span (Loc), SGR_Span => SGR_Note);
- end if;
- end;
-
- else
- declare
- SGR_Span : constant String :=
- (if Errors.Table (E).Kind = Info then SGR_Note
- elsif Errors.Table (E).Kind = Warning
- and then not Errors.Table (E).Warn_Err
- then SGR_Warning
- else SGR_Error);
- begin
- Write_Source_Code_Lines
- (Errors.Table (E).Optr, SGR_Span);
- end;
- end if;
- end if;
end if;
E := Errors.Table (E).Next;
@@ -2664,310 +2795,18 @@ package body Errout is
end if;
end Write_Max_Errors;
- -----------------------------
- -- Write_Source_Code_Lines --
- -----------------------------
-
- procedure Write_Source_Code_Lines
- (Span : Source_Span;
- SGR_Span : String)
- is
- function Get_Line_End
- (Buf : Source_Buffer_Ptr;
- Loc : Source_Ptr) return Source_Ptr;
- -- Get the source location for the end of the line in Buf for Loc. If
- -- Loc is past the end of Buf already, return Buf'Last.
-
- function Get_Line_Start
- (Buf : Source_Buffer_Ptr;
- Loc : Source_Ptr) return Source_Ptr;
- -- Get the source location for the start of the line in Buf for Loc
-
- function Image (X : Positive; Width : Positive) return String;
- -- Output number X over Width characters, with whitespace padding.
- -- Only output the low-order Width digits of X, if X is larger than
- -- Width digits.
-
- procedure Write_Buffer
- (Buf : Source_Buffer_Ptr;
- First : Source_Ptr;
- Last : Source_Ptr);
- -- Output the characters from First to Last position in Buf, using
- -- Write_Buffer_Char.
-
- procedure Write_Buffer_Char
- (Buf : Source_Buffer_Ptr;
- Loc : Source_Ptr);
- -- Output the characters at position Loc in Buf, translating ASCII.HT
- -- in a suitable number of spaces so that the output is not modified
- -- by starting in a different column that 1.
-
- procedure Write_Line_Marker
- (Num : Pos;
- Mark : Boolean;
- Width : Positive);
- -- Output the line number Num over Width characters, with possibly
- -- a Mark to denote the line with the main location when reporting
- -- a span over multiple lines.
-
- ------------------
- -- Get_Line_End --
- ------------------
-
- function Get_Line_End
- (Buf : Source_Buffer_Ptr;
- Loc : Source_Ptr) return Source_Ptr
- is
- Cur_Loc : Source_Ptr := Source_Ptr'Min (Loc, Buf'Last);
- begin
- while Cur_Loc < Buf'Last
- and then Buf (Cur_Loc) /= ASCII.LF
- loop
- Cur_Loc := Cur_Loc + 1;
- end loop;
-
- return Cur_Loc;
- end Get_Line_End;
-
- --------------------
- -- Get_Line_Start --
- --------------------
-
- function Get_Line_Start
- (Buf : Source_Buffer_Ptr;
- Loc : Source_Ptr) return Source_Ptr
- is
- Cur_Loc : Source_Ptr := Loc;
- begin
- while Cur_Loc > Buf'First
- and then Buf (Cur_Loc - 1) /= ASCII.LF
- loop
- Cur_Loc := Cur_Loc - 1;
- end loop;
-
- return Cur_Loc;
- end Get_Line_Start;
-
- -----------
- -- Image --
- -----------
-
- function Image (X : Positive; Width : Positive) return String is
- Str : String (1 .. Width);
- Curr : Natural := X;
- begin
- for J in reverse 1 .. Width loop
- if Curr > 0 then
- Str (J) := Character'Val (Character'Pos ('0') + Curr mod 10);
- Curr := Curr / 10;
- else
- Str (J) := ' ';
- end if;
- end loop;
-
- return Str;
- end Image;
-
- ------------------
- -- Write_Buffer --
- ------------------
-
- procedure Write_Buffer
- (Buf : Source_Buffer_Ptr;
- First : Source_Ptr;
- Last : Source_Ptr)
- is
- begin
- for Loc in First .. Last loop
- Write_Buffer_Char (Buf, Loc);
- end loop;
- end Write_Buffer;
-
- -----------------------
- -- Write_Buffer_Char --
- -----------------------
-
- procedure Write_Buffer_Char
- (Buf : Source_Buffer_Ptr;
- Loc : Source_Ptr)
- is
- begin
- -- If the character ASCII.HT is not the last one in the file,
- -- output as many spaces as the character represents in the
- -- original source file.
-
- if Buf (Loc) = ASCII.HT
- and then Loc < Buf'Last
- then
- for X in Get_Column_Number (Loc) ..
- Get_Column_Number (Loc + 1) - 1
- loop
- Write_Char (' ');
- end loop;
-
- -- Otherwise output the character itself
-
- else
- Write_Char (Buf (Loc));
- end if;
- end Write_Buffer_Char;
-
- -----------------------
- -- Write_Line_Marker --
- -----------------------
-
- procedure Write_Line_Marker
- (Num : Pos;
- Mark : Boolean;
- Width : Positive)
- is
- begin
- Write_Str (Image (Positive (Num), Width => Width));
- Write_Str ((if Mark then ">" else " ") & "|");
- end Write_Line_Marker;
-
- -- Local variables
-
- Loc : constant Source_Ptr := Span.Ptr;
- Line : constant Pos := Pos (Get_Physical_Line_Number (Loc));
-
- Col : constant Natural := Natural (Get_Column_Number (Loc));
-
- Fst : constant Source_Ptr := Span.First;
- Line_Fst : constant Pos :=
- Pos (Get_Physical_Line_Number (Fst));
- Col_Fst : constant Natural :=
- Natural (Get_Column_Number (Fst));
- Lst : constant Source_Ptr := Span.Last;
- Line_Lst : constant Pos :=
- Pos (Get_Physical_Line_Number (Lst));
- Col_Lst : constant Natural :=
- Natural (Get_Column_Number (Lst));
-
- Width : constant := 5;
- Buf : Source_Buffer_Ptr;
- Cur_Loc : Source_Ptr := Fst;
- Cur_Line : Pos := Line_Fst;
-
- -- Start of processing for Write_Source_Code_Lines
-
- begin
- if Loc >= First_Source_Ptr then
- Buf := Source_Text (Get_Source_File_Index (Loc));
-
- -- First line of the span with actual source code. We retrieve
- -- the beginning of the line instead of relying on Col_Fst, as
- -- ASCII.HT characters change column numbers by possibly more
- -- than one.
-
- Write_Line_Marker
- (Cur_Line,
- Line_Fst /= Line_Lst and then Cur_Line = Line,
- Width);
- Write_Buffer (Buf, Get_Line_Start (Buf, Cur_Loc), Cur_Loc - 1);
-
- -- Output the first/caret/last lines of the span, as well as
- -- lines that are directly above/below the caret if they complete
- -- the gap with first/last lines, otherwise use ... to denote
- -- intermediate lines.
-
- -- If the span is on one line and not a simple source location,
- -- color it appropriately.
-
- if Line_Fst = Line_Lst
- and then Col_Fst /= Col_Lst
- then
- Write_Str (SGR_Span);
- end if;
-
- declare
- function Do_Write_Line (Cur_Line : Pos) return Boolean is
- (Cur_Line in Line_Fst | Line | Line_Lst
- or else
- (Cur_Line = Line_Fst + 1 and then Cur_Line = Line - 1)
- or else
- (Cur_Line = Line + 1 and then Cur_Line = Line_Lst - 1));
- begin
- while Cur_Loc <= Buf'Last
- and then Cur_Loc <= Lst
- loop
- if Do_Write_Line (Cur_Line) then
- Write_Buffer_Char (Buf, Cur_Loc);
- end if;
-
- if Buf (Cur_Loc) = ASCII.LF then
- Cur_Line := Cur_Line + 1;
-
- -- Output ... for skipped lines
-
- if (Cur_Line = Line
- and then not Do_Write_Line (Cur_Line - 1))
- or else
- (Cur_Line = Line + 1
- and then not Do_Write_Line (Cur_Line))
- then
- Write_Str ((1 .. Width - 3 => ' ') & "... | ...");
- Write_Eol;
- end if;
-
- -- Display the line marker if the line should be
- -- displayed.
-
- if Do_Write_Line (Cur_Line) then
- Write_Line_Marker
- (Cur_Line,
- Line_Fst /= Line_Lst and then Cur_Line = Line,
- Width);
- end if;
- end if;
-
- Cur_Loc := Cur_Loc + 1;
- end loop;
- end;
-
- if Line_Fst = Line_Lst
- and then Col_Fst /= Col_Lst
- then
- Write_Str (SGR_Reset);
- end if;
-
- -- Output the rest of the last line of the span
-
- Write_Buffer (Buf, Cur_Loc, Get_Line_End (Buf, Cur_Loc));
-
- -- If the span is on one line, output a second line with caret
- -- sign pointing to location Loc
-
- if Line_Fst = Line_Lst then
- Write_Str (String'(1 .. Width => ' '));
- Write_Str (" |");
- Write_Str (String'(1 .. Col_Fst - 1 => ' '));
-
- Write_Str (SGR_Span);
-
- Write_Str (String'(Col_Fst .. Col - 1 => '~'));
- Write_Str ("^");
- Write_Str (String'(Col + 1 .. Col_Lst => '~'));
-
- -- If the span is really just a location, add the word "here"
- -- to clarify this is the location for the message.
-
- if Col_Fst = Col_Lst then
- Write_Str (" here");
- end if;
-
- Write_Str (SGR_Reset);
-
- Write_Eol;
- end if;
- end if;
- end Write_Source_Code_Lines;
-
-- Local variables
E : Error_Msg_Id;
Err_Flag : Boolean;
+ Sarif_File_Name : constant String :=
+ Get_First_Main_File_Name & ".gnat.sarif";
+ Switches_File_Name : constant String := "gnat_switches.json";
+ Diagnostics_File_Name : constant String := "gnat_diagnostics.json";
+
+ Dummy : Boolean;
+
-- Start of processing for Output_Messages
begin
@@ -2977,6 +2816,8 @@ package body Errout is
raise Program_Error;
end if;
+ Erroutc.Exit_Code := Exit_Code;
+
-- Reset current error source file if the main unit has a pragma
-- Source_Reference. This ensures outputting the proper name of
-- the source file in this situation.
@@ -3039,15 +2880,72 @@ package body Errout is
-- Use updated diagnostic mechanism
- if Debug_Flag_Underscore_DD then
- Convert_Errors_To_Diagnostics;
+ if Opt.SARIF_Output then
+ Set_Standard_Error;
+ Erroutc.SARIF_Emitter.Print_SARIF_Report;
+ Set_Standard_Output;
- Emit_Diagnostics;
+ elsif Opt.SARIF_File then
+ System.OS_Lib.Delete_File (Sarif_File_Name, Dummy);
+ declare
+ Output_FD :
+ constant System.OS_Lib.File_Descriptor :=
+ System.OS_Lib.Create_New_File
+ (Sarif_File_Name, Fmode => System.OS_Lib.Text);
+
+ begin
+ Set_Output (Output_FD);
+ Erroutc.SARIF_Emitter.Print_SARIF_Report;
+ Set_Standard_Output;
+ System.OS_Lib.Close (Output_FD);
+ end;
+ elsif Debug_Flag_FF then
+ Erroutc.Pretty_Emitter.Print_Error_Messages;
else
Emit_Error_Msgs;
end if;
end if;
+ if Debug_Flag_Underscore_EE then
+ -- Print the switch repository to a file
+
+ System.OS_Lib.Delete_File (Switches_File_Name, Dummy);
+ declare
+ Output_FD : constant System.OS_Lib.File_Descriptor :=
+ System.OS_Lib.Create_New_File
+ (Switches_File_Name,
+ Fmode => System.OS_Lib.Text);
+
+ begin
+ Set_Output (Output_FD);
+
+ Print_Switch_Repository;
+
+ Set_Standard_Output;
+
+ System.OS_Lib.Close (Output_FD);
+ end;
+
+ -- Print the diagnostics repository to a file
+
+ System.OS_Lib.Delete_File (Diagnostics_File_Name, Dummy);
+ declare
+ Output_FD : constant System.OS_Lib.File_Descriptor :=
+ System.OS_Lib.Create_New_File
+ (Diagnostics_File_Name,
+ Fmode => System.OS_Lib.Text);
+
+ begin
+ Set_Output (Output_FD);
+
+ Print_Diagnostic_Repository;
+
+ Set_Standard_Output;
+
+ System.OS_Lib.Close (Output_FD);
+ end;
+ end if;
+
-- Full source listing case
if Full_List then
@@ -3241,19 +3139,10 @@ package body Errout is
end if;
if Warning_Mode = Treat_As_Error then
- declare
- Compile_Time_Pragma_Warnings : constant Nat :=
- Count_Compile_Time_Pragma_Warnings;
- Total : constant Int := Total_Errors_Detected + Warnings_Detected
- - Compile_Time_Pragma_Warnings;
- -- We need to protect against a negative Total here, because
- -- if a pragma Compile_Time_Warning occurs in dead code, it
- -- gets counted in Compile_Time_Pragma_Warnings but not in
- -- Warnings_Detected.
- begin
- Total_Errors_Detected := Int'Max (Total, 0);
- Warnings_Detected := Compile_Time_Pragma_Warnings;
- end;
+ pragma Assert (Warnings_Detected >= Warnings_Treated_As_Errors);
+ Total_Errors_Detected :=
+ Total_Errors_Detected + Warnings_Treated_As_Errors;
+ Warnings_Detected := Warnings_Detected - Warnings_Treated_As_Errors;
end if;
end Output_Messages;
@@ -3442,7 +3331,7 @@ package body Errout is
and then not Errors.Table (E).Uncond
then
- Warnings_Detected := Warnings_Detected - 1;
+ Decrease_Error_Msg_Count (Errors.Table (E));
return True;
@@ -3467,6 +3356,8 @@ package body Errout is
E := First_Error_Msg;
while E /= No_Error_Msg loop
while To_Be_Removed (Errors.Table (E).Next) loop
+ Errors.Table (Errors.Table (E).Next).Deleted := True;
+
Errors.Table (E).Next :=
Errors.Table (Errors.Table (E).Next).Next;
@@ -4056,17 +3947,45 @@ package body Errout is
Msglen := 0;
Flag_Source := Get_Source_File_Index (Flag);
- -- Skip info: at start, we have recorded this in Error_Msg_Kind, and
- -- this will be used (Info field in error message object) to put back
- -- the string when it is printed. We need to do this, or we get confused
+ P := Text'First;
+
+ -- Skip the continuation symbols at the start
+
+ if P <= Text'Last and then Text (P) = '\' then
+ Continuation := True;
+ P := P + 1;
+
+ if P <= Text'Last and then Text (P) = '\' then
+ Continuation_New_Line := True;
+ P := P + 1;
+ end if;
+ end if;
+
+ -- Skip the message kind tokens at start since it is recorded
+ -- in Error_Msg_Kind, and this will be used to put back the string when
+ -- it is printed. We need to do this, or we get confused
-- with instantiation continuations.
- if Text'Length > 6
- and then Text (Text'First .. Text'First + 5) = "info: "
+ if Text'Length > P + Info_Prefix'Length - 1
+ and then Text (P .. P + Info_Prefix'Length - 1) = Info_Prefix
then
- P := Text'First + 6;
- else
- P := Text'First;
+ P := P + Info_Prefix'Length;
+ elsif Text'Length > P + Style_Prefix'Length - 1
+ and then Text (P .. P + Style_Prefix'Length - 1) = Style_Prefix
+ then
+ P := P + Style_Prefix'Length;
+ elsif Text'Length > P + High_Prefix'Length - 1
+ and then Text (P .. P + High_Prefix'Length - 1) = High_Prefix
+ then
+ P := P + High_Prefix'Length;
+ elsif Text'Length > P + Medium_Prefix'Length - 1
+ and then Text (P .. P + Medium_Prefix'Length - 1) = Medium_Prefix
+ then
+ P := P + Medium_Prefix'Length;
+ elsif Text'Length > P + Low_Prefix'Length - 1
+ and then Text (P .. P + Low_Prefix'Length - 1) = Low_Prefix
+ then
+ P := P + Low_Prefix'Length;
end if;
-- Loop through characters of message
@@ -4109,14 +4028,6 @@ package body Errout is
when '#' =>
Set_Msg_Insertion_Line_Number (Error_Msg_Sloc, Flag);
- when '\' =>
- Continuation := True;
-
- if P <= Text'Last and then Text (P) = '\' then
- Continuation_New_Line := True;
- P := P + 1;
- end if;
-
when '@' =>
Set_Msg_Insertion_Column;
@@ -4176,15 +4087,7 @@ package body Errout is
Set_Msg_Insertion_Code;
else
- -- Switch the message from a warning to an error if the flag
- -- -gnatwE is specified to treat run-time exception warnings
- -- as non-serious errors.
-
- if Error_Msg_Kind = Warning
- and then Warning_Mode = Treat_Run_Time_Warnings_As_Errors
- then
- Is_Runtime_Raise := True;
- end if;
+ Is_Runtime_Raise_Msg := True;
if Error_Msg_Kind = Warning then
Set_Msg_Str ("will be raised at run time");
@@ -4372,6 +4275,48 @@ package body Errout is
end if;
end SPARK_Msg_NE;
+ ------------------
+ -- To_Full_Span --
+ ------------------
+
+ function To_Full_Span (N : Node_Id) return Source_Span is
+ Fst, Lst : Node_Id;
+ begin
+ First_And_Last_Nodes (N, Fst, Lst);
+ return To_Span (Ptr => Sloc (N),
+ First => First_Sloc (Fst),
+ Last => Last_Sloc (Lst));
+ end To_Full_Span;
+
+ ------------------------
+ -- To_Full_Span_First --
+ ------------------------
+
+ function To_Full_Span_First (N : Node_Id) return Source_Span is
+ Fst, Lst : Node_Id;
+ begin
+ First_And_Last_Nodes (N, Fst, Lst);
+ return To_Span (Ptr => Sloc (Fst),
+ First => First_Sloc (Fst),
+ Last => Last_Sloc (Lst));
+ end To_Full_Span_First;
+
+ -------------
+ -- To_Name --
+ -------------
+
+ function To_Name (E : Entity_Id) return String is
+ begin
+ -- The name of the node operator "&" has many special cases. Reuse the
+ -- node to name conversion implementation from the errout package for
+ -- now.
+
+ Error_Msg_Node_1 := E;
+ Set_Msg_Text ("&", Sloc (E));
+
+ return Msg_Buffer (1 .. Msglen);
+ end To_Name;
+
--------------------------
-- Unwind_Internal_Type --
--------------------------
diff --git a/gcc/ada/errout.ads b/gcc/ada/errout.ads
index 24cc1c2..40b5155 100644
--- a/gcc/ada/errout.ads
+++ b/gcc/ada/errout.ads
@@ -30,7 +30,9 @@
with Err_Vars;
with Erroutc;
+with Errid; use Errid;
with Namet; use Namet;
+with Osint; use Osint;
with Table;
with Types; use Types;
with Uintp; use Uintp;
@@ -580,6 +582,19 @@ package Errout is
-- client to set this to No_Error_Msg and then test it to see if a warning
-- message has been issued.
+ subtype Labeled_Span_Type is Erroutc.Labeled_Span_Type;
+ subtype Fix_Type is Erroutc.Fix_Type;
+ subtype Edit_Type is Erroutc.Edit_Type;
+
+ type Labeled_Span_Array is
+ array (Positive range <>) of Labeled_Span_Type;
+ type Fix_Array is array (Positive range <>) of Fix_Type;
+ type Edit_Array is array (Positive range <>) of Edit_Type;
+
+ No_Locations : constant Labeled_Span_Array (1 .. 0) := (others => <>);
+ No_Fixes : constant Fix_Array (1 .. 0) := (others => <>);
+ No_Edits : constant Edit_Array (1 .. 0) := (others => <>);
+
procedure Delete_Warning_And_Continuations (Msg : Error_Msg_Id);
-- Deletes the given warning message and all its continuations. This is
-- typically used in conjunction with reading the value of Warning_Msg.
@@ -702,9 +717,9 @@ package Errout is
-- and must be set True on the last call (a value of True activates some
-- processing that must only be done after all messages are posted).
- procedure Output_Messages;
+ procedure Output_Messages (Exit_Code : Exit_Code_Type);
-- Output list of messages, including messages giving number of detected
- -- errors and warnings.
+ -- errors and warnings and store the exit code used.
procedure Error_Msg
(Msg : String; Flag_Location : Source_Ptr);
@@ -713,11 +728,24 @@ package Errout is
procedure Error_Msg
(Msg : String; Flag_Location : Source_Ptr; N : Node_Id);
procedure Error_Msg
- (Msg : String; Flag_Span : Source_Span; N : Node_Id);
+ (Msg : String;
+ Flag_Span : Source_Span;
+ N : Node_Id;
+ Error_Code : Diagnostic_Id := No_Diagnostic_Id;
+ Label : String := "";
+ Spans : Labeled_Span_Array := No_Locations;
+ Fixes : Fix_Array := No_Fixes);
-- Output a message at specified location. Can be called from the parser
-- or the semantic analyzer. If N is set, points to the relevant node for
-- this message. The version with a span is preferred whenever possible,
-- in other cases the version with a location can still be used.
+ --
+ -- @param Error_Code is the unique identifier for that kind of message.
+ -- @param Label specifies an optional short label that will be displayed
+ -- under the Flag_Span.
+ -- @param Spans specifies other spans with labels that will be highlighted
+ -- in the error message.
+ -- @param Fixes contains a list of possible fixes for the error message.
procedure Error_Msg
(Msg : String;
@@ -753,7 +781,13 @@ package Errout is
-- Output a message at the start of the previous token. This routine can
-- be called only from the parser, since it references Prev_Token_Ptr.
- procedure Error_Msg_N (Msg : String; N : Node_Or_Entity_Id);
+ procedure Error_Msg_N
+ (Msg : String;
+ N : Node_Or_Entity_Id;
+ Error_Code : Diagnostic_Id := No_Diagnostic_Id;
+ Label : String := "";
+ Spans : Labeled_Span_Array := No_Locations;
+ Fixes : Fix_Array := No_Fixes);
-- Output a message at the Sloc of the given node. This routine can be
-- called from the parser or the semantic analyzer, although the call from
-- the latter is much more common (and is the most usual way of generating
@@ -762,6 +796,9 @@ package Errout is
-- suppressed if the node N already has a message posted, or if it is a
-- warning and N is an entity node for which warnings are suppressed.
+ procedure Error_Msg_N_Gigi (Msg : String; N : Node_Or_Entity_Id);
+ -- This is a wrapper for the Error_Msg_N method that gets linked to gigi.
+ --
-- WARNING: There is a matching C declaration of this subprogram in fe.h
procedure Error_Msg_F (Msg : String; N : Node_Id);
@@ -771,15 +808,23 @@ package Errout is
-- want for placing an error message flag in the right place.
procedure Error_Msg_NE
- (Msg : String;
- N : Node_Or_Entity_Id;
- E : Node_Or_Entity_Id);
+ (Msg : String;
+ N : Node_Or_Entity_Id;
+ E : Node_Or_Entity_Id;
+ Error_Code : Diagnostic_Id := No_Diagnostic_Id;
+ Label : String := "";
+ Spans : Labeled_Span_Array := No_Locations;
+ Fixes : Fix_Array := No_Fixes);
-- Output a message at the Sloc of the given node N, with an insertion of
-- the name from the given entity node E. This is used by the semantic
-- routines, where this is a common error message situation. The Msg text
-- will contain a & or } as usual to mark the insertion point. This
-- routine can be called from the parser or the analyzer.
+ procedure Error_Msg_NE_Gigi
+ (Msg : String; N : Node_Or_Entity_Id; E : Node_Or_Entity_Id);
+ -- This is a wrapper for the Error_Msg_NE method that gets linked to gigi.
+ --
-- WARNING: There is a matching C declaration of this subprogram in fe.h
procedure Error_Msg_FE
@@ -795,10 +840,14 @@ package Errout is
E : Node_Or_Entity_Id;
Flag_Location : Source_Ptr);
procedure Error_Msg_NEL
- (Msg : String;
- N : Node_Or_Entity_Id;
- E : Node_Or_Entity_Id;
- Flag_Span : Source_Span);
+ (Msg : String;
+ N : Node_Or_Entity_Id;
+ E : Node_Or_Entity_Id;
+ Flag_Span : Source_Span;
+ Error_Code : Diagnostic_Id := No_Diagnostic_Id;
+ Label : String := "";
+ Spans : Labeled_Span_Array := No_Locations;
+ Fixes : Fix_Array := No_Fixes);
-- Exactly the same as Error_Msg_NE, except that the flag is placed at
-- the specified Flag_Location/Flag_Span instead of at Sloc (N).
@@ -827,6 +876,16 @@ package Errout is
-- at the original source tree, since that's what we want for placing an
-- error message flag in the right place.
+ function To_Full_Span (N : Node_Id) return Source_Span;
+ -- Creates a Source_Span by calculating the positions of its first and last
+ -- node contained by N in the source code and sets the span to point at the
+ -- location of N.
+
+ function To_Full_Span_First (N : Node_Id) return Source_Span;
+ -- Creates a Source_Span by calculating the positions of its first and last
+ -- node contained by N in the source code and sets the span to point to the
+ -- starting position of the span.
+
function First_Node (C : Node_Id) return Node_Id;
-- Return the first output of First_And_Last_Nodes
@@ -966,6 +1025,32 @@ package Errout is
procedure dmsg (Id : Error_Msg_Id) renames Erroutc.dmsg;
-- Debugging routine to dump an error message
+ function Labeled_Span
+ (Span : Source_Span;
+ Label : String := "";
+ Is_Primary : Boolean := True;
+ Is_Region : Boolean := False)
+ return Labeled_Span_Type;
+ -- Constructs a Labeled_Span structure with all of its attributes.
+
+ function Primary_Labeled_Span
+ (Span : Source_Span; Label : String := "") return Labeled_Span_Type;
+ function Primary_Labeled_Span
+ (N : Node_Or_Entity_Id; Label : String := "") return Labeled_Span_Type;
+ -- Shorthand function for creating Primary Labeled_Spans
+
+ function Secondary_Labeled_Span
+ (Span : Source_Span; Label : String := "") return Labeled_Span_Type;
+ function Secondary_Labeled_Span
+ (N : Node_Or_Entity_Id; Label : String := "") return Labeled_Span_Type;
+ -- Shorthand function for creating Secondary Labeled_Spans
+
+ function Edit (Text : String; Span : Source_Span) return Edit_Type;
+ -- Constructs a Edit structure with all of its attributes.
+
+ function Fix (Description : String; Edits : Edit_Array) return Fix_Type;
+ -- Constructs a Fix structure with all of its attributes.
+
------------------------------------
-- SPARK Error Output Subprograms --
------------------------------------
@@ -1028,4 +1113,8 @@ package Errout is
-- Function Is_Size_Too_Small_Message tests for it by testing a prefix.
-- The function and constant should be kept in synch.
+ function To_Name (E : Entity_Id) return String;
+ -- Converts an entities name into a String as if the '&' insertion
+ -- character was used.
+
end Errout;
diff --git a/gcc/ada/diagnostics-pretty_emitter.adb b/gcc/ada/erroutc-pretty_emitter.adb
index 6d3b908..d9bf560 100644
--- a/gcc/ada/diagnostics-pretty_emitter.adb
+++ b/gcc/ada/erroutc-pretty_emitter.adb
@@ -23,12 +23,13 @@
-- --
------------------------------------------------------------------------------
-with Diagnostics.Utils; use Diagnostics.Utils;
-with Output; use Output;
-with Sinput; use Sinput;
-with Erroutc; use Erroutc;
+with Namet; use Namet;
+with Opt; use Opt;
+with Output; use Output;
+with Sinput; use Sinput;
+with GNAT.Lists; use GNAT.Lists;
-package body Diagnostics.Pretty_Emitter is
+package body Erroutc.Pretty_Emitter is
REGION_OFFSET : constant := 1;
-- Number of characters between the line bar and the region span
@@ -46,17 +47,35 @@ package body Diagnostics.Pretty_Emitter is
MAX_BAR_POS : constant := 7;
-- The maximum position of the line bar from the start of the line
+
+ procedure Destroy (Elem : in out Labeled_Span_Type);
+ pragma Inline (Destroy);
+
+ procedure Destroy (Elem : in out Labeled_Span_Type) is
+ begin
+ -- Diagnostic elements will be freed when all the diagnostics have been
+ -- emitted.
+ null;
+ end Destroy;
+
+ package Labeled_Span_Lists is new Doubly_Linked_Lists
+ (Element_Type => Labeled_Span_Type,
+ "=" => "=",
+ Destroy_Element => Destroy,
+ Check_Tampering => False);
+ subtype Labeled_Span_List is Labeled_Span_Lists.Doubly_Linked_List;
+
type Printable_Line is record
- First : Source_Ptr;
+ First : Source_Ptr;
-- The first character of the line
- Last : Source_Ptr;
+ Last : Source_Ptr;
-- The last character of the line
Line_Nr : Pos;
-- The line number
- Spans : Labeled_Span_List;
+ Spans : Labeled_Span_List;
-- The spans applied on the line
end record;
@@ -75,9 +94,14 @@ package body Diagnostics.Pretty_Emitter is
subtype Lines_List is Lines_Lists.Doubly_Linked_List;
type File_Sections is record
- File : String_Ptr;
+ File : String_Ptr;
-- Name of the file
+ Ptr : Source_Ptr;
+ -- Pointer to the Primary location in the file section that is printed
+ -- at the start of the file section. If there are none then the first
+ -- location in the section.
+
Lines : Lines_List;
-- Lines to be printed for the file
end record;
@@ -86,9 +110,7 @@ package body Diagnostics.Pretty_Emitter is
pragma Inline (Destroy);
function Equals (L, R : File_Sections) return Boolean is
- (L.File /= null
- and then R.File /= null
- and then L.File.all = R.File.all);
+ (L.File /= null and then R.File /= null and then L.File.all = R.File.all);
package File_Section_Lists is new Doubly_Linked_Lists
(Element_Type => File_Sections,
@@ -98,8 +120,8 @@ package body Diagnostics.Pretty_Emitter is
subtype File_Section_List is File_Section_Lists.Doubly_Linked_List;
- function Create_File_Sections (Spans : Labeled_Span_List)
- return File_Section_List;
+ function Create_File_Sections
+ (Locations : Labeled_Span_Id) return File_Section_List;
-- Create a list of file sections from the labeled spans that are to be
-- printed.
--
@@ -107,36 +129,31 @@ package body Diagnostics.Pretty_Emitter is
-- the file and the spans that are applied to each of those lines.
procedure Create_File_Section
- (Sections : in out File_Section_List;
- Loc : Labeled_Span_Type);
+ (Sections : in out File_Section_List; Loc : Labeled_Span_Type);
-- Create a new file section for the given labeled span.
procedure Add_Printable_Line
- (Lines : Lines_List;
- Loc : Labeled_Span_Type;
- S_Ptr : Source_Ptr);
+ (Lines : Lines_List; Loc : Labeled_Span_Type; S_Ptr : Source_Ptr);
procedure Create_Printable_Line
- (Lines : Lines_List;
- Loc : Labeled_Span_Type;
- S_Ptr : Source_Ptr);
+ (Lines : Lines_List; Loc : Labeled_Span_Type; S_Ptr : Source_Ptr);
-- Create a new printable line for the given labeled span and add it in the
-- correct position to the Lines list based on the line number.
- function Has_Region_Span_Start (L : Printable_Line) return Boolean;
- function Has_Region_Span_End (L : Printable_Line) return Boolean;
+ function Get_Region_Span
+ (Spans : Labeled_Span_List) return Labeled_Span_Type;
function Has_Multiple_Labeled_Spans (L : Printable_Line) return Boolean;
- procedure Write_Region_Delimiter;
+ procedure Write_Region_Delimiter (SGR_Code : String);
-- Write the arms signifying the start and end of a region span
-- e.g. +--
- procedure Write_Region_Bar;
+ procedure Write_Region_Bar (SGR_Code : String);
-- Write the bar signifying the continuation of a region span
-- e.g. |
- procedure Write_Region_Continuation;
+ procedure Write_Region_Continuation (SGR_Code : String);
-- Write the continuation signifying the continuation of a region span
-- e.g. :
@@ -144,33 +161,62 @@ package body Diagnostics.Pretty_Emitter is
-- Write a number of whitespaces equal to the size of the region span
function Trimmed_Image (I : Natural) return String;
-
- procedure Write_Span_Labels (Loc : Labeled_Span_Type;
- L : Printable_Line;
- Line_Size : Integer;
- Idx : String;
- Within_Region_Span : Boolean);
-
- procedure Write_File_Section (Sec : File_Sections;
- Write_File_Name : Boolean;
- File_Name_Offset : Integer);
-
- procedure Write_Labeled_Spans (Spans : Labeled_Span_List;
- Write_File_Name : Boolean;
- File_Name_Offset : Integer);
+ -- Removes the leading whitespace from the 'Image of a Natural number.
+
+ procedure Write_Span_Labels
+ (Loc : Labeled_Span_Type;
+ L : Printable_Line;
+ Line_Size : Integer;
+ Idx : String;
+ Within_Region_Span : Boolean;
+ SGR_Code : String;
+ Region_Span_SGR_Code : String);
+
+ procedure Write_File_Section
+ (Sec : File_Sections;
+ Write_File_Name : Boolean;
+ File_Name_Offset : Integer;
+ Include_Spans : Boolean;
+ SGR_Code : String := SGR_Note);
+ -- Prints the labled spans for a given File_Section.
+ --
+ -- --> <File_Section.File_Name>
+ -- <Labeled_Spans inside the file>
+
+ procedure Write_Labeled_Spans
+ (Locations : Labeled_Span_Id;
+ Write_File_Name : Boolean;
+ File_Name_Offset : Integer;
+ Include_Spans : Boolean := True;
+ SGR_Code : String := SGR_Note);
+ -- Pretty-prints all of the code regions indicated by the Locations. The
+ -- labeled spans in the Locations are grouped by file into File_Sections
+ -- and sorted by the file name of the Primary location followed by all
+ -- other locations sorted alphabetically.
procedure Write_Intersecting_Labels
- (Intersecting_Labels : Labeled_Span_List);
+ (Intersecting_Labels : Labeled_Span_List; SGR_Code : String);
+ -- Prints the indices and their associated labels of intersecting labels.
+ --
+ -- Labeled spans that are insercting on the same line are printed without
+ -- labels. Instead the span pointer is replaced by an index number and in
+ -- the end all of the indices are printed with their associated labels.
+ --
+ --
+ -- 42 | [for I in V1.First_Index .. V1.Last_Index => V1(I), -6];
+ -- | ^~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ -- | 1-
+ -- | 2-------------------------------------------
+ -- | 1: positional element
+ -- | 2: named element
function Get_Line_End
- (Buf : Source_Buffer_Ptr;
- Loc : Source_Ptr) return Source_Ptr;
+ (Buf : Source_Buffer_Ptr; Loc : Source_Ptr) return Source_Ptr;
-- Get the source location for the end of the line (LF) in Buf for Loc. If
-- Loc is past the end of Buf already, return Buf'Last.
function Get_Line_Start
- (Buf : Source_Buffer_Ptr;
- Loc : Source_Ptr) return Source_Ptr;
+ (Buf : Source_Buffer_Ptr; Loc : Source_Ptr) return Source_Ptr;
-- Get the source location for the start of the line in Buf for Loc
function Get_First_Line_Char
@@ -187,40 +233,50 @@ package body Diagnostics.Pretty_Emitter is
-- Width digits.
procedure Write_Buffer
- (Buf : Source_Buffer_Ptr;
- First : Source_Ptr;
- Last : Source_Ptr);
+ (Buf : Source_Buffer_Ptr; First : Source_Ptr; Last : Source_Ptr);
-- Output the characters from First to Last position in Buf, using
-- Write_Buffer_Char.
- procedure Write_Buffer_Char
- (Buf : Source_Buffer_Ptr;
- Loc : Source_Ptr);
+ procedure Write_Buffer_Char (Buf : Source_Buffer_Ptr; Loc : Source_Ptr);
-- Output the characters at position Loc in Buf, translating ASCII.HT
-- in a suitable number of spaces so that the output is not modified
-- by starting in a different column that 1.
- procedure Write_Line_Marker
- (Num : Pos;
- Width : Positive);
+ procedure Write_Line_Marker (Num : Pos; Width : Positive);
+ -- Attempts to write the line number within Width number of whitespaces
+ -- followed by a bar ':' symbol.
+ --
+ -- e.g ' 12 |'
+ --
+ -- This is usually used on source code lines that are marked by a span.
procedure Write_Empty_Bar_Line (Width : Integer);
+ -- Writes Width number of whitespaces and a bar '|' symbol.
+ --
+ -- e.g ' |'
+ --
+ -- This is usually used on lines where the label is going to printed.
procedure Write_Empty_Skip_Line (Width : Integer);
+ -- Writes Width number of whitespaces and a bar ':' symbol.
+ --
+ -- e.g ' :'
+ --
+ -- This is usually used between non-continous source lines that neec to be
+ -- printed.
- procedure Write_Error_Msg_Line (Diag : Diagnostic_Type);
+ procedure Write_Error_Msg_Line (E_Msg : Error_Msg_Object);
-- Write the error message line for the given diagnostic:
--
-- '['<Diag.Id>']' <Diag.Kind>: <Diag.Message> ['['<Diag.Switch>']']
- function Should_Write_File_Name (Sub_Diag : Sub_Diagnostic_Type;
- Diag : Diagnostic_Type) return Boolean;
+ function Should_Write_File_Name
+ (Sub_Diag : Error_Msg_Object; Diag : Error_Msg_Object) return Boolean;
-- If the sub-diagnostic and the main diagnostic only point to the same
-- file then there is no reason to add the file name to the sub-diagnostic.
- function Should_Write_Spans (Sub_Diag : Sub_Diagnostic_Type;
- Diag : Diagnostic_Type)
- return Boolean;
+ function Should_Write_Spans
+ (Sub_Diag : Error_Msg_Object; Diag : Error_Msg_Object) return Boolean;
-- Old sub-diagnostics used to have the same location as the main
-- diagnostic in order to group them correctly. However in most cases
-- it was not meant to point to a location but rather add an additional
@@ -229,39 +285,55 @@ package body Diagnostics.Pretty_Emitter is
-- If the sub-diagnostic and the main diagnostic have the same location
-- then we should avoid printing the spans.
- procedure Print_Edit
- (Edit : Edit_Type;
- Offset : Integer);
+ procedure Print_Diagnostic (E : Error_Msg_Id);
+ -- Entry point for printing a primary diagnostic message.
- procedure Print_Fix
- (Fix : Fix_Type;
- Offset : Integer);
+ procedure Print_Edit (Edit : Edit_Type; Offset : Integer);
+ -- Prints an edit object as follows:
+ --
+ -- --> <File_Name>
+ -- -<Line_Nr> <Old_Line>
+ -- +<Line_Nr> <New_Line>
+
+ procedure Print_Fix (Fix : Fix_Type; Offset : Integer);
+ -- Prints a fix object as follows
+ --
+ -- + Fix: <Fix.Description>
+ -- <Fix.Edits>
procedure Print_Sub_Diagnostic
- (Sub_Diag : Sub_Diagnostic_Type;
- Diag : Diagnostic_Type;
- Offset : Integer);
+ (Sub_Diag : Error_Msg_Object; Diag : Error_Msg_Object; Offset : Integer);
+
+ function To_String (Sptr : Source_Ptr) return String;
+ -- Convert the source pointer to a string of the form: "file:line:column"
+
+ function To_File_Name (Sptr : Source_Ptr) return String;
+ -- Converts the file name of the Sptr to a string.
+
+ function Line_To_String (Sptr : Source_Ptr) return String;
+ -- Converts the logical line number of the Sptr to a string.
+
+ function Column_To_String (Sptr : Source_Ptr) return String;
+ -- Converts the column number of the Sptr to a string. Column values less
+ -- than 10 are prefixed with a 0.
-------------
-- Destroy --
-------------
- procedure Destroy (Elem : in out Printable_Line)
- is
+ procedure Destroy (Elem : in out Printable_Line) is
begin
- -- Diagnostic elements will be freed when all the diagnostics have been
- -- emitted.
- null;
+ Labeled_Span_Lists.Destroy (Elem.Spans);
end Destroy;
-------------
-- Destroy --
-------------
- procedure Destroy (Elem : in out File_Sections)
- is
+ procedure Destroy (Elem : in out File_Sections) is
begin
Free (Elem.File);
+ Lines_Lists.Destroy (Elem.Lines);
end Destroy;
------------------
@@ -273,9 +345,7 @@ package body Diagnostics.Pretty_Emitter is
is
Cur_Loc : Source_Ptr := Source_Ptr'Min (Loc, Buf'Last);
begin
- while Cur_Loc < Buf'Last
- and then Buf (Cur_Loc) /= ASCII.LF
- loop
+ while Cur_Loc < Buf'Last and then Buf (Cur_Loc) /= ASCII.LF loop
Cur_Loc := Cur_Loc + 1;
end loop;
@@ -291,9 +361,7 @@ package body Diagnostics.Pretty_Emitter is
is
Cur_Loc : Source_Ptr := Loc;
begin
- while Cur_Loc > Buf'First
- and then Buf (Cur_Loc - 1) /= ASCII.LF
- loop
+ while Cur_Loc > Buf'First and then Buf (Cur_Loc - 1) /= ASCII.LF loop
Cur_Loc := Cur_Loc - 1;
end loop;
@@ -309,9 +377,7 @@ package body Diagnostics.Pretty_Emitter is
is
Cur_Loc : Source_Ptr := Get_Line_Start (Buf, Loc);
begin
- while Cur_Loc < Buf'Last
- and then Buf (Cur_Loc) = ' '
- loop
+ while Cur_Loc < Buf'Last and then Buf (Cur_Loc) = ' ' loop
Cur_Loc := Cur_Loc + 1;
end loop;
@@ -347,7 +413,7 @@ package body Diagnostics.Pretty_Emitter is
for J in reverse 1 .. Width loop
if Curr > 0 then
Str (J) := Character'Val (Character'Pos ('0') + Curr mod 10);
- Curr := Curr / 10;
+ Curr := Curr / 10;
else
Str (J) := ' ';
end if;
@@ -360,11 +426,10 @@ package body Diagnostics.Pretty_Emitter is
-- Has_Multiple_Labeled_Spans --
--------------------------------
- function Has_Multiple_Labeled_Spans (L : Printable_Line) return Boolean
- is
+ function Has_Multiple_Labeled_Spans (L : Printable_Line) return Boolean is
Count : Natural := 0;
- Loc : Labeled_Span_Type;
+ Loc : Labeled_Span_Type;
Loc_It : Labeled_Span_Lists.Iterator :=
Labeled_Span_Lists.Iterate (L.Spans);
begin
@@ -378,64 +443,34 @@ package body Diagnostics.Pretty_Emitter is
return Count > 1;
end Has_Multiple_Labeled_Spans;
- ---------------------------
- -- Has_Region_Span_Start --
- ---------------------------
+ ---------------------
+ -- Get_Region_Span --
+ ---------------------
- function Has_Region_Span_Start (L : Printable_Line) return Boolean is
+ function Get_Region_Span
+ (Spans : Labeled_Span_List) return Labeled_Span_Type
+ is
Loc : Labeled_Span_Type;
Loc_It : Labeled_Span_Lists.Iterator :=
- Labeled_Span_Lists.Iterate (L.Spans);
-
- Has_Region_Start : Boolean := False;
+ Labeled_Span_Lists.Iterate (Spans);
begin
while Labeled_Span_Lists.Has_Next (Loc_It) loop
Labeled_Span_Lists.Next (Loc_It, Loc);
- if not Has_Region_Start
- and then Loc.Is_Region
- and then L.Line_Nr =
- Pos (Get_Physical_Line_Number (Loc.Span.First))
- then
- Has_Region_Start := True;
+ if Loc.Is_Region then
+ return Loc;
end if;
end loop;
- return Has_Region_Start;
- end Has_Region_Span_Start;
-
- -------------------------
- -- Has_Region_Span_End --
- -------------------------
-
- function Has_Region_Span_End (L : Printable_Line) return Boolean is
- Loc : Labeled_Span_Type;
- Loc_It : Labeled_Span_Lists.Iterator :=
- Labeled_Span_Lists.Iterate (L.Spans);
-
- Has_Region_End : Boolean := False;
- begin
- while Labeled_Span_Lists.Has_Next (Loc_It) loop
- Labeled_Span_Lists.Next (Loc_It, Loc);
- if not Has_Region_End
- and then Loc.Is_Region
- and then L.Line_Nr =
- Pos (Get_Physical_Line_Number (Loc.Span.Last))
- then
- Has_Region_End := True;
- end if;
- end loop;
- return Has_Region_End;
- end Has_Region_Span_End;
+ return No_Labeled_Span_Object;
+ end Get_Region_Span;
------------------
-- Write_Buffer --
------------------
procedure Write_Buffer
- (Buf : Source_Buffer_Ptr;
- First : Source_Ptr;
- Last : Source_Ptr)
+ (Buf : Source_Buffer_Ptr; First : Source_Ptr; Last : Source_Ptr)
is
begin
for Loc in First .. Last loop
@@ -447,20 +482,14 @@ package body Diagnostics.Pretty_Emitter is
-- Write_Buffer_Char --
-----------------------
- procedure Write_Buffer_Char
- (Buf : Source_Buffer_Ptr;
- Loc : Source_Ptr)
- is
+ procedure Write_Buffer_Char (Buf : Source_Buffer_Ptr; Loc : Source_Ptr) is
begin
-- If the character ASCII.HT is not the last one in the file,
-- output as many spaces as the character represents in the
-- original source file.
- if Buf (Loc) = ASCII.HT
- and then Loc < Buf'Last
- then
- for X in Get_Column_Number (Loc) ..
- Get_Column_Number (Loc + 1) - 1
+ if Buf (Loc) = ASCII.HT and then Loc < Buf'Last then
+ for X in Get_Column_Number (Loc) .. Get_Column_Number (Loc + 1) - 1
loop
Write_Char (' ');
end loop;
@@ -476,10 +505,7 @@ package body Diagnostics.Pretty_Emitter is
-- Write_Line_Marker --
-----------------------
- procedure Write_Line_Marker
- (Num : Pos;
- Width : Positive)
- is
+ procedure Write_Line_Marker (Num : Pos; Width : Positive) is
begin
Write_Str (Image (Positive (Num), Width => Width - 2));
Write_Str (" |");
@@ -511,23 +537,27 @@ package body Diagnostics.Pretty_Emitter is
-- Write_Region_Delimiter --
----------------------------
- procedure Write_Region_Delimiter is
+ procedure Write_Region_Delimiter (SGR_Code : String) is
begin
Write_Str (String'(1 .. REGION_OFFSET => ' '));
+ Write_Str (SGR_Code);
Write_Str ("+");
Write_Str (String'(1 .. REGION_ARM_SIZE => '-'));
+ Write_Str (SGR_Reset);
end Write_Region_Delimiter;
----------------------
-- Write_Region_Bar --
----------------------
- procedure Write_Region_Bar is
+ procedure Write_Region_Bar (SGR_Code : String) is
begin
Write_Str (String'(1 .. REGION_OFFSET => ' '));
+ Write_Str (SGR_Code);
Write_Str ("|");
+ Write_Str (SGR_Reset);
Write_Str (String'(1 .. REGION_ARM_SIZE => ' '));
end Write_Region_Bar;
@@ -535,11 +565,13 @@ package body Diagnostics.Pretty_Emitter is
-- Write_Region_Continuation --
-------------------------------
- procedure Write_Region_Continuation is
+ procedure Write_Region_Continuation (SGR_Code : String) is
begin
Write_Str (String'(1 .. REGION_OFFSET => ' '));
+ Write_Str (SGR_Code);
Write_Str (":");
+ Write_Str (SGR_Reset);
Write_Str (String'(1 .. REGION_ARM_SIZE => ' '));
end Write_Region_Continuation;
@@ -562,8 +594,8 @@ package body Diagnostics.Pretty_Emitter is
Loc : Labeled_Span_Type;
S_Ptr : Source_Ptr)
is
- L : Printable_Line;
- L_It : Lines_Lists.Iterator;
+ L : Printable_Line;
+ L_It : Lines_Lists.Iterator;
Line_Ptr : constant Pos := Pos (Get_Physical_Line_Number (S_Ptr));
Line_Found : Boolean := False;
@@ -590,16 +622,14 @@ package body Diagnostics.Pretty_Emitter is
---------------------------
procedure Create_Printable_Line
- (Lines : Lines_List;
- Loc : Labeled_Span_Type;
- S_Ptr : Source_Ptr)
+ (Lines : Lines_List; Loc : Labeled_Span_Type; S_Ptr : Source_Ptr)
is
Spans : constant Labeled_Span_List := Labeled_Span_Lists.Create;
Buf : constant Source_Buffer_Ptr :=
Source_Text (Get_Source_File_Index (S_Ptr));
- Line_Nr : constant Pos := Pos (Get_Physical_Line_Number (S_Ptr));
+ Line_Nr : constant Pos := Pos (Get_Physical_Line_Number (S_Ptr));
New_Line : constant Printable_Line :=
(First => Get_Line_Start (Buf, S_Ptr),
@@ -620,9 +650,7 @@ package body Diagnostics.Pretty_Emitter is
while Lines_Lists.Has_Next (L_It) loop
Lines_Lists.Next (L_It, L);
- if not Found_Greater_Line
- and then L.Line_Nr > New_Line.Line_Nr
- then
+ if not Found_Greater_Line and then L.Line_Nr > New_Line.Line_Nr then
Found_Greater_Line := True;
Insert_Before_Line := L;
@@ -630,13 +658,10 @@ package body Diagnostics.Pretty_Emitter is
end if;
end loop;
- if Found_Greater_Line then
-
- -- Insert after all the lines have been iterated over to avoid the
- -- mutation lock in GNAT.Lists
+ -- Insert after all the lines have been iterated over to avoid the
+ -- mutation lock in GNAT.Lists.
- null;
- else
+ if not Found_Greater_Line then
Lines_Lists.Append (Lines, New_Line);
end if;
end Create_Printable_Line;
@@ -652,15 +677,15 @@ package body Diagnostics.Pretty_Emitter is
-- Carret positions
Ptr : constant Source_Ptr := Loc.Span.Ptr;
- Line_Ptr : constant Pos := Pos (Get_Physical_Line_Number (Ptr));
+ Line_Ptr : constant Pos := Pos (Get_Physical_Line_Number (Ptr));
-- Span start positions
Fst : constant Source_Ptr := Loc.Span.First;
- Line_Fst : constant Pos := Pos (Get_Physical_Line_Number (Fst));
+ Line_Fst : constant Pos := Pos (Get_Physical_Line_Number (Fst));
-- Span end positions
Lst : constant Source_Ptr := Loc.Span.Last;
- Line_Lst : constant Pos := Pos (Get_Physical_Line_Number (Lst));
+ Line_Lst : constant Pos := Pos (Get_Physical_Line_Number (Lst));
begin
Create_Printable_Line (Lines, Loc, Fst);
@@ -675,6 +700,7 @@ package body Diagnostics.Pretty_Emitter is
File_Section_Lists.Append
(Sections,
(File => new String'(To_File_Name (Loc.Span.Ptr)),
+ Ptr => Loc.Span.Ptr,
Lines => Lines));
end Create_File_Section;
@@ -683,11 +709,10 @@ package body Diagnostics.Pretty_Emitter is
--------------------------
function Create_File_Sections
- (Spans : Labeled_Span_List) return File_Section_List
+ (Locations : Labeled_Span_Id) return File_Section_List
is
Loc : Labeled_Span_Type;
- Loc_It : Labeled_Span_Lists.Iterator :=
- Labeled_Span_Lists.Iterate (Spans);
+ Loc_It : Labeled_Span_Id := Locations;
Sections : File_Section_List := File_Section_Lists.Create;
@@ -696,8 +721,8 @@ package body Diagnostics.Pretty_Emitter is
File_Found : Boolean;
begin
- while Labeled_Span_Lists.Has_Next (Loc_It) loop
- Labeled_Span_Lists.Next (Loc_It, Loc);
+ while Loc_It /= No_Labeled_Span loop
+ Loc := Erroutc.Locations.Table (Loc_It);
File_Found := False;
F_It := File_Section_Lists.Iterate (Sections);
@@ -711,16 +736,20 @@ package body Diagnostics.Pretty_Emitter is
File_Found := True;
Add_Printable_Line (Sec.Lines, Loc, Loc.Span.First);
-
Add_Printable_Line (Sec.Lines, Loc, Loc.Span.Ptr);
-
Add_Printable_Line (Sec.Lines, Loc, Loc.Span.Last);
+
+ if Loc.Is_Primary then
+ Sec.Ptr := Loc.Span.Ptr;
+ end if;
end if;
end loop;
if not File_Found then
Create_File_Section (Sections, Loc);
end if;
+
+ Loc_It := Loc.Next;
end loop;
return Sections;
@@ -730,21 +759,24 @@ package body Diagnostics.Pretty_Emitter is
-- Write_Span_Labels --
-----------------------
- procedure Write_Span_Labels (Loc : Labeled_Span_Type;
- L : Printable_Line;
- Line_Size : Integer;
- Idx : String;
- Within_Region_Span : Boolean)
+ procedure Write_Span_Labels
+ (Loc : Labeled_Span_Type;
+ L : Printable_Line;
+ Line_Size : Integer;
+ Idx : String;
+ Within_Region_Span : Boolean;
+ SGR_Code : String;
+ Region_Span_SGR_Code : String)
is
Span_Char : constant Character := (if Loc.Is_Primary then '~' else '-');
Buf : constant Source_Buffer_Ptr :=
Source_Text (Get_Source_File_Index (L.First));
- Col_L_Fst : constant Natural := Natural
- (Get_Column_Number (Get_First_Line_Char (Buf, L.First)));
- Col_L_Lst : constant Natural := Natural
- (Get_Column_Number (Get_Last_Line_Char (Buf, L.Last)));
+ Col_L_Fst : constant Natural :=
+ Natural (Get_Column_Number (Get_First_Line_Char (Buf, L.First)));
+ Col_L_Lst : constant Natural :=
+ Natural (Get_Column_Number (Get_Last_Line_Char (Buf, L.Last)));
-- Carret positions
Ptr : constant Source_Ptr := Loc.Span.Ptr;
@@ -775,8 +807,7 @@ package body Diagnostics.Pretty_Emitter is
(if Line_Ptr = L.Line_Nr then Col_Ptr else Col_L_Fst);
Span_Ptr_Lst : constant Natural :=
- (if Line_Ptr = L.Line_Nr
- then Span_Ptr_Fst + Span_Sym'Length
+ (if Line_Ptr = L.Line_Nr then Span_Ptr_Fst + Span_Sym'Length
else Span_Fst);
begin
@@ -784,13 +815,15 @@ package body Diagnostics.Pretty_Emitter is
Write_Empty_Bar_Line (Line_Size);
if Within_Region_Span then
- Write_Region_Bar;
+ Write_Region_Bar (Region_Span_SGR_Code);
else
Write_Region_Offset;
end if;
Write_Str (String'(1 .. Span_Fst - 1 => ' '));
+ Write_Str (SGR_Code);
+
if Line_Ptr = L.Line_Nr then
Write_Str (String'(Span_Fst .. Col_Ptr - 1 => Span_Char));
Write_Str (Span_Sym);
@@ -798,6 +831,8 @@ package body Diagnostics.Pretty_Emitter is
Write_Str (String'(Span_Ptr_Lst .. Span_Lst => Span_Char));
+ Write_Str (SGR_Reset);
+
Write_Eol;
-- Write the label under the line unless it is an intersecting span.
@@ -808,24 +843,27 @@ package body Diagnostics.Pretty_Emitter is
Write_Empty_Bar_Line (Line_Size);
if Within_Region_Span then
- Write_Region_Bar;
+ Write_Region_Bar (Region_Span_SGR_Code);
else
Write_Region_Offset;
end if;
Write_Str (String'(1 .. Span_Fst - 1 => ' '));
+ Write_Str (SGR_Code);
Write_Str (Loc.Label.all);
+ Write_Str (SGR_Reset);
Write_Eol;
end if;
else
if Line_Lst = L.Line_Nr then
Write_Empty_Bar_Line (Line_Size);
Write_Str (String'(1 .. REGION_OFFSET => ' '));
+ Write_Str (SGR_Code);
Write_Str (Loc.Label.all);
+ Write_Str (SGR_Reset);
Write_Eol;
end if;
end if;
-
end Write_Span_Labels;
-------------------
@@ -833,7 +871,7 @@ package body Diagnostics.Pretty_Emitter is
-------------------
function Trimmed_Image (I : Natural) return String is
- Img_Raw : constant String := Natural'Image (I);
+ Img_Raw : constant String := Natural'Image (I);
begin
return Img_Raw (Img_Raw'First + 1 .. Img_Raw'Last);
end Trimmed_Image;
@@ -843,22 +881,24 @@ package body Diagnostics.Pretty_Emitter is
-------------------------------
procedure Write_Intersecting_Labels
- (Intersecting_Labels : Labeled_Span_List)
+ (Intersecting_Labels : Labeled_Span_List; SGR_Code : String)
is
- Ls : Labeled_Span_Type;
- Ls_It : Labeled_Span_Lists.Iterator :=
+ L : Labeled_Span_Type;
+ L_It : Labeled_Span_Lists.Iterator :=
Labeled_Span_Lists.Iterate (Intersecting_Labels);
- Idx : Integer := 0;
+ Idx : Integer := 0;
begin
- while Labeled_Span_Lists.Has_Next (Ls_It) loop
- Labeled_Span_Lists.Next (Ls_It, Ls);
+ while Labeled_Span_Lists.Has_Next (L_It) loop
+ Labeled_Span_Lists.Next (L_It, L);
Idx := Idx + 1;
Write_Empty_Bar_Line (MAX_BAR_POS);
Write_Str (" ");
+ Write_Str ((if L.Is_Primary then SGR_Code else SGR_Note));
Write_Int (Int (Idx));
Write_Str (": ");
- Write_Str (Ls.Label.all);
+ Write_Str (L.Label.all);
+ Write_Str (SGR_Reset);
Write_Eol;
end loop;
end Write_Intersecting_Labels;
@@ -867,18 +907,18 @@ package body Diagnostics.Pretty_Emitter is
-- Write_File_Section --
------------------------
- procedure Write_File_Section (Sec : File_Sections;
- Write_File_Name : Boolean;
- File_Name_Offset : Integer)
+ procedure Write_File_Section
+ (Sec : File_Sections; Write_File_Name : Boolean;
+ File_Name_Offset : Integer; Include_Spans : Boolean;
+ SGR_Code : String := SGR_Note)
is
use Lines_Lists;
- L : Printable_Line;
- L_It : Iterator := Iterate (Sec.Lines);
+ function Get_SGR_Code (L : Labeled_Span_Type) return String is
+ (if L.Is_Primary then SGR_Code else SGR_Note);
- -- The error should be included in the first (primary) span of the file.
- Loc : constant Labeled_Span_Type :=
- Labeled_Span_Lists.First (Lines_Lists.First (Sec.Lines).Spans);
+ L : Printable_Line;
+ L_It : Iterator := Iterate (Sec.Lines);
Multiple_Labeled_Spans : Boolean := False;
@@ -896,45 +936,62 @@ package body Diagnostics.Pretty_Emitter is
-- offset the file start location for sub-diagnostics
Write_Str (String'(1 .. File_Name_Offset => ' '));
- Write_Str ("--> " & To_String (Loc.Span.Ptr));
+ Write_Str ("--> " & To_String (Sec.Ptr));
Write_Eol;
end if;
+ -- Historically SPARK does not include spans in their info messages.
+
+ if not Include_Spans then
+ return;
+ end if;
+
while Has_Next (L_It) loop
Next (L_It, L);
declare
- Line_Nr : constant Pos := L.Line_Nr;
+ Line_Nr : constant Pos := L.Line_Nr;
Line_Str : constant String := Trimmed_Image (Natural (Line_Nr));
Line_Size : constant Integer :=
Integer'Max (Line_Str'Length, MAX_BAR_POS);
- Loc : Labeled_Span_Type;
+ Loc : Labeled_Span_Type;
Loc_It : Labeled_Span_Lists.Iterator :=
Labeled_Span_Lists.Iterate (L.Spans);
Buf : constant Source_Buffer_Ptr :=
Source_Text (Get_Source_File_Index (L.First));
+ Region_Span : constant Labeled_Span_Type :=
+ Get_Region_Span (L.Spans);
+
Contains_Region_Span_Start : constant Boolean :=
- Has_Region_Span_Start (L);
+ Region_Span /= No_Labeled_Span_Object
+ and then Line_Nr =
+ Pos (Get_Physical_Line_Number (Region_Span.Span.First));
Contains_Region_Span_End : constant Boolean :=
- Has_Region_Span_End (L);
+ Region_Span /= No_Labeled_Span_Object
+ and then Line_Nr =
+ Pos (Get_Physical_Line_Number (Region_Span.Span.Last));
+
+ Region_Span_Color : constant String :=
+ (if Region_Span /= No_Labeled_Span_Object then
+ Get_SGR_Code (Region_Span)
+ else SGR_Note);
begin
if not Multiple_Labeled_Spans then
- Multiple_Labeled_Spans := Has_Multiple_Labeled_Spans (L);
+ Multiple_Labeled_Spans := Has_Multiple_Labeled_Spans (L);
end if;
-- Write an empty line with the continuation symbol if the line
-- numbers are not contiguous
- if Prev_Line_Nr /= 0
- and then Pos (Prev_Line_Nr + 1) /= Line_Nr
+ if Prev_Line_Nr /= 0 and then Pos (Prev_Line_Nr + 1) /= Line_Nr
then
Write_Empty_Skip_Line (Line_Size);
if Within_Region_Span then
- Write_Region_Continuation;
+ Write_Region_Continuation (Region_Span_Color);
end if;
Write_Eol;
@@ -950,28 +1007,23 @@ package body Diagnostics.Pretty_Emitter is
-- whitespaces.
if Contains_Region_Span_Start or Contains_Region_Span_End then
- Write_Region_Delimiter;
+ Write_Region_Delimiter (Region_Span_Color);
elsif Within_Region_Span then
- Write_Region_Bar;
+ Write_Region_Bar (Region_Span_Color);
else
Write_Region_Offset;
end if;
-- Write the line itself
- Write_Buffer
- (Buf => Buf,
- First => L.First,
- Last => L.Last);
+ Write_Buffer (Buf => Buf, First => L.First, Last => L.Last);
-- Write all the spans for the line
while Labeled_Span_Lists.Has_Next (Loc_It) loop
Labeled_Span_Lists.Next (Loc_It, Loc);
- if Multiple_Labeled_Spans
- and then Loc.Label /= null
- then
+ if Multiple_Labeled_Spans and then Loc.Label /= null then
-- Collect all the spans with labels to print them at the
-- end.
@@ -980,17 +1032,23 @@ package body Diagnostics.Pretty_Emitter is
Idx := Idx + 1;
- Write_Span_Labels (Loc,
- L,
- Line_Size,
- Trimmed_Image (Idx),
- Within_Region_Span);
+ Write_Span_Labels
+ (Loc => Loc,
+ L => L,
+ Line_Size => Line_Size,
+ Idx => Trimmed_Image (Idx),
+ Within_Region_Span => Within_Region_Span,
+ SGR_Code => Get_SGR_Code (Loc),
+ Region_Span_SGR_Code => Region_Span_Color);
else
- Write_Span_Labels (Loc,
- L,
- Line_Size,
- "",
- Within_Region_Span);
+ Write_Span_Labels
+ (Loc => Loc,
+ L => L,
+ Line_Size => Line_Size,
+ Idx => "",
+ Within_Region_Span => Within_Region_Span,
+ SGR_Code => Get_SGR_Code (Loc),
+ Region_Span_SGR_Code => Region_Span_Color);
end if;
end loop;
@@ -1003,18 +1061,21 @@ package body Diagnostics.Pretty_Emitter is
end;
end loop;
- Write_Intersecting_Labels (Intersecting_Labels);
+ Write_Intersecting_Labels (Intersecting_Labels, SGR_Code);
end Write_File_Section;
-------------------------
-- Write_Labeled_Spans --
-------------------------
- procedure Write_Labeled_Spans (Spans : Labeled_Span_List;
- Write_File_Name : Boolean;
- File_Name_Offset : Integer)
+ procedure Write_Labeled_Spans
+ (Locations : Labeled_Span_Id;
+ Write_File_Name : Boolean;
+ File_Name_Offset : Integer;
+ Include_Spans : Boolean := True;
+ SGR_Code : String := SGR_Note)
is
- Sections : File_Section_List := Create_File_Sections (Spans);
+ Sections : File_Section_List := Create_File_Sections (Locations);
Sec : File_Sections;
F_It : File_Section_Lists.Iterator :=
@@ -1024,7 +1085,11 @@ package body Diagnostics.Pretty_Emitter is
File_Section_Lists.Next (F_It, Sec);
Write_File_Section
- (Sec, Write_File_Name, File_Name_Offset);
+ (Sec => Sec,
+ Write_File_Name => Write_File_Name,
+ File_Name_Offset => File_Name_Offset,
+ Include_Spans => Include_Spans,
+ SGR_Code => SGR_Code);
end loop;
File_Section_Lists.Destroy (Sections);
@@ -1034,33 +1099,29 @@ package body Diagnostics.Pretty_Emitter is
-- Write_Error_Msg_Line --
--------------------------
- procedure Write_Error_Msg_Line (Diag : Diagnostic_Type) is
- Switch_Str : constant String := Get_Doc_Switch (Diag);
-
- Kind_Str : constant String := Kind_To_String (Diag);
+ procedure Write_Error_Msg_Line (E_Msg : Error_Msg_Object) is
+ Switch_Str : constant String := Get_Doc_Switch (E_Msg);
- SGR_Code : constant String :=
- (if Kind_Str = "error" then SGR_Error
- elsif Kind_Str = "warning" then SGR_Warning
- elsif Kind_Str = "info" then SGR_Note
- else SGR_Reset);
+ SGR_Code : constant String := Get_SGR_Code (E_Msg);
begin
Write_Str (SGR_Code);
- Write_Str ("[" & To_String (Diag.Id) & "]");
+ if not GNATprove_Mode or else E_Msg.Id /= No_Diagnostic_Id then
+ Write_Str ("[" & To_String (E_Msg.Id) & "]");
+ end if;
- Write_Str (" " & Kind_To_String (Diag) & ": ");
+ Write_Str (" " & Kind_To_String (E_Msg) & ": ");
Write_Str (SGR_Reset);
- Write_Str (Diag.Message.all);
+ Write_Str (E_Msg.Text.all);
if Switch_Str /= "" then
Write_Str (" " & Switch_Str);
end if;
- if Diag.Warn_Err then
- Write_Str (" [warning-as-error]");
+ if E_Msg.Warn_Err = From_Pragma then
+ Write_Str (" " & Warn_As_Err_Tag);
end if;
Write_Eol;
@@ -1070,44 +1131,49 @@ package body Diagnostics.Pretty_Emitter is
-- Should_Write_File_Name --
----------------------------
- function Should_Write_File_Name (Sub_Diag : Sub_Diagnostic_Type;
- Diag : Diagnostic_Type)
- return Boolean
+ function Should_Write_File_Name
+ (Sub_Diag : Error_Msg_Object; Diag : Error_Msg_Object) return Boolean
is
- Sub_Loc : constant Labeled_Span_Type := Primary_Location (Sub_Diag);
- Diag_Loc : constant Labeled_Span_Type := Primary_Location (Diag);
+ Sub_Loc : constant Labeled_Span_Type :=
+ Locations.Table (Primary_Location (Sub_Diag));
+
+ Diag_Loc : constant Labeled_Span_Type :=
+ Locations.Table (Primary_Location (Diag));
- function Has_Multiple_Files (Spans : Labeled_Span_List) return Boolean;
+ function Has_Multiple_Files (Diag : Error_Msg_Object) return Boolean;
------------------------
-- Has_Multiple_Files --
------------------------
- function Has_Multiple_Files
- (Spans : Labeled_Span_List) return Boolean
- is
+ function Has_Multiple_Files (Diag : Error_Msg_Object) return Boolean is
First : constant Labeled_Span_Type :=
- Labeled_Span_Lists.First (Spans);
+ Locations.Table (Diag.Locations);
File : constant String := To_File_Name (First.Span.Ptr);
- Loc : Labeled_Span_Type;
- It : Labeled_Span_Lists.Iterator :=
- Labeled_Span_Lists.Iterate (Spans);
-
+ Loc_Id : Labeled_Span_Id := Diag.Locations;
+ Loc : Labeled_Span_Type;
begin
- while Labeled_Span_Lists.Has_Next (It) loop
- Labeled_Span_Lists.Next (It, Loc);
+ Loc_Id := Diag.Locations;
+ while Loc_Id /= No_Labeled_Span loop
+ Loc := Locations.Table (Loc_Id);
if To_File_Name (Loc.Span.Ptr) /= File then
return True;
end if;
+
+ Loc_Id := Loc.Next;
end loop;
+
return False;
end Has_Multiple_Files;
+
+ -- Start of processing for Should_Write_File_Name
+
begin
return
- Has_Multiple_Files (Diag.Locations)
+ Has_Multiple_Files (Diag)
or else To_File_Name (Sub_Loc.Span.Ptr) /=
To_File_Name (Diag_Loc.Span.Ptr);
end Should_Write_File_Name;
@@ -1116,16 +1182,16 @@ package body Diagnostics.Pretty_Emitter is
-- Should_Write_Spans --
------------------------
- function Should_Write_Spans (Sub_Diag : Sub_Diagnostic_Type;
- Diag : Diagnostic_Type)
- return Boolean
+ function Should_Write_Spans
+ (Sub_Diag : Error_Msg_Object; Diag : Error_Msg_Object) return Boolean
is
- Sub_Loc : constant Labeled_Span_Type := Primary_Location (Sub_Diag);
- Diag_Loc : constant Labeled_Span_Type := Primary_Location (Diag);
+ Sub_Loc : constant Labeled_Span_Id := Primary_Location (Sub_Diag);
+ Diag_Loc : constant Labeled_Span_Id := Primary_Location (Diag);
begin
- return Sub_Loc /= No_Labeled_Span
- and then Diag_Loc /= No_Labeled_Span
- and then Sub_Loc.Span.Ptr /= Diag_Loc.Span.Ptr;
+ return
+ Sub_Loc /= No_Labeled_Span and then Diag_Loc /= No_Labeled_Span
+ and then Locations.Table (Sub_Loc).Span.Ptr /=
+ Locations.Table (Diag_Loc).Span.Ptr;
end Should_Write_Spans;
----------------
@@ -1134,7 +1200,7 @@ package body Diagnostics.Pretty_Emitter is
procedure Print_Edit (Edit : Edit_Type; Offset : Integer) is
Buf : constant Source_Buffer_Ptr :=
- Source_Text (Get_Source_File_Index (Edit.Span.Ptr));
+ Source_Text (Get_Source_File_Index (Edit.Span.Ptr));
Line_Nr : constant Pos := Pos (Get_Physical_Line_Number (Edit.Span.Ptr));
@@ -1150,10 +1216,7 @@ package body Diagnostics.Pretty_Emitter is
Write_Char ('-');
Write_Line_Marker (Line_Nr, MAX_BAR_POS - 1);
- Write_Buffer
- (Buf => Buf,
- First => Line_Fst,
- Last => Line_Lst);
+ Write_Buffer (Buf => Buf, First => Line_Fst, Last => Line_Lst);
-- write the edited line
@@ -1161,19 +1224,13 @@ package body Diagnostics.Pretty_Emitter is
Write_Line_Marker (Line_Nr, MAX_BAR_POS - 1);
Write_Buffer
- (Buf => Buf,
- First => Line_Fst,
- Last => Edit.Span.First - 1);
+ (Buf => Buf, First => Line_Fst, Last => Edit.Span.First - 1);
if Edit.Text /= null then
Write_Str (Edit.Text.all);
end if;
- Write_Buffer
- (Buf => Buf,
- First => Edit.Span.Last + 1,
- Last => Line_Lst);
-
+ Write_Buffer (Buf => Buf, First => Edit.Span.Last + 1, Last => Line_Lst);
end Print_Edit;
---------------
@@ -1181,7 +1238,7 @@ package body Diagnostics.Pretty_Emitter is
---------------
procedure Print_Fix (Fix : Fix_Type; Offset : Integer) is
- use Edit_Lists;
+ E : Edit_Id;
begin
Write_Str (String'(1 .. Offset => ' '));
Write_Str ("+ Fix: ");
@@ -1191,19 +1248,12 @@ package body Diagnostics.Pretty_Emitter is
end if;
Write_Eol;
- if Present (Fix.Edits) then
- declare
- Edit : Edit_Type;
-
- It : Iterator := Iterate (Fix.Edits);
- begin
- while Has_Next (It) loop
- Next (It, Edit);
+ E := Fix.Edits;
+ while E /= No_Edit loop
+ Print_Edit (Edits.Table (E), MAX_BAR_POS - 1);
- Print_Edit (Edit, MAX_BAR_POS - 1);
- end loop;
- end;
- end if;
+ E := Edits.Table (E).Next;
+ end loop;
end Print_Fix;
--------------------------
@@ -1211,26 +1261,23 @@ package body Diagnostics.Pretty_Emitter is
--------------------------
procedure Print_Sub_Diagnostic
- (Sub_Diag : Sub_Diagnostic_Type;
- Diag : Diagnostic_Type;
- Offset : Integer)
+ (Sub_Diag : Error_Msg_Object; Diag : Error_Msg_Object; Offset : Integer)
is
begin
Write_Str (String'(1 .. Offset => ' '));
- if Sub_Diag.Kind = Suggestion then
- Write_Str ("+ Suggestion: ");
- else
- Write_Str ("+ ");
- end if;
+ Write_Str ("+ ");
- Write_Str (Sub_Diag.Message.all);
+ Write_Str (Sub_Diag.Text.all);
Write_Eol;
if Should_Write_Spans (Sub_Diag, Diag) then
- Write_Labeled_Spans (Sub_Diag.Locations,
- Should_Write_File_Name (Sub_Diag, Diag),
- Offset);
+ Write_Labeled_Spans
+ (Locations => Sub_Diag.Locations,
+ Write_File_Name => Should_Write_File_Name (Sub_Diag, Diag),
+ File_Name_Offset => Offset,
+ Include_Spans => not GNATprove_Mode or else Sub_Diag.Kind /= Info,
+ SGR_Code => SGR_Note);
end if;
end Print_Sub_Diagnostic;
@@ -1238,57 +1285,126 @@ package body Diagnostics.Pretty_Emitter is
-- Print_Diagnostic --
----------------------
- procedure Print_Diagnostic (Diag : Diagnostic_Type) is
+ procedure Print_Diagnostic (E : Error_Msg_Id) is
+ E_Msg : constant Error_Msg_Object := Errors.Table (E);
+
+ E_Next_Id : Error_Msg_Id;
+ F : Fix_Id;
begin
-- Print the main diagnostic
- Write_Error_Msg_Line (Diag);
+ Write_Error_Msg_Line (E_Msg);
-- Print diagnostic locations along with spans
- Write_Labeled_Spans (Diag.Locations, True, 0);
+ Write_Labeled_Spans
+ (Locations => E_Msg.Locations,
+ Write_File_Name => True,
+ File_Name_Offset => 0,
+ Include_Spans => not GNATprove_Mode or else E_Msg.Kind /= Info,
+ SGR_Code => Get_SGR_Code (E_Msg));
-- Print subdiagnostics
- if Sub_Diagnostic_Lists.Present (Diag.Sub_Diagnostics) then
- declare
- use Sub_Diagnostic_Lists;
- Sub_Diag : Sub_Diagnostic_Type;
-
- It : Iterator := Iterate (Diag.Sub_Diagnostics);
- begin
- while Has_Next (It) loop
- Next (It, Sub_Diag);
-
- -- Print the subdiagnostic and offset the location of the file
- -- name
+ E_Next_Id := E_Msg.Next;
+ while E_Next_Id /= No_Error_Msg
+ and then Errors.Table (E_Next_Id).Msg_Cont
+ loop
+ -- Print the subdiagnostic and offset the location of the file
+ -- name
+ Print_Sub_Diagnostic
+ (Errors.Table (E_Next_Id), E_Msg, MAX_BAR_POS - 1);
- Print_Sub_Diagnostic (Sub_Diag, Diag, MAX_BAR_POS - 1);
- end loop;
- end;
- end if;
+ E_Next_Id := Errors.Table (E_Next_Id).Next;
+ end loop;
-- Print fixes
- if Fix_Lists.Present (Diag.Fixes) then
- declare
- use Fix_Lists;
- Fix : Fix_Type;
-
- It : Iterator := Iterate (Diag.Fixes);
- begin
- while Has_Next (It) loop
- Next (It, Fix);
+ F := E_Msg.Fixes;
+ while F /= No_Fix loop
+ Print_Fix (Fixes.Table (F), MAX_BAR_POS - 1);
- Print_Fix (Fix, MAX_BAR_POS - 1);
- end loop;
- end;
- end if;
+ F := Fixes.Table (F).Next;
+ end loop;
-- Separate main diagnostics with a blank line
Write_Eol;
-
end Print_Diagnostic;
-end Diagnostics.Pretty_Emitter;
+
+ --------------------------
+ -- Print_Error_Messages --
+ --------------------------
+
+ procedure Print_Error_Messages is
+ E : Error_Msg_Id;
+ begin
+ Set_Standard_Error;
+
+ E := First_Error_Msg;
+ while E /= No_Error_Msg loop
+
+ if not Errors.Table (E).Deleted and then not Errors.Table (E).Msg_Cont
+ then
+ Print_Diagnostic (E);
+ end if;
+
+ E := Errors.Table (E).Next;
+ end loop;
+
+ Set_Standard_Output;
+ end Print_Error_Messages;
+
+ ------------------
+ -- To_File_Name --
+ ------------------
+
+ function To_File_Name (Sptr : Source_Ptr) return String is
+ Sfile : constant Source_File_Index := Get_Source_File_Index (Sptr);
+ Ref_Name : constant File_Name_Type :=
+ (if Full_Path_Name_For_Brief_Errors then Full_Ref_Name (Sfile)
+ else Reference_Name (Sfile));
+
+ begin
+ return Get_Name_String (Ref_Name);
+ end To_File_Name;
+
+ --------------------
+ -- Line_To_String --
+ --------------------
+
+ function Line_To_String (Sptr : Source_Ptr) return String is
+ Line : constant Logical_Line_Number := Get_Logical_Line_Number (Sptr);
+ Img_Raw : constant String := Int'Image (Int (Line));
+
+ begin
+ return Img_Raw (Img_Raw'First + 1 .. Img_Raw'Last);
+ end Line_To_String;
+
+ ----------------------
+ -- Column_To_String --
+ ----------------------
+
+ function Column_To_String (Sptr : Source_Ptr) return String is
+ Col : constant Column_Number := Get_Column_Number (Sptr);
+ Img_Raw : constant String := Int'Image (Int (Col));
+
+ begin
+ return
+ (if Col < 10 then "0" else "") &
+ Img_Raw (Img_Raw'First + 1 .. Img_Raw'Last);
+ end Column_To_String;
+
+ ---------------
+ -- To_String --
+ ---------------
+
+ function To_String (Sptr : Source_Ptr) return String is
+ begin
+ return
+ To_File_Name (Sptr) & ":" & Line_To_String (Sptr) & ":" &
+ Column_To_String (Sptr);
+ end To_String;
+
+end Erroutc.Pretty_Emitter;
diff --git a/gcc/ada/diagnostics-pretty_emitter.ads b/gcc/ada/erroutc-pretty_emitter.ads
index 2f5ba04..3ff0109 100644
--- a/gcc/ada/diagnostics-pretty_emitter.ads
+++ b/gcc/ada/erroutc-pretty_emitter.ads
@@ -23,6 +23,6 @@
-- --
------------------------------------------------------------------------------
-package Diagnostics.Pretty_Emitter is
- procedure Print_Diagnostic (Diag : Diagnostic_Type);
-end Diagnostics.Pretty_Emitter;
+package Erroutc.Pretty_Emitter is
+ procedure Print_Error_Messages;
+end Erroutc.Pretty_Emitter;
diff --git a/gcc/ada/diagnostics-sarif_emitter.adb b/gcc/ada/erroutc-sarif_emitter.adb
index 31b3154..90f7a7c 100644
--- a/gcc/ada/diagnostics-sarif_emitter.adb
+++ b/gcc/ada/erroutc-sarif_emitter.adb
@@ -23,29 +23,103 @@
-- --
------------------------------------------------------------------------------
-with Diagnostics.Utils; use Diagnostics.Utils;
-with Diagnostics.JSON_Utils; use Diagnostics.JSON_Utils;
-with Gnatvsn; use Gnatvsn;
-with Output; use Output;
-with Sinput; use Sinput;
-with Lib; use Lib;
-with Namet; use Namet;
-with Osint; use Osint;
-with Errout; use Errout;
-
-package body Diagnostics.SARIF_Emitter is
+with JSON_Utils; use JSON_Utils;
+with GNAT.Lists; use GNAT.Lists;
+with Gnatvsn; use Gnatvsn;
+with Lib; use Lib;
+with Namet; use Namet;
+with Output; use Output;
+with Sinput; use Sinput;
+with System.OS_Lib;
+
+package body Erroutc.SARIF_Emitter is
+
+ -- SARIF attribute names
+
+ N_ARTIFACT_CHANGES : constant String := "artifactChanges";
+ N_ARTIFACT_LOCATION : constant String := "artifactLocation";
+ N_COMMAND_LINE : constant String := "commandLine";
+ N_DELETED_REGION : constant String := "deletedRegion";
+ N_DESCRIPTION : constant String := "description";
+ N_DRIVER : constant String := "driver";
+ N_END_COLUMN : constant String := "endColumn";
+ N_END_LINE : constant String := "endLine";
+ N_EXECUTION_SUCCESSFUL : constant String := "executionSuccessful";
+ N_FIXES : constant String := "fixes";
+ N_ID : constant String := "id";
+ N_INSERTED_CONTENT : constant String := "insertedContent";
+ N_INVOCATIONS : constant String := "invocations";
+ N_LOCATIONS : constant String := "locations";
+ N_LEVEL : constant String := "level";
+ N_MESSAGE : constant String := "message";
+ N_NAME : constant String := "name";
+ N_ORIGINAL_URI_BASE_IDS : constant String := "originalUriBaseIds";
+ N_PHYSICAL_LOCATION : constant String := "physicalLocation";
+ N_REGION : constant String := "region";
+ N_RELATED_LOCATIONS : constant String := "relatedLocations";
+ N_REPLACEMENTS : constant String := "replacements";
+ N_RESULTS : constant String := "results";
+ N_RULES : constant String := "rules";
+ N_RULE_ID : constant String := "ruleId";
+ N_RUNS : constant String := "runs";
+ N_SCHEMA : constant String := "$schema";
+ N_START_COLUMN : constant String := "startColumn";
+ N_START_LINE : constant String := "startLine";
+ N_TEXT : constant String := "text";
+ N_TOOL : constant String := "tool";
+ N_URI : constant String := "uri";
+ N_URI_BASE_ID : constant String := "uriBaseId";
+ N_VERSION : constant String := "version";
-- We are currently using SARIF 2.1.0
SARIF_Version : constant String := "2.1.0";
pragma Style_Checks ("M100");
- SARIF_Schema : constant String :=
+ SARIF_Schema : constant String :=
"https://docs.oasis-open.org/sarif/sarif/v2.1.0/errata01/os/schemas/sarif-schema-2.1.0.json";
pragma Style_Checks ("M79");
+ URI_Base_Id_Name : constant String := "PWD";
+ -- We use the pwd as the originalUriBaseIds when providing absolute paths
+ -- in locations.
+
+ Current_Dir : constant String := Get_Current_Dir;
+ -- Cached value of the current directory that is used in the URI_Base_Id
+ -- and it is also the path that all other Uri attributes will be created
+ -- relative to.
+
+ procedure Destroy (Elem : in out Error_Msg_Object) is null;
+ pragma Inline (Destroy);
+ package Error_Msg_Lists is new Doubly_Linked_Lists
+ (Element_Type => Error_Msg_Object,
+ "=" => "=",
+ Destroy_Element => Destroy,
+ Check_Tampering => False);
+
+ subtype Error_Msg_List is Error_Msg_Lists.Doubly_Linked_List;
+
+ procedure Destroy (Elem : in out Edit_Type);
+
+ procedure Destroy (Elem : in out Edit_Type) is
+ begin
+ -- Diagnostic elements will be freed when all the diagnostics have been
+ -- emitted.
+ null;
+ end Destroy;
+
+ pragma Inline (Destroy);
+
+ package Edit_Lists is new Doubly_Linked_Lists
+ (Element_Type => Edit_Type,
+ "=" => "=",
+ Destroy_Element => Destroy,
+ Check_Tampering => False);
+
+ subtype Edit_List is Edit_Lists.Doubly_Linked_List;
+
type Artifact_Change is record
- File : String_Ptr;
- -- Name of the file
+ File_Index : Source_File_Index;
+ -- Index for the source file
Replacements : Edit_List;
-- Regions of texts to be edited
@@ -55,9 +129,7 @@ package body Diagnostics.SARIF_Emitter is
pragma Inline (Destroy);
function Equals (L, R : Artifact_Change) return Boolean is
- (L.File /= null
- and then R.File /= null
- and then L.File.all = R.File.all);
+ (L.File_Index = R.File_Index);
package Artifact_Change_Lists is new Doubly_Linked_Lists
(Element_Type => Artifact_Change,
@@ -71,7 +143,7 @@ package body Diagnostics.SARIF_Emitter is
-- Group edits of a Fix into Artifact_Changes that organize the edits by
-- file name.
- function Get_Unique_Rules (Diags : Diagnostic_List) return Diagnostic_List;
+ function Get_Unique_Rules return Error_Msg_List;
-- Get a list of diagnostics that have unique Diagnostic Id-s.
procedure Print_Replacement (Replacement : Edit_Type);
@@ -90,7 +162,7 @@ package body Diagnostics.SARIF_Emitter is
-- artifactChanges: [<ArtifactChange>]
-- }
- procedure Print_Fixes (Diag : Diagnostic_Type);
+ procedure Print_Fixes (E_Msg : Error_Msg_Object);
-- Print the fixes node
--
-- "fixes": [
@@ -119,15 +191,15 @@ package body Diagnostics.SARIF_Emitter is
-- replacements: [<Replacements>]
-- }
- procedure Print_Artifact_Location (File_Name : String);
+ procedure Print_Artifact_Location (Sfile : Source_File_Index);
-- Print an artifactLocation node
--
-- "artifactLocation": {
- -- "URI": <File_Name>
+ -- "uri": <File_Name>,
+ -- "uriBaseId": "PWD"
-- }
- procedure Print_Location (Loc : Labeled_Span_Type;
- Msg : String_Ptr);
+ procedure Print_Location (Loc : Labeled_Span_Type; Msg : String_Ptr);
-- Print a location node that consists of
-- * an optional message node
-- * a physicalLocation node
@@ -140,7 +212,7 @@ package body Diagnostics.SARIF_Emitter is
-- },
-- "physicalLocation": {
-- "artifactLocation": {
- -- "URI": <File_Name (Loc)>
+ -- "uri": <File_Name (Loc)>
-- },
-- "region": {
-- "startLine": <Line(Loc.Fst)>,
@@ -151,7 +223,7 @@ package body Diagnostics.SARIF_Emitter is
-- }
-- }
- procedure Print_Locations (Diag : Diagnostic_Type);
+ procedure Print_Locations (E_Msg : Error_Msg_Object);
-- Print a locations node that consists of multiple location nodes. However
-- typically just one location for the primary span of the diagnostic.
--
@@ -159,14 +231,26 @@ package body Diagnostics.SARIF_Emitter is
-- <Location (Primary_Span (Diag))>
-- ],
- procedure Print_Message (Text : String; Name : String := "message");
- -- Print a SARIF message node
+ procedure Print_Message (Text : String; Name : String := N_MESSAGE);
+ -- Print a SARIF message node.
--
- -- "message": {
+ -- There are many message type nodes in the SARIF report however they can
+ -- have a different node <Name>.
+ --
+ -- <Name>: {
-- "text": <text>
-- },
- procedure Print_Related_Locations (Diag : Diagnostic_Type);
+ procedure Print_Original_Uri_Base_Ids;
+ -- Print the originalUriBaseIds that holds the PWD value
+ --
+ -- "originalUriBaseIds": {
+ -- "PWD": {
+ -- "uri": "<current_working_directory>"
+ -- }
+ -- },
+
+ procedure Print_Related_Locations (E_Msg : Error_Msg_Object);
-- Print a relatedLocations node that consists of multiple location nodes.
-- Related locations are the non-primary spans of the diagnostic and the
-- primary locations of sub-diagnostics.
@@ -175,11 +259,12 @@ package body Diagnostics.SARIF_Emitter is
-- <Location (Diag.Loc)>
-- ],
- procedure Print_Region (Start_Line : Int;
- Start_Col : Int;
- End_Line : Int;
- End_Col : Int;
- Name : String := "region");
+ procedure Print_Region
+ (Start_Line : Int;
+ Start_Col : Int;
+ End_Line : Int;
+ End_Col : Int;
+ Name : String := N_REGION);
-- Print a region node.
--
-- More specifically a text region node that specifies the textual
@@ -207,7 +292,7 @@ package body Diagnostics.SARIF_Emitter is
-- the GNAT span definition and we amend the endColumn value so that it
-- matches the SARIF definition.
- procedure Print_Result (Diag : Diagnostic_Type);
+ procedure Print_Result (E_Msg : Error_Msg_Object);
-- {
-- "ruleId": <Diag.Id>,
-- "level": <Diag.Kind>,
@@ -218,7 +303,7 @@ package body Diagnostics.SARIF_Emitter is
-- "relatedLocations": [<Secondary_Locations>]
-- },
- procedure Print_Results (Diags : Diagnostic_List);
+ procedure Print_Results;
-- Print a results node that consists of multiple result nodes for each
-- diagnostic instance.
--
@@ -226,7 +311,7 @@ package body Diagnostics.SARIF_Emitter is
-- <Result (Diag)>
-- ]
- procedure Print_Rule (Diag : Diagnostic_Type);
+ procedure Print_Rule (E : Error_Msg_Object);
-- Print a rule node that consists of the following attributes:
-- * ruleId
-- * name
@@ -236,7 +321,7 @@ package body Diagnostics.SARIF_Emitter is
-- "name": <Human_Id(Diag)>
-- },
- procedure Print_Rules (Diags : Diagnostic_List);
+ procedure Print_Rules;
-- Print a rules node that consists of multiple rule nodes.
-- Rules are considered to be a set of unique diagnostics with the unique
-- id-s.
@@ -245,7 +330,7 @@ package body Diagnostics.SARIF_Emitter is
-- <Rule (Diag)>
-- ]
- procedure Print_Runs (Diags : Diagnostic_List);
+ procedure Print_Runs;
-- Print a runs node that can consist of multiple run nodes.
-- However for our report it consists of a single run that consists of
-- * a tool node
@@ -256,7 +341,7 @@ package body Diagnostics.SARIF_Emitter is
-- "results": [<Results (Diags)>]
-- }
- procedure Print_Tool (Diags : Diagnostic_List);
+ procedure Print_Tool;
-- Print a tool node that consists of
-- * a driver node that consists of:
-- * name
@@ -275,11 +360,9 @@ package body Diagnostics.SARIF_Emitter is
-- Destroy --
-------------
- procedure Destroy (Elem : in out Artifact_Change)
- is
-
+ procedure Destroy (Elem : in out Artifact_Change) is
begin
- Free (Elem.File);
+ Edit_Lists.Destroy (Elem.Replacements);
end Destroy;
--------------------------
@@ -294,8 +377,7 @@ package body Diagnostics.SARIF_Emitter is
-- Insert --
------------
- procedure Insert (Changes : Artifact_Change_List; E : Edit_Type)
- is
+ procedure Insert (Changes : Artifact_Change_List; E : Edit_Type) is
A : Artifact_Change;
It : Artifact_Change_Lists.Iterator :=
@@ -304,7 +386,7 @@ package body Diagnostics.SARIF_Emitter is
while Artifact_Change_Lists.Has_Next (It) loop
Artifact_Change_Lists.Next (It, A);
- if A.File.all = To_File_Name (E.Span.Ptr) then
+ if A.File_Index = Get_Source_File_Index (E.Span.Ptr) then
Edit_Lists.Append (A.Replacements, E);
return;
end if;
@@ -316,7 +398,7 @@ package body Diagnostics.SARIF_Emitter is
Edit_Lists.Append (Replacements, E);
Artifact_Change_Lists.Append
(Changes,
- (File => new String'(To_File_Name (E.Span.Ptr)),
+ (File_Index => Get_Source_File_Index (E.Span.Ptr),
Replacements => Replacements));
end;
end Insert;
@@ -325,12 +407,19 @@ package body Diagnostics.SARIF_Emitter is
E : Edit_Type;
- It : Edit_Lists.Iterator := Edit_Lists.Iterate (Fix.Edits);
+ It : Edit_Id;
+
+ -- Start of processing for Get_Artifact_Changes
+
begin
- while Edit_Lists.Has_Next (It) loop
- Edit_Lists.Next (It, E);
+ It := Fix.Edits;
+
+ while It /= No_Edit loop
+ E := Edits.Table (It);
Insert (Changes, E);
+
+ It := E.Next;
end loop;
return Changes;
@@ -340,46 +429,46 @@ package body Diagnostics.SARIF_Emitter is
-- Get_Unique_Rules --
----------------------
- function Get_Unique_Rules (Diags : Diagnostic_List)
- return Diagnostic_List
- is
- use Diagnostics.Diagnostics_Lists;
+ function Get_Unique_Rules return Error_Msg_List is
+ use Error_Msg_Lists;
- procedure Insert (Rules : Diagnostic_List; D : Diagnostic_Type);
+ procedure Insert (Rules : Error_Msg_List; E : Error_Msg_Object);
------------
-- Insert --
------------
- procedure Insert (Rules : Diagnostic_List; D : Diagnostic_Type) is
+ procedure Insert (Rules : Error_Msg_List; E : Error_Msg_Object) is
It : Iterator := Iterate (Rules);
- R : Diagnostic_Type;
+ R : Error_Msg_Object;
begin
while Has_Next (It) loop
Next (It, R);
- if R.Id = D.Id then
+ if R.Id = E.Id then
return;
- elsif R.Id > D.Id then
- Insert_Before (Rules, R, D);
+ elsif R.Id > E.Id then
+ Insert_Before (Rules, R, E);
return;
end if;
end loop;
- Append (Rules, D);
+ Append (Rules, E);
end Insert;
- D : Diagnostic_Type;
- Unique_Rules : constant Diagnostic_List := Create;
+ Unique_Rules : constant Error_Msg_List := Create;
+
+ E : Error_Msg_Id;
+
+ -- Start of processing for Get_Unique_Rules
- It : Iterator := Iterate (Diags);
begin
- if Present (Diags) then
- while Has_Next (It) loop
- Next (It, D);
- Insert (Unique_Rules, D);
- end loop;
- end if;
+ E := First_Error_Msg;
+ while E /= No_Error_Msg loop
+ Insert (Unique_Rules, Errors.Table (E));
+
+ Next_Error_Msg (E);
+ end loop;
return Unique_Rules;
end Get_Unique_Rules;
@@ -388,10 +477,9 @@ package body Diagnostics.SARIF_Emitter is
-- Print_Artifact_Change --
---------------------------
- procedure Print_Artifact_Change (A : Artifact_Change)
- is
- use Diagnostics.Edit_Lists;
- E : Edit_Type;
+ procedure Print_Artifact_Change (A : Artifact_Change) is
+ use Edit_Lists;
+ E : Edit_Type;
E_It : Iterator;
First : Boolean := True;
@@ -402,12 +490,12 @@ package body Diagnostics.SARIF_Emitter is
-- Print artifactLocation
- Print_Artifact_Location (A.File.all);
+ Print_Artifact_Location (A.File_Index);
Write_Char (',');
NL_And_Indent;
- Write_Str ("""" & "replacements" & """" & ": " & "[");
+ Write_Str ("""" & N_REPLACEMENTS & """" & ": " & "[");
Begin_Block;
NL_And_Indent;
@@ -443,14 +531,49 @@ package body Diagnostics.SARIF_Emitter is
-- Print_Artifact_Location --
-----------------------------
- procedure Print_Artifact_Location (File_Name : String) is
-
+ procedure Print_Artifact_Location (Sfile : Source_File_Index) is
+ Full_Name : constant String := Get_Name_String (Full_Ref_Name (Sfile));
begin
- Write_Str ("""" & "artifactLocation" & """" & ": " & "{");
+ Write_Str ("""" & N_ARTIFACT_LOCATION & """" & ": " & "{");
Begin_Block;
NL_And_Indent;
- Write_String_Attribute ("uri", File_Name);
+ if System.OS_Lib.Is_Absolute_Path (Full_Name) then
+ declare
+ Abs_Name : constant String :=
+ System.OS_Lib.Normalize_Pathname
+ (Name => Full_Name, Resolve_Links => False);
+ begin
+ -- We cannot create relative paths between different drives on
+ -- Windows. If the path is on a different drive than the PWD print
+ -- the absolute path in the URI and omit the baseUriId attribute.
+
+ if Osint.On_Windows
+ and then Abs_Name (Abs_Name'First) =
+ Current_Dir (Current_Dir'First)
+ then
+ Write_String_Attribute (N_URI, To_File_Uri (Abs_Name));
+ else
+ Write_String_Attribute
+ (N_URI, To_File_Uri (Relative_Path (Abs_Name, Current_Dir)));
+
+ Write_Char (',');
+ NL_And_Indent;
+
+ Write_String_Attribute (N_URI_BASE_ID, URI_Base_Id_Name);
+ end if;
+ end;
+ else
+ -- If the path was not absolute it was given relative to the
+ -- uriBaseId.
+
+ Write_String_Attribute (N_URI, To_File_Uri (Full_Name));
+
+ Write_Char (',');
+ NL_And_Indent;
+
+ Write_String_Attribute (N_URI_BASE_ID, URI_Base_Id_Name);
+ end if;
End_Block;
NL_And_Indent;
@@ -478,17 +601,18 @@ package body Diagnostics.SARIF_Emitter is
-- Print deletedRegion
- Print_Region (Start_Line => Line_Fst,
- Start_Col => Col_Fst,
- End_Line => Line_Lst,
- End_Col => Col_Lst,
- Name => "deletedRegion");
+ Print_Region
+ (Start_Line => Line_Fst,
+ Start_Col => Col_Fst,
+ End_Line => Line_Lst,
+ End_Col => Col_Lst,
+ Name => N_DELETED_REGION);
if Replacement.Text /= null then
Write_Char (',');
NL_And_Indent;
- Print_Message (Replacement.Text.all, "insertedContent");
+ Print_Message (Replacement.Text.all, N_INSERTED_CONTENT);
end if;
-- End replacement
@@ -512,7 +636,7 @@ package body Diagnostics.SARIF_Emitter is
-- Print the message if the location has one
if Fix.Description /= null then
- Print_Message (Fix.Description.all, "description");
+ Print_Message (Fix.Description.all, N_DESCRIPTION);
Write_Char (',');
NL_And_Indent;
@@ -522,9 +646,9 @@ package body Diagnostics.SARIF_Emitter is
use Artifact_Change_Lists;
Changes : Artifact_Change_List := Get_Artifact_Changes (Fix);
A : Artifact_Change;
- A_It : Iterator := Iterate (Changes);
+ A_It : Iterator := Iterate (Changes);
begin
- Write_Str ("""" & "artifactChanges" & """" & ": " & "[");
+ Write_Str ("""" & N_ARTIFACT_CHANGES & """" & ": " & "[");
Begin_Block;
while Has_Next (A_It) loop
@@ -557,31 +681,30 @@ package body Diagnostics.SARIF_Emitter is
-- Print_Fixes --
-----------------
- procedure Print_Fixes (Diag : Diagnostic_Type) is
- use Diagnostics.Fix_Lists;
- F : Fix_Type;
- F_It : Iterator;
+ procedure Print_Fixes (E_Msg : Error_Msg_Object) is
+ F : Fix_Type;
+ F_It : Fix_Id;
First : Boolean := True;
begin
- Write_Str ("""" & "fixes" & """" & ": " & "[");
+ Write_Str ("""" & N_FIXES & """" & ": " & "[");
Begin_Block;
- if Present (Diag.Fixes) then
- F_It := Iterate (Diag.Fixes);
- while Has_Next (F_It) loop
- Next (F_It, F);
+ F_It := E_Msg.Fixes;
+ while F_It /= No_Fix loop
+ F := Fixes.Table (F_It);
- if First then
- First := False;
- else
- Write_Char (',');
- end if;
+ if First then
+ First := False;
+ else
+ Write_Char (',');
+ end if;
- NL_And_Indent;
- Print_Fix (F);
- end loop;
- end if;
+ NL_And_Indent;
+ Print_Fix (F);
+
+ F_It := F.Next;
+ end loop;
End_Block;
NL_And_Indent;
@@ -601,6 +724,9 @@ package body Diagnostics.SARIF_Emitter is
function Compose_Command_Line return String is
Buffer : Bounded_String;
begin
+ Find_Program_Name;
+ Append (Buffer, Name_Buffer (1 .. Name_Len));
+ Append (Buffer, ' ');
Append (Buffer, Get_First_Main_File_Name);
for I in 1 .. Compilation_Switches_Last loop
declare
@@ -616,7 +742,7 @@ package body Diagnostics.SARIF_Emitter is
end Compose_Command_Line;
begin
- Write_Str ("""" & "invocations" & """" & ": " & "[");
+ Write_Str ("""" & N_INVOCATIONS & """" & ": " & "[");
Begin_Block;
NL_And_Indent;
@@ -626,13 +752,13 @@ package body Diagnostics.SARIF_Emitter is
-- Print commandLine
- Write_String_Attribute ("commandLine", Compose_Command_Line);
+ Write_String_Attribute (N_COMMAND_LINE, Compose_Command_Line);
Write_Char (',');
NL_And_Indent;
-- Print executionSuccessful
- Write_Boolean_Attribute ("executionSuccessful", Compilation_Errors);
+ Write_Boolean_Attribute (N_EXECUTION_SUCCESSFUL, Exit_Code = E_Success);
End_Block;
NL_And_Indent;
@@ -647,11 +773,12 @@ package body Diagnostics.SARIF_Emitter is
-- Print_Region --
------------------
- procedure Print_Region (Start_Line : Int;
- Start_Col : Int;
- End_Line : Int;
- End_Col : Int;
- Name : String := "region")
+ procedure Print_Region
+ (Start_Line : Int;
+ Start_Col : Int;
+ End_Line : Int;
+ End_Col : Int;
+ Name : String := N_REGION)
is
begin
@@ -659,22 +786,22 @@ package body Diagnostics.SARIF_Emitter is
Begin_Block;
NL_And_Indent;
- Write_Int_Attribute ("startLine", Start_Line);
+ Write_Int_Attribute (N_START_LINE, Start_Line);
Write_Char (',');
NL_And_Indent;
- Write_Int_Attribute ("startColumn", Start_Col);
+ Write_Int_Attribute (N_START_COLUMN, Start_Col);
Write_Char (',');
NL_And_Indent;
- Write_Int_Attribute ("endLine", End_Line);
+ Write_Int_Attribute (N_END_LINE, End_Line);
Write_Char (',');
NL_And_Indent;
-- Convert the end of the span to the definition of the endColumn
-- for a SARIF region.
- Write_Int_Attribute ("endColumn", End_Col + 1);
+ Write_Int_Attribute (N_END_COLUMN, End_Col + 1);
End_Block;
NL_And_Indent;
@@ -685,9 +812,7 @@ package body Diagnostics.SARIF_Emitter is
-- Print_Location --
--------------------
- procedure Print_Location (Loc : Labeled_Span_Type;
- Msg : String_Ptr)
- is
+ procedure Print_Location (Loc : Labeled_Span_Type; Msg : String_Ptr) is
-- Span start positions
Fst : constant Source_Ptr := Loc.Span.First;
@@ -713,23 +838,24 @@ package body Diagnostics.SARIF_Emitter is
NL_And_Indent;
end if;
- Write_Str ("""" & "physicalLocation" & """" & ": " & "{");
+ Write_Str ("""" & N_PHYSICAL_LOCATION & """" & ": " & "{");
Begin_Block;
NL_And_Indent;
-- Print artifactLocation
- Print_Artifact_Location (To_File_Name (Loc.Span.Ptr));
+ Print_Artifact_Location (Get_Source_File_Index (Loc.Span.Ptr));
Write_Char (',');
NL_And_Indent;
-- Print region
- Print_Region (Start_Line => Line_Fst,
- Start_Col => Col_Fst,
- End_Line => Line_Lst,
- End_Col => Col_Lst);
+ Print_Region
+ (Start_Line => Line_Fst,
+ Start_Col => Col_Fst,
+ End_Line => Line_Lst,
+ End_Col => Col_Lst);
End_Block;
NL_And_Indent;
@@ -744,18 +870,18 @@ package body Diagnostics.SARIF_Emitter is
-- Print_Locations --
---------------------
- procedure Print_Locations (Diag : Diagnostic_Type) is
- use Diagnostics.Labeled_Span_Lists;
+ procedure Print_Locations (E_Msg : Error_Msg_Object) is
Loc : Labeled_Span_Type;
- It : Iterator := Iterate (Diag.Locations);
+ It : Labeled_Span_Id;
First : Boolean := True;
begin
- Write_Str ("""" & "locations" & """" & ": " & "[");
+ Write_Str ("""" & N_LOCATIONS & """" & ": " & "[");
Begin_Block;
- while Has_Next (It) loop
- Next (It, Loc);
+ It := E_Msg.Locations;
+ while It /= No_Labeled_Span loop
+ Loc := Locations.Table (It);
-- Only the primary span is considered as the main location other
-- spans are considered related locations
@@ -770,51 +896,77 @@ package body Diagnostics.SARIF_Emitter is
NL_And_Indent;
Print_Location (Loc, Loc.Label);
end if;
+
+ It := Loc.Next;
end loop;
End_Block;
NL_And_Indent;
Write_Char (']');
-
end Print_Locations;
-------------------
-- Print_Message --
-------------------
- procedure Print_Message (Text : String; Name : String := "message") is
+ procedure Print_Message (Text : String; Name : String := N_MESSAGE) is
begin
Write_Str ("""" & Name & """" & ": " & "{");
Begin_Block;
NL_And_Indent;
- Write_String_Attribute ("text", Text);
+ Write_String_Attribute (N_TEXT, Text);
End_Block;
NL_And_Indent;
Write_Char ('}');
end Print_Message;
+ ---------------------------------
+ -- Print_Original_Uri_Base_Ids --
+ ---------------------------------
+
+ procedure Print_Original_Uri_Base_Ids is
+ begin
+ Write_Str ("""" & N_ORIGINAL_URI_BASE_IDS & """" & ": " & "{");
+ Begin_Block;
+ NL_And_Indent;
+
+ Write_Str ("""" & URI_Base_Id_Name & """" & ": " & "{");
+ Begin_Block;
+ NL_And_Indent;
+
+ Write_String_Attribute (N_URI, To_File_Uri (Current_Dir));
+
+ End_Block;
+ NL_And_Indent;
+ Write_Char ('}');
+
+ End_Block;
+ NL_And_Indent;
+ Write_Char ('}');
+ end Print_Original_Uri_Base_Ids;
+
-----------------------------
-- Print_Related_Locations --
-----------------------------
- procedure Print_Related_Locations (Diag : Diagnostic_Type) is
- Loc : Labeled_Span_Type;
- Loc_It : Labeled_Span_Lists.Iterator :=
- Labeled_Span_Lists.Iterate (Diag.Locations);
+ procedure Print_Related_Locations (E_Msg : Error_Msg_Object) is
+ Loc : Labeled_Span_Type;
+ Loc_It : Labeled_Span_Id;
- Sub : Sub_Diagnostic_Type;
- Sub_It : Sub_Diagnostic_Lists.Iterator;
+ Sub : Error_Msg_Object;
+ Sub_It : Error_Msg_Id;
First : Boolean := True;
begin
- Write_Str ("""" & "relatedLocations" & """" & ": " & "[");
+ Write_Str ("""" & N_RELATED_LOCATIONS & """" & ": " & "[");
Begin_Block;
-- Related locations are the non-primary spans of the diagnostic
- while Labeled_Span_Lists.Has_Next (Loc_It) loop
- Labeled_Span_Lists.Next (Loc_It, Loc);
+ Loc_It := E_Msg.Locations;
+ while Loc_It /= No_Labeled_Span loop
+ Loc := Locations.Table (Loc_It);
-- Non-primary spans are considered related locations
@@ -828,78 +980,64 @@ package body Diagnostics.SARIF_Emitter is
NL_And_Indent;
Print_Location (Loc, Loc.Label);
end if;
+ Loc_It := Loc.Next;
end loop;
-- And the sub-diagnostic locations
- if Sub_Diagnostic_Lists.Present (Diag.Sub_Diagnostics) then
- Sub_It := Sub_Diagnostic_Lists.Iterate (Diag.Sub_Diagnostics);
+ Sub_It := E_Msg.Next;
+ while Sub_It /= No_Error_Msg and then Errors.Table (Sub_It).Msg_Cont loop
+ Sub := Errors.Table (Sub_It);
- while Sub_Diagnostic_Lists.Has_Next (Sub_It) loop
- Sub_Diagnostic_Lists.Next (Sub_It, Sub);
-
- declare
- Found : Boolean := False;
+ declare
+ Found : Boolean := False;
- Prim_Loc : Labeled_Span_Type;
- begin
- if Labeled_Span_Lists.Present (Sub.Locations) then
- Loc_It := Labeled_Span_Lists.Iterate (Sub.Locations);
- while Labeled_Span_Lists.Has_Next (Loc_It) loop
- Labeled_Span_Lists.Next (Loc_It, Loc);
-
- -- For sub-diagnostic locations, only the primary span is
- -- considered.
-
- if not Found and then Loc.Is_Primary then
- Found := True;
- Prim_Loc := Loc;
- end if;
- end loop;
- else
+ Prim_Loc_Id : Labeled_Span_Id;
+ begin
+ Prim_Loc_Id := Primary_Location (Sub);
- -- If there are no locations for the sub-diagnostic then use
- -- the primary location of the main diagnostic.
+ if Prim_Loc_Id /= No_Labeled_Span then
+ Found := True;
+ else
+ Prim_Loc_Id := Primary_Location (E_Msg);
+ Found := True;
+ end if;
- Found := True;
- Prim_Loc := Primary_Location (Diag);
+ -- For mapping sub-diagnostics to related locations we have to
+ -- make some compromises in details.
+ --
+ -- Firstly we only make one entry that is for the primary span
+ -- of the sub-diagnostic.
+ --
+ -- Secondly this span can also have a label. However this
+ -- pattern is not advised and by default we include the message
+ -- of the sub-diagnostic as the message in location node since
+ -- it should have more information.
+
+ if Found then
+ if First then
+ First := False;
+ else
+ Write_Char (',');
end if;
+ NL_And_Indent;
+ Print_Location (Locations.Table (Prim_Loc_Id), Sub.Text);
+ end if;
+ end;
- -- For mapping sub-diagnostics to related locations we have to
- -- make some compromises in details.
- --
- -- Firstly we only make one entry that is for the primary span
- -- of the sub-diagnostic.
- --
- -- Secondly this span can also have a label. However this
- -- pattern is not advised and by default we include the message
- -- of the sub-diagnostic as the message in location node since
- -- it should have more information.
-
- if Found then
- if First then
- First := False;
- else
- Write_Char (',');
- end if;
- NL_And_Indent;
- Print_Location (Prim_Loc, Sub.Message);
- end if;
- end;
- end loop;
- end if;
+ Next_Continuation_Msg (Sub_It);
+ end loop;
End_Block;
NL_And_Indent;
Write_Char (']');
-
end Print_Related_Locations;
------------------
-- Print_Result --
------------------
- procedure Print_Result (Diag : Diagnostic_Type) is
+ procedure Print_Result (E_Msg : Error_Msg_Object) is
begin
Write_Char ('{');
@@ -908,42 +1046,42 @@ package body Diagnostics.SARIF_Emitter is
-- Print ruleId
- Write_String_Attribute ("ruleId", "[" & To_String (Diag.Id) & "]");
+ Write_String_Attribute (N_RULE_ID, "[" & To_String (E_Msg.Id) & "]");
Write_Char (',');
NL_And_Indent;
-- Print level
- Write_String_Attribute ("level", Kind_To_String (Diag));
+ Write_String_Attribute (N_LEVEL, Kind_To_String (E_Msg));
Write_Char (',');
NL_And_Indent;
-- Print message
- Print_Message (Diag.Message.all);
+ Print_Message (E_Msg.Text.all);
Write_Char (',');
NL_And_Indent;
-- Print locations
- Print_Locations (Diag);
+ Print_Locations (E_Msg);
Write_Char (',');
NL_And_Indent;
-- Print related locations
- Print_Related_Locations (Diag);
+ Print_Related_Locations (E_Msg);
Write_Char (',');
NL_And_Indent;
-- Print fixes
- Print_Fixes (Diag);
+ Print_Fixes (E_Msg);
End_Block;
NL_And_Indent;
@@ -955,32 +1093,28 @@ package body Diagnostics.SARIF_Emitter is
-- Print_Results --
-------------------
- procedure Print_Results (Diags : Diagnostic_List) is
- use Diagnostics.Diagnostics_Lists;
-
- D : Diagnostic_Type;
-
- It : Iterator := Iterate (All_Diagnostics);
+ procedure Print_Results is
+ E : Error_Msg_Id;
First : Boolean := True;
begin
- Write_Str ("""" & "results" & """" & ": " & "[");
+ Write_Str ("""" & N_RESULTS & """" & ": " & "[");
Begin_Block;
- if Present (Diags) then
- while Has_Next (It) loop
- Next (It, D);
+ E := First_Error_Msg;
+ while E /= No_Error_Msg loop
+ if First then
+ First := False;
+ else
+ Write_Char (',');
+ end if;
- if First then
- First := False;
- else
- Write_Char (',');
- end if;
+ NL_And_Indent;
- NL_And_Indent;
- Print_Result (D);
- end loop;
- end if;
+ Print_Result (Errors.Table (E));
+
+ Next_Error_Msg (E);
+ end loop;
End_Block;
NL_And_Indent;
@@ -991,21 +1125,21 @@ package body Diagnostics.SARIF_Emitter is
-- Print_Rule --
----------------
- procedure Print_Rule (Diag : Diagnostic_Type) is
- Human_Id : constant String_Ptr := Get_Human_Id (Diag);
+ procedure Print_Rule (E : Error_Msg_Object) is
+ Human_Id : constant String_Ptr := Get_Human_Id (E);
begin
Write_Char ('{');
Begin_Block;
NL_And_Indent;
- Write_String_Attribute ("id", "[" & To_String (Diag.Id) & "]");
+ Write_String_Attribute (N_ID, "[" & To_String (E.Id) & "]");
Write_Char (',');
NL_And_Indent;
if Human_Id = null then
- Write_String_Attribute ("name", "Uncategorized_Diagnostic");
+ Write_String_Attribute (N_NAME, "Uncategorized_Diagnostic");
else
- Write_String_Attribute ("name", Human_Id.all);
+ Write_String_Attribute (N_NAME, Human_Id.all);
end if;
End_Block;
@@ -1017,17 +1151,15 @@ package body Diagnostics.SARIF_Emitter is
-- Print_Rules --
-----------------
- procedure Print_Rules (Diags : Diagnostic_List) is
- use Diagnostics.Diagnostics_Lists;
-
- R : Diagnostic_Type;
- Rules : constant Diagnostic_List := Get_Unique_Rules (Diags);
-
- It : Iterator := Iterate (Rules);
+ procedure Print_Rules is
+ use Error_Msg_Lists;
+ R : Error_Msg_Object;
+ Rules : Error_Msg_List := Get_Unique_Rules;
+ It : Iterator := Iterate (Rules);
First : Boolean := True;
begin
- Write_Str ("""" & "rules" & """" & ": " & "[");
+ Write_Str ("""" & N_RULES & """" & ": " & "[");
Begin_Block;
while Has_Next (It) loop
@@ -1047,36 +1179,37 @@ package body Diagnostics.SARIF_Emitter is
NL_And_Indent;
Write_Char (']');
+ Error_Msg_Lists.Destroy (Rules);
end Print_Rules;
----------------
-- Print_Tool --
----------------
- procedure Print_Tool (Diags : Diagnostic_List) is
+ procedure Print_Tool is
begin
- Write_Str ("""" & "tool" & """" & ": " & "{");
+ Write_Str ("""" & N_TOOL & """" & ": " & "{");
Begin_Block;
NL_And_Indent;
-- -- Attributes of tool
- Write_Str ("""" & "driver" & """" & ": " & "{");
+ Write_Str ("""" & N_DRIVER & """" & ": " & "{");
Begin_Block;
NL_And_Indent;
-- Attributes of tool.driver
- Write_String_Attribute ("name", "GNAT");
+ Write_String_Attribute (N_NAME, "GNAT");
Write_Char (',');
NL_And_Indent;
- Write_String_Attribute ("version", Gnat_Version_String);
+ Write_String_Attribute (N_VERSION, Gnat_Version_String);
Write_Char (',');
NL_And_Indent;
- Print_Rules (Diags);
+ Print_Rules;
-- End of tool.driver
@@ -1097,10 +1230,10 @@ package body Diagnostics.SARIF_Emitter is
-- Print_Runs --
----------------
- procedure Print_Runs (Diags : Diagnostic_List) is
+ procedure Print_Runs is
begin
- Write_Str ("""" & "runs" & """" & ": " & "[");
+ Write_Str ("""" & N_RUNS & """" & ": " & "[");
Begin_Block;
NL_And_Indent;
@@ -1113,7 +1246,7 @@ package body Diagnostics.SARIF_Emitter is
-- A run consists of a tool
- Print_Tool (Diags);
+ Print_Tool;
Write_Char (',');
NL_And_Indent;
@@ -1124,9 +1257,13 @@ package body Diagnostics.SARIF_Emitter is
Write_Char (',');
NL_And_Indent;
+ Print_Original_Uri_Base_Ids;
+ Write_Char (',');
+ NL_And_Indent;
+
-- A run consists of results
- Print_Results (Diags);
+ Print_Results;
-- End of run
@@ -1147,21 +1284,21 @@ package body Diagnostics.SARIF_Emitter is
-- Print_SARIF_Report --
------------------------
- procedure Print_SARIF_Report (Diags : Diagnostic_List) is
+ procedure Print_SARIF_Report is
begin
Write_Char ('{');
Begin_Block;
NL_And_Indent;
- Write_String_Attribute ("$schema", SARIF_Schema);
+ Write_String_Attribute (N_SCHEMA, SARIF_Schema);
Write_Char (',');
NL_And_Indent;
- Write_String_Attribute ("version", SARIF_Version);
+ Write_String_Attribute (N_VERSION, SARIF_Version);
Write_Char (',');
NL_And_Indent;
- Print_Runs (Diags);
+ Print_Runs;
End_Block;
NL_And_Indent;
@@ -1170,4 +1307,4 @@ package body Diagnostics.SARIF_Emitter is
Write_Eol;
end Print_SARIF_Report;
-end Diagnostics.SARIF_Emitter;
+end Erroutc.SARIF_Emitter;
diff --git a/gcc/ada/diagnostics-sarif_emitter.ads b/gcc/ada/erroutc-sarif_emitter.ads
index 4c8ec78..9272b54 100644
--- a/gcc/ada/diagnostics-sarif_emitter.ads
+++ b/gcc/ada/erroutc-sarif_emitter.ads
@@ -23,7 +23,7 @@
-- --
------------------------------------------------------------------------------
-package Diagnostics.SARIF_Emitter is
+package Erroutc.SARIF_Emitter is
- procedure Print_SARIF_Report (Diags : Diagnostic_List);
-end Diagnostics.SARIF_Emitter;
+ procedure Print_SARIF_Report;
+end Erroutc.SARIF_Emitter;
diff --git a/gcc/ada/erroutc.adb b/gcc/ada/erroutc.adb
index c8de60d..14a11ff 100644
--- a/gcc/ada/erroutc.adb
+++ b/gcc/ada/erroutc.adb
@@ -225,49 +225,11 @@ package body Erroutc is
------------------------
function Compilation_Errors return Boolean is
- Warnings_Count : constant Int := Warnings_Detected;
begin
- if Total_Errors_Detected /= 0 then
- return True;
-
- elsif Warnings_Treated_As_Errors /= 0 then
- return True;
-
- -- We should never treat warnings that originate from a
- -- Compile_Time_Warning pragma as an error. Warnings_Count is the sum
- -- of both "normal" and Compile_Time_Warning warnings. This means that
- -- there are only one or more non-Compile_Time_Warning warnings when
- -- Warnings_Count is greater than Count_Compile_Time_Pragma_Warnings.
-
- elsif Warning_Mode = Treat_As_Error
- and then Warnings_Count > Count_Compile_Time_Pragma_Warnings
- then
- return True;
- end if;
-
- return False;
+ return Total_Errors_Detected /= 0
+ or else Warnings_Treated_As_Errors /= 0;
end Compilation_Errors;
- ----------------------------------------
- -- Count_Compile_Time_Pragma_Warnings --
- ----------------------------------------
-
- function Count_Compile_Time_Pragma_Warnings return Int is
- Result : Int := 0;
- begin
- for J in 1 .. Errors.Last loop
- begin
- if Errors.Table (J).Kind = Warning
- and then Errors.Table (J).Compile_Time_Pragma
- and then not Errors.Table (J).Deleted
- then
- Result := Result + 1;
- end if;
- end;
- end loop;
- return Result;
- end Count_Compile_Time_Pragma_Warnings;
-
------------------------------
-- Decrease_Error_Msg_Count --
------------------------------
@@ -282,6 +244,10 @@ package body Erroutc is
when Warning | Style =>
Warnings_Detected := Warnings_Detected - 1;
+ if E.Warn_Err /= None then
+ Warnings_Treated_As_Errors := Warnings_Treated_As_Errors - 1;
+ end if;
+
when High_Check | Medium_Check | Low_Check =>
Check_Messages := Check_Messages - 1;
@@ -340,7 +306,7 @@ package body Erroutc is
w (" Line = ", Int (E.Line));
w (" Col = ", Int (E.Col));
w (" Kind = ", E.Kind'Img);
- w (" Warn_Err = ", E.Warn_Err);
+ w (" Warn_Err = ", E.Warn_Err'Img);
w (" Warn_Chr = '" & E.Warn_Chr & ''');
w (" Uncond = ", E.Uncond);
w (" Msg_Cont = ", E.Msg_Cont);
@@ -372,11 +338,16 @@ package body Erroutc is
------------------------
function Get_Warning_Option (Id : Error_Msg_Id) return String is
- Is_Style : constant Boolean := Errors.Table (Id).Kind in Style;
- Warn_Chr : constant String (1 .. 2) := Errors.Table (Id).Warn_Chr;
+ begin
+ return Get_Warning_Option (Errors.Table (Id));
+ end Get_Warning_Option;
+
+ function Get_Warning_Option (E : Error_Msg_Object) return String is
+ Is_Style : constant Boolean := E.Kind in Style;
+ Warn_Chr : constant String (1 .. 2) := E.Warn_Chr;
begin
- if Has_Switch_Tag (Errors.Table (Id))
+ if Has_Switch_Tag (E)
and then Warn_Chr (1) /= '?'
then
if Warn_Chr = "$ " then
@@ -398,11 +369,16 @@ package body Erroutc is
---------------------
function Get_Warning_Tag (Id : Error_Msg_Id) return String is
- Warn_Chr : constant String (1 .. 2) := Errors.Table (Id).Warn_Chr;
- Option : constant String := Get_Warning_Option (Id);
+ begin
+ return Get_Warning_Tag (Errors.Table (Id));
+ end Get_Warning_Tag;
+
+ function Get_Warning_Tag (E : Error_Msg_Object) return String is
+ Warn_Chr : constant String (1 .. 2) := E.Warn_Chr;
+ Option : constant String := Get_Warning_Option (E);
begin
- if Has_Switch_Tag (Id) then
+ if Has_Switch_Tag (E) then
if Warn_Chr = "? " then
return "[enabled by default]";
elsif Warn_Chr = "* " then
@@ -429,6 +405,24 @@ package body Erroutc is
when Warning | Style =>
Warnings_Detected := Warnings_Detected + 1;
+ if E.Warn_Err /= None then
+ Warnings_Treated_As_Errors := Warnings_Treated_As_Errors + 1;
+
+ -- Propagate Warn_Err to all of the preceeding continuation
+ -- messages and the main message.
+
+ for J in reverse 1 .. Errors.Last loop
+ if Errors.Table (J).Warn_Err = None then
+ Errors.Table (J).Warn_Err := E.Warn_Err;
+
+ Warnings_Treated_As_Errors :=
+ Warnings_Treated_As_Errors + 1;
+ end if;
+
+ exit when not Errors.Table (J).Msg_Cont;
+ end loop;
+ end if;
+
when High_Check | Medium_Check | Low_Check =>
Check_Messages := Check_Messages + 1;
@@ -491,6 +485,134 @@ package body Erroutc is
E_Msg.Kind in Warning | Info | Style and then E_Msg.Warn_Chr /= " ";
end Has_Switch_Tag;
+ --------------------
+ -- Next_Error_Msg --
+ --------------------
+
+ procedure Next_Error_Msg (E : in out Error_Msg_Id) is
+ begin
+ loop
+ E := Errors.Table (E).Next;
+ exit when E = No_Error_Msg;
+ exit when not Errors.Table (E).Deleted
+ and then not Errors.Table (E).Msg_Cont;
+ end loop;
+ end Next_Error_Msg;
+
+ ---------------------------
+ -- Next_Continuation_Msg --
+ ---------------------------
+
+ procedure Next_Continuation_Msg (E : in out Error_Msg_Id) is
+ begin
+ E := Errors.Table (E).Next;
+
+ if E = No_Error_Msg or else not Errors.Table (E).Msg_Cont then
+ E := No_Error_Msg;
+ end if;
+ end Next_Continuation_Msg;
+
+ ----------------------
+ -- Primary_Location --
+ ----------------------
+
+ function Primary_Location (E : Error_Msg_Object) return Labeled_Span_Id is
+ L : Labeled_Span_Id;
+ begin
+ L := E.Locations;
+ while L /= No_Labeled_Span loop
+ if Locations.Table (L).Is_Primary then
+ return L;
+ end if;
+
+ L := Locations.Table (L).Next;
+ end loop;
+
+ return No_Labeled_Span;
+ end Primary_Location;
+
+ ------------------
+ -- Get_Human_Id --
+ ------------------
+
+ function Get_Human_Id (E : Error_Msg_Object) return String_Ptr is
+ begin
+ if E.Switch = No_Switch_Id then
+ return Diagnostic_Entries (E.Id).Human_Id;
+ else
+ return Get_Switch (E).Human_Id;
+ end if;
+ end Get_Human_Id;
+
+ --------------------
+ -- Get_Doc_Switch --
+ --------------------
+
+ function Get_Doc_Switch (E : Error_Msg_Object) return String is
+ begin
+ if Warning_Doc_Switch
+ and then E.Warn_Chr /= " "
+ and then E.Kind in Info
+ | Style
+ | Warning
+ then
+ if E.Switch = No_Switch_Id then
+ if E.Warn_Chr = "* " then
+ return "[restriction warning]";
+
+ -- Info messages can have a switch tag but they should not have
+ -- a default switch tag.
+
+ elsif E.Kind /= Info then
+
+ -- For Default_Warning
+
+ return "[enabled by default]";
+ end if;
+ else
+ declare
+ S : constant Switch_Type := Get_Switch (E);
+ begin
+ return "[-" & S.Short_Name.all & "]";
+ end;
+ end if;
+ end if;
+
+ return "";
+ end Get_Doc_Switch;
+
+ ----------------
+ -- Get_Switch --
+ ----------------
+
+ function Get_Switch (E : Error_Msg_Object) return Switch_Type is
+ begin
+ return Get_Switch (E.Switch);
+ end Get_Switch;
+
+ -------------------
+ -- Get_Switch_Id --
+ -------------------
+
+ function Get_Switch_Id (E : Error_Msg_Object) return Switch_Id is
+ begin
+ return Get_Switch_Id (E.Kind, E.Warn_Chr);
+ end Get_Switch_Id;
+
+ function Get_Switch_Id
+ (Kind : Error_Msg_Type; Warn_Chr : String) return Switch_Id is
+ begin
+ if Warn_Chr = "$ " then
+ return Get_Switch_Id ("gnatel");
+ elsif Kind in Warning | Info then
+ return Get_Switch_Id ("gnatw" & Warn_Chr);
+ elsif Kind = Style then
+ return Get_Switch_Id ("gnaty" & Warn_Chr);
+ else
+ return No_Switch_Id;
+ end if;
+ end Get_Switch_Id;
+
-------------
-- Matches --
-------------
@@ -752,7 +874,7 @@ package body Erroutc is
-- Output_Text_Within --
------------------------
- procedure Output_Text_Within (Txt : String_Ptr; Line_Length : Nat) is
+ procedure Output_Text_Within (Txt : String; Line_Length : Nat) is
Offs : constant Nat := Column - 1;
-- Offset to start of message, used for continuations
@@ -869,98 +991,59 @@ package body Erroutc is
procedure Output_Msg_Text (E : Error_Msg_Id) is
- E_Msg : Error_Msg_Object renames Errors.Table (E);
- Text : constant String_Ptr := E_Msg.Text;
- Tag : constant String := Get_Warning_Tag (E);
- Txt : String_Ptr;
-
- Line_Length : constant Nat :=
+ E_Msg : Error_Msg_Object renames Errors.Table (E);
+ Text : constant String_Ptr := E_Msg.Text;
+ Tag : constant String := Get_Warning_Tag (E);
+ SGR_Code : constant String := Get_SGR_Code (E_Msg);
+ Kind_Prefix : constant String :=
+ (if E_Msg.Kind = Style then Style_Prefix
+ else Kind_To_String (E_Msg) & ": ");
+ Buf : Bounded_String (Max_Msg_Length);
+ Line_Length : constant Nat :=
(if Error_Msg_Line_Length = 0 then Nat'Last
else Error_Msg_Line_Length);
begin
- -- Postfix warning tag to message if needed
-
- if Tag /= "" and then Warning_Doc_Switch then
- Txt := new String'(Text.all & ' ' & Tag);
- else
- Txt := Text;
+ -- Prefix with "error:" rather than warning.
+ -- Additionally include the style suffix when needed.
+
+ if E_Msg.Warn_Err in From_Pragma | From_Run_Time_As_Err then
+ Append
+ (Buf,
+ SGR_Error & "error: " & SGR_Reset &
+ (if E_Msg.Kind = Style then Style_Prefix else ""));
+
+ -- Print the message kind prefix
+ -- * Info/Style/Warning messages
+ -- * Check messages that are not continuations in the pretty printer
+ -- * Error messages when error tags are allowed
+
+ elsif E_Msg.Kind in Info | Style | Warning
+ or else
+ (E_Msg.Kind in High_Check | Medium_Check | Low_Check
+ and then not (E_Msg.Msg_Cont and then Debug_Flag_FF))
+ or else
+ (E_Msg.Kind in Error | Non_Serious_Error
+ and then Opt.Unique_Error_Tag)
+ then
+ Append (Buf, SGR_Code & Kind_Prefix & SGR_Reset);
end if;
- -- If -gnatdF is used, continuation messages follow the main message
- -- with only an indentation of two space characters, without repeating
- -- any prefix.
-
- if Debug_Flag_FF and then E_Msg.Msg_Cont then
- null;
-
- -- For info messages, prefix message with "info: "
-
- elsif E_Msg.Kind = Info then
- Txt := new String'(SGR_Note & "info: " & SGR_Reset & Txt.all);
-
- -- Warning treated as error
-
- elsif E_Msg.Warn_Err then
-
- -- We prefix with "error:" rather than warning: and postfix
- -- [warning-as-error] at the end.
-
- Warnings_Treated_As_Errors := Warnings_Treated_As_Errors + 1;
- Txt := new String'(SGR_Error & "error: " & SGR_Reset
- & Txt.all & " [warning-as-error]");
-
- -- Normal warning, prefix with "warning: "
-
- elsif E_Msg.Kind = Warning then
- Txt := new String'(SGR_Warning & "warning: " & SGR_Reset & Txt.all);
-
- -- No prefix needed for style message, "(style)" is there already
-
- elsif E_Msg.Kind = Style then
- if Txt (Txt'First .. Txt'First + 6) = "(style)" then
- Txt := new String'(SGR_Warning & "(style)" & SGR_Reset
- & Txt (Txt'First + 7 .. Txt'Last));
- end if;
-
- -- No prefix needed for check message, severity is there already
-
- elsif E_Msg.Kind in High_Check | Medium_Check | Low_Check then
-
- -- The message format is "severity: ..."
- --
- -- Enclose the severity with an SGR control string if requested
+ Append (Buf, Text.all);
- if Use_SGR_Control then
- declare
- Msg : String renames Text.all;
- Colon : Natural := 0;
- begin
- -- Find first colon
-
- for J in Msg'Range loop
- if Msg (J) = ':' then
- Colon := J;
- exit;
- end if;
- end loop;
-
- pragma Assert (Colon > 0);
+ -- Postfix warning tag to message if needed
- Txt := new String'(SGR_Error
- & Msg (Msg'First .. Colon)
- & SGR_Reset
- & Msg (Colon + 1 .. Msg'Last));
- end;
- end if;
+ if Tag /= "" and then Warning_Doc_Switch then
+ Append (Buf, ' ' & Tag);
+ end if;
- -- All other cases, add "error: " if unique error tag set
+ -- Postfix [warning-as-error] at the end
- elsif Opt.Unique_Error_Tag then
- Txt := new String'(SGR_Error & "error: " & SGR_Reset & Txt.all);
+ if E_Msg.Warn_Err = From_Pragma then
+ Append (Buf, " " & Warn_As_Err_Tag);
end if;
- Output_Text_Within (Txt, Line_Length);
+ Output_Text_Within (To_String (Buf), Line_Length);
end Output_Msg_Text;
---------------------
@@ -1051,41 +1134,51 @@ package body Erroutc is
Error_Msg_Kind := Error;
Is_Unconditional_Msg := False;
- Is_Runtime_Raise := False;
+ Is_Runtime_Raise_Msg := False;
Warning_Msg_Char := " ";
-- Check style message
- if Msg'Length > 7
- and then Msg (Msg'First .. Msg'First + 6) = "(style)"
+ if Msg'Length > Style_Prefix'Length
+ and then
+ Msg (Msg'First .. Msg'First + Style_Prefix'Length - 1) =
+ Style_Prefix
then
Error_Msg_Kind := Style;
-- Check info message
- elsif Msg'Length > 6
- and then Msg (Msg'First .. Msg'First + 5) = "info: "
+ elsif Msg'Length > Info_Prefix'Length
+ and then
+ Msg (Msg'First .. Msg'First + Info_Prefix'Length - 1) =
+ Info_Prefix
then
Error_Msg_Kind := Info;
-- Check high check message
- elsif Msg'Length > 6
- and then Msg (Msg'First .. Msg'First + 5) = "high: "
+ elsif Msg'Length > High_Prefix'Length
+ and then
+ Msg (Msg'First .. Msg'First + High_Prefix'Length - 1) =
+ High_Prefix
then
Error_Msg_Kind := High_Check;
-- Check medium check message
- elsif Msg'Length > 8
- and then Msg (Msg'First .. Msg'First + 7) = "medium: "
+ elsif Msg'Length > Medium_Prefix'Length
+ and then
+ Msg (Msg'First .. Msg'First + Medium_Prefix'Length - 1) =
+ Medium_Prefix
then
Error_Msg_Kind := Medium_Check;
-- Check low check message
- elsif Msg'Length > 5
- and then Msg (Msg'First .. Msg'First + 4) = "low: "
+ elsif Msg'Length > Low_Prefix'Length
+ and then
+ Msg (Msg'First .. Msg'First + Low_Prefix'Length - 1) =
+ Low_Prefix
then
Error_Msg_Kind := Low_Check;
end if;
@@ -1211,6 +1304,8 @@ package body Erroutc is
E := First_Error_Msg;
while E /= No_Error_Msg loop
while To_Be_Purged (Errors.Table (E).Next) loop
+ Errors.Table (Errors.Table (E).Next).Deleted := True;
+
Errors.Table (E).Next :=
Errors.Table (Errors.Table (E).Next).Next;
end loop;
@@ -2004,6 +2099,14 @@ package body Erroutc is
return False;
end Warning_Treated_As_Error;
+ function Warning_Treated_As_Error (E : Error_Msg_Object) return Boolean is
+
+ begin
+ return
+ Warning_Treated_As_Error (E.Text.all)
+ or else Warning_Treated_As_Error (Get_Warning_Tag (E));
+ end Warning_Treated_As_Error;
+
-------------------------
-- Warnings_Suppressed --
-------------------------
@@ -2080,76 +2183,32 @@ package body Erroutc is
Write_Str (" errors");
end if;
- -- We now need to output warnings. When using -gnatwe, all warnings
- -- should be treated as errors, except for warnings originating from
- -- the use of the Compile_Time_Warning pragma. Another situation
- -- where a warning might be treated as an error is when the source
- -- code contains a Warning_As_Error pragma.
- -- When warnings are treated as errors, we still log them as
- -- warnings, but we add a message denoting how many of these warnings
- -- are also errors.
-
- declare
- Warnings_Count : constant Int := Warnings_Detected;
-
- Compile_Time_Warnings : Int;
- -- Number of warnings that come from a Compile_Time_Warning
- -- pragma.
+ if Warnings_Detected > 0 then
+ Write_Str (", ");
+ Write_Int (Warnings_Detected);
+ Write_Str (" warning");
- Non_Compile_Time_Warnings : Int;
- -- Number of warnings that do not come from a Compile_Time_Warning
- -- pragmas.
+ if Warnings_Detected > 1 then
+ Write_Char ('s');
+ end if;
- begin
- if Warnings_Count > 0 then
- Write_Str (", ");
- Write_Int (Warnings_Count);
- Write_Str (" warning");
+ if Warnings_Treated_As_Errors > 0 then
+ Write_Str (" (");
- if Warnings_Count > 1 then
- Write_Char ('s');
+ if Warnings_Treated_As_Errors /= Warnings_Detected then
+ Write_Int (Warnings_Treated_As_Errors);
+ Write_Str (" ");
end if;
- Compile_Time_Warnings := Count_Compile_Time_Pragma_Warnings;
- Non_Compile_Time_Warnings :=
- Warnings_Count - Compile_Time_Warnings;
-
- if Warning_Mode = Treat_As_Error
- and then Non_Compile_Time_Warnings > 0
- then
- Write_Str (" (");
-
- if Compile_Time_Warnings > 0 then
- Write_Int (Non_Compile_Time_Warnings);
- Write_Str (" ");
- end if;
-
- Write_Str ("treated as error");
-
- if Non_Compile_Time_Warnings > 1 then
- Write_Char ('s');
- end if;
+ Write_Str ("treated as error");
- Write_Char (')');
-
- elsif Warnings_Treated_As_Errors > 0 then
- Write_Str (" (");
-
- if Warnings_Treated_As_Errors /= Warnings_Count then
- Write_Int (Warnings_Treated_As_Errors);
- Write_Str (" ");
- end if;
-
- Write_Str ("treated as error");
-
- if Warnings_Treated_As_Errors > 1 then
- Write_Str ("s");
- end if;
-
- Write_Str (")");
+ if Warnings_Treated_As_Errors > 1 then
+ Write_Str ("s");
end if;
+
+ Write_Str (")");
end if;
- end;
+ end if;
if Info_Messages /= 0 then
Write_Str (", ");
diff --git a/gcc/ada/erroutc.ads b/gcc/ada/erroutc.ads
index 3f080a5..2d8499a 100644
--- a/gcc/ada/erroutc.ads
+++ b/gcc/ada/erroutc.ads
@@ -27,10 +27,16 @@
-- reporting packages, including Errout and Prj.Err.
with Table;
+with Errsw; use Errsw;
+with Errid; use Errid;
+with Osint; use Osint;
with Types; use Types;
package Erroutc is
+ Exit_Code : Exit_Code_Type := E_Success;
+ -- Exit_Code used at the end of the compilation
+
type Error_Msg_Type is
(Error, -- Default value
Non_Serious_Error,
@@ -76,15 +82,14 @@ package Erroutc is
-- Set true to indicate that the current message originates from a
-- Compile_Time_Warning or Compile_Time_Error pragma.
+ Is_Runtime_Raise_Msg : Boolean := False;
+ -- Set to True to indicate that the current message is a constraint error
+ -- that will be raised at runtime (contains [).
+
Is_Unconditional_Msg : Boolean := False;
-- Set True to indicate that the current message contains the insertion
-- character ! and is thus to be treated as an unconditional message.
- Is_Runtime_Raise : Boolean := False;
- -- Set to True to indicate that the current message is a warning about a
- -- constraint error that will be raised at runtime (contains [ and switch
- -- -gnatwE was given)..
-
Error_Msg_Kind : Error_Msg_Type := Error;
Warning_Msg_Char : String (1 .. 2);
@@ -177,6 +182,95 @@ package Erroutc is
-- The following record type and table are used to represent error
-- messages, with one entry in the table being allocated for each message.
+ type Labeled_Span_Id is new Int;
+ No_Labeled_Span : constant Labeled_Span_Id := 0;
+
+ type Labeled_Span_Type is record
+ Label : String_Ptr := null;
+ -- Text associated with the span
+
+ Span : Source_Span := (others => No_Location);
+ -- Textual region in the source code
+
+ Is_Primary : Boolean := True;
+ -- Primary spans are used to indicate the primary location of the
+ -- diagnostic. Typically there should just be one primary span per
+ -- diagnostic.
+ -- Non-primary spans are used to indicate secondary locations and
+ -- typically are formatted in a different way or omitted in some
+ -- contexts.
+
+ Is_Region : Boolean := False;
+ -- Regional spans are multiline spans that have a unique way of being
+ -- displayed in the pretty output.
+
+ Next : Labeled_Span_Id := No_Labeled_Span;
+
+ end record;
+
+ No_Labeled_Span_Object : Labeled_Span_Type := (others => <>);
+
+ package Locations is new Table.Table (
+ Table_Component_Type => Labeled_Span_Type,
+ Table_Index_Type => Labeled_Span_Id,
+ Table_Low_Bound => 1,
+ Table_Initial => 200,
+ Table_Increment => 200,
+ Table_Name => "Location");
+
+ type Edit_Id is new Int;
+ No_Edit : constant Edit_Id := 0;
+
+ type Edit_Type is record
+ Span : Source_Span;
+ -- Region of the file to be removed
+
+ Text : String_Ptr;
+ -- Text to be inserted at the start location of the span
+
+ Next : Edit_Id := No_Edit;
+ end record;
+
+ package Edits is new Table.Table (
+ Table_Component_Type => Edit_Type,
+ Table_Index_Type => Edit_Id,
+ Table_Low_Bound => 1,
+ Table_Initial => 200,
+ Table_Increment => 200,
+ Table_Name => "Edit");
+
+ type Fix_Id is new Int;
+ No_Fix : constant Fix_Id := 0;
+
+ type Fix_Type is record
+ Description : String_Ptr := null;
+ -- Message describing the fix that will be displayed to the user.
+
+ Edits : Edit_Id := No_Edit;
+ -- File changes for the fix.
+
+ Next : Fix_Id := No_Fix;
+ end record;
+
+ package Fixes is new Table.Table (
+ Table_Component_Type => Fix_Type,
+ Table_Index_Type => Fix_Id,
+ Table_Low_Bound => 1,
+ Table_Initial => 200,
+ Table_Increment => 200,
+ Table_Name => "Fix");
+
+ type Warning_As_Error_Kind is
+ (None, From_Pragma, From_Warn_As_Err, From_Run_Time_As_Err);
+ -- The reason for a warning to be converted as an error:
+ -- * None - Regular warning. Default value for non-warning messages.
+ -- * From_Pragma - Warning converted to an error due to a pragma
+ -- Warning_As_Error.
+ -- * From_Warn_As_Err - Warning converted to an error because the
+ -- Warning_Mode was set to Treat_As_Errors by -gnatwe.
+ -- * From_Run_Time_As_Err - Warning converted to an error because the
+ -- Warning_Mode was set to Treat_Run_Time_Warnings_As_Errors by -gnatwE.
+
type Error_Msg_Object is record
Text : String_Ptr;
-- Text of error message, fully expanded with all insertions
@@ -224,9 +318,11 @@ package Erroutc is
-- True if the message originates from a Compile_Time_Warning or
-- Compile_Time_Error pragma
- Warn_Err : Boolean;
- -- True if this is a warning message which is to be treated as an error
- -- as a result of a match with a Warning_As_Error pragma.
+ Warn_Err : Warning_As_Error_Kind;
+ -- By default this is None. If the warning was converted by some reason
+ -- to an error then it has a different value. Depending on the value
+ -- the warning will be printed in a different way due to historical
+ -- reasons.
Warn_Chr : String (1 .. 2);
-- See Warning_Msg_Char
@@ -248,6 +344,27 @@ package Erroutc is
-- in the circuit for deleting duplicate/redundant error messages.
Kind : Error_Msg_Type;
+ -- The kind of the error message. This determines how the message
+ -- should be handled and what kind of prefix should be added before the
+ -- message text.
+
+ Switch : Switch_Id := No_Switch_Id;
+ -- Identifier for a given switch that enabled the diagnostic
+
+ Id : Diagnostic_Id := No_Diagnostic_Id;
+ -- Unique error code for the given message
+
+ Locations : Labeled_Span_Id := No_Labeled_Span;
+ -- Identifier to the first location identified by the error message.
+ -- These locations are marked with an underlying span line and
+ -- optionally given a short label.
+
+ Fixes : Fix_Id := No_Fix;
+ -- Identifier to the first fix object for the error message. The fix
+ -- contains a suggestion to prevent the error from being triggered.
+ -- This includes edits that can be made to the source code. An edit
+ -- contians a region of the code that needs to be changed and the new
+ -- text that should be inserted to that region.
end record;
package Errors is new Table.Table (
@@ -268,6 +385,56 @@ package Erroutc is
-- as the physically last entry in the error message table, since messages
-- are not always inserted in sequence.
+ procedure Next_Error_Msg (E : in out Error_Msg_Id);
+ -- Update E to point to the next error message in the list of error
+ -- messages. Skip deleted and continuation messages.
+
+ procedure Next_Continuation_Msg (E : in out Error_Msg_Id);
+ -- Update E to point to the next continuation message
+
+ function Kind_To_String (E : Error_Msg_Object) return String is
+ (if E.Warn_Err in From_Pragma | From_Run_Time_As_Err then "error"
+ else
+ (case E.Kind is
+ when Error | Non_Serious_Error => "error",
+ when Warning => "warning",
+ when Style => "style",
+ when Info => "info",
+ when Low_Check => "low",
+ when Medium_Check => "medium",
+ when High_Check => "high"));
+ -- Returns the name of the error message kind. If it is a warning that has
+ -- been turned to an error then it returns "error".
+
+ function Get_Doc_Switch (E : Error_Msg_Object) return String;
+ -- Returns the documentation switch for a given Error_Msg_Object.
+ --
+ -- This either the name of the switch encased in brackets. E.g [-gnatwx].
+ --
+ -- If the Warn_Char is "* " is then it will return [restriction warning].
+ --
+ -- Otherwise for messages without a switch it will return
+ -- [enabled by default] .
+
+ function Primary_Location (E : Error_Msg_Object) return Labeled_Span_Id;
+ -- Returns the first Primary Labeled_Span associated with the error
+ -- message. Otherwise it returns No_Labeled_Span.
+
+ function Get_Human_Id (E : Error_Msg_Object) return String_Ptr;
+ -- Returns a longer human readable name for the switch associated with the
+ -- error message.
+
+ function Get_Switch (E : Error_Msg_Object) return Switch_Type;
+ -- Returns the Switch information for the given error message
+
+ function Get_Switch_Id (E : Error_Msg_Object) return Switch_Id;
+ -- Returns the Switch information identifier for the given error message
+
+ function Get_Switch_Id
+ (Kind : Error_Msg_Type; Warn_Chr : String) return Switch_Id;
+ -- Returns the Switch information identifier based on the error kind and
+ -- the warning character.
+
--------------------------
-- Warning Mode Control --
--------------------------
@@ -422,6 +589,14 @@ package Erroutc is
function SGR_Locus return String is
(SGR_Seq (Color_Bold));
+ function Get_SGR_Code (E_Msg : Error_Msg_Object) return String is
+ (if E_Msg.Warn_Err /= None then SGR_Error
+ else
+ (case E_Msg.Kind is
+ when Warning | Style => SGR_Warning,
+ when Info => SGR_Note,
+ when others => SGR_Error));
+
-----------------
-- Subprograms --
-----------------
@@ -443,8 +618,8 @@ package Erroutc is
-- buffer, and preceded by a space.
function Compilation_Errors return Boolean;
- -- Returns true if errors have been detected, or warnings in -gnatwe
- -- (treat warnings as errors) mode.
+ -- Returns true if errors have been detected, or warnings that are treated
+ -- as errors.
procedure dmsg (Id : Error_Msg_Id);
-- Debugging routine to dump an error message
@@ -462,16 +637,14 @@ package Erroutc is
-- redundant. If so, the message to be deleted and all its continuations
-- are marked with the Deleted flag set to True.
- function Count_Compile_Time_Pragma_Warnings return Int;
- -- Returns the number of warnings in the Errors table that were triggered
- -- by a Compile_Time_Warning pragma.
-
function Get_Warning_Option (Id : Error_Msg_Id) return String;
+ function Get_Warning_Option (E : Error_Msg_Object) return String;
-- Returns the warning switch causing this warning message or an empty
-- string is there is none..
function Get_Warning_Tag (Id : Error_Msg_Id) return String;
- -- Given an error message ID, return tag showing warning message class, or
+ function Get_Warning_Tag (E : Error_Msg_Object) return String;
+ -- Given an error message, return tag showing warning message class, or
-- the null string if this option is not enabled or this is not a warning.
procedure Increase_Error_Msg_Count (E : Error_Msg_Object);
@@ -513,7 +686,7 @@ package Erroutc is
-- splits the line generating multiple lines of output, and in this case
-- the last line has no terminating end of line character.
- procedure Output_Text_Within (Txt : String_Ptr; Line_Length : Nat);
+ procedure Output_Text_Within (Txt : String; Line_Length : Nat);
-- Output the text in Txt, splitting it into lines of at most the size of
-- Line_Length.
@@ -549,6 +722,18 @@ package Erroutc is
-- Note that the call has no effect for continuation messages (those whose
-- first character is '\') except for the Has_Insertion_Line setting.
+ -- Definitions for valid message kind prefixes within error messages.
+
+ Info_Prefix : constant String := "info: ";
+ Low_Prefix : constant String := "low: ";
+ Medium_Prefix : constant String := "medium: ";
+ High_Prefix : constant String := "high: ";
+ Style_Prefix : constant String := "(style) ";
+
+ Warn_As_Err_Tag : constant String := "[warning-as-error]";
+ -- Tag used at the end of warning messages that were converted by
+ -- pragma Warning_As_Error.
+
procedure Purge_Messages (From : Source_Ptr; To : Source_Ptr);
-- All error messages whose location is in the range From .. To (not
-- including the end points) will be deleted from the error listing.
@@ -705,6 +890,10 @@ package Erroutc is
-- given by Warning_As_Error pragmas, as stored in the Warnings_As_Errors
-- table.
+ function Warning_Treated_As_Error (E : Error_Msg_Object) return Boolean;
+ -- Returns true if a Warning_As_Error pragma matches either the error text
+ -- or the warning tag of the message.
+
procedure Write_Error_Summary;
-- Write error summary
diff --git a/gcc/ada/diagnostics-switch_repository.adb b/gcc/ada/errsw.adb
index 1627de3..f4c4128 100644
--- a/gcc/ada/diagnostics-switch_repository.adb
+++ b/gcc/ada/errsw.adb
@@ -22,9 +22,10 @@
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-with Diagnostics.JSON_Utils; use Diagnostics.JSON_Utils;
-with Output; use Output;
-package body Diagnostics.Switch_Repository is
+with JSON_Utils; use JSON_Utils;
+with Output; use Output;
+
+package body Errsw is
Switches : constant array (Switch_Id)
of Switch_Type :=
@@ -553,12 +554,6 @@ package body Diagnostics.Switch_Repository is
return Switches (Id);
end Get_Switch;
- function Get_Switch (Diag : Diagnostic_Type) return Switch_Type is
-
- begin
- return Get_Switch (Diag.Switch);
- end Get_Switch;
-
-------------------
-- Get_Switch_Id --
-------------------
@@ -577,26 +572,6 @@ package body Diagnostics.Switch_Repository is
return No_Switch_Id;
end Get_Switch_Id;
- -------------------
- -- Get_Switch_Id --
- -------------------
-
- function Get_Switch_Id (E : Error_Msg_Object) return Switch_Id is
- Switch_Name : constant String :=
- (if E.Warn_Chr = "$ " then "gnatel"
- elsif E.Warn_Chr in "? " | " " then ""
- elsif E.Kind in Erroutc.Warning | Erroutc.Info
- then "gnatw" & E.Warn_Chr
- elsif E.Kind in Erroutc.Style then "gnatw" & E.Warn_Chr
- else "");
- begin
- if Switch_Name /= "" then
- return Get_Switch_Id (Switch_Name);
- else
- return No_Switch_Id;
- end if;
- end Get_Switch_Id;
-
-----------------------------
-- Print_Switch_Repository --
-----------------------------
@@ -687,4 +662,4 @@ package body Diagnostics.Switch_Repository is
Write_Eol;
end Print_Switch_Repository;
-end Diagnostics.Switch_Repository;
+end Errsw;
diff --git a/gcc/ada/errsw.ads b/gcc/ada/errsw.ads
new file mode 100644
index 0000000..b6d0130
--- /dev/null
+++ b/gcc/ada/errsw.ads
@@ -0,0 +1,154 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- D I A G N O S T I C S . D I A G N O S T I C S _ R E P O S I T O R Y --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1992-2025, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING3. If not, go to --
+-- http://www.gnu.org/licenses for a complete copy of the license. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+with Types; use Types;
+
+package Errsw is
+
+ type Status_Type is
+ (Active,
+ Deprecated);
+
+ type Switch_Id is (
+ No_Switch_Id,
+ gnatwb,
+ gnatwc,
+ gnatwd,
+ gnatwf,
+ gnatwg,
+ gnatwh,
+ gnatwi,
+ gnatwj,
+ gnatwk,
+ gnatwl,
+ gnatwm,
+ gnatwo,
+ gnatwp,
+ gnatwq,
+ gnatwr,
+ gnatwt,
+ gnatwu,
+ gnatwv,
+ gnatww,
+ gnatwx,
+ gnatwy,
+ gnatwz,
+ gnatw_dot_a,
+ gnatw_dot_b,
+ gnatw_dot_c,
+ gnatw_dot_f,
+ gnatw_dot_h,
+ gnatw_dot_i,
+ gnatw_dot_j,
+ gnatw_dot_k,
+ gnatw_dot_l,
+ gnatw_dot_m,
+ gnatw_dot_n,
+ gnatw_dot_o,
+ gnatw_dot_p,
+ gnatw_dot_q,
+ gnatw_dot_r,
+ gnatw_dot_s,
+ gnatw_dot_t,
+ gnatw_dot_u,
+ gnatw_dot_v,
+ gnatw_dot_w,
+ gnatw_dot_x,
+ gnatw_dot_y,
+ gnatw_dot_z,
+ gnatw_underscore_a,
+ gnatw_underscore_c,
+ gnatw_underscore_j,
+ gnatw_underscore_l,
+ gnatw_underscore_p,
+ gnatw_underscore_q,
+ gnatw_underscore_r,
+ gnatw_underscore_s,
+ gnaty,
+ gnatya,
+ gnatyb,
+ gnatyc,
+ gnatyd,
+ gnatye,
+ gnatyf,
+ gnatyh,
+ gnatyi,
+ gnatyk,
+ gnatyl,
+ gnatym,
+ gnatyn,
+ gnatyo,
+ gnatyp,
+ gnatyr,
+ gnatys,
+ gnatyu,
+ gnatyx,
+ gnatyz,
+ gnatyaa,
+ gnatybb,
+ gnatycc,
+ gnatydd,
+ gnatyii,
+ gnatyll,
+ gnatymm,
+ gnatyoo,
+ gnatyss,
+ gnatytt,
+ gnatel
+ );
+
+ subtype Active_Switch_Id is Switch_Id range gnatwb .. gnatel;
+
+ type Switch_Type is record
+
+ Status : Status_Type := Active;
+ -- The status will indicate whether the switch is currently active,
+ -- or has been deprecated. A deprecated switch will not control
+ -- diagnostics, and will not be emitted by the GNAT usage.
+
+ Human_Id : String_Ptr := null;
+ -- The Human_Id will be a unique and stable string-based ID which
+ -- identifies the content of the switch within the switch registry.
+ -- This ID will appear in SARIF readers.
+
+ Short_Name : String_Ptr := null;
+ -- The Short_Name will denote the -gnatXX name of the switch.
+
+ Description : String_Ptr := null;
+ -- The description will contain the description of the switch, as it is
+ -- currently emitted by the GNAT usage.
+
+ Documentation_Url : String_Ptr := null;
+ -- The documentation_url will point to the AdaCore documentation site
+ -- for the switch.
+
+ end record;
+
+ function Get_Switch (Id : Switch_Id) return Switch_Type;
+
+ function Get_Switch_Id (Name : String) return Switch_Id;
+
+ procedure Print_Switch_Repository;
+
+end Errsw;
diff --git a/gcc/ada/errutil.adb b/gcc/ada/errutil.adb
index 5548d53..b3674a1 100644
--- a/gcc/ada/errutil.adb
+++ b/gcc/ada/errutil.adb
@@ -25,7 +25,9 @@
with Atree; use Atree;
with Err_Vars; use Err_Vars;
+with Errid; use Errid;
with Erroutc; use Erroutc;
+with Errsw; use Errsw;
with Namet; use Namet;
with Opt; use Opt;
with Output; use Output;
@@ -206,12 +208,18 @@ package body Errutil is
Line => Get_Physical_Line_Number (Sptr),
Col => Get_Column_Number (Sptr),
Compile_Time_Pragma => Is_Compile_Time_Msg,
- Warn_Err => Warning_Mode = Treat_As_Error,
+ Warn_Err => (if Warning_Mode = Treat_As_Error
+ then From_Warn_As_Err
+ else None),
Warn_Chr => Warning_Msg_Char,
Uncond => Is_Unconditional_Msg,
Msg_Cont => Continuation,
Deleted => False,
- Kind => Error_Msg_Kind));
+ Kind => Error_Msg_Kind,
+ Id => No_Diagnostic_Id,
+ Switch => No_Switch_Id,
+ Locations => No_Labeled_Span,
+ Fixes => No_Fix));
Cur_Msg := Errors.Last;
Prev_Msg := No_Error_Msg;
diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb
index 7cb26ce..e3734a2 100644
--- a/gcc/ada/exp_aggr.adb
+++ b/gcc/ada/exp_aggr.adb
@@ -865,7 +865,9 @@ package body Exp_Aggr is
-- Checks 8: (no delayed components)
- if Is_Delayed_Aggregate (Expr) then
+ if Is_Delayed_Aggregate (Expr)
+ or else Is_Delayed_Conditional_Expression (Expr)
+ then
return False;
end if;
@@ -1405,6 +1407,23 @@ package body Exp_Aggr is
N_Iterated_Component_Association
then
null;
+
+ -- For mutably tagged class-wide type components that have an
+ -- initializing qualified expression, the expression must be
+ -- analyzed and resolved using the type of the qualified
+ -- expression; otherwise spurious errors would be reported
+ -- because components defined in derivations of the root type
+ -- of the mutably tagged class-wide type would not be visible.
+
+ -- Resolve_Aggr_Expr has previously checked that the type of
+ -- the qualified expression is a descendant of the root type
+ -- of the mutably class-wide tagged type.
+
+ elsif Is_Mutably_Tagged_Type (Comp_Typ)
+ and then Nkind (Expr) = N_Qualified_Expression
+ then
+ Analyze_And_Resolve (Expr_Q, Etype (Expr));
+
else
Analyze_And_Resolve (Expr_Q, Comp_Typ);
end if;
@@ -1438,12 +1457,54 @@ package body Exp_Aggr is
end if;
if Present (Expr) then
- Initialize_Component
- (N => N,
- Comp => Indexed_Comp,
- Comp_Typ => Comp_Typ,
- Init_Expr => Expr,
- Stmts => Stmts);
+
+ -- For mutably tagged abstract class-wide types, we rely on the
+ -- type of the initializing expression to initialize the tag of
+ -- each array component.
+
+ -- Generate:
+ -- expr_type!(Indexed_Comp) := expr;
+ -- expr_type!(Indexed_Comp)._tag := expr_type'Tag;
+
+ if Is_Mutably_Tagged_Type (Comp_Typ)
+ and then Is_Abstract_Type (Root_Type (Comp_Typ))
+ then
+ declare
+ Expr_Type : Entity_Id;
+
+ begin
+ if Nkind (Expr) in N_Has_Etype
+ and then Present (Etype (Expr))
+ then
+ Expr_Type := Etype (Expr);
+
+ elsif Nkind (Expr) = N_Qualified_Expression then
+ Analyze (Subtype_Mark (Expr));
+ Expr_Type := Etype (Subtype_Mark (Expr));
+
+ -- Unsupported case
+
+ else
+ pragma Assert (False);
+ raise Program_Error;
+ end if;
+
+ Initialize_Component
+ (N => N,
+ Comp => Unchecked_Convert_To (Expr_Type,
+ Indexed_Comp),
+ Comp_Typ => Expr_Type,
+ Init_Expr => Expr,
+ Stmts => Stmts);
+ end;
+ else
+ Initialize_Component
+ (N => N,
+ Comp => Indexed_Comp,
+ Comp_Typ => Comp_Typ,
+ Init_Expr => Expr,
+ Stmts => Stmts);
+ end if;
-- Ada 2005 (AI-287): In case of default initialized component, call
-- the initialization subprogram associated with the component type.
@@ -1457,14 +1518,21 @@ package body Exp_Aggr is
-- object creation that will invoke it otherwise.
else
- if Present (Base_Init_Proc (Ctype)) then
+ -- For mutably tagged class-wide types, default initialization is
+ -- performed by the init procedure of their root type.
+
+ if Is_Mutably_Tagged_Type (Comp_Typ) then
+ Comp_Typ := Root_Type (Comp_Typ);
+ end if;
+
+ if Present (Base_Init_Proc (Comp_Typ)) then
Check_Restriction (No_Default_Initialization, N);
if not Restriction_Active (No_Default_Initialization) then
Append_List_To (Stmts,
Build_Initialization_Call (N,
Id_Ref => Indexed_Comp,
- Typ => Ctype,
+ Typ => Comp_Typ,
With_Default_Init => True));
end if;
@@ -1473,17 +1541,17 @@ package body Exp_Aggr is
-- be analyzed and resolved before the code for initialization
-- of other components.
- if Has_Invariants (Ctype) then
- Set_Etype (Indexed_Comp, Ctype);
+ if Has_Invariants (Comp_Typ) then
+ Set_Etype (Indexed_Comp, Comp_Typ);
Append_To (Stmts, Make_Invariant_Call (Indexed_Comp));
end if;
end if;
- if Needs_Finalization (Ctype) then
+ if Needs_Finalization (Comp_Typ) then
Init_Call :=
Make_Init_Call
(Obj_Ref => New_Copy_Tree (Indexed_Comp),
- Typ => Ctype);
+ Typ => Comp_Typ);
-- Guard against a missing [Deep_]Initialize when the component
-- type was not properly frozen.
@@ -1504,9 +1572,13 @@ package body Exp_Aggr is
-- 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
+ if Has_DIC (Comp_Typ)
+ and then Present (DIC_Procedure (Comp_Typ))
+ then
Append_To (Stmts,
- Build_DIC_Call (Loc, New_Copy_Tree (Indexed_Comp), Ctype));
+ Build_DIC_Call (Loc,
+ Obj_Name => New_Copy_Tree (Indexed_Comp),
+ Typ => Comp_Typ));
end if;
end if;
@@ -1518,6 +1590,8 @@ package body Exp_Aggr is
--------------
function Gen_Loop (L, H : Node_Id; Expr : Node_Id) return List_Id is
+ Comp_Typ : Entity_Id;
+
Is_Iterated_Component : constant Boolean :=
Parent_Kind (Expr) = N_Iterated_Component_Association;
@@ -1573,6 +1647,12 @@ package body Exp_Aggr is
Tcopy := New_Copy_Tree (Expr);
Set_Parent (Tcopy, N);
+ Comp_Typ := Component_Type (Etype (N));
+
+ if Is_Class_Wide_Equivalent_Type (Comp_Typ) then
+ Comp_Typ := Corresponding_Mutably_Tagged_Type (Comp_Typ);
+ end if;
+
-- For iterated_component_association analyze and resolve
-- the expression with name of the index parameter visible.
-- To manipulate scopes, we use entity of the implicit loop.
@@ -1584,8 +1664,7 @@ package body Exp_Aggr is
begin
Push_Scope (Scope (Index_Parameter));
Enter_Name (Index_Parameter);
- Analyze_And_Resolve
- (Tcopy, Component_Type (Etype (N)));
+ Analyze_And_Resolve (Tcopy, Comp_Typ);
End_Scope;
end;
@@ -1593,7 +1672,7 @@ package body Exp_Aggr is
-- resolve the expression.
else
- Analyze_And_Resolve (Tcopy, Component_Type (Etype (N)));
+ Analyze_And_Resolve (Tcopy, Comp_Typ);
end if;
Expander_Mode_Restore;
@@ -2130,6 +2209,7 @@ package body Exp_Aggr is
Set_Loop_Actions (Others_Assoc, New_List);
First := False;
end if;
+
Expr := Get_Assoc_Expr (Others_Assoc);
Append_List (Gen_Loop (Low, High, Expr), To => New_Code);
end if;
@@ -3267,54 +3347,85 @@ package body Exp_Aggr is
-- a call to the corresponding IP subprogram if available.
elsif Box_Present (Comp)
- and then Has_Non_Null_Base_Init_Proc (Etype (Selector))
- then
- Check_Restriction (No_Default_Initialization, N);
-
- if Ekind (Selector) /= E_Discriminant then
- Generate_Finalization_Actions;
- end if;
+ and then
+ (Has_Non_Null_Base_Init_Proc (Etype (Selector))
- -- Ada 2005 (AI-287): If the component type has tasks then
- -- generate the activation chain and master entities (except
- -- in case of an allocator because in that case these entities
- -- are generated by Build_Task_Allocate_Block).
+ -- Default initialization of mutably tagged class-wide type
+ -- components is performed by the IP subprogram.
+ or else Is_Class_Wide_Equivalent_Type (Etype (Selector)))
+ then
declare
- Ctype : constant Entity_Id := Etype (Selector);
- Inside_Allocator : Boolean := False;
- P : Node_Id := Parent (N);
+ Ctype : Entity_Id := Etype (Selector);
begin
- if Is_Task_Type (Ctype) or else Has_Task (Ctype) then
- while Present (P) loop
- if Nkind (P) = N_Allocator then
- Inside_Allocator := True;
- exit;
+ if Is_Class_Wide_Equivalent_Type (Ctype) then
+ Ctype :=
+ Root_Type (Corresponding_Mutably_Tagged_Type (Ctype));
+ end if;
+
+ Check_Restriction (No_Default_Initialization, N);
+
+ if Ekind (Selector) /= E_Discriminant then
+ Generate_Finalization_Actions;
+ end if;
+
+ -- Ada 2005 (AI-287): If the component type has tasks then
+ -- generate the activation chain and master entities (except
+ -- in case of an allocator because in that case these entities
+ -- are generated by Build_Task_Allocate_Block).
+
+ declare
+ Inside_Allocator : Boolean := False;
+ P : Node_Id := Parent (N);
+
+ begin
+ if Is_Task_Type (Ctype) or else Has_Task (Ctype) then
+ while Present (P) loop
+ if Nkind (P) = N_Allocator then
+ Inside_Allocator := True;
+ exit;
+ end if;
+
+ P := Parent (P);
+ end loop;
+
+ if not Inside_Init_Proc and not Inside_Allocator then
+ Build_Activation_Chain_Entity (N);
end if;
+ end if;
+ end;
- P := Parent (P);
- end loop;
+ if not Restriction_Active (No_Default_Initialization) then
+ Append_List_To (L,
+ Build_Initialization_Call (N,
+ Id_Ref => Make_Selected_Component (Loc,
+ Prefix =>
+ New_Copy_Tree (Target),
+ Selector_Name =>
+ New_Occurrence_Of
+ (Selector, Loc)),
+ Typ => Ctype,
+ Enclos_Type => Typ,
+ With_Default_Init => True));
+
+ if Is_Class_Wide_Equivalent_Type (Etype (Selector))
+ and then Is_Abstract_Type (Ctype)
+ then
+ Error_Msg_Name_1 := Chars (Selector);
+ Error_Msg_N
+ ("default initialization of abstract type "
+ & "component % not allowed??", Comp);
+ Error_Msg_N
+ ("\Program_Error will be raised at run time??", Comp);
- if not Inside_Init_Proc and not Inside_Allocator then
- Build_Activation_Chain_Entity (N);
+ Append_To (L,
+ Make_Raise_Program_Error (Loc,
+ Reason => PE_Abstract_Type_Component));
end if;
end if;
end;
- if not Restriction_Active (No_Default_Initialization) then
- Append_List_To (L,
- Build_Initialization_Call (N,
- Id_Ref => Make_Selected_Component (Loc,
- Prefix =>
- New_Copy_Tree (Target),
- Selector_Name =>
- New_Occurrence_Of (Selector, Loc)),
- Typ => Etype (Selector),
- Enclos_Type => Typ,
- With_Default_Init => True));
- end if;
-
-- Prepare for component assignment
elsif Ekind (Selector) /= E_Discriminant
@@ -3471,12 +3582,27 @@ package body Exp_Aggr is
end if;
end if;
- Initialize_Component
- (N => N,
- Comp => Comp_Expr,
- Comp_Typ => Etype (Selector),
- Init_Expr => Expr_Q,
- Stmts => L);
+ -- For mutably tagged class-wide components with a qualified
+ -- initializing expressions use the qualified expression as
+ -- its Init_Expr; required to avoid reporting spurious errors.
+
+ if Is_Class_Wide_Equivalent_Type (Comp_Type)
+ and then Nkind (Expression (Comp)) = N_Qualified_Expression
+ then
+ Initialize_Component
+ (N => N,
+ Comp => Comp_Expr,
+ Comp_Typ => Etype (Selector),
+ Init_Expr => Expression (Comp),
+ Stmts => L);
+ else
+ Initialize_Component
+ (N => N,
+ Comp => Comp_Expr,
+ Comp_Typ => Etype (Selector),
+ Init_Expr => Expr_Q,
+ Stmts => L);
+ end if;
end if;
-- comment would be good here ???
@@ -3865,8 +3991,8 @@ package body Exp_Aggr is
function Safe_Component (Expr : Node_Id) return Boolean;
-- Verify that an expression cannot depend on the target being assigned
- -- to. Return true for compile-time known values, stand-alone objects,
- -- parameters passed by copy, calls to functions that return by copy,
+ -- (which is Target_Object if it is set), return true for compile-time
+ -- known values, stand-alone objects, formal parameters passed by copy,
-- selected components thereof only if the aggregate's type is an array,
-- indexed components and slices thereof only if the aggregate's type is
-- a record, and simple expressions involving only these as operands.
@@ -3877,7 +4003,8 @@ package body Exp_Aggr is
-- which is excluded by the above condition. Additionally, if the target
-- is statically known, return true for arbitrarily nested selections,
-- indexations or slicings, provided that their ultimate prefix is not
- -- the target itself.
+ -- the target itself, and calls to functions that take only these as
+ -- actual parameters provided that the target is not aliased.
--------------------
-- Safe_Aggregate --
@@ -3982,12 +4109,26 @@ package body Exp_Aggr is
return Check_Component (Prefix (C), T_OK);
when N_Function_Call =>
- if Nkind (Name (C)) = N_Explicit_Dereference then
- return not Returns_By_Ref (Etype (Name (C)));
- else
- return not Returns_By_Ref (Entity (Name (C)));
+ if No (Target_Object) or else Is_Aliased (Target_Object) then
+ return False;
end if;
+ if Present (Parameter_Associations (C)) then
+ declare
+ Actual : Node_Id;
+ begin
+ Actual := First_Actual (C);
+ while Present (Actual) loop
+ if not Check_Component (Actual, T_OK) then
+ return False;
+ end if;
+ Next_Actual (Actual);
+ end loop;
+ end;
+ end if;
+
+ return True;
+
when N_Indexed_Component | N_Slice =>
-- In a target record, these operations cannot determine
-- alone a component so we can recurse whatever the target.
@@ -4179,11 +4320,7 @@ package body Exp_Aggr is
-- excluding container aggregates as these are transformed into
-- subprogram calls later.
- (Nkind (Parent_Node) = N_Component_Association
- and then not Is_Container_Aggregate (Parent (Parent_Node)))
-
- or else (Nkind (Parent_Node) in N_Aggregate | N_Extension_Aggregate
- and then not Is_Container_Aggregate (Parent_Node))
+ Parent_Is_Regular_Aggregate (Parent_Node)
-- Allocator (see Convert_Aggr_In_Allocator)
@@ -4327,6 +4464,7 @@ package body Exp_Aggr is
Typ : constant Entity_Id := Etype (N);
Dims : constant Nat := Number_Dimensions (Typ);
Max_Others_Replicate : constant Nat := Max_Aggregate_Size (N);
+ Ctyp : constant Entity_Id := Component_Type (Typ);
Static_Components : Boolean := True;
@@ -4803,7 +4941,13 @@ package body Exp_Aggr is
-- components because in this case will need to call the corresponding
-- IP procedure.
- if Has_Default_Init_Comps (N) then
+ if Has_Default_Init_Comps (N)
+ or else Present (Constructor_Name (Ctyp))
+ or else (Is_Access_Type (Ctyp)
+ and then Present
+ (Constructor_Name
+ (Directly_Designated_Type (Ctyp))))
+ then
return;
end if;
@@ -4956,6 +5100,14 @@ package body Exp_Aggr is
-- type using the computable sizes of the aggregate and its sub-
-- aggregates.
+ function Build_Two_Pass_Aggr_Code
+ (Lhs : Node_Id;
+ Aggr_Typ : out Entity_Id) return List_Id;
+ -- The aggregate consists only of iterated associations and Lhs is an
+ -- expression containing the location of the anonymous object, which
+ -- may be built in place. Returns the dynamic subtype of the aggregate
+ -- in Aggr_Typ and the list of statements needed to build it.
+
procedure Check_Bounds (Aggr_Bounds_Node, Index_Bounds_Node : Node_Id);
-- Checks that the bounds of Aggr_Bounds are within the bounds defined
-- by Index_Bounds. For null array aggregate (Ada 2022) check that the
@@ -4983,7 +5135,7 @@ package body Exp_Aggr is
-- built directly into the target of an assignment, the target must
-- be free of side effects. N is the target of the assignment.
- procedure Two_Pass_Aggregate_Expansion (N : Node_Id);
+ procedure Two_Pass_Aggregate_Expansion;
-- If the aggregate consists only of iterated associations then the
-- aggregate is constructed in two steps:
-- a) Build an expression to compute the number of elements
@@ -5053,6 +5205,221 @@ package body Exp_Aggr is
Freeze_Itype (Agg_Type, N);
end Build_Constrained_Type;
+ ------------------------------
+ -- Build_Two_Pass_Aggr_Code --
+ ------------------------------
+
+ function Build_Two_Pass_Aggr_Code
+ (Lhs : Node_Id;
+ Aggr_Typ : out Entity_Id) return List_Id
+ is
+ Index_Id : constant Entity_Id := Make_Temporary (Loc, 'I', N);
+ Index_Type : constant Entity_Id := Etype (First_Index (Typ));
+ Index_Base : constant Entity_Id := Base_Type (Index_Type);
+ Size_Id : constant Entity_Id := Make_Temporary (Loc, 'I', N);
+ Size_Type : constant Entity_Id :=
+ Integer_Type_For
+ (Esize (Index_Base), Is_Unsigned_Type (Index_Base));
+
+ Assoc : Node_Id;
+ Incr : Node_Id;
+ Iter : Node_Id;
+ New_Comp : Node_Id;
+ One_Loop : Node_Id;
+ Iter_Id : Entity_Id;
+
+ Aggr_Code : List_Id;
+ Size_Expr_Code : List_Id;
+
+ begin
+ Size_Expr_Code := New_List (
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Size_Id,
+ Object_Definition => New_Occurrence_Of (Size_Type, Loc),
+ Expression => Make_Integer_Literal (Loc, 0)));
+
+ -- First pass: execute the iterators to count the number of elements
+ -- that will be generated.
+
+ Assoc := First (Component_Associations (N));
+ while Present (Assoc) loop
+ Iter := Iterator_Specification (Assoc);
+ Iter_Id := Defining_Identifier (Iter);
+ Incr :=
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Size_Id, Loc),
+ Expression =>
+ Make_Op_Add (Loc,
+ Left_Opnd => New_Occurrence_Of (Size_Id, Loc),
+ Right_Opnd => Make_Integer_Literal (Loc, 1)));
+
+ -- Avoid using the same iterator definition in both loops by
+ -- creating a new iterator for each loop and mapping it over the
+ -- original iterator references.
+
+ One_Loop :=
+ Make_Implicit_Loop_Statement (N,
+ Iteration_Scheme =>
+ Make_Iteration_Scheme (Loc,
+ Iterator_Specification =>
+ New_Copy_Tree (Iter,
+ Map => New_Elmt_List (Iter_Id, New_Copy (Iter_Id)))),
+ Statements => New_List (Incr));
+
+ Append (One_Loop, Size_Expr_Code);
+ Next (Assoc);
+ end loop;
+
+ Insert_Actions (N, Size_Expr_Code);
+
+ -- Build a constrained subtype with the bounds deduced from
+ -- the size computed above and declare the aggregate object.
+ -- The index type is some discrete type, so the bounds of the
+ -- constrained subtype are computed as T'Val (integer bounds).
+
+ declare
+ -- Pos_Lo := Index_Type'Pos (Index_Type'First)
+
+ Pos_Lo : constant Node_Id :=
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Index_Type, Loc),
+ Attribute_Name => Name_Pos,
+ Expressions => New_List (
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Index_Type, Loc),
+ Attribute_Name => Name_First)));
+
+ -- Corresponding index value, i.e. Index_Type'First
+
+ Aggr_Lo : constant Node_Id :=
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Index_Type, Loc),
+ Attribute_Name => Name_First);
+
+ -- Pos_Hi := Pos_Lo + Size - 1
+
+ Pos_Hi : constant Node_Id :=
+ Make_Op_Add (Loc,
+ Left_Opnd => Pos_Lo,
+ Right_Opnd =>
+ Make_Op_Subtract (Loc,
+ Left_Opnd => New_Occurrence_Of (Size_Id, Loc),
+ Right_Opnd => Make_Integer_Literal (Loc, 1)));
+
+ -- Corresponding index value
+
+ Aggr_Hi : constant Node_Id :=
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Index_Type, Loc),
+ Attribute_Name => Name_Val,
+ Expressions => New_List (Pos_Hi));
+
+ begin
+ Aggr_Typ := Make_Temporary (Loc, 'T');
+
+ Insert_Action (N,
+ Make_Subtype_Declaration (Loc,
+ Defining_Identifier => Aggr_Typ,
+ Subtype_Indication =>
+ Make_Subtype_Indication (Loc,
+ Subtype_Mark =>
+ New_Occurrence_Of (Base_Type (Typ), Loc),
+ Constraint =>
+ Make_Index_Or_Discriminant_Constraint
+ (Loc,
+ Constraints =>
+ New_List (Make_Range (Loc, Aggr_Lo, Aggr_Hi))))));
+ end;
+
+ -- Second pass: use the iterators to generate the elements of the
+ -- aggregate. We assume that the second evaluation of each iterator
+ -- generates the same number of elements as the first pass, and thus
+ -- consider that the execution is erroneous (even if the RM does not
+ -- state this explicitly) if the number of elements generated differs
+ -- between first and second pass.
+
+ Assoc := First (Component_Associations (N));
+
+ -- Initialize insertion position to first array component
+
+ Aggr_Code := New_List (
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Index_Id,
+ Object_Definition =>
+ New_Occurrence_Of (Index_Type, Loc),
+ Expression =>
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Copy_Tree (Lhs),
+ Attribute_Name => Name_First)));
+
+ while Present (Assoc) loop
+ Iter := Iterator_Specification (Assoc);
+ Iter_Id := Defining_Identifier (Iter);
+ New_Comp :=
+ Make_OK_Assignment_Statement (Loc,
+ Name =>
+ Make_Indexed_Component (Loc,
+ Prefix => New_Copy_Tree (Lhs),
+ Expressions =>
+ New_List (New_Occurrence_Of (Index_Id, Loc))),
+ Expression => Copy_Separate_Tree (Expression (Assoc)));
+
+ -- Arrange for the component to be adjusted if need be (the call
+ -- will be generated by Make_Tag_Ctrl_Assignment).
+
+ if Needs_Finalization (Ctyp)
+ and then not Is_Inherently_Limited_Type (Ctyp)
+ then
+ Set_No_Finalize_Actions (New_Comp);
+ else
+ Set_No_Ctrl_Actions (New_Comp);
+ end if;
+
+ -- Advance index position for insertion
+
+ Incr :=
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Index_Id, Loc),
+ Expression =>
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Index_Type, Loc),
+ Attribute_Name => Name_Succ,
+ Expressions =>
+ New_List (New_Occurrence_Of (Index_Id, Loc))));
+
+ -- Add guard to skip last increment when upper bound is reached
+
+ Incr :=
+ Make_If_Statement (Loc,
+ Condition =>
+ Make_Op_Ne (Loc,
+ Left_Opnd => New_Occurrence_Of (Index_Id, Loc),
+ Right_Opnd =>
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Index_Type, Loc),
+ Attribute_Name => Name_Last)),
+ Then_Statements => New_List (Incr));
+
+ -- Avoid using the same iterator definition in both loops by
+ -- creating a new iterator for each loop and mapping it over
+ -- the original iterator references.
+
+ One_Loop :=
+ Make_Implicit_Loop_Statement (N,
+ Iteration_Scheme =>
+ Make_Iteration_Scheme (Loc,
+ Iterator_Specification =>
+ New_Copy_Tree (Iter,
+ Map => New_Elmt_List (Iter_Id, New_Copy (Iter_Id)))),
+ Statements => New_List (New_Comp, Incr));
+
+ Append (One_Loop, Aggr_Code);
+ Next (Assoc);
+ end loop;
+
+ return Aggr_Code;
+ end Build_Two_Pass_Aggr_Code;
+
------------------
-- Check_Bounds --
------------------
@@ -5596,214 +5963,98 @@ package body Exp_Aggr is
-- Two_Pass_Aggregate_Expansion --
----------------------------------
- procedure Two_Pass_Aggregate_Expansion (N : Node_Id) is
- Loc : constant Source_Ptr := Sloc (N);
- Comp_Type : constant Entity_Id := Etype (N);
- Index_Id : constant Entity_Id := Make_Temporary (Loc, 'I', N);
- Index_Type : constant Entity_Id := Etype (First_Index (Etype (N)));
- Index_Base : constant Entity_Id := Base_Type (Index_Type);
- Size_Id : constant Entity_Id := Make_Temporary (Loc, 'I', N);
- Size_Type : constant Entity_Id :=
- Integer_Type_For
- (Esize (Index_Base), Is_Unsigned_Type (Index_Base));
- TmpE : constant Entity_Id := Make_Temporary (Loc, 'A', N);
-
- Assoc : Node_Id := First (Component_Associations (N));
- Incr : Node_Id;
- Iter : Node_Id;
- New_Comp : Node_Id;
- One_Loop : Node_Id;
- Iter_Id : Entity_Id;
-
- Size_Expr_Code : List_Id;
- Insertion_Code : List_Id := New_List;
+ procedure Two_Pass_Aggregate_Expansion is
+ Aggr_Code : List_Id;
+ Aggr_Typ : Entity_Id;
+ Lhs : Node_Id;
+ Obj_Id : Entity_Id;
+ Par : Node_Id;
begin
- Size_Expr_Code := New_List (
- Make_Object_Declaration (Loc,
- Defining_Identifier => Size_Id,
- Object_Definition => New_Occurrence_Of (Size_Type, Loc),
- Expression => Make_Integer_Literal (Loc, 0)));
-
- -- First pass: execute the iterators to count the number of elements
- -- that will be generated.
-
- while Present (Assoc) loop
- Iter := Iterator_Specification (Assoc);
- Iter_Id := Defining_Identifier (Iter);
- Incr := Make_Assignment_Statement (Loc,
- Name => New_Occurrence_Of (Size_Id, Loc),
- Expression =>
- Make_Op_Add (Loc,
- Left_Opnd => New_Occurrence_Of (Size_Id, Loc),
- Right_Opnd => Make_Integer_Literal (Loc, 1)));
-
- -- Avoid using the same iterator definition in both loops by
- -- creating a new iterator for each loop and mapping it over the
- -- original iterator references.
-
- One_Loop := Make_Implicit_Loop_Statement (N,
- Iteration_Scheme =>
- Make_Iteration_Scheme (Loc,
- Iterator_Specification =>
- New_Copy_Tree (Iter,
- Map => New_Elmt_List (Iter_Id, New_Copy (Iter_Id)))),
- Statements => New_List (Incr));
-
- Append (One_Loop, Size_Expr_Code);
- Next (Assoc);
+ Par := Parent (N);
+ while Nkind (Par) = N_Qualified_Expression loop
+ Par := Parent (Par);
end loop;
- Insert_Actions (N, Size_Expr_Code);
-
- -- Build a constrained subtype with the bounds deduced from
- -- the size computed above and declare the aggregate object.
- -- The index type is some discrete type, so the bounds of the
- -- constrained subtype are computed as T'Val (integer bounds).
-
- declare
- -- Pos_Lo := Index_Type'Pos (Index_Type'First)
+ -- If the aggregate is the initialization expression of an object
+ -- declaration, we always build the aggregate in place, although
+ -- this is required only for immutably limited types and types
+ -- that need finalization, see RM 7.6(17.2/3-17.3/3).
- Pos_Lo : constant Node_Id :=
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Index_Type, Loc),
- Attribute_Name => Name_Pos,
- Expressions => New_List (
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Index_Type, Loc),
- Attribute_Name => Name_First)));
-
- -- Corresponding index value, i.e. Index_Type'First
-
- Aggr_Lo : constant Node_Id :=
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Index_Type, Loc),
- Attribute_Name => Name_First);
-
- -- Pos_Hi := Pos_Lo + Size - 1
-
- Pos_Hi : constant Node_Id :=
- Make_Op_Add (Loc,
- Left_Opnd => Pos_Lo,
- Right_Opnd =>
- Make_Op_Subtract (Loc,
- Left_Opnd => New_Occurrence_Of (Size_Id, Loc),
- Right_Opnd => Make_Integer_Literal (Loc, 1)));
-
- -- Corresponding index value
-
- Aggr_Hi : constant Node_Id :=
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Index_Type, Loc),
- Attribute_Name => Name_Val,
- Expressions => New_List (Pos_Hi));
-
- SubE : constant Entity_Id := Make_Temporary (Loc, 'T');
- SubD : constant Node_Id :=
- Make_Subtype_Declaration (Loc,
- Defining_Identifier => SubE,
- Subtype_Indication =>
- Make_Subtype_Indication (Loc,
- Subtype_Mark =>
- New_Occurrence_Of (Etype (Comp_Type), Loc),
- Constraint =>
- Make_Index_Or_Discriminant_Constraint
- (Loc,
- Constraints =>
- New_List (Make_Range (Loc, Aggr_Lo, Aggr_Hi)))));
-
- -- Create a temporary array of the above subtype which
- -- will be used to capture the aggregate assignments.
-
- TmpD : constant Node_Id :=
- Make_Object_Declaration (Loc,
- Defining_Identifier => TmpE,
- Object_Definition => New_Occurrence_Of (SubE, Loc));
-
- begin
- Insert_Actions (N, New_List (SubD, TmpD));
- end;
-
- -- Second pass: use the iterators to generate the elements of the
- -- aggregate. Insertion index starts at Index_Type'First. We
- -- assume that the second evaluation of each iterator generates
- -- the same number of elements as the first pass, and consider
- -- that the execution is erroneous (even if the RM does not state
- -- this explicitly) if the number of elements generated differs
- -- between first and second pass.
-
- Assoc := First (Component_Associations (N));
+ if Nkind (Par) = N_Object_Declaration then
+ Obj_Id := Defining_Identifier (Par);
+ Lhs := New_Occurrence_Of (Obj_Id, Loc);
+ Set_Assignment_OK (Lhs);
+ Aggr_Code := Build_Two_Pass_Aggr_Code (Lhs, Aggr_Typ);
- -- Initialize insertion position to first array component.
+ -- Save the last assignment statement associated with the
+ -- aggregate when building a controlled object. This last
+ -- assignment is used by the finalization machinery when
+ -- marking an object as successfully initialized.
- Insertion_Code := New_List (
- Make_Object_Declaration (Loc,
- Defining_Identifier => Index_Id,
- Object_Definition =>
- New_Occurrence_Of (Index_Type, Loc),
- Expression =>
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Index_Type, Loc),
- Attribute_Name => Name_First)));
+ if Needs_Finalization (Typ) then
+ Mutate_Ekind (Obj_Id, E_Variable);
+ Set_Last_Aggregate_Assignment (Obj_Id, Last (Aggr_Code));
+ end if;
- while Present (Assoc) loop
- Iter := Iterator_Specification (Assoc);
- Iter_Id := Defining_Identifier (Iter);
- New_Comp := Make_Assignment_Statement (Loc,
- Name =>
- Make_Indexed_Component (Loc,
- Prefix => New_Occurrence_Of (TmpE, Loc),
- Expressions =>
- New_List (New_Occurrence_Of (Index_Id, Loc))),
- Expression => Copy_Separate_Tree (Expression (Assoc)));
+ -- If a transient scope has been created around the declaration,
+ -- we need to attach the code to it so that finalization actions
+ -- of the declaration will be inserted after it; otherwise, we
+ -- directly insert it after the declaration. In both cases, the
+ -- code will be analyzed after the declaration is processed, i.e.
+ -- once the actual subtype of the object is established.
- -- Advance index position for insertion.
+ if Scope_Is_Transient and then Par = Node_To_Be_Wrapped then
+ Store_After_Actions_In_Scope_Without_Analysis (Aggr_Code);
+ else
+ Insert_List_After (Par, Aggr_Code);
+ end if;
- Incr := Make_Assignment_Statement (Loc,
- Name => New_Occurrence_Of (Index_Id, Loc),
- Expression =>
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (Index_Type, Loc),
- Attribute_Name => Name_Succ,
- Expressions =>
- New_List (New_Occurrence_Of (Index_Id, Loc))));
+ Set_Etype (N, Aggr_Typ);
+ Set_No_Initialization (Par);
- -- Add guard to skip last increment when upper bound is reached.
+ -- Likewise if it is the qualified expression of an allocator but,
+ -- in this case, we wait until after Expand_Allocator_Expression
+ -- rewrites the allocator as the initialization expression of an
+ -- object declaration, so that we have the left-hand side.
- Incr := Make_If_Statement (Loc,
- Condition =>
- Make_Op_Ne (Loc,
- Left_Opnd => New_Occurrence_Of (Index_Id, Loc),
- Right_Opnd =>
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Index_Type, Loc),
- Attribute_Name => Name_Last)),
- Then_Statements => New_List (Incr));
+ elsif Nkind (Par) = N_Allocator then
+ if Nkind (Parent (Par)) = N_Object_Declaration
+ and then
+ not Comes_From_Source (Defining_Identifier (Parent (Par)))
+ then
+ Obj_Id := Defining_Identifier (Parent (Par));
+ Lhs :=
+ Make_Explicit_Dereference (Loc,
+ Prefix => New_Occurrence_Of (Obj_Id, Loc));
+ Set_Assignment_OK (Lhs);
+ Aggr_Code := Build_Two_Pass_Aggr_Code (Lhs, Aggr_Typ);
- -- Avoid using the same iterator definition in both loops by
- -- creating a new iterator for each loop and mapping it over the
- -- original iterator references.
+ Insert_Actions_After (Parent (Par), Aggr_Code);
- One_Loop := Make_Implicit_Loop_Statement (N,
- Iteration_Scheme =>
- Make_Iteration_Scheme (Loc,
- Iterator_Specification =>
- New_Copy_Tree (Iter,
- Map => New_Elmt_List (Iter_Id, New_Copy (Iter_Id)))),
- Statements => New_List (New_Comp, Incr));
+ Set_Expression (Par, New_Occurrence_Of (Aggr_Typ, Loc));
+ Set_No_Initialization (Par);
+ end if;
- Append (One_Loop, Insertion_Code);
- Next (Assoc);
- end loop;
+ -- Otherwise we create a temporary for the anonymous object and
+ -- replace the aggregate with the temporary.
- Insert_Actions (N, Insertion_Code);
+ else
+ Obj_Id := Make_Temporary (Loc, 'A', N);
+ Lhs := New_Occurrence_Of (Obj_Id, Loc);
+ Set_Assignment_OK (Lhs);
- -- Depending on context this may not work for build-in-place
- -- arrays ???
+ Aggr_Code := Build_Two_Pass_Aggr_Code (Lhs, Aggr_Typ);
+ Prepend_To (Aggr_Code,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Obj_Id,
+ Object_Definition => New_Occurrence_Of (Aggr_Typ, Loc)));
- Rewrite (N, New_Occurrence_Of (TmpE, Loc));
+ Insert_Actions (N, Aggr_Code);
+ Rewrite (N, Lhs);
+ Analyze_And_Resolve (N, Aggr_Typ);
+ end if;
end Two_Pass_Aggregate_Expansion;
-- Local variables
@@ -5829,7 +6080,7 @@ package body Exp_Aggr is
-- Aggregates that require a two-pass expansion are handled separately
elsif Is_Two_Pass_Aggregate (N) then
- Two_Pass_Aggregate_Expansion (N);
+ Two_Pass_Aggregate_Expansion;
return;
-- Do not attempt expansion if error already detected. We may reach this
@@ -6002,12 +6253,11 @@ package body Exp_Aggr is
-- static type imposed by the context.
declare
- Itype : constant Entity_Id := Etype (N);
Index : Node_Id;
Needs_Type : Boolean := False;
begin
- Index := First_Index (Itype);
+ Index := First_Index (Typ);
while Present (Index) loop
if not Is_OK_Static_Subtype (Etype (Index)) then
Needs_Type := True;
@@ -6019,7 +6269,7 @@ package body Exp_Aggr is
if Needs_Type then
Build_Constrained_Type (Positional => True);
- Rewrite (N, Unchecked_Convert_To (Itype, N));
+ Rewrite (N, Unchecked_Convert_To (Typ, N));
Analyze (N);
end if;
end;
@@ -6037,14 +6287,9 @@ package body Exp_Aggr is
if
-- Internal aggregates (transformed when expanding the parent),
-- excluding container aggregates as these are transformed into
- -- subprogram calls later. So far aggregates with self-references
- -- are not supported if they appear in a conditional expression.
-
- (Nkind (Parent_Node) = N_Component_Association
- and then not Is_Container_Aggregate (Parent (Parent_Node)))
+ -- subprogram calls later.
- or else (Nkind (Parent_Node) in N_Aggregate | N_Extension_Aggregate
- and then not Is_Container_Aggregate (Parent_Node))
+ Parent_Is_Regular_Aggregate (Parent_Node)
-- Allocator (see Convert_Aggr_In_Allocator). Sliding cannot be done
-- in place for the time being.
@@ -6147,7 +6392,7 @@ package body Exp_Aggr is
then
Tmp := Name (Parent_Node);
- if Etype (Tmp) /= Etype (N) then
+ if Etype (Tmp) /= Typ then
Apply_Length_Check (N, Etype (Tmp));
if Nkind (N) = N_Raise_Constraint_Error then
@@ -6904,7 +7149,7 @@ package body Exp_Aggr is
begin
return UI_To_Int ((if Nkind (Expr) = N_Integer_Literal
then Intval (Expr)
- else Enumeration_Pos (Expr)));
+ else Enumeration_Pos (Entity (Expr))));
end To_Int;
-- Local variables
@@ -7362,7 +7607,7 @@ package body Exp_Aggr is
-- Likewise if the aggregate is the qualified expression of an allocator
-- but, in this case, we wait until after Expand_Allocator_Expression
-- rewrites the allocator as the initialization expression of an object
- -- declaration to have the left hand side.
+ -- declaration, so that we have the left-hand side.
elsif Nkind (Par) = N_Allocator then
if Nkind (Parent (Par)) = N_Object_Declaration
@@ -7390,10 +7635,19 @@ package body Exp_Aggr is
Set_Assignment_OK (Lhs);
Aggr_Code := Build_Container_Aggr_Code (N, Typ, Lhs, Init);
+
+ -- Use the unconstrained base subtype of the subtype provided by
+ -- the context for declaring the temporary object (which may come
+ -- from a constrained assignment target), to ensure that the
+ -- aggregate can be successfully expanded and assigned to the
+ -- temporary without exceeding its capacity. (Later assignment
+ -- of the temporary to a target object may result in failing
+ -- a discriminant check.)
+
Prepend_To (Aggr_Code,
Make_Object_Declaration (Loc,
Defining_Identifier => Obj_Id,
- Object_Definition => New_Occurrence_Of (Typ, Loc),
+ Object_Definition => New_Occurrence_Of (Base_Type (Typ), Loc),
Expression => Init));
Insert_Actions (N, Aggr_Code);
@@ -7971,7 +8225,8 @@ package body Exp_Aggr is
Make_Selected_Component (Loc,
Prefix =>
Unchecked_Convert_To (Typ,
- Duplicate_Subexpr (Parent_Expr, True)),
+ Duplicate_Subexpr
+ (Parent_Expr, Name_Req => True)),
Selector_Name => New_Occurrence_Of (Comp, Loc));
Append_To (Comps,
@@ -8580,6 +8835,8 @@ package body Exp_Aggr is
-- generated by Make_Tag_Ctrl_Assignment). But, in the case of an array
-- aggregate, controlled subaggregates are not considered because each
-- of their individual elements will receive an adjustment of its own.
+ -- Moreover, the result of a function call need not be adjusted if it
+ -- has already been adjusted in the called function.
if Finalization_OK
and then not Is_Inherently_Limited_Type (Comp_Typ)
@@ -8588,6 +8845,8 @@ package body Exp_Aggr is
and then Is_Array_Type (Comp_Typ)
and then Needs_Finalization (Component_Type (Comp_Typ))
and then Nkind (Unqualify (Init_Expr)) = N_Aggregate)
+ and then not (Back_End_Return_Slot
+ and then Nkind (Init_Expr) = N_Function_Call)
then
Set_No_Finalize_Actions (Init_Stmt);
@@ -9314,6 +9573,24 @@ package body Exp_Aggr is
return False;
end Must_Slide;
+ ---------------------------------
+ -- Parent_Is_Regular_Aggregate --
+ ---------------------------------
+
+ function Parent_Is_Regular_Aggregate (Par : Node_Id) return Boolean is
+ begin
+ case Nkind (Par) is
+ when N_Component_Association =>
+ return Parent_Is_Regular_Aggregate (Parent (Par));
+
+ when N_Extension_Aggregate | N_Aggregate =>
+ return not Is_Container_Aggregate (Par);
+
+ when others =>
+ return False;
+ end case;
+ end Parent_Is_Regular_Aggregate;
+
---------------------
-- Sort_Case_Table --
---------------------
diff --git a/gcc/ada/exp_aggr.ads b/gcc/ada/exp_aggr.ads
index c071e76..0da0d8f 100644
--- a/gcc/ada/exp_aggr.ads
+++ b/gcc/ada/exp_aggr.ads
@@ -59,6 +59,10 @@ package Exp_Aggr is
-- This is the case if it consists only of iterated component associations
-- with iterator specifications, see RM 4.3.3(20.2/5).
+ function Parent_Is_Regular_Aggregate (Par : Node_Id) return Boolean;
+ -- Return True if Par is an aggregate that is not a container aggregate, or
+ -- a component association of such an aggregate.
+
function Static_Array_Aggregate (N : Node_Id) return Boolean;
-- N is an array aggregate that may have a component association with
-- an others clause and a range. If bounds are static and the expressions
diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb
index b896228..0f09ba5 100644
--- a/gcc/ada/exp_attr.adb
+++ b/gcc/ada/exp_attr.adb
@@ -24,6 +24,7 @@
------------------------------------------------------------------------------
with Accessibility; use Accessibility;
+with Aspects; use Aspects;
with Atree; use Atree;
with Checks; use Checks;
with Debug; use Debug;
@@ -88,8 +89,10 @@ package body Exp_Attr is
function Attribute_Op_Hash (Id : Entity_Id) return Header_Num is
(Header_Num (Id mod Map_Size));
- -- Cache used to avoid building duplicate subprograms for a single
- -- type/streaming-attribute pair.
+ -- Caches used to avoid building duplicate subprograms for a single
+ -- type/attribute pair (where the attribute is either Put_Image or
+ -- one of the four streaming attributes). The type used as a key in
+ -- in accessing these maps should not be the entity of a subtype.
package Read_Map is new GNAT.HTable.Simple_HTable
(Header_Num => Header_Num,
@@ -282,8 +285,8 @@ package body Exp_Attr is
(In_Same_Extended_Unit (Subp_Unit, Attr_Ref_Unit)
-- If subp declared in unit body, then we don't want to refer
-- to it from within unit spec so return False in that case.
- and then not (Body_Required (Attr_Ref_Unit)
- and not Body_Required (Subp_Unit)));
+ and then not (not Is_Body (Unit (Attr_Ref_Unit))
+ and Is_Body (Unit (Subp_Unit))));
-- Returns True if it is ok to refer to a cached subprogram declared in
-- Subp_Unit from the point of an attribute reference occurring in
-- Attr_Ref_Unit. Both arguments are usually N_Compilation_Nodes,
@@ -4669,7 +4672,7 @@ package body Exp_Attr is
end if;
if not Is_Tagged_Type (P_Type) then
- Cached_Attribute_Ops.Input_Map.Set (P_Type, Fname);
+ Cached_Attribute_Ops.Input_Map.Set (U_Type, Fname);
end if;
end Input;
@@ -4983,6 +4986,316 @@ package body Exp_Attr is
Analyze_And_Resolve (N, Typ);
+ ----------
+ -- Make --
+ ----------
+
+ when Attribute_Make =>
+ declare
+ Params : List_Id;
+ Param : Node_Id;
+ Par : Node_Id;
+ Construct : Entity_Id;
+ Obj : Node_Id := Empty;
+ Make_Expr : Node_Id := N;
+
+ Formal : Entity_Id;
+ Replace_Expr : Node_Id;
+ Init_Param : Node_Id;
+ Construct_Call : Node_Id;
+ Curr_Nam : Node_Id := Empty;
+
+ function Replace_Formal_Ref
+ (N : Node_Id) return Traverse_Result;
+
+ function Replace_Formal_Ref
+ (N : Node_Id) return Traverse_Result is
+ begin
+ if Is_Entity_Name (N)
+ and then Chars (Formal) = Chars (N)
+ then
+ Rewrite (N,
+ New_Copy_Tree (Replace_Expr));
+ end if;
+
+ return OK;
+ end Replace_Formal_Ref;
+
+ procedure Search_And_Replace_Formal is new
+ Traverse_Proc (Replace_Formal_Ref);
+
+ begin
+ -- Remove side effects for constructor call
+
+ Param := First (Expressions (N));
+ while Present (Param) loop
+ if Nkind (Param) = N_Parameter_Association then
+ Remove_Side_Effects (Explicit_Actual_Parameter (Param),
+ Check_Side_Effects => False);
+ else
+ Remove_Side_Effects (Param, Check_Side_Effects => False);
+ end if;
+
+ Next (Param);
+ end loop;
+
+ -- Construct the parameters list
+
+ Params := New_Copy_List (Expressions (N));
+ if Is_Empty_List (Params) then
+ Params := New_List;
+ end if;
+
+ -- Identify the enclosing parent for the non-copy cases
+
+ Par := Parent (N);
+ if Nkind (Par) = N_Qualified_Expression then
+ Par := Parent (Par);
+ Make_Expr := Par;
+ end if;
+ if Nkind (Par) = N_Allocator then
+ Par := Parent (Par);
+ Curr_Nam := Make_Explicit_Dereference
+ (Loc, Prefix => Empty);
+ Obj := Curr_Nam;
+ end if;
+
+ declare
+ Base_Obj : Node_Id := Empty;
+ Typ_Comp : Entity_Id;
+ Agg_Comp : Entity_Id;
+ Comp_Nam : Node_Id := Empty;
+ begin
+ while Nkind (Par) not in N_Object_Declaration
+ | N_Assignment_Statement
+ loop
+ if Nkind (Par) = N_Aggregate then
+ Typ_Comp := First_Entity (Etype (Par));
+ Agg_Comp := First (Expressions (Par));
+ loop
+ if No (Agg_Comp) then
+ return;
+ end if;
+
+ if Agg_Comp = Make_Expr then
+ Comp_Nam :=
+ Make_Selected_Component (Loc,
+ Prefix => Empty,
+ Selector_Name =>
+ New_Occurrence_Of (Typ_Comp, Loc));
+
+ Make_Expr := Parent (Make_Expr);
+ Par := Parent (Par);
+ exit;
+ end if;
+
+ Next_Entity (Typ_Comp);
+ Next (Agg_Comp);
+ end loop;
+ elsif Nkind (Par) = N_Component_Association then
+ Comp_Nam :=
+ Make_Selected_Component (Loc,
+ Prefix => Empty,
+ Selector_Name =>
+ Make_Identifier (Loc,
+ (Chars (First (Choices (Par))))));
+
+ Make_Expr := Parent (Parent (Make_Expr));
+ Par := Parent (Parent (Par));
+ else
+ declare
+ Temp : constant Entity_Id :=
+ Make_Temporary (Loc, 'T', N);
+ begin
+ Rewrite (N,
+ Make_Expression_With_Actions (Loc,
+ Actions => New_List (
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Temp,
+ Object_Definition =>
+ New_Occurrence_Of (Typ, Loc),
+ Expression =>
+ New_Copy_Tree (N))),
+ Expression => New_Occurrence_Of (Temp, Loc)));
+ Analyze_And_Resolve (N);
+ return;
+ end;
+ end if;
+
+ if No (Curr_Nam) then
+ Curr_Nam := Comp_Nam;
+ Obj := Curr_Nam;
+ elsif Has_Prefix (Curr_Nam) then
+ Set_Prefix (Curr_Nam, Comp_Nam);
+ Curr_Nam := Comp_Nam;
+ end if;
+ end loop;
+
+ Base_Obj := (case Nkind (Par) is
+ when N_Assignment_Statement =>
+ New_Copy_Tree (Name (Par)),
+ when N_Object_Declaration =>
+ New_Occurrence_Of
+ (Defining_Identifier (Par), Loc),
+ when others => (raise Program_Error));
+
+ if Present (Curr_Nam) then
+ Set_Prefix (Curr_Nam, Base_Obj);
+ else
+ Obj := Base_Obj;
+ end if;
+ end;
+
+ Prepend_To (Params, Obj);
+
+ -- Find the constructor we are interested in by doing a
+ -- pseudo-pass to resolve the constructor call.
+
+ declare
+ Dummy_Params : List_Id := New_Copy_List (Expressions (N));
+ Dummy_Self : Node_Id;
+ Dummy_Block : Node_Id;
+ Dummy_Call : Node_Id;
+ Dummy_Id : Entity_Id := Make_Temporary (Loc, 'D', N);
+ begin
+ if Is_Empty_List (Dummy_Params) then
+ Dummy_Params := New_List;
+ end if;
+
+ Dummy_Self := Make_Object_Declaration (Loc,
+ Defining_Identifier => Dummy_Id,
+ Object_Definition =>
+ New_Occurrence_Of (Typ, Loc));
+ Prepend_To (Dummy_Params, New_Occurrence_Of (Dummy_Id, Loc));
+
+ Dummy_Call := Make_Procedure_Call_Statement (Loc,
+ Parameter_Associations => Dummy_Params,
+ Name =>
+ (if not Has_Prefix (Pref) then
+ Make_Identifier (Loc,
+ Chars (Constructor_Name (Typ)))
+ else
+ Make_Expanded_Name (Loc,
+ Chars =>
+ Chars (Constructor_Name (Typ)),
+ Prefix =>
+ New_Copy_Tree (Prefix (Pref)),
+ Selector_Name =>
+ Make_Identifier (Loc,
+ Chars (Constructor_Name (Typ))))));
+ Set_Is_Expanded_Constructor_Call (Dummy_Call, True);
+
+ Dummy_Block := Make_Block_Statement (Loc,
+ Declarations => New_List (Dummy_Self),
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (Dummy_Call)));
+
+ Expander_Active := False;
+
+ Insert_After_And_Analyze
+ (Enclosing_Declaration_Or_Statement (Par), Dummy_Block);
+
+ Expander_Active := True;
+
+ -- Finally, we can get the constructor based on our pseudo-pass
+
+ Construct := Entity (Name (Dummy_Call));
+
+ -- Replace the Typ'Make attribute with an aggregate featuring
+ -- then relevant aggregate from the correct constructor's
+ -- Inializeaspect if it is present - otherwise, simply use a
+ -- box.
+
+ if Has_Aspect (Construct, Aspect_Initialize) then
+ Rewrite (N,
+ New_Copy_Tree
+ (Find_Value_Of_Aspect (Construct, Aspect_Initialize)));
+
+ Param := Next (First (Params));
+ Formal := Next_Entity (First_Entity (Construct));
+ while Present (Param) loop
+ if Nkind (Param) = N_Parameter_Association then
+ Formal := Selector_Name (Param);
+ Replace_Expr := Explicit_Actual_Parameter (Param);
+ else
+ Replace_Expr := Param;
+ end if;
+
+ Init_Param := First (Component_Associations (N));
+ while Present (Init_Param) loop
+ Search_And_Replace_Formal (Expression (Init_Param));
+
+ Next (Init_Param);
+ end loop;
+
+ if Nkind (Param) /= N_Parameter_Association then
+ Next_Entity (Formal);
+ end if;
+ Next (Param);
+ end loop;
+
+ Init_Param := First (Component_Associations (N));
+ while Present (Init_Param) loop
+ if Nkind (Expression (Init_Param)) = N_Attribute_Reference
+ and then Attribute_Name
+ (Expression (Init_Param)) = Name_Make
+ then
+ Insert_After (Par,
+ Make_Assignment_Statement (Loc,
+ Name =>
+ Make_Selected_Component (Loc,
+ Prefix =>
+ New_Copy_Tree (First (Params)),
+ Selector_Name =>
+ Make_Identifier (Loc,
+ Chars (First (Choices (Init_Param))))),
+ Expression =>
+ New_Copy_Tree (Expression (Init_Param))));
+
+ Rewrite (Expression (Init_Param),
+ Make_Aggregate (Loc,
+ Expressions => New_List,
+ Component_Associations => New_List (
+ Make_Component_Association (Loc,
+ Choices =>
+ New_List (Make_Others_Choice (Loc)),
+ Expression => Empty,
+ Box_Present => True))));
+ end if;
+
+ Next (Init_Param);
+ end loop;
+ else
+ Rewrite (N,
+ Make_Aggregate (Loc,
+ Expressions => New_List,
+ Component_Associations => New_List (
+ Make_Component_Association (Loc,
+ Choices => New_List (Make_Others_Choice (Loc)),
+ Expression => Empty,
+ Box_Present => True))));
+ end if;
+
+ -- Rewrite this block to be null and pretend it didn't happen
+
+ Rewrite (Dummy_Block, Make_Null_Statement (Loc));
+ end;
+
+ Analyze_And_Resolve (N, Typ);
+
+ -- Finally, insert the constructor call
+
+ Construct_Call :=
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Occurrence_Of (Construct, Loc),
+ Parameter_Associations => Params);
+
+ Set_Is_Expanded_Constructor_Call (Construct_Call);
+ Insert_After (Par, Construct_Call);
+ end;
+
--------------
-- Mantissa --
--------------
@@ -5040,22 +5353,42 @@ package body Exp_Attr is
Typ : constant Entity_Id := Etype (N);
begin
- -- If the prefix is X'Class, we transform it into a direct reference
- -- to the class-wide type, because the back end must not see a 'Class
- -- reference. See also 'Size.
+ -- Tranform T'Class'Max_Size_In_Storage_Elements (for any T) into
+ -- Storage_Count'Pos (Storage_Count'Last), because it must include
+ -- all descendants, which can be arbitrarily large. Note that the
+ -- back end must not see any 'Class attribute references.
+ -- The 'Pos is to make it be of type universal_integer.
+ --
+ -- ???If T'Class'Size is specified, it should probably affect
+ -- T'Class'Max_Size_In_Storage_Elements accordingly.
if Is_Entity_Name (Pref)
and then Is_Class_Wide_Type (Entity (Pref))
then
- Rewrite (Prefix (N), New_Occurrence_Of (Entity (Pref), Loc));
- return;
- end if;
+ declare
+ Storage_Count_Type : constant Entity_Id :=
+ RTE (RE_Storage_Count);
+ Attr : constant Node_Id :=
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Storage_Count_Type, Loc),
+ Attribute_Name => Name_Pos,
+ Expressions => New_List (
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Storage_Count_Type, Loc),
+ Attribute_Name => Name_Last)));
+ begin
+ Rewrite (N, Attr);
+ Analyze_And_Resolve (N, Typ);
+ return;
+ end;
-- Heap-allocated controlled objects contain two extra pointers which
-- are not part of the actual type. Transform the attribute reference
-- into a runtime expression to add the size of the hidden header.
- if Needs_Finalization (Ptyp) and then not Header_Size_Added (N) then
+ elsif Needs_Finalization (Ptyp)
+ and then not Header_Size_Added (N)
+ then
Set_Header_Size_Added (N);
-- Generate:
@@ -5750,7 +6083,7 @@ package body Exp_Attr is
Rewrite_Attribute_Proc_Call (Pname);
if not Is_Tagged_Type (P_Type) then
- Cached_Attribute_Ops.Output_Map.Set (P_Type, Pname);
+ Cached_Attribute_Ops.Output_Map.Set (U_Type, Pname);
end if;
end Output;
@@ -6669,7 +7002,7 @@ package body Exp_Attr is
Rewrite_Attribute_Proc_Call (Pname);
if not Is_Tagged_Type (P_Type) then
- Cached_Attribute_Ops.Read_Map.Set (P_Type, Pname);
+ Cached_Attribute_Ops.Read_Map.Set (U_Type, Pname);
end if;
end Read;
@@ -7870,9 +8203,8 @@ package body Exp_Attr is
else
declare
Uns : constant Boolean :=
- Is_Unsigned_Type (Ptyp)
- or else (Is_Private_Type (Ptyp)
- and then Is_Unsigned_Type (PBtyp));
+ Is_Unsigned_Type (Validated_View (Ptyp));
+
Size : Uint;
P : Node_Id := Pref;
@@ -8349,7 +8681,7 @@ package body Exp_Attr is
Rewrite_Attribute_Proc_Call (Pname);
if not Is_Tagged_Type (P_Type) then
- Cached_Attribute_Ops.Write_Map.Set (P_Type, Pname);
+ Cached_Attribute_Ops.Write_Map.Set (U_Type, Pname);
end if;
end Write;
@@ -8600,10 +8932,10 @@ package body Exp_Attr is
Rewrite (N,
Make_Op_Multiply (Loc,
Make_Attribute_Reference (Loc,
- Prefix => Duplicate_Subexpr (Pref, True),
+ Prefix => Duplicate_Subexpr (Pref, Name_Req => True),
Attribute_Name => Name_Length),
Make_Attribute_Reference (Loc,
- Prefix => Duplicate_Subexpr (Pref, True),
+ Prefix => Duplicate_Subexpr (Pref, Name_Req => True),
Attribute_Name => Name_Component_Size)));
Analyze_And_Resolve (N, Typ);
end if;
@@ -8951,15 +9283,22 @@ package body Exp_Attr is
return Empty;
end if;
- if Nam = TSS_Stream_Read then
- Ent := Cached_Attribute_Ops.Read_Map.Get (Typ);
- elsif Nam = TSS_Stream_Write then
- Ent := Cached_Attribute_Ops.Write_Map.Get (Typ);
- elsif Nam = TSS_Stream_Input then
- Ent := Cached_Attribute_Ops.Input_Map.Get (Typ);
- elsif Nam = TSS_Stream_Output then
- Ent := Cached_Attribute_Ops.Output_Map.Get (Typ);
- end if;
+ declare
+ function U_Base return Entity_Id is
+ (Underlying_Type (Base_Type (Typ)));
+ -- Return the right type node for use in a C_A_O map lookup.
+ -- In particular, we do not want the entity for a subtype.
+ begin
+ if Nam = TSS_Stream_Read then
+ Ent := Cached_Attribute_Ops.Read_Map.Get (U_Base);
+ elsif Nam = TSS_Stream_Write then
+ Ent := Cached_Attribute_Ops.Write_Map.Get (U_Base);
+ elsif Nam = TSS_Stream_Input then
+ Ent := Cached_Attribute_Ops.Input_Map.Get (U_Base);
+ elsif Nam = TSS_Stream_Output then
+ Ent := Cached_Attribute_Ops.Output_Map.Get (U_Base);
+ end if;
+ end;
Cached_Attribute_Ops.Validate_Cached_Candidate
(Subp => Ent, Attr_Ref => Attr_Ref);
diff --git a/gcc/ada/exp_ch11.adb b/gcc/ada/exp_ch11.adb
index a0dbcad..ee6010a7 100644
--- a/gcc/ada/exp_ch11.adb
+++ b/gcc/ada/exp_ch11.adb
@@ -1194,8 +1194,6 @@ package body Exp_Ch11 is
Prefix => New_Occurrence_Of (Id, Loc),
Attribute_Name => Name_Unrestricted_Access)))));
- Set_Register_Exception_Call (Id, First (L));
-
if not Is_Library_Level_Entity (Id) then
Flag_Id :=
Make_Defining_Identifier (Loc,
@@ -1972,6 +1970,8 @@ package body Exp_Ch11 is
when CE_Tag_Check_Failed =>
Add_Str_To_Name_Buffer ("CE_Tag_Check");
+ when PE_Abstract_Type_Component =>
+ Add_Str_To_Name_Buffer ("PE_Abstract_Type_Component");
when PE_Access_Before_Elaboration =>
Add_Str_To_Name_Buffer ("PE_Access_Before_Elaboration");
when PE_Accessibility_Check_Failed =>
diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index bc46fd3..7c18f81 100644
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -69,6 +69,7 @@ with Sem_Res; use Sem_Res;
with Sem_SCIL; use Sem_SCIL;
with Sem_Type; use Sem_Type;
with Sem_Util; use Sem_Util;
+with Sem_Warn; use Sem_Warn;
with Sinfo; use Sinfo;
with Sinfo.Nodes; use Sinfo.Nodes;
with Sinfo.Utils; use Sinfo.Utils;
@@ -77,6 +78,7 @@ with Snames; use Snames;
with Tbuild; use Tbuild;
with Ttypes; use Ttypes;
with Validsw; use Validsw;
+with Warnsw; use Warnsw;
package body Exp_Ch3 is
@@ -671,7 +673,8 @@ package body Exp_Ch3 is
--------------------
function Init_Component return List_Id is
- Comp : Node_Id;
+ Comp : Node_Id;
+ Result : List_Id;
begin
Comp :=
@@ -681,7 +684,7 @@ package body Exp_Ch3 is
if Has_Default_Aspect (A_Type) then
Set_Assignment_OK (Comp);
- return New_List (
+ Result := New_List (
Make_Assignment_Statement (Loc,
Name => Comp,
Expression =>
@@ -690,7 +693,7 @@ package body Exp_Ch3 is
elsif Comp_Simple_Init then
Set_Assignment_OK (Comp);
- return New_List (
+ Result := New_List (
Make_Assignment_Statement (Loc,
Name => Comp,
Expression =>
@@ -701,7 +704,7 @@ package body Exp_Ch3 is
else
Clean_Task_Names (Comp_Type, Proc_Id);
- return
+ Result :=
Build_Initialization_Call
(N => Nod,
Id_Ref => Comp,
@@ -709,6 +712,19 @@ package body Exp_Ch3 is
In_Init_Proc => True,
Enclos_Type => A_Type);
end if;
+
+ -- Raise Program_Error in the init procedure of arrays when the type
+ -- of their components is a mutably tagged abstract class-wide type.
+
+ if Is_Class_Wide_Equivalent_Type (Component_Type (A_Type))
+ and then Is_Abstract_Type (Comp_Type)
+ then
+ Append_To (Result,
+ Make_Raise_Program_Error (Loc,
+ Reason => PE_Abstract_Type_Component));
+ end if;
+
+ return Result;
end Init_Component;
------------------------
@@ -2652,11 +2668,9 @@ package body Exp_Ch3 is
-- may have an incomplete type. In that case, it must also be
-- replaced by the formal of the Init_Proc.
- if Nkind (Parent (Rec_Type)) = N_Full_Type_Declaration
- and then Present (Incomplete_View (Parent (Rec_Type)))
- then
+ if Present (Incomplete_View (Rec_Type)) then
Append_Elmt (
- N => Incomplete_View (Parent (Rec_Type)),
+ N => Incomplete_View (Rec_Type),
To => Map);
Append_Elmt (
N => Defining_Identifier
@@ -2677,9 +2691,10 @@ package body Exp_Ch3 is
Exp_Q := Unqualify (Exp);
- -- Adjust the component if controlled, except if it is an aggregate
- -- that will be expanded inline (but note that the case of container
- -- aggregates does require component adjustment), or a function call.
+ -- Adjust the component if controlled, except if the expression is an
+ -- aggregate that will be expanded inline (but note that the case of
+ -- container aggregates does require component adjustment), or else
+ -- a function call whose result is adjusted in the called function.
-- Note that, when we don't inhibit component adjustment, the tag
-- will be automatically inserted by Make_Tag_Ctrl_Assignment in the
-- tagged case. Otherwise, we have to generate a tag assignment here.
@@ -2688,7 +2703,8 @@ package body Exp_Ch3 is
and then (Nkind (Exp_Q) not in N_Aggregate | N_Extension_Aggregate
or else Is_Container_Aggregate (Exp_Q))
and then not Is_Build_In_Place_Function_Call (Exp)
- and then Nkind (Exp) /= N_Function_Call
+ and then not (Back_End_Return_Slot
+ and then Nkind (Exp) = N_Function_Call)
then
Set_No_Finalize_Actions (First (Res));
@@ -3325,6 +3341,17 @@ package body Exp_Ch3 is
Make_Tag_Assignment_From_Type
(Loc, Make_Identifier (Loc, Name_uInit), Rec_Type));
+ -- Ensure that Program_Error is raised if a mutably class-wide
+ -- abstract tagged type is initialized by default.
+
+ if Is_Abstract_Type (Rec_Type)
+ and then Is_Mutably_Tagged_Type (Class_Wide_Type (Rec_Type))
+ then
+ Append_To (Init_Tags_List,
+ Make_Raise_Program_Error (Loc,
+ Reason => PE_Abstract_Type_Component));
+ end if;
+
-- Ada 2005 (AI-251): Initialize the secondary tags components
-- located at fixed positions (tags whose position depends on
-- variable size components are initialized later ---see below)
@@ -3746,6 +3773,16 @@ package body Exp_Ch3 is
-- Explicit initialization
if Present (Expression (Decl)) then
+
+ -- Ensure that the type of the expression initializing a
+ -- mutably tagged class-wide type component is frozen.
+
+ if Nkind (Expression (Decl)) = N_Qualified_Expression
+ and then Is_Class_Wide_Equivalent_Type (Etype (Id))
+ then
+ Freeze_Before (N, Etype (Expression (Decl)));
+ end if;
+
if Is_CPP_Constructor_Call (Expression (Decl)) then
Actions :=
Build_Initialization_Call
@@ -3765,6 +3802,21 @@ package body Exp_Ch3 is
Actions := Build_Assignment (Id, Expression (Decl));
end if;
+ -- Expand components with constructors to have the 'Make
+ -- attribute.
+
+ elsif Present (Constructor_Name (Typ))
+ and then Present (Default_Constructor (Typ))
+ then
+ Set_Expression (Decl,
+ Make_Attribute_Reference (Loc,
+ Attribute_Name => Name_Make,
+ Prefix =>
+ Subtype_Indication
+ (Component_Definition (Decl))));
+ Analyze (Expression (Decl));
+ Actions := Build_Assignment (Id, Expression (Decl));
+
-- CPU, Dispatching_Domain, Priority, and Secondary_Stack_Size
-- components are filled in with the corresponding rep-item
-- expression of the concurrent type (if any).
@@ -3902,6 +3954,15 @@ package body Exp_Ch3 is
Discr_Map => Discr_Map,
Init_Control_Actual => Init_Control_Actual);
+ if Is_Mutably_Tagged_CW_Equivalent_Type (Etype (Id))
+ and then not Is_Parent
+ and then Is_Abstract_Type (Typ)
+ then
+ Append_To (Init_Call_Stmts,
+ Make_Raise_Program_Error (Comp_Loc,
+ Reason => PE_Abstract_Type_Component));
+ end if;
+
if Is_Parent then
-- This is tricky. At first it looks like
-- we are going to end up with nested
@@ -4522,6 +4583,11 @@ package body Exp_Ch3 is
if Present (Expression (Comp_Decl))
or else Has_Non_Null_Base_Init_Proc (Typ)
or else Component_Needs_Simple_Initialization (Typ)
+
+ -- Mutably tagged class-wide types require the init-proc since
+ -- it takes care of their default initialization.
+
+ or else Is_Mutably_Tagged_CW_Equivalent_Type (Typ)
then
return True;
end if;
@@ -5093,6 +5159,32 @@ package body Exp_Ch3 is
if Is_Library_Level_Entity (Typ) then
Set_Is_Public (Op);
end if;
+
+ -- Otherwise, the result is defined in terms of the primitive equals
+ -- operator (RM 4.5.2 (24/3)). Report a warning if some component of
+ -- the untagged record has defined a user-defined "=", because it can
+ -- be surprising that the predefined "=" takes precedence over it.
+ -- This warning is not reported when Build_Eq is True because the
+ -- expansion of the built body will call Expand_Composite_Equality
+ -- that will report it if necessary.
+
+ elsif Warn_On_Ignored_Equality then
+ Comp := First_Component (Typ);
+
+ while Present (Comp) loop
+ if Present (User_Defined_Eq (Etype (Comp)))
+ and then not Is_Record_Type (Etype (Comp))
+ and then not Is_Intrinsic_Subprogram
+ (User_Defined_Eq (Etype (Comp)))
+ then
+ Warn_On_Ignored_Equality_Operator
+ (Typ => Typ,
+ Comp_Typ => Etype (Comp),
+ Loc => Sloc (User_Defined_Eq (Etype (Comp))));
+ end if;
+
+ Next_Component (Comp);
+ end loop;
end if;
end Build_Untagged_Record_Equality;
@@ -5423,18 +5515,12 @@ package body Exp_Ch3 is
-- with an initial value, its Init_Proc will never be called. The
-- initial value itself may have been expanded into assignments,
-- in which case the declaration has the No_Initialization flag.
- -- The exception is when the initial value is a 2-pass aggregate,
- -- because the special expansion used for it creates a temporary
- -- that needs a fully-fledged initialization.
if Is_Itype (Base)
and then Nkind (Associated_Node_For_Itype (Base)) =
N_Object_Declaration
and then
- ((Present (Expression (Associated_Node_For_Itype (Base)))
- and then not
- Is_Two_Pass_Aggregate
- (Expression (Associated_Node_For_Itype (Base))))
+ (Present (Expression (Associated_Node_For_Itype (Base)))
or else No_Initialization (Associated_Node_For_Itype (Base)))
then
null;
@@ -6760,12 +6846,13 @@ package body Exp_Ch3 is
procedure Expand_N_Object_Declaration (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Def_Id : constant Entity_Id := Defining_Identifier (N);
- Expr : constant Node_Id := Expression (N);
Obj_Def : constant Node_Id := Object_Definition (N);
Typ : constant Entity_Id := Etype (Def_Id);
Base_Typ : constant Entity_Id := Base_Type (Typ);
Next_N : constant Node_Id := Next (N);
+ Expr : Node_Id := Expression (N);
+
Special_Ret_Obj : constant Boolean := Is_Special_Return_Object (Def_Id);
-- If this is a special return object, it will be allocated differently
-- and ultimately rewritten as a renaming, so initialization activities
@@ -6894,7 +6981,9 @@ package body Exp_Ch3 is
-- Processing for objects that require finalization actions
- if Needs_Finalization (Ret_Typ) then
+ if Needs_Finalization (Ret_Typ)
+ and then not Has_Relaxed_Finalization (Ret_Typ)
+ then
declare
Decls : constant List_Id := New_List;
Fin_Coll_Id : constant Entity_Id :=
@@ -7482,7 +7571,11 @@ package body Exp_Ch3 is
-- Don't do anything for deferred constants. All proper actions will be
-- expanded during the full declaration.
- if No (Expr) and Constant_Present (N) then
+ if No (Expr)
+ and then Constant_Present (N)
+ and then (No (Constructor_Name (Typ))
+ or else No (Default_Constructor (Typ)))
+ then
return;
end if;
@@ -7507,6 +7600,21 @@ package body Exp_Ch3 is
return;
end if;
+ -- Expand objects with default constructors to have the 'Make
+ -- attribute.
+
+ if Comes_From_Source (N)
+ and then No (Expr)
+ and then Present (Constructor_Name (Typ))
+ and then Present (Default_Constructor (Typ))
+ then
+ Expr := Make_Attribute_Reference (Loc,
+ Attribute_Name => Name_Make,
+ Prefix => Object_Definition (N));
+ Set_Expression (N, Expr);
+ Analyze_And_Resolve (Expr);
+ end if;
+
-- Make shared memory routines for shared passive variable
if Is_Shared_Passive (Def_Id) then
@@ -8293,12 +8401,15 @@ package body Exp_Ch3 is
-- where the object has been initialized by a call to a function
-- returning on the primary stack (see Expand_Ctrl_Function_Call)
-- since no copy occurred, given that the type is by-reference.
+ -- Likewise if it is initialized by a 2-pass aggregate, since the
+ -- actual initialization will only occur during the second pass.
-- Similarly, no adjustment is needed if we are going to rewrite
-- the object declaration into a renaming declaration.
if Needs_Finalization (Typ)
and then not Is_Inherently_Limited_Type (Typ)
and then Nkind (Expr_Q) /= N_Function_Call
+ and then not Is_Two_Pass_Aggregate (Expr_Q)
and then not Rewrite_As_Renaming
then
Adj_Call :=
@@ -8711,8 +8822,9 @@ package body Exp_Ch3 is
-- be illegal in some cases (such as converting access-
-- to-unconstrained to access-to-constrained), but the
-- the unchecked conversion will presumably fail to work
- -- right in just such cases. It's not clear at all how to
- -- handle this.
+ -- right in just such cases. In order to handle this
+ -- properly, in the Caller_Allocation case, the callee
+ -- needs to do the constraint check.
Alloc_Stmt :=
Make_If_Statement (Loc,
diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb
index 82978c7..b427002 100644
--- a/gcc/ada/exp_ch4.adb
+++ b/gcc/ada/exp_ch4.adb
@@ -177,12 +177,6 @@ package body Exp_Ch4 is
-- integer type. This is a case where top level processing is required to
-- handle overflow checks in subtrees.
- procedure Fixup_Universal_Fixed_Operation (N : Node_Id);
- -- N is a N_Op_Divide or N_Op_Multiply node whose result is universal
- -- fixed. We do not have such a type at runtime, so the purpose of this
- -- routine is to find the real type by looking up the tree. We also
- -- determine if the operation must be rounded.
-
procedure Get_First_Index_Bounds (T : Entity_Id; Lo, Hi : out Uint);
-- T is an array whose index bounds are all known at compile time. Return
-- the value of the low and high bounds of the first index of T.
@@ -193,12 +187,12 @@ package body Exp_Ch4 is
procedure Insert_Conditional_Object_Declaration
(Obj_Id : Entity_Id;
+ Typ : Entity_Id;
Expr : Node_Id;
- Decl : Node_Id);
- -- Expr is the dependent expression of a conditional expression and Decl
- -- is the declaration of an object whose initialization expression is the
- -- conditional expression. Insert in the actions of Expr the declaration
- -- of Obj_Id modeled on Decl and with Expr as initialization expression.
+ Const : Boolean);
+ -- Expr is the dependent expression of a conditional expression. Insert in
+ -- the actions of Expr the declaration of Obj_Id with type Typ and Expr as
+ -- initialization expression. Const is True when Obj_Id is a constant.
procedure Insert_Dereference_Action (N : Node_Id);
-- N is an expression whose type is an access. When the type of the
@@ -240,6 +234,10 @@ package body Exp_Ch4 is
-- skipped if the operation is done in Bignum mode but that's fine, since
-- the Bignum call takes care of everything.
+ function New_Assign_Copy (N : Node_Id; Expr : Node_Id) return Node_Id;
+ -- N is an assignment statement. Return a copy of N with the same name but
+ -- expression changed to Expr and perform a couple of adjustments.
+
procedure Narrow_Large_Operation (N : Node_Id);
-- Try to compute the result of a large operation in a narrower type than
-- its nominal type. This is mainly aimed at getting rid of operations done
@@ -727,7 +725,7 @@ package body Exp_Ch4 is
-- adjust after the assignment but, in either case, we do not
-- finalize before since the target is newly allocated memory.
- if Nkind (Exp) = N_Function_Call then
+ if Back_End_Return_Slot and then Nkind (Exp) = N_Function_Call then
Set_No_Ctrl_Actions (Assign);
else
Set_No_Finalize_Actions (Assign);
@@ -769,7 +767,6 @@ package body Exp_Ch4 is
-- Local variables
Aggr_In_Place : Boolean;
- Container_Aggr : Boolean;
Delayed_Cond_Expr : Boolean;
TagT : Entity_Id := Empty;
@@ -865,13 +862,12 @@ package body Exp_Ch4 is
Aggr_In_Place := Is_Delayed_Aggregate (Exp);
Delayed_Cond_Expr := Is_Delayed_Conditional_Expression (Exp);
- Container_Aggr := Nkind (Exp) = N_Aggregate
- and then Has_Aspect (T, Aspect_Aggregate);
- -- An allocator with a container aggregate as qualified expression must
- -- be rewritten into the form expected by Expand_Container_Aggregate.
+ -- An allocator with a container aggregate, resp. a 2-pass aggregate,
+ -- as qualified expression must be rewritten into the form expected by
+ -- Expand_Container_Aggregate, resp. Two_Pass_Aggregate_Expansion.
- if Container_Aggr then
+ if Is_Container_Aggregate (Exp) or else Is_Two_Pass_Aggregate (Exp) then
Temp := Make_Temporary (Loc, 'P', N);
Set_Analyzed (Exp, False);
Insert_Action (N,
@@ -2468,21 +2464,20 @@ package body Exp_Ch4 is
declare
Op : constant Entity_Id := Find_Primitive_Eq (Comp_Type);
+
begin
- if Warn_On_Ignored_Equality
- and then Present (Op)
+ if Present (Op)
and then not In_Predefined_Unit (Base_Type (Comp_Type))
and then not Is_Intrinsic_Subprogram (Op)
then
pragma Assert
(Is_First_Subtype (Outer_Type)
or else Is_Generic_Actual_Type (Outer_Type));
- Error_Msg_Node_2 := Comp_Type;
- Error_Msg_N
- ("?_q?""="" for type & uses predefined ""="" for }",
- Outer_Type);
- Error_Msg_Sloc := Sloc (Op);
- Error_Msg_N ("\?_q?""="" # is ignored here", Outer_Type);
+
+ Warn_On_Ignored_Equality_Operator
+ (Typ => Outer_Type,
+ Comp_Typ => Comp_Type,
+ Loc => Sloc (Op));
end if;
end;
@@ -4490,6 +4485,15 @@ package body Exp_Ch4 is
Error_Msg_N ("?_a?use of an anonymous access type allocator", N);
end if;
+ -- Here we set no initialization on types with constructors since we
+ -- generate initialization for the separately.
+
+ if Present (Constructor_Name (Directly_Designated_Type (PtrT)))
+ and then Nkind (Expression (N)) = N_Identifier
+ then
+ Set_No_Initialization (N, False);
+ end if;
+
-- RM E.2.2(17). We enforce that the expected type of an allocator
-- shall not be a remote access-to-class-wide-limited-private type.
-- We probably shouldn't be doing this legality check during expansion,
@@ -5181,6 +5185,8 @@ package body Exp_Ch4 is
-- expansion until the (immediate) parent is rewritten as a return
-- statement (or is already the return statement). Likewise if it is
-- in the context of an object declaration that can be optimized.
+ -- Likewise if it is in the context of a regular agggregate and the
+ -- type should not be copied.
if not Expansion_Delayed (N) then
declare
@@ -5188,6 +5194,8 @@ package body Exp_Ch4 is
begin
if Nkind (Uncond_Par) = N_Simple_Return_Statement
or else Is_Optimizable_Declaration (Uncond_Par)
+ or else (Parent_Is_Regular_Aggregate (Uncond_Par)
+ and then not Is_Copy_Type (Typ))
then
Delay_Conditional_Expressions_Between (N, Uncond_Par);
end if;
@@ -5303,7 +5311,7 @@ package body Exp_Ch4 is
-- 'Unrestricted_Access.
-- Generate:
- -- type Ptr_Typ is not null access all [constant] Typ;
+ -- type Target_Typ is not null access all [constant] Typ;
else
Target_Typ := Make_Temporary (Loc, 'P');
@@ -5367,17 +5375,7 @@ package body Exp_Ch4 is
if Optimize_Assignment_Stmt then
-- We directly copy the parent node to preserve its flags
- Stmts := New_List (New_Copy (Par));
- Set_Sloc (First (Stmts), Alt_Loc);
- Set_Name (First (Stmts), New_Copy_Tree (Name (Par)));
- Set_Expression (First (Stmts), Alt_Expr);
-
- -- If the expression is itself a conditional expression whose
- -- expansion has been delayed, analyze it again and expand it.
-
- if Is_Delayed_Conditional_Expression (Alt_Expr) then
- Unanalyze_Delayed_Conditional_Expression (Alt_Expr);
- end if;
+ Stmts := New_List (New_Assign_Copy (Par, Alt_Expr));
-- Generate:
-- return AX;
@@ -5401,20 +5399,16 @@ package body Exp_Ch4 is
elsif Optimize_Object_Decl then
Obj := Make_Temporary (Loc, 'C', Alt_Expr);
- Insert_Conditional_Object_Declaration (Obj, Alt_Expr, Par);
-
- Alt_Expr :=
- Make_Attribute_Reference (Alt_Loc,
- Prefix => New_Occurrence_Of (Obj, Alt_Loc),
- Attribute_Name => Name_Unrestricted_Access);
-
- LHS := New_Occurrence_Of (Target, Loc);
- Set_Assignment_OK (LHS);
+ Insert_Conditional_Object_Declaration
+ (Obj, Typ, Alt_Expr, Const => Constant_Present (Par));
Stmts := New_List (
Make_Assignment_Statement (Alt_Loc,
- Name => LHS,
- Expression => Alt_Expr));
+ Name => New_Occurrence_Of (Target, Loc),
+ Expression =>
+ Make_Attribute_Reference (Alt_Loc,
+ Prefix => New_Occurrence_Of (Obj, Alt_Loc),
+ Attribute_Name => Name_Unrestricted_Access)));
-- Take the unrestricted access of the expression value for non-
-- scalar types. This approach avoids big copies and covers the
@@ -5799,8 +5793,9 @@ package body Exp_Ch4 is
-- expansion until the (immediate) parent is rewritten as a return
-- statement (or is already the return statement). Likewise if it is
-- in the context of an object declaration that can be optimized.
- -- Note that this deals with the case of the elsif part of the if
- -- expression, if it exists.
+ -- Likewise if it is in the context of a regular agggregate and the
+ -- type should not be copied. Note that this deals with the case of
+ -- the elsif part of the if expression, if it exists.
if not Expansion_Delayed (N) then
declare
@@ -5808,6 +5803,8 @@ package body Exp_Ch4 is
begin
if Nkind (Uncond_Par) = N_Simple_Return_Statement
or else Is_Optimizable_Declaration (Uncond_Par)
+ or else (Parent_Is_Regular_Aggregate (Uncond_Par)
+ and then not Is_Copy_Type (Typ))
then
Delay_Conditional_Expressions_Between (N, Uncond_Par);
end if;
@@ -5910,26 +5907,8 @@ package body Exp_Ch4 is
-- We directly copy the parent node to preserve its flags
- New_Then := New_Copy (Par);
- Set_Sloc (New_Then, Sloc (Thenx));
- Set_Name (New_Then, New_Copy_Tree (Name (Par)));
- Set_Expression (New_Then, Relocate_Node (Thenx));
-
- -- If the expression is itself a conditional expression whose
- -- expansion has been delayed, analyze it again and expand it.
-
- if Is_Delayed_Conditional_Expression (Expression (New_Then)) then
- Unanalyze_Delayed_Conditional_Expression (Expression (New_Then));
- end if;
-
- New_Else := New_Copy (Par);
- Set_Sloc (New_Else, Sloc (Elsex));
- Set_Name (New_Else, New_Copy_Tree (Name (Par)));
- Set_Expression (New_Else, Relocate_Node (Elsex));
-
- if Is_Delayed_Conditional_Expression (Expression (New_Else)) then
- Unanalyze_Delayed_Conditional_Expression (Expression (New_Else));
- end if;
+ New_Then := New_Assign_Copy (Par, Relocate_Node (Thenx));
+ New_Else := New_Assign_Copy (Par, Relocate_Node (Elsex));
If_Stmt :=
Make_Implicit_If_Statement (N,
@@ -6012,8 +5991,10 @@ package body Exp_Ch4 is
Target : constant Entity_Id := Make_Temporary (Loc, 'C', N);
begin
- Insert_Conditional_Object_Declaration (Then_Obj, Thenx, Par);
- Insert_Conditional_Object_Declaration (Else_Obj, Elsex, Par);
+ Insert_Conditional_Object_Declaration
+ (Then_Obj, Typ, Thenx, Const => Constant_Present (Par));
+ Insert_Conditional_Object_Declaration
+ (Else_Obj, Typ, Elsex, Const => Constant_Present (Par));
-- Generate:
-- type Ptr_Typ is not null access all [constant] Typ;
@@ -13284,17 +13265,20 @@ package body Exp_Ch4 is
procedure Insert_Conditional_Object_Declaration
(Obj_Id : Entity_Id;
+ Typ : Entity_Id;
Expr : Node_Id;
- Decl : Node_Id)
+ Const : Boolean)
is
Loc : constant Source_Ptr := Sloc (Expr);
Obj_Decl : constant Node_Id :=
Make_Object_Declaration (Loc,
Defining_Identifier => Obj_Id,
- Aliased_Present => Aliased_Present (Decl),
- Constant_Present => Constant_Present (Decl),
- Object_Definition => New_Copy_Tree (Object_Definition (Decl)),
+ Aliased_Present => True,
+ Constant_Present => Const,
+ Object_Definition => New_Occurrence_Of (Typ, Loc),
Expression => Relocate_Node (Expr));
+ -- We make the object unconditionally aliased to avoid dangling bound
+ -- issues when its nominal subtype is an unconstrained array type.
Master_Node_Decl : Node_Id;
Master_Node_Id : Entity_Id;
@@ -13309,6 +13293,21 @@ package body Exp_Ch4 is
Insert_Action (Expr, Obj_Decl);
+ -- The object can never be local to an elaboration routine at library
+ -- level since we will take 'Unrestricted_Access of it. Beware that
+ -- Is_Library_Level_Entity always returns False when called from within
+ -- a transient scope, but the associated block will not be materialized
+ -- when the transient scope is finally closed in the case of an object
+ -- declaration (see Exp.Ch7.Wrap_Transient_Declaration).
+
+ if Scope (Obj_Id) = Current_Scope and then Scope_Is_Transient then
+ Set_Is_Statically_Allocated
+ (Obj_Id, Is_Library_Level_Entity (Scope (Obj_Id)));
+ else
+ Set_Is_Statically_Allocated
+ (Obj_Id, Is_Library_Level_Entity (Obj_Id));
+ end if;
+
-- If the object needs finalization, we need to insert its Master_Node
-- manually because 1) the machinery in Exp_Ch7 will not pick it since
-- it will be declared in the arm of a conditional statement and 2) we
@@ -14197,6 +14196,39 @@ package body Exp_Ch4 is
end if;
end Narrow_Large_Operation;
+ ---------------------
+ -- New_Assign_Copy --
+ ---------------------
+
+ function New_Assign_Copy (N : Node_Id; Expr : Node_Id) return Node_Id is
+ New_N : constant Node_Id := New_Copy (N);
+
+ begin
+ Set_Sloc (New_N, Sloc (Expr));
+ Set_Name (New_N, New_Copy_Tree (Name (N)));
+ Set_Expression (New_N, Expr);
+
+ -- The result of a function call need not be adjusted if it has
+ -- already been adjusted in the called function.
+
+ if No_Finalize_Actions (New_N)
+ and then Back_End_Return_Slot
+ and then Nkind (Expr) = N_Function_Call
+ then
+ Set_No_Finalize_Actions (New_N, False);
+ Set_No_Ctrl_Actions (New_N);
+ end if;
+
+ -- If the expression is itself a conditional expression whose
+ -- expansion has been delayed, analyze it again and expand it.
+
+ if Is_Delayed_Conditional_Expression (Expr) then
+ Unanalyze_Delayed_Conditional_Expression (Expr);
+ end if;
+
+ return New_N;
+ end New_Assign_Copy;
+
--------------------------------
-- Optimize_Length_Comparison --
--------------------------------
@@ -15035,10 +15067,11 @@ package body Exp_Ch4 is
-- Handle entities from the limited view
- Orig_Right_Type : constant Entity_Id := Available_View (Etype (Right));
+ Orig_Right_Type : constant Entity_Id :=
+ Base_Type (Available_View (Etype (Right)));
Full_R_Typ : Entity_Id;
- Left_Type : Entity_Id := Available_View (Etype (Left));
+ Left_Type : Entity_Id := Base_Type (Available_View (Etype (Left)));
Right_Type : Entity_Id := Orig_Right_Type;
Obj_Tag : Node_Id;
diff --git a/gcc/ada/exp_ch4.ads b/gcc/ada/exp_ch4.ads
index d954852..4207715 100644
--- a/gcc/ada/exp_ch4.ads
+++ b/gcc/ada/exp_ch4.ads
@@ -124,4 +124,10 @@ package Exp_Ch4 is
-- have special circuitry in Expand_N_Type_Conversion to promote both of
-- the operands to type Integer.
+ procedure Fixup_Universal_Fixed_Operation (N : Node_Id);
+ -- N is a N_Op_Divide or N_Op_Multiply node whose result is universal
+ -- fixed. We do not have such a type at runtime, so the purpose of this
+ -- routine is to find the real type by looking up the tree. We also
+ -- determine if the operation must be rounded.
+
end Exp_Ch4;
diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb
index 06616ea..f46fb47 100644
--- a/gcc/ada/exp_ch5.adb
+++ b/gcc/ada/exp_ch5.adb
@@ -190,6 +190,9 @@ package body Exp_Ch5 is
-- specification and Container is either the Container (for OF) or the
-- iterator (for IN).
+ procedure Expand_Loop_Flow_Statement (N : N_Loop_Flow_Statement_Id);
+ -- Common processing for expansion of "loop flow" statements
+
procedure Expand_Predicated_Loop (N : Node_Id);
-- Expand for loop over predicated subtype
@@ -280,14 +283,11 @@ package body Exp_Ch5 is
Statements => Stats,
End_Label => Empty);
- -- If the contruct has a specified loop name, preserve it in the new
- -- loop, for possible use in exit statements.
+ -- Preserve the construct's loop name in the new loop, for possible use
+ -- in exit statements.
- if Present (Identifier (N))
- and then Comes_From_Source (Identifier (N))
- then
- Set_Identifier (New_Loop, Identifier (N));
- end if;
+ pragma Assert (Present (Identifier (N)));
+ Set_Identifier (New_Loop, Identifier (N));
end Build_Formal_Container_Iteration;
------------------------------
@@ -1039,7 +1039,8 @@ package body Exp_Ch5 is
Prefix =>
Make_Indexed_Component (Loc,
Prefix =>
- Duplicate_Subexpr_Move_Checks (Larray, True),
+ Duplicate_Subexpr_Move_Checks
+ (Larray, Name_Req => True),
Expressions => New_List (
Make_Attribute_Reference (Loc,
Prefix =>
@@ -1054,7 +1055,8 @@ package body Exp_Ch5 is
Prefix =>
Make_Indexed_Component (Loc,
Prefix =>
- Duplicate_Subexpr_Move_Checks (Rarray, True),
+ Duplicate_Subexpr_Move_Checks
+ (Rarray, Name_Req => True),
Expressions => New_List (
Make_Attribute_Reference (Loc,
Prefix =>
@@ -1396,7 +1398,7 @@ package body Exp_Ch5 is
Prefix =>
Make_Indexed_Component (Loc,
Prefix =>
- Duplicate_Subexpr (Larray, True),
+ Duplicate_Subexpr (Larray, Name_Req => True),
Expressions => New_List (New_Copy_Tree (Left_Lo))),
Attribute_Name => Name_Address);
@@ -1405,7 +1407,7 @@ package body Exp_Ch5 is
Prefix =>
Make_Indexed_Component (Loc,
Prefix =>
- Duplicate_Subexpr (Larray, True),
+ Duplicate_Subexpr (Larray, Name_Req => True),
Expressions => New_List (New_Copy_Tree (Left_Lo))),
Attribute_Name => Name_Bit);
@@ -1414,7 +1416,7 @@ package body Exp_Ch5 is
Prefix =>
Make_Indexed_Component (Loc,
Prefix =>
- Duplicate_Subexpr (Rarray, True),
+ Duplicate_Subexpr (Rarray, Name_Req => True),
Expressions => New_List (New_Copy_Tree (Right_Lo))),
Attribute_Name => Name_Address);
@@ -1423,7 +1425,7 @@ package body Exp_Ch5 is
Prefix =>
Make_Indexed_Component (Loc,
Prefix =>
- Duplicate_Subexpr (Rarray, True),
+ Duplicate_Subexpr (Rarray, Name_Req => True),
Expressions => New_List (New_Copy_Tree (Right_Lo))),
Attribute_Name => Name_Bit);
@@ -1439,11 +1441,11 @@ package body Exp_Ch5 is
Make_Op_Multiply (Loc,
Make_Attribute_Reference (Loc,
Prefix =>
- Duplicate_Subexpr (Name (N), True),
+ Duplicate_Subexpr (Name (N), Name_Req => True),
Attribute_Name => Name_Length),
Make_Attribute_Reference (Loc,
Prefix =>
- Duplicate_Subexpr (Name (N), True),
+ Duplicate_Subexpr (Name (N), Name_Req => True),
Attribute_Name => Name_Component_Size));
begin
@@ -1527,11 +1529,11 @@ package body Exp_Ch5 is
Make_Op_Multiply (Loc,
Make_Attribute_Reference (Loc,
Prefix =>
- Duplicate_Subexpr (Name (N), True),
+ Duplicate_Subexpr (Name (N), Name_Req => True),
Attribute_Name => Name_Length),
Make_Attribute_Reference (Loc,
Prefix =>
- Duplicate_Subexpr (Larray, True),
+ Duplicate_Subexpr (Larray, Name_Req => True),
Attribute_Name => Name_Component_Size));
L_Arg, R_Arg, Call : Node_Id;
@@ -1582,7 +1584,7 @@ package body Exp_Ch5 is
end if;
return Make_Assignment_Statement (Loc,
- Name => Duplicate_Subexpr (Larray, True),
+ Name => Duplicate_Subexpr (Larray, Name_Req => True),
Expression => Unchecked_Convert_To (L_Typ, Call));
end Expand_Assign_Array_Bitfield_Fast;
@@ -4423,16 +4425,98 @@ package body Exp_Ch5 is
end;
end Expand_N_Case_Statement;
+ ---------------------------------
+ -- Expand_N_Continue_Statement --
+ ---------------------------------
+
+ procedure Expand_N_Continue_Statement (N : Node_Id) is
+ X : constant Node_Id := Call_Or_Target_Loop (N);
+
+ Loc : constant Source_Ptr := Sloc (N);
+
+ Label : E_Label_Id;
+ begin
+ if No (X) then
+ return;
+ end if;
+
+ if Nkind (X) = N_Procedure_Call_Statement then
+ Replace (N, X);
+ Analyze (N);
+ return;
+ end if;
+
+ Expand_Loop_Flow_Statement (N);
+
+ declare
+ L : constant E_Loop_Id := Call_Or_Target_Loop (N);
+ M : constant Node_Id := Continue_Mark (L);
+ A : constant Node_Id := Next (M);
+ begin
+ if not (Present (A) and then Nkind (A) = N_Label) then
+ -- This is the first continue statement that is expanded for this
+ -- loop; we set up the label that the goto statement will target.
+ declare
+ P : constant Node_Id := Atree.Node_Parent (L);
+
+ Decl_List : constant List_Id :=
+ (if Nkind (P) = N_Implicit_Label_Declaration
+ then List_Containing (P)
+ else Declarations (Parent (Parent (P))));
+
+ Label_Entity : constant Entity_Id :=
+ Make_Defining_Identifier
+ (Loc, New_External_Name (Chars (L), 'C'));
+ Label_Id : constant N_Identifier_Id :=
+ Make_Identifier (Loc, Chars (Label_Entity));
+ Label_Node : constant N_Label_Id :=
+ Make_Label (Loc, Label_Id);
+ Label_Decl : constant N_Implicit_Label_Declaration_Id :=
+ Make_Implicit_Label_Declaration
+ (Loc, Label_Entity, Label_Node);
+ begin
+ Mutate_Ekind (Label_Entity, E_Label);
+ Set_Etype (Label_Entity, Standard_Void_Type);
+
+ Set_Entity (Label_Id, Label_Entity);
+ Set_Etype (Label_Id, Standard_Void_Type);
+
+ Insert_After (Node => Label_Node, After => M);
+
+ Append (Node => Label_Decl, To => Decl_List);
+
+ Label := Label_Entity;
+ end;
+ else
+ -- Some other continue statement for this loop was expanded
+ -- already, so we can reuse the label that is already set up.
+ Label := Entity (Identifier (A));
+ end if;
+ end;
+
+ declare
+ C : constant Opt_N_Subexpr_Id := Condition (N);
+ Goto_St : constant N_Goto_Statement_Id :=
+ Make_Goto_Statement (Loc, New_Occurrence_Of (Label, Loc));
+
+ New_St : constant Node_Id :=
+ (if Present (C)
+ then Make_If_Statement (Sloc (N), C, New_List (Goto_St))
+ else Goto_St);
+ begin
+ Set_Parent (New_St, Parent (N));
+ Replace (N, New_St);
+ end;
+
+ end Expand_N_Continue_Statement;
+
-----------------------------
-- Expand_N_Exit_Statement --
-----------------------------
- -- The only processing required is to deal with a possible C/Fortran
- -- boolean value used as the condition for the exit statement.
-
procedure Expand_N_Exit_Statement (N : Node_Id) is
begin
- Adjust_Condition (Condition (N));
+ Expand_Loop_Flow_Statement (N);
end Expand_N_Exit_Statement;
----------------------------------
@@ -5754,7 +5838,6 @@ package body Exp_Ch5 is
Loc : constant Source_Ptr := Sloc (N);
Scheme : constant Node_Id := Iteration_Scheme (N);
Stmt : Node_Id;
-
begin
-- Delete null loop
@@ -5978,8 +6061,7 @@ package body Exp_Ch5 is
-- ...
-- end loop
- elsif Present (Scheme)
- and then Present (Condition_Actions (Scheme))
+ elsif Present (Condition_Actions (Scheme))
and then Present (Condition (Scheme))
then
declare
@@ -6011,9 +6093,7 @@ package body Exp_Ch5 is
-- Here to deal with iterator case
- elsif Present (Scheme)
- and then Present (Iterator_Specification (Scheme))
- then
+ elsif Present (Iterator_Specification (Scheme)) then
Expand_Iterator_Loop (N);
-- An iterator loop may generate renaming declarations for elements
@@ -6044,6 +6124,18 @@ package body Exp_Ch5 is
Process_Statements_For_Controlled_Objects (Stmt);
end Expand_N_Loop_Statement;
+ --------------------------------
+ -- Expand_Loop_Flow_Statement --
+ --------------------------------
+
+ -- The only processing required is to deal with a possible C/Fortran
+ -- boolean value used as the condition for the statement.
+
+ procedure Expand_Loop_Flow_Statement (N : N_Loop_Flow_Statement_Id) is
+ begin
+ Adjust_Condition (Condition (N));
+ end Expand_Loop_Flow_Statement;
+
----------------------------
-- Expand_Predicated_Loop --
----------------------------
diff --git a/gcc/ada/exp_ch5.ads b/gcc/ada/exp_ch5.ads
index efde755..e75c128 100644
--- a/gcc/ada/exp_ch5.ads
+++ b/gcc/ada/exp_ch5.ads
@@ -31,6 +31,7 @@ package Exp_Ch5 is
procedure Expand_N_Assignment_Statement (N : Node_Id);
procedure Expand_N_Block_Statement (N : Node_Id);
procedure Expand_N_Case_Statement (N : Node_Id);
+ procedure Expand_N_Continue_Statement (N : Node_Id);
procedure Expand_N_Exit_Statement (N : Node_Id);
procedure Expand_N_Goto_When_Statement (N : Node_Id);
procedure Expand_N_If_Statement (N : Node_Id);
diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index 7e46454..6216192 100644
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -158,7 +158,7 @@ package body Exp_Ch6 is
Alloc_Form_Exp : Node_Id := Empty;
Pool_Exp : Node_Id := Empty);
-- Ada 2005 (AI-318-02): If the result type of a build-in-place call needs
- -- them, add the actuals parameters BIP_Alloc_Form and BIP_Storage_Pool.
+ -- them, add the actual parameters BIP_Alloc_Form and BIP_Storage_Pool.
-- If Alloc_Form_Exp is present, then pass it for the first parameter,
-- otherwise pass a literal corresponding to the Alloc_Form parameter
-- (which must not be Unspecified in that case). If Pool_Exp is present,
@@ -289,8 +289,8 @@ package body Exp_Ch6 is
-- denoted by the call needs finalization in the current subprogram, which
-- excludes return statements, and is not identified with another object
-- that will be finalized, which excludes (statically) declared objects,
- -- dynamically allocated objects, and targets of assignments that are done
- -- directly (without intermediate temporaries).
+ -- dynamically allocated objects, components of aggregates, and targets of
+ -- assignments that are done directly (without intermediate temporaries).
procedure Expand_Non_Function_Return (N : Node_Id);
-- Expand a simple return statement found in a procedure body, entry body,
@@ -442,9 +442,7 @@ package body Exp_Ch6 is
return;
end if;
- -- Locate the implicit allocation form parameter in the called function.
- -- Maybe it would be better for each implicit formal of a build-in-place
- -- function to have a flag or a Uint attribute to identify it. ???
+ -- Locate the implicit allocation form parameter in the called function
Alloc_Form_Formal := Build_In_Place_Formal (Function_Id, BIP_Alloc_Form);
@@ -928,9 +926,6 @@ package body Exp_Ch6 is
Formal_Suffix : constant String := BIP_Formal_Suffix (Kind);
begin
- -- Maybe it would be better for each implicit formal of a build-in-place
- -- function to have a flag or a Uint attribute to identify it. ???
-
-- The return type in the function declaration may have been a limited
-- view, and the extra formals for the function were not generated at
-- that point. At the point of call the full view must be available and
@@ -2470,11 +2465,6 @@ package body Exp_Ch6 is
-- (and ensure that we have an activation chain defined for tasks
-- and a Master variable).
- -- Currently we limit such functions to those with inherently
- -- limited result subtypes, but eventually we plan to expand the
- -- functions that are treated as build-in-place to include other
- -- composite result types.
-
-- But do not do it here for intrinsic subprograms since this will
-- be done properly after the subprogram is expanded.
@@ -5375,7 +5365,7 @@ package body Exp_Ch6 is
-- to copy/readjust/finalize, we can just pass the value through (see
-- Expand_N_Simple_Return_Statement), and thus no attachment is needed.
-- Note that simple return statements are distributed into conditional
- -- expressions but we may be invoked before this distribution is done.
+ -- expressions, but we may be invoked before this distribution is done.
if Nkind (Uncond_Par) = N_Simple_Return_Statement then
return;
@@ -5396,7 +5386,7 @@ package body Exp_Ch6 is
end if;
-- Note that object declarations are also distributed into conditional
- -- expressions but we may be invoked before this distribution is done.
+ -- expressions, but we may be invoked before this distribution is done.
elsif Nkind (Uncond_Par) = N_Object_Declaration then
return;
@@ -5412,6 +5402,16 @@ package body Exp_Ch6 is
return;
end if;
+ -- Another optimization: if the returned value is used to initialize the
+ -- component of an aggregate, then no need to copy/readjust/finalize, we
+ -- can initialize it in place. Note that assignments for aggregates are
+ -- also distributed into conditional expressions, but we may be invoked
+ -- before this distribution is done.
+
+ if Parent_Is_Regular_Aggregate (Uncond_Par) then
+ return;
+ end if;
+
-- Avoid expansion to catch the error when the function call is on the
-- left-hand side of an assignment. Likewise if it is on the right-hand
-- side and no controlling actions will be performed for the assignment,
@@ -8562,12 +8562,10 @@ package body Exp_Ch6 is
procedure Make_Build_In_Place_Call_In_Anonymous_Context
(Function_Call : Node_Id)
is
- Loc : constant Source_Ptr := Sloc (Function_Call);
- Func_Call : constant Node_Id := Unqual_Conv (Function_Call);
- Function_Id : Entity_Id;
- Result_Subt : Entity_Id;
- Return_Obj_Id : Entity_Id;
- Return_Obj_Decl : Entity_Id;
+ Loc : constant Source_Ptr := Sloc (Function_Call);
+ Func_Call : constant Node_Id := Unqual_Conv (Function_Call);
+ Function_Id : Entity_Id;
+ Result_Subt : Entity_Id;
begin
-- If the call has already been processed to add build-in-place actuals
@@ -8580,10 +8578,6 @@ package body Exp_Ch6 is
return;
end if;
- -- Mark the call as processed as a build-in-place call
-
- Set_Is_Expanded_Build_In_Place_Call (Func_Call);
-
if Is_Entity_Name (Name (Func_Call)) then
Function_Id := Entity (Name (Func_Call));
@@ -8601,8 +8595,13 @@ package body Exp_Ch6 is
-- If the build-in-place function returns a controlled object, then the
-- object needs to be finalized immediately after the context. Since
-- this case produces a transient scope, the servicing finalizer needs
- -- to name the returned object. Create a temporary which is initialized
- -- with the function call:
+ -- to name the returned object.
+
+ -- If the build-in-place function returns a definite subtype, then an
+ -- object also needs to be created and an access value designating it
+ -- passed as an actual.
+
+ -- Create a temporary which is initialized with the function call:
--
-- Temp_Id : Func_Type := BIP_Func_Call;
--
@@ -8610,75 +8609,25 @@ package body Exp_Ch6 is
-- the expander using the appropriate mechanism in Make_Build_In_Place_
-- Call_In_Object_Declaration.
- if Needs_Finalization (Result_Subt) then
+ if Needs_Finalization (Result_Subt)
+ or else Caller_Known_Size (Func_Call, Result_Subt)
+ then
declare
Temp_Id : constant Entity_Id := Make_Temporary (Loc, 'R');
- Temp_Decl : Node_Id;
-
- begin
- -- Reset the guard on the function call since the following does
- -- not perform actual call expansion.
-
- Set_Is_Expanded_Build_In_Place_Call (Func_Call, False);
-
- Temp_Decl :=
+ Temp_Decl : constant Node_Id :=
Make_Object_Declaration (Loc,
Defining_Identifier => Temp_Id,
- Object_Definition =>
- New_Occurrence_Of (Result_Subt, Loc),
- Expression =>
- New_Copy_Tree (Function_Call));
+ Aliased_Present => True,
+ Object_Definition => New_Occurrence_Of (Result_Subt, Loc),
+ Expression => Relocate_Node (Function_Call));
+ begin
+ Set_Assignment_OK (Temp_Decl);
Insert_Action (Function_Call, Temp_Decl);
-
Rewrite (Function_Call, New_Occurrence_Of (Temp_Id, Loc));
Analyze (Function_Call);
end;
- -- When the result subtype is definite, an object of the subtype is
- -- declared and an access value designating it is passed as an actual.
-
- elsif Caller_Known_Size (Func_Call, Result_Subt) then
-
- -- Create a temporary object to hold the function result
-
- Return_Obj_Id := Make_Temporary (Loc, 'R');
- Set_Etype (Return_Obj_Id, Result_Subt);
-
- Return_Obj_Decl :=
- Make_Object_Declaration (Loc,
- Defining_Identifier => Return_Obj_Id,
- Aliased_Present => True,
- Object_Definition => New_Occurrence_Of (Result_Subt, Loc));
-
- Set_No_Initialization (Return_Obj_Decl);
-
- Insert_Action (Func_Call, Return_Obj_Decl);
-
- -- When the function has a controlling result, an allocation-form
- -- parameter must be passed indicating that the caller is allocating
- -- the result object. This is needed because such a function can be
- -- called as a dispatching operation and must be treated similarly
- -- to functions with unconstrained result subtypes.
-
- Add_Unconstrained_Actuals_To_Build_In_Place_Call
- (Func_Call, Function_Id, Alloc_Form => Caller_Allocation);
-
- Add_Collection_Actual_To_Build_In_Place_Call
- (Func_Call, Function_Id);
-
- Add_Task_Actuals_To_Build_In_Place_Call
- (Func_Call, Function_Id, Make_Identifier (Loc, Name_uMaster));
-
- -- Add an implicit actual to the function call that provides access
- -- to the caller's return object.
-
- Add_Access_Actual_To_Build_In_Place_Call
- (Func_Call, Function_Id, New_Occurrence_Of (Return_Obj_Id, Loc));
-
- pragma Assert (Check_Number_Of_Actuals (Func_Call, Function_Id));
- pragma Assert (Check_BIP_Actuals (Func_Call, Function_Id));
-
-- When the result subtype is unconstrained, the function must allocate
-- the return object in the secondary stack, so appropriate implicit
-- parameters are added to the call to indicate that. A transient
@@ -8703,6 +8652,10 @@ package body Exp_Ch6 is
Add_Access_Actual_To_Build_In_Place_Call
(Func_Call, Function_Id, Empty);
+ -- Mark the call as processed as a build-in-place call
+
+ Set_Is_Expanded_Build_In_Place_Call (Func_Call);
+
pragma Assert (Check_Number_Of_Actuals (Func_Call, Function_Id));
pragma Assert (Check_BIP_Actuals (Func_Call, Function_Id));
end if;
@@ -8873,6 +8826,25 @@ package body Exp_Ch6 is
and then
not Has_Foreign_Convention (Return_Applies_To (Scope (Obj_Def_Id)));
+ Constraint_Check_Needed : constant Boolean :=
+ (Has_Discriminants (Obj_Typ) or else Is_Array_Type (Obj_Typ))
+ and then Is_Tagged_Type (Obj_Typ)
+ and then Nkind (Original_Node (Obj_Decl)) /=
+ N_Object_Renaming_Declaration
+ and then Is_Constrained (Obj_Typ);
+ -- We are processing a call in the context of something like
+ -- "X : T := F (...);". This is True if we need to do a constraint
+ -- check, because T has constrained bounds or discriminants,
+ -- and F is returning an unconstrained subtype.
+ -- We are currently doing the check at the call site,
+ -- which is possible only in the callee-allocates case,
+ -- which is why we have Is_Tagged_Type above.
+ -- ???The check is missing in the untagged caller-allocates case.
+ -- ???The check for renaming declarations above is needed because
+ -- Sem_Ch8.Analyze_Object_Renaming sometimes changes a renaming
+ -- into an object declaration. We probably shouldn't do that,
+ -- but for now, we need this check.
+
-- Start of processing for Make_Build_In_Place_Call_In_Object_Declaration
begin
@@ -8915,15 +8887,16 @@ package body Exp_Ch6 is
Subtype_Indication =>
New_Occurrence_Of (Designated_Type, Loc)));
- -- The access type and its accompanying object must be inserted after
- -- the object declaration in the constrained case, so that the function
- -- call can be passed access to the object. In the indefinite case, or
+ -- The access type and its object must be inserted after the object
+ -- declaration in the caller-allocates case, so that the function call
+ -- can be passed access to the object. In the caller-allocates case, or
-- if the object declaration is for a return object, the access type and
-- object must be inserted before the object, since the object
-- declaration is rewritten to be a renaming of a dereference of the
-- access object.
- if Definite and then not Is_OK_Return_Object then
+ if Definite and not Is_OK_Return_Object and not Constraint_Check_Needed
+ then
Insert_Action_After (Obj_Decl, Ptr_Typ_Decl);
else
Insert_Action (Obj_Decl, Ptr_Typ_Decl);
@@ -9004,7 +8977,7 @@ package body Exp_Ch6 is
-- to the (specific) result type of the function is inserted to handle
-- the case where the object is declared with a class-wide type.
- elsif Definite then
+ elsif Definite and not Constraint_Check_Needed then
Caller_Object := Unchecked_Convert_To
(Result_Subt, New_Occurrence_Of (Obj_Def_Id, Loc));
@@ -9142,8 +9115,8 @@ package body Exp_Ch6 is
-- itself the return expression of an enclosing BIP function, then mark
-- the object as having no initialization.
- if Definite and then not Is_OK_Return_Object then
-
+ if Definite and not Is_OK_Return_Object and not Constraint_Check_Needed
+ then
Set_Expression (Obj_Decl, Empty);
Set_No_Initialization (Obj_Decl);
@@ -9202,6 +9175,10 @@ package body Exp_Ch6 is
Analyze (Obj_Decl);
Replace_Renaming_Declaration_Id
(Obj_Decl, Original_Node (Obj_Decl));
+
+ if Constraint_Check_Needed then
+ Apply_Constraint_Check (Call_Deref, Obj_Typ);
+ end if;
end if;
pragma Assert (Check_Number_Of_Actuals (Func_Call, Function_Id));
@@ -9598,9 +9575,8 @@ package body Exp_Ch6 is
-- such build-in-place functions, primitive or not.
return not Restriction_Active (No_Finalization)
- and then ((Needs_Finalization (Typ)
- and then not Has_Relaxed_Finalization (Typ))
- or else Is_Tagged_Type (Typ))
+ and then (Needs_Finalization (Typ) or else Is_Tagged_Type (Typ))
+ and then not Has_Relaxed_Finalization (Typ)
and then not Has_Foreign_Convention (Typ);
end Needs_BIP_Collection;
@@ -9909,6 +9885,13 @@ package body Exp_Ch6 is
return Skip;
end if;
+ -- Skip calls placed in unexpanded initialization expressions
+
+ when N_Object_Declaration =>
+ if No_Initialization (Nod) then
+ return Skip;
+ end if;
+
-- Skip calls placed in subprogram specifications since function
-- calls initializing default parameter values will be processed
-- when the call to the subprogram is found (if the default actual
@@ -9964,15 +9947,15 @@ package body Exp_Ch6 is
-- Start of processing for Validate_Subprogram_Calls
begin
- -- No action required if we are not generating code or compiling sources
- -- that have errors.
+ -- No action if we are not generating code (including if we have
+ -- errors).
- if Serious_Errors_Detected > 0
- or else Operating_Mode /= Generate_Code
- then
+ if Operating_Mode /= Generate_Code then
return;
end if;
+ pragma Assert (Serious_Errors_Detected = 0);
+
Check_Calls (N);
end Validate_Subprogram_Calls;
diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb
index 67af1d7..4d2b834 100644
--- a/gcc/ada/exp_ch7.adb
+++ b/gcc/ada/exp_ch7.adb
@@ -696,6 +696,15 @@ package body Exp_Ch7 is
-- Set the Finalize_Address primitive for the object that has been
-- attached to a finalization Master_Node.
+ function Shift_Address_For_Descriptor
+ (Addr : Node_Id;
+ Typ : Entity_Id;
+ Op_Nam : Name_Id) return Node_Id
+ with Pre => Is_Array_Type (Typ)
+ and then not Is_Constrained (Typ)
+ and then Op_Nam in Name_Op_Add | Name_Op_Subtract;
+ -- Add to Addr, or subtract from Addr, the size of the descriptor of Typ
+
----------------------------------
-- Attach_Object_To_Master_Node --
----------------------------------
@@ -2466,7 +2475,6 @@ package body Exp_Ch7 is
-- Local variables
Decl : Node_Id;
- Expr : Node_Id;
Obj_Id : Entity_Id;
Obj_Typ : Entity_Id;
Pack_Id : Entity_Id;
@@ -2516,7 +2524,6 @@ package body Exp_Ch7 is
elsif Nkind (Decl) = N_Object_Declaration then
Obj_Id := Defining_Identifier (Decl);
Obj_Typ := Base_Type (Etype (Obj_Id));
- Expr := Expression (Decl);
-- Bypass any form of processing for objects which have their
-- finalization disabled. This applies only to objects at the
@@ -2572,21 +2579,10 @@ package body Exp_Ch7 is
Processing_Actions
(Decl, Strict => not Has_Relaxed_Finalization (Obj_Typ));
- -- The object is of the form:
- -- Obj : Access_Typ := Non_BIP_Function_Call'reference;
-
- -- Obj : Access_Typ :=
- -- BIP_Function_Call (BIPalloc => 2, ...)'reference;
+ -- The object is an access-to-controlled that must be finalized
elsif Is_Access_Type (Obj_Typ)
- and then Needs_Finalization
- (Available_View (Designated_Type (Obj_Typ)))
- and then Present (Expr)
- and then
- (Is_Secondary_Stack_BIP_Func_Call (Expr)
- or else
- (Is_Non_BIP_Func_Call (Expr)
- and then not Is_Related_To_Func_Return (Obj_Id)))
+ and then Is_Finalizable_Access (Decl)
then
Processing_Actions
(Decl,
@@ -2783,16 +2779,31 @@ package body Exp_Ch7 is
Master_Node_Id :=
Make_Defining_Identifier (Master_Node_Loc,
Chars => New_External_Name (Chars (Obj_Id), Suffix => "MN"));
+
Master_Node_Decl :=
Make_Master_Node_Declaration (Master_Node_Loc,
Master_Node_Id, Obj_Id);
Push_Scope (Scope (Obj_Id));
+
+ -- Avoid generating duplicate names for master nodes
+
+ if Ekind (Obj_Id) = E_Loop_Parameter
+ and then
+ Present (Current_Entity_In_Scope (Chars (Master_Node_Id)))
+ then
+ Set_Chars (Master_Node_Id,
+ New_External_Name (Chars (Obj_Id),
+ Suffix => "MN",
+ Suffix_Index => -1));
+ end if;
+
if not Has_Strict_Ctrl_Objs or else Count = 1 then
Prepend_To (Decls, Master_Node_Decl);
else
Insert_Before (Decl, Master_Node_Decl);
end if;
+
Analyze (Master_Node_Decl);
Pop_Scope;
@@ -5260,6 +5271,13 @@ package body Exp_Ch7 is
Obj_Typ : Entity_Id;
begin
+ -- Ignored Ghost objects do not need any cleanup actions because
+ -- they will not appear in the final tree.
+
+ if Is_Ignored_Ghost_Entity (Obj_Id) then
+ return;
+ end if;
+
-- If the object needs to be exported to the outer finalizer,
-- create the declaration of the Master_Node for the object,
-- which will later be picked up by Build_Finalizer.
@@ -5537,35 +5555,14 @@ package body Exp_Ch7 is
-- an object with a dope vector (see Make_Finalize_Address_Stmts).
-- This is achieved by setting Is_Constr_Array_Subt_With_Bounds,
-- but the address of the object is still that of its elements,
- -- so we need to shift it.
+ -- so we need to shift it back to skip the dope vector.
if Is_Array_Type (Utyp)
and then not Is_Constrained (First_Subtype (Utyp))
then
- -- Shift the address from the start of the elements to the
- -- start of the dope vector:
-
- -- V - (Utyp'Descriptor_Size / Storage_Unit)
-
Obj_Addr :=
- Make_Function_Call (Loc,
- Name =>
- Make_Expanded_Name (Loc,
- Chars => Name_Op_Subtract,
- Prefix =>
- New_Occurrence_Of
- (RTU_Entity (System_Storage_Elements), Loc),
- Selector_Name =>
- Make_Identifier (Loc, Name_Op_Subtract)),
- Parameter_Associations => New_List (
- Obj_Addr,
- Make_Op_Divide (Loc,
- Left_Opnd =>
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Utyp, Loc),
- Attribute_Name => Name_Descriptor_Size),
- Right_Opnd =>
- Make_Integer_Literal (Loc, System_Storage_Unit))));
+ Shift_Address_For_Descriptor
+ (Obj_Addr, First_Subtype (Utyp), Name_Op_Subtract);
end if;
return Obj_Addr;
@@ -8174,6 +8171,10 @@ package body Exp_Ch7 is
Ptr_Typ : Entity_Id;
begin
+ -- Array types: picking the (unconstrained) base type as designated type
+ -- requires allocating the bounds alongside the data, so we only do this
+ -- when the first subtype itself was declared as unconstrained.
+
if Is_Array_Type (Typ) then
if Is_Constrained (First_Subtype (Typ)) then
Desig_Typ := First_Subtype (Typ);
@@ -8269,63 +8270,18 @@ package body Exp_Ch7 is
-- lays in front of the elements and then use a thin pointer to perform
-- the address-to-access conversion.
- if Is_Array_Type (Typ)
- and then not Is_Constrained (First_Subtype (Typ))
- then
- declare
- Dope_Id : Entity_Id;
-
- begin
- -- Ensure that Ptr_Typ is a thin pointer; generate:
- -- for Ptr_Typ'Size use System.Address'Size;
-
- Append_To (Decls,
- Make_Attribute_Definition_Clause (Loc,
- Name => New_Occurrence_Of (Ptr_Typ, Loc),
- Chars => Name_Size,
- Expression =>
- Make_Integer_Literal (Loc, System_Address_Size)));
-
- -- Generate:
- -- Dnn : constant Storage_Offset :=
- -- Desig_Typ'Descriptor_Size / Storage_Unit;
+ if Is_Array_Type (Typ) and then not Is_Constrained (Desig_Typ) then
+ Obj_Expr :=
+ Shift_Address_For_Descriptor (Obj_Expr, Desig_Typ, Name_Op_Add);
- Dope_Id := Make_Temporary (Loc, 'D');
+ -- Ensure that Ptr_Typ is a thin pointer; generate:
+ -- for Ptr_Typ'Size use System.Address'Size;
- Append_To (Decls,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Dope_Id,
- Constant_Present => True,
- Object_Definition =>
- New_Occurrence_Of (RTE (RE_Storage_Offset), Loc),
- Expression =>
- Make_Op_Divide (Loc,
- Left_Opnd =>
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Desig_Typ, Loc),
- Attribute_Name => Name_Descriptor_Size),
- Right_Opnd =>
- Make_Integer_Literal (Loc, System_Storage_Unit))));
-
- -- Shift the address from the start of the dope vector to the
- -- start of the elements:
- --
- -- V + Dnn
-
- Obj_Expr :=
- Make_Function_Call (Loc,
- Name =>
- Make_Expanded_Name (Loc,
- Chars => Name_Op_Add,
- Prefix =>
- New_Occurrence_Of
- (RTU_Entity (System_Storage_Elements), Loc),
- Selector_Name =>
- Make_Identifier (Loc, Name_Op_Add)),
- Parameter_Associations => New_List (
- Obj_Expr,
- New_Occurrence_Of (Dope_Id, Loc)));
- end;
+ Append_To (Decls,
+ Make_Attribute_Definition_Clause (Loc,
+ Name => New_Occurrence_Of (Ptr_Typ, Loc),
+ Chars => Name_Size,
+ Expression => Make_Integer_Literal (Loc, System_Address_Size)));
end if;
Fin_Call :=
@@ -8903,6 +8859,43 @@ package body Exp_Ch7 is
return Scope_Stack.Table (Scope_Stack.Last).Node_To_Be_Wrapped;
end Node_To_Be_Wrapped;
+ ----------------------------------
+ -- Shift_Address_For_Descriptor --
+ ----------------------------------
+
+ function Shift_Address_For_Descriptor
+ (Addr : Node_Id;
+ Typ : Entity_Id;
+ Op_Nam : Name_Id) return Node_Id
+ is
+ Loc : constant Source_Ptr := Sloc (Addr);
+ Dummy : constant Entity_Id := RTE (RE_Storage_Offset);
+ -- Make sure System_Storage_Elements is loaded for RTU_Entity
+
+ begin
+ -- Generate:
+ -- Addr +/- (Typ'Descriptor_Size / Storage_Unit)
+
+ return
+ Make_Function_Call (Loc,
+ Name =>
+ Make_Expanded_Name (Loc,
+ Chars => Op_Nam,
+ Prefix =>
+ New_Occurrence_Of
+ (RTU_Entity (System_Storage_Elements), Loc),
+ Selector_Name => Make_Identifier (Loc, Op_Nam)),
+ Parameter_Associations => New_List (
+ Addr,
+ Make_Op_Divide (Loc,
+ Left_Opnd =>
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Typ, Loc),
+ Attribute_Name => Name_Descriptor_Size),
+ Right_Opnd =>
+ Make_Integer_Literal (Loc, System_Storage_Unit))));
+ end Shift_Address_For_Descriptor;
+
----------------------------
-- Store_Actions_In_Scope --
----------------------------
diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb
index d75fd3a..9cfc6b5 100644
--- a/gcc/ada/exp_ch9.adb
+++ b/gcc/ada/exp_ch9.adb
@@ -4273,6 +4273,7 @@ package body Exp_Ch9 is
Defining_Identifier => Obj,
Object_Definition => New_Occurrence_Of (Conctyp, Loc),
Expression => ExpR);
+ Mutate_Ekind (Obj, E_Variable);
Set_Etype (Obj, Conctyp);
Decls := New_List (Decl);
Rewrite (Concval, New_Occurrence_Of (Obj, Loc));
@@ -5747,7 +5748,7 @@ package body Exp_Ch9 is
Insert_Before_And_Analyze (N, Decl1);
-- Associate the access to subprogram with its original access to
- -- protected subprogram type. Needed by the backend to know that this
+ -- protected subprogram type. Needed by CodePeer to know that this
-- type corresponds with an access to protected subprogram type.
Set_Original_Access_Type (D_T2, T);
@@ -9877,7 +9878,7 @@ package body Exp_Ch9 is
-- (T => To_Tag_Ptr (Obj'Address).all,
-- Position =>
-- Ada.Tags.Get_Offset_Index
- -- (Ada.Tags.Tag (Concval),
+ -- (Concval._Tag,
-- <interface dispatch table position of Ename>));
-- Note that Obj'Address is recursively expanded into a call to
@@ -9898,7 +9899,9 @@ package body Exp_Ch9 is
Make_Function_Call (Loc,
Name => New_Occurrence_Of (RTE (RE_Get_Offset_Index), Loc),
Parameter_Associations => New_List (
- Unchecked_Convert_To (RTE (RE_Tag), Concval),
+ Make_Attribute_Reference (Loc,
+ Prefix => Concval,
+ Attribute_Name => Name_Tag),
Make_Integer_Literal (Loc,
DT_Position (Entity (Ename))))))));
@@ -10593,14 +10596,6 @@ package body Exp_Ch9 is
Build_Accept_Body (Accept_Statement (Alt)));
Reset_Scopes_To (Proc_Body, PB_Ent);
-
- -- During the analysis of the body of the accept statement, any
- -- zero cost exception handler records were collected in the
- -- Accept_Handler_Records field of the N_Accept_Alternative node.
- -- This is where we move them to where they belong, namely the
- -- newly created procedure.
-
- Set_Handler_Records (PB_Ent, Accept_Handler_Records (Alt));
Append (Proc_Body, Body_List);
else
diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb
index 458b32c..080a2e1 100644
--- a/gcc/ada/exp_disp.adb
+++ b/gcc/ada/exp_disp.adb
@@ -413,7 +413,9 @@ package body Exp_Disp is
if Nkind (D) = N_Package_Declaration then
Build_Package_Dispatch_Tables (D);
- elsif Nkind (D) = N_Package_Body then
+ elsif Nkind (D) = N_Package_Body
+ and then Ekind (Corresponding_Spec (D)) /= E_Generic_Package
+ then
Build_Dispatch_Tables (Declarations (D));
elsif Nkind (D) = N_Package_Body_Stub
diff --git a/gcc/ada/exp_dist.adb b/gcc/ada/exp_dist.adb
index 694fbe4..a351b9b 100644
--- a/gcc/ada/exp_dist.adb
+++ b/gcc/ada/exp_dist.adb
@@ -10980,6 +10980,7 @@ package body Exp_Dist is
if not Constrained or else Depth > 1 then
Inner_Any := Make_Defining_Identifier (Loc,
New_External_Name ('A', Depth));
+ Mutate_Ekind (Inner_Any, E_Variable);
Set_Etype (Inner_Any, RTE (RE_Any));
else
Inner_Any := Empty;
@@ -10988,6 +10989,7 @@ package body Exp_Dist is
if Present (Counter) then
Inner_Counter := Make_Defining_Identifier (Loc,
New_External_Name ('J', Depth));
+ Mutate_Ekind (Inner_Counter, E_Variable);
else
Inner_Counter := Empty;
end if;
diff --git a/gcc/ada/exp_fixd.adb b/gcc/ada/exp_fixd.adb
index 03c7ca8..8759099 100644
--- a/gcc/ada/exp_fixd.adb
+++ b/gcc/ada/exp_fixd.adb
@@ -570,12 +570,16 @@ package body Exp_Fixd is
-- Case where we can compute the denominator in Max_Integer_Size bits
if QR_Id = RE_Null then
+ Mutate_Ekind (Qnn, E_Constant);
+ Mutate_Ekind (Rnn, E_Constant);
-- Create temporaries for numerator and denominator and set Etypes,
-- so that New_Occurrence_Of picks them up for Build_xxx calls.
Nnn := Make_Temporary (Loc, 'N');
+ Mutate_Ekind (Nnn, E_Constant);
Dnn := Make_Temporary (Loc, 'D');
+ Mutate_Ekind (Dnn, E_Constant);
Set_Etype (Nnn, QR_Typ);
Set_Etype (Dnn, QR_Typ);
@@ -621,6 +625,8 @@ package body Exp_Fixd is
-- to call the runtime routine to compute the quotient and remainder.
else
+ Mutate_Ekind (Qnn, E_Variable);
+ Mutate_Ekind (Rnn, E_Variable);
Rnd := Boolean_Literals (Rounded_Result_Set (N));
Code := New_List (
@@ -935,8 +941,13 @@ package body Exp_Fixd is
-- Case where we can compute the numerator in Max_Integer_Size bits
if QR_Id = RE_Null then
+ Mutate_Ekind (Qnn, E_Constant);
+ Mutate_Ekind (Rnn, E_Constant);
+
Nnn := Make_Temporary (Loc, 'N');
+ Mutate_Ekind (Nnn, E_Constant);
Dnn := Make_Temporary (Loc, 'D');
+ Mutate_Ekind (Dnn, E_Constant);
-- Set Etypes, so that they can be picked up by New_Occurrence_Of
@@ -982,6 +993,9 @@ package body Exp_Fixd is
-- to call the runtime routine to compute the quotient and remainder.
else
+ Mutate_Ekind (Qnn, E_Variable);
+ Mutate_Ekind (Rnn, E_Variable);
+
Rnd := Boolean_Literals (Rounded_Result_Set (N));
Code := New_List (
diff --git a/gcc/ada/exp_pakd.adb b/gcc/ada/exp_pakd.adb
index 4eb93c3..f04016f 100644
--- a/gcc/ada/exp_pakd.adb
+++ b/gcc/ada/exp_pakd.adb
@@ -904,7 +904,8 @@ package body Exp_Pakd is
-- discriminants, so we treat it as a default/per-object expression.
Set_Parent (Len_Expr, Typ);
- Preanalyze_Spec_Expression (Len_Expr, Standard_Long_Long_Integer);
+ Preanalyze_And_Resolve_Spec_Expression
+ (Len_Expr, Standard_Long_Long_Integer);
-- Use a modular type if possible. We can do this if we have
-- static bounds, and the length is small enough, and the length
@@ -1525,21 +1526,24 @@ package body Exp_Pakd is
Get_Base_And_Bit_Offset (Prefix (N), Base, Offset);
+ Offset := Unchecked_Convert_To (RTE (RE_Storage_Offset), Offset);
+
Rewrite (N,
- Unchecked_Convert_To (RTE (RE_Address),
- Make_Op_Add (Loc,
- Left_Opnd =>
- Unchecked_Convert_To (RTE (RE_Integer_Address),
- Make_Attribute_Reference (Loc,
- Prefix => Base,
- Attribute_Name => Name_Address)),
-
- Right_Opnd =>
- Unchecked_Convert_To (RTE (RE_Integer_Address),
- Make_Op_Divide (Loc,
- Left_Opnd => Offset,
- Right_Opnd =>
- Make_Integer_Literal (Loc, System_Storage_Unit))))));
+ Make_Function_Call (Loc,
+ Name =>
+ Make_Expanded_Name (Loc,
+ Chars => Name_Op_Add,
+ Prefix =>
+ New_Occurrence_Of (RTU_Entity (System_Storage_Elements), Loc),
+ Selector_Name => Make_Identifier (Loc, Name_Op_Add)),
+ Parameter_Associations => New_List (
+ Make_Attribute_Reference (Loc,
+ Prefix => Base,
+ Attribute_Name => Name_Address),
+ Make_Op_Divide (Loc,
+ Left_Opnd => Offset,
+ Right_Opnd =>
+ Make_Integer_Literal (Loc, System_Storage_Unit)))));
Analyze_And_Resolve (N, RTE (RE_Address));
end Expand_Packed_Address_Reference;
diff --git a/gcc/ada/exp_prag.adb b/gcc/ada/exp_prag.adb
index cc59620..340f2dc 100644
--- a/gcc/ada/exp_prag.adb
+++ b/gcc/ada/exp_prag.adb
@@ -3083,6 +3083,16 @@ package body Exp_Prag is
end Expand_Pragma_Loop_Variant;
--------------------------------
+ -- Expand_Pragma_Program_Exit --
+ --------------------------------
+
+ procedure Expand_Pragma_Program_Exit (Prag : Node_Id) is
+ pragma Unreferenced (Prag);
+ begin
+ null;
+ end Expand_Pragma_Program_Exit;
+
+ --------------------------------
-- Expand_Pragma_Psect_Object --
--------------------------------
diff --git a/gcc/ada/exp_prag.ads b/gcc/ada/exp_prag.ads
index 036d7b1..cd78dd206 100644
--- a/gcc/ada/exp_prag.ads
+++ b/gcc/ada/exp_prag.ads
@@ -72,4 +72,8 @@ package Exp_Prag is
-- of Prag is replaced with a reference to procedure with checks for the
-- variant expressions.
+ procedure Expand_Pragma_Program_Exit (Prag : Node_Id);
+ -- This routine only exists for consistency with other pragmas, since
+ -- Program_Exit has no meaningful expansion.
+
end Exp_Prag;
diff --git a/gcc/ada/exp_put_image.adb b/gcc/ada/exp_put_image.adb
index ae5fa40..40b2a65 100644
--- a/gcc/ada/exp_put_image.adb
+++ b/gcc/ada/exp_put_image.adb
@@ -695,17 +695,15 @@ package body Exp_Put_Image is
Put_Image_Base_Type
(Get_Corresponding_Mutably_Tagged_Type_If_Present (Etype (C)));
begin
- if Ekind (C) /= E_Void then
- Append_To (Clist,
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Component_Typ, Loc),
- Attribute_Name => Name_Put_Image,
- Expressions => New_List (
- Make_Identifier (Loc, Name_S),
- Make_Selected_Component (Loc,
- Prefix => Make_Identifier (Loc, Name_V),
- Selector_Name => New_Occurrence_Of (C, Loc)))));
- end if;
+ Append_To (Clist,
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Component_Typ, Loc),
+ Attribute_Name => Name_Put_Image,
+ Expressions => New_List (
+ Make_Identifier (Loc, Name_S),
+ Make_Selected_Component (Loc,
+ Prefix => Make_Identifier (Loc, Name_V),
+ Selector_Name => New_Occurrence_Of (C, Loc)))));
end Append_Component_Attr;
-------------------------------
@@ -944,9 +942,38 @@ package body Exp_Put_Image is
-- Generate Put_Images for the discriminants of the type
- Append_List_To (Stms,
- Make_Component_Attributes
- (Discriminant_Specifications (Type_Decl)));
+ declare
+ Discrim_Specs : List_Id := Discriminant_Specifications (Type_Decl);
+ Partial_View : Entity_Id;
+ begin
+ if Present (First (Discrim_Specs))
+ and then Ekind (Defining_Identifier (First (Discrim_Specs))) =
+ E_Void
+ then
+ -- If the known discriminant part is repeated for the
+ -- completion of a private type declaration, then the
+ -- second copy is (by design) not analyzed. So we'd better
+ -- use the first copy instead.
+
+ Partial_View := Incomplete_Or_Partial_View
+ (Defining_Identifier (Type_Decl));
+
+ pragma Assert (Ekind (Partial_View) in
+ E_Private_Type
+ | E_Limited_Private_Type
+ | E_Record_Type_With_Private);
+
+ Discrim_Specs :=
+ Discriminant_Specifications (Parent (Partial_View));
+
+ pragma Assert (Present (First (Discrim_Specs)));
+ pragma Assert
+ (Ekind (Defining_Identifier (First (Discrim_Specs))) /=
+ E_Void);
+ end if;
+
+ Append_List_To (Stms, Make_Component_Attributes (Discrim_Specs));
+ end;
Rdef := Type_Definition (Type_Decl);
diff --git a/gcc/ada/exp_spark.adb b/gcc/ada/exp_spark.adb
index b75b31b..6e1c86a 100644
--- a/gcc/ada/exp_spark.adb
+++ b/gcc/ada/exp_spark.adb
@@ -172,6 +172,14 @@ package body Exp_SPARK is
when N_Op_Ne =>
Expand_SPARK_N_Op_Ne (N);
+ -- Resolution of type conversion relies on minimal expansion of
+ -- fixedpoint operations to insert the range check on their result.
+
+ when N_Op_Multiply | N_Op_Divide =>
+ if Etype (N) = Universal_Fixed then
+ Exp_Ch4.Fixup_Universal_Fixed_Operation (N);
+ end if;
+
when N_Freeze_Entity =>
-- Currently we only expand type freeze entities, so ignore other
-- freeze entites, because it is expensive to create a suitable
diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb
index b8c6a9f..9077891 100644
--- a/gcc/ada/exp_util.adb
+++ b/gcc/ada/exp_util.adb
@@ -167,6 +167,9 @@ package body Exp_Util is
-- Force evaluation of bounds of a slice, which may be given by a range
-- or by a subtype indication with or without a constraint.
+ function Is_Expression_Of_Func_Return (N : Node_Id) return Boolean;
+ -- Return True if N is the expression of a function return
+
function Is_Uninitialized_Aggregate
(Exp : Node_Id;
T : Entity_Id) return Boolean;
@@ -1081,10 +1084,12 @@ package body Exp_Util is
Make_Attribute_Reference (Loc,
Prefix =>
(if Is_Allocate then
- Duplicate_Subexpr_No_Checks (Expression (Alloc_Expr))
+ Duplicate_Subexpr_No_Checks
+ (Expression (Alloc_Expr), New_Scope => Proc_Id)
else
Make_Explicit_Dereference (Loc,
- Duplicate_Subexpr_No_Checks (Expr))),
+ Duplicate_Subexpr_No_Checks
+ (Expr, New_Scope => Proc_Id))),
Attribute_Name => Name_Alignment)));
end if;
@@ -1137,7 +1142,9 @@ package body Exp_Util is
if Is_RTE (Etype (Temp), RE_Tag_Ptr) then
Param :=
Make_Explicit_Dereference (Loc,
- Prefix => Duplicate_Subexpr_No_Checks (Temp));
+ Prefix =>
+ Duplicate_Subexpr_No_Checks
+ (Temp, New_Scope => Proc_Id));
-- In the default case, obtain the tag of the object about
-- to be allocated / deallocated. Generate:
@@ -1157,7 +1164,9 @@ package body Exp_Util is
Param :=
Make_Attribute_Reference (Loc,
- Prefix => Duplicate_Subexpr_No_Checks (Temp),
+ Prefix =>
+ Duplicate_Subexpr_No_Checks
+ (Temp, New_Scope => Proc_Id),
Attribute_Name => Name_Tag);
end if;
@@ -1517,7 +1526,228 @@ package body Exp_Util is
New_E := Type_Map.Get (Entity (N));
if Present (New_E) then
- Rewrite (N, New_Occurrence_Of (New_E, Sloc (N)));
+ declare
+
+ Ctrl_Type : constant Entity_Id
+ := Find_Dispatching_Type (Par_Subp);
+
+ function Must_Map_Call_To_Parent_Primitive
+ (Call_Node : Node_Id;
+ Check_Parents : Boolean := True) return Boolean;
+ -- If Call_Node is a call to a primitive function F of the
+ -- tagged type T associated with Par_Subp that either has
+ -- any actuals that involve controlling formals of Par_Subp,
+ -- or else the call to F is an actual parameter of an
+ -- enclosing call to a primitive of T that has any actuals
+ -- that involve controlling formals of Par_Subp (and
+ -- recursively up the tree of enclosing function calls),
+ -- returns True; otherwise returns False. Returning True
+ -- implies that the call to F must be mapped to a call
+ -- that instead targets the corresponding function F of
+ -- the tagged type for which Subp is a primitive function.
+ -- Checks_Parent specifies whether this function should
+ -- recursively check enclosing calls.
+
+ ---------------------------------------
+ -- Must_Map_Call_To_Parent_Primitive --
+ ---------------------------------------
+
+ function Must_Map_Call_To_Parent_Primitive
+ (Call_Node : Node_Id;
+ Check_Parents : Boolean := True) return Boolean
+ is
+ pragma Assert (Nkind (Call_Node) = N_Function_Call);
+
+ Actual : Node_Id := First_Actual (Call_Node);
+
+ function Expr_Has_Ctrl_Formal_Ref
+ (Expr : Node_Id) return Boolean;
+ -- Determines whether Expr is or contains a reference
+ -- to a controlling formal and returns True if so. More
+ -- specifically, if Expr is not directly a reference
+ -- to a formal, it can be an access attribute or Old
+ -- attribute whose immediate object prefix is such
+ -- a reference (possibly through a chain of multiple
+ -- such attributes); or else it can be a dereference
+ -- of a controlling formal; or else it can be either
+ -- a dependent expression of a conditional expression,
+ -- or the expression of a declare expression that
+ -- qualifies as such. Returns True if the expression
+ -- satisifies one of those requirements; otherwise
+ -- returns False.
+
+ ------------------------------
+ -- Expr_Has_Ctrl_Formal_Ref --
+ ------------------------------
+
+ function Expr_Has_Ctrl_Formal_Ref
+ (Expr : Node_Id) return Boolean
+ is
+
+ function Is_Controlling_Formal_Ref
+ (N : Node_Id) return Boolean;
+ -- Returns True if and only if N denotes a reference
+ -- to a controlling formal declared for Par_Subp, or
+ -- Subp as formals may have been rewritten before the
+ -- test happens.
+
+ -------------------------------
+ -- Is_Controlling_Formal_Ref --
+ -------------------------------
+
+ function Is_Controlling_Formal_Ref
+ (N : Node_Id) return Boolean
+ is
+ begin
+ return Nkind (N) in N_Identifier | N_Expanded_Name
+ and then Is_Formal (Entity (N))
+ and then Is_Controlling_Formal (Entity (N))
+ and then Scope (Entity (N)) in Par_Subp | Subp;
+ end Is_Controlling_Formal_Ref;
+
+ -- Start of processing for Expr_Has_Ctrl_Formal_Ref
+
+ begin
+ if (Nkind (Expr) = N_Attribute_Reference
+ and then Attribute_Name (Expr)
+ in Name_Old
+ | Name_Access
+ | Name_Unchecked_Access
+ | Name_Unrestricted_Access)
+ or else Nkind (Expr) = N_Explicit_Dereference
+ then
+ return Expr_Has_Ctrl_Formal_Ref (Prefix (Expr));
+
+ elsif Nkind (Expr) = N_If_Expression then
+ declare
+ Then_Expr : constant Node_Id :=
+ Pick (Expressions (Expr), 2);
+ Else_Expr : constant Node_Id :=
+ Pick (Expressions (Expr), 3);
+ begin
+ return Expr_Has_Ctrl_Formal_Ref (Then_Expr)
+ or else Expr_Has_Ctrl_Formal_Ref (Else_Expr);
+ end;
+
+ elsif Nkind (Expr) = N_Case_Expression then
+ declare
+ Case_Expr_Alt : Node_Id :=
+ First (Alternatives (Expr));
+ begin
+ while Present (Case_Expr_Alt) loop
+ if Expr_Has_Ctrl_Formal_Ref
+ (Expression (Case_Expr_Alt))
+ then
+ return True;
+ end if;
+
+ Next (Case_Expr_Alt);
+ end loop;
+ end;
+
+ return False;
+
+ -- Case of a declare_expression
+
+ elsif Nkind (Expr) = N_Expression_With_Actions
+ and then Comes_From_Source (Expr)
+ then
+ return Expr_Has_Ctrl_Formal_Ref (Expression (Expr));
+
+ -- All other cases must be references to a formal
+
+ else
+ return Is_Controlling_Formal_Ref (Expr);
+ end if;
+ end Expr_Has_Ctrl_Formal_Ref;
+
+ -- Start of processing for Must_Map_Call_To_Parent_Primitive
+
+ begin
+ if Is_Entity_Name (Name (Call_Node))
+ and then Is_Dispatching_Operation
+ (Entity (Name (Call_Node)))
+ and then
+ Is_Ancestor
+ (Ctrl_Type,
+ Find_Dispatching_Type
+ (Entity (Name (Call_Node))))
+ then
+ while Present (Actual) loop
+
+ -- If at least one actual references a controlling
+ -- formal parameter of a class-wide Pre/Post
+ -- aspect's associated subprogram (including
+ -- a direct prefix of an access attribute or
+ -- dereference), the rule in RM 6.1.1(7) applies,
+ -- and we want to map the call to target the
+ -- corresponding function of the derived type.
+
+ if Expr_Has_Ctrl_Formal_Ref (Actual) then
+ return True;
+
+ -- RM 6.1.1(7) also applies to Result attributes
+ -- of primitive functions with controlling results.
+
+ elsif Is_Attribute_Result (Actual)
+ and then Has_Controlling_Result (Subp)
+ then
+ return True;
+
+ -- Recursively check any actuals that are function
+ -- calls with controlling results.
+
+ elsif Nkind (Actual) = N_Function_Call
+ and then
+ Has_Controlling_Result
+ (Entity (Name (Actual)))
+ and then
+ Must_Map_Call_To_Parent_Primitive
+ (Actual, Check_Parents => False)
+ then
+ return True;
+ end if;
+
+ Next_Actual (Actual);
+ end loop;
+
+ -- Recursively check parents that are function calls,
+ -- to handle cases like "F1 (F2, F3 (X))", where
+ -- Call_Node is the call to F2, and we need to map
+ -- F1, F2, and F3 due to the reference to formal X.
+
+ if Check_Parents
+ and then Nkind (Parent (Call_Node)) = N_Function_Call
+ then
+ return Must_Map_Call_To_Parent_Primitive
+ (Parent (Call_Node));
+ end if;
+
+ return False;
+
+ else
+ return False;
+ end if;
+ end Must_Map_Call_To_Parent_Primitive;
+
+ begin
+ -- If N's entity is in the map, then the entity is either
+ -- a formal of the parent subprogram that should necessarily
+ -- be mapped, or it's a function call's target entity that
+ -- that should be mapped if the call involves any actuals
+ -- that reference formals of the parent subprogram (or the
+ -- function call is part of an enclosing call that similarly
+ -- qualifies for mapping). Rewrite a node that references
+ -- any such qualified entity to a new node referencing the
+ -- corresponding entity associated with the derived type.
+
+ if not Is_Subprogram (Entity (N))
+ or else Nkind (Parent (N)) /= N_Function_Call
+ or else Must_Map_Call_To_Parent_Primitive (Parent (N))
+ then
+ Rewrite (N, New_Occurrence_Of (New_E, Sloc (N)));
+ end if;
+ end;
end if;
-- Update type of function call node, which should be the same as
@@ -1956,7 +2186,7 @@ package body Exp_Util is
-- time capture the visibility of the proper package part.
Set_Parent (Expr, Typ_Decl);
- Preanalyze_Assert_Expression (Expr, Any_Boolean);
+ Preanalyze_And_Resolve_Assert_Expression (Expr, Any_Boolean);
-- Save a copy of the expression with all replacements and analysis
-- already taken place in case a derived type inherits the pragma.
@@ -1969,8 +2199,8 @@ package body Exp_Util is
-- If the pragma comes from an aspect specification, replace the
-- saved expression because all type references must be substituted
- -- for the call to Preanalyze_Spec_Expression in Check_Aspect_At_xxx
- -- routines.
+ -- for the call to Preanalyze_And_Resolve_Spec_Expression in
+ -- Check_Aspect_At_xxx routines.
if Present (DIC_Asp) then
Set_Expression_Copy (DIC_Asp, New_Copy_Tree (Expr));
@@ -3217,7 +3447,7 @@ package body Exp_Util is
-- part.
Set_Parent (Expr, Parent (Prag_Expr));
- Preanalyze_Assert_Expression (Expr, Any_Boolean);
+ Preanalyze_And_Resolve_Assert_Expression (Expr, Any_Boolean);
-- Save a copy of the expression when T is tagged to detect
-- errors and capture the visibility of the proper package part
@@ -3229,8 +3459,8 @@ package body Exp_Util is
-- If the pragma comes from an aspect specification, replace
-- the saved expression because all type references must be
- -- substituted for the call to Preanalyze_Spec_Expression in
- -- Check_Aspect_At_xxx routines.
+ -- substituted for the call to Preanalyze_And_Resolve_Spec_
+ -- Expression in Check_Aspect_At_xxx routines.
if Present (Prag_Asp) then
Set_Expression_Copy (Prag_Asp, New_Copy_Tree (Expr));
@@ -5062,12 +5292,13 @@ package body Exp_Util is
function Duplicate_Subexpr
(Exp : Node_Id;
- Name_Req : Boolean := False;
- Renaming_Req : Boolean := False) return Node_Id
+ New_Scope : Entity_Id := Empty;
+ Name_Req : Boolean := False;
+ Renaming_Req : Boolean := False) return Node_Id
is
begin
Remove_Side_Effects (Exp, Name_Req, Renaming_Req);
- return New_Copy_Tree (Exp);
+ return New_Copy_Tree (Exp, New_Scope => New_Scope);
end Duplicate_Subexpr;
---------------------------------
@@ -5076,8 +5307,9 @@ package body Exp_Util is
function Duplicate_Subexpr_No_Checks
(Exp : Node_Id;
- Name_Req : Boolean := False;
- Renaming_Req : Boolean := False) return Node_Id
+ New_Scope : Entity_Id := Empty;
+ Name_Req : Boolean := False;
+ Renaming_Req : Boolean := False) return Node_Id
is
New_Exp : Node_Id;
@@ -5087,7 +5319,7 @@ package body Exp_Util is
Name_Req => Name_Req,
Renaming_Req => Renaming_Req);
- New_Exp := New_Copy_Tree (Exp);
+ New_Exp := New_Copy_Tree (Exp, New_Scope => New_Scope);
Remove_Checks (New_Exp);
return New_Exp;
end Duplicate_Subexpr_No_Checks;
@@ -5098,14 +5330,15 @@ package body Exp_Util is
function Duplicate_Subexpr_Move_Checks
(Exp : Node_Id;
- Name_Req : Boolean := False;
- Renaming_Req : Boolean := False) return Node_Id
+ New_Scope : Entity_Id := Empty;
+ Name_Req : Boolean := False;
+ Renaming_Req : Boolean := False) return Node_Id
is
New_Exp : Node_Id;
begin
Remove_Side_Effects (Exp, Name_Req, Renaming_Req);
- New_Exp := New_Copy_Tree (Exp);
+ New_Exp := New_Copy_Tree (Exp, New_Scope => New_Scope);
Remove_Checks (Exp);
return New_Exp;
end Duplicate_Subexpr_Move_Checks;
@@ -5949,9 +6182,10 @@ package body Exp_Util is
-- now known to be protected, the finalization routine is the one
-- defined on the corresponding record of the ancestor (corresponding
-- records do not automatically inherit operations, but maybe they
- -- should???)
+ -- should???). This does not apply to array types, where every base
+ -- type has a finalization routine that depends on the first subtype.
- if Is_Untagged_Derivation (Btyp) then
+ if Is_Untagged_Derivation (Btyp) and then not Is_Array_Type (Btyp) then
if Is_Protected_Type (Btyp) then
Utyp := Corresponding_Record_Type (Root_Type (Btyp));
@@ -8075,20 +8309,24 @@ package body Exp_Util is
elsif Nkind (Parent (P)) in N_Variant | N_Record_Definition then
null;
- -- Do not insert freeze nodes within the loop generated for
- -- an aggregate, because they may be elaborated too late for
- -- subsequent use in the back end: within a package spec the
- -- loop is part of the elaboration procedure and is only
- -- elaborated during the second pass.
-
- -- If the loop comes from source, or the entity is local to the
- -- loop itself it must remain within.
-
- elsif Nkind (Parent (P)) = N_Loop_Statement
- and then not Comes_From_Source (Parent (P))
+ -- Do not insert freeze nodes within a block or loop generated
+ -- for an aggregate, because they may be elaborated too late
+ -- for subsequent use in the back end: within a package spec,
+ -- the block or loop is part of the elaboration procedure and
+ -- is only elaborated during the second pass.
+
+ -- If the block or loop comes from source, or the entity is
+ -- local to the block or loop itself, it must remain within.
+
+ elsif ((Nkind (Parent (P)) = N_Handled_Sequence_Of_Statements
+ and then
+ Nkind (Parent (Parent (P))) = N_Block_Statement
+ and then not Comes_From_Source (Parent (Parent (P))))
+ or else (Nkind (Parent (P)) = N_Loop_Statement
+ and then not Comes_From_Source (Parent (P))))
and then Nkind (First (Ins_Actions)) = N_Freeze_Entity
- and then
- Scope (Entity (First (Ins_Actions))) /= Current_Scope
+ and then not
+ Within_Scope (Entity (First (Ins_Actions)), Current_Scope)
then
null;
@@ -8103,19 +8341,31 @@ package body Exp_Util is
return;
end if;
- -- the expansion of Task and protected type declarations can
+ -- The expansion of task and protected type declarations can
-- create declarations for temporaries which, like other actions
- -- are inserted and analyzed before the current declaraation.
- -- However, the current scope is the synchronized type, and
- -- for unnesting it is critical that the proper scope for these
- -- generated entities be the enclosing one.
+ -- are inserted and analyzed before the current declaration.
+ -- However, in some cases, the current scope is the synchronized
+ -- type, and for unnesting it is critical that the proper scope
+ -- for these generated entities be the enclosing one.
when N_Task_Type_Declaration
| N_Protected_Type_Declaration =>
- Push_Scope (Scope (Current_Scope));
- Insert_List_Before_And_Analyze (P, Ins_Actions);
- Pop_Scope;
+ declare
+ Skip_Scope : constant Boolean :=
+ Ekind (Current_Scope) in Concurrent_Kind;
+ begin
+ if Skip_Scope then
+ Push_Scope (Scope (Current_Scope));
+ end if;
+
+ Insert_List_Before_And_Analyze (P, Ins_Actions);
+
+ if Skip_Scope then
+ Pop_Scope;
+ end if;
+ end;
+
return;
-- A special case, N_Raise_xxx_Error can act either as a statement
@@ -8563,6 +8813,20 @@ package body Exp_Util is
end if;
end Is_Captured_Function_Call;
+ -------------------------------------------------
+ -- Is_Constr_Array_Subt_Of_Unc_With_Controlled --
+ -------------------------------------------------
+
+ function Is_Constr_Array_Subt_Of_Unc_With_Controlled (Typ : Entity_Id)
+ return Boolean
+ is
+ begin
+ return Is_Array_Type (Typ)
+ and then Is_Constrained (Typ)
+ and then Has_Controlled_Component (Typ)
+ and then not Is_Constrained (First_Subtype (Typ));
+ end Is_Constr_Array_Subt_Of_Unc_With_Controlled;
+
------------------------------------------
-- Is_Conversion_Or_Reference_To_Formal --
------------------------------------------
@@ -8606,6 +8870,97 @@ package body Exp_Util is
and then Nkind (Name (N)) = N_Explicit_Dereference;
end Is_Expanded_Class_Wide_Interface_Object_Decl;
+ ----------------------------------
+ -- Is_Expression_Of_Func_Return --
+ ----------------------------------
+
+ function Is_Expression_Of_Func_Return (N : Node_Id) return Boolean is
+ Par : constant Node_Id := Parent (N);
+
+ begin
+ return Nkind (Par) = N_Simple_Return_Statement
+ or else (Nkind (Par) in N_Object_Declaration
+ | N_Object_Renaming_Declaration
+ and then Is_Return_Object (Defining_Entity (Par)));
+ end Is_Expression_Of_Func_Return;
+
+ ---------------------------
+ -- Is_Finalizable_Access --
+ ---------------------------
+
+ function Is_Finalizable_Access (Decl : Node_Id) return Boolean is
+ Obj : constant Entity_Id := Defining_Identifier (Decl);
+ Typ : constant Entity_Id := Base_Type (Etype (Obj));
+ Desig : constant Entity_Id := Available_View (Designated_Type (Typ));
+ Expr : constant Node_Id := Expression (Decl);
+
+ Secondary_Stack_Val : constant Uint :=
+ UI_From_Int (BIP_Allocation_Form'Pos (Secondary_Stack));
+
+ Actual : Node_Id;
+ Call : Node_Id;
+ Formal : Node_Id;
+ Param : Node_Id;
+
+ begin
+ -- The prerequisite is a reference to a controlled object
+
+ if No (Expr)
+ or else Nkind (Expr) /= N_Reference
+ or else not Needs_Finalization (Desig)
+ then
+ return False;
+ end if;
+
+ Call := Unqual_Conv (Prefix (Expr));
+
+ -- For a BIP function call, the only case where the return object needs
+ -- to be finalized through Obj is when it is allocated on the secondary
+ -- stack; when it is allocated in the caller, it is finalized directly,
+ -- and when it is allocated on the global heap or in a storage pool, it
+ -- is finalized through another mechanism.
+
+ -- Obj : Access_Typ :=
+ -- BIP_Function_Call (BIPalloc => Secondary_Stack, ...)'reference;
+
+ if Is_Build_In_Place_Function_Call (Call) then
+
+ -- Examine all parameter associations of the function call
+
+ Param := First (Parameter_Associations (Call));
+ while Present (Param) loop
+ if Nkind (Param) = N_Parameter_Association then
+ Formal := Selector_Name (Param);
+ Actual := Explicit_Actual_Parameter (Param);
+
+ -- A match for BIPalloc => Secondary_Stack has been found
+
+ if Is_Build_In_Place_Entity (Formal)
+ and then BIP_Suffix_Kind (Formal) = BIP_Alloc_Form
+ and then Nkind (Actual) = N_Integer_Literal
+ and then Intval (Actual) = Secondary_Stack_Val
+ then
+ return True;
+ end if;
+ end if;
+
+ Next (Param);
+ end loop;
+
+ -- For a non-BIP function call, the only case where the return object
+ -- need not be finalized is when it itself is going to be returned.
+
+ -- Obj : Typ := Non_BIP_Function_Call'reference;
+
+ elsif Nkind (Call) = N_Function_Call
+ and then not Is_Related_To_Func_Return (Obj)
+ then
+ return True;
+ end if;
+
+ return False;
+ end Is_Finalizable_Access;
+
------------------------------
-- Is_Finalizable_Transient --
------------------------------
@@ -8617,19 +8972,6 @@ package body Exp_Util is
Obj_Id : constant Entity_Id := Defining_Identifier (Decl);
Obj_Typ : constant Entity_Id := Base_Type (Etype (Obj_Id));
- function Initialized_By_Aliased_BIP_Func_Call
- (Trans_Id : Entity_Id) return Boolean;
- -- Determine whether transient object Trans_Id is initialized by a
- -- build-in-place function call where the BIPalloc parameter either
- -- does not exist or is Caller_Allocation, and BIPaccess is not null.
- -- This case creates an aliasing between the returned value and the
- -- value denoted by BIPaccess.
-
- function Initialized_By_Reference (Trans_Id : Entity_Id) return Boolean;
- -- Determine whether transient object Trans_Id is initialized by a
- -- reference to another object. This is the only case where we can
- -- possibly finalize a transient object through an access value.
-
function Is_Aliased
(Trans_Id : Entity_Id;
First_Stmt : Node_Id) return Boolean;
@@ -8655,115 +8997,6 @@ package body Exp_Util is
-- Return True if N is directly part of a build-in-place return
-- statement.
- ------------------------------------------
- -- Initialized_By_Aliased_BIP_Func_Call --
- ------------------------------------------
-
- function Initialized_By_Aliased_BIP_Func_Call
- (Trans_Id : Entity_Id) return Boolean
- is
- Call : Node_Id := Expression (Parent (Trans_Id));
-
- begin
- -- Build-in-place calls usually appear in 'reference format
-
- if Nkind (Call) = N_Reference then
- Call := Prefix (Call);
- end if;
-
- Call := Unqual_Conv (Call);
-
- -- We search for a formal with a matching suffix. We can't search
- -- for the full name, because of the code at the end of Sem_Ch6.-
- -- Create_Extra_Formals, which copies the Extra_Formals over to
- -- the Alias of an instance, which will cause the formals to have
- -- "incorrect" names. See also Exp_Ch6.Build_In_Place_Formal.
-
- if Is_Build_In_Place_Function_Call (Call) then
- declare
- Caller_Allocation_Val : constant Uint :=
- UI_From_Int (BIP_Allocation_Form'Pos (Caller_Allocation));
- Access_Suffix : constant String :=
- BIP_Formal_Suffix (BIP_Object_Access);
- Alloc_Suffix : constant String :=
- BIP_Formal_Suffix (BIP_Alloc_Form);
-
- function Has_Suffix (Name, Suffix : String) return Boolean;
- -- Return True if Name has suffix Suffix
-
- ----------------
- -- Has_Suffix --
- ----------------
-
- function Has_Suffix (Name, Suffix : String) return Boolean is
- Len : constant Natural := Suffix'Length;
-
- begin
- return Name'Length > Len
- and then Name (Name'Last - Len + 1 .. Name'Last) = Suffix;
- end Has_Suffix;
-
- Access_OK : Boolean := False;
- Alloc_OK : Boolean := True;
- Param : Node_Id;
-
- begin
- -- Examine all parameter associations of the function call
-
- Param := First (Parameter_Associations (Call));
-
- while Present (Param) loop
- if Nkind (Param) = N_Parameter_Association
- and then Nkind (Selector_Name (Param)) = N_Identifier
- then
- declare
- Actual : constant Node_Id :=
- Explicit_Actual_Parameter (Param);
- Formal : constant Node_Id :=
- Selector_Name (Param);
- Name : constant String :=
- Get_Name_String (Chars (Formal));
-
- begin
- -- A nonnull BIPaccess has been found
-
- if Has_Suffix (Name, Access_Suffix)
- and then Nkind (Actual) /= N_Null
- then
- Access_OK := True;
-
- -- A BIPalloc has been found
-
- elsif Has_Suffix (Name, Alloc_Suffix)
- and then Nkind (Actual) = N_Integer_Literal
- then
- Alloc_OK := Intval (Actual) = Caller_Allocation_Val;
- end if;
- end;
- end if;
-
- Next (Param);
- end loop;
-
- return Access_OK and Alloc_OK;
- end;
- end if;
-
- return False;
- end Initialized_By_Aliased_BIP_Func_Call;
-
- ------------------------------
- -- Initialized_By_Reference --
- ------------------------------
-
- function Initialized_By_Reference (Trans_Id : Entity_Id) return Boolean
- is
- Expr : constant Node_Id := Expression (Parent (Trans_Id));
-
- begin
- return Present (Expr) and then Nkind (Expr) = N_Reference;
- end Initialized_By_Reference;
-
----------------
-- Is_Aliased --
----------------
@@ -8869,13 +9102,16 @@ package body Exp_Util is
Stmt := First_Stmt;
while Present (Stmt) loop
- -- Transient objects initialized by a reference are finalized
- -- (see Initialized_By_Reference above), so we must make sure
- -- not to finalize the referenced object twice. And we cannot
- -- finalize it at all if it is referenced by the nontransient
- -- object serviced by the transient scope.
-
- if Nkind (Stmt) = N_Object_Declaration then
+ -- (Transient) objects initialized by a reference to another named
+ -- object are never finalized (see Is_Finalizable_Access), so we
+ -- need not worry about finalizing (transient) referenced objects
+ -- twice. Therefore, we only need to look at the nontransient
+ -- object serviced by the transient scope, if it exists and is
+ -- declared as a reference to another named object.
+
+ if Nkind (Stmt) = N_Object_Declaration
+ and then Stmt = N
+ then
Expr := Expression (Stmt);
-- Aliasing of the form:
@@ -8889,8 +9125,8 @@ package body Exp_Util is
return True;
end if;
- -- (Transient) renamings are never finalized so we need not bother
- -- about finalizing transient renamed objects twice. Therefore, we
+ -- (Transient) renamings are never finalized so we need not worry
+ -- about finalizing (transient) renamed objects twice. Therefore,
-- we only need to look at the nontransient object serviced by the
-- transient scope, if it exists and is declared as a renaming.
@@ -9090,12 +9326,11 @@ package body Exp_Util is
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
+ if No (Subp) or else not Is_Build_In_Place_Function (Subp) then
return False;
end if;
@@ -9119,6 +9354,15 @@ package body Exp_Util is
-- Start of processing for Is_Finalizable_Transient
begin
+ -- If the node serviced by the transient context is a return statement,
+ -- then the finalization needs to be deferred to the generic machinery.
+
+ if Nkind (N) = N_Simple_Return_Statement
+ or else Is_Part_Of_BIP_Return_Statement (N)
+ then
+ return False;
+ end if;
+
-- Handle access types
if Is_Access_Type (Desig) then
@@ -9128,34 +9372,27 @@ package body Exp_Util is
return
Ekind (Obj_Id) in E_Constant | E_Variable
and then Needs_Finalization (Desig)
- and then Nkind (N) /= N_Simple_Return_Statement
- and then not Is_Part_Of_BIP_Return_Statement (N)
-- Do not consider a transient object that was already processed
and then not Is_Finalized_Transient (Obj_Id)
- -- Do not consider renamed or 'reference-d transient objects because
- -- the act of renaming extends the object's lifetime.
+ -- Do not consider iterators because those are treated as normal
+ -- controlled objects and are processed by the usual finalization
+ -- machinery. This avoids the double finalization of an iterator.
- and then not Is_Aliased (Obj_Id, Decl)
+ and then not Is_Iterator (Desig)
- -- If the transient object is of an access type, check that it is
- -- initialized by a reference to another object.
+ -- If the transient object is of an access type, check that it must
+ -- be finalized.
and then (not Is_Access_Type (Obj_Typ)
- or else Initialized_By_Reference (Obj_Id))
-
- -- Do not consider transient objects which act as indirect aliases
- -- of build-in-place function results.
+ or else Is_Finalizable_Access (Decl))
- and then not Initialized_By_Aliased_BIP_Func_Call (Obj_Id)
+ -- Do not consider renamed transient objects because the act of
+ -- renaming extends the object's lifetime.
- -- Do not consider iterators because those are treated as normal
- -- controlled objects and are processed by the usual finalization
- -- machinery. This avoids the double finalization of an iterator.
-
- and then not Is_Iterator (Desig)
+ and then not Is_Aliased (Obj_Id, Decl)
-- Do not consider containers in the context of iterator loops. Such
-- transient objects must exist for as long as the loop is around,
@@ -9224,22 +9461,6 @@ package body Exp_Util is
and then Present (LSP_Subprogram (E));
end Is_LSP_Wrapper;
- --------------------------
- -- Is_Non_BIP_Func_Call --
- --------------------------
-
- function Is_Non_BIP_Func_Call (Expr : Node_Id) return Boolean is
- begin
- -- The expected call is of the format
- --
- -- Func_Call'reference
-
- return
- Nkind (Expr) = N_Reference
- and then Nkind (Prefix (Expr)) = N_Function_Call
- and then not Is_Build_In_Place_Function_Call (Prefix (Expr));
- end Is_Non_BIP_Func_Call;
-
----------------------------------
-- Is_Possibly_Unaligned_Object --
----------------------------------
@@ -9512,21 +9733,16 @@ package body Exp_Util is
function Is_Related_To_Func_Return (Id : Entity_Id) return Boolean is
Expr : constant Node_Id := Related_Expression (Id);
+
begin
-- In the case of a function with a class-wide result that returns
-- a call to a function with a specific result, we introduce a
-- type conversion for the return expression. We do not want that
-- type conversion to influence the result of this function.
- return
- Present (Expr)
- and then Nkind (Unqual_Conv (Expr)) = N_Explicit_Dereference
- and then (Nkind (Parent (Expr)) = N_Simple_Return_Statement
- or else
- (Nkind (Parent (Expr)) in N_Object_Declaration
- | N_Object_Renaming_Declaration
- and then
- Is_Return_Object (Defining_Entity (Parent (Expr)))));
+ return Present (Expr)
+ and then Nkind (Unqual_Conv (Expr)) = N_Explicit_Dereference
+ and then Is_Expression_Of_Func_Return (Expr);
end Is_Related_To_Func_Return;
--------------------------------
@@ -9612,55 +9828,6 @@ package body Exp_Util is
end if;
end Is_Renamed_Object;
- --------------------------------------
- -- Is_Secondary_Stack_BIP_Func_Call --
- --------------------------------------
-
- function Is_Secondary_Stack_BIP_Func_Call (Expr : Node_Id) return Boolean is
- Actual : Node_Id;
- Call : Node_Id := Expr;
- Formal : Node_Id;
- Param : Node_Id;
-
- begin
- -- Build-in-place calls usually appear in 'reference format. Note that
- -- the accessibility check machinery may add an extra 'reference due to
- -- side-effect removal.
-
- while Nkind (Call) = N_Reference loop
- Call := Prefix (Call);
- end loop;
-
- Call := Unqual_Conv (Call);
-
- if Is_Build_In_Place_Function_Call (Call) then
-
- -- Examine all parameter associations of the function call
-
- Param := First (Parameter_Associations (Call));
- while Present (Param) loop
- if Nkind (Param) = N_Parameter_Association then
- Formal := Selector_Name (Param);
- Actual := Explicit_Actual_Parameter (Param);
-
- -- A match for BIPalloc => 2 has been found
-
- if Is_Build_In_Place_Entity (Formal)
- and then BIP_Suffix_Kind (Formal) = BIP_Alloc_Form
- and then Nkind (Actual) = N_Integer_Literal
- and then Intval (Actual) = Uint_2
- then
- return True;
- end if;
- end if;
-
- Next (Param);
- end loop;
- end if;
-
- return False;
- end Is_Secondary_Stack_BIP_Func_Call;
-
------------------------------
-- Is_Secondary_Stack_Thunk --
------------------------------
@@ -10871,11 +11038,10 @@ package body Exp_Util is
-- operator on private type might not be visible and won't be
-- resolved.
- else pragma Assert (Is_RTE (Base_Type (Typ), RE_Big_Integer)
- or else
- Is_RTE (Base_Type (Typ), RO_GH_Big_Integer)
- or else
- Is_RTE (Base_Type (Typ), RO_SP_Big_Integer));
+ else
+ pragma Assert
+ (Is_RTE (Base_Type (Typ), RE_Big_Integer)
+ or else Is_RTE (Base_Type (Typ), RO_SP_Big_Integer));
return
Make_Function_Call (Loc,
Name =>
@@ -12704,18 +12870,22 @@ package body Exp_Util is
-- Otherwise we generate a reference to the expression
else
- -- Special processing for function calls that return a limited type.
- -- We need to build a declaration that will enable build-in-place
- -- expansion of the call. This is not done if the context is already
- -- an object declaration, to prevent infinite recursion.
-
- -- This is relevant only in Ada 2005 mode. In Ada 95 programs we have
- -- to accommodate functions returning limited objects by reference.
-
- if Ada_Version >= Ada_2005
- and then Nkind (Exp) = N_Function_Call
- and then Is_Inherently_Limited_Type (Etype (Exp))
+ -- Special processing for function calls with a result type that is
+ -- either BIP or a constrained array with controlled component and
+ -- an unconstrained first subtype, when the context is neither an
+ -- object declaration (to prevent infinite recursion) nor a function
+ -- return (to propagate the anonymous return object).
+
+ -- We need to build an object declaration to trigger build-in-place
+ -- expansion of the call in the former case, and addition of bounds
+ -- to the object in the latter case.
+
+ if Nkind (Exp) = N_Function_Call
+ and then (Is_Build_In_Place_Result_Type (Exp_Type)
+ or else
+ Is_Constr_Array_Subt_Of_Unc_With_Controlled (Exp_Type))
and then Nkind (Parent (Exp)) /= N_Object_Declaration
+ and then not Is_Expression_Of_Func_Return (Exp)
then
declare
Obj : constant Entity_Id := Make_Temporary (Loc, 'F', Exp);
@@ -13324,7 +13494,6 @@ package body Exp_Util is
Nested_Constructs : Boolean) return Boolean
is
Decl : Node_Id;
- Expr : Node_Id;
Obj_Id : Entity_Id;
Obj_Typ : Entity_Id;
Pack_Id : Entity_Id;
@@ -13362,7 +13531,6 @@ package body Exp_Util is
elsif Nkind (Decl) = N_Object_Declaration then
Obj_Id := Defining_Identifier (Decl);
Obj_Typ := Base_Type (Etype (Obj_Id));
- Expr := Expression (Decl);
-- Bypass any form of processing for objects which have their
-- finalization disabled. This applies only to objects at the
@@ -13416,21 +13584,10 @@ package body Exp_Util is
then
return True;
- -- The object is of the form:
- -- Obj : Access_Typ := Non_BIP_Function_Call'reference;
- --
- -- Obj : Access_Typ :=
- -- BIP_Function_Call (BIPalloc => 2, ...)'reference;
+ -- The object is an access-to-controlled that must be finalized
elsif Is_Access_Type (Obj_Typ)
- and then Needs_Finalization
- (Available_View (Designated_Type (Obj_Typ)))
- and then Present (Expr)
- and then
- (Is_Secondary_Stack_BIP_Func_Call (Expr)
- or else
- (Is_Non_BIP_Func_Call (Expr)
- and then not Is_Related_To_Func_Return (Obj_Id)))
+ and then Is_Finalizable_Access (Decl)
then
return True;
@@ -14439,6 +14596,11 @@ package body Exp_Util is
when N_Aggregate =>
return Compile_Time_Known_Aggregate (N);
+ -- A reference is side-effect-free
+
+ when N_Reference =>
+ return True;
+
-- We consider that anything else has side effects. This is a bit
-- crude, but we are pretty close for most common cases, and we
-- are certainly correct (i.e. we never return True when the
@@ -14466,7 +14628,16 @@ package body Exp_Util is
else
N := First (L);
while Present (N) loop
- if not Side_Effect_Free (N, Name_Req, Variable_Ref) then
+ if Nkind (N) = N_Parameter_Association then
+ if not
+ Side_Effect_Free
+ (Explicit_Actual_Parameter (N), Name_Req, Variable_Ref)
+ then
+ return False;
+ end if;
+
+ Next (N);
+ elsif not Side_Effect_Free (N, Name_Req, Variable_Ref) then
return False;
else
Next (N);
diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads
index 6178767..b8b7525 100644
--- a/gcc/ada/exp_util.ads
+++ b/gcc/ada/exp_util.ads
@@ -479,8 +479,9 @@ package Exp_Util is
function Duplicate_Subexpr
(Exp : Node_Id;
- Name_Req : Boolean := False;
- Renaming_Req : Boolean := False) return Node_Id;
+ New_Scope : Entity_Id := Empty;
+ Name_Req : Boolean := False;
+ Renaming_Req : Boolean := False) return Node_Id;
-- Given the node for a subexpression, this function makes a logical copy
-- of the subexpression, and returns it. This is intended for use when the
-- expansion of an expression needs to repeat part of it. For example,
@@ -494,6 +495,9 @@ package Exp_Util is
-- the caller is responsible for analyzing the returned copy after it is
-- attached to the tree.
--
+ -- The New_Scope entity may be used to specify a new scope for all copied
+ -- entities and itypes.
+ --
-- The Name_Req flag is set to ensure that the result is suitable for use
-- in a context requiring a name (for example, the prefix of an attribute
-- reference).
@@ -509,8 +513,9 @@ package Exp_Util is
function Duplicate_Subexpr_No_Checks
(Exp : Node_Id;
- Name_Req : Boolean := False;
- Renaming_Req : Boolean := False) return Node_Id;
+ New_Scope : Entity_Id := Empty;
+ Name_Req : Boolean := False;
+ Renaming_Req : Boolean := False) return Node_Id;
-- Identical in effect to Duplicate_Subexpr, except that Remove_Checks is
-- called on the result, so that the duplicated expression does not include
-- checks. This is appropriate for use when Exp, the original expression is
@@ -519,8 +524,9 @@ package Exp_Util is
function Duplicate_Subexpr_Move_Checks
(Exp : Node_Id;
- Name_Req : Boolean := False;
- Renaming_Req : Boolean := False) return Node_Id;
+ New_Scope : Entity_Id := Empty;
+ Name_Req : Boolean := False;
+ Renaming_Req : Boolean := False) return Node_Id;
-- Identical in effect to Duplicate_Subexpr, except that Remove_Checks is
-- called on Exp after the duplication is complete, so that the original
-- expression does not include checks. In this case the result returned
@@ -810,6 +816,11 @@ package Exp_Util is
-- Rnn : constant Ann := Func (...)'reference;
-- Rnn.all
+ function Is_Constr_Array_Subt_Of_Unc_With_Controlled (Typ : Entity_Id)
+ return Boolean;
+ -- Return True if Typ is a constrained subtype of an array type with an
+ -- unconstrained first subtype and a controlled component type.
+
function Is_Conversion_Or_Reference_To_Formal (N : Node_Id) return Boolean;
-- Return True if N is a type conversion, or a dereference thereof, or a
-- reference to a formal parameter.
@@ -819,6 +830,14 @@ package Exp_Util is
-- Determine if N is the expanded code for a class-wide interface type
-- object declaration.
+ function Is_Finalizable_Access (Decl : Node_Id) return Boolean;
+ -- Determine whether declaration Decl denotes an access-to-controlled
+ -- object that must be finalized, i.e. both that the designated object
+ -- is controlled and that it must be finalized through this access, in
+ -- particular that it will not be also finalized directly. That is the
+ -- case only for objects initialized by a reference to a function call
+ -- that meet specific conditions.
+
function Is_Finalizable_Transient
(Decl : Node_Id;
N : Node_Id) return Boolean;
@@ -845,9 +864,6 @@ package Exp_Util is
-- preconditions or postconditions affected by overriding (AI12-0195).
-- LSP stands for Liskov Substitution Principle.
- function Is_Non_BIP_Func_Call (Expr : Node_Id) return Boolean;
- -- Determine whether node Expr denotes a non build-in-place function call
-
function Is_Possibly_Unaligned_Object (N : Node_Id) return Boolean;
-- Node N is an object reference. This function returns True if it is
-- possible that the object may not be aligned according to the normal
@@ -892,10 +908,6 @@ package Exp_Util is
-- We consider that a (1 .. 2) is a renamed object since it is the prefix
-- of the name in the renaming declaration.
- function Is_Secondary_Stack_BIP_Func_Call (Expr : Node_Id) return Boolean;
- -- Determine whether Expr denotes a build-in-place function which returns
- -- its result on the secondary stack.
-
function Is_Secondary_Stack_Thunk (Id : Entity_Id) return Boolean;
-- Determine whether Id denotes a secondary stack thunk
diff --git a/gcc/ada/expander.adb b/gcc/ada/expander.adb
index 8cec821..3d7b0d7 100644
--- a/gcc/ada/expander.adb
+++ b/gcc/ada/expander.adb
@@ -230,6 +230,9 @@ package body Expander is
when N_Conditional_Entry_Call =>
Expand_N_Conditional_Entry_Call (N);
+ when N_Continue_Statement =>
+ Expand_N_Continue_Statement (N);
+
when N_Delay_Relative_Statement =>
Expand_N_Delay_Relative_Statement (N);
diff --git a/gcc/ada/fe.h b/gcc/ada/fe.h
index bb8b96e..0b80a56 100644
--- a/gcc/ada/fe.h
+++ b/gcc/ada/fe.h
@@ -110,8 +110,8 @@ extern Node_Id Get_Attribute_Definition_Clause (Entity_Id, unsigned char);
/* errout: */
-#define Error_Msg_N errout__error_msg_n
-#define Error_Msg_NE errout__error_msg_ne
+#define Error_Msg_N errout__error_msg_n_gigi
+#define Error_Msg_NE errout__error_msg_ne_gigi
#define Set_Identifier_Casing errout__set_identifier_casing
extern void Error_Msg_N (String_Pointer, Node_Id);
diff --git a/gcc/ada/fname-uf.adb b/gcc/ada/fname-uf.adb
index 39a09c4..ec22ad7 100644
--- a/gcc/ada/fname-uf.adb
+++ b/gcc/ada/fname-uf.adb
@@ -90,8 +90,9 @@ package body Fname.UF is
Table_Initial => 10,
Table_Increment => 100,
Table_Name => "SFN_Patterns");
- -- Table recording calls to Set_File_Name_Pattern. Note that the first two
- -- entries are set to represent the standard GNAT rules for file naming.
+ -- Table recording calls to Set_File_Name_Pattern. Note that the last two
+ -- entries are set to represent the standard GNAT rules for file naming;
+ -- that invariant is maintained by Set_File_Name_Pattern.
procedure Instantiate_SFN_Pattern
(Pattern : SFN_Pattern_Entry;
@@ -178,6 +179,8 @@ package body Fname.UF is
---------------------------
function Get_Default_File_Name (Uname : Unit_Name_Type) return String is
+ L : constant Int := SFN_Patterns.Last;
+
Buf : Bounded_String;
Pattern : SFN_Pattern_Entry;
@@ -185,10 +188,10 @@ package body Fname.UF is
Get_Unit_Name_String (Buf, Uname, False);
if Is_Spec_Name (Uname) then
- Pattern := SFN_Patterns.Table (1);
+ Pattern := SFN_Patterns.Table (L - 1);
else
pragma Assert (Is_Body_Name (Uname));
- Pattern := SFN_Patterns.Table (2);
+ Pattern := SFN_Patterns.Table (L);
end if;
Instantiate_SFN_Pattern (Pattern, Buf);
diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb
index 54b6202..be2115a 100644
--- a/gcc/ada/freeze.adb
+++ b/gcc/ada/freeze.adb
@@ -715,10 +715,11 @@ package body Freeze is
then
declare
O_Ent : Entity_Id;
+ O_Typ : Entity_Id;
Off : Boolean;
begin
- Find_Overlaid_Entity (Addr, O_Ent, Off);
+ Find_Overlaid_Entity (Addr, O_Ent, O_Typ, Off);
if Ekind (O_Ent) = E_Constant
and then Etype (O_Ent) = Typ
@@ -1495,12 +1496,13 @@ package body Freeze is
New_Formal := Defining_Identifier (New_F_Spec);
-- If the controlling argument is inherited, add conversion to
- -- parent type for the call.
+ -- parent type for the call. We make this an unchecked conversion
+ -- since the formal subtypes of the parent and derived subprograms
+ -- must conform, so checks should not be needed.
if Is_Controlling_Formal (Formal) then
Append_To (Actuals,
- Make_Type_Conversion (Loc,
- New_Occurrence_Of (Etype (Formal), Loc),
+ Unchecked_Convert_To (Etype (Formal),
New_Occurrence_Of (New_Formal, Loc)));
else
Append_To (Actuals, New_Occurrence_Of (New_Formal, Loc));
@@ -5449,9 +5451,12 @@ package body Freeze is
Set_Must_Be_On_Byte_Boundary (Rec);
-- Check for component clause that is inconsistent with
- -- the required byte boundary alignment.
+ -- the required byte boundary alignment. Do not do this
+ -- in CodePeer_Mode, as we do not have sufficient info
+ -- on size and representation clauses.
- if Present (CC)
+ if not CodePeer_Mode
+ and then Present (CC)
and then Normalized_First_Bit (Comp) mod
System_Storage_Unit /= 0
then
@@ -6869,9 +6874,10 @@ package body Freeze is
end if;
end if;
- -- Static objects require special handling
+ -- Statically allocated objects require special handling
if (Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
+ and then No (Renamed_Object (E))
and then Is_Statically_Allocated (E)
then
Freeze_Static_Object (E);
@@ -9389,16 +9395,17 @@ package body Freeze is
-- pre/postconditions during expansion of the subprogram body, the
-- subprogram is already installed.
- -- Call Preanalyze_Spec_Expression instead of Preanalyze_And_Resolve
- -- for the sake of consistency with Analyze_Expression_Function.
+ -- Call Preanalyze_And_Resolve_Spec_Expression instead of Preanalyze_
+ -- And_Resolve for the sake of consistency with Analyze_Expression_
+ -- Function.
if Def_Id /= Current_Scope then
Push_Scope (Def_Id);
Install_Formals (Def_Id);
- Preanalyze_Spec_Expression (Dup_Expr, Typ);
+ Preanalyze_And_Resolve_Spec_Expression (Dup_Expr, Typ);
End_Scope;
else
- Preanalyze_Spec_Expression (Dup_Expr, Typ);
+ Preanalyze_And_Resolve_Spec_Expression (Dup_Expr, Typ);
end if;
-- Restore certain attributes of Def_Id since the preanalysis may
@@ -10230,11 +10237,17 @@ package body Freeze is
-- issue an error message saying that this object cannot be imported
-- or exported. If it has an address clause it is an overlay in the
-- current partition and the static requirement is not relevant.
- -- Do not issue any error message when ignoring rep clauses.
+ -- Do not issue any error message when ignoring rep clauses or for
+ -- compiler-generated entities.
if Ignore_Rep_Clauses then
null;
+ elsif not Comes_From_Source (E) then
+ pragma
+ Assert (Nkind (Parent (Declaration_Node (E))) in N_Case_Statement
+ | N_If_Statement);
+
elsif Is_Imported (E) then
if No (Address_Clause (E)) then
Error_Msg_N
diff --git a/gcc/ada/frontend.adb b/gcc/ada/frontend.adb
index 12cea9c..564f153 100644
--- a/gcc/ada/frontend.adb
+++ b/gcc/ada/frontend.adb
@@ -368,11 +368,12 @@ begin
-- If we have restriction No_Exception_Propagation, and we did not have
-- an explicit switch turning off Warn_On_Non_Local_Exception, then turn
-- on this warning by default if we have encountered an exception
- -- handler.
+ -- handler. We do not override the setting of GNATprove.
if Restriction_Check_Required (No_Exception_Propagation)
and then not No_Warn_On_Non_Local_Exception
and then Exception_Handler_Encountered
+ and then not GNATprove_Mode
then
Warn_On_Non_Local_Exception := True;
end if;
@@ -506,9 +507,7 @@ begin
-- Verify the validity of the tree
- if Debug_Flag_Underscore_VV then
- VAST.Check_Tree (Cunit (Main_Unit));
- end if;
+ VAST.VAST;
-- Validate all the subprogram calls; this work will be done by VAST; in
-- the meantime it is done to check extra formals and it can be disabled
diff --git a/gcc/ada/gcc-interface/Make-lang.in b/gcc/ada/gcc-interface/Make-lang.in
index 964cae8..1c93816 100644
--- a/gcc/ada/gcc-interface/Make-lang.in
+++ b/gcc/ada/gcc-interface/Make-lang.in
@@ -185,6 +185,11 @@ ada.serial = gnat1$(exeext)
# variable conveys what we need for this, set to "g++" if not bootstrapping,
# ".../xg++" otherwise.
+GNATMAKE_FOR_HOST = $(GNATMAKE)
+GNATBIND_FOR_HOST = $(GNATBIND)
+GNATLINK_FOR_HOST = $(subst gnatmake,gnatlink,$(GNATMAKE))
+GNATLS_FOR_HOST = $(subst gnatmake,gnatls,$(GNATMAKE))
+
# There are too many Ada sources to check against here. Let's
# always force the recursive make.
ifeq ($(build), $(host))
@@ -214,20 +219,16 @@ ifeq ($(build), $(host))
CXX="$(CXX)" \
$(COMMON_FLAGS_TO_PASS) $(ADA_FLAGS_TO_PASS) \
ADA_INCLUDES="-I../generated -I$(RTS_DIR)/../adainclude -I$(RTS_DIR)" \
- GNATMAKE="gnatmake" \
- GNATBIND="gnatbind" \
- GNATLINK="gnatlink" \
+ GNATMAKE="$(GNATMAKE_FOR_HOST)" \
+ GNATBIND="$(GNATBIND_FOR_HOST)" \
+ GNATLINK="$(GNATLINK_FOR_HOST)" \
LIBGNAT=""
endif
else
# Build is different from host so we are either building a canadian cross
# or a cross-native compiler. We provide defaults for tools targeting the
- # host platform, but they can be overriden by just setting <tool>_FOR_HOST
+ # host platform, but they can be overridden by just setting <tool>_FOR_HOST
# variables.
- GNATMAKE_FOR_HOST=$(host_noncanonical)-gnatmake
- GNATBIND_FOR_HOST=$(host_noncanonical)-gnatbind
- GNATLINK_FOR_HOST=$(host_noncanonical)-gnatlink
- GNATLS_FOR_HOST=$(host_noncanonical)-gnatls
ifeq ($(host), $(target))
# This is a cross native. All the sources are taken from the currently
@@ -315,23 +316,17 @@ GNAT_ADA_OBJS = \
ada/cstand.o \
ada/debug.o \
ada/debug_a.o \
- ada/diagnostics-brief_emitter.o \
- ada/diagnostics-constructors.o \
- ada/diagnostics-converter.o \
- ada/diagnostics-json_utils.o \
- ada/diagnostics-pretty_emitter.o \
- ada/diagnostics-repository.o \
- ada/diagnostics-sarif_emitter.o \
- ada/diagnostics-switch_repository.o \
- ada/diagnostics-utils.o \
- ada/diagnostics.o \
ada/einfo-entities.o \
ada/einfo-utils.o \
ada/einfo.o \
ada/elists.o \
ada/err_vars.o \
+ ada/errid.o \
ada/errout.o \
ada/erroutc.o \
+ ada/erroutc-pretty_emitter.o \
+ ada/erroutc-sarif_emitter.o \
+ ada/errsw.o \
ada/eval_fat.o \
ada/exp_aggr.o \
ada/exp_spark.o \
@@ -380,6 +375,7 @@ GNAT_ADA_OBJS = \
ada/impunit.o \
ada/inline.o \
ada/itypes.o \
+ ada/json_utils.o \
ada/krunch.o \
ada/layout.o \
ada/lib-load.o \
@@ -535,6 +531,7 @@ GNAT_ADA_OBJS+= \
ada/libgnat/s-bitops.o \
ada/libgnat/s-carun8.o \
ada/libgnat/s-casuti.o \
+ ada/libgnat/s-cautns.o \
ada/libgnat/s-crtl.o \
ada/libgnat/s-conca2.o \
ada/libgnat/s-conca3.o \
@@ -562,8 +559,6 @@ GNAT_ADA_OBJS+= \
ada/libgnat/s-secsta.o \
ada/libgnat/s-soflin.o \
ada/libgnat/s-soliin.o \
- ada/libgnat/s-spark.o \
- ada/libgnat/s-spcuop.o \
ada/libgnat/s-stache.o \
ada/libgnat/s-stalib.o \
ada/libgnat/s-stoele.o \
@@ -575,11 +570,8 @@ GNAT_ADA_OBJS+= \
ada/libgnat/s-trasym.o \
ada/libgnat/s-unstyp.o \
ada/libgnat/s-valint.o \
- ada/libgnat/s-valspe.o \
ada/libgnat/s-valuns.o \
ada/libgnat/s-valuti.o \
- ada/libgnat/s-vs_int.o \
- ada/libgnat/s-vs_uns.o \
ada/libgnat/s-wchcnv.o \
ada/libgnat/s-wchcon.o \
ada/libgnat/s-wchjis.o \
@@ -615,23 +607,17 @@ GNATBIND_OBJS = \
ada/casing.o \
ada/csets.o \
ada/debug.o \
- ada/diagnostics-brief_emitter.o \
- ada/diagnostics-constructors.o \
- ada/diagnostics-converter.o \
- ada/diagnostics-json_utils.o \
- ada/diagnostics-pretty_emitter.o \
- ada/diagnostics-repository.o \
- ada/diagnostics-sarif_emitter.o \
- ada/diagnostics-switch_repository.o \
- ada/diagnostics-utils.o \
- ada/diagnostics.o \
ada/einfo-entities.o \
ada/einfo-utils.o \
ada/einfo.o \
ada/elists.o \
ada/err_vars.o \
+ ada/errid.o \
ada/errout.o \
ada/erroutc.o \
+ ada/erroutc-sarif_emitter.o \
+ ada/erroutc-pretty_emitter.o \
+ ada/errsw.o \
ada/exit.o \
ada/final.o \
ada/fmap.o \
@@ -639,6 +625,7 @@ GNATBIND_OBJS = \
ada/gnatbind.o \
ada/gnatvsn.o \
ada/hostparm.o \
+ ada/json_utils.o \
ada/lib.o \
ada/link.o \
ada/namet.o \
@@ -710,6 +697,7 @@ GNATBIND_OBJS += \
ada/libgnat/s-assert.o \
ada/libgnat/s-carun8.o \
ada/libgnat/s-casuti.o \
+ ada/libgnat/s-cautns.o \
ada/libgnat/s-conca2.o \
ada/libgnat/s-conca3.o \
ada/libgnat/s-conca4.o \
@@ -1108,7 +1096,7 @@ check-ada-subtargets: check-acats-subtargets check-gnat-subtargets
# No ada-specific selftests
selftest-ada:
-ACATSDIR = $(TESTSUITEDIR)/ada/acats
+ACATSDIR = $(TESTSUITEDIR)/ada/acats-2
ACATSCMD = run_acats.sh
check_acats_numbers0:=1 2 3 4 5 6 7 8 9
diff --git a/gcc/ada/gcc-interface/Makefile.in b/gcc/ada/gcc-interface/Makefile.in
index 4ffdc1e..3557b46 100644
--- a/gcc/ada/gcc-interface/Makefile.in
+++ b/gcc/ada/gcc-interface/Makefile.in
@@ -104,6 +104,8 @@ INSTALL_DATA_DATE = cp -p
MAKEINFO = makeinfo
TEXI2DVI = texi2dvi
TEXI2PDF = texi2pdf
+
+GNATMAKE_FOR_BUILD = gnatmake
GNATBIND_FLAGS = -static -x
ADA_CFLAGS =
ADAFLAGS = -W -Wall -gnatpg -gnata -gnatU
@@ -321,23 +323,18 @@ GNATMAKE_OBJS = a-except.o ali.o ali-util.o aspects.o s-casuti.o alloc.o \
erroutc.o errutil.o err_vars.o fmap.o fname.o fname-uf.o fname-sf.o \
gnatmake.o gnatvsn.o hostparm.o interfac.o i-c.o i-cstrin.o krunch.o lib.o \
make.o makeusg.o make_util.o namet.o nlists.o opt.o osint.o osint-m.o \
- output.o restrict.o rident.o s-exctab.o \
+ output.o restrict.o rident.o s-exctab.o s-cautns.o \
s-secsta.o s-stalib.o s-stoele.o scans.o scng.o sdefault.o sfn_scan.o \
s-purexc.o s-htable.o scil_ll.o sem_aux.o sinfo.o sinput.o sinput-c.o \
snames.o stand.o stringt.o styleg.o stylesw.o system.o validsw.o \
switch.o switch-m.o table.o targparm.o tempdir.o types.o uintp.o \
uname.o urealp.o usage.o widechar.o warnsw.o \
seinfo.o einfo-entities.o einfo-utils.o sinfo-nodes.o sinfo-utils.o \
- diagnostics-brief_emitter.o \
- diagnostics-constructors.o \
- diagnostics-converter.o \
- diagnostics-json_utils.o \
- diagnostics-pretty_emitter.o \
- diagnostics-repository.o \
- diagnostics-sarif_emitter.o \
- diagnostics-switch_repository.o \
- diagnostics-utils.o \
- diagnostics.o \
+ errid.o \
+ errsw.o \
+ erroutc-pretty_emitter.o \
+ erroutc-sarif_emitter.o \
+ json_utils.o
$(EXTRA_GNATMAKE_OBJS)
# Make arch match the current multilib so that the RTS selection code
@@ -634,7 +631,7 @@ OSCONS_EXTRACT=$(GCC_FOR_ADA_RTS) $(GNATLIBCFLAGS_FOR_C) -S s-oscons-tmplt.i
-$(MKDIR) ./bldtools/oscons
$(RM) $(addprefix ./bldtools/oscons/,$(notdir $^))
$(CP) $^ ./bldtools/oscons
- (cd ./bldtools/oscons ; gnatmake -q xoscons)
+ (cd ./bldtools/oscons ; $(GNATMAKE_FOR_BUILD) xoscons)
$(RTSDIR)/s-oscons.ads: ../stamp-gnatlib1-$(RTSDIR) s-oscons-tmplt.c gsocket.h ./bldtools/oscons/xoscons
$(RM) $(RTSDIR)/s-oscons-tmplt.i $(RTSDIR)/s-oscons-tmplt.s
diff --git a/gcc/ada/gcc-interface/decl.cc b/gcc/ada/gcc-interface/decl.cc
index 1694b4e..972607a 100644
--- a/gcc/ada/gcc-interface/decl.cc
+++ b/gcc/ada/gcc-interface/decl.cc
@@ -1228,6 +1228,24 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
gnu_expr = gnat_build_constructor (gnu_type, v);
}
+ /* If we are allocating the anonymous object of a small aggregate on
+ the stack, zero-initialize it so that the entire object is assigned
+ and the subsequent assignments need not preserve unknown bits, but
+ do it only when optimization is enabled for the sake of consistency
+ with the gimplifier which does the same for CONSTRUCTORs. */
+ else if (definition
+ && !imported_p
+ && !static_flag
+ && !gnu_expr
+ && TREE_CODE (gnu_type) == RECORD_TYPE
+ && TREE_CODE (gnu_object_size) == INTEGER_CST
+ && compare_tree_int (gnu_object_size, MAX_FIXED_MODE_SIZE) <= 0
+ && Present (Related_Expression (gnat_entity))
+ && Nkind (Original_Node (Related_Expression (gnat_entity)))
+ == N_Aggregate
+ && optimize)
+ gnu_expr = build_constructor (gnu_type, NULL);
+
/* Convert the expression to the type of the object if need be. */
if (gnu_expr && initial_value_needs_conversion (gnu_type, gnu_expr))
gnu_expr = convert (gnu_type, gnu_expr);
@@ -5251,7 +5269,7 @@ inline_status_for_subprog (Entity_Id subprog)
&& Is_Record_Type (Etype (First_Formal (subprog)))
&& (gnu_type = gnat_to_gnu_type (Etype (First_Formal (subprog))))
&& !TYPE_IS_BY_REFERENCE_P (gnu_type)
- && tree_fits_uhwi_p (TYPE_SIZE (gnu_type))
+ && TREE_CODE (TYPE_SIZE (gnu_type)) == INTEGER_CST
&& compare_tree_int (TYPE_SIZE (gnu_type), MAX_FIXED_MODE_SIZE) <= 0)
return is_prescribed;
diff --git a/gcc/ada/gcc-interface/misc.cc b/gcc/ada/gcc-interface/misc.cc
index ca5c9a2..128040e 100644
--- a/gcc/ada/gcc-interface/misc.cc
+++ b/gcc/ada/gcc-interface/misc.cc
@@ -377,7 +377,7 @@ gnat_init (void)
line_table->default_range_bits = 0;
/* Register our internal error function. */
- global_dc->m_internal_error = &internal_error_function;
+ global_dc->set_internal_error_callback (&internal_error_function);
return true;
}
diff --git a/gcc/ada/gen_il-fields.ads b/gcc/ada/gen_il-fields.ads
index c293e0f..2d16e12 100644
--- a/gcc/ada/gen_il-fields.ads
+++ b/gcc/ada/gen_il-fields.ads
@@ -56,7 +56,6 @@ package Gen_IL.Fields is
Abort_Present,
Abortable_Part,
Abstract_Present,
- Accept_Handler_Records,
Accept_Statement,
Access_Definition,
Access_To_Subprogram_Definition,
@@ -230,7 +229,6 @@ package Gen_IL.Fields is
Import_Interface_Present,
In_Present,
Includes_Infinities,
- Incomplete_View,
Inherited_Discriminant,
Instance_Spec,
Intval,
@@ -256,6 +254,7 @@ package Gen_IL.Fields is
Is_Elsif,
Is_Entry_Barrier_Function,
Is_Expanded_Build_In_Place_Call,
+ Is_Expanded_Constructor_Call,
Is_Expanded_Prefixed_Call,
Is_Folded_In_Parser,
Is_Generic_Contract_Pragma,
@@ -402,6 +401,7 @@ package Gen_IL.Fields is
Synchronized_Present,
Tagged_Present,
Target,
+ Call_Or_Target_Loop,
Target_Type,
Task_Definition,
Task_Present,
@@ -472,6 +472,9 @@ package Gen_IL.Fields is
Component_Clause,
Component_Size,
Component_Type,
+ Constructor_List,
+ Constructor_Name,
+ Continue_Mark,
Contract,
Contract_Wrapper,
Corresponding_Concurrent_Type,
@@ -487,12 +490,10 @@ package Gen_IL.Fields is
Debug_Renaming_Link,
Default_Aspect_Component_Value,
Default_Aspect_Value,
- Default_Expr_Function,
Default_Expressions_Processed,
Default_Value,
Delay_Cleanups,
Delta_Value,
- Dependent_Instances,
Depends_On_Private,
Derived_Type_Link,
Digits_Value,
@@ -553,7 +554,6 @@ package Gen_IL.Fields is
Full_View,
Generic_Homonym,
Generic_Renamings,
- Handler_Records,
Has_Aliased_Components,
Has_Alignment_Clause,
Has_All_Calls_Remote,
@@ -659,6 +659,7 @@ package Gen_IL.Fields is
Ignore_SPARK_Mode_Pragmas,
Import_Pragma,
Incomplete_Actuals,
+ Incomplete_View,
Indirect_Call_Wrapper,
In_Package_Body,
In_Private_Part,
@@ -744,6 +745,7 @@ package Gen_IL.Fields is
Is_Known_Non_Null,
Is_Known_Null,
Is_Known_Valid,
+ Is_Large_Unconstrained_Definite,
Is_Limited_Composite,
Is_Limited_Interface,
Is_Limited_Record,
@@ -822,7 +824,7 @@ package Gen_IL.Fields is
Modulus,
Must_Be_On_Byte_Boundary,
Must_Have_Preelab_Init,
- Needs_Activation_Record,
+ Needs_Construction,
Needs_Debug_Info,
Needs_No_Actuals,
Never_Set_In_Source,
@@ -870,7 +872,6 @@ package Gen_IL.Fields is
Referenced_As_LHS,
Referenced_As_Out_Parameter,
Refinement_Constituents,
- Register_Exception_Call,
Related_Array_Object,
Related_Expression,
Related_Instance,
@@ -892,7 +893,6 @@ package Gen_IL.Fields is
Scope_Depth_Value,
Sec_Stack_Needed_For_Return,
Shared_Var_Procs_Instance,
- Size_Check_Code,
Size_Depends_On_Discriminant,
Size_Known_At_Compile_Time,
Small_Value,
diff --git a/gcc/ada/gen_il-gen-gen_entities.adb b/gcc/ada/gen_il-gen-gen_entities.adb
index 37ddd85..8cbed8a 100644
--- a/gcc/ada/gen_il-gen-gen_entities.adb
+++ b/gcc/ada/gen_il-gen-gen_entities.adb
@@ -77,7 +77,6 @@ begin -- Gen_IL.Gen.Gen_Entities
Sm (Has_Delayed_Aspects, Flag),
Sm (Has_Delayed_Freeze, Flag),
Sm (Has_Delayed_Rep_Aspects, Flag),
- Sm (Has_Exit, Flag),
Sm (Has_Forward_Instantiation, Flag),
Sm (Has_Fully_Qualified_Name, Flag),
Sm (Has_Gigi_Rep_Item, Flag),
@@ -114,6 +113,7 @@ begin -- Gen_IL.Gen.Gen_Entities
Sm (Has_Xref_Entry, Flag),
Sm (Has_Yield_Aspect, Flag),
Sm (Homonym, Node_Id),
+ Sm (Incomplete_View, Node_Id),
Sm (In_Package_Body, Flag),
Sm (In_Private_Part, Flag),
Sm (In_Use, Flag),
@@ -212,10 +212,8 @@ begin -- Gen_IL.Gen.Gen_Entities
Sm (Low_Bound_Tested, Flag),
Sm (Materialize_Entity, Flag),
Sm (May_Inherit_Delayed_Rep_Aspects, Flag),
- Sm (Needs_Activation_Record, Flag),
Sm (Needs_Debug_Info, Flag),
Sm (Never_Set_In_Source, Flag),
- Sm (Overlays_Constant, Flag),
Sm (Prev_Entity, Node_Id),
Sm (Referenced, Flag),
Sm (Referenced_As_LHS, Flag),
@@ -288,7 +286,6 @@ begin -- Gen_IL.Gen.Gen_Entities
Sm (Extra_Formal, Node_Id),
Sm (Generic_Homonym, Node_Id),
Sm (Generic_Renamings, Elist_Id),
- Sm (Handler_Records, List_Id),
Sm (Has_Static_Discriminants, Flag),
Sm (Inner_Instances, Elist_Id),
Sm (Interface_Name, Node_Id),
@@ -354,10 +351,10 @@ begin -- Gen_IL.Gen.Gen_Entities
Sm (Last_Aggregate_Assignment, Node_Id),
Sm (Optimize_Alignment_Space, Flag),
Sm (Optimize_Alignment_Time, Flag),
+ Sm (Overlays_Constant, Flag),
Sm (Prival_Link, Node_Id),
Sm (Related_Type, Node_Id),
Sm (Return_Statement, Node_Id),
- Sm (Size_Check_Code, Node_Id),
Sm (SPARK_Pragma, Node_Id),
Sm (SPARK_Pragma_Inherited, Flag)));
@@ -399,7 +396,6 @@ begin -- Gen_IL.Gen.Gen_Entities
(Sm (Activation_Record_Component, Node_Id),
Sm (Actual_Subtype, Node_Id),
Sm (Alignment, Unat),
- Sm (Default_Expr_Function, Node_Id),
Sm (Default_Value, Node_Id),
Sm (Entry_Component, Node_Id),
Sm (Extra_Accessibility, Node_Id),
@@ -429,9 +425,8 @@ begin -- Gen_IL.Gen.Gen_Entities
Sm (Discriminant_Default_Value, Node_Id),
Sm (Is_Activation_Record, Flag)));
- Ab (Formal_Object_Kind, Object_Kind,
- -- Generic formal objects are also objects
- (Sm (Entry_Component, Node_Id)));
+ Ab (Formal_Object_Kind, Object_Kind);
+ -- Generic formal objects are also objects
Cc (E_Generic_In_Out_Parameter, Formal_Object_Kind,
-- A generic in out parameter, created by the use of a generic in out
@@ -458,6 +453,8 @@ begin -- Gen_IL.Gen.Gen_Entities
Pre => "Ekind (Base_Type (N)) in Access_Subprogram_Kind"),
Sm (Class_Wide_Equivalent_Type, Node_Id),
Sm (Class_Wide_Type, Node_Id),
+ Sm (Constructor_List, Elist_Id),
+ Sm (Constructor_Name, Node_Id),
Sm (Contract, Node_Id),
Sm (Current_Use_Clause, Node_Id),
Sm (Derived_Type_Link, Node_Id),
@@ -516,6 +513,7 @@ begin -- Gen_IL.Gen.Gen_Entities
Sm (Linker_Section_Pragma, Node_Id),
Sm (Must_Be_On_Byte_Boundary, Flag),
Sm (Must_Have_Preelab_Init, Flag),
+ Sm (Needs_Construction, Flag),
Sm (No_Tagged_Streams_Pragma, Node_Id,
Pre => "Is_Tagged_Type (N)"),
Sm (Non_Binary_Modulus, Flag, Base_Type_Only),
@@ -576,7 +574,7 @@ begin -- Gen_IL.Gen.Gen_Entities
-- created for the base type, and this is the first named subtype).
Ab (Modular_Integer_Kind, Integer_Kind,
- (Sm (Modulus, Uint, Base_Type_Only),
+ (Sm (Modulus, Uint, Impl_Base_Type_Only),
Sm (Original_Array_Type, Node_Id)));
Cc (E_Modular_Integer_Type, Modular_Integer_Kind);
@@ -781,7 +779,8 @@ begin -- Gen_IL.Gen.Gen_Entities
Sm (No_Reordering, Flag, Impl_Base_Type_Only),
Sm (Parent_Subtype, Node_Id, Base_Type_Only),
Sm (Reverse_Bit_Order, Flag, Base_Type_Only),
- Sm (Underlying_Record_View, Node_Id)));
+ Sm (Underlying_Record_View, Node_Id),
+ Sm (Is_Large_Unconstrained_Definite, Flag, Impl_Base_Type_Only)));
Cc (E_Record_Subtype, Aggregate_Kind,
-- A record subtype, created by a record subtype declaration
@@ -1004,7 +1003,6 @@ begin -- Gen_IL.Gen.Gen_Entities
Sm (DTC_Entity, Node_Id),
Sm (Extra_Accessibility_Of_Result, Node_Id),
Sm (Generic_Renamings, Elist_Id),
- Sm (Handler_Records, List_Id),
Sm (Has_Missing_Return, Flag),
Sm (Inner_Instances, Elist_Id),
Sm (Is_Called, Flag),
@@ -1048,7 +1046,6 @@ begin -- Gen_IL.Gen.Gen_Entities
Sm (DTC_Entity, Node_Id),
Sm (Entry_Parameters_Type, Node_Id),
Sm (Generic_Renamings, Elist_Id),
- Sm (Handler_Records, List_Id),
Sm (Inner_Instances, Elist_Id),
Sm (Is_Asynchronous, Flag),
Sm (Is_Called, Flag),
@@ -1167,7 +1164,6 @@ begin -- Gen_IL.Gen.Gen_Entities
(Sm (Alignment, Unat),
Sm (Interface_Name, Node_Id),
Sm (Is_Raised, Flag),
- Sm (Register_Exception_Call, Node_Id),
Sm (Renamed_Or_Alias, Node_Id)));
Ab (Generic_Unit_Kind, Entity_Kind,
@@ -1227,8 +1223,10 @@ begin -- Gen_IL.Gen.Gen_Entities
Cc (E_Loop, Entity_Kind,
-- A loop identifier, created by an explicit or implicit label on a
-- loop statement.
- (Sm (First_Entity, Node_Id),
+ (Sm (Continue_Mark, Node_Id),
+ Sm (First_Entity, Node_Id),
Sm (First_Exit_Statement, Node_Id),
+ Sm (Has_Exit, Flag),
Sm (Has_Loop_Entry_Attributes, Flag),
Sm (Last_Entity, Node_Id),
Sm (Renamed_Or_Alias, Node_Id),
@@ -1256,8 +1254,6 @@ begin -- Gen_IL.Gen.Gen_Entities
Sm (Body_Needed_For_SAL, Flag),
Sm (Contract, Node_Id),
Sm (Current_Use_Clause, Node_Id),
- Sm (Dependent_Instances, Elist_Id,
- Pre => "Is_Generic_Instance (N)"),
Sm (Elaborate_Body_Desirable, Flag),
Sm (Elaboration_Entity, Node_Id),
Sm (Elaboration_Entity_Required, Flag),
@@ -1265,7 +1261,6 @@ begin -- Gen_IL.Gen.Gen_Entities
Sm (First_Entity, Node_Id),
Sm (First_Private_Entity, Node_Id),
Sm (Generic_Renamings, Elist_Id),
- Sm (Handler_Records, List_Id),
Sm (Has_RACW, Flag),
Sm (Hidden_In_Formal_Instance, Elist_Id),
Sm (Ignore_SPARK_Mode_Pragmas, Flag),
@@ -1297,7 +1292,6 @@ begin -- Gen_IL.Gen.Gen_Entities
(Sm (Contract, Node_Id),
Sm (Finalizer, Node_Id),
Sm (First_Entity, Node_Id),
- Sm (Handler_Records, List_Id),
Sm (Ignore_SPARK_Mode_Pragmas, Flag),
Sm (Last_Entity, Node_Id),
Sm (Related_Instance, Node_Id),
diff --git a/gcc/ada/gen_il-gen-gen_nodes.adb b/gcc/ada/gen_il-gen-gen_nodes.adb
index eb03536..debc66b 100644
--- a/gcc/ada/gen_il-gen-gen_nodes.adb
+++ b/gcc/ada/gen_il-gen-gen_nodes.adb
@@ -303,6 +303,7 @@ begin -- Gen_IL.Gen.Gen_Nodes
Sm (Is_Known_Guaranteed_ABE, Flag),
Sm (Is_SPARK_Mode_On_Node, Flag),
Sm (No_Elaboration_Check, Flag),
+ Sm (Is_Expanded_Constructor_Call, Flag),
Sm (Is_Expanded_Prefixed_Call, Flag)));
Cc (N_Function_Call, N_Subprogram_Call,
@@ -533,8 +534,7 @@ begin -- Gen_IL.Gen.Gen_Nodes
Sy (Discriminant_Specifications, List_Id, Default_No_List),
Sy (Type_Definition, Node_Id),
Sy (Aspect_Specifications, List_Id, Default_No_List),
- Sm (Discr_Check_Funcs_Built, Flag),
- Sm (Incomplete_View, Node_Id)));
+ Sm (Discr_Check_Funcs_Built, Flag)));
Cc (N_Incomplete_Type_Declaration, N_Declaration,
(Sy (Defining_Identifier, Node_Id),
@@ -967,6 +967,16 @@ begin -- Gen_IL.Gen.Gen_Nodes
Sy (Is_Null_Loop, Flag),
Sy (Suppress_Loop_Warnings, Flag)));
+ Ab (N_Loop_Flow_Statement, N_Statement_Other_Than_Procedure_Call,
+ (Sy (Name, Node_Id, Default_Empty),
+ Sy (Condition, Node_Id, Default_Empty)));
+
+ Cc (N_Continue_Statement, N_Loop_Flow_Statement,
+ (Sm (Call_Or_Target_Loop, Node_Id)));
+
+ Cc (N_Exit_Statement, N_Loop_Flow_Statement,
+ (Sm (Next_Exit_Statement, Node_Id)));
+
Cc (N_Null_Statement, N_Statement_Other_Than_Procedure_Call,
(Sm (Next_Rep_Item, Node_Id)));
@@ -1012,11 +1022,6 @@ begin -- Gen_IL.Gen.Gen_Nodes
(Sy (Entry_Call_Alternative, Node_Id),
Sy (Delay_Alternative, Node_Id)));
- Cc (N_Exit_Statement, N_Statement_Other_Than_Procedure_Call,
- (Sy (Name, Node_Id, Default_Empty),
- Sy (Condition, Node_Id, Default_Empty),
- Sm (Next_Exit_Statement, Node_Id)));
-
Cc (N_If_Statement, N_Statement_Other_Than_Procedure_Call,
(Sy (Condition, Node_Id, Default_Empty),
Sy (Then_Statements, List_Id),
@@ -1030,8 +1035,7 @@ begin -- Gen_IL.Gen.Gen_Nodes
(Sy (Accept_Statement, Node_Id),
Sy (Condition, Node_Id, Default_Empty),
Sy (Statements, List_Id, Default_Empty_List),
- Sy (Pragmas_Before, List_Id, Default_No_List),
- Sm (Accept_Handler_Records, List_Id)));
+ Sy (Pragmas_Before, List_Id, Default_No_List)));
Cc (N_Delay_Alternative, Node_Kind,
(Sy (Delay_Statement, Node_Id),
diff --git a/gcc/ada/gen_il-types.ads b/gcc/ada/gen_il-types.ads
index 6e0ab5b..c3a9755 100644
--- a/gcc/ada/gen_il-types.ads
+++ b/gcc/ada/gen_il-types.ads
@@ -103,6 +103,7 @@ package Gen_IL.Types is
N_Is_Range,
N_Multiplying_Operator,
N_Later_Decl_Item,
+ N_Loop_Flow_Statement,
N_Membership_Test,
N_Numeric_Or_String_Literal,
N_Op,
@@ -328,6 +329,7 @@ package Gen_IL.Types is
N_Code_Statement,
N_Compound_Statement,
N_Conditional_Entry_Call,
+ N_Continue_Statement,
N_Delay_Relative_Statement,
N_Delay_Until_Statement,
N_Entry_Call_Statement,
diff --git a/gcc/ada/generate_minimal_reproducer.adb b/gcc/ada/generate_minimal_reproducer.adb
index 66d34fe..5a5ae16 100644
--- a/gcc/ada/generate_minimal_reproducer.adb
+++ b/gcc/ada/generate_minimal_reproducer.adb
@@ -23,16 +23,18 @@
-- --
------------------------------------------------------------------------------
+with Atree;
with Fmap;
with Fname.UF;
with Lib;
-with Namet; use Namet;
-with Osint; use Osint;
-with Output; use Output;
-with Sinfo.Nodes;
+with Namet; use Namet;
+with Osint; use Osint;
+with Output; use Output;
+with Sinfo.Nodes; use Sinfo.Nodes;
with System.CRTL;
with System.OS_Lib; use System.OS_Lib;
-with Types; use Types;
+with Types; use Types;
+with Uname;
procedure Generate_Minimal_Reproducer is
Reproducer_Generation_Failed : exception;
@@ -85,6 +87,26 @@ procedure Generate_Minimal_Reproducer is
Oracle_Path : constant String :=
Dirname & Directory_Separator & Executable_Name ("oracle");
+ Main_Library_Item : constant Node_Id := Unit (Lib.Cunit (Main_Unit));
+
+ -- There is a special case that we need to detect: when the main library
+ -- item is the instantiation of a generic that has a body, and the
+ -- instantiation of generic bodies has started. We start by binding whether
+ -- the main library item is an instantiation to the following constant.
+ Main_Is_Instantiation : constant Boolean :=
+ Nkind (Atree.Original_Node (Main_Library_Item))
+ in N_Generic_Instantiation;
+
+ -- If the main library item is an instantiation and its unit name is a body
+ -- name, it means that Make_Instance_Unit has been called. We need to use
+ -- the corresponding spec name to reconstruct the on-disk form of the
+ -- semantic closure.
+ Main_Unit_Name : constant Unit_Name_Type :=
+ (if Main_Is_Instantiation
+ and then Uname.Is_Body_Name (Lib.Unit_Name (Main_Unit))
+ then Uname.Get_Spec_Name (Lib.Unit_Name (Main_Unit))
+ else Lib.Unit_Name (Main_Unit));
+
Result : Integer;
begin
Create_Semantic_Closure_Project :
@@ -118,25 +140,30 @@ begin
end if;
for J in Main_Unit .. Lib.Last_Unit loop
- declare
- Path : File_Name_Type :=
- Fmap.Mapped_Path_Name (Lib.Unit_File_Name (J));
-
- Default_File_Name : constant String :=
- Fname.UF.Get_Default_File_Name (Lib.Unit_Name (J));
-
- File_Copy_Path : constant String :=
- Src_Dir_Path & Directory_Separator & Default_File_Name;
-
- -- We may have synthesized units for child subprograms without
- -- spec files. We need to filter out those units because we would
- -- create bogus spec files that break compilation if we didn't.
- Is_Synthetic_Subprogram_Spec : constant Boolean :=
- not Sinfo.Nodes.Comes_From_Source (Lib.Cunit (J));
- begin
- if not Lib.Is_Internal_Unit (J)
- and then not Is_Synthetic_Subprogram_Spec
- then
+ -- We skip library units that fall under one of the following cases:
+ -- - Internal library units.
+ -- - Units that were synthesized for child subprograms without spec
+ -- files.
+ -- - Dummy entries that Add_Preprocessing_Dependency puts in
+ -- Lib.Units.
+ -- Those cases correspond to the conjuncts in the condition below.
+ if not Lib.Is_Internal_Unit (J)
+ and then Comes_From_Source (Lib.Cunit (J))
+ and then Lib.Unit_Name (J) /= No_Unit_Name
+ then
+ declare
+ Path : File_Name_Type :=
+ Fmap.Mapped_Path_Name (Lib.Unit_File_Name (J));
+
+ Unit_Name : constant Unit_Name_Type :=
+ (if J = Main_Unit then Main_Unit_Name else Lib.Unit_Name (J));
+
+ Default_File_Name : constant String :=
+ Fname.UF.Get_Default_File_Name (Unit_Name);
+
+ File_Copy_Path : constant String :=
+ Src_Dir_Path & Directory_Separator & Default_File_Name;
+ begin
-- Mapped_Path_Name might have returned No_File. This has been
-- observed for files with a Source_File_Name pragma.
if Path = No_File then
@@ -153,8 +180,8 @@ begin
pragma Assert (Success);
end;
- end if;
- end;
+ end;
+ end if;
end loop;
end Create_Semantic_Closure_Project;
@@ -197,7 +224,7 @@ begin
(Fmap.Mapped_Path_Name (Lib.Unit_File_Name (Main_Unit)));
Default_Main_Name : constant String :=
- Fname.UF.Get_Default_File_Name (Lib.Unit_Name (Main_Unit));
+ Fname.UF.Get_Default_File_Name (Main_Unit_Name);
New_Main_Path : constant String :=
Src_Dir_Path & Directory_Separator & Default_Main_Name;
@@ -228,7 +255,8 @@ begin
Write_Eol;
Write_Line (" Args : constant GNAT.OS_Lib.Argument_List :=");
- Write_Str (" (new String'(""-gnatd_M"")");
+ Write_Str
+ (" (new String'(""-quiet""), new String'(""-gnatd_M"")");
-- The following way of iterating through the command line arguments
-- was copied from Set_Targ. TODO factorize???
diff --git a/gcc/ada/get_targ.ads b/gcc/ada/get_targ.ads
index 35cf00d..4b658f1 100644
--- a/gcc/ada/get_targ.ads
+++ b/gcc/ada/get_targ.ads
@@ -113,7 +113,7 @@ package Get_Targ is
type C_String is array (0 .. 255) of aliased Character;
pragma Convention (C, C_String);
- type Register_Type_Proc is access procedure
+ type Register_Type_Proc is not null access procedure
(C_Name : C_String; -- Nul-terminated string with name of type
Digs : Natural; -- Digits for floating point, 0 otherwise
Complex : Boolean; -- True iff type has real and imaginary parts
diff --git a/gcc/ada/ghost.adb b/gcc/ada/ghost.adb
index 314a13d..6f648f2 100644
--- a/gcc/ada/ghost.adb
+++ b/gcc/ada/ghost.adb
@@ -67,17 +67,6 @@ package body Ghost is
-- Local subprograms --
-----------------------
- function Whole_Object_Ref (Ref : Node_Id) return Node_Id;
- -- For a name that denotes an object, returns a name that denotes the whole
- -- object, declared by an object declaration, formal parameter declaration,
- -- etc. For example, for P.X.Comp (J), if P is a package X is a record
- -- object, this returns P.X.
-
- function Ghost_Entity (Ref : Node_Id) return Entity_Id;
- pragma Inline (Ghost_Entity);
- -- Obtain the entity of a Ghost entity from reference Ref. Return Empty if
- -- no such entity exists.
-
procedure Install_Ghost_Mode (Mode : Ghost_Mode_Type);
pragma Inline (Install_Ghost_Mode);
-- Install Ghost mode Mode as the Ghost mode in effect
@@ -787,7 +776,7 @@ package body Ghost is
Formal : Entity_Id;
Is_Default : Boolean := False)
is
- Actual_Obj : constant Entity_Id := Get_Enclosing_Deep_Object (Actual);
+ Actual_Obj : constant Entity_Id := Get_Enclosing_Ghost_Entity (Actual);
begin
if not Is_Ghost_Entity (Formal) then
return;
@@ -1085,27 +1074,6 @@ package body Ghost is
end if;
end Check_Ghost_Type;
- ------------------
- -- Ghost_Entity --
- ------------------
-
- function Ghost_Entity (Ref : Node_Id) return Entity_Id is
- Obj_Ref : constant Node_Id := Ultimate_Prefix (Ref);
-
- begin
- -- When the reference denotes a subcomponent, recover the related whole
- -- object (SPARK RM 6.9(1)).
-
- if Is_Entity_Name (Obj_Ref) then
- return Entity (Obj_Ref);
-
- -- Otherwise the reference cannot possibly denote a Ghost entity
-
- else
- return Empty;
- end if;
- end Ghost_Entity;
-
--------------------------------
-- Implements_Ghost_Interface --
--------------------------------
@@ -1197,7 +1165,7 @@ package body Ghost is
-- entity.
if Nkind (N) = N_Assignment_Statement then
- Id := Ghost_Entity (Name (N));
+ Id := Get_Enclosing_Ghost_Entity (Name (N));
return Present (Id) and then Is_Ghost_Entity (Id);
end if;
@@ -1255,7 +1223,7 @@ package body Ghost is
-- A procedure call is Ghost when it invokes a Ghost procedure
if Nkind (N) = N_Procedure_Call_Statement then
- Id := Ghost_Entity (Name (N));
+ Id := Get_Enclosing_Ghost_Entity (Name (N));
return Present (Id) and then Is_Ghost_Entity (Id);
end if;
@@ -1492,29 +1460,23 @@ package body Ghost is
end if;
declare
- Whole : constant Node_Id := Whole_Object_Ref (Lhs);
- Id : Entity_Id;
+ Id : constant Entity_Id := Get_Enclosing_Ghost_Entity (Lhs);
begin
- if Is_Entity_Name (Whole) then
- Id := Entity (Whole);
-
- if Present (Id) then
- -- Left-hand side denotes a Checked ghost entity, so
- -- install the region.
+ if Present (Id) then
+ -- Left-hand side denotes a Checked ghost entity, so install
+ -- the region.
- if Is_Checked_Ghost_Entity (Id) then
- Install_Ghost_Region (Check, N);
+ if Is_Checked_Ghost_Entity (Id) then
+ Install_Ghost_Region (Check, N);
- -- Left-hand side denotes an Ignored ghost entity, so
- -- install the region, and mark the assignment statement
- -- as an ignored ghost assignment, so it will be removed
- -- later.
+ -- Left-hand side denotes an Ignored ghost entity, so
+ -- install the region, and mark the assignment statement as
+ -- an ignored ghost assignment, so it will be removed later.
- elsif Is_Ignored_Ghost_Entity (Id) then
- Install_Ghost_Region (Ignore, N);
- Set_Is_Ignored_Ghost_Node (N);
- Record_Ignored_Ghost_Node (N);
- end if;
+ elsif Is_Ignored_Ghost_Entity (Id) then
+ Install_Ghost_Region (Ignore, N);
+ Set_Is_Ignored_Ghost_Node (N);
+ Record_Ignored_Ghost_Node (N);
end if;
end if;
end;
@@ -1782,7 +1744,7 @@ package body Ghost is
-- A procedure call becomes Ghost when the procedure being invoked is
-- Ghost. Install the Ghost mode of the procedure.
- Id := Ghost_Entity (Name (N));
+ Id := Get_Enclosing_Ghost_Entity (Name (N));
if Present (Id) then
if Is_Checked_Ghost_Entity (Id) then
@@ -2096,7 +2058,7 @@ package body Ghost is
-- of the target.
if Nkind (N) = N_Assignment_Statement then
- Id := Ghost_Entity (Name (N));
+ Id := Get_Enclosing_Ghost_Entity (Name (N));
if Present (Id) then
Set_Ghost_Mode_From_Entity (Id);
@@ -2135,7 +2097,7 @@ package body Ghost is
-- procedure being invoked.
elsif Nkind (N) = N_Procedure_Call_Statement then
- Id := Ghost_Entity (Name (N));
+ Id := Get_Enclosing_Ghost_Entity (Name (N));
if Present (Id) then
Set_Ghost_Mode_From_Entity (Id);
@@ -2157,24 +2119,4 @@ package body Ghost is
end if;
end Set_Is_Ghost_Entity;
- ----------------------
- -- Whole_Object_Ref --
- ----------------------
-
- function Whole_Object_Ref (Ref : Node_Id) return Node_Id is
- begin
- if Nkind (Ref) in N_Indexed_Component | N_Slice
- or else (Nkind (Ref) = N_Selected_Component
- and then Is_Object_Reference (Prefix (Ref)))
- then
- if Is_Access_Type (Etype (Prefix (Ref))) then
- return Ref;
- else
- return Whole_Object_Ref (Prefix (Ref));
- end if;
- else
- return Ref;
- end if;
- end Whole_Object_Ref;
-
end Ghost;
diff --git a/gcc/ada/gnat-style.texi b/gcc/ada/gnat-style.texi
index dde6ec4..0880400 100644
--- a/gcc/ada/gnat-style.texi
+++ b/gcc/ada/gnat-style.texi
@@ -3,7 +3,7 @@
@setfilename gnat-style.info
@documentencoding UTF-8
@ifinfo
-@*Generated by Sphinx 8.0.2.@*
+@*Generated by Sphinx 8.2.3.@*
@end ifinfo
@settitle GNAT Coding Style A Guide for GNAT Developers
@defindex ge
@@ -19,7 +19,7 @@
@copying
@quotation
-GNAT Coding Style: A Guide for GNAT Developers , Jan 03, 2025
+GNAT Coding Style: A Guide for GNAT Developers , Jun 02, 2025
AdaCore
diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb
index 46f04e4..52063c8 100644
--- a/gcc/ada/gnat1drv.adb
+++ b/gcc/ada/gnat1drv.adb
@@ -982,7 +982,7 @@ procedure Gnat1drv is
-- Local variables
Back_End_Mode : Back_End.Back_End_Mode_Type;
- Ecode : Exit_Code_Type;
+ Ecode : Exit_Code_Type := E_Success;
Main_Unit_Kind : Node_Kind;
-- Kind of main compilation unit node
@@ -1169,9 +1169,10 @@ begin
-- Exit with errors if the main source could not be parsed
if Sinput.Main_Source_File <= No_Source_File then
+ Ecode := E_Errors;
Errout.Finalize (Last_Call => True);
- Errout.Output_Messages;
- Exit_Program (E_Errors);
+ Errout.Output_Messages (Ecode);
+ Exit_Program (Ecode);
end if;
Main_Unit_Node := Cunit (Main_Unit);
@@ -1198,9 +1199,10 @@ begin
Errout.Finalize (Last_Call => False);
if Compilation_Errors then
+ Ecode := E_Errors;
Treepr.Tree_Dump;
Errout.Finalize (Last_Call => True);
- Errout.Output_Messages;
+ Errout.Output_Messages (Ecode);
Namet.Finalize;
-- Generate ALI file if specially requested
@@ -1209,7 +1211,7 @@ begin
Write_ALI (Object => False);
end if;
- Exit_Program (E_Errors);
+ Exit_Program (Ecode);
end if;
-- Case of no code required to be generated, exit indicating no error
@@ -1217,7 +1219,7 @@ begin
if Original_Operating_Mode = Check_Syntax then
Treepr.Tree_Dump;
Errout.Finalize (Last_Call => True);
- Errout.Output_Messages;
+ Errout.Output_Messages (Ecode);
Namet.Finalize;
Check_Rep_Info;
@@ -1350,7 +1352,15 @@ begin
-- Exit the gnat driver with success, otherwise external builders
-- such as gnatmake and gprbuild will treat the compilation of an
-- ignored Ghost unit as a failure. Be sure we produce an empty
- -- object file for the unit.
+ -- object file for the unit, while indicating for the ALI file
+ -- generation that neither spec or body has elaboration code
+ -- (which in ordinary compilation is indicated in Gigi).
+
+ Set_Has_No_Elaboration_Code (Main_Unit_Node);
+
+ if Present (Library_Unit (Main_Unit_Node)) then
+ Set_Has_No_Elaboration_Code (Library_Unit (Main_Unit_Node));
+ end if;
Ecode := E_Success;
Back_End.Gen_Or_Update_Object_File;
@@ -1407,7 +1417,7 @@ begin
Post_Compilation_Validation_Checks;
Errout.Finalize (Last_Call => True);
- Errout.Output_Messages;
+ Errout.Output_Messages (Ecode);
Treepr.Tree_Dump;
-- Generate ALI file if specially requested, or for missing subunits,
@@ -1461,7 +1471,7 @@ begin
then
Post_Compilation_Validation_Checks;
Errout.Finalize (Last_Call => True);
- Errout.Output_Messages;
+ Errout.Output_Messages (Ecode);
Write_ALI (Object => False);
Tree_Dump;
Namet.Finalize;
@@ -1541,7 +1551,8 @@ begin
-- representation information for List_Rep_Info).
Errout.Finalize (Last_Call => True);
- Errout.Output_Messages;
+ Errout.Output_Messages
+ ((if Compilation_Errors then E_Errors else E_Success));
-- Back annotation of representation info is not done in CodePeer and
-- SPARK modes.
@@ -1557,8 +1568,9 @@ begin
-- there will be no attempt to generate an object file.
if Compilation_Errors then
+ Ecode := E_Errors;
Treepr.Tree_Dump;
- Exit_Program (E_Errors);
+ Exit_Program (Ecode);
end if;
if not GNATprove_Mode then
@@ -1632,7 +1644,7 @@ begin
exception
when Unrecoverable_Error =>
Errout.Finalize (Last_Call => True);
- Errout.Output_Messages;
+ Errout.Output_Messages (E_Errors);
Set_Standard_Error;
Write_Str ("compilation abandoned");
diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi
index 97469d7..f45ea7c 100644
--- a/gcc/ada/gnat_rm.texi
+++ b/gcc/ada/gnat_rm.texi
@@ -3,7 +3,7 @@
@setfilename gnat_rm.info
@documentencoding UTF-8
@ifinfo
-@*Generated by Sphinx 8.0.2.@*
+@*Generated by Sphinx 8.2.3.@*
@end ifinfo
@settitle GNAT Reference Manual
@defindex ge
@@ -19,7 +19,7 @@
@copying
@quotation
-GNAT Reference Manual , Jan 03, 2025
+GNAT Reference Manual , Jun 27, 2025
AdaCore
@@ -76,7 +76,7 @@ included in the section entitled @ref{1,,GNU Free Documentation License}.
* Interfacing to Other Languages::
* Specialized Needs Annexes::
* Implementation of Specific Ada Features::
-* Implementation of Ada 2012 Features::
+* Implementation of Ada 2022 Features::
* GNAT language extensions::
* Security Hardening Features::
* Obsolescent Features::
@@ -238,6 +238,7 @@ Implementation Defined Pragmas
* Pragma Priority_Specific_Dispatching::
* Pragma Profile::
* Pragma Profile_Warnings::
+* Pragma Program_Exit::
* Pragma Propagate_Exceptions::
* Pragma Provide_Shift_Operators::
* Pragma Psect_Object::
@@ -348,6 +349,7 @@ Implementation Defined Aspects
* Aspect Part_Of::
* Aspect Persistent_BSS::
* Aspect Predicate::
+* Aspect Program_Exit::
* Aspect Pure_Function::
* Aspect Refined_Depends::
* Aspect Refined_Global::
@@ -916,6 +918,7 @@ Deep delta Aggregates
Experimental Language Extensions
* Conditional when constructs::
+* Implicit With::
* Storage Model::
* Attribute Super::
* Simpler Accessibility Model::
@@ -926,6 +929,7 @@ Experimental Language Extensions
* Inference of Dependent Types in Generic Instantiations::
* External_Initialization Aspect::
* Finally construct::
+* Continue statement::
Storage Model
@@ -939,10 +943,9 @@ Simpler Accessibility Model
* Subprogram parameters::
* Function results::
-No_Raise aspect
+Generalized Finalization
-* New specification for Ada.Finalization.Controlled: New specification for Ada Finalization Controlled.
-* Finalized tagged types::
+* Finalizable tagged types::
* Composite types::
* Interoperability with controlled types::
@@ -1007,7 +1010,7 @@ GNAT compiler. It includes information on implementation dependent
characteristics of GNAT, including all the information required by
Annex M of the Ada language standard.
-GNAT implements Ada 95, Ada 2005 and Ada 2012, and it may also be
+GNAT implements Ada 95, Ada 2005, Ada 2012 and Ada 2022, and it may also be
invoked in Ada 83 compatibility mode.
By default, GNAT assumes Ada 2012,
but you can override with a compiler switch
@@ -1112,8 +1115,8 @@ to GNAT’s implementation of machine code insertions, tasking, and several
other features.
@item
-@ref{14,,Implementation of Ada 2012 Features}, describes the status of the
-GNAT implementation of the Ada 2012 language standard.
+@ref{14,,Implementation of Ada 2022 Features}, describes the status of the
+GNAT implementation of the Ada 2022 language standard.
@item
@ref{15,,Security Hardening Features} documents GNAT extensions aimed
@@ -1405,6 +1408,7 @@ consideration, the use of these pragmas should be minimized.
* Pragma Priority_Specific_Dispatching::
* Pragma Profile::
* Pragma Profile_Warnings::
+* Pragma Program_Exit::
* Pragma Propagate_Exceptions::
* Pragma Provide_Shift_Operators::
* Pragma Psect_Object::
@@ -1577,6 +1581,11 @@ and generics may name types with unknown discriminants without using
the @code{(<>)} notation. In addition, some but not all of the additional
restrictions of Ada 83 are enforced.
+Like all configuration pragmas, if the pragma is placed before a library
+level package specification it is not propagated to the corresponding
+package body (see RM 10.1.5(8)); it must be added explicitly to the
+package body.
+
Ada 83 mode is intended for two purposes. Firstly, it allows existing
Ada 83 code to be compiled and adapted to GNAT with less effort.
Secondly, it aids in keeping code backwards compatible with Ada 83.
@@ -1604,6 +1613,11 @@ contexts. This pragma is useful when writing a reusable component that
itself uses Ada 95 features, but which is intended to be usable from
either Ada 83 or Ada 95 programs.
+Like all configuration pragmas, if the pragma is placed before a library
+level package specification it is not propagated to the corresponding
+package body (see RM 10.1.5(8)); it must be added explicitly to the
+package body.
+
@node Pragma Ada_05,Pragma Ada_2005,Pragma Ada_95,Implementation Defined Pragmas
@anchor{gnat_rm/implementation_defined_pragmas pragma-ada-05}@anchor{21}
@section Pragma Ada_05
@@ -1622,6 +1636,11 @@ This pragma is useful when writing a reusable component that
itself uses Ada 2005 features, but which is intended to be usable from
either Ada 83 or Ada 95 programs.
+Like all configuration pragmas, if the pragma is placed before a library
+level package specification it is not propagated to the corresponding
+package body (see RM 10.1.5(8)); it must be added explicitly to the
+package body.
+
The one argument form (which is not a configuration pragma)
is used for managing the transition from
Ada 95 to Ada 2005 in the run-time library. If an entity is marked
@@ -1667,6 +1686,11 @@ contexts. This pragma is useful when writing a reusable component that
itself uses Ada 2012 features, but which is intended to be usable from
Ada 83, Ada 95, or Ada 2005 programs.
+Like all configuration pragmas, if the pragma is placed before a library
+level package specification it is not propagated to the corresponding
+package body (see RM 10.1.5(8)); it must be added explicitly to the
+package body.
+
The one argument form, which is not a configuration pragma,
is used for managing the transition from Ada
2005 to Ada 2012 in the run-time library. If an entity is marked
@@ -1712,6 +1736,11 @@ contexts. This pragma is useful when writing a reusable component that
itself uses Ada 2022 features, but which is intended to be usable from
Ada 83, Ada 95, Ada 2005 or Ada 2012 programs.
+Like all configuration pragmas, if the pragma is placed before a library
+level package specification it is not propagated to the corresponding
+package body (see RM 10.1.5(8)); it must be added explicitly to the
+package body.
+
The one argument form, which is not a configuration pragma,
is used for managing the transition from Ada
2012 to Ada 2022 in the run-time library. If an entity is marked
@@ -3470,6 +3499,7 @@ EXIT_CASE ::= GUARD => EXIT_KIND
EXIT_KIND ::= Normal_Return
| Exception_Raised
| (Exception_Raised => exception_name)
+ | Program_Exit
GUARD ::= Boolean_expression
@end example
@@ -4682,8 +4712,8 @@ pragma Interrupt_State
Normally certain interrupts are reserved to the implementation. Any attempt
to attach an interrupt causes Program_Error to be raised, as described in
RM C.3.2(22). A typical example is the @code{SIGINT} interrupt used in
-many systems for an @code{Ctrl-C} interrupt. Normally this interrupt is
-reserved to the implementation, so that @code{Ctrl-C} can be used to
+many systems for an @code{Ctrl}-@code{C} interrupt. Normally this interrupt is
+reserved to the implementation, so that @code{Ctrl}-@code{C} can be used to
interrupt execution. Additionally, signals such as @code{SIGSEGV},
@code{SIGABRT}, @code{SIGFPE} and @code{SIGILL} are often mapped to specific
Ada exceptions, or used to implement run-time functions such as the
@@ -6912,7 +6942,7 @@ conforming Ada constructs. The profile enables the following three pragmas:
@end itemize
@end itemize
-@node Pragma Profile_Warnings,Pragma Propagate_Exceptions,Pragma Profile,Implementation Defined Pragmas
+@node Pragma Profile_Warnings,Pragma Program_Exit,Pragma Profile,Implementation Defined Pragmas
@anchor{gnat_rm/implementation_defined_pragmas pragma-profile-warnings}@anchor{ce}
@section Pragma Profile_Warnings
@@ -6930,8 +6960,22 @@ generating @code{Restrictions} pragmas, it generates
violations of the profile generate warning messages instead
of error messages.
-@node Pragma Propagate_Exceptions,Pragma Provide_Shift_Operators,Pragma Profile_Warnings,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-propagate-exceptions}@anchor{cf}
+@node Pragma Program_Exit,Pragma Propagate_Exceptions,Pragma Profile_Warnings,Implementation Defined Pragmas
+@anchor{gnat_rm/implementation_defined_pragmas id34}@anchor{cf}@anchor{gnat_rm/implementation_defined_pragmas pragma-program-exit}@anchor{d0}
+@section Pragma Program_Exit
+
+
+Syntax:
+
+@example
+pragma Program_Exit [ (boolean_EXPRESSION) ];
+@end example
+
+For the semantics of this pragma, see the entry for aspect @code{Program_Exit}
+in the SPARK 2014 Reference Manual, section 6.1.10.
+
+@node Pragma Propagate_Exceptions,Pragma Provide_Shift_Operators,Pragma Program_Exit,Implementation Defined Pragmas
+@anchor{gnat_rm/implementation_defined_pragmas pragma-propagate-exceptions}@anchor{d1}
@section Pragma Propagate_Exceptions
@@ -6950,7 +6994,7 @@ purposes. It used to be used in connection with optimization of
a now-obsolete mechanism for implementation of exceptions.
@node Pragma Provide_Shift_Operators,Pragma Psect_Object,Pragma Propagate_Exceptions,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-provide-shift-operators}@anchor{d0}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-provide-shift-operators}@anchor{d2}
@section Pragma Provide_Shift_Operators
@@ -6970,7 +7014,7 @@ including the function declarations for these five operators, together
with the pragma Import (Intrinsic, …) statements.
@node Pragma Psect_Object,Pragma Pure_Function,Pragma Provide_Shift_Operators,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-psect-object}@anchor{d1}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-psect-object}@anchor{d3}
@section Pragma Psect_Object
@@ -6990,7 +7034,7 @@ EXTERNAL_SYMBOL ::=
This pragma is identical in effect to pragma @code{Common_Object}.
@node Pragma Pure_Function,Pragma Rational,Pragma Psect_Object,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas id34}@anchor{d2}@anchor{gnat_rm/implementation_defined_pragmas pragma-pure-function}@anchor{d3}
+@anchor{gnat_rm/implementation_defined_pragmas id35}@anchor{d4}@anchor{gnat_rm/implementation_defined_pragmas pragma-pure-function}@anchor{d5}
@section Pragma Pure_Function
@@ -7052,7 +7096,7 @@ unit is not a Pure unit in the categorization sense. So for example, a function
thus marked is free to @code{with} non-pure units.
@node Pragma Rational,Pragma Ravenscar,Pragma Pure_Function,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-rational}@anchor{d4}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-rational}@anchor{d6}
@section Pragma Rational
@@ -7070,7 +7114,7 @@ pragma Profile (Rational);
@end example
@node Pragma Ravenscar,Pragma Refined_Depends,Pragma Rational,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-ravenscar}@anchor{d5}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-ravenscar}@anchor{d7}
@section Pragma Ravenscar
@@ -7090,7 +7134,7 @@ pragma Profile (Ravenscar);
which is the preferred method of setting the @code{Ravenscar} profile.
@node Pragma Refined_Depends,Pragma Refined_Global,Pragma Ravenscar,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas id35}@anchor{d6}@anchor{gnat_rm/implementation_defined_pragmas pragma-refined-depends}@anchor{d7}
+@anchor{gnat_rm/implementation_defined_pragmas id36}@anchor{d8}@anchor{gnat_rm/implementation_defined_pragmas pragma-refined-depends}@anchor{d9}
@section Pragma Refined_Depends
@@ -7123,7 +7167,7 @@ For the semantics of this pragma, see the entry for aspect @code{Refined_Depends
the SPARK 2014 Reference Manual, section 6.1.5.
@node Pragma Refined_Global,Pragma Refined_Post,Pragma Refined_Depends,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas id36}@anchor{d8}@anchor{gnat_rm/implementation_defined_pragmas pragma-refined-global}@anchor{d9}
+@anchor{gnat_rm/implementation_defined_pragmas id37}@anchor{da}@anchor{gnat_rm/implementation_defined_pragmas pragma-refined-global}@anchor{db}
@section Pragma Refined_Global
@@ -7148,7 +7192,7 @@ For the semantics of this pragma, see the entry for aspect @code{Refined_Global}
the SPARK 2014 Reference Manual, section 6.1.4.
@node Pragma Refined_Post,Pragma Refined_State,Pragma Refined_Global,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas id37}@anchor{da}@anchor{gnat_rm/implementation_defined_pragmas pragma-refined-post}@anchor{db}
+@anchor{gnat_rm/implementation_defined_pragmas id38}@anchor{dc}@anchor{gnat_rm/implementation_defined_pragmas pragma-refined-post}@anchor{dd}
@section Pragma Refined_Post
@@ -7162,7 +7206,7 @@ For the semantics of this pragma, see the entry for aspect @code{Refined_Post} i
the SPARK 2014 Reference Manual, section 7.2.7.
@node Pragma Refined_State,Pragma Relative_Deadline,Pragma Refined_Post,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas id38}@anchor{dc}@anchor{gnat_rm/implementation_defined_pragmas pragma-refined-state}@anchor{dd}
+@anchor{gnat_rm/implementation_defined_pragmas id39}@anchor{de}@anchor{gnat_rm/implementation_defined_pragmas pragma-refined-state}@anchor{df}
@section Pragma Refined_State
@@ -7188,7 +7232,7 @@ For the semantics of this pragma, see the entry for aspect @code{Refined_State}
the SPARK 2014 Reference Manual, section 7.2.2.
@node Pragma Relative_Deadline,Pragma Remote_Access_Type,Pragma Refined_State,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-relative-deadline}@anchor{de}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-relative-deadline}@anchor{e0}
@section Pragma Relative_Deadline
@@ -7203,7 +7247,7 @@ versions of Ada as an implementation-defined pragma.
See Ada 2012 Reference Manual for details.
@node Pragma Remote_Access_Type,Pragma Rename_Pragma,Pragma Relative_Deadline,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas id39}@anchor{df}@anchor{gnat_rm/implementation_defined_pragmas pragma-remote-access-type}@anchor{e0}
+@anchor{gnat_rm/implementation_defined_pragmas id40}@anchor{e1}@anchor{gnat_rm/implementation_defined_pragmas pragma-remote-access-type}@anchor{e2}
@section Pragma Remote_Access_Type
@@ -7229,7 +7273,7 @@ pertaining to remote access to class-wide types. At instantiation, the
actual type must be a remote access to class-wide type.
@node Pragma Rename_Pragma,Pragma Restricted_Run_Time,Pragma Remote_Access_Type,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-rename-pragma}@anchor{e1}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-rename-pragma}@anchor{e3}
@section Pragma Rename_Pragma
@@ -7268,7 +7312,7 @@ Pragma Inline_Only will not necessarily mean the same thing as the other Ada
compiler; it’s up to you to make sure the semantics are close enough.
@node Pragma Restricted_Run_Time,Pragma Restriction_Warnings,Pragma Rename_Pragma,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-restricted-run-time}@anchor{e2}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-restricted-run-time}@anchor{e4}
@section Pragma Restricted_Run_Time
@@ -7289,7 +7333,7 @@ which is the preferred method of setting the restricted run time
profile.
@node Pragma Restriction_Warnings,Pragma Reviewable,Pragma Restricted_Run_Time,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-restriction-warnings}@anchor{e3}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-restriction-warnings}@anchor{e5}
@section Pragma Restriction_Warnings
@@ -7327,7 +7371,7 @@ generating a warning, but any other use of implementation
defined pragmas will cause a warning to be generated.
@node Pragma Reviewable,Pragma Secondary_Stack_Size,Pragma Restriction_Warnings,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-reviewable}@anchor{e4}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-reviewable}@anchor{e6}
@section Pragma Reviewable
@@ -7431,7 +7475,7 @@ comprehensive messages identifying possible problems based on this
information.
@node Pragma Secondary_Stack_Size,Pragma Share_Generic,Pragma Reviewable,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas id40}@anchor{e5}@anchor{gnat_rm/implementation_defined_pragmas pragma-secondary-stack-size}@anchor{e6}
+@anchor{gnat_rm/implementation_defined_pragmas id41}@anchor{e7}@anchor{gnat_rm/implementation_defined_pragmas pragma-secondary-stack-size}@anchor{e8}
@section Pragma Secondary_Stack_Size
@@ -7467,7 +7511,7 @@ Note the pragma cannot appear when the restriction @code{No_Secondary_Stack}
is in effect.
@node Pragma Share_Generic,Pragma Shared,Pragma Secondary_Stack_Size,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-share-generic}@anchor{e7}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-share-generic}@anchor{e9}
@section Pragma Share_Generic
@@ -7485,7 +7529,7 @@ than to check that the given names are all names of generic units or
generic instances.
@node Pragma Shared,Pragma Short_Circuit_And_Or,Pragma Share_Generic,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas id41}@anchor{e8}@anchor{gnat_rm/implementation_defined_pragmas pragma-shared}@anchor{e9}
+@anchor{gnat_rm/implementation_defined_pragmas id42}@anchor{ea}@anchor{gnat_rm/implementation_defined_pragmas pragma-shared}@anchor{eb}
@section Pragma Shared
@@ -7493,7 +7537,7 @@ This pragma is provided for compatibility with Ada 83. The syntax and
semantics are identical to pragma Atomic.
@node Pragma Short_Circuit_And_Or,Pragma Short_Descriptors,Pragma Shared,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-short-circuit-and-or}@anchor{ea}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-short-circuit-and-or}@anchor{ec}
@section Pragma Short_Circuit_And_Or
@@ -7512,7 +7556,7 @@ within the file being compiled, it applies only to the file being compiled.
There is no requirement that all units in a partition use this option.
@node Pragma Short_Descriptors,Pragma Side_Effects,Pragma Short_Circuit_And_Or,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-short-descriptors}@anchor{eb}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-short-descriptors}@anchor{ed}
@section Pragma Short_Descriptors
@@ -7526,7 +7570,7 @@ This pragma is provided for compatibility with other Ada implementations. It
is recognized but ignored by all current versions of GNAT.
@node Pragma Side_Effects,Pragma Simple_Storage_Pool_Type,Pragma Short_Descriptors,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas id42}@anchor{ec}@anchor{gnat_rm/implementation_defined_pragmas pragma-side-effects}@anchor{ed}
+@anchor{gnat_rm/implementation_defined_pragmas id43}@anchor{ee}@anchor{gnat_rm/implementation_defined_pragmas pragma-side-effects}@anchor{ef}
@section Pragma Side_Effects
@@ -7540,7 +7584,7 @@ For the semantics of this pragma, see the entry for aspect
@code{Side_Effects} in the SPARK Reference Manual, section 6.1.12.
@node Pragma Simple_Storage_Pool_Type,Pragma Source_File_Name,Pragma Side_Effects,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas id43}@anchor{ee}@anchor{gnat_rm/implementation_defined_pragmas pragma-simple-storage-pool-type}@anchor{ef}
+@anchor{gnat_rm/implementation_defined_pragmas id44}@anchor{f0}@anchor{gnat_rm/implementation_defined_pragmas pragma-simple-storage-pool-type}@anchor{f1}
@section Pragma Simple_Storage_Pool_Type
@@ -7594,7 +7638,7 @@ storage-management discipline).
An object of a simple storage pool type can be associated with an access
type by specifying the attribute
-@ref{f0,,Simple_Storage_Pool}. For example:
+@ref{f2,,Simple_Storage_Pool}. For example:
@example
My_Pool : My_Simple_Storage_Pool_Type;
@@ -7604,11 +7648,11 @@ type Acc is access My_Data_Type;
for Acc'Simple_Storage_Pool use My_Pool;
@end example
-See attribute @ref{f0,,Simple_Storage_Pool}
+See attribute @ref{f2,,Simple_Storage_Pool}
for further details.
@node Pragma Source_File_Name,Pragma Source_File_Name_Project,Pragma Simple_Storage_Pool_Type,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas id44}@anchor{f1}@anchor{gnat_rm/implementation_defined_pragmas pragma-source-file-name}@anchor{f2}
+@anchor{gnat_rm/implementation_defined_pragmas id45}@anchor{f3}@anchor{gnat_rm/implementation_defined_pragmas pragma-source-file-name}@anchor{f4}
@section Pragma Source_File_Name
@@ -7700,20 +7744,20 @@ aware of these pragmas, and so other tools that use the project file would not
be aware of the intended naming conventions. If you are using project files,
file naming is controlled by Source_File_Name_Project pragmas, which are
usually supplied automatically by the project manager. A pragma
-Source_File_Name cannot appear after a @ref{f3,,Pragma Source_File_Name_Project}.
+Source_File_Name cannot appear after a @ref{f5,,Pragma Source_File_Name_Project}.
For more details on the use of the @code{Source_File_Name} pragma, see the
sections on @cite{Using Other File Names} and @cite{Alternative File Naming Schemes}
in the @cite{GNAT User’s Guide}.
@node Pragma Source_File_Name_Project,Pragma Source_Reference,Pragma Source_File_Name,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas id45}@anchor{f4}@anchor{gnat_rm/implementation_defined_pragmas pragma-source-file-name-project}@anchor{f3}
+@anchor{gnat_rm/implementation_defined_pragmas id46}@anchor{f6}@anchor{gnat_rm/implementation_defined_pragmas pragma-source-file-name-project}@anchor{f5}
@section Pragma Source_File_Name_Project
This pragma has the same syntax and semantics as pragma Source_File_Name.
It is only allowed as a stand-alone configuration pragma.
-It cannot appear after a @ref{f2,,Pragma Source_File_Name}, and
+It cannot appear after a @ref{f4,,Pragma Source_File_Name}, and
most importantly, once pragma Source_File_Name_Project appears,
no further Source_File_Name pragmas are allowed.
@@ -7725,7 +7769,7 @@ Source_File_Name or Source_File_Name_Project pragmas (which would not be
known to the project manager).
@node Pragma Source_Reference,Pragma SPARK_Mode,Pragma Source_File_Name_Project,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-source-reference}@anchor{f5}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-source-reference}@anchor{f7}
@section Pragma Source_Reference
@@ -7749,7 +7793,7 @@ string expression other than a string literal. This is because its value
is needed for error messages issued by all phases of the compiler.
@node Pragma SPARK_Mode,Pragma Static_Elaboration_Desired,Pragma Source_Reference,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas id46}@anchor{f6}@anchor{gnat_rm/implementation_defined_pragmas pragma-spark-mode}@anchor{f7}
+@anchor{gnat_rm/implementation_defined_pragmas id47}@anchor{f8}@anchor{gnat_rm/implementation_defined_pragmas pragma-spark-mode}@anchor{f9}
@section Pragma SPARK_Mode
@@ -7831,7 +7875,7 @@ SPARK_Mode (@code{Off}), then that pragma will need to be repeated in
the package body.
@node Pragma Static_Elaboration_Desired,Pragma Stream_Convert,Pragma SPARK_Mode,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-static-elaboration-desired}@anchor{f8}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-static-elaboration-desired}@anchor{fa}
@section Pragma Static_Elaboration_Desired
@@ -7855,7 +7899,7 @@ construction of larger aggregates with static components that include an others
choice.)
@node Pragma Stream_Convert,Pragma Style_Checks,Pragma Static_Elaboration_Desired,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-stream-convert}@anchor{f9}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-stream-convert}@anchor{fb}
@section Pragma Stream_Convert
@@ -7932,7 +7976,7 @@ the pragma is silently ignored, and the default implementation of the stream
attributes is used instead.
@node Pragma Style_Checks,Pragma Subprogram_Variant,Pragma Stream_Convert,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-style-checks}@anchor{fa}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-style-checks}@anchor{fc}
@section Pragma Style_Checks
@@ -8078,7 +8122,7 @@ Rf2 : Integer := ARG; -- OK, no error
@end example
@node Pragma Subprogram_Variant,Pragma Subtitle,Pragma Style_Checks,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-subprogram-variant}@anchor{fb}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-subprogram-variant}@anchor{fd}
@section Pragma Subprogram_Variant
@@ -8110,7 +8154,7 @@ the implementation-defined @code{Subprogram_Variant} aspect, and shares its
restrictions and semantics.
@node Pragma Subtitle,Pragma Suppress,Pragma Subprogram_Variant,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-subtitle}@anchor{fc}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-subtitle}@anchor{fe}
@section Pragma Subtitle
@@ -8124,7 +8168,7 @@ This pragma is recognized for compatibility with other Ada compilers
but is ignored by GNAT.
@node Pragma Suppress,Pragma Suppress_All,Pragma Subtitle,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-suppress}@anchor{fd}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-suppress}@anchor{ff}
@section Pragma Suppress
@@ -8197,7 +8241,7 @@ Of course, run-time checks are omitted whenever the compiler can prove
that they will not fail, whether or not checks are suppressed.
@node Pragma Suppress_All,Pragma Suppress_Debug_Info,Pragma Suppress,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-suppress-all}@anchor{fe}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-suppress-all}@anchor{100}
@section Pragma Suppress_All
@@ -8216,7 +8260,7 @@ The use of the standard Ada pragma @code{Suppress (All_Checks)}
as a normal configuration pragma is the preferred usage in GNAT.
@node Pragma Suppress_Debug_Info,Pragma Suppress_Exception_Locations,Pragma Suppress_All,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas id47}@anchor{ff}@anchor{gnat_rm/implementation_defined_pragmas pragma-suppress-debug-info}@anchor{100}
+@anchor{gnat_rm/implementation_defined_pragmas id48}@anchor{101}@anchor{gnat_rm/implementation_defined_pragmas pragma-suppress-debug-info}@anchor{102}
@section Pragma Suppress_Debug_Info
@@ -8231,7 +8275,7 @@ for the specified entity. It is intended primarily for use in debugging
the debugger, and navigating around debugger problems.
@node Pragma Suppress_Exception_Locations,Pragma Suppress_Initialization,Pragma Suppress_Debug_Info,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-suppress-exception-locations}@anchor{101}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-suppress-exception-locations}@anchor{103}
@section Pragma Suppress_Exception_Locations
@@ -8254,7 +8298,7 @@ a partition, so it is fine to have some units within a partition compiled
with this pragma and others compiled in normal mode without it.
@node Pragma Suppress_Initialization,Pragma Task_Name,Pragma Suppress_Exception_Locations,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas id48}@anchor{102}@anchor{gnat_rm/implementation_defined_pragmas pragma-suppress-initialization}@anchor{103}
+@anchor{gnat_rm/implementation_defined_pragmas id49}@anchor{104}@anchor{gnat_rm/implementation_defined_pragmas pragma-suppress-initialization}@anchor{105}
@section Pragma Suppress_Initialization
@@ -8299,7 +8343,7 @@ is suppressed, just as though its subtype had been given in a pragma
Suppress_Initialization, as described above.
@node Pragma Task_Name,Pragma Task_Storage,Pragma Suppress_Initialization,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-task-name}@anchor{104}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-task-name}@anchor{106}
@section Pragma Task_Name
@@ -8355,7 +8399,7 @@ end;
@end example
@node Pragma Task_Storage,Pragma Test_Case,Pragma Task_Name,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-task-storage}@anchor{105}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-task-storage}@anchor{107}
@section Pragma Task_Storage
@@ -8375,7 +8419,7 @@ created, depending on the target. This pragma can appear anywhere a
type.
@node Pragma Test_Case,Pragma Thread_Local_Storage,Pragma Task_Storage,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas id49}@anchor{106}@anchor{gnat_rm/implementation_defined_pragmas pragma-test-case}@anchor{107}
+@anchor{gnat_rm/implementation_defined_pragmas id50}@anchor{108}@anchor{gnat_rm/implementation_defined_pragmas pragma-test-case}@anchor{109}
@section Pragma Test_Case
@@ -8431,7 +8475,7 @@ postcondition. Mode @code{Robustness} indicates that the precondition and
postcondition of the subprogram should be ignored for this test case.
@node Pragma Thread_Local_Storage,Pragma Time_Slice,Pragma Test_Case,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas id50}@anchor{108}@anchor{gnat_rm/implementation_defined_pragmas pragma-thread-local-storage}@anchor{109}
+@anchor{gnat_rm/implementation_defined_pragmas id51}@anchor{10a}@anchor{gnat_rm/implementation_defined_pragmas pragma-thread-local-storage}@anchor{10b}
@section Pragma Thread_Local_Storage
@@ -8469,7 +8513,7 @@ If this pragma is used on a system where @code{TLS} is not supported,
then an error message will be generated and the program will be rejected.
@node Pragma Time_Slice,Pragma Title,Pragma Thread_Local_Storage,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-time-slice}@anchor{10a}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-time-slice}@anchor{10c}
@section Pragma Time_Slice
@@ -8485,7 +8529,7 @@ It is ignored if it is used in a system that does not allow this control,
or if it appears in other than the main program unit.
@node Pragma Title,Pragma Type_Invariant,Pragma Time_Slice,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-title}@anchor{10b}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-title}@anchor{10d}
@section Pragma Title
@@ -8510,7 +8554,7 @@ notation is used, and named and positional notation can be mixed
following the normal rules for procedure calls in Ada.
@node Pragma Type_Invariant,Pragma Type_Invariant_Class,Pragma Title,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-type-invariant}@anchor{10c}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-type-invariant}@anchor{10e}
@section Pragma Type_Invariant
@@ -8531,7 +8575,7 @@ controlled by the assertion identifier @code{Type_Invariant}
rather than @code{Invariant}.
@node Pragma Type_Invariant_Class,Pragma Unchecked_Union,Pragma Type_Invariant,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas id51}@anchor{10d}@anchor{gnat_rm/implementation_defined_pragmas pragma-type-invariant-class}@anchor{10e}
+@anchor{gnat_rm/implementation_defined_pragmas id52}@anchor{10f}@anchor{gnat_rm/implementation_defined_pragmas pragma-type-invariant-class}@anchor{110}
@section Pragma Type_Invariant_Class
@@ -8558,7 +8602,7 @@ policy that controls this pragma is @code{Type_Invariant'Class},
not @code{Type_Invariant_Class}.
@node Pragma Unchecked_Union,Pragma Unevaluated_Use_Of_Old,Pragma Type_Invariant_Class,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-unchecked-union}@anchor{10f}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-unchecked-union}@anchor{111}
@section Pragma Unchecked_Union
@@ -8578,7 +8622,7 @@ version in all language modes (Ada 83, Ada 95, and Ada 2005). For full
details, consult the Ada 2012 Reference Manual, section B.3.3.
@node Pragma Unevaluated_Use_Of_Old,Pragma User_Aspect_Definition,Pragma Unchecked_Union,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-unevaluated-use-of-old}@anchor{110}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-unevaluated-use-of-old}@anchor{112}
@section Pragma Unevaluated_Use_Of_Old
@@ -8633,7 +8677,7 @@ uses up to the end of the corresponding statement sequence or
sequence of package declarations.
@node Pragma User_Aspect_Definition,Pragma Unimplemented_Unit,Pragma Unevaluated_Use_Of_Old,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-user-aspect-definition}@anchor{111}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-user-aspect-definition}@anchor{113}
@section Pragma User_Aspect_Definition
@@ -8665,7 +8709,7 @@ pragma. If multiple definitions are visible for some aspect at some point,
then the definitions must agree. A predefined aspect cannot be redefined.
@node Pragma Unimplemented_Unit,Pragma Universal_Aliasing,Pragma User_Aspect_Definition,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-unimplemented-unit}@anchor{112}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-unimplemented-unit}@anchor{114}
@section Pragma Unimplemented_Unit
@@ -8685,7 +8729,7 @@ The abort only happens if code is being generated. Thus you can use
specs of unimplemented packages in syntax or semantic checking mode.
@node Pragma Universal_Aliasing,Pragma Unmodified,Pragma Unimplemented_Unit,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas id52}@anchor{113}@anchor{gnat_rm/implementation_defined_pragmas pragma-universal-aliasing}@anchor{114}
+@anchor{gnat_rm/implementation_defined_pragmas id53}@anchor{115}@anchor{gnat_rm/implementation_defined_pragmas pragma-universal-aliasing}@anchor{116}
@section Pragma Universal_Aliasing
@@ -8703,7 +8747,7 @@ they need to be suppressed, see the section on
@code{Optimization and Strict Aliasing} in the @cite{GNAT User’s Guide}.
@node Pragma Unmodified,Pragma Unreferenced,Pragma Universal_Aliasing,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas id53}@anchor{115}@anchor{gnat_rm/implementation_defined_pragmas pragma-unmodified}@anchor{116}
+@anchor{gnat_rm/implementation_defined_pragmas id54}@anchor{117}@anchor{gnat_rm/implementation_defined_pragmas pragma-unmodified}@anchor{118}
@section Pragma Unmodified
@@ -8737,7 +8781,7 @@ Thus it is never necessary to use @code{pragma Unmodified} for such
variables, though it is harmless to do so.
@node Pragma Unreferenced,Pragma Unreferenced_Objects,Pragma Unmodified,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas id54}@anchor{117}@anchor{gnat_rm/implementation_defined_pragmas pragma-unreferenced}@anchor{118}
+@anchor{gnat_rm/implementation_defined_pragmas id55}@anchor{119}@anchor{gnat_rm/implementation_defined_pragmas pragma-unreferenced}@anchor{11a}
@section Pragma Unreferenced
@@ -8799,7 +8843,7 @@ Thus it is never necessary to use @code{pragma Unreferenced} for such
variables, though it is harmless to do so.
@node Pragma Unreferenced_Objects,Pragma Unreserve_All_Interrupts,Pragma Unreferenced,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas id55}@anchor{119}@anchor{gnat_rm/implementation_defined_pragmas pragma-unreferenced-objects}@anchor{11a}
+@anchor{gnat_rm/implementation_defined_pragmas id56}@anchor{11b}@anchor{gnat_rm/implementation_defined_pragmas pragma-unreferenced-objects}@anchor{11c}
@section Pragma Unreferenced_Objects
@@ -8824,7 +8868,7 @@ compiler will automatically suppress unwanted warnings about these variables
not being referenced.
@node Pragma Unreserve_All_Interrupts,Pragma Unsuppress,Pragma Unreferenced_Objects,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-unreserve-all-interrupts}@anchor{11b}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-unreserve-all-interrupts}@anchor{11d}
@section Pragma Unreserve_All_Interrupts
@@ -8837,15 +8881,15 @@ pragma Unreserve_All_Interrupts;
Normally certain interrupts are reserved to the implementation. Any attempt
to attach an interrupt causes Program_Error to be raised, as described in
RM C.3.2(22). A typical example is the @code{SIGINT} interrupt used in
-many systems for a @code{Ctrl-C} interrupt. Normally this interrupt is
-reserved to the implementation, so that @code{Ctrl-C} can be used to
+many systems for a @code{Ctrl}-@code{C} interrupt. Normally this interrupt is
+reserved to the implementation, so that @code{Ctrl}-@code{C} can be used to
interrupt execution.
If the pragma @code{Unreserve_All_Interrupts} appears anywhere in any unit in
a program, then all such interrupts are unreserved. This allows the
program to handle these interrupts, but disables their standard
functions. For example, if this pragma is used, then pressing
-@code{Ctrl-C} will not automatically interrupt execution. However,
+@code{Ctrl}-@code{C} will not automatically interrupt execution. However,
a program can then handle the @code{SIGINT} interrupt as it chooses.
For a full list of the interrupts handled in a specific implementation,
@@ -8860,7 +8904,7 @@ handled, see pragma @code{Interrupt_State}, which subsumes the functionality
of the @code{Unreserve_All_Interrupts} pragma.
@node Pragma Unsuppress,Pragma Unused,Pragma Unreserve_All_Interrupts,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-unsuppress}@anchor{11c}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-unsuppress}@anchor{11e}
@section Pragma Unsuppress
@@ -8896,7 +8940,7 @@ number of implementation-defined check names. See the description of pragma
@code{Suppress} for full details.
@node Pragma Unused,Pragma Use_VADS_Size,Pragma Unsuppress,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas id56}@anchor{11d}@anchor{gnat_rm/implementation_defined_pragmas pragma-unused}@anchor{11e}
+@anchor{gnat_rm/implementation_defined_pragmas id57}@anchor{11f}@anchor{gnat_rm/implementation_defined_pragmas pragma-unused}@anchor{120}
@section Pragma Unused
@@ -8930,7 +8974,7 @@ Thus it is never necessary to use @code{pragma Unused} for such
variables, though it is harmless to do so.
@node Pragma Use_VADS_Size,Pragma Validity_Checks,Pragma Unused,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-use-vads-size}@anchor{11f}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-use-vads-size}@anchor{121}
@section Pragma Use_VADS_Size
@@ -8954,7 +8998,7 @@ as implemented in the VADS compiler. See description of the VADS_Size
attribute for further details.
@node Pragma Validity_Checks,Pragma Volatile,Pragma Use_VADS_Size,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-validity-checks}@anchor{120}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-validity-checks}@anchor{122}
@section Pragma Validity_Checks
@@ -9010,7 +9054,7 @@ A := C; -- C will be validity checked
@end example
@node Pragma Volatile,Pragma Volatile_Full_Access,Pragma Validity_Checks,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas id57}@anchor{121}@anchor{gnat_rm/implementation_defined_pragmas pragma-volatile}@anchor{122}
+@anchor{gnat_rm/implementation_defined_pragmas id58}@anchor{123}@anchor{gnat_rm/implementation_defined_pragmas pragma-volatile}@anchor{124}
@section Pragma Volatile
@@ -9028,7 +9072,7 @@ implementation of pragma Volatile is upwards compatible with the
implementation in DEC Ada 83.
@node Pragma Volatile_Full_Access,Pragma Volatile_Function,Pragma Volatile,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas id58}@anchor{123}@anchor{gnat_rm/implementation_defined_pragmas pragma-volatile-full-access}@anchor{124}
+@anchor{gnat_rm/implementation_defined_pragmas id59}@anchor{125}@anchor{gnat_rm/implementation_defined_pragmas pragma-volatile-full-access}@anchor{126}
@section Pragma Volatile_Full_Access
@@ -9054,7 +9098,7 @@ is not to the whole object; the compiler is allowed (and generally will)
access only part of the object in this case.
@node Pragma Volatile_Function,Pragma Warning_As_Error,Pragma Volatile_Full_Access,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas id59}@anchor{125}@anchor{gnat_rm/implementation_defined_pragmas pragma-volatile-function}@anchor{126}
+@anchor{gnat_rm/implementation_defined_pragmas id60}@anchor{127}@anchor{gnat_rm/implementation_defined_pragmas pragma-volatile-function}@anchor{128}
@section Pragma Volatile_Function
@@ -9068,7 +9112,7 @@ For the semantics of this pragma, see the entry for aspect @code{Volatile_Functi
in the SPARK 2014 Reference Manual, section 7.1.2.
@node Pragma Warning_As_Error,Pragma Warnings,Pragma Volatile_Function,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-warning-as-error}@anchor{127}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-warning-as-error}@anchor{129}
@section Pragma Warning_As_Error
@@ -9108,7 +9152,7 @@ you can use multiple pragma Warning_As_Error.
The above use of patterns to match the message applies only to warning
messages generated by the front end. This pragma can also be applied to
-warnings provided by the back end and mentioned in @ref{128,,Pragma Warnings}.
+warnings provided by the back end and mentioned in @ref{12a,,Pragma Warnings}.
By using a single full `-Wxxx' switch in the pragma, such warnings
can also be treated as errors.
@@ -9158,7 +9202,7 @@ the tag is changed from “warning:” to “error:” and the string
“[warning-as-error]” is appended to the end of the message.
@node Pragma Warnings,Pragma Weak_External,Pragma Warning_As_Error,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas id60}@anchor{129}@anchor{gnat_rm/implementation_defined_pragmas pragma-warnings}@anchor{128}
+@anchor{gnat_rm/implementation_defined_pragmas id61}@anchor{12b}@anchor{gnat_rm/implementation_defined_pragmas pragma-warnings}@anchor{12a}
@section Pragma Warnings
@@ -9314,7 +9358,7 @@ selectively for each tool, and as a consequence to detect useless pragma
Warnings with switch @code{-gnatw.w}.
@node Pragma Weak_External,Pragma Wide_Character_Encoding,Pragma Warnings,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-weak-external}@anchor{12a}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-weak-external}@anchor{12c}
@section Pragma Weak_External
@@ -9365,7 +9409,7 @@ end External_Module;
@end example
@node Pragma Wide_Character_Encoding,,Pragma Weak_External,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-wide-character-encoding}@anchor{12b}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-wide-character-encoding}@anchor{12d}
@section Pragma Wide_Character_Encoding
@@ -9396,7 +9440,7 @@ encoding within that file, and does not affect withed units, specs,
or subunits.
@node Implementation Defined Aspects,Implementation Defined Attributes,Implementation Defined Pragmas,Top
-@anchor{gnat_rm/implementation_defined_aspects doc}@anchor{12c}@anchor{gnat_rm/implementation_defined_aspects id1}@anchor{12d}@anchor{gnat_rm/implementation_defined_aspects implementation-defined-aspects}@anchor{12e}
+@anchor{gnat_rm/implementation_defined_aspects doc}@anchor{12e}@anchor{gnat_rm/implementation_defined_aspects id1}@anchor{12f}@anchor{gnat_rm/implementation_defined_aspects implementation-defined-aspects}@anchor{130}
@chapter Implementation Defined Aspects
@@ -9493,6 +9537,7 @@ or attribute definition clause.
* Aspect Part_Of::
* Aspect Persistent_BSS::
* Aspect Predicate::
+* Aspect Program_Exit::
* Aspect Pure_Function::
* Aspect Refined_Depends::
* Aspect Refined_Global::
@@ -9525,7 +9570,7 @@ or attribute definition clause.
@end menu
@node Aspect Abstract_State,Aspect Always_Terminates,,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-abstract-state}@anchor{12f}
+@anchor{gnat_rm/implementation_defined_aspects aspect-abstract-state}@anchor{131}
@section Aspect Abstract_State
@@ -9534,7 +9579,7 @@ or attribute definition clause.
This aspect is equivalent to @ref{1e,,pragma Abstract_State}.
@node Aspect Always_Terminates,Aspect Annotate,Aspect Abstract_State,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-always-terminates}@anchor{130}
+@anchor{gnat_rm/implementation_defined_aspects aspect-always-terminates}@anchor{132}
@section Aspect Always_Terminates
@@ -9543,7 +9588,7 @@ This aspect is equivalent to @ref{1e,,pragma Abstract_State}.
This boolean aspect is equivalent to @ref{29,,pragma Always_Terminates}.
@node Aspect Annotate,Aspect Async_Readers,Aspect Always_Terminates,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-annotate}@anchor{131}
+@anchor{gnat_rm/implementation_defined_aspects aspect-annotate}@anchor{133}
@section Aspect Annotate
@@ -9570,7 +9615,7 @@ Equivalent to @code{pragma Annotate (ID, ID @{, ARG@}, Entity => Name);}
@end table
@node Aspect Async_Readers,Aspect Async_Writers,Aspect Annotate,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-async-readers}@anchor{132}
+@anchor{gnat_rm/implementation_defined_aspects aspect-async-readers}@anchor{134}
@section Aspect Async_Readers
@@ -9579,7 +9624,7 @@ Equivalent to @code{pragma Annotate (ID, ID @{, ARG@}, Entity => Name);}
This boolean aspect is equivalent to @ref{32,,pragma Async_Readers}.
@node Aspect Async_Writers,Aspect Constant_After_Elaboration,Aspect Async_Readers,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-async-writers}@anchor{133}
+@anchor{gnat_rm/implementation_defined_aspects aspect-async-writers}@anchor{135}
@section Aspect Async_Writers
@@ -9588,7 +9633,7 @@ This boolean aspect is equivalent to @ref{32,,pragma Async_Readers}.
This boolean aspect is equivalent to @ref{34,,pragma Async_Writers}.
@node Aspect Constant_After_Elaboration,Aspect Contract_Cases,Aspect Async_Writers,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-constant-after-elaboration}@anchor{134}
+@anchor{gnat_rm/implementation_defined_aspects aspect-constant-after-elaboration}@anchor{136}
@section Aspect Constant_After_Elaboration
@@ -9597,7 +9642,7 @@ This boolean aspect is equivalent to @ref{34,,pragma Async_Writers}.
This aspect is equivalent to @ref{44,,pragma Constant_After_Elaboration}.
@node Aspect Contract_Cases,Aspect Depends,Aspect Constant_After_Elaboration,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-contract-cases}@anchor{135}
+@anchor{gnat_rm/implementation_defined_aspects aspect-contract-cases}@anchor{137}
@section Aspect Contract_Cases
@@ -9608,7 +9653,7 @@ of clauses being enclosed in parentheses so that syntactically it is an
aggregate.
@node Aspect Depends,Aspect Default_Initial_Condition,Aspect Contract_Cases,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-depends}@anchor{136}
+@anchor{gnat_rm/implementation_defined_aspects aspect-depends}@anchor{138}
@section Aspect Depends
@@ -9617,7 +9662,7 @@ aggregate.
This aspect is equivalent to @ref{56,,pragma Depends}.
@node Aspect Default_Initial_Condition,Aspect Dimension,Aspect Depends,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-default-initial-condition}@anchor{137}
+@anchor{gnat_rm/implementation_defined_aspects aspect-default-initial-condition}@anchor{139}
@section Aspect Default_Initial_Condition
@@ -9626,7 +9671,7 @@ This aspect is equivalent to @ref{56,,pragma Depends}.
This aspect is equivalent to @ref{52,,pragma Default_Initial_Condition}.
@node Aspect Dimension,Aspect Dimension_System,Aspect Default_Initial_Condition,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-dimension}@anchor{138}
+@anchor{gnat_rm/implementation_defined_aspects aspect-dimension}@anchor{13a}
@section Aspect Dimension
@@ -9662,7 +9707,7 @@ Note that when the dimensioned type is an integer type, then any
dimension value must be an integer literal.
@node Aspect Dimension_System,Aspect Disable_Controlled,Aspect Dimension,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-dimension-system}@anchor{139}
+@anchor{gnat_rm/implementation_defined_aspects aspect-dimension-system}@anchor{13b}
@section Aspect Dimension_System
@@ -9722,7 +9767,7 @@ See section ‘Performing Dimensionality Analysis in GNAT’ in the GNAT Users
Guide for detailed examples of use of the dimension system.
@node Aspect Disable_Controlled,Aspect Effective_Reads,Aspect Dimension_System,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-disable-controlled}@anchor{13a}
+@anchor{gnat_rm/implementation_defined_aspects aspect-disable-controlled}@anchor{13c}
@section Aspect Disable_Controlled
@@ -9735,7 +9780,7 @@ where for example you might want a record to be controlled or not depending on
whether some run-time check is enabled or suppressed.
@node Aspect Effective_Reads,Aspect Effective_Writes,Aspect Disable_Controlled,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-effective-reads}@anchor{13b}
+@anchor{gnat_rm/implementation_defined_aspects aspect-effective-reads}@anchor{13d}
@section Aspect Effective_Reads
@@ -9744,7 +9789,7 @@ whether some run-time check is enabled or suppressed.
This aspect is equivalent to @ref{5b,,pragma Effective_Reads}.
@node Aspect Effective_Writes,Aspect Exceptional_Cases,Aspect Effective_Reads,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-effective-writes}@anchor{13c}
+@anchor{gnat_rm/implementation_defined_aspects aspect-effective-writes}@anchor{13e}
@section Aspect Effective_Writes
@@ -9753,7 +9798,7 @@ This aspect is equivalent to @ref{5b,,pragma Effective_Reads}.
This aspect is equivalent to @ref{5d,,pragma Effective_Writes}.
@node Aspect Exceptional_Cases,Aspect Exit_Cases,Aspect Effective_Writes,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-exceptional-cases}@anchor{13d}
+@anchor{gnat_rm/implementation_defined_aspects aspect-exceptional-cases}@anchor{13f}
@section Aspect Exceptional_Cases
@@ -9768,7 +9813,7 @@ For the syntax and semantics of this aspect, see the SPARK 2014 Reference
Manual, section 6.1.9.
@node Aspect Exit_Cases,Aspect Extensions_Visible,Aspect Exceptional_Cases,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-exit-cases}@anchor{13e}
+@anchor{gnat_rm/implementation_defined_aspects aspect-exit-cases}@anchor{140}
@section Aspect Exit_Cases
@@ -9783,7 +9828,7 @@ For the syntax and semantics of this aspect, see the SPARK 2014 Reference
Manual, section 6.1.10.
@node Aspect Extensions_Visible,Aspect Favor_Top_Level,Aspect Exit_Cases,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-extensions-visible}@anchor{13f}
+@anchor{gnat_rm/implementation_defined_aspects aspect-extensions-visible}@anchor{141}
@section Aspect Extensions_Visible
@@ -9792,7 +9837,7 @@ Manual, section 6.1.10.
This aspect is equivalent to @ref{6d,,pragma Extensions_Visible}.
@node Aspect Favor_Top_Level,Aspect Ghost,Aspect Extensions_Visible,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-favor-top-level}@anchor{140}
+@anchor{gnat_rm/implementation_defined_aspects aspect-favor-top-level}@anchor{142}
@section Aspect Favor_Top_Level
@@ -9801,7 +9846,7 @@ This aspect is equivalent to @ref{6d,,pragma Extensions_Visible}.
This boolean aspect is equivalent to @ref{72,,pragma Favor_Top_Level}.
@node Aspect Ghost,Aspect Ghost_Predicate,Aspect Favor_Top_Level,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-ghost}@anchor{141}
+@anchor{gnat_rm/implementation_defined_aspects aspect-ghost}@anchor{143}
@section Aspect Ghost
@@ -9810,7 +9855,7 @@ This boolean aspect is equivalent to @ref{72,,pragma Favor_Top_Level}.
This aspect is equivalent to @ref{76,,pragma Ghost}.
@node Aspect Ghost_Predicate,Aspect Global,Aspect Ghost,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-ghost-predicate}@anchor{142}
+@anchor{gnat_rm/implementation_defined_aspects aspect-ghost-predicate}@anchor{144}
@section Aspect Ghost_Predicate
@@ -9823,7 +9868,7 @@ For the detailed semantics of this aspect, see the entry for subtype predicates
in the SPARK Reference Manual, section 3.2.4.
@node Aspect Global,Aspect Initial_Condition,Aspect Ghost_Predicate,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-global}@anchor{143}
+@anchor{gnat_rm/implementation_defined_aspects aspect-global}@anchor{145}
@section Aspect Global
@@ -9832,7 +9877,7 @@ in the SPARK Reference Manual, section 3.2.4.
This aspect is equivalent to @ref{78,,pragma Global}.
@node Aspect Initial_Condition,Aspect Initializes,Aspect Global,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-initial-condition}@anchor{144}
+@anchor{gnat_rm/implementation_defined_aspects aspect-initial-condition}@anchor{146}
@section Aspect Initial_Condition
@@ -9841,7 +9886,7 @@ This aspect is equivalent to @ref{78,,pragma Global}.
This aspect is equivalent to @ref{85,,pragma Initial_Condition}.
@node Aspect Initializes,Aspect Inline_Always,Aspect Initial_Condition,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-initializes}@anchor{145}
+@anchor{gnat_rm/implementation_defined_aspects aspect-initializes}@anchor{147}
@section Aspect Initializes
@@ -9850,7 +9895,7 @@ This aspect is equivalent to @ref{85,,pragma Initial_Condition}.
This aspect is equivalent to @ref{88,,pragma Initializes}.
@node Aspect Inline_Always,Aspect Invariant,Aspect Initializes,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-inline-always}@anchor{146}
+@anchor{gnat_rm/implementation_defined_aspects aspect-inline-always}@anchor{148}
@section Aspect Inline_Always
@@ -9859,7 +9904,7 @@ This aspect is equivalent to @ref{88,,pragma Initializes}.
This boolean aspect is equivalent to @ref{8a,,pragma Inline_Always}.
@node Aspect Invariant,Aspect Invariant’Class,Aspect Inline_Always,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-invariant}@anchor{147}
+@anchor{gnat_rm/implementation_defined_aspects aspect-invariant}@anchor{149}
@section Aspect Invariant
@@ -9870,18 +9915,18 @@ synonym for the language defined aspect @code{Type_Invariant} except
that it is separately controllable using pragma @code{Assertion_Policy}.
@node Aspect Invariant’Class,Aspect Iterable,Aspect Invariant,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-invariant-class}@anchor{148}
+@anchor{gnat_rm/implementation_defined_aspects aspect-invariant-class}@anchor{14a}
@section Aspect Invariant’Class
@geindex Invariant'Class
-This aspect is equivalent to @ref{10e,,pragma Type_Invariant_Class}. It is a
+This aspect is equivalent to @ref{110,,pragma Type_Invariant_Class}. It is a
synonym for the language defined aspect @code{Type_Invariant'Class} except
that it is separately controllable using pragma @code{Assertion_Policy}.
@node Aspect Iterable,Aspect Linker_Section,Aspect Invariant’Class,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-iterable}@anchor{149}
+@anchor{gnat_rm/implementation_defined_aspects aspect-iterable}@anchor{14b}
@section Aspect Iterable
@@ -9965,7 +10010,7 @@ function Get_Element (Cont : Container; Position : Cursor) return Element_Type;
This aspect is used in the GNAT-defined formal container packages.
@node Aspect Linker_Section,Aspect Local_Restrictions,Aspect Iterable,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-linker-section}@anchor{14a}
+@anchor{gnat_rm/implementation_defined_aspects aspect-linker-section}@anchor{14c}
@section Aspect Linker_Section
@@ -9974,7 +10019,7 @@ This aspect is used in the GNAT-defined formal container packages.
This aspect is equivalent to @ref{9a,,pragma Linker_Section}.
@node Aspect Local_Restrictions,Aspect Lock_Free,Aspect Linker_Section,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-local-restrictions}@anchor{14b}
+@anchor{gnat_rm/implementation_defined_aspects aspect-local-restrictions}@anchor{14d}
@section Aspect Local_Restrictions
@@ -10028,7 +10073,7 @@ case of a declaration that occurs within nested packages that each have
a Local_Restrictions specification).
@node Aspect Lock_Free,Aspect Max_Queue_Length,Aspect Local_Restrictions,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-lock-free}@anchor{14c}
+@anchor{gnat_rm/implementation_defined_aspects aspect-lock-free}@anchor{14e}
@section Aspect Lock_Free
@@ -10037,7 +10082,7 @@ a Local_Restrictions specification).
This boolean aspect is equivalent to @ref{9c,,pragma Lock_Free}.
@node Aspect Max_Queue_Length,Aspect No_Caching,Aspect Lock_Free,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-max-queue-length}@anchor{14d}
+@anchor{gnat_rm/implementation_defined_aspects aspect-max-queue-length}@anchor{14f}
@section Aspect Max_Queue_Length
@@ -10046,7 +10091,7 @@ This boolean aspect is equivalent to @ref{9c,,pragma Lock_Free}.
This aspect is equivalent to @ref{a4,,pragma Max_Queue_Length}.
@node Aspect No_Caching,Aspect No_Elaboration_Code_All,Aspect Max_Queue_Length,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-no-caching}@anchor{14e}
+@anchor{gnat_rm/implementation_defined_aspects aspect-no-caching}@anchor{150}
@section Aspect No_Caching
@@ -10055,7 +10100,7 @@ This aspect is equivalent to @ref{a4,,pragma Max_Queue_Length}.
This boolean aspect is equivalent to @ref{a7,,pragma No_Caching}.
@node Aspect No_Elaboration_Code_All,Aspect No_Inline,Aspect No_Caching,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-no-elaboration-code-all}@anchor{14f}
+@anchor{gnat_rm/implementation_defined_aspects aspect-no-elaboration-code-all}@anchor{151}
@section Aspect No_Elaboration_Code_All
@@ -10065,7 +10110,7 @@ This aspect is equivalent to @ref{aa,,pragma No_Elaboration_Code_All}
for a program unit.
@node Aspect No_Inline,Aspect No_Raise,Aspect No_Elaboration_Code_All,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-no-inline}@anchor{150}
+@anchor{gnat_rm/implementation_defined_aspects aspect-no-inline}@anchor{152}
@section Aspect No_Inline
@@ -10074,7 +10119,7 @@ for a program unit.
This boolean aspect is equivalent to @ref{ad,,pragma No_Inline}.
@node Aspect No_Raise,Aspect No_Tagged_Streams,Aspect No_Inline,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-no-raise}@anchor{151}
+@anchor{gnat_rm/implementation_defined_aspects aspect-no-raise}@anchor{153}
@section Aspect No_Raise
@@ -10083,7 +10128,7 @@ This boolean aspect is equivalent to @ref{ad,,pragma No_Inline}.
This boolean aspect is equivalent to @ref{af,,pragma No_Raise}.
@node Aspect No_Tagged_Streams,Aspect No_Task_Parts,Aspect No_Raise,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-no-tagged-streams}@anchor{152}
+@anchor{gnat_rm/implementation_defined_aspects aspect-no-tagged-streams}@anchor{154}
@section Aspect No_Tagged_Streams
@@ -10094,7 +10139,7 @@ argument specifying a root tagged type (thus this aspect can only be
applied to such a type).
@node Aspect No_Task_Parts,Aspect Object_Size,Aspect No_Tagged_Streams,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-no-task-parts}@anchor{153}
+@anchor{gnat_rm/implementation_defined_aspects aspect-no-task-parts}@anchor{155}
@section Aspect No_Task_Parts
@@ -10110,16 +10155,16 @@ away certain tasking-related code that would otherwise be needed
for T’Class, because descendants of T might contain tasks.
@node Aspect Object_Size,Aspect Obsolescent,Aspect No_Task_Parts,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-object-size}@anchor{154}
+@anchor{gnat_rm/implementation_defined_aspects aspect-object-size}@anchor{156}
@section Aspect Object_Size
@geindex Object_Size
-This aspect is equivalent to @ref{155,,attribute Object_Size}.
+This aspect is equivalent to @ref{157,,attribute Object_Size}.
@node Aspect Obsolescent,Aspect Part_Of,Aspect Object_Size,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-obsolescent}@anchor{156}
+@anchor{gnat_rm/implementation_defined_aspects aspect-obsolescent}@anchor{158}
@section Aspect Obsolescent
@@ -10130,7 +10175,7 @@ evaluation of this aspect happens at the point of occurrence, it is not
delayed until the freeze point.
@node Aspect Part_Of,Aspect Persistent_BSS,Aspect Obsolescent,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-part-of}@anchor{157}
+@anchor{gnat_rm/implementation_defined_aspects aspect-part-of}@anchor{159}
@section Aspect Part_Of
@@ -10139,7 +10184,7 @@ delayed until the freeze point.
This aspect is equivalent to @ref{bc,,pragma Part_Of}.
@node Aspect Persistent_BSS,Aspect Predicate,Aspect Part_Of,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-persistent-bss}@anchor{158}
+@anchor{gnat_rm/implementation_defined_aspects aspect-persistent-bss}@anchor{15a}
@section Aspect Persistent_BSS
@@ -10147,8 +10192,8 @@ This aspect is equivalent to @ref{bc,,pragma Part_Of}.
This boolean aspect is equivalent to @ref{c0,,pragma Persistent_BSS}.
-@node Aspect Predicate,Aspect Pure_Function,Aspect Persistent_BSS,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-predicate}@anchor{159}
+@node Aspect Predicate,Aspect Program_Exit,Aspect Persistent_BSS,Implementation Defined Aspects
+@anchor{gnat_rm/implementation_defined_aspects aspect-predicate}@anchor{15b}
@section Aspect Predicate
@@ -10161,53 +10206,62 @@ predicate is static or dynamic is controlled by the form of the
expression. It is also separately controllable using pragma
@code{Assertion_Policy}.
-@node Aspect Pure_Function,Aspect Refined_Depends,Aspect Predicate,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-pure-function}@anchor{15a}
+@node Aspect Program_Exit,Aspect Pure_Function,Aspect Predicate,Implementation Defined Aspects
+@anchor{gnat_rm/implementation_defined_aspects aspect-program-exit}@anchor{15c}
+@section Aspect Program_Exit
+
+
+@geindex Program_Exit
+
+This boolean aspect is equivalent to @ref{d0,,pragma Program_Exit}.
+
+@node Aspect Pure_Function,Aspect Refined_Depends,Aspect Program_Exit,Implementation Defined Aspects
+@anchor{gnat_rm/implementation_defined_aspects aspect-pure-function}@anchor{15d}
@section Aspect Pure_Function
@geindex Pure_Function
-This boolean aspect is equivalent to @ref{d3,,pragma Pure_Function}.
+This boolean aspect is equivalent to @ref{d5,,pragma Pure_Function}.
@node Aspect Refined_Depends,Aspect Refined_Global,Aspect Pure_Function,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-refined-depends}@anchor{15b}
+@anchor{gnat_rm/implementation_defined_aspects aspect-refined-depends}@anchor{15e}
@section Aspect Refined_Depends
@geindex Refined_Depends
-This aspect is equivalent to @ref{d7,,pragma Refined_Depends}.
+This aspect is equivalent to @ref{d9,,pragma Refined_Depends}.
@node Aspect Refined_Global,Aspect Refined_Post,Aspect Refined_Depends,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-refined-global}@anchor{15c}
+@anchor{gnat_rm/implementation_defined_aspects aspect-refined-global}@anchor{15f}
@section Aspect Refined_Global
@geindex Refined_Global
-This aspect is equivalent to @ref{d9,,pragma Refined_Global}.
+This aspect is equivalent to @ref{db,,pragma Refined_Global}.
@node Aspect Refined_Post,Aspect Refined_State,Aspect Refined_Global,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-refined-post}@anchor{15d}
+@anchor{gnat_rm/implementation_defined_aspects aspect-refined-post}@anchor{160}
@section Aspect Refined_Post
@geindex Refined_Post
-This aspect is equivalent to @ref{db,,pragma Refined_Post}.
+This aspect is equivalent to @ref{dd,,pragma Refined_Post}.
@node Aspect Refined_State,Aspect Relaxed_Initialization,Aspect Refined_Post,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-refined-state}@anchor{15e}
+@anchor{gnat_rm/implementation_defined_aspects aspect-refined-state}@anchor{161}
@section Aspect Refined_State
@geindex Refined_State
-This aspect is equivalent to @ref{dd,,pragma Refined_State}.
+This aspect is equivalent to @ref{df,,pragma Refined_State}.
@node Aspect Relaxed_Initialization,Aspect Remote_Access_Type,Aspect Refined_State,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-relaxed-initialization}@anchor{15f}
+@anchor{gnat_rm/implementation_defined_aspects aspect-relaxed-initialization}@anchor{162}
@section Aspect Relaxed_Initialization
@@ -10217,82 +10271,82 @@ For the syntax and semantics of this aspect, see the SPARK 2014 Reference
Manual, section 6.10.
@node Aspect Remote_Access_Type,Aspect Scalar_Storage_Order,Aspect Relaxed_Initialization,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-remote-access-type}@anchor{160}
+@anchor{gnat_rm/implementation_defined_aspects aspect-remote-access-type}@anchor{163}
@section Aspect Remote_Access_Type
@geindex Remote_Access_Type
-This aspect is equivalent to @ref{e0,,pragma Remote_Access_Type}.
+This aspect is equivalent to @ref{e2,,pragma Remote_Access_Type}.
@node Aspect Scalar_Storage_Order,Aspect Secondary_Stack_Size,Aspect Remote_Access_Type,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-scalar-storage-order}@anchor{161}
+@anchor{gnat_rm/implementation_defined_aspects aspect-scalar-storage-order}@anchor{164}
@section Aspect Scalar_Storage_Order
@geindex Scalar_Storage_Order
-This aspect is equivalent to a @ref{162,,attribute Scalar_Storage_Order}.
+This aspect is equivalent to a @ref{165,,attribute Scalar_Storage_Order}.
@node Aspect Secondary_Stack_Size,Aspect Shared,Aspect Scalar_Storage_Order,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-secondary-stack-size}@anchor{163}
+@anchor{gnat_rm/implementation_defined_aspects aspect-secondary-stack-size}@anchor{166}
@section Aspect Secondary_Stack_Size
@geindex Secondary_Stack_Size
-This aspect is equivalent to @ref{e6,,pragma Secondary_Stack_Size}.
+This aspect is equivalent to @ref{e8,,pragma Secondary_Stack_Size}.
@node Aspect Shared,Aspect Side_Effects,Aspect Secondary_Stack_Size,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-shared}@anchor{164}
+@anchor{gnat_rm/implementation_defined_aspects aspect-shared}@anchor{167}
@section Aspect Shared
@geindex Shared
-This boolean aspect is equivalent to @ref{e9,,pragma Shared}
+This boolean aspect is equivalent to @ref{eb,,pragma Shared}
and is thus a synonym for aspect @code{Atomic}.
@node Aspect Side_Effects,Aspect Simple_Storage_Pool,Aspect Shared,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-side-effects}@anchor{165}
+@anchor{gnat_rm/implementation_defined_aspects aspect-side-effects}@anchor{168}
@section Aspect Side_Effects
@geindex Side_Effects
-This aspect is equivalent to @ref{ed,,pragma Side_Effects}.
+This aspect is equivalent to @ref{ef,,pragma Side_Effects}.
@node Aspect Simple_Storage_Pool,Aspect Simple_Storage_Pool_Type,Aspect Side_Effects,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-simple-storage-pool}@anchor{166}
+@anchor{gnat_rm/implementation_defined_aspects aspect-simple-storage-pool}@anchor{169}
@section Aspect Simple_Storage_Pool
@geindex Simple_Storage_Pool
-This aspect is equivalent to @ref{f0,,attribute Simple_Storage_Pool}.
+This aspect is equivalent to @ref{f2,,attribute Simple_Storage_Pool}.
@node Aspect Simple_Storage_Pool_Type,Aspect SPARK_Mode,Aspect Simple_Storage_Pool,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-simple-storage-pool-type}@anchor{167}
+@anchor{gnat_rm/implementation_defined_aspects aspect-simple-storage-pool-type}@anchor{16a}
@section Aspect Simple_Storage_Pool_Type
@geindex Simple_Storage_Pool_Type
-This boolean aspect is equivalent to @ref{ef,,pragma Simple_Storage_Pool_Type}.
+This boolean aspect is equivalent to @ref{f1,,pragma Simple_Storage_Pool_Type}.
@node Aspect SPARK_Mode,Aspect Subprogram_Variant,Aspect Simple_Storage_Pool_Type,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-spark-mode}@anchor{168}
+@anchor{gnat_rm/implementation_defined_aspects aspect-spark-mode}@anchor{16b}
@section Aspect SPARK_Mode
@geindex SPARK_Mode
-This aspect is equivalent to @ref{f7,,pragma SPARK_Mode} and
+This aspect is equivalent to @ref{f9,,pragma SPARK_Mode} and
may be specified for either or both of the specification and body
of a subprogram or package.
@node Aspect Subprogram_Variant,Aspect Suppress_Debug_Info,Aspect SPARK_Mode,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-subprogram-variant}@anchor{169}
+@anchor{gnat_rm/implementation_defined_aspects aspect-subprogram-variant}@anchor{16c}
@section Aspect Subprogram_Variant
@@ -10302,83 +10356,83 @@ For the syntax and semantics of this aspect, see the SPARK 2014 Reference
Manual, section 6.1.8.
@node Aspect Suppress_Debug_Info,Aspect Suppress_Initialization,Aspect Subprogram_Variant,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-suppress-debug-info}@anchor{16a}
+@anchor{gnat_rm/implementation_defined_aspects aspect-suppress-debug-info}@anchor{16d}
@section Aspect Suppress_Debug_Info
@geindex Suppress_Debug_Info
-This boolean aspect is equivalent to @ref{100,,pragma Suppress_Debug_Info}.
+This boolean aspect is equivalent to @ref{102,,pragma Suppress_Debug_Info}.
@node Aspect Suppress_Initialization,Aspect Test_Case,Aspect Suppress_Debug_Info,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-suppress-initialization}@anchor{16b}
+@anchor{gnat_rm/implementation_defined_aspects aspect-suppress-initialization}@anchor{16e}
@section Aspect Suppress_Initialization
@geindex Suppress_Initialization
-This boolean aspect is equivalent to @ref{103,,pragma Suppress_Initialization}.
+This boolean aspect is equivalent to @ref{105,,pragma Suppress_Initialization}.
@node Aspect Test_Case,Aspect Thread_Local_Storage,Aspect Suppress_Initialization,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-test-case}@anchor{16c}
+@anchor{gnat_rm/implementation_defined_aspects aspect-test-case}@anchor{16f}
@section Aspect Test_Case
@geindex Test_Case
-This aspect is equivalent to @ref{107,,pragma Test_Case}.
+This aspect is equivalent to @ref{109,,pragma Test_Case}.
@node Aspect Thread_Local_Storage,Aspect Universal_Aliasing,Aspect Test_Case,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-thread-local-storage}@anchor{16d}
+@anchor{gnat_rm/implementation_defined_aspects aspect-thread-local-storage}@anchor{170}
@section Aspect Thread_Local_Storage
@geindex Thread_Local_Storage
-This boolean aspect is equivalent to @ref{109,,pragma Thread_Local_Storage}.
+This boolean aspect is equivalent to @ref{10b,,pragma Thread_Local_Storage}.
@node Aspect Universal_Aliasing,Aspect Unmodified,Aspect Thread_Local_Storage,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-universal-aliasing}@anchor{16e}
+@anchor{gnat_rm/implementation_defined_aspects aspect-universal-aliasing}@anchor{171}
@section Aspect Universal_Aliasing
@geindex Universal_Aliasing
-This boolean aspect is equivalent to @ref{114,,pragma Universal_Aliasing}.
+This boolean aspect is equivalent to @ref{116,,pragma Universal_Aliasing}.
@node Aspect Unmodified,Aspect Unreferenced,Aspect Universal_Aliasing,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-unmodified}@anchor{16f}
+@anchor{gnat_rm/implementation_defined_aspects aspect-unmodified}@anchor{172}
@section Aspect Unmodified
@geindex Unmodified
-This boolean aspect is equivalent to @ref{116,,pragma Unmodified}.
+This boolean aspect is equivalent to @ref{118,,pragma Unmodified}.
@node Aspect Unreferenced,Aspect Unreferenced_Objects,Aspect Unmodified,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-unreferenced}@anchor{170}
+@anchor{gnat_rm/implementation_defined_aspects aspect-unreferenced}@anchor{173}
@section Aspect Unreferenced
@geindex Unreferenced
-This boolean aspect is equivalent to @ref{118,,pragma Unreferenced}.
+This boolean aspect is equivalent to @ref{11a,,pragma Unreferenced}.
When using the @code{-gnat2022} switch, this aspect is also supported on formal
parameters, which is in particular the only form possible for expression
functions.
@node Aspect Unreferenced_Objects,Aspect User_Aspect,Aspect Unreferenced,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-unreferenced-objects}@anchor{171}
+@anchor{gnat_rm/implementation_defined_aspects aspect-unreferenced-objects}@anchor{174}
@section Aspect Unreferenced_Objects
@geindex Unreferenced_Objects
-This boolean aspect is equivalent to @ref{11a,,pragma Unreferenced_Objects}.
+This boolean aspect is equivalent to @ref{11c,,pragma Unreferenced_Objects}.
@node Aspect User_Aspect,Aspect Value_Size,Aspect Unreferenced_Objects,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-user-aspect}@anchor{172}
+@anchor{gnat_rm/implementation_defined_aspects aspect-user-aspect}@anchor{175}
@section Aspect User_Aspect
@@ -10391,45 +10445,45 @@ replicating the set of aspect specifications associated with the named
pragma-defined aspect.
@node Aspect Value_Size,Aspect Volatile_Full_Access,Aspect User_Aspect,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-value-size}@anchor{173}
+@anchor{gnat_rm/implementation_defined_aspects aspect-value-size}@anchor{176}
@section Aspect Value_Size
@geindex Value_Size
-This aspect is equivalent to @ref{174,,attribute Value_Size}.
+This aspect is equivalent to @ref{177,,attribute Value_Size}.
@node Aspect Volatile_Full_Access,Aspect Volatile_Function,Aspect Value_Size,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-volatile-full-access}@anchor{175}
+@anchor{gnat_rm/implementation_defined_aspects aspect-volatile-full-access}@anchor{178}
@section Aspect Volatile_Full_Access
@geindex Volatile_Full_Access
-This boolean aspect is equivalent to @ref{124,,pragma Volatile_Full_Access}.
+This boolean aspect is equivalent to @ref{126,,pragma Volatile_Full_Access}.
@node Aspect Volatile_Function,Aspect Warnings,Aspect Volatile_Full_Access,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-volatile-function}@anchor{176}
+@anchor{gnat_rm/implementation_defined_aspects aspect-volatile-function}@anchor{179}
@section Aspect Volatile_Function
@geindex Volatile_Function
-This boolean aspect is equivalent to @ref{126,,pragma Volatile_Function}.
+This boolean aspect is equivalent to @ref{128,,pragma Volatile_Function}.
@node Aspect Warnings,,Aspect Volatile_Function,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-warnings}@anchor{177}
+@anchor{gnat_rm/implementation_defined_aspects aspect-warnings}@anchor{17a}
@section Aspect Warnings
@geindex Warnings
-This aspect is equivalent to the two argument form of @ref{128,,pragma Warnings},
+This aspect is equivalent to the two argument form of @ref{12a,,pragma Warnings},
where the first argument is @code{ON} or @code{OFF} and the second argument
is the entity.
@node Implementation Defined Attributes,Standard and Implementation Defined Restrictions,Implementation Defined Aspects,Top
-@anchor{gnat_rm/implementation_defined_attributes doc}@anchor{178}@anchor{gnat_rm/implementation_defined_attributes id1}@anchor{179}@anchor{gnat_rm/implementation_defined_attributes implementation-defined-attributes}@anchor{8}
+@anchor{gnat_rm/implementation_defined_attributes doc}@anchor{17b}@anchor{gnat_rm/implementation_defined_attributes id1}@anchor{17c}@anchor{gnat_rm/implementation_defined_attributes implementation-defined-attributes}@anchor{8}
@chapter Implementation Defined Attributes
@@ -10535,7 +10589,7 @@ consideration, you should minimize the use of these attributes.
@end menu
@node Attribute Abort_Signal,Attribute Address_Size,,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-abort-signal}@anchor{17a}
+@anchor{gnat_rm/implementation_defined_attributes attribute-abort-signal}@anchor{17d}
@section Attribute Abort_Signal
@@ -10549,7 +10603,7 @@ completely outside the normal semantics of Ada, for a user program to
intercept the abort exception).
@node Attribute Address_Size,Attribute Asm_Input,Attribute Abort_Signal,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-address-size}@anchor{17b}
+@anchor{gnat_rm/implementation_defined_attributes attribute-address-size}@anchor{17e}
@section Attribute Address_Size
@@ -10565,7 +10619,7 @@ reference to System.Address’Size is nonstatic because Address
is a private type.
@node Attribute Asm_Input,Attribute Asm_Output,Attribute Address_Size,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-asm-input}@anchor{17c}
+@anchor{gnat_rm/implementation_defined_attributes attribute-asm-input}@anchor{17f}
@section Attribute Asm_Input
@@ -10579,10 +10633,10 @@ to be a static expression, and is the constraint for the parameter,
value to be used as the input argument. The possible values for the
constant are the same as those used in the RTL, and are dependent on
the configuration file used to built the GCC back end.
-@ref{17d,,Machine Code Insertions}
+@ref{180,,Machine Code Insertions}
@node Attribute Asm_Output,Attribute Atomic_Always_Lock_Free,Attribute Asm_Input,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-asm-output}@anchor{17e}
+@anchor{gnat_rm/implementation_defined_attributes attribute-asm-output}@anchor{181}
@section Attribute Asm_Output
@@ -10598,10 +10652,10 @@ result. The possible values for constraint are the same as those used in
the RTL, and are dependent on the configuration file used to build the
GCC back end. If there are no output operands, then this argument may
either be omitted, or explicitly given as @code{No_Output_Operands}.
-@ref{17d,,Machine Code Insertions}
+@ref{180,,Machine Code Insertions}
@node Attribute Atomic_Always_Lock_Free,Attribute Bit,Attribute Asm_Output,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-atomic-always-lock-free}@anchor{17f}
+@anchor{gnat_rm/implementation_defined_attributes attribute-atomic-always-lock-free}@anchor{182}
@section Attribute Atomic_Always_Lock_Free
@@ -10612,7 +10666,7 @@ result indicates whether atomic operations are supported by the target
for the given type.
@node Attribute Bit,Attribute Bit_Position,Attribute Atomic_Always_Lock_Free,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-bit}@anchor{180}
+@anchor{gnat_rm/implementation_defined_attributes attribute-bit}@anchor{183}
@section Attribute Bit
@@ -10643,7 +10697,7 @@ This attribute is designed to be compatible with the DEC Ada 83 definition
and implementation of the @code{Bit} attribute.
@node Attribute Bit_Position,Attribute Code_Address,Attribute Bit,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-bit-position}@anchor{181}
+@anchor{gnat_rm/implementation_defined_attributes attribute-bit-position}@anchor{184}
@section Attribute Bit_Position
@@ -10658,7 +10712,7 @@ type `universal_integer'. The value depends only on the field
the containing record @code{R}.
@node Attribute Code_Address,Attribute Compiler_Version,Attribute Bit_Position,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-code-address}@anchor{182}
+@anchor{gnat_rm/implementation_defined_attributes attribute-code-address}@anchor{185}
@section Attribute Code_Address
@@ -10701,7 +10755,7 @@ the same value as is returned by the corresponding @code{'Address}
attribute.
@node Attribute Compiler_Version,Attribute Constrained,Attribute Code_Address,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-compiler-version}@anchor{183}
+@anchor{gnat_rm/implementation_defined_attributes attribute-compiler-version}@anchor{186}
@section Attribute Compiler_Version
@@ -10712,7 +10766,7 @@ prefix) yields a static string identifying the version of the compiler
being used to compile the unit containing the attribute reference.
@node Attribute Constrained,Attribute Default_Bit_Order,Attribute Compiler_Version,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-constrained}@anchor{184}
+@anchor{gnat_rm/implementation_defined_attributes attribute-constrained}@anchor{187}
@section Attribute Constrained
@@ -10727,7 +10781,7 @@ record type without discriminants is always @code{True}. This usage is
compatible with older Ada compilers, including notably DEC Ada.
@node Attribute Default_Bit_Order,Attribute Default_Scalar_Storage_Order,Attribute Constrained,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-default-bit-order}@anchor{185}
+@anchor{gnat_rm/implementation_defined_attributes attribute-default-bit-order}@anchor{188}
@section Attribute Default_Bit_Order
@@ -10744,7 +10798,7 @@ as a @code{Pos} value (0 for @code{High_Order_First}, 1 for
@code{Default_Bit_Order} in package @code{System}.
@node Attribute Default_Scalar_Storage_Order,Attribute Deref,Attribute Default_Bit_Order,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-default-scalar-storage-order}@anchor{186}
+@anchor{gnat_rm/implementation_defined_attributes attribute-default-scalar-storage-order}@anchor{189}
@section Attribute Default_Scalar_Storage_Order
@@ -10761,7 +10815,7 @@ equal to @code{Default_Bit_Order} if unspecified) as a
@code{System.Bit_Order} value. This is a static attribute.
@node Attribute Deref,Attribute Descriptor_Size,Attribute Default_Scalar_Storage_Order,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-deref}@anchor{187}
+@anchor{gnat_rm/implementation_defined_attributes attribute-deref}@anchor{18a}
@section Attribute Deref
@@ -10774,7 +10828,7 @@ a named access-to-@cite{typ} type, except that it yields a variable, so it can b
used on the left side of an assignment.
@node Attribute Descriptor_Size,Attribute Elaborated,Attribute Deref,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-descriptor-size}@anchor{188}
+@anchor{gnat_rm/implementation_defined_attributes attribute-descriptor-size}@anchor{18b}
@section Attribute Descriptor_Size
@@ -10803,7 +10857,7 @@ since @code{Positive} has an alignment of 4, the size of the descriptor is
which yields a size of 32 bits, i.e. including 16 bits of padding.
@node Attribute Elaborated,Attribute Elab_Body,Attribute Descriptor_Size,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-elaborated}@anchor{189}
+@anchor{gnat_rm/implementation_defined_attributes attribute-elaborated}@anchor{18c}
@section Attribute Elaborated
@@ -10818,7 +10872,7 @@ units has been completed. An exception is for units which need no
elaboration, the value is always False for such units.
@node Attribute Elab_Body,Attribute Elab_Spec,Attribute Elaborated,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-elab-body}@anchor{18a}
+@anchor{gnat_rm/implementation_defined_attributes attribute-elab-body}@anchor{18d}
@section Attribute Elab_Body
@@ -10834,7 +10888,7 @@ e.g., if it is necessary to do selective re-elaboration to fix some
error.
@node Attribute Elab_Spec,Attribute Elab_Subp_Body,Attribute Elab_Body,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-elab-spec}@anchor{18b}
+@anchor{gnat_rm/implementation_defined_attributes attribute-elab-spec}@anchor{18e}
@section Attribute Elab_Spec
@@ -10850,7 +10904,7 @@ Ada code, e.g., if it is necessary to do selective re-elaboration to fix
some error.
@node Attribute Elab_Subp_Body,Attribute Emax,Attribute Elab_Spec,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-elab-subp-body}@anchor{18c}
+@anchor{gnat_rm/implementation_defined_attributes attribute-elab-subp-body}@anchor{18f}
@section Attribute Elab_Subp_Body
@@ -10864,7 +10918,7 @@ elaboration procedure by the binder in CodePeer mode only and is unrecognized
otherwise.
@node Attribute Emax,Attribute Enabled,Attribute Elab_Subp_Body,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-emax}@anchor{18d}
+@anchor{gnat_rm/implementation_defined_attributes attribute-emax}@anchor{190}
@section Attribute Emax
@@ -10877,7 +10931,7 @@ the Ada 83 reference manual for an exact description of the semantics of
this attribute.
@node Attribute Enabled,Attribute Enum_Rep,Attribute Emax,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-enabled}@anchor{18e}
+@anchor{gnat_rm/implementation_defined_attributes attribute-enabled}@anchor{191}
@section Attribute Enabled
@@ -10901,7 +10955,7 @@ a @code{pragma Suppress} or @code{pragma Unsuppress} before instantiating
the package or subprogram, controlling whether the check will be present.
@node Attribute Enum_Rep,Attribute Enum_Val,Attribute Enabled,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-enum-rep}@anchor{18f}
+@anchor{gnat_rm/implementation_defined_attributes attribute-enum-rep}@anchor{192}
@section Attribute Enum_Rep
@@ -10941,7 +10995,7 @@ integer calculation is done at run time, then the call to @code{Enum_Rep}
may raise @code{Constraint_Error}.
@node Attribute Enum_Val,Attribute Epsilon,Attribute Enum_Rep,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-enum-val}@anchor{190}
+@anchor{gnat_rm/implementation_defined_attributes attribute-enum-val}@anchor{193}
@section Attribute Enum_Val
@@ -10967,7 +11021,7 @@ absence of an enumeration representation clause. This is a static
attribute (i.e., the result is static if the argument is static).
@node Attribute Epsilon,Attribute Fast_Math,Attribute Enum_Val,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-epsilon}@anchor{191}
+@anchor{gnat_rm/implementation_defined_attributes attribute-epsilon}@anchor{194}
@section Attribute Epsilon
@@ -10980,7 +11034,7 @@ the Ada 83 reference manual for an exact description of the semantics of
this attribute.
@node Attribute Fast_Math,Attribute Finalization_Size,Attribute Epsilon,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-fast-math}@anchor{192}
+@anchor{gnat_rm/implementation_defined_attributes attribute-fast-math}@anchor{195}
@section Attribute Fast_Math
@@ -10991,7 +11045,7 @@ prefix) yields a static Boolean value that is True if pragma
@code{Fast_Math} is active, and False otherwise.
@node Attribute Finalization_Size,Attribute Fixed_Value,Attribute Fast_Math,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-finalization-size}@anchor{193}
+@anchor{gnat_rm/implementation_defined_attributes attribute-finalization-size}@anchor{196}
@section Attribute Finalization_Size
@@ -11009,7 +11063,7 @@ class-wide type whose tag denotes a type with no controlled parts.
Note that only heap-allocated objects contain finalization data.
@node Attribute Fixed_Value,Attribute From_Any,Attribute Finalization_Size,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-fixed-value}@anchor{194}
+@anchor{gnat_rm/implementation_defined_attributes attribute-fixed-value}@anchor{197}
@section Attribute Fixed_Value
@@ -11036,7 +11090,7 @@ This attribute is primarily intended for use in implementation of the
input-output functions for fixed-point values.
@node Attribute From_Any,Attribute Has_Access_Values,Attribute Fixed_Value,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-from-any}@anchor{195}
+@anchor{gnat_rm/implementation_defined_attributes attribute-from-any}@anchor{198}
@section Attribute From_Any
@@ -11046,7 +11100,7 @@ This internal attribute is used for the generation of remote subprogram
stubs in the context of the Distributed Systems Annex.
@node Attribute Has_Access_Values,Attribute Has_Discriminants,Attribute From_Any,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-has-access-values}@anchor{196}
+@anchor{gnat_rm/implementation_defined_attributes attribute-has-access-values}@anchor{199}
@section Attribute Has_Access_Values
@@ -11064,7 +11118,7 @@ definitions. If the attribute is applied to a generic private type, it
indicates whether or not the corresponding actual type has access values.
@node Attribute Has_Discriminants,Attribute Has_Tagged_Values,Attribute Has_Access_Values,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-has-discriminants}@anchor{197}
+@anchor{gnat_rm/implementation_defined_attributes attribute-has-discriminants}@anchor{19a}
@section Attribute Has_Discriminants
@@ -11080,7 +11134,7 @@ definitions. If the attribute is applied to a generic private type, it
indicates whether or not the corresponding actual type has discriminants.
@node Attribute Has_Tagged_Values,Attribute Img,Attribute Has_Discriminants,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-has-tagged-values}@anchor{198}
+@anchor{gnat_rm/implementation_defined_attributes attribute-has-tagged-values}@anchor{19b}
@section Attribute Has_Tagged_Values
@@ -11097,7 +11151,7 @@ definitions. If the attribute is applied to a generic private type, it
indicates whether or not the corresponding actual type has access values.
@node Attribute Img,Attribute Initialized,Attribute Has_Tagged_Values,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-img}@anchor{199}
+@anchor{gnat_rm/implementation_defined_attributes attribute-img}@anchor{19c}
@section Attribute Img
@@ -11127,7 +11181,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{19a}
+@anchor{gnat_rm/implementation_defined_attributes attribute-initialized}@anchor{19d}
@section Attribute Initialized
@@ -11137,7 +11191,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{19b}
+@anchor{gnat_rm/implementation_defined_attributes attribute-integer-value}@anchor{19e}
@section Attribute Integer_Value
@@ -11165,7 +11219,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 Large,Attribute Integer_Value,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-invalid-value}@anchor{19c}
+@anchor{gnat_rm/implementation_defined_attributes attribute-invalid-value}@anchor{19f}
@section Attribute Invalid_Value
@@ -11179,7 +11233,7 @@ including the ability to modify the value with the binder -Sxx flag and
relevant environment variables at run time.
@node Attribute Large,Attribute Library_Level,Attribute Invalid_Value,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-large}@anchor{19d}
+@anchor{gnat_rm/implementation_defined_attributes attribute-large}@anchor{1a0}
@section Attribute Large
@@ -11192,7 +11246,7 @@ the Ada 83 reference manual for an exact description of the semantics of
this attribute.
@node Attribute Library_Level,Attribute Loop_Entry,Attribute Large,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-library-level}@anchor{19e}
+@anchor{gnat_rm/implementation_defined_attributes attribute-library-level}@anchor{1a1}
@section Attribute Library_Level
@@ -11218,7 +11272,7 @@ end Gen;
@end example
@node Attribute Loop_Entry,Attribute Machine_Size,Attribute Library_Level,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-loop-entry}@anchor{19f}
+@anchor{gnat_rm/implementation_defined_attributes attribute-loop-entry}@anchor{1a2}
@section Attribute Loop_Entry
@@ -11251,7 +11305,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{1a0}
+@anchor{gnat_rm/implementation_defined_attributes attribute-machine-size}@anchor{1a3}
@section Attribute Machine_Size
@@ -11261,7 +11315,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{1a1}
+@anchor{gnat_rm/implementation_defined_attributes attribute-mantissa}@anchor{1a4}
@section Attribute Mantissa
@@ -11274,7 +11328,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{1a2}@anchor{gnat_rm/implementation_defined_attributes id2}@anchor{1a3}
+@anchor{gnat_rm/implementation_defined_attributes attribute-maximum-alignment}@anchor{1a5}@anchor{gnat_rm/implementation_defined_attributes id2}@anchor{1a6}
@section Attribute Maximum_Alignment
@@ -11290,7 +11344,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{1a4}
+@anchor{gnat_rm/implementation_defined_attributes attribute-max-integer-size}@anchor{1a7}
@section Attribute Max_Integer_Size
@@ -11301,7 +11355,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{1a5}
+@anchor{gnat_rm/implementation_defined_attributes attribute-mechanism-code}@anchor{1a8}
@section Attribute Mechanism_Code
@@ -11332,7 +11386,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{1a6}
+@anchor{gnat_rm/implementation_defined_attributes attribute-null-parameter}@anchor{1a9}
@section Attribute Null_Parameter
@@ -11357,7 +11411,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{155}@anchor{gnat_rm/implementation_defined_attributes id3}@anchor{1a7}
+@anchor{gnat_rm/implementation_defined_attributes attribute-object-size}@anchor{157}@anchor{gnat_rm/implementation_defined_attributes id3}@anchor{1aa}
@section Attribute Object_Size
@@ -11427,7 +11481,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{1a8}
+@anchor{gnat_rm/implementation_defined_attributes attribute-old}@anchor{1ab}
@section Attribute Old
@@ -11442,7 +11496,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{1a9}
+@anchor{gnat_rm/implementation_defined_attributes attribute-passed-by-reference}@anchor{1ac}
@section Attribute Passed_By_Reference
@@ -11458,7 +11512,7 @@ passed by copy in calls. For scalar types, the result is always @code{False}
and is static. For non-scalar types, the result is nonstatic.
@node Attribute Pool_Address,Attribute Range_Length,Attribute Passed_By_Reference,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-pool-address}@anchor{1aa}
+@anchor{gnat_rm/implementation_defined_attributes attribute-pool-address}@anchor{1ad}
@section Attribute Pool_Address
@@ -11480,7 +11534,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{1ab}
+@anchor{gnat_rm/implementation_defined_attributes attribute-range-length}@anchor{1ae}
@section Attribute Range_Length
@@ -11493,7 +11547,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{1ac}
+@anchor{gnat_rm/implementation_defined_attributes attribute-restriction-set}@anchor{1af}
@section Attribute Restriction_Set
@@ -11563,7 +11617,7 @@ Restrictions pragma, they are not analyzed semantically,
so they do not have a type.
@node Attribute Result,Attribute Round,Attribute Restriction_Set,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-result}@anchor{1ad}
+@anchor{gnat_rm/implementation_defined_attributes attribute-result}@anchor{1b0}
@section Attribute Result
@@ -11576,7 +11630,7 @@ For a further discussion of the use of this attribute and examples of its use,
see the description of pragma Postcondition.
@node Attribute Round,Attribute Safe_Emax,Attribute Result,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-round}@anchor{1ae}
+@anchor{gnat_rm/implementation_defined_attributes attribute-round}@anchor{1b1}
@section Attribute Round
@@ -11587,7 +11641,7 @@ also permits the use of the @code{'Round} attribute for ordinary
fixed point types.
@node Attribute Safe_Emax,Attribute Safe_Large,Attribute Round,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-safe-emax}@anchor{1af}
+@anchor{gnat_rm/implementation_defined_attributes attribute-safe-emax}@anchor{1b2}
@section Attribute Safe_Emax
@@ -11600,7 +11654,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{1b0}
+@anchor{gnat_rm/implementation_defined_attributes attribute-safe-large}@anchor{1b3}
@section Attribute Safe_Large
@@ -11613,7 +11667,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{1b1}
+@anchor{gnat_rm/implementation_defined_attributes attribute-safe-small}@anchor{1b4}
@section Attribute Safe_Small
@@ -11626,7 +11680,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 attribute-scalar-storage-order}@anchor{162}@anchor{gnat_rm/implementation_defined_attributes id4}@anchor{1b2}
+@anchor{gnat_rm/implementation_defined_attributes attribute-scalar-storage-order}@anchor{165}@anchor{gnat_rm/implementation_defined_attributes id4}@anchor{1b5}
@section Attribute Scalar_Storage_Order
@@ -11789,7 +11843,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{f0}@anchor{gnat_rm/implementation_defined_attributes id5}@anchor{1b3}
+@anchor{gnat_rm/implementation_defined_attributes attribute-simple-storage-pool}@anchor{f2}@anchor{gnat_rm/implementation_defined_attributes id5}@anchor{1b6}
@section Attribute Simple_Storage_Pool
@@ -11852,7 +11906,7 @@ as defined in section 13.11.2 of the Ada Reference Manual, except that the
term `simple storage pool' is substituted for `storage pool'.
@node Attribute Small,Attribute Small_Denominator,Attribute Simple_Storage_Pool,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-small}@anchor{1b4}
+@anchor{gnat_rm/implementation_defined_attributes attribute-small}@anchor{1b7}
@section Attribute Small
@@ -11868,7 +11922,7 @@ the Ada 83 reference manual for an exact description of the semantics of
this attribute when applied to floating-point types.
@node Attribute Small_Denominator,Attribute Small_Numerator,Attribute Small,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-small-denominator}@anchor{1b5}
+@anchor{gnat_rm/implementation_defined_attributes attribute-small-denominator}@anchor{1b8}
@section Attribute Small_Denominator
@@ -11881,7 +11935,7 @@ denominator in the representation of @code{typ'Small} as a rational number
with coprime factors (i.e. as an irreducible fraction).
@node Attribute Small_Numerator,Attribute Storage_Unit,Attribute Small_Denominator,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-small-numerator}@anchor{1b6}
+@anchor{gnat_rm/implementation_defined_attributes attribute-small-numerator}@anchor{1b9}
@section Attribute Small_Numerator
@@ -11894,7 +11948,7 @@ 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{1b7}
+@anchor{gnat_rm/implementation_defined_attributes attribute-storage-unit}@anchor{1ba}
@section Attribute Storage_Unit
@@ -11904,7 +11958,7 @@ with coprime factors (i.e. as an irreducible fraction).
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{1b8}
+@anchor{gnat_rm/implementation_defined_attributes attribute-stub-type}@anchor{1bb}
@section Attribute Stub_Type
@@ -11928,7 +11982,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{1b9}
+@anchor{gnat_rm/implementation_defined_attributes attribute-system-allocator-alignment}@anchor{1bc}
@section Attribute System_Allocator_Alignment
@@ -11945,7 +11999,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{1ba}
+@anchor{gnat_rm/implementation_defined_attributes attribute-target-name}@anchor{1bd}
@section Attribute Target_Name
@@ -11958,7 +12012,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{1bb}
+@anchor{gnat_rm/implementation_defined_attributes attribute-to-address}@anchor{1be}
@section Attribute To_Address
@@ -11981,7 +12035,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{1bc}
+@anchor{gnat_rm/implementation_defined_attributes attribute-to-any}@anchor{1bf}
@section Attribute To_Any
@@ -11991,7 +12045,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{1bd}
+@anchor{gnat_rm/implementation_defined_attributes attribute-type-class}@anchor{1c0}
@section Attribute Type_Class
@@ -12021,7 +12075,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{1be}
+@anchor{gnat_rm/implementation_defined_attributes attribute-type-key}@anchor{1c1}
@section Attribute Type_Key
@@ -12033,7 +12087,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{1bf}
+@anchor{gnat_rm/implementation_defined_attributes attribute-typecode}@anchor{1c2}
@section Attribute TypeCode
@@ -12043,7 +12097,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{1c0}
+@anchor{gnat_rm/implementation_defined_attributes attribute-unconstrained-array}@anchor{1c3}
@section Attribute Unconstrained_Array
@@ -12057,7 +12111,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{1c1}
+@anchor{gnat_rm/implementation_defined_attributes attribute-universal-literal-string}@anchor{1c4}
@section Attribute Universal_Literal_String
@@ -12085,7 +12139,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{1c2}
+@anchor{gnat_rm/implementation_defined_attributes attribute-unrestricted-access}@anchor{1c5}
@section Attribute Unrestricted_Access
@@ -12272,7 +12326,7 @@ In general this is a risky approach. It may appear to “work” but such uses o
of GNAT to another, so are best avoided if possible.
@node Attribute Update,Attribute Valid_Value,Attribute Unrestricted_Access,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-update}@anchor{1c3}
+@anchor{gnat_rm/implementation_defined_attributes attribute-update}@anchor{1c6}
@section Attribute Update
@@ -12353,19 +12407,19 @@ A := A'Update ((1, 2) => 20, (3, 4) => 30);
which changes element (1,2) to 20 and (3,4) to 30.
@node Attribute Valid_Value,Attribute Valid_Scalars,Attribute Update,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-valid-value}@anchor{1c4}
+@anchor{gnat_rm/implementation_defined_attributes attribute-valid-value}@anchor{1c7}
@section Attribute Valid_Value
@geindex Valid_Value
The @code{'Valid_Value} attribute is defined for enumeration types other than
-those in package Standard. This attribute is a function that takes
-a String, and returns Boolean. @code{T'Valid_Value (S)} returns True
-if and only if @code{T'Value (S)} would not raise Constraint_Error.
+those in package Standard or types derived from those types. This attribute is
+a function that takes a String, and returns Boolean. @code{T'Valid_Value (S)}
+returns True if and only if @code{T'Value (S)} would not raise Constraint_Error.
@node Attribute Valid_Scalars,Attribute VADS_Size,Attribute Valid_Value,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-valid-scalars}@anchor{1c5}
+@anchor{gnat_rm/implementation_defined_attributes attribute-valid-scalars}@anchor{1c8}
@section Attribute Valid_Scalars
@@ -12399,7 +12453,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{1c6}
+@anchor{gnat_rm/implementation_defined_attributes attribute-vads-size}@anchor{1c9}
@section Attribute VADS_Size
@@ -12419,7 +12473,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 attribute-value-size}@anchor{174}@anchor{gnat_rm/implementation_defined_attributes id6}@anchor{1c7}
+@anchor{gnat_rm/implementation_defined_attributes attribute-value-size}@anchor{177}@anchor{gnat_rm/implementation_defined_attributes id6}@anchor{1ca}
@section Attribute Value_Size
@@ -12433,7 +12487,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{1c8}
+@anchor{gnat_rm/implementation_defined_attributes attribute-wchar-t-size}@anchor{1cb}
@section Attribute Wchar_T_Size
@@ -12445,7 +12499,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{1c9}
+@anchor{gnat_rm/implementation_defined_attributes attribute-word-size}@anchor{1cc}
@section Attribute Word_Size
@@ -12456,7 +12510,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 doc}@anchor{1ca}@anchor{gnat_rm/standard_and_implementation_defined_restrictions id1}@anchor{1cb}@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{1cd}@anchor{gnat_rm/standard_and_implementation_defined_restrictions id1}@anchor{1ce}@anchor{gnat_rm/standard_and_implementation_defined_restrictions standard-and-implementation-defined-restrictions}@anchor{9}
@chapter Standard and Implementation Defined Restrictions
@@ -12485,7 +12539,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 id2}@anchor{1cc}@anchor{gnat_rm/standard_and_implementation_defined_restrictions partition-wide-restrictions}@anchor{1cd}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions id2}@anchor{1cf}@anchor{gnat_rm/standard_and_implementation_defined_restrictions partition-wide-restrictions}@anchor{1d0}
@section Partition-Wide Restrictions
@@ -12578,7 +12632,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{1ce}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions immediate-reclamation}@anchor{1d1}
@subsection Immediate_Reclamation
@@ -12590,7 +12644,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{1cf}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-asynchronous-select-nesting}@anchor{1d2}
@subsection Max_Asynchronous_Select_Nesting
@@ -12602,7 +12656,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{1d0}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-entry-queue-length}@anchor{1d3}
@subsection Max_Entry_Queue_Length
@@ -12623,7 +12677,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{1d1}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-protected-entries}@anchor{1d4}
@subsection Max_Protected_Entries
@@ -12634,7 +12688,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{1d2}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-select-alternatives}@anchor{1d5}
@subsection Max_Select_Alternatives
@@ -12643,7 +12697,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{1d3}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-storage-at-blocking}@anchor{1d6}
@subsection Max_Storage_At_Blocking
@@ -12654,7 +12708,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{1d4}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-task-entries}@anchor{1d7}
@subsection Max_Task_Entries
@@ -12667,7 +12721,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{1d5}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-tasks}@anchor{1d8}
@subsection Max_Tasks
@@ -12680,7 +12734,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{1d6}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-abort-statements}@anchor{1d9}
@subsection No_Abort_Statements
@@ -12690,7 +12744,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{1d7}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-access-parameter-allocators}@anchor{1da}
@subsection No_Access_Parameter_Allocators
@@ -12701,7 +12755,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{1d8}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-access-subprograms}@anchor{1db}
@subsection No_Access_Subprograms
@@ -12711,7 +12765,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{1d9}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-allocators}@anchor{1dc}
@subsection No_Allocators
@@ -12721,7 +12775,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{1da}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-anonymous-allocators}@anchor{1dd}
@subsection No_Anonymous_Allocators
@@ -12731,7 +12785,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{1db}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-asynchronous-control}@anchor{1de}
@subsection No_Asynchronous_Control
@@ -12741,7 +12795,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{1dc}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-calendar}@anchor{1df}
@subsection No_Calendar
@@ -12751,7 +12805,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{1dd}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-coextensions}@anchor{1e0}
@subsection No_Coextensions
@@ -12761,7 +12815,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{1de}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-default-initialization}@anchor{1e1}
@subsection No_Default_Initialization
@@ -12778,7 +12832,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{1df}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-delay}@anchor{1e2}
@subsection No_Delay
@@ -12788,7 +12842,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{1e0}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dependence}@anchor{1e3}
@subsection No_Dependence
@@ -12831,7 +12885,7 @@ to support specific constructs of the language. Here are some examples:
@end itemize
@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{1e1}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-direct-boolean-operators}@anchor{1e4}
@subsection No_Direct_Boolean_Operators
@@ -12844,7 +12898,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{1e2}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dispatch}@anchor{1e5}
@subsection No_Dispatch
@@ -12854,7 +12908,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{1e3}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dispatching-calls}@anchor{1e6}
@subsection No_Dispatching_Calls
@@ -12915,7 +12969,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{1e4}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dynamic-attachment}@anchor{1e7}
@subsection No_Dynamic_Attachment
@@ -12934,7 +12988,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{1e5}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dynamic-priorities}@anchor{1e8}
@subsection No_Dynamic_Priorities
@@ -12943,7 +12997,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{1e6}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-entry-calls-in-elaboration-code}@anchor{1e9}
@subsection No_Entry_Calls_In_Elaboration_Code
@@ -12955,7 +13009,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{1e7}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-enumeration-maps}@anchor{1ea}
@subsection No_Enumeration_Maps
@@ -12966,7 +13020,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{1e8}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-exception-handlers}@anchor{1eb}
@subsection No_Exception_Handlers
@@ -12991,7 +13045,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{1e9}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-exception-propagation}@anchor{1ec}
@subsection No_Exception_Propagation
@@ -13008,7 +13062,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{1ea}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-exception-registration}@anchor{1ed}
@subsection No_Exception_Registration
@@ -13022,7 +13076,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{1eb}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-exceptions}@anchor{1ee}
@subsection No_Exceptions
@@ -13033,7 +13087,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{1ec}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-finalization}@anchor{1ef}
@subsection No_Finalization
@@ -13074,7 +13128,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{1ed}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-fixed-point}@anchor{1f0}
@subsection No_Fixed_Point
@@ -13084,7 +13138,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{1ee}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-floating-point}@anchor{1f1}
@subsection No_Floating_Point
@@ -13094,7 +13148,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{1ef}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-conditionals}@anchor{1f2}
@subsection No_Implicit_Conditionals
@@ -13110,7 +13164,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{1f0}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-dynamic-code}@anchor{1f3}
@subsection No_Implicit_Dynamic_Code
@@ -13140,7 +13194,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{1f1}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-heap-allocations}@anchor{1f4}
@subsection No_Implicit_Heap_Allocations
@@ -13149,7 +13203,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{1f2}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-protected-object-allocations}@anchor{1f5}
@subsection No_Implicit_Protected_Object_Allocations
@@ -13159,7 +13213,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{1f3}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-task-allocations}@anchor{1f6}
@subsection No_Implicit_Task_Allocations
@@ -13168,7 +13222,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{1f4}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-initialize-scalars}@anchor{1f7}
@subsection No_Initialize_Scalars
@@ -13180,7 +13234,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{1f5}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-io}@anchor{1f8}
@subsection No_IO
@@ -13191,7 +13245,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{1f6}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-local-allocators}@anchor{1f9}
@subsection No_Local_Allocators
@@ -13202,7 +13256,7 @@ occurrences of an allocator in subprograms, generic subprograms, tasks,
and entry bodies.
@node No_Local_Protected_Objects,No_Local_Tagged_Types,No_Local_Allocators,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-local-protected-objects}@anchor{1f7}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-local-protected-objects}@anchor{1fa}
@subsection No_Local_Protected_Objects
@@ -13212,7 +13266,7 @@ and entry bodies.
only declared at the library level.
@node No_Local_Tagged_Types,No_Local_Timing_Events,No_Local_Protected_Objects,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-local-tagged-types}@anchor{1f8}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-local-tagged-types}@anchor{1fb}
@subsection No_Local_Tagged_Types
@@ -13222,7 +13276,7 @@ only declared at the library level.
declared at the library level.
@node No_Local_Timing_Events,No_Long_Long_Integers,No_Local_Tagged_Types,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-local-timing-events}@anchor{1f9}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-local-timing-events}@anchor{1fc}
@subsection No_Local_Timing_Events
@@ -13232,7 +13286,7 @@ 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{1fa}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-long-long-integers}@anchor{1fd}
@subsection No_Long_Long_Integers
@@ -13244,7 +13298,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{1fb}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-multiple-elaboration}@anchor{1fe}
@subsection No_Multiple_Elaboration
@@ -13260,7 +13314,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{1fc}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-nested-finalization}@anchor{1ff}
@subsection No_Nested_Finalization
@@ -13269,7 +13323,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{1fd}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-protected-type-allocators}@anchor{200}
@subsection No_Protected_Type_Allocators
@@ -13279,7 +13333,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{1fe}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-protected-types}@anchor{201}
@subsection No_Protected_Types
@@ -13289,7 +13343,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{1ff}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-recursion}@anchor{202}
@subsection No_Recursion
@@ -13299,7 +13353,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{200}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-reentrancy}@anchor{203}
@subsection No_Reentrancy
@@ -13309,7 +13363,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{201}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-relative-delay}@anchor{204}
@subsection No_Relative_Delay
@@ -13320,7 +13374,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{202}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-requeue-statements}@anchor{205}
@subsection No_Requeue_Statements
@@ -13338,7 +13392,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{203}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-secondary-stack}@anchor{206}
@subsection No_Secondary_Stack
@@ -13351,7 +13405,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{204}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-select-statements}@anchor{207}
@subsection No_Select_Statements
@@ -13361,7 +13415,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{205}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-specific-termination-handlers}@anchor{208}
@subsection No_Specific_Termination_Handlers
@@ -13371,7 +13425,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{206}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-specification-of-aspect}@anchor{209}
@subsection No_Specification_of_Aspect
@@ -13382,7 +13436,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{207}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-standard-allocators-after-elaboration}@anchor{20a}
@subsection No_Standard_Allocators_After_Elaboration
@@ -13394,7 +13448,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{208}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-standard-storage-pools}@anchor{20b}
@subsection No_Standard_Storage_Pools
@@ -13406,7 +13460,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{209}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-stream-optimizations}@anchor{20c}
@subsection No_Stream_Optimizations
@@ -13419,7 +13473,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_Tagged_Type_Registration,No_Stream_Optimizations,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-streams}@anchor{20a}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-streams}@anchor{20d}
@subsection No_Streams
@@ -13446,7 +13500,7 @@ configuration pragmas to avoid exposing entity names at binary level for the
entire partition.
@node No_Tagged_Type_Registration,No_Task_Allocators,No_Streams,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-tagged-type-registration}@anchor{20b}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-tagged-type-registration}@anchor{20e}
@subsection No_Tagged_Type_Registration
@@ -13461,7 +13515,7 @@ are declared. This restriction may be necessary in order to also apply
the No_Elaboration_Code restriction.
@node No_Task_Allocators,No_Task_At_Interrupt_Priority,No_Tagged_Type_Registration,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-task-allocators}@anchor{20c}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-task-allocators}@anchor{20f}
@subsection No_Task_Allocators
@@ -13471,7 +13525,7 @@ the No_Elaboration_Code restriction.
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{20d}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-task-at-interrupt-priority}@anchor{210}
@subsection No_Task_At_Interrupt_Priority
@@ -13483,7 +13537,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{20e}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-task-attributes-package}@anchor{211}
@subsection No_Task_Attributes_Package
@@ -13500,7 +13554,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{20f}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-task-hierarchy}@anchor{212}
@subsection No_Task_Hierarchy
@@ -13510,7 +13564,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{210}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-task-termination}@anchor{213}
@subsection No_Task_Termination
@@ -13519,7 +13573,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{211}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-tasking}@anchor{214}
@subsection No_Tasking
@@ -13532,7 +13586,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{212}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-terminate-alternatives}@anchor{215}
@subsection No_Terminate_Alternatives
@@ -13541,7 +13595,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{213}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-unchecked-access}@anchor{216}
@subsection No_Unchecked_Access
@@ -13551,7 +13605,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{214}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-unchecked-conversion}@anchor{217}
@subsection No_Unchecked_Conversion
@@ -13561,7 +13615,7 @@ occurrences of the Unchecked_Access attribute.
dependences on the predefined generic function Unchecked_Conversion.
@node No_Unchecked_Deallocation,No_Use_Of_Attribute,No_Unchecked_Conversion,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-unchecked-deallocation}@anchor{215}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-unchecked-deallocation}@anchor{218}
@subsection No_Unchecked_Deallocation
@@ -13571,7 +13625,7 @@ dependences on the predefined generic function Unchecked_Conversion.
dependences on the predefined generic procedure Unchecked_Deallocation.
@node No_Use_Of_Attribute,No_Use_Of_Entity,No_Unchecked_Deallocation,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-use-of-attribute}@anchor{216}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-use-of-attribute}@anchor{219}
@subsection No_Use_Of_Attribute
@@ -13581,7 +13635,7 @@ dependences on the predefined generic procedure Unchecked_Deallocation.
earlier versions of Ada.
@node No_Use_Of_Entity,No_Use_Of_Pragma,No_Use_Of_Attribute,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-use-of-entity}@anchor{217}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-use-of-entity}@anchor{21a}
@subsection No_Use_Of_Entity
@@ -13601,7 +13655,7 @@ No_Use_Of_Entity => Ada.Text_IO.Put_Line
@end example
@node No_Use_Of_Pragma,Pure_Barriers,No_Use_Of_Entity,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-use-of-pragma}@anchor{218}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-use-of-pragma}@anchor{21b}
@subsection No_Use_Of_Pragma
@@ -13611,7 +13665,7 @@ No_Use_Of_Entity => Ada.Text_IO.Put_Line
earlier versions of Ada.
@node Pure_Barriers,Simple_Barriers,No_Use_Of_Pragma,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions pure-barriers}@anchor{219}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions pure-barriers}@anchor{21c}
@subsection Pure_Barriers
@@ -13662,7 +13716,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{21a}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions simple-barriers}@anchor{21d}
@subsection Simple_Barriers
@@ -13681,7 +13735,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{21b}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions static-priorities}@anchor{21e}
@subsection Static_Priorities
@@ -13692,7 +13746,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{21c}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions static-storage-size}@anchor{21f}
@subsection Static_Storage_Size
@@ -13702,7 +13756,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 id3}@anchor{21d}@anchor{gnat_rm/standard_and_implementation_defined_restrictions program-unit-level-restrictions}@anchor{21e}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions id3}@anchor{220}@anchor{gnat_rm/standard_and_implementation_defined_restrictions program-unit-level-restrictions}@anchor{221}
@section Program Unit Level Restrictions
@@ -13733,7 +13787,7 @@ other compilation units in the partition.
@end menu
@node No_Elaboration_Code,No_Dynamic_Accessibility_Checks,,Program Unit Level Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-elaboration-code}@anchor{21f}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-elaboration-code}@anchor{222}
@subsection No_Elaboration_Code
@@ -13789,7 +13843,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_Accessibility_Checks,No_Dynamic_Sized_Objects,No_Elaboration_Code,Program Unit Level Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dynamic-accessibility-checks}@anchor{220}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dynamic-accessibility-checks}@anchor{223}
@subsection No_Dynamic_Accessibility_Checks
@@ -13838,7 +13892,7 @@ In all other cases, the level of T is as defined by the existing rules of Ada.
@end itemize
@node No_Dynamic_Sized_Objects,No_Entry_Queue,No_Dynamic_Accessibility_Checks,Program Unit Level Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dynamic-sized-objects}@anchor{221}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dynamic-sized-objects}@anchor{224}
@subsection No_Dynamic_Sized_Objects
@@ -13856,7 +13910,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{222}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-entry-queue}@anchor{225}
@subsection No_Entry_Queue
@@ -13869,7 +13923,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{223}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-aspect-specifications}@anchor{226}
@subsection No_Implementation_Aspect_Specifications
@@ -13880,7 +13934,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{224}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-attributes}@anchor{227}
@subsection No_Implementation_Attributes
@@ -13892,7 +13946,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{225}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-identifiers}@anchor{228}
@subsection No_Implementation_Identifiers
@@ -13903,7 +13957,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{226}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-pragmas}@anchor{229}
@subsection No_Implementation_Pragmas
@@ -13914,7 +13968,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{227}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-restrictions}@anchor{22a}
@subsection No_Implementation_Restrictions
@@ -13926,7 +13980,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{228}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-units}@anchor{22b}
@subsection No_Implementation_Units
@@ -13937,7 +13991,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{229}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-aliasing}@anchor{22c}
@subsection No_Implicit_Aliasing
@@ -13952,7 +14006,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{22a}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-loops}@anchor{22d}
@subsection No_Implicit_Loops
@@ -13969,7 +14023,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{22b}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-obsolescent-features}@anchor{22e}
@subsection No_Obsolescent_Features
@@ -13979,7 +14033,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{22c}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-wide-characters}@anchor{22f}
@subsection No_Wide_Characters
@@ -13993,7 +14047,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{22d}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions static-dispatch-tables}@anchor{230}
@subsection Static_Dispatch_Tables
@@ -14003,7 +14057,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{22e}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions spark-05}@anchor{231}
@subsection SPARK_05
@@ -14026,7 +14080,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{22f}@anchor{gnat_rm/implementation_advice id1}@anchor{230}@anchor{gnat_rm/implementation_advice implementation-advice}@anchor{a}
+@anchor{gnat_rm/implementation_advice doc}@anchor{232}@anchor{gnat_rm/implementation_advice id1}@anchor{233}@anchor{gnat_rm/implementation_advice implementation-advice}@anchor{a}
@chapter Implementation Advice
@@ -14124,7 +14178,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{231}
+@anchor{gnat_rm/implementation_advice rm-1-1-3-20-error-detection}@anchor{234}
@section RM 1.1.3(20): Error Detection
@@ -14141,7 +14195,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{232}
+@anchor{gnat_rm/implementation_advice rm-1-1-3-31-child-units}@anchor{235}
@section RM 1.1.3(31): Child Units
@@ -14157,7 +14211,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{233}
+@anchor{gnat_rm/implementation_advice rm-1-1-5-12-bounded-errors}@anchor{236}
@section RM 1.1.5(12): Bounded Errors
@@ -14174,7 +14228,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{234}@anchor{gnat_rm/implementation_advice rm-2-8-16-pragmas}@anchor{235}
+@anchor{gnat_rm/implementation_advice id2}@anchor{237}@anchor{gnat_rm/implementation_advice rm-2-8-16-pragmas}@anchor{238}
@section RM 2.8(16): Pragmas
@@ -14287,7 +14341,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{236}
+@anchor{gnat_rm/implementation_advice rm-2-8-17-19-pragmas}@anchor{239}
@section RM 2.8(17-19): Pragmas
@@ -14308,14 +14362,14 @@ replacing @code{library_items}.”
@end itemize
@end quotation
-See @ref{235,,RM 2.8(16); Pragmas}.
+See @ref{238,,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{237}
+@anchor{gnat_rm/implementation_advice rm-3-5-2-5-alternative-character-sets}@anchor{23a}
@section RM 3.5.2(5): Alternative Character Sets
@@ -14343,7 +14397,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{238}
+@anchor{gnat_rm/implementation_advice rm-3-5-4-28-integer-types}@anchor{23b}
@section RM 3.5.4(28): Integer Types
@@ -14362,7 +14416,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{239}
+@anchor{gnat_rm/implementation_advice rm-3-5-4-29-integer-types}@anchor{23c}
@section RM 3.5.4(29): Integer Types
@@ -14378,7 +14432,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{23a}
+@anchor{gnat_rm/implementation_advice rm-3-5-5-8-enumeration-values}@anchor{23d}
@section RM 3.5.5(8): Enumeration Values
@@ -14398,7 +14452,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{23b}
+@anchor{gnat_rm/implementation_advice rm-3-5-7-17-float-types}@anchor{23e}
@section RM 3.5.7(17): Float Types
@@ -14428,7 +14482,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{23c}
+@anchor{gnat_rm/implementation_advice rm-3-6-2-11-multidimensional-arrays}@anchor{23f}
@section RM 3.6.2(11): Multidimensional Arrays
@@ -14446,7 +14500,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{23d}
+@anchor{gnat_rm/implementation_advice rm-9-6-30-31-duration-small}@anchor{240}
@section RM 9.6(30-31): Duration’Small
@@ -14467,7 +14521,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{23e}
+@anchor{gnat_rm/implementation_advice rm-10-2-1-12-consistent-representation}@anchor{241}
@section RM 10.2.1(12): Consistent Representation
@@ -14489,7 +14543,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{23f}
+@anchor{gnat_rm/implementation_advice rm-11-4-1-19-exception-information}@anchor{242}
@section RM 11.4.1(19): Exception Information
@@ -14520,7 +14574,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{240}
+@anchor{gnat_rm/implementation_advice rm-11-5-28-suppression-of-checks}@anchor{243}
@section RM 11.5(28): Suppression of Checks
@@ -14535,7 +14589,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{241}
+@anchor{gnat_rm/implementation_advice rm-13-1-21-24-representation-clauses}@anchor{244}
@section RM 13.1 (21-24): Representation Clauses
@@ -14587,7 +14641,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{242}
+@anchor{gnat_rm/implementation_advice rm-13-2-6-8-packed-types}@anchor{245}
@section RM 13.2(6-8): Packed Types
@@ -14618,7 +14672,7 @@ subcomponent of the packed type.
@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{243}
+@anchor{gnat_rm/implementation_advice rm-13-3-14-19-address-clauses}@anchor{246}
@section RM 13.3(14-19): Address Clauses
@@ -14671,7 +14725,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{244}
+@anchor{gnat_rm/implementation_advice rm-13-3-29-35-alignment-clauses}@anchor{247}
@section RM 13.3(29-35): Alignment Clauses
@@ -14728,7 +14782,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{245}
+@anchor{gnat_rm/implementation_advice rm-13-3-42-43-size-clauses}@anchor{248}
@section RM 13.3(42-43): Size Clauses
@@ -14746,7 +14800,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{246}
+@anchor{gnat_rm/implementation_advice rm-13-3-50-56-size-clauses}@anchor{249}
@section RM 13.3(50-56): Size Clauses
@@ -14797,7 +14851,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{247}
+@anchor{gnat_rm/implementation_advice rm-13-3-71-73-component-size-clauses}@anchor{24a}
@section RM 13.3(71-73): Component Size Clauses
@@ -14831,7 +14885,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{248}
+@anchor{gnat_rm/implementation_advice rm-13-4-9-10-enumeration-representation-clauses}@anchor{24b}
@section RM 13.4(9-10): Enumeration Representation Clauses
@@ -14853,7 +14907,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{249}
+@anchor{gnat_rm/implementation_advice rm-13-5-1-17-22-record-representation-clauses}@anchor{24c}
@section RM 13.5.1(17-22): Record Representation Clauses
@@ -14913,7 +14967,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{24a}
+@anchor{gnat_rm/implementation_advice rm-13-5-2-5-storage-place-attributes}@anchor{24d}
@section RM 13.5.2(5): Storage Place Attributes
@@ -14933,7 +14987,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{24b}
+@anchor{gnat_rm/implementation_advice rm-13-5-3-7-8-bit-ordering}@anchor{24e}
@section RM 13.5.3(7-8): Bit Ordering
@@ -14951,7 +15005,7 @@ Followed.
@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{24c}
+@anchor{gnat_rm/implementation_advice rm-13-7-37-address-as-private}@anchor{24f}
@section RM 13.7(37): Address as Private
@@ -14969,7 +15023,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{24d}
+@anchor{gnat_rm/implementation_advice rm-13-7-1-16-address-operations}@anchor{250}
@section RM 13.7.1(16): Address Operations
@@ -14987,7 +15041,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{24e}
+@anchor{gnat_rm/implementation_advice rm-13-9-14-17-unchecked-conversion}@anchor{251}
@section RM 13.9(14-17): Unchecked Conversion
@@ -15031,7 +15085,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{24f}
+@anchor{gnat_rm/implementation_advice rm-13-11-23-25-implicit-heap-usage}@anchor{252}
@section RM 13.11(23-25): Implicit Heap Usage
@@ -15082,7 +15136,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{250}
+@anchor{gnat_rm/implementation_advice rm-13-11-2-17-unchecked-deallocation}@anchor{253}
@section RM 13.11.2(17): Unchecked Deallocation
@@ -15097,7 +15151,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{251}
+@anchor{gnat_rm/implementation_advice rm-13-13-2-1-6-stream-oriented-attributes}@anchor{254}
@section RM 13.13.2(1.6): Stream Oriented Attributes
@@ -15128,7 +15182,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{252}
+@anchor{gnat_rm/implementation_advice rm-a-1-52-names-of-predefined-numeric-types}@anchor{255}
@section RM A.1(52): Names of Predefined Numeric Types
@@ -15146,7 +15200,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{253}
+@anchor{gnat_rm/implementation_advice rm-a-3-2-49-ada-characters-handling}@anchor{256}
@section RM A.3.2(49): @code{Ada.Characters.Handling}
@@ -15163,7 +15217,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{254}
+@anchor{gnat_rm/implementation_advice rm-a-4-4-106-bounded-length-string-handling}@anchor{257}
@section RM A.4.4(106): Bounded-Length String Handling
@@ -15178,7 +15232,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{255}
+@anchor{gnat_rm/implementation_advice rm-a-5-2-46-47-random-number-generation}@anchor{258}
@section RM A.5.2(46-47): Random Number Generation
@@ -15207,7 +15261,7 @@ condition here to hold true.
@geindex Get_Immediate
@node RM A 10 7 23 Get_Immediate,RM A 18 Containers,RM A 5 2 46-47 Random Number Generation,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-a-10-7-23-get-immediate}@anchor{256}
+@anchor{gnat_rm/implementation_advice rm-a-10-7-23-get-immediate}@anchor{259}
@section RM A.10.7(23): @code{Get_Immediate}
@@ -15231,7 +15285,7 @@ this functionality.
@geindex Containers
@node RM A 18 Containers,RM B 1 39-41 Pragma Export,RM A 10 7 23 Get_Immediate,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-a-18-containers}@anchor{257}
+@anchor{gnat_rm/implementation_advice rm-a-18-containers}@anchor{25a}
@section RM A.18: @code{Containers}
@@ -15252,7 +15306,7 @@ follow the implementation advice.
@geindex Export
@node RM B 1 39-41 Pragma Export,RM B 2 12-13 Package Interfaces,RM A 18 Containers,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-b-1-39-41-pragma-export}@anchor{258}
+@anchor{gnat_rm/implementation_advice rm-b-1-39-41-pragma-export}@anchor{25b}
@section RM B.1(39-41): Pragma @code{Export}
@@ -15300,7 +15354,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{259}
+@anchor{gnat_rm/implementation_advice rm-b-2-12-13-package-interfaces}@anchor{25c}
@section RM B.2(12-13): Package @code{Interfaces}
@@ -15330,7 +15384,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{25a}
+@anchor{gnat_rm/implementation_advice rm-b-3-63-71-interfacing-with-c}@anchor{25d}
@section RM B.3(63-71): Interfacing with C
@@ -15418,7 +15472,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{25b}
+@anchor{gnat_rm/implementation_advice rm-b-4-95-98-interfacing-with-cobol}@anchor{25e}
@section RM B.4(95-98): Interfacing with COBOL
@@ -15459,7 +15513,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{25c}
+@anchor{gnat_rm/implementation_advice rm-b-5-22-26-interfacing-with-fortran}@anchor{25f}
@section RM B.5(22-26): Interfacing with Fortran
@@ -15510,7 +15564,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{25d}
+@anchor{gnat_rm/implementation_advice rm-c-1-3-5-access-to-machine-operations}@anchor{260}
@section RM C.1(3-5): Access to Machine Operations
@@ -15545,7 +15599,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{25e}
+@anchor{gnat_rm/implementation_advice rm-c-1-10-16-access-to-machine-operations}@anchor{261}
@section RM C.1(10-16): Access to Machine Operations
@@ -15606,7 +15660,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{25f}
+@anchor{gnat_rm/implementation_advice rm-c-3-28-interrupt-support}@anchor{262}
@section RM C.3(28): Interrupt Support
@@ -15624,7 +15678,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{260}
+@anchor{gnat_rm/implementation_advice rm-c-3-1-20-21-protected-procedure-handlers}@anchor{263}
@section RM C.3.1(20-21): Protected Procedure Handlers
@@ -15650,7 +15704,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{261}
+@anchor{gnat_rm/implementation_advice rm-c-3-2-25-package-interrupts}@anchor{264}
@section RM C.3.2(25): Package @code{Interrupts}
@@ -15668,7 +15722,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{262}
+@anchor{gnat_rm/implementation_advice rm-c-4-14-pre-elaboration-requirements}@anchor{265}
@section RM C.4(14): Pre-elaboration Requirements
@@ -15684,7 +15738,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{263}
+@anchor{gnat_rm/implementation_advice rm-c-5-8-pragma-discard-names}@anchor{266}
@section RM C.5(8): Pragma @code{Discard_Names}
@@ -15702,7 +15756,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{264}
+@anchor{gnat_rm/implementation_advice rm-c-7-2-30-the-package-task-attributes}@anchor{267}
@section RM C.7.2(30): The Package Task_Attributes
@@ -15723,7 +15777,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{265}
+@anchor{gnat_rm/implementation_advice rm-d-3-17-locking-policies}@anchor{268}
@section RM D.3(17): Locking Policies
@@ -15740,7 +15794,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{266}
+@anchor{gnat_rm/implementation_advice rm-d-4-16-entry-queuing-policies}@anchor{269}
@section RM D.4(16): Entry Queuing Policies
@@ -15755,7 +15809,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{267}
+@anchor{gnat_rm/implementation_advice rm-d-6-9-10-preemptive-abort}@anchor{26a}
@section RM D.6(9-10): Preemptive Abort
@@ -15781,7 +15835,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{268}
+@anchor{gnat_rm/implementation_advice rm-d-7-21-tasking-restrictions}@anchor{26b}
@section RM D.7(21): Tasking Restrictions
@@ -15800,7 +15854,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{269}
+@anchor{gnat_rm/implementation_advice rm-d-8-47-49-monotonic-time}@anchor{26c}
@section RM D.8(47-49): Monotonic Time
@@ -15835,7 +15889,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{26a}
+@anchor{gnat_rm/implementation_advice rm-e-5-28-29-partition-communication-subsystem}@anchor{26d}
@section RM E.5(28-29): Partition Communication Subsystem
@@ -15847,8 +15901,7 @@ should allow them to block until the corresponding subprogram body
returns.”
@end quotation
-Followed by GLADE, a separately supplied PCS that can be used with
-GNAT.
+A separately supplied PCS that can be used with GNAT when combined with the PolyORB product.
@quotation
@@ -15857,13 +15910,10 @@ should raise @code{Storage_Error} if it runs out of space trying to
write the @code{Item} into the stream.”
@end quotation
-Followed by GLADE, a separately supplied PCS that can be used with
-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{26b}
+@anchor{gnat_rm/implementation_advice rm-f-7-cobol-support}@anchor{26e}
@section RM F(7): COBOL Support
@@ -15883,7 +15933,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{26c}
+@anchor{gnat_rm/implementation_advice rm-f-1-2-decimal-radix-support}@anchor{26f}
@section RM F.1(2): Decimal Radix Support
@@ -15899,7 +15949,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{26d}
+@anchor{gnat_rm/implementation_advice rm-g-numerics}@anchor{270}
@section RM G: Numerics
@@ -15919,7 +15969,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{26e}
+@anchor{gnat_rm/implementation_advice rm-g-1-1-56-58-complex-types}@anchor{271}
@section RM G.1.1(56-58): Complex Types
@@ -15981,7 +16031,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{26f}
+@anchor{gnat_rm/implementation_advice rm-g-1-2-49-complex-elementary-functions}@anchor{272}
@section RM G.1.2(49): Complex Elementary Functions
@@ -16003,7 +16053,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{270}
+@anchor{gnat_rm/implementation_advice rm-g-2-4-19-accuracy-requirements}@anchor{273}
@section RM G.2.4(19): Accuracy Requirements
@@ -16027,7 +16077,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{271}
+@anchor{gnat_rm/implementation_advice rm-g-2-6-15-complex-arithmetic-accuracy}@anchor{274}
@section RM G.2.6(15): Complex Arithmetic Accuracy
@@ -16045,7 +16095,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{272}
+@anchor{gnat_rm/implementation_advice rm-h-6-15-2-pragma-partition-elaboration-policy}@anchor{275}
@section RM H.6(15/2): Pragma Partition_Elaboration_Policy
@@ -16060,7 +16110,7 @@ immediately terminated.”
Not followed.
@node Implementation Defined Characteristics,Intrinsic Subprograms,Implementation Advice,Top
-@anchor{gnat_rm/implementation_defined_characteristics doc}@anchor{273}@anchor{gnat_rm/implementation_defined_characteristics id1}@anchor{274}@anchor{gnat_rm/implementation_defined_characteristics implementation-defined-characteristics}@anchor{b}
+@anchor{gnat_rm/implementation_defined_characteristics doc}@anchor{276}@anchor{gnat_rm/implementation_defined_characteristics id1}@anchor{277}@anchor{gnat_rm/implementation_defined_characteristics implementation-defined-characteristics}@anchor{b}
@chapter Implementation Defined Characteristics
@@ -16701,11 +16751,7 @@ may have been set by a call to @code{Ada.Command_Line.Set_Exit_Status}).
“The mechanisms for building and running partitions. See 10.2(24).”
@end itemize
-GNAT itself supports programs with only a single partition. The GNATDIST
-tool provided with the GLADE package (which also includes an implementation
-of the PCS) provides a completely flexible method for building and running
-programs consisting of multiple partitions. See the separate GLADE manual
-for details.
+GNAT itself supports programs with only a single partition. The PolyORB product (which also includes an implementation of the PCS) provides a completely flexible method for building and running programs consisting of multiple partitions. See the separate PolyORB user guide for details.
@itemize *
@@ -16726,7 +16772,7 @@ implementation. See 10.2(28).”
@end itemize
Passive partitions are supported on targets where shared memory is
-provided by the operating system. See the GLADE reference manual for
+provided by the operating system. See the PolyORB user guide for
further details.
@@ -16910,7 +16956,7 @@ See separate section on data representations.
such aspects and the legality rules for such aspects. See 13.1.1(38).”
@end itemize
-See @ref{12e,,Implementation Defined Aspects}.
+See @ref{130,,Implementation Defined Aspects}.
@itemize *
@@ -17354,7 +17400,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{275,,GNAT.Regexp (g-regexp.ads)}.
+See @ref{278,,GNAT.Regexp (g-regexp.ads)}.
@itemize *
@@ -18112,8 +18158,8 @@ Unknown.
programs. See E(5).”
@end itemize
-The GLADE package provides a utility GNATDIST for creating and executing
-distributed programs. See the GLADE reference manual for further details.
+The PolyORB product provides means creating and executing
+distributed programs. See the PolyORB user guide for further details.
@itemize *
@@ -18123,7 +18169,7 @@ distributed programs. See the GLADE reference manual for further details.
inaccessible. See E.1(7).”
@end itemize
-See the GLADE reference manual for full details on such events.
+See the PolyORB user guide for full details on such events.
@itemize *
@@ -18133,7 +18179,7 @@ See the GLADE reference manual for full details on such events.
shared resources between partitions in certain cases. See E.1(11).”
@end itemize
-See the GLADE reference manual for full details on these aspects of
+See the PolyORB user guide for full details on these aspects of
multi-partition execution.
@@ -18144,7 +18190,7 @@ multi-partition execution.
immediately aborted as a result of cancellation. See E.4(13).”
@end itemize
-See the GLADE reference manual for details on the effect of abort in
+See the PolyORB user guide for details on the effect of abort in
a distributed application.
@@ -18163,7 +18209,7 @@ System.RPC.Partition_ID’Last is Integer’Last. See source file @code{s-rpc.ad
“Implementation-defined interfaces in the PCS. See E.5(26).”
@end itemize
-See the GLADE reference manual for a full description of all
+See the PolyORB user guide for a full description of all
implementation defined interfaces.
@@ -18452,7 +18498,7 @@ Information on those subjects is not yet available.
Execution is erroneous in that case.
@node Intrinsic Subprograms,Representation Clauses and Pragmas,Implementation Defined Characteristics,Top
-@anchor{gnat_rm/intrinsic_subprograms doc}@anchor{276}@anchor{gnat_rm/intrinsic_subprograms id1}@anchor{277}@anchor{gnat_rm/intrinsic_subprograms intrinsic-subprograms}@anchor{c}
+@anchor{gnat_rm/intrinsic_subprograms doc}@anchor{279}@anchor{gnat_rm/intrinsic_subprograms id1}@anchor{27a}@anchor{gnat_rm/intrinsic_subprograms intrinsic-subprograms}@anchor{c}
@chapter Intrinsic Subprograms
@@ -18490,7 +18536,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{278}@anchor{gnat_rm/intrinsic_subprograms intrinsic-operators}@anchor{279}
+@anchor{gnat_rm/intrinsic_subprograms id2}@anchor{27b}@anchor{gnat_rm/intrinsic_subprograms intrinsic-operators}@anchor{27c}
@section Intrinsic Operators
@@ -18521,7 +18567,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 compilation-iso-date}@anchor{27a}@anchor{gnat_rm/intrinsic_subprograms id3}@anchor{27b}
+@anchor{gnat_rm/intrinsic_subprograms compilation-iso-date}@anchor{27d}@anchor{gnat_rm/intrinsic_subprograms id3}@anchor{27e}
@section Compilation_ISO_Date
@@ -18535,7 +18581,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{27c}@anchor{gnat_rm/intrinsic_subprograms id4}@anchor{27d}
+@anchor{gnat_rm/intrinsic_subprograms compilation-date}@anchor{27f}@anchor{gnat_rm/intrinsic_subprograms id4}@anchor{280}
@section Compilation_Date
@@ -18545,7 +18591,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{27e}@anchor{gnat_rm/intrinsic_subprograms id5}@anchor{27f}
+@anchor{gnat_rm/intrinsic_subprograms compilation-time}@anchor{281}@anchor{gnat_rm/intrinsic_subprograms id5}@anchor{282}
@section Compilation_Time
@@ -18559,7 +18605,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 enclosing-entity}@anchor{280}@anchor{gnat_rm/intrinsic_subprograms id6}@anchor{281}
+@anchor{gnat_rm/intrinsic_subprograms enclosing-entity}@anchor{283}@anchor{gnat_rm/intrinsic_subprograms id6}@anchor{284}
@section Enclosing_Entity
@@ -18573,7 +18619,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 exception-information}@anchor{282}@anchor{gnat_rm/intrinsic_subprograms id7}@anchor{283}
+@anchor{gnat_rm/intrinsic_subprograms exception-information}@anchor{285}@anchor{gnat_rm/intrinsic_subprograms id7}@anchor{286}
@section Exception_Information
@@ -18587,7 +18633,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{284}@anchor{gnat_rm/intrinsic_subprograms id8}@anchor{285}
+@anchor{gnat_rm/intrinsic_subprograms exception-message}@anchor{287}@anchor{gnat_rm/intrinsic_subprograms id8}@anchor{288}
@section Exception_Message
@@ -18601,7 +18647,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{286}@anchor{gnat_rm/intrinsic_subprograms id9}@anchor{287}
+@anchor{gnat_rm/intrinsic_subprograms exception-name}@anchor{289}@anchor{gnat_rm/intrinsic_subprograms id9}@anchor{28a}
@section Exception_Name
@@ -18615,7 +18661,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 file}@anchor{288}@anchor{gnat_rm/intrinsic_subprograms id10}@anchor{289}
+@anchor{gnat_rm/intrinsic_subprograms file}@anchor{28b}@anchor{gnat_rm/intrinsic_subprograms id10}@anchor{28c}
@section File
@@ -18629,7 +18675,7 @@ application program should simply call the function
file.
@node Line,Shifts and Rotates,File,Intrinsic Subprograms
-@anchor{gnat_rm/intrinsic_subprograms id11}@anchor{28a}@anchor{gnat_rm/intrinsic_subprograms line}@anchor{28b}
+@anchor{gnat_rm/intrinsic_subprograms id11}@anchor{28d}@anchor{gnat_rm/intrinsic_subprograms line}@anchor{28e}
@section Line
@@ -18643,7 +18689,7 @@ application program should simply call the function
source line.
@node Shifts and Rotates,Source_Location,Line,Intrinsic Subprograms
-@anchor{gnat_rm/intrinsic_subprograms id12}@anchor{28c}@anchor{gnat_rm/intrinsic_subprograms shifts-and-rotates}@anchor{28d}
+@anchor{gnat_rm/intrinsic_subprograms id12}@anchor{28f}@anchor{gnat_rm/intrinsic_subprograms shifts-and-rotates}@anchor{290}
@section Shifts and Rotates
@@ -18686,7 +18732,7 @@ corresponding operator for modular type. In particular, shifting a negative
number may change its sign bit to positive.
@node Source_Location,,Shifts and Rotates,Intrinsic Subprograms
-@anchor{gnat_rm/intrinsic_subprograms id13}@anchor{28e}@anchor{gnat_rm/intrinsic_subprograms source-location}@anchor{28f}
+@anchor{gnat_rm/intrinsic_subprograms id13}@anchor{291}@anchor{gnat_rm/intrinsic_subprograms source-location}@anchor{292}
@section Source_Location
@@ -18700,7 +18746,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 doc}@anchor{290}@anchor{gnat_rm/representation_clauses_and_pragmas id1}@anchor{291}@anchor{gnat_rm/representation_clauses_and_pragmas representation-clauses-and-pragmas}@anchor{d}
+@anchor{gnat_rm/representation_clauses_and_pragmas doc}@anchor{293}@anchor{gnat_rm/representation_clauses_and_pragmas id1}@anchor{294}@anchor{gnat_rm/representation_clauses_and_pragmas representation-clauses-and-pragmas}@anchor{d}
@chapter Representation Clauses and Pragmas
@@ -18746,7 +18792,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 alignment-clauses}@anchor{292}@anchor{gnat_rm/representation_clauses_and_pragmas id2}@anchor{293}
+@anchor{gnat_rm/representation_clauses_and_pragmas alignment-clauses}@anchor{295}@anchor{gnat_rm/representation_clauses_and_pragmas id2}@anchor{296}
@section Alignment Clauses
@@ -18768,7 +18814,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{1a2,,Attribute Maximum_Alignment}.)
+@code{Standard'Maximum_Alignment}; see @ref{1a5,,Attribute Maximum_Alignment}.)
@geindex Maximum_Alignment attribute
@@ -18877,7 +18923,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{294}@anchor{gnat_rm/representation_clauses_and_pragmas size-clauses}@anchor{295}
+@anchor{gnat_rm/representation_clauses_and_pragmas id3}@anchor{297}@anchor{gnat_rm/representation_clauses_and_pragmas size-clauses}@anchor{298}
@section Size Clauses
@@ -18954,7 +19000,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 id4}@anchor{296}@anchor{gnat_rm/representation_clauses_and_pragmas storage-size-clauses}@anchor{297}
+@anchor{gnat_rm/representation_clauses_and_pragmas id4}@anchor{299}@anchor{gnat_rm/representation_clauses_and_pragmas storage-size-clauses}@anchor{29a}
@section Storage_Size Clauses
@@ -19027,7 +19073,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{298}@anchor{gnat_rm/representation_clauses_and_pragmas size-of-variant-record-objects}@anchor{299}
+@anchor{gnat_rm/representation_clauses_and_pragmas id5}@anchor{29b}@anchor{gnat_rm/representation_clauses_and_pragmas size-of-variant-record-objects}@anchor{29c}
@section Size of Variant Record Objects
@@ -19137,7 +19183,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 biased-representation}@anchor{29a}@anchor{gnat_rm/representation_clauses_and_pragmas id6}@anchor{29b}
+@anchor{gnat_rm/representation_clauses_and_pragmas biased-representation}@anchor{29d}@anchor{gnat_rm/representation_clauses_and_pragmas id6}@anchor{29e}
@section Biased Representation
@@ -19175,7 +19221,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{29c}@anchor{gnat_rm/representation_clauses_and_pragmas value-size-and-object-size-clauses}@anchor{29d}
+@anchor{gnat_rm/representation_clauses_and_pragmas id7}@anchor{29f}@anchor{gnat_rm/representation_clauses_and_pragmas value-size-and-object-size-clauses}@anchor{2a0}
@section Value_Size and Object_Size Clauses
@@ -19491,7 +19537,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 component-size-clauses}@anchor{29e}@anchor{gnat_rm/representation_clauses_and_pragmas id8}@anchor{29f}
+@anchor{gnat_rm/representation_clauses_and_pragmas component-size-clauses}@anchor{2a1}@anchor{gnat_rm/representation_clauses_and_pragmas id8}@anchor{2a2}
@section Component_Size Clauses
@@ -19539,7 +19585,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{2a0}@anchor{gnat_rm/representation_clauses_and_pragmas id9}@anchor{2a1}
+@anchor{gnat_rm/representation_clauses_and_pragmas bit-order-clauses}@anchor{2a3}@anchor{gnat_rm/representation_clauses_and_pragmas id9}@anchor{2a4}
@section Bit_Order Clauses
@@ -19645,7 +19691,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 effect-of-bit-order-on-byte-ordering}@anchor{2a2}@anchor{gnat_rm/representation_clauses_and_pragmas id10}@anchor{2a3}
+@anchor{gnat_rm/representation_clauses_and_pragmas effect-of-bit-order-on-byte-ordering}@anchor{2a5}@anchor{gnat_rm/representation_clauses_and_pragmas id10}@anchor{2a6}
@section Effect of Bit_Order on Byte Ordering
@@ -19902,7 +19948,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 id11}@anchor{2a4}@anchor{gnat_rm/representation_clauses_and_pragmas pragma-pack-for-arrays}@anchor{2a5}
+@anchor{gnat_rm/representation_clauses_and_pragmas id11}@anchor{2a7}@anchor{gnat_rm/representation_clauses_and_pragmas pragma-pack-for-arrays}@anchor{2a8}
@section Pragma Pack for Arrays
@@ -20022,7 +20068,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 id12}@anchor{2a6}@anchor{gnat_rm/representation_clauses_and_pragmas pragma-pack-for-records}@anchor{2a7}
+@anchor{gnat_rm/representation_clauses_and_pragmas id12}@anchor{2a9}@anchor{gnat_rm/representation_clauses_and_pragmas pragma-pack-for-records}@anchor{2aa}
@section Pragma Pack for Records
@@ -20106,7 +20152,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{2a8}@anchor{gnat_rm/representation_clauses_and_pragmas record-representation-clauses}@anchor{2a9}
+@anchor{gnat_rm/representation_clauses_and_pragmas id13}@anchor{2ab}@anchor{gnat_rm/representation_clauses_and_pragmas record-representation-clauses}@anchor{2ac}
@section Record Representation Clauses
@@ -20185,7 +20231,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{2aa}@anchor{gnat_rm/representation_clauses_and_pragmas id14}@anchor{2ab}
+@anchor{gnat_rm/representation_clauses_and_pragmas handling-of-records-with-holes}@anchor{2ad}@anchor{gnat_rm/representation_clauses_and_pragmas id14}@anchor{2ae}
@section Handling of Records with Holes
@@ -20261,7 +20307,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{2ac}@anchor{gnat_rm/representation_clauses_and_pragmas id15}@anchor{2ad}
+@anchor{gnat_rm/representation_clauses_and_pragmas enumeration-clauses}@anchor{2af}@anchor{gnat_rm/representation_clauses_and_pragmas id15}@anchor{2b0}
@section Enumeration Clauses
@@ -20304,7 +20350,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 address-clauses}@anchor{2ae}@anchor{gnat_rm/representation_clauses_and_pragmas id16}@anchor{2af}
+@anchor{gnat_rm/representation_clauses_and_pragmas address-clauses}@anchor{2b1}@anchor{gnat_rm/representation_clauses_and_pragmas id16}@anchor{2b2}
@section Address Clauses
@@ -20644,7 +20690,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{2b0}@anchor{gnat_rm/representation_clauses_and_pragmas use-of-address-clauses-for-memory-mapped-i-o}@anchor{2b1}
+@anchor{gnat_rm/representation_clauses_and_pragmas id17}@anchor{2b3}@anchor{gnat_rm/representation_clauses_and_pragmas use-of-address-clauses-for-memory-mapped-i-o}@anchor{2b4}
@section Use of Address Clauses for Memory-Mapped I/O
@@ -20702,7 +20748,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 effect-of-convention-on-representation}@anchor{2b2}@anchor{gnat_rm/representation_clauses_and_pragmas id18}@anchor{2b3}
+@anchor{gnat_rm/representation_clauses_and_pragmas effect-of-convention-on-representation}@anchor{2b5}@anchor{gnat_rm/representation_clauses_and_pragmas id18}@anchor{2b6}
@section Effect of Convention on Representation
@@ -20716,7 +20762,7 @@ conventions, and for example records are laid out in a manner that is
consistent with C. This means that specifying convention C (for example)
has no effect.
-There are four exceptions to this general rule:
+There are three exceptions to this general rule:
@itemize *
@@ -20780,7 +20826,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{2b4}@anchor{gnat_rm/representation_clauses_and_pragmas id19}@anchor{2b5}
+@anchor{gnat_rm/representation_clauses_and_pragmas conventions-and-anonymous-access-types}@anchor{2b7}@anchor{gnat_rm/representation_clauses_and_pragmas id19}@anchor{2b8}
@section Conventions and Anonymous Access Types
@@ -20856,7 +20902,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 determining-the-representations-chosen-by-gnat}@anchor{2b6}@anchor{gnat_rm/representation_clauses_and_pragmas id20}@anchor{2b7}
+@anchor{gnat_rm/representation_clauses_and_pragmas determining-the-representations-chosen-by-gnat}@anchor{2b9}@anchor{gnat_rm/representation_clauses_and_pragmas id20}@anchor{2ba}
@section Determining the Representations chosen by GNAT
@@ -21008,7 +21054,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 doc}@anchor{2b8}@anchor{gnat_rm/standard_library_routines id1}@anchor{2b9}@anchor{gnat_rm/standard_library_routines standard-library-routines}@anchor{e}
+@anchor{gnat_rm/standard_library_routines doc}@anchor{2bb}@anchor{gnat_rm/standard_library_routines id1}@anchor{2bc}@anchor{gnat_rm/standard_library_routines standard-library-routines}@anchor{e}
@chapter Standard Library Routines
@@ -21835,7 +21881,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 doc}@anchor{2ba}@anchor{gnat_rm/the_implementation_of_standard_i_o id1}@anchor{2bb}@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{2bd}@anchor{gnat_rm/the_implementation_of_standard_i_o id1}@anchor{2be}@anchor{gnat_rm/the_implementation_of_standard_i_o the-implementation-of-standard-i-o}@anchor{f}
@chapter The Implementation of Standard I/O
@@ -21887,7 +21933,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 id2}@anchor{2bc}@anchor{gnat_rm/the_implementation_of_standard_i_o standard-i-o-packages}@anchor{2bd}
+@anchor{gnat_rm/the_implementation_of_standard_i_o id2}@anchor{2bf}@anchor{gnat_rm/the_implementation_of_standard_i_o standard-i-o-packages}@anchor{2c0}
@section Standard I/O Packages
@@ -21958,7 +22004,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{2be}@anchor{gnat_rm/the_implementation_of_standard_i_o id3}@anchor{2bf}
+@anchor{gnat_rm/the_implementation_of_standard_i_o form-strings}@anchor{2c1}@anchor{gnat_rm/the_implementation_of_standard_i_o id3}@anchor{2c2}
@section FORM Strings
@@ -21984,7 +22030,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{2c0}@anchor{gnat_rm/the_implementation_of_standard_i_o id4}@anchor{2c1}
+@anchor{gnat_rm/the_implementation_of_standard_i_o direct-io}@anchor{2c3}@anchor{gnat_rm/the_implementation_of_standard_i_o id4}@anchor{2c4}
@section Direct_IO
@@ -22003,7 +22049,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 id5}@anchor{2c2}@anchor{gnat_rm/the_implementation_of_standard_i_o sequential-io}@anchor{2c3}
+@anchor{gnat_rm/the_implementation_of_standard_i_o id5}@anchor{2c5}@anchor{gnat_rm/the_implementation_of_standard_i_o sequential-io}@anchor{2c6}
@section Sequential_IO
@@ -22050,7 +22096,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{2c4}@anchor{gnat_rm/the_implementation_of_standard_i_o text-io}@anchor{2c5}
+@anchor{gnat_rm/the_implementation_of_standard_i_o id6}@anchor{2c7}@anchor{gnat_rm/the_implementation_of_standard_i_o text-io}@anchor{2c8}
@section Text_IO
@@ -22133,7 +22179,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{2c6}@anchor{gnat_rm/the_implementation_of_standard_i_o stream-pointer-positioning}@anchor{2c7}
+@anchor{gnat_rm/the_implementation_of_standard_i_o id7}@anchor{2c9}@anchor{gnat_rm/the_implementation_of_standard_i_o stream-pointer-positioning}@anchor{2ca}
@subsection Stream Pointer Positioning
@@ -22169,7 +22215,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 id8}@anchor{2c8}@anchor{gnat_rm/the_implementation_of_standard_i_o reading-and-writing-non-regular-files}@anchor{2c9}
+@anchor{gnat_rm/the_implementation_of_standard_i_o id8}@anchor{2cb}@anchor{gnat_rm/the_implementation_of_standard_i_o reading-and-writing-non-regular-files}@anchor{2cc}
@subsection Reading and Writing Non-Regular Files
@@ -22220,7 +22266,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{2ca}@anchor{gnat_rm/the_implementation_of_standard_i_o id9}@anchor{2cb}
+@anchor{gnat_rm/the_implementation_of_standard_i_o get-immediate}@anchor{2cd}@anchor{gnat_rm/the_implementation_of_standard_i_o id9}@anchor{2ce}
@subsection Get_Immediate
@@ -22238,7 +22284,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{2cc}@anchor{gnat_rm/the_implementation_of_standard_i_o treating-text-io-files-as-streams}@anchor{2cd}
+@anchor{gnat_rm/the_implementation_of_standard_i_o id10}@anchor{2cf}@anchor{gnat_rm/the_implementation_of_standard_i_o treating-text-io-files-as-streams}@anchor{2d0}
@subsection Treating Text_IO Files as Streams
@@ -22254,7 +22300,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{2ce}@anchor{gnat_rm/the_implementation_of_standard_i_o text-io-extensions}@anchor{2cf}
+@anchor{gnat_rm/the_implementation_of_standard_i_o id11}@anchor{2d1}@anchor{gnat_rm/the_implementation_of_standard_i_o text-io-extensions}@anchor{2d2}
@subsection Text_IO Extensions
@@ -22282,7 +22328,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 id12}@anchor{2d0}@anchor{gnat_rm/the_implementation_of_standard_i_o text-io-facilities-for-unbounded-strings}@anchor{2d1}
+@anchor{gnat_rm/the_implementation_of_standard_i_o id12}@anchor{2d3}@anchor{gnat_rm/the_implementation_of_standard_i_o text-io-facilities-for-unbounded-strings}@anchor{2d4}
@subsection Text_IO Facilities for Unbounded Strings
@@ -22330,7 +22376,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 id13}@anchor{2d2}@anchor{gnat_rm/the_implementation_of_standard_i_o wide-text-io}@anchor{2d3}
+@anchor{gnat_rm/the_implementation_of_standard_i_o id13}@anchor{2d5}@anchor{gnat_rm/the_implementation_of_standard_i_o wide-text-io}@anchor{2d6}
@section Wide_Text_IO
@@ -22577,12 +22623,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 id14}@anchor{2d4}@anchor{gnat_rm/the_implementation_of_standard_i_o stream-pointer-positioning-1}@anchor{2d5}
+@anchor{gnat_rm/the_implementation_of_standard_i_o id14}@anchor{2d7}@anchor{gnat_rm/the_implementation_of_standard_i_o stream-pointer-positioning-1}@anchor{2d8}
@subsection Stream Pointer Positioning
@code{Ada.Wide_Text_IO} is similar to @code{Ada.Text_IO} in its handling
-of stream pointer positioning (@ref{2c5,,Text_IO}). There is one additional
+of stream pointer positioning (@ref{2c8,,Text_IO}). There is one additional
case:
If @code{Ada.Wide_Text_IO.Look_Ahead} reads a character outside the
@@ -22601,7 +22647,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 id15}@anchor{2d6}@anchor{gnat_rm/the_implementation_of_standard_i_o reading-and-writing-non-regular-files-1}@anchor{2d7}
+@anchor{gnat_rm/the_implementation_of_standard_i_o id15}@anchor{2d9}@anchor{gnat_rm/the_implementation_of_standard_i_o reading-and-writing-non-regular-files-1}@anchor{2da}
@subsection Reading and Writing Non-Regular Files
@@ -22612,7 +22658,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{2d8}@anchor{gnat_rm/the_implementation_of_standard_i_o wide-wide-text-io}@anchor{2d9}
+@anchor{gnat_rm/the_implementation_of_standard_i_o id16}@anchor{2db}@anchor{gnat_rm/the_implementation_of_standard_i_o wide-wide-text-io}@anchor{2dc}
@section Wide_Wide_Text_IO
@@ -22781,12 +22827,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 id17}@anchor{2da}@anchor{gnat_rm/the_implementation_of_standard_i_o stream-pointer-positioning-2}@anchor{2db}
+@anchor{gnat_rm/the_implementation_of_standard_i_o id17}@anchor{2dd}@anchor{gnat_rm/the_implementation_of_standard_i_o stream-pointer-positioning-2}@anchor{2de}
@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{2c5,,Text_IO}). There is one additional
+of stream pointer positioning (@ref{2c8,,Text_IO}). There is one additional
case:
If @code{Ada.Wide_Wide_Text_IO.Look_Ahead} reads a character outside the
@@ -22805,7 +22851,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{2dc}@anchor{gnat_rm/the_implementation_of_standard_i_o reading-and-writing-non-regular-files-2}@anchor{2dd}
+@anchor{gnat_rm/the_implementation_of_standard_i_o id18}@anchor{2df}@anchor{gnat_rm/the_implementation_of_standard_i_o reading-and-writing-non-regular-files-2}@anchor{2e0}
@subsection Reading and Writing Non-Regular Files
@@ -22816,7 +22862,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{2de}@anchor{gnat_rm/the_implementation_of_standard_i_o stream-io}@anchor{2df}
+@anchor{gnat_rm/the_implementation_of_standard_i_o id19}@anchor{2e1}@anchor{gnat_rm/the_implementation_of_standard_i_o stream-io}@anchor{2e2}
@section Stream_IO
@@ -22838,7 +22884,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{2e0}@anchor{gnat_rm/the_implementation_of_standard_i_o text-translation}@anchor{2e1}
+@anchor{gnat_rm/the_implementation_of_standard_i_o id20}@anchor{2e3}@anchor{gnat_rm/the_implementation_of_standard_i_o text-translation}@anchor{2e4}
@section Text Translation
@@ -22872,7 +22918,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{2e2}@anchor{gnat_rm/the_implementation_of_standard_i_o shared-files}@anchor{2e3}
+@anchor{gnat_rm/the_implementation_of_standard_i_o id21}@anchor{2e5}@anchor{gnat_rm/the_implementation_of_standard_i_o shared-files}@anchor{2e6}
@section Shared Files
@@ -22935,7 +22981,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{2e4}@anchor{gnat_rm/the_implementation_of_standard_i_o id22}@anchor{2e5}
+@anchor{gnat_rm/the_implementation_of_standard_i_o filenames-encoding}@anchor{2e7}@anchor{gnat_rm/the_implementation_of_standard_i_o id22}@anchor{2e8}
@section Filenames encoding
@@ -22975,7 +23021,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{2e6}@anchor{gnat_rm/the_implementation_of_standard_i_o id23}@anchor{2e7}
+@anchor{gnat_rm/the_implementation_of_standard_i_o file-content-encoding}@anchor{2e9}@anchor{gnat_rm/the_implementation_of_standard_i_o id23}@anchor{2ea}
@section File content encoding
@@ -23008,7 +23054,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 id24}@anchor{2e8}@anchor{gnat_rm/the_implementation_of_standard_i_o open-modes}@anchor{2e9}
+@anchor{gnat_rm/the_implementation_of_standard_i_o id24}@anchor{2eb}@anchor{gnat_rm/the_implementation_of_standard_i_o open-modes}@anchor{2ec}
@section Open Modes
@@ -23111,7 +23157,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 id25}@anchor{2ea}@anchor{gnat_rm/the_implementation_of_standard_i_o operations-on-c-streams}@anchor{2eb}
+@anchor{gnat_rm/the_implementation_of_standard_i_o id25}@anchor{2ed}@anchor{gnat_rm/the_implementation_of_standard_i_o operations-on-c-streams}@anchor{2ee}
@section Operations on C Streams
@@ -23271,7 +23317,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 id26}@anchor{2ec}@anchor{gnat_rm/the_implementation_of_standard_i_o interfacing-to-c-streams}@anchor{2ed}
+@anchor{gnat_rm/the_implementation_of_standard_i_o id26}@anchor{2ef}@anchor{gnat_rm/the_implementation_of_standard_i_o interfacing-to-c-streams}@anchor{2f0}
@section Interfacing to C Streams
@@ -23364,7 +23410,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 doc}@anchor{2ee}@anchor{gnat_rm/the_gnat_library id1}@anchor{2ef}@anchor{gnat_rm/the_gnat_library the-gnat-library}@anchor{10}
+@anchor{gnat_rm/the_gnat_library doc}@anchor{2f1}@anchor{gnat_rm/the_gnat_library id1}@anchor{2f2}@anchor{gnat_rm/the_gnat_library the-gnat-library}@anchor{10}
@chapter The GNAT Library
@@ -23549,7 +23595,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 ada-characters-latin-9-a-chlat9-ads}@anchor{2f0}@anchor{gnat_rm/the_gnat_library id2}@anchor{2f1}
+@anchor{gnat_rm/the_gnat_library ada-characters-latin-9-a-chlat9-ads}@anchor{2f3}@anchor{gnat_rm/the_gnat_library id2}@anchor{2f4}
@section @code{Ada.Characters.Latin_9} (@code{a-chlat9.ads})
@@ -23566,7 +23612,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-cwila9 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{2f2}@anchor{gnat_rm/the_gnat_library id3}@anchor{2f3}
+@anchor{gnat_rm/the_gnat_library ada-characters-wide-latin-1-a-cwila1-ads}@anchor{2f5}@anchor{gnat_rm/the_gnat_library id3}@anchor{2f6}
@section @code{Ada.Characters.Wide_Latin_1} (@code{a-cwila1.ads})
@@ -23583,7 +23629,7 @@ is specifically authorized by the Ada Reference Manual
(RM A.3.3(27)).
@node Ada Characters Wide_Latin_9 a-cwila9 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 ada-characters-wide-latin-9-a-cwila9-ads}@anchor{2f4}@anchor{gnat_rm/the_gnat_library id4}@anchor{2f5}
+@anchor{gnat_rm/the_gnat_library ada-characters-wide-latin-9-a-cwila9-ads}@anchor{2f7}@anchor{gnat_rm/the_gnat_library id4}@anchor{2f8}
@section @code{Ada.Characters.Wide_Latin_9} (@code{a-cwila9.ads})
@@ -23600,7 +23646,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-cwila9 ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library ada-characters-wide-wide-latin-1-a-chzla1-ads}@anchor{2f6}@anchor{gnat_rm/the_gnat_library id5}@anchor{2f7}
+@anchor{gnat_rm/the_gnat_library ada-characters-wide-wide-latin-1-a-chzla1-ads}@anchor{2f9}@anchor{gnat_rm/the_gnat_library id5}@anchor{2fa}
@section @code{Ada.Characters.Wide_Wide_Latin_1} (@code{a-chzla1.ads})
@@ -23617,7 +23663,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 Bounded_Holders a-coboho 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{2f8}@anchor{gnat_rm/the_gnat_library id6}@anchor{2f9}
+@anchor{gnat_rm/the_gnat_library ada-characters-wide-wide-latin-9-a-chzla9-ads}@anchor{2fb}@anchor{gnat_rm/the_gnat_library id6}@anchor{2fc}
@section @code{Ada.Characters.Wide_Wide_Latin_9} (@code{a-chzla9.ads})
@@ -23634,7 +23680,7 @@ is specifically authorized by the Ada Reference Manual
(RM A.3.3(27)).
@node Ada Containers Bounded_Holders a-coboho ads,Ada Command_Line Environment a-colien ads,Ada Characters Wide_Wide_Latin_9 a-chzla9 ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library ada-containers-bounded-holders-a-coboho-ads}@anchor{2fa}@anchor{gnat_rm/the_gnat_library id7}@anchor{2fb}
+@anchor{gnat_rm/the_gnat_library ada-containers-bounded-holders-a-coboho-ads}@anchor{2fd}@anchor{gnat_rm/the_gnat_library id7}@anchor{2fe}
@section @code{Ada.Containers.Bounded_Holders} (@code{a-coboho.ads})
@@ -23646,7 +23692,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{2fc}@anchor{gnat_rm/the_gnat_library id8}@anchor{2fd}
+@anchor{gnat_rm/the_gnat_library ada-command-line-environment-a-colien-ads}@anchor{2ff}@anchor{gnat_rm/the_gnat_library id8}@anchor{300}
@section @code{Ada.Command_Line.Environment} (@code{a-colien.ads})
@@ -23659,7 +23705,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 ada-command-line-remove-a-colire-ads}@anchor{2fe}@anchor{gnat_rm/the_gnat_library id9}@anchor{2ff}
+@anchor{gnat_rm/the_gnat_library ada-command-line-remove-a-colire-ads}@anchor{301}@anchor{gnat_rm/the_gnat_library id9}@anchor{302}
@section @code{Ada.Command_Line.Remove} (@code{a-colire.ads})
@@ -23677,7 +23723,7 @@ to further calls to the subprograms in @code{Ada.Command_Line}. These calls
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 ada-command-line-response-file-a-clrefi-ads}@anchor{300}@anchor{gnat_rm/the_gnat_library id10}@anchor{301}
+@anchor{gnat_rm/the_gnat_library ada-command-line-response-file-a-clrefi-ads}@anchor{303}@anchor{gnat_rm/the_gnat_library id10}@anchor{304}
@section @code{Ada.Command_Line.Response_File} (@code{a-clrefi.ads})
@@ -23697,7 +23743,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 ada-direct-io-c-streams-a-diocst-ads}@anchor{302}@anchor{gnat_rm/the_gnat_library id11}@anchor{303}
+@anchor{gnat_rm/the_gnat_library ada-direct-io-c-streams-a-diocst-ads}@anchor{305}@anchor{gnat_rm/the_gnat_library id11}@anchor{306}
@section @code{Ada.Direct_IO.C_Streams} (@code{a-diocst.ads})
@@ -23712,7 +23758,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 ada-exceptions-is-null-occurrence-a-einuoc-ads}@anchor{304}@anchor{gnat_rm/the_gnat_library id12}@anchor{305}
+@anchor{gnat_rm/the_gnat_library ada-exceptions-is-null-occurrence-a-einuoc-ads}@anchor{307}@anchor{gnat_rm/the_gnat_library id12}@anchor{308}
@section @code{Ada.Exceptions.Is_Null_Occurrence} (@code{a-einuoc.ads})
@@ -23726,7 +23772,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 ada-exceptions-last-chance-handler-a-elchha-ads}@anchor{306}@anchor{gnat_rm/the_gnat_library id13}@anchor{307}
+@anchor{gnat_rm/the_gnat_library ada-exceptions-last-chance-handler-a-elchha-ads}@anchor{309}@anchor{gnat_rm/the_gnat_library id13}@anchor{30a}
@section @code{Ada.Exceptions.Last_Chance_Handler} (@code{a-elchha.ads})
@@ -23740,7 +23786,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{308}@anchor{gnat_rm/the_gnat_library id14}@anchor{309}
+@anchor{gnat_rm/the_gnat_library ada-exceptions-traceback-a-exctra-ads}@anchor{30b}@anchor{gnat_rm/the_gnat_library id14}@anchor{30c}
@section @code{Ada.Exceptions.Traceback} (@code{a-exctra.ads})
@@ -23753,7 +23799,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{30a}@anchor{gnat_rm/the_gnat_library id15}@anchor{30b}
+@anchor{gnat_rm/the_gnat_library ada-sequential-io-c-streams-a-siocst-ads}@anchor{30d}@anchor{gnat_rm/the_gnat_library id15}@anchor{30e}
@section @code{Ada.Sequential_IO.C_Streams} (@code{a-siocst.ads})
@@ -23768,7 +23814,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 ada-streams-stream-io-c-streams-a-ssicst-ads}@anchor{30c}@anchor{gnat_rm/the_gnat_library id16}@anchor{30d}
+@anchor{gnat_rm/the_gnat_library ada-streams-stream-io-c-streams-a-ssicst-ads}@anchor{30f}@anchor{gnat_rm/the_gnat_library id16}@anchor{310}
@section @code{Ada.Streams.Stream_IO.C_Streams} (@code{a-ssicst.ads})
@@ -23783,7 +23829,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{30e}@anchor{gnat_rm/the_gnat_library id17}@anchor{30f}
+@anchor{gnat_rm/the_gnat_library ada-strings-unbounded-text-io-a-suteio-ads}@anchor{311}@anchor{gnat_rm/the_gnat_library id17}@anchor{312}
@section @code{Ada.Strings.Unbounded.Text_IO} (@code{a-suteio.ads})
@@ -23800,7 +23846,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 ada-strings-wide-unbounded-wide-text-io-a-swuwti-ads}@anchor{310}@anchor{gnat_rm/the_gnat_library id18}@anchor{311}
+@anchor{gnat_rm/the_gnat_library ada-strings-wide-unbounded-wide-text-io-a-swuwti-ads}@anchor{313}@anchor{gnat_rm/the_gnat_library id18}@anchor{314}
@section @code{Ada.Strings.Wide_Unbounded.Wide_Text_IO} (@code{a-swuwti.ads})
@@ -23817,7 +23863,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 ada-strings-wide-wide-unbounded-wide-wide-text-io-a-szuzti-ads}@anchor{312}@anchor{gnat_rm/the_gnat_library id19}@anchor{313}
+@anchor{gnat_rm/the_gnat_library ada-strings-wide-wide-unbounded-wide-wide-text-io-a-szuzti-ads}@anchor{315}@anchor{gnat_rm/the_gnat_library id19}@anchor{316}
@section @code{Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO} (@code{a-szuzti.ads})
@@ -23834,7 +23880,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{314}@anchor{gnat_rm/the_gnat_library id20}@anchor{315}
+@anchor{gnat_rm/the_gnat_library ada-task-initialization-a-tasini-ads}@anchor{317}@anchor{gnat_rm/the_gnat_library id20}@anchor{318}
@section @code{Ada.Task_Initialization} (@code{a-tasini.ads})
@@ -23846,7 +23892,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{316}@anchor{gnat_rm/the_gnat_library id21}@anchor{317}
+@anchor{gnat_rm/the_gnat_library ada-text-io-c-streams-a-tiocst-ads}@anchor{319}@anchor{gnat_rm/the_gnat_library id21}@anchor{31a}
@section @code{Ada.Text_IO.C_Streams} (@code{a-tiocst.ads})
@@ -23861,7 +23907,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{318}@anchor{gnat_rm/the_gnat_library id22}@anchor{319}
+@anchor{gnat_rm/the_gnat_library ada-text-io-reset-standard-files-a-tirsfi-ads}@anchor{31b}@anchor{gnat_rm/the_gnat_library id22}@anchor{31c}
@section @code{Ada.Text_IO.Reset_Standard_Files} (@code{a-tirsfi.ads})
@@ -23876,7 +23922,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 ada-wide-characters-unicode-a-wichun-ads}@anchor{31a}@anchor{gnat_rm/the_gnat_library id23}@anchor{31b}
+@anchor{gnat_rm/the_gnat_library ada-wide-characters-unicode-a-wichun-ads}@anchor{31d}@anchor{gnat_rm/the_gnat_library id23}@anchor{31e}
@section @code{Ada.Wide_Characters.Unicode} (@code{a-wichun.ads})
@@ -23889,7 +23935,7 @@ This package provides subprograms that allow categorization of
Wide_Character values according to Unicode categories.
@node Ada Wide_Text_IO C_Streams a-wtcstr ads,Ada Wide_Text_IO Reset_Standard_Files a-wrstfi ads,Ada Wide_Characters Unicode a-wichun ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library ada-wide-text-io-c-streams-a-wtcstr-ads}@anchor{31c}@anchor{gnat_rm/the_gnat_library id24}@anchor{31d}
+@anchor{gnat_rm/the_gnat_library ada-wide-text-io-c-streams-a-wtcstr-ads}@anchor{31f}@anchor{gnat_rm/the_gnat_library id24}@anchor{320}
@section @code{Ada.Wide_Text_IO.C_Streams} (@code{a-wtcstr.ads})
@@ -23904,7 +23950,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{31e}@anchor{gnat_rm/the_gnat_library id25}@anchor{31f}
+@anchor{gnat_rm/the_gnat_library ada-wide-text-io-reset-standard-files-a-wrstfi-ads}@anchor{321}@anchor{gnat_rm/the_gnat_library id25}@anchor{322}
@section @code{Ada.Wide_Text_IO.Reset_Standard_Files} (@code{a-wrstfi.ads})
@@ -23919,7 +23965,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 ada-wide-wide-characters-unicode-a-zchuni-ads}@anchor{320}@anchor{gnat_rm/the_gnat_library id26}@anchor{321}
+@anchor{gnat_rm/the_gnat_library ada-wide-wide-characters-unicode-a-zchuni-ads}@anchor{323}@anchor{gnat_rm/the_gnat_library id26}@anchor{324}
@section @code{Ada.Wide_Wide_Characters.Unicode} (@code{a-zchuni.ads})
@@ -23932,7 +23978,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 ada-wide-wide-text-io-c-streams-a-ztcstr-ads}@anchor{322}@anchor{gnat_rm/the_gnat_library id27}@anchor{323}
+@anchor{gnat_rm/the_gnat_library ada-wide-wide-text-io-c-streams-a-ztcstr-ads}@anchor{325}@anchor{gnat_rm/the_gnat_library id27}@anchor{326}
@section @code{Ada.Wide_Wide_Text_IO.C_Streams} (@code{a-ztcstr.ads})
@@ -23947,7 +23993,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{324}@anchor{gnat_rm/the_gnat_library id28}@anchor{325}
+@anchor{gnat_rm/the_gnat_library ada-wide-wide-text-io-reset-standard-files-a-zrstfi-ads}@anchor{327}@anchor{gnat_rm/the_gnat_library id28}@anchor{328}
@section @code{Ada.Wide_Wide_Text_IO.Reset_Standard_Files} (@code{a-zrstfi.ads})
@@ -23962,7 +24008,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{326}@anchor{gnat_rm/the_gnat_library id29}@anchor{327}
+@anchor{gnat_rm/the_gnat_library gnat-altivec-g-altive-ads}@anchor{329}@anchor{gnat_rm/the_gnat_library id29}@anchor{32a}
@section @code{GNAT.Altivec} (@code{g-altive.ads})
@@ -23975,7 +24021,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{328}@anchor{gnat_rm/the_gnat_library id30}@anchor{329}
+@anchor{gnat_rm/the_gnat_library gnat-altivec-conversions-g-altcon-ads}@anchor{32b}@anchor{gnat_rm/the_gnat_library id30}@anchor{32c}
@section @code{GNAT.Altivec.Conversions} (@code{g-altcon.ads})
@@ -23986,7 +24032,7 @@ binding.
This package provides the Vector/View conversion routines.
@node GNAT Altivec Vector_Operations g-alveop ads,GNAT Altivec Vector_Types g-alvety ads,GNAT Altivec Conversions g-altcon ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-altivec-vector-operations-g-alveop-ads}@anchor{32a}@anchor{gnat_rm/the_gnat_library id31}@anchor{32b}
+@anchor{gnat_rm/the_gnat_library gnat-altivec-vector-operations-g-alveop-ads}@anchor{32d}@anchor{gnat_rm/the_gnat_library id31}@anchor{32e}
@section @code{GNAT.Altivec.Vector_Operations} (@code{g-alveop.ads})
@@ -24000,7 +24046,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{32c}@anchor{gnat_rm/the_gnat_library id32}@anchor{32d}
+@anchor{gnat_rm/the_gnat_library gnat-altivec-vector-types-g-alvety-ads}@anchor{32f}@anchor{gnat_rm/the_gnat_library id32}@anchor{330}
@section @code{GNAT.Altivec.Vector_Types} (@code{g-alvety.ads})
@@ -24012,7 +24058,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{32e}@anchor{gnat_rm/the_gnat_library id33}@anchor{32f}
+@anchor{gnat_rm/the_gnat_library gnat-altivec-vector-views-g-alvevi-ads}@anchor{331}@anchor{gnat_rm/the_gnat_library id33}@anchor{332}
@section @code{GNAT.Altivec.Vector_Views} (@code{g-alvevi.ads})
@@ -24027,7 +24073,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{330}@anchor{gnat_rm/the_gnat_library id34}@anchor{331}
+@anchor{gnat_rm/the_gnat_library gnat-array-split-g-arrspl-ads}@anchor{333}@anchor{gnat_rm/the_gnat_library id34}@anchor{334}
@section @code{GNAT.Array_Split} (@code{g-arrspl.ads})
@@ -24040,7 +24086,7 @@ an array wherever the separators appear, and provide direct access
to the resulting slices.
@node GNAT AWK g-awk ads,GNAT Binary_Search g-binsea ads,GNAT Array_Split g-arrspl ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-awk-g-awk-ads}@anchor{332}@anchor{gnat_rm/the_gnat_library id35}@anchor{333}
+@anchor{gnat_rm/the_gnat_library gnat-awk-g-awk-ads}@anchor{335}@anchor{gnat_rm/the_gnat_library id35}@anchor{336}
@section @code{GNAT.AWK} (@code{g-awk.ads})
@@ -24055,7 +24101,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 Binary_Search g-binsea ads,GNAT Bind_Environment g-binenv ads,GNAT AWK g-awk ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-binary-search-g-binsea-ads}@anchor{334}@anchor{gnat_rm/the_gnat_library id36}@anchor{335}
+@anchor{gnat_rm/the_gnat_library gnat-binary-search-g-binsea-ads}@anchor{337}@anchor{gnat_rm/the_gnat_library id36}@anchor{338}
@section @code{GNAT.Binary_Search} (@code{g-binsea.ads})
@@ -24067,7 +24113,7 @@ Allow binary search of a sorted array (or of an array-like container;
the generic does not reference the array directly).
@node GNAT Bind_Environment g-binenv ads,GNAT Branch_Prediction g-brapre ads,GNAT Binary_Search g-binsea ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-bind-environment-g-binenv-ads}@anchor{336}@anchor{gnat_rm/the_gnat_library id37}@anchor{337}
+@anchor{gnat_rm/the_gnat_library gnat-bind-environment-g-binenv-ads}@anchor{339}@anchor{gnat_rm/the_gnat_library id37}@anchor{33a}
@section @code{GNAT.Bind_Environment} (@code{g-binenv.ads})
@@ -24080,7 +24126,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 gnat-branch-prediction-g-brapre-ads}@anchor{338}@anchor{gnat_rm/the_gnat_library id38}@anchor{339}
+@anchor{gnat_rm/the_gnat_library gnat-branch-prediction-g-brapre-ads}@anchor{33b}@anchor{gnat_rm/the_gnat_library id38}@anchor{33c}
@section @code{GNAT.Branch_Prediction} (@code{g-brapre.ads})
@@ -24091,7 +24137,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{33a}@anchor{gnat_rm/the_gnat_library id39}@anchor{33b}
+@anchor{gnat_rm/the_gnat_library gnat-bounded-buffers-g-boubuf-ads}@anchor{33d}@anchor{gnat_rm/the_gnat_library id39}@anchor{33e}
@section @code{GNAT.Bounded_Buffers} (@code{g-boubuf.ads})
@@ -24106,7 +24152,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{33c}@anchor{gnat_rm/the_gnat_library id40}@anchor{33d}
+@anchor{gnat_rm/the_gnat_library gnat-bounded-mailboxes-g-boumai-ads}@anchor{33f}@anchor{gnat_rm/the_gnat_library id40}@anchor{340}
@section @code{GNAT.Bounded_Mailboxes} (@code{g-boumai.ads})
@@ -24119,7 +24165,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{33e}@anchor{gnat_rm/the_gnat_library id41}@anchor{33f}
+@anchor{gnat_rm/the_gnat_library gnat-bubble-sort-g-bubsor-ads}@anchor{341}@anchor{gnat_rm/the_gnat_library id41}@anchor{342}
@section @code{GNAT.Bubble_Sort} (@code{g-bubsor.ads})
@@ -24134,7 +24180,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 gnat-bubble-sort-a-g-busora-ads}@anchor{340}@anchor{gnat_rm/the_gnat_library id42}@anchor{341}
+@anchor{gnat_rm/the_gnat_library gnat-bubble-sort-a-g-busora-ads}@anchor{343}@anchor{gnat_rm/the_gnat_library id42}@anchor{344}
@section @code{GNAT.Bubble_Sort_A} (@code{g-busora.ads})
@@ -24150,7 +24196,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{342}@anchor{gnat_rm/the_gnat_library id43}@anchor{343}
+@anchor{gnat_rm/the_gnat_library gnat-bubble-sort-g-g-busorg-ads}@anchor{345}@anchor{gnat_rm/the_gnat_library id43}@anchor{346}
@section @code{GNAT.Bubble_Sort_G} (@code{g-busorg.ads})
@@ -24166,7 +24212,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{344}@anchor{gnat_rm/the_gnat_library id44}@anchor{345}
+@anchor{gnat_rm/the_gnat_library gnat-byte-order-mark-g-byorma-ads}@anchor{347}@anchor{gnat_rm/the_gnat_library id44}@anchor{348}
@section @code{GNAT.Byte_Order_Mark} (@code{g-byorma.ads})
@@ -24182,7 +24228,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{346}@anchor{gnat_rm/the_gnat_library id45}@anchor{347}
+@anchor{gnat_rm/the_gnat_library gnat-byte-swapping-g-bytswa-ads}@anchor{349}@anchor{gnat_rm/the_gnat_library id45}@anchor{34a}
@section @code{GNAT.Byte_Swapping} (@code{g-bytswa.ads})
@@ -24196,7 +24242,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 gnat-calendar-g-calend-ads}@anchor{348}@anchor{gnat_rm/the_gnat_library id46}@anchor{349}
+@anchor{gnat_rm/the_gnat_library gnat-calendar-g-calend-ads}@anchor{34b}@anchor{gnat_rm/the_gnat_library id46}@anchor{34c}
@section @code{GNAT.Calendar} (@code{g-calend.ads})
@@ -24210,7 +24256,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 gnat-calendar-time-io-g-catiio-ads}@anchor{34a}@anchor{gnat_rm/the_gnat_library id47}@anchor{34b}
+@anchor{gnat_rm/the_gnat_library gnat-calendar-time-io-g-catiio-ads}@anchor{34d}@anchor{gnat_rm/the_gnat_library id47}@anchor{34e}
@section @code{GNAT.Calendar.Time_IO} (@code{g-catiio.ads})
@@ -24221,7 +24267,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 gnat-crc32-g-crc32-ads}@anchor{34c}@anchor{gnat_rm/the_gnat_library id48}@anchor{34d}
+@anchor{gnat_rm/the_gnat_library gnat-crc32-g-crc32-ads}@anchor{34f}@anchor{gnat_rm/the_gnat_library id48}@anchor{350}
@section @code{GNAT.CRC32} (@code{g-crc32.ads})
@@ -24238,7 +24284,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 gnat-case-util-g-casuti-ads}@anchor{34e}@anchor{gnat_rm/the_gnat_library id49}@anchor{34f}
+@anchor{gnat_rm/the_gnat_library gnat-case-util-g-casuti-ads}@anchor{351}@anchor{gnat_rm/the_gnat_library id49}@anchor{352}
@section @code{GNAT.Case_Util} (@code{g-casuti.ads})
@@ -24253,7 +24299,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 gnat-cgi-g-cgi-ads}@anchor{350}@anchor{gnat_rm/the_gnat_library id50}@anchor{351}
+@anchor{gnat_rm/the_gnat_library gnat-cgi-g-cgi-ads}@anchor{353}@anchor{gnat_rm/the_gnat_library id50}@anchor{354}
@section @code{GNAT.CGI} (@code{g-cgi.ads})
@@ -24268,7 +24314,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{352}@anchor{gnat_rm/the_gnat_library id51}@anchor{353}
+@anchor{gnat_rm/the_gnat_library gnat-cgi-cookie-g-cgicoo-ads}@anchor{355}@anchor{gnat_rm/the_gnat_library id51}@anchor{356}
@section @code{GNAT.CGI.Cookie} (@code{g-cgicoo.ads})
@@ -24283,7 +24329,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{354}@anchor{gnat_rm/the_gnat_library id52}@anchor{355}
+@anchor{gnat_rm/the_gnat_library gnat-cgi-debug-g-cgideb-ads}@anchor{357}@anchor{gnat_rm/the_gnat_library id52}@anchor{358}
@section @code{GNAT.CGI.Debug} (@code{g-cgideb.ads})
@@ -24295,7 +24341,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 gnat-command-line-g-comlin-ads}@anchor{356}@anchor{gnat_rm/the_gnat_library id53}@anchor{357}
+@anchor{gnat_rm/the_gnat_library gnat-command-line-g-comlin-ads}@anchor{359}@anchor{gnat_rm/the_gnat_library id53}@anchor{35a}
@section @code{GNAT.Command_Line} (@code{g-comlin.ads})
@@ -24308,7 +24354,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{358}@anchor{gnat_rm/the_gnat_library id54}@anchor{359}
+@anchor{gnat_rm/the_gnat_library gnat-compiler-version-g-comver-ads}@anchor{35b}@anchor{gnat_rm/the_gnat_library id54}@anchor{35c}
@section @code{GNAT.Compiler_Version} (@code{g-comver.ads})
@@ -24326,7 +24372,7 @@ of the compiler if a consistent tool set is used to compile all units
of a partition).
@node GNAT Ctrl_C g-ctrl_c ads,GNAT Current_Exception g-curexc ads,GNAT Compiler_Version g-comver ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-ctrl-c-g-ctrl-c-ads}@anchor{35a}@anchor{gnat_rm/the_gnat_library id55}@anchor{35b}
+@anchor{gnat_rm/the_gnat_library gnat-ctrl-c-g-ctrl-c-ads}@anchor{35d}@anchor{gnat_rm/the_gnat_library id55}@anchor{35e}
@section @code{GNAT.Ctrl_C} (@code{g-ctrl_c.ads})
@@ -24337,7 +24383,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 gnat-current-exception-g-curexc-ads}@anchor{35c}@anchor{gnat_rm/the_gnat_library id56}@anchor{35d}
+@anchor{gnat_rm/the_gnat_library gnat-current-exception-g-curexc-ads}@anchor{35f}@anchor{gnat_rm/the_gnat_library id56}@anchor{360}
@section @code{GNAT.Current_Exception} (@code{g-curexc.ads})
@@ -24354,7 +24400,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{35e}@anchor{gnat_rm/the_gnat_library id57}@anchor{35f}
+@anchor{gnat_rm/the_gnat_library gnat-debug-pools-g-debpoo-ads}@anchor{361}@anchor{gnat_rm/the_gnat_library id57}@anchor{362}
@section @code{GNAT.Debug_Pools} (@code{g-debpoo.ads})
@@ -24371,7 +24417,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{360}@anchor{gnat_rm/the_gnat_library id58}@anchor{361}
+@anchor{gnat_rm/the_gnat_library gnat-debug-utilities-g-debuti-ads}@anchor{363}@anchor{gnat_rm/the_gnat_library id58}@anchor{364}
@section @code{GNAT.Debug_Utilities} (@code{g-debuti.ads})
@@ -24384,7 +24430,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{362}@anchor{gnat_rm/the_gnat_library id59}@anchor{363}
+@anchor{gnat_rm/the_gnat_library gnat-decode-string-g-decstr-ads}@anchor{365}@anchor{gnat_rm/the_gnat_library id59}@anchor{366}
@section @code{GNAT.Decode_String} (@code{g-decstr.ads})
@@ -24408,7 +24454,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{364}@anchor{gnat_rm/the_gnat_library id60}@anchor{365}
+@anchor{gnat_rm/the_gnat_library gnat-decode-utf8-string-g-deutst-ads}@anchor{367}@anchor{gnat_rm/the_gnat_library id60}@anchor{368}
@section @code{GNAT.Decode_UTF8_String} (@code{g-deutst.ads})
@@ -24429,7 +24475,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 gnat-directory-operations-g-dirope-ads}@anchor{366}@anchor{gnat_rm/the_gnat_library id61}@anchor{367}
+@anchor{gnat_rm/the_gnat_library gnat-directory-operations-g-dirope-ads}@anchor{369}@anchor{gnat_rm/the_gnat_library id61}@anchor{36a}
@section @code{GNAT.Directory_Operations} (@code{g-dirope.ads})
@@ -24442,7 +24488,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 gnat-directory-operations-iteration-g-diopit-ads}@anchor{368}@anchor{gnat_rm/the_gnat_library id62}@anchor{369}
+@anchor{gnat_rm/the_gnat_library gnat-directory-operations-iteration-g-diopit-ads}@anchor{36b}@anchor{gnat_rm/the_gnat_library id62}@anchor{36c}
@section @code{GNAT.Directory_Operations.Iteration} (@code{g-diopit.ads})
@@ -24454,7 +24500,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 gnat-dynamic-htables-g-dynhta-ads}@anchor{36a}@anchor{gnat_rm/the_gnat_library id63}@anchor{36b}
+@anchor{gnat_rm/the_gnat_library gnat-dynamic-htables-g-dynhta-ads}@anchor{36d}@anchor{gnat_rm/the_gnat_library id63}@anchor{36e}
@section @code{GNAT.Dynamic_HTables} (@code{g-dynhta.ads})
@@ -24472,7 +24518,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{36c}@anchor{gnat_rm/the_gnat_library id64}@anchor{36d}
+@anchor{gnat_rm/the_gnat_library gnat-dynamic-tables-g-dyntab-ads}@anchor{36f}@anchor{gnat_rm/the_gnat_library id64}@anchor{370}
@section @code{GNAT.Dynamic_Tables} (@code{g-dyntab.ads})
@@ -24492,7 +24538,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 gnat-encode-string-g-encstr-ads}@anchor{36e}@anchor{gnat_rm/the_gnat_library id65}@anchor{36f}
+@anchor{gnat_rm/the_gnat_library gnat-encode-string-g-encstr-ads}@anchor{371}@anchor{gnat_rm/the_gnat_library id65}@anchor{372}
@section @code{GNAT.Encode_String} (@code{g-encstr.ads})
@@ -24514,7 +24560,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{370}@anchor{gnat_rm/the_gnat_library id66}@anchor{371}
+@anchor{gnat_rm/the_gnat_library gnat-encode-utf8-string-g-enutst-ads}@anchor{373}@anchor{gnat_rm/the_gnat_library id66}@anchor{374}
@section @code{GNAT.Encode_UTF8_String} (@code{g-enutst.ads})
@@ -24535,7 +24581,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{372}@anchor{gnat_rm/the_gnat_library id67}@anchor{373}
+@anchor{gnat_rm/the_gnat_library gnat-exception-actions-g-excact-ads}@anchor{375}@anchor{gnat_rm/the_gnat_library id67}@anchor{376}
@section @code{GNAT.Exception_Actions} (@code{g-excact.ads})
@@ -24548,7 +24594,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{374}@anchor{gnat_rm/the_gnat_library id68}@anchor{375}
+@anchor{gnat_rm/the_gnat_library gnat-exception-traces-g-exctra-ads}@anchor{377}@anchor{gnat_rm/the_gnat_library id68}@anchor{378}
@section @code{GNAT.Exception_Traces} (@code{g-exctra.ads})
@@ -24562,7 +24608,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 gnat-exceptions-g-except-ads}@anchor{376}@anchor{gnat_rm/the_gnat_library id69}@anchor{377}
+@anchor{gnat_rm/the_gnat_library gnat-exceptions-g-except-ads}@anchor{379}@anchor{gnat_rm/the_gnat_library id69}@anchor{37a}
@section @code{GNAT.Exceptions} (@code{g-except.ads})
@@ -24583,7 +24629,7 @@ predefined exceptions, and for example allows 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 gnat-expect-g-expect-ads}@anchor{378}@anchor{gnat_rm/the_gnat_library id70}@anchor{379}
+@anchor{gnat_rm/the_gnat_library gnat-expect-g-expect-ads}@anchor{37b}@anchor{gnat_rm/the_gnat_library id70}@anchor{37c}
@section @code{GNAT.Expect} (@code{g-expect.ads})
@@ -24599,7 +24645,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 gnat-expect-tty-g-exptty-ads}@anchor{37a}@anchor{gnat_rm/the_gnat_library id71}@anchor{37b}
+@anchor{gnat_rm/the_gnat_library gnat-expect-tty-g-exptty-ads}@anchor{37d}@anchor{gnat_rm/the_gnat_library id71}@anchor{37e}
@section @code{GNAT.Expect.TTY} (@code{g-exptty.ads})
@@ -24611,7 +24657,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 gnat-float-control-g-flocon-ads}@anchor{37c}@anchor{gnat_rm/the_gnat_library id72}@anchor{37d}
+@anchor{gnat_rm/the_gnat_library gnat-float-control-g-flocon-ads}@anchor{37f}@anchor{gnat_rm/the_gnat_library id72}@anchor{380}
@section @code{GNAT.Float_Control} (@code{g-flocon.ads})
@@ -24625,7 +24671,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 Generic_Fast_Math_Functions g-gfmafu ads,GNAT Float_Control g-flocon ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-formatted-string-g-forstr-ads}@anchor{37e}@anchor{gnat_rm/the_gnat_library id73}@anchor{37f}
+@anchor{gnat_rm/the_gnat_library gnat-formatted-string-g-forstr-ads}@anchor{381}@anchor{gnat_rm/the_gnat_library id73}@anchor{382}
@section @code{GNAT.Formatted_String} (@code{g-forstr.ads})
@@ -24640,7 +24686,7 @@ derived from Integer, Float or enumerations as values for the
formatted string.
@node GNAT Generic_Fast_Math_Functions g-gfmafu ads,GNAT Heap_Sort g-heasor ads,GNAT Formatted_String g-forstr ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-generic-fast-math-functions-g-gfmafu-ads}@anchor{380}@anchor{gnat_rm/the_gnat_library id74}@anchor{381}
+@anchor{gnat_rm/the_gnat_library gnat-generic-fast-math-functions-g-gfmafu-ads}@anchor{383}@anchor{gnat_rm/the_gnat_library id74}@anchor{384}
@section @code{GNAT.Generic_Fast_Math_Functions} (@code{g-gfmafu.ads})
@@ -24658,7 +24704,7 @@ have a vector implementation that can be automatically used by the
compiler when auto-vectorization is enabled.
@node GNAT Heap_Sort g-heasor ads,GNAT Heap_Sort_A g-hesora ads,GNAT Generic_Fast_Math_Functions g-gfmafu ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-heap-sort-g-heasor-ads}@anchor{382}@anchor{gnat_rm/the_gnat_library id75}@anchor{383}
+@anchor{gnat_rm/the_gnat_library gnat-heap-sort-g-heasor-ads}@anchor{385}@anchor{gnat_rm/the_gnat_library id75}@anchor{386}
@section @code{GNAT.Heap_Sort} (@code{g-heasor.ads})
@@ -24672,7 +24718,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{384}@anchor{gnat_rm/the_gnat_library id76}@anchor{385}
+@anchor{gnat_rm/the_gnat_library gnat-heap-sort-a-g-hesora-ads}@anchor{387}@anchor{gnat_rm/the_gnat_library id76}@anchor{388}
@section @code{GNAT.Heap_Sort_A} (@code{g-hesora.ads})
@@ -24688,7 +24734,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 gnat-heap-sort-g-g-hesorg-ads}@anchor{386}@anchor{gnat_rm/the_gnat_library id77}@anchor{387}
+@anchor{gnat_rm/the_gnat_library gnat-heap-sort-g-g-hesorg-ads}@anchor{389}@anchor{gnat_rm/the_gnat_library id77}@anchor{38a}
@section @code{GNAT.Heap_Sort_G} (@code{g-hesorg.ads})
@@ -24702,7 +24748,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 gnat-htable-g-htable-ads}@anchor{388}@anchor{gnat_rm/the_gnat_library id78}@anchor{389}
+@anchor{gnat_rm/the_gnat_library gnat-htable-g-htable-ads}@anchor{38b}@anchor{gnat_rm/the_gnat_library id78}@anchor{38c}
@section @code{GNAT.HTable} (@code{g-htable.ads})
@@ -24715,7 +24761,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 gnat-io-g-io-ads}@anchor{38a}@anchor{gnat_rm/the_gnat_library id79}@anchor{38b}
+@anchor{gnat_rm/the_gnat_library gnat-io-g-io-ads}@anchor{38d}@anchor{gnat_rm/the_gnat_library id79}@anchor{38e}
@section @code{GNAT.IO} (@code{g-io.ads})
@@ -24731,7 +24777,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 gnat-io-aux-g-io-aux-ads}@anchor{38c}@anchor{gnat_rm/the_gnat_library id80}@anchor{38d}
+@anchor{gnat_rm/the_gnat_library gnat-io-aux-g-io-aux-ads}@anchor{38f}@anchor{gnat_rm/the_gnat_library id80}@anchor{390}
@section @code{GNAT.IO_Aux} (@code{g-io_aux.ads})
@@ -24745,7 +24791,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 gnat-lock-files-g-locfil-ads}@anchor{38e}@anchor{gnat_rm/the_gnat_library id81}@anchor{38f}
+@anchor{gnat_rm/the_gnat_library gnat-lock-files-g-locfil-ads}@anchor{391}@anchor{gnat_rm/the_gnat_library id81}@anchor{392}
@section @code{GNAT.Lock_Files} (@code{g-locfil.ads})
@@ -24759,7 +24805,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 gnat-mbbs-discrete-random-g-mbdira-ads}@anchor{390}@anchor{gnat_rm/the_gnat_library id82}@anchor{391}
+@anchor{gnat_rm/the_gnat_library gnat-mbbs-discrete-random-g-mbdira-ads}@anchor{393}@anchor{gnat_rm/the_gnat_library id82}@anchor{394}
@section @code{GNAT.MBBS_Discrete_Random} (@code{g-mbdira.ads})
@@ -24771,7 +24817,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 gnat-mbbs-float-random-g-mbflra-ads}@anchor{392}@anchor{gnat_rm/the_gnat_library id83}@anchor{393}
+@anchor{gnat_rm/the_gnat_library gnat-mbbs-float-random-g-mbflra-ads}@anchor{395}@anchor{gnat_rm/the_gnat_library id83}@anchor{396}
@section @code{GNAT.MBBS_Float_Random} (@code{g-mbflra.ads})
@@ -24783,7 +24829,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 gnat-md5-g-md5-ads}@anchor{394}@anchor{gnat_rm/the_gnat_library id84}@anchor{395}
+@anchor{gnat_rm/the_gnat_library gnat-md5-g-md5-ads}@anchor{397}@anchor{gnat_rm/the_gnat_library id84}@anchor{398}
@section @code{GNAT.MD5} (@code{g-md5.ads})
@@ -24796,7 +24842,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 gnat-memory-dump-g-memdum-ads}@anchor{396}@anchor{gnat_rm/the_gnat_library id85}@anchor{397}
+@anchor{gnat_rm/the_gnat_library gnat-memory-dump-g-memdum-ads}@anchor{399}@anchor{gnat_rm/the_gnat_library id85}@anchor{39a}
@section @code{GNAT.Memory_Dump} (@code{g-memdum.ads})
@@ -24809,7 +24855,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{398}@anchor{gnat_rm/the_gnat_library id86}@anchor{399}
+@anchor{gnat_rm/the_gnat_library gnat-most-recent-exception-g-moreex-ads}@anchor{39b}@anchor{gnat_rm/the_gnat_library id86}@anchor{39c}
@section @code{GNAT.Most_Recent_Exception} (@code{g-moreex.ads})
@@ -24823,7 +24869,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{39a}@anchor{gnat_rm/the_gnat_library id87}@anchor{39b}
+@anchor{gnat_rm/the_gnat_library gnat-os-lib-g-os-lib-ads}@anchor{39d}@anchor{gnat_rm/the_gnat_library id87}@anchor{39e}
@section @code{GNAT.OS_Lib} (@code{g-os_lib.ads})
@@ -24839,7 +24885,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{39c}@anchor{gnat_rm/the_gnat_library id88}@anchor{39d}
+@anchor{gnat_rm/the_gnat_library gnat-perfect-hash-generators-g-pehage-ads}@anchor{39f}@anchor{gnat_rm/the_gnat_library id88}@anchor{3a0}
@section @code{GNAT.Perfect_Hash_Generators} (@code{g-pehage.ads})
@@ -24857,7 +24903,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{39e}@anchor{gnat_rm/the_gnat_library id89}@anchor{39f}
+@anchor{gnat_rm/the_gnat_library gnat-random-numbers-g-rannum-ads}@anchor{3a1}@anchor{gnat_rm/the_gnat_library id89}@anchor{3a2}
@section @code{GNAT.Random_Numbers} (@code{g-rannum.ads})
@@ -24871,7 +24917,7 @@ however NOT suitable for situations requiring cryptographically secure
randomness.
@node GNAT Regexp g-regexp ads,GNAT Registry g-regist ads,GNAT Random_Numbers g-rannum ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-regexp-g-regexp-ads}@anchor{275}@anchor{gnat_rm/the_gnat_library id90}@anchor{3a0}
+@anchor{gnat_rm/the_gnat_library gnat-regexp-g-regexp-ads}@anchor{278}@anchor{gnat_rm/the_gnat_library id90}@anchor{3a3}
@section @code{GNAT.Regexp} (@code{g-regexp.ads})
@@ -24887,7 +24933,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 gnat-registry-g-regist-ads}@anchor{3a1}@anchor{gnat_rm/the_gnat_library id91}@anchor{3a2}
+@anchor{gnat_rm/the_gnat_library gnat-registry-g-regist-ads}@anchor{3a4}@anchor{gnat_rm/the_gnat_library id91}@anchor{3a5}
@section @code{GNAT.Registry} (@code{g-regist.ads})
@@ -24901,7 +24947,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 gnat-regpat-g-regpat-ads}@anchor{3a3}@anchor{gnat_rm/the_gnat_library id92}@anchor{3a4}
+@anchor{gnat_rm/the_gnat_library gnat-regpat-g-regpat-ads}@anchor{3a6}@anchor{gnat_rm/the_gnat_library id92}@anchor{3a7}
@section @code{GNAT.Regpat} (@code{g-regpat.ads})
@@ -24916,7 +24962,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 gnat-rewrite-data-g-rewdat-ads}@anchor{3a5}@anchor{gnat_rm/the_gnat_library id93}@anchor{3a6}
+@anchor{gnat_rm/the_gnat_library gnat-rewrite-data-g-rewdat-ads}@anchor{3a8}@anchor{gnat_rm/the_gnat_library id93}@anchor{3a9}
@section @code{GNAT.Rewrite_Data} (@code{g-rewdat.ads})
@@ -24930,7 +24976,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{3a7}@anchor{gnat_rm/the_gnat_library id94}@anchor{3a8}
+@anchor{gnat_rm/the_gnat_library gnat-secondary-stack-info-g-sestin-ads}@anchor{3aa}@anchor{gnat_rm/the_gnat_library id94}@anchor{3ab}
@section @code{GNAT.Secondary_Stack_Info} (@code{g-sestin.ads})
@@ -24942,7 +24988,7 @@ Provides 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 gnat-semaphores-g-semaph-ads}@anchor{3a9}@anchor{gnat_rm/the_gnat_library id95}@anchor{3aa}
+@anchor{gnat_rm/the_gnat_library gnat-semaphores-g-semaph-ads}@anchor{3ac}@anchor{gnat_rm/the_gnat_library id95}@anchor{3ad}
@section @code{GNAT.Semaphores} (@code{g-semaph.ads})
@@ -24953,7 +24999,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{3ab}@anchor{gnat_rm/the_gnat_library id96}@anchor{3ac}
+@anchor{gnat_rm/the_gnat_library gnat-serial-communications-g-sercom-ads}@anchor{3ae}@anchor{gnat_rm/the_gnat_library id96}@anchor{3af}
@section @code{GNAT.Serial_Communications} (@code{g-sercom.ads})
@@ -24965,7 +25011,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{3ad}@anchor{gnat_rm/the_gnat_library id97}@anchor{3ae}
+@anchor{gnat_rm/the_gnat_library gnat-sha1-g-sha1-ads}@anchor{3b0}@anchor{gnat_rm/the_gnat_library id97}@anchor{3b1}
@section @code{GNAT.SHA1} (@code{g-sha1.ads})
@@ -24978,7 +25024,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{3af}@anchor{gnat_rm/the_gnat_library id98}@anchor{3b0}
+@anchor{gnat_rm/the_gnat_library gnat-sha224-g-sha224-ads}@anchor{3b2}@anchor{gnat_rm/the_gnat_library id98}@anchor{3b3}
@section @code{GNAT.SHA224} (@code{g-sha224.ads})
@@ -24991,7 +25037,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{3b1}@anchor{gnat_rm/the_gnat_library id99}@anchor{3b2}
+@anchor{gnat_rm/the_gnat_library gnat-sha256-g-sha256-ads}@anchor{3b4}@anchor{gnat_rm/the_gnat_library id99}@anchor{3b5}
@section @code{GNAT.SHA256} (@code{g-sha256.ads})
@@ -25004,7 +25050,7 @@ and the HMAC-SHA256 message authentication function as described
in RFC 2104 and FIPS PUB 198.
@node GNAT SHA384 g-sha384 ads,GNAT SHA512 g-sha512 ads,GNAT SHA256 g-sha256 ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-sha384-g-sha384-ads}@anchor{3b3}@anchor{gnat_rm/the_gnat_library id100}@anchor{3b4}
+@anchor{gnat_rm/the_gnat_library gnat-sha384-g-sha384-ads}@anchor{3b6}@anchor{gnat_rm/the_gnat_library id100}@anchor{3b7}
@section @code{GNAT.SHA384} (@code{g-sha384.ads})
@@ -25017,7 +25063,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 gnat-sha512-g-sha512-ads}@anchor{3b5}@anchor{gnat_rm/the_gnat_library id101}@anchor{3b6}
+@anchor{gnat_rm/the_gnat_library gnat-sha512-g-sha512-ads}@anchor{3b8}@anchor{gnat_rm/the_gnat_library id101}@anchor{3b9}
@section @code{GNAT.SHA512} (@code{g-sha512.ads})
@@ -25030,7 +25076,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{3b7}@anchor{gnat_rm/the_gnat_library id102}@anchor{3b8}
+@anchor{gnat_rm/the_gnat_library gnat-signals-g-signal-ads}@anchor{3ba}@anchor{gnat_rm/the_gnat_library id102}@anchor{3bb}
@section @code{GNAT.Signals} (@code{g-signal.ads})
@@ -25042,7 +25088,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{3b9}@anchor{gnat_rm/the_gnat_library id103}@anchor{3ba}
+@anchor{gnat_rm/the_gnat_library gnat-sockets-g-socket-ads}@anchor{3bc}@anchor{gnat_rm/the_gnat_library id103}@anchor{3bd}
@section @code{GNAT.Sockets} (@code{g-socket.ads})
@@ -25057,7 +25103,7 @@ on all native GNAT ports and on VxWorks cross ports. 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{3bb}@anchor{gnat_rm/the_gnat_library id104}@anchor{3bc}
+@anchor{gnat_rm/the_gnat_library gnat-source-info-g-souinf-ads}@anchor{3be}@anchor{gnat_rm/the_gnat_library id104}@anchor{3bf}
@section @code{GNAT.Source_Info} (@code{g-souinf.ads})
@@ -25071,7 +25117,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{3bd}@anchor{gnat_rm/the_gnat_library id105}@anchor{3be}
+@anchor{gnat_rm/the_gnat_library gnat-spelling-checker-g-speche-ads}@anchor{3c0}@anchor{gnat_rm/the_gnat_library id105}@anchor{3c1}
@section @code{GNAT.Spelling_Checker} (@code{g-speche.ads})
@@ -25083,7 +25129,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{3bf}@anchor{gnat_rm/the_gnat_library id106}@anchor{3c0}
+@anchor{gnat_rm/the_gnat_library gnat-spelling-checker-generic-g-spchge-ads}@anchor{3c2}@anchor{gnat_rm/the_gnat_library id106}@anchor{3c3}
@section @code{GNAT.Spelling_Checker_Generic} (@code{g-spchge.ads})
@@ -25096,7 +25142,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{3c1}@anchor{gnat_rm/the_gnat_library id107}@anchor{3c2}
+@anchor{gnat_rm/the_gnat_library gnat-spitbol-patterns-g-spipat-ads}@anchor{3c4}@anchor{gnat_rm/the_gnat_library id107}@anchor{3c5}
@section @code{GNAT.Spitbol.Patterns} (@code{g-spipat.ads})
@@ -25112,7 +25158,7 @@ the SNOBOL4 dynamic pattern construction and matching capabilities, using the
efficient algorithm developed by Robert Dewar for the SPITBOL system.
@node GNAT Spitbol g-spitbo ads,GNAT Spitbol Table_Boolean g-sptabo ads,GNAT Spitbol Patterns g-spipat ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-spitbol-g-spitbo-ads}@anchor{3c3}@anchor{gnat_rm/the_gnat_library id108}@anchor{3c4}
+@anchor{gnat_rm/the_gnat_library gnat-spitbol-g-spitbo-ads}@anchor{3c6}@anchor{gnat_rm/the_gnat_library id108}@anchor{3c7}
@section @code{GNAT.Spitbol} (@code{g-spitbo.ads})
@@ -25127,7 +25173,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{3c5}@anchor{gnat_rm/the_gnat_library id109}@anchor{3c6}
+@anchor{gnat_rm/the_gnat_library gnat-spitbol-table-boolean-g-sptabo-ads}@anchor{3c8}@anchor{gnat_rm/the_gnat_library id109}@anchor{3c9}
@section @code{GNAT.Spitbol.Table_Boolean} (@code{g-sptabo.ads})
@@ -25142,7 +25188,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{3c7}@anchor{gnat_rm/the_gnat_library id110}@anchor{3c8}
+@anchor{gnat_rm/the_gnat_library gnat-spitbol-table-integer-g-sptain-ads}@anchor{3ca}@anchor{gnat_rm/the_gnat_library id110}@anchor{3cb}
@section @code{GNAT.Spitbol.Table_Integer} (@code{g-sptain.ads})
@@ -25159,7 +25205,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 gnat-spitbol-table-vstring-g-sptavs-ads}@anchor{3c9}@anchor{gnat_rm/the_gnat_library id111}@anchor{3ca}
+@anchor{gnat_rm/the_gnat_library gnat-spitbol-table-vstring-g-sptavs-ads}@anchor{3cc}@anchor{gnat_rm/the_gnat_library id111}@anchor{3cd}
@section @code{GNAT.Spitbol.Table_VString} (@code{g-sptavs.ads})
@@ -25176,7 +25222,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 gnat-sse-g-sse-ads}@anchor{3cb}@anchor{gnat_rm/the_gnat_library id112}@anchor{3cc}
+@anchor{gnat_rm/the_gnat_library gnat-sse-g-sse-ads}@anchor{3ce}@anchor{gnat_rm/the_gnat_library id112}@anchor{3cf}
@section @code{GNAT.SSE} (@code{g-sse.ads})
@@ -25188,7 +25234,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{3cd}@anchor{gnat_rm/the_gnat_library id113}@anchor{3ce}
+@anchor{gnat_rm/the_gnat_library gnat-sse-vector-types-g-ssvety-ads}@anchor{3d0}@anchor{gnat_rm/the_gnat_library id113}@anchor{3d1}
@section @code{GNAT.SSE.Vector_Types} (@code{g-ssvety.ads})
@@ -25197,7 +25243,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{3cf}@anchor{gnat_rm/the_gnat_library id114}@anchor{3d0}
+@anchor{gnat_rm/the_gnat_library gnat-string-hash-g-strhas-ads}@anchor{3d2}@anchor{gnat_rm/the_gnat_library id114}@anchor{3d3}
@section @code{GNAT.String_Hash} (@code{g-strhas.ads})
@@ -25209,7 +25255,7 @@ Provides a generic hash function working on arrays of scalars. Both the scalar
type and the hash result type are parameters.
@node GNAT Strings g-string ads,GNAT String_Split g-strspl ads,GNAT String_Hash g-strhas ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-strings-g-string-ads}@anchor{3d1}@anchor{gnat_rm/the_gnat_library id115}@anchor{3d2}
+@anchor{gnat_rm/the_gnat_library gnat-strings-g-string-ads}@anchor{3d4}@anchor{gnat_rm/the_gnat_library id115}@anchor{3d5}
@section @code{GNAT.Strings} (@code{g-string.ads})
@@ -25219,7 +25265,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{3d3}@anchor{gnat_rm/the_gnat_library id116}@anchor{3d4}
+@anchor{gnat_rm/the_gnat_library gnat-string-split-g-strspl-ads}@anchor{3d6}@anchor{gnat_rm/the_gnat_library id116}@anchor{3d7}
@section @code{GNAT.String_Split} (@code{g-strspl.ads})
@@ -25233,7 +25279,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 gnat-table-g-table-ads}@anchor{3d5}@anchor{gnat_rm/the_gnat_library id117}@anchor{3d6}
+@anchor{gnat_rm/the_gnat_library gnat-table-g-table-ads}@anchor{3d8}@anchor{gnat_rm/the_gnat_library id117}@anchor{3d9}
@section @code{GNAT.Table} (@code{g-table.ads})
@@ -25253,7 +25299,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 gnat-task-lock-g-tasloc-ads}@anchor{3d7}@anchor{gnat_rm/the_gnat_library id118}@anchor{3d8}
+@anchor{gnat_rm/the_gnat_library gnat-task-lock-g-tasloc-ads}@anchor{3da}@anchor{gnat_rm/the_gnat_library id118}@anchor{3db}
@section @code{GNAT.Task_Lock} (@code{g-tasloc.ads})
@@ -25270,7 +25316,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 gnat-time-stamp-g-timsta-ads}@anchor{3d9}@anchor{gnat_rm/the_gnat_library id119}@anchor{3da}
+@anchor{gnat_rm/the_gnat_library gnat-time-stamp-g-timsta-ads}@anchor{3dc}@anchor{gnat_rm/the_gnat_library id119}@anchor{3dd}
@section @code{GNAT.Time_Stamp} (@code{g-timsta.ads})
@@ -25285,7 +25331,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{3db}@anchor{gnat_rm/the_gnat_library id120}@anchor{3dc}
+@anchor{gnat_rm/the_gnat_library gnat-threads-g-thread-ads}@anchor{3de}@anchor{gnat_rm/the_gnat_library id120}@anchor{3df}
@section @code{GNAT.Threads} (@code{g-thread.ads})
@@ -25302,7 +25348,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 gnat-traceback-g-traceb-ads}@anchor{3dd}@anchor{gnat_rm/the_gnat_library id121}@anchor{3de}
+@anchor{gnat_rm/the_gnat_library gnat-traceback-g-traceb-ads}@anchor{3e0}@anchor{gnat_rm/the_gnat_library id121}@anchor{3e1}
@section @code{GNAT.Traceback} (@code{g-traceb.ads})
@@ -25314,7 +25360,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-utf_32 ads,GNAT Traceback g-traceb ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-traceback-symbolic-g-trasym-ads}@anchor{3df}@anchor{gnat_rm/the_gnat_library id122}@anchor{3e0}
+@anchor{gnat_rm/the_gnat_library gnat-traceback-symbolic-g-trasym-ads}@anchor{3e2}@anchor{gnat_rm/the_gnat_library id122}@anchor{3e3}
@section @code{GNAT.Traceback.Symbolic} (@code{g-trasym.ads})
@@ -25323,7 +25369,7 @@ in various debugging situations.
@geindex Trace back facilities
@node GNAT UTF_32 g-utf_32 ads,GNAT UTF_32_Spelling_Checker g-u3spch ads,GNAT Traceback Symbolic g-trasym ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-utf-32-g-utf-32-ads}@anchor{3e1}@anchor{gnat_rm/the_gnat_library id123}@anchor{3e2}
+@anchor{gnat_rm/the_gnat_library gnat-utf-32-g-utf-32-ads}@anchor{3e4}@anchor{gnat_rm/the_gnat_library id123}@anchor{3e5}
@section @code{GNAT.UTF_32} (@code{g-utf_32.ads})
@@ -25342,7 +25388,7 @@ lower case to upper case fold routine corresponding to
the Ada 2005 rules for identifier equivalence.
@node GNAT UTF_32_Spelling_Checker g-u3spch ads,GNAT Wide_Spelling_Checker g-wispch ads,GNAT UTF_32 g-utf_32 ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-utf-32-spelling-checker-g-u3spch-ads}@anchor{3e3}@anchor{gnat_rm/the_gnat_library id124}@anchor{3e4}
+@anchor{gnat_rm/the_gnat_library gnat-utf-32-spelling-checker-g-u3spch-ads}@anchor{3e6}@anchor{gnat_rm/the_gnat_library id124}@anchor{3e7}
@section @code{GNAT.UTF_32_Spelling_Checker} (@code{g-u3spch.ads})
@@ -25355,7 +25401,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 UTF_32_Spelling_Checker g-u3spch ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-wide-spelling-checker-g-wispch-ads}@anchor{3e5}@anchor{gnat_rm/the_gnat_library id125}@anchor{3e6}
+@anchor{gnat_rm/the_gnat_library gnat-wide-spelling-checker-g-wispch-ads}@anchor{3e8}@anchor{gnat_rm/the_gnat_library id125}@anchor{3e9}
@section @code{GNAT.Wide_Spelling_Checker} (@code{g-wispch.ads})
@@ -25367,7 +25413,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 gnat-wide-string-split-g-wistsp-ads}@anchor{3e7}@anchor{gnat_rm/the_gnat_library id126}@anchor{3e8}
+@anchor{gnat_rm/the_gnat_library gnat-wide-string-split-g-wistsp-ads}@anchor{3ea}@anchor{gnat_rm/the_gnat_library id126}@anchor{3eb}
@section @code{GNAT.Wide_String_Split} (@code{g-wistsp.ads})
@@ -25381,7 +25427,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{3e9}@anchor{gnat_rm/the_gnat_library id127}@anchor{3ea}
+@anchor{gnat_rm/the_gnat_library gnat-wide-wide-spelling-checker-g-zspche-ads}@anchor{3ec}@anchor{gnat_rm/the_gnat_library id127}@anchor{3ed}
@section @code{GNAT.Wide_Wide_Spelling_Checker} (@code{g-zspche.ads})
@@ -25393,7 +25439,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{3eb}@anchor{gnat_rm/the_gnat_library id128}@anchor{3ec}
+@anchor{gnat_rm/the_gnat_library gnat-wide-wide-string-split-g-zistsp-ads}@anchor{3ee}@anchor{gnat_rm/the_gnat_library id128}@anchor{3ef}
@section @code{GNAT.Wide_Wide_String_Split} (@code{g-zistsp.ads})
@@ -25407,7 +25453,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 id129}@anchor{3ed}@anchor{gnat_rm/the_gnat_library interfaces-c-extensions-i-cexten-ads}@anchor{3ee}
+@anchor{gnat_rm/the_gnat_library id129}@anchor{3f0}@anchor{gnat_rm/the_gnat_library interfaces-c-extensions-i-cexten-ads}@anchor{3f1}
@section @code{Interfaces.C.Extensions} (@code{i-cexten.ads})
@@ -25418,7 +25464,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 id130}@anchor{3ef}@anchor{gnat_rm/the_gnat_library interfaces-c-streams-i-cstrea-ads}@anchor{3f0}
+@anchor{gnat_rm/the_gnat_library id130}@anchor{3f2}@anchor{gnat_rm/the_gnat_library interfaces-c-streams-i-cstrea-ads}@anchor{3f3}
@section @code{Interfaces.C.Streams} (@code{i-cstrea.ads})
@@ -25431,7 +25477,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 id131}@anchor{3f1}@anchor{gnat_rm/the_gnat_library interfaces-packed-decimal-i-pacdec-ads}@anchor{3f2}
+@anchor{gnat_rm/the_gnat_library id131}@anchor{3f4}@anchor{gnat_rm/the_gnat_library interfaces-packed-decimal-i-pacdec-ads}@anchor{3f5}
@section @code{Interfaces.Packed_Decimal} (@code{i-pacdec.ads})
@@ -25446,7 +25492,7 @@ from a packed decimal format compatible with that used on IBM
mainframes.
@node Interfaces VxWorks i-vxwork ads,Interfaces VxWorks IO i-vxwoio ads,Interfaces Packed_Decimal i-pacdec ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id132}@anchor{3f3}@anchor{gnat_rm/the_gnat_library interfaces-vxworks-i-vxwork-ads}@anchor{3f4}
+@anchor{gnat_rm/the_gnat_library id132}@anchor{3f6}@anchor{gnat_rm/the_gnat_library interfaces-vxworks-i-vxwork-ads}@anchor{3f7}
@section @code{Interfaces.VxWorks} (@code{i-vxwork.ads})
@@ -25460,7 +25506,7 @@ mainframes.
This package provides a limited binding to the VxWorks API.
@node Interfaces VxWorks IO i-vxwoio ads,System Address_Image s-addima ads,Interfaces VxWorks i-vxwork ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id133}@anchor{3f5}@anchor{gnat_rm/the_gnat_library interfaces-vxworks-io-i-vxwoio-ads}@anchor{3f6}
+@anchor{gnat_rm/the_gnat_library id133}@anchor{3f8}@anchor{gnat_rm/the_gnat_library interfaces-vxworks-io-i-vxwoio-ads}@anchor{3f9}
@section @code{Interfaces.VxWorks.IO} (@code{i-vxwoio.ads})
@@ -25483,7 +25529,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 id134}@anchor{3f7}@anchor{gnat_rm/the_gnat_library system-address-image-s-addima-ads}@anchor{3f8}
+@anchor{gnat_rm/the_gnat_library id134}@anchor{3fa}@anchor{gnat_rm/the_gnat_library system-address-image-s-addima-ads}@anchor{3fb}
@section @code{System.Address_Image} (@code{s-addima.ads})
@@ -25499,7 +25545,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 id135}@anchor{3f9}@anchor{gnat_rm/the_gnat_library system-assertions-s-assert-ads}@anchor{3fa}
+@anchor{gnat_rm/the_gnat_library id135}@anchor{3fc}@anchor{gnat_rm/the_gnat_library system-assertions-s-assert-ads}@anchor{3fd}
@section @code{System.Assertions} (@code{s-assert.ads})
@@ -25515,7 +25561,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 id136}@anchor{3fb}@anchor{gnat_rm/the_gnat_library system-atomic-counters-s-atocou-ads}@anchor{3fc}
+@anchor{gnat_rm/the_gnat_library id136}@anchor{3fe}@anchor{gnat_rm/the_gnat_library system-atomic-counters-s-atocou-ads}@anchor{3ff}
@section @code{System.Atomic_Counters} (@code{s-atocou.ads})
@@ -25529,7 +25575,7 @@ on most targets, including all Alpha, AARCH64, ARM, 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 id137}@anchor{3fd}@anchor{gnat_rm/the_gnat_library system-memory-s-memory-ads}@anchor{3fe}
+@anchor{gnat_rm/the_gnat_library id137}@anchor{400}@anchor{gnat_rm/the_gnat_library system-memory-s-memory-ads}@anchor{401}
@section @code{System.Memory} (@code{s-memory.ads})
@@ -25547,7 +25593,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 id138}@anchor{3ff}@anchor{gnat_rm/the_gnat_library system-multiprocessors-s-multip-ads}@anchor{400}
+@anchor{gnat_rm/the_gnat_library id138}@anchor{402}@anchor{gnat_rm/the_gnat_library system-multiprocessors-s-multip-ads}@anchor{403}
@section @code{System.Multiprocessors} (@code{s-multip.ads})
@@ -25560,7 +25606,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 id139}@anchor{401}@anchor{gnat_rm/the_gnat_library system-multiprocessors-dispatching-domains-s-mudido-ads}@anchor{402}
+@anchor{gnat_rm/the_gnat_library id139}@anchor{404}@anchor{gnat_rm/the_gnat_library system-multiprocessors-dispatching-domains-s-mudido-ads}@anchor{405}
@section @code{System.Multiprocessors.Dispatching_Domains} (@code{s-mudido.ads})
@@ -25573,7 +25619,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 id140}@anchor{403}@anchor{gnat_rm/the_gnat_library system-partition-interface-s-parint-ads}@anchor{404}
+@anchor{gnat_rm/the_gnat_library id140}@anchor{406}@anchor{gnat_rm/the_gnat_library system-partition-interface-s-parint-ads}@anchor{407}
@section @code{System.Partition_Interface} (@code{s-parint.ads})
@@ -25583,10 +25629,10 @@ technically an implementation-defined addition).
This package provides facilities for partition interfacing. It
is used primarily in a distribution context when using Annex E
-with @code{GLADE}.
+with @code{PolyORB}.
@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 id141}@anchor{405}@anchor{gnat_rm/the_gnat_library system-pool-global-s-pooglo-ads}@anchor{406}
+@anchor{gnat_rm/the_gnat_library id141}@anchor{408}@anchor{gnat_rm/the_gnat_library system-pool-global-s-pooglo-ads}@anchor{409}
@section @code{System.Pool_Global} (@code{s-pooglo.ads})
@@ -25603,7 +25649,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 id142}@anchor{407}@anchor{gnat_rm/the_gnat_library system-pool-local-s-pooloc-ads}@anchor{408}
+@anchor{gnat_rm/the_gnat_library id142}@anchor{40a}@anchor{gnat_rm/the_gnat_library system-pool-local-s-pooloc-ads}@anchor{40b}
@section @code{System.Pool_Local} (@code{s-pooloc.ads})
@@ -25620,7 +25666,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 id143}@anchor{409}@anchor{gnat_rm/the_gnat_library system-restrictions-s-restri-ads}@anchor{40a}
+@anchor{gnat_rm/the_gnat_library id143}@anchor{40c}@anchor{gnat_rm/the_gnat_library system-restrictions-s-restri-ads}@anchor{40d}
@section @code{System.Restrictions} (@code{s-restri.ads})
@@ -25636,7 +25682,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 id144}@anchor{40b}@anchor{gnat_rm/the_gnat_library system-rident-s-rident-ads}@anchor{40c}
+@anchor{gnat_rm/the_gnat_library id144}@anchor{40e}@anchor{gnat_rm/the_gnat_library system-rident-s-rident-ads}@anchor{40f}
@section @code{System.Rident} (@code{s-rident.ads})
@@ -25652,7 +25698,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 id145}@anchor{40d}@anchor{gnat_rm/the_gnat_library system-strings-stream-ops-s-ststop-ads}@anchor{40e}
+@anchor{gnat_rm/the_gnat_library id145}@anchor{410}@anchor{gnat_rm/the_gnat_library system-strings-stream-ops-s-ststop-ads}@anchor{411}
@section @code{System.Strings.Stream_Ops} (@code{s-ststop.ads})
@@ -25668,7 +25714,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 id146}@anchor{40f}@anchor{gnat_rm/the_gnat_library system-unsigned-types-s-unstyp-ads}@anchor{410}
+@anchor{gnat_rm/the_gnat_library id146}@anchor{412}@anchor{gnat_rm/the_gnat_library system-unsigned-types-s-unstyp-ads}@anchor{413}
@section @code{System.Unsigned_Types} (@code{s-unstyp.ads})
@@ -25681,7 +25727,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 id147}@anchor{411}@anchor{gnat_rm/the_gnat_library system-wch-cnv-s-wchcnv-ads}@anchor{412}
+@anchor{gnat_rm/the_gnat_library id147}@anchor{414}@anchor{gnat_rm/the_gnat_library system-wch-cnv-s-wchcnv-ads}@anchor{415}
@section @code{System.Wch_Cnv} (@code{s-wchcnv.ads})
@@ -25702,7 +25748,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 id148}@anchor{413}@anchor{gnat_rm/the_gnat_library system-wch-con-s-wchcon-ads}@anchor{414}
+@anchor{gnat_rm/the_gnat_library id148}@anchor{416}@anchor{gnat_rm/the_gnat_library system-wch-con-s-wchcon-ads}@anchor{417}
@section @code{System.Wch_Con} (@code{s-wchcon.ads})
@@ -25714,7 +25760,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 doc}@anchor{415}@anchor{gnat_rm/interfacing_to_other_languages id1}@anchor{416}@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-other-languages}@anchor{11}
+@anchor{gnat_rm/interfacing_to_other_languages doc}@anchor{418}@anchor{gnat_rm/interfacing_to_other_languages id1}@anchor{419}@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-other-languages}@anchor{11}
@chapter Interfacing to Other Languages
@@ -25732,7 +25778,7 @@ provided.
@end menu
@node Interfacing to C,Interfacing to C++,,Interfacing to Other Languages
-@anchor{gnat_rm/interfacing_to_other_languages id2}@anchor{417}@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-c}@anchor{418}
+@anchor{gnat_rm/interfacing_to_other_languages id2}@anchor{41a}@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-c}@anchor{41b}
@section Interfacing to C
@@ -25872,7 +25918,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 id3}@anchor{49}@anchor{gnat_rm/interfacing_to_other_languages id4}@anchor{419}
+@anchor{gnat_rm/interfacing_to_other_languages id3}@anchor{49}@anchor{gnat_rm/interfacing_to_other_languages id4}@anchor{41c}
@section Interfacing to C++
@@ -26089,7 +26135,7 @@ builds an opaque @code{Type_Info_Ptr} to reference a @code{std::type_info}
object at a given @code{System.Address}.
@node Interfacing to COBOL,Interfacing to Fortran,Interfacing to C++,Interfacing to Other Languages
-@anchor{gnat_rm/interfacing_to_other_languages id5}@anchor{41a}@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-cobol}@anchor{41b}
+@anchor{gnat_rm/interfacing_to_other_languages id5}@anchor{41d}@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-cobol}@anchor{41e}
@section Interfacing to COBOL
@@ -26097,7 +26143,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{41c}@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-fortran}@anchor{41d}
+@anchor{gnat_rm/interfacing_to_other_languages id6}@anchor{41f}@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-fortran}@anchor{420}
@section Interfacing to Fortran
@@ -26107,7 +26153,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 id7}@anchor{41e}@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-non-gnat-ada-code}@anchor{41f}
+@anchor{gnat_rm/interfacing_to_other_languages id7}@anchor{421}@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-non-gnat-ada-code}@anchor{422}
@section Interfacing to non-GNAT Ada code
@@ -26131,13 +26177,11 @@ 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 doc}@anchor{420}@anchor{gnat_rm/specialized_needs_annexes id1}@anchor{421}@anchor{gnat_rm/specialized_needs_annexes specialized-needs-annexes}@anchor{12}
+@anchor{gnat_rm/specialized_needs_annexes doc}@anchor{423}@anchor{gnat_rm/specialized_needs_annexes id1}@anchor{424}@anchor{gnat_rm/specialized_needs_annexes specialized-needs-annexes}@anchor{12}
@chapter Specialized Needs Annexes
-Ada 95, Ada 2005, and Ada 2012 define a number of Specialized Needs Annexes, which are not
-required in all implementations. However, as described in this chapter,
-GNAT implements all of these annexes:
+Ada 95, Ada 2005, Ada 2012, and Ada 2022 define a number of Specialized Needs Annexes, which are not required in all implementations. However, as described in this chapter, GNAT implements all of these annexes:
@table @asis
@@ -26153,9 +26197,8 @@ The Real-Time Systems Annex is fully implemented.
@item `Distributed Systems (Annex E)'
Stub generation is fully implemented in the GNAT compiler. In addition,
-a complete compatible PCS is available as part of the GLADE system,
-a separate product. When the two
-products are used in conjunction, this annex is fully implemented.
+a complete compatible PCS is available as part of @code{PolyORB},
+a separate product. Note, that PolyORB is a deprecated product and will be eventually replaced with other technologies such as @code{RTI}.
@item `Information Systems (Annex F)'
@@ -26171,8 +26214,8 @@ The Safety and Security Annex (termed the High-Integrity Systems Annex
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 doc}@anchor{422}@anchor{gnat_rm/implementation_of_specific_ada_features id1}@anchor{423}@anchor{gnat_rm/implementation_of_specific_ada_features implementation-of-specific-ada-features}@anchor{13}
+@node Implementation of Specific Ada Features,Implementation of Ada 2022 Features,Specialized Needs Annexes,Top
+@anchor{gnat_rm/implementation_of_specific_ada_features doc}@anchor{425}@anchor{gnat_rm/implementation_of_specific_ada_features id1}@anchor{426}@anchor{gnat_rm/implementation_of_specific_ada_features implementation-of-specific-ada-features}@anchor{13}
@chapter Implementation of Specific Ada Features
@@ -26191,7 +26234,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 id2}@anchor{424}@anchor{gnat_rm/implementation_of_specific_ada_features machine-code-insertions}@anchor{17d}
+@anchor{gnat_rm/implementation_of_specific_ada_features id2}@anchor{427}@anchor{gnat_rm/implementation_of_specific_ada_features machine-code-insertions}@anchor{180}
@section Machine Code Insertions
@@ -26359,7 +26402,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 gnat-implementation-of-tasking}@anchor{425}@anchor{gnat_rm/implementation_of_specific_ada_features id3}@anchor{426}
+@anchor{gnat_rm/implementation_of_specific_ada_features gnat-implementation-of-tasking}@anchor{428}@anchor{gnat_rm/implementation_of_specific_ada_features id3}@anchor{429}
@section GNAT Implementation of Tasking
@@ -26375,7 +26418,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 id4}@anchor{427}@anchor{gnat_rm/implementation_of_specific_ada_features mapping-ada-tasks-onto-the-underlying-kernel-threads}@anchor{428}
+@anchor{gnat_rm/implementation_of_specific_ada_features id4}@anchor{42a}@anchor{gnat_rm/implementation_of_specific_ada_features mapping-ada-tasks-onto-the-underlying-kernel-threads}@anchor{42b}
@subsection Mapping Ada Tasks onto the Underlying Kernel Threads
@@ -26444,7 +26487,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 ensuring-compliance-with-the-real-time-annex}@anchor{429}@anchor{gnat_rm/implementation_of_specific_ada_features id5}@anchor{42a}
+@anchor{gnat_rm/implementation_of_specific_ada_features ensuring-compliance-with-the-real-time-annex}@anchor{42c}@anchor{gnat_rm/implementation_of_specific_ada_features id5}@anchor{42d}
@subsection Ensuring Compliance with the Real-Time Annex
@@ -26495,7 +26538,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{42b}
+@anchor{gnat_rm/implementation_of_specific_ada_features support-for-locking-policies}@anchor{42e}
@subsection Support for Locking Policies
@@ -26529,7 +26572,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 gnat-implementation-of-shared-passive-packages}@anchor{42c}@anchor{gnat_rm/implementation_of_specific_ada_features id6}@anchor{42d}
+@anchor{gnat_rm/implementation_of_specific_ada_features gnat-implementation-of-shared-passive-packages}@anchor{42f}@anchor{gnat_rm/implementation_of_specific_ada_features id6}@anchor{430}
@section GNAT Implementation of Shared Passive Packages
@@ -26627,7 +26670,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{42e}@anchor{gnat_rm/implementation_of_specific_ada_features id7}@anchor{42f}
+@anchor{gnat_rm/implementation_of_specific_ada_features code-generation-for-array-aggregates}@anchor{431}@anchor{gnat_rm/implementation_of_specific_ada_features id7}@anchor{432}
@section Code Generation for Array Aggregates
@@ -26658,7 +26701,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 id8}@anchor{430}@anchor{gnat_rm/implementation_of_specific_ada_features static-constant-aggregates-with-static-bounds}@anchor{431}
+@anchor{gnat_rm/implementation_of_specific_ada_features id8}@anchor{433}@anchor{gnat_rm/implementation_of_specific_ada_features static-constant-aggregates-with-static-bounds}@anchor{434}
@subsection Static constant aggregates with static bounds
@@ -26705,7 +26748,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{432}@anchor{gnat_rm/implementation_of_specific_ada_features id9}@anchor{433}
+@anchor{gnat_rm/implementation_of_specific_ada_features constant-aggregates-with-unconstrained-nominal-types}@anchor{435}@anchor{gnat_rm/implementation_of_specific_ada_features id9}@anchor{436}
@subsection Constant aggregates with unconstrained nominal types
@@ -26720,7 +26763,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 aggregates-with-static-bounds}@anchor{434}@anchor{gnat_rm/implementation_of_specific_ada_features id10}@anchor{435}
+@anchor{gnat_rm/implementation_of_specific_ada_features aggregates-with-static-bounds}@anchor{437}@anchor{gnat_rm/implementation_of_specific_ada_features id10}@anchor{438}
@subsection Aggregates with static bounds
@@ -26748,7 +26791,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 aggregates-with-nonstatic-bounds}@anchor{436}@anchor{gnat_rm/implementation_of_specific_ada_features id11}@anchor{437}
+@anchor{gnat_rm/implementation_of_specific_ada_features aggregates-with-nonstatic-bounds}@anchor{439}@anchor{gnat_rm/implementation_of_specific_ada_features id11}@anchor{43a}
@subsection Aggregates with nonstatic bounds
@@ -26759,7 +26802,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 aggregates-in-assignment-statements}@anchor{438}@anchor{gnat_rm/implementation_of_specific_ada_features id12}@anchor{439}
+@anchor{gnat_rm/implementation_of_specific_ada_features aggregates-in-assignment-statements}@anchor{43b}@anchor{gnat_rm/implementation_of_specific_ada_features id12}@anchor{43c}
@subsection Aggregates in assignment statements
@@ -26801,7 +26844,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,Image Values For Nonscalar Types,Code Generation for Array Aggregates,Implementation of Specific Ada Features
-@anchor{gnat_rm/implementation_of_specific_ada_features id13}@anchor{43a}@anchor{gnat_rm/implementation_of_specific_ada_features the-size-of-discriminated-records-with-default-discriminants}@anchor{43b}
+@anchor{gnat_rm/implementation_of_specific_ada_features id13}@anchor{43d}@anchor{gnat_rm/implementation_of_specific_ada_features the-size-of-discriminated-records-with-default-discriminants}@anchor{43e}
@section The Size of Discriminated Records with Default Discriminants
@@ -26881,7 +26924,7 @@ say) must be consistent, so it is imperative that the object, once created,
remain invariant.
@node Image Values For Nonscalar Types,Strict Conformance to the Ada Reference Manual,The Size of Discriminated Records with Default Discriminants,Implementation of Specific Ada Features
-@anchor{gnat_rm/implementation_of_specific_ada_features id14}@anchor{43c}@anchor{gnat_rm/implementation_of_specific_ada_features image-values-for-nonscalar-types}@anchor{43d}
+@anchor{gnat_rm/implementation_of_specific_ada_features id14}@anchor{43f}@anchor{gnat_rm/implementation_of_specific_ada_features image-values-for-nonscalar-types}@anchor{440}
@section Image Values For Nonscalar Types
@@ -26901,7 +26944,7 @@ control of image text is required for some type T, then T’Put_Image should be
explicitly specified.
@node Strict Conformance to the Ada Reference Manual,,Image Values For Nonscalar Types,Implementation of Specific Ada Features
-@anchor{gnat_rm/implementation_of_specific_ada_features id15}@anchor{43e}@anchor{gnat_rm/implementation_of_specific_ada_features strict-conformance-to-the-ada-reference-manual}@anchor{43f}
+@anchor{gnat_rm/implementation_of_specific_ada_features id15}@anchor{441}@anchor{gnat_rm/implementation_of_specific_ada_features strict-conformance-to-the-ada-reference-manual}@anchor{442}
@section Strict Conformance to the Ada Reference Manual
@@ -26927,31 +26970,25 @@ machines that are not fully compliant with this standard, such as Alpha, the
behavior (although at the cost of a significant performance penalty), so
infinite and NaN values are properly generated.
-@node Implementation of Ada 2012 Features,GNAT language extensions,Implementation of Specific Ada Features,Top
-@anchor{gnat_rm/implementation_of_ada_2012_features doc}@anchor{440}@anchor{gnat_rm/implementation_of_ada_2012_features id1}@anchor{441}@anchor{gnat_rm/implementation_of_ada_2012_features implementation-of-ada-2012-features}@anchor{14}
-@chapter Implementation of Ada 2012 Features
+@node Implementation of Ada 2022 Features,GNAT language extensions,Implementation of Specific Ada Features,Top
+@anchor{gnat_rm/implementation_of_ada_2022_features doc}@anchor{443}@anchor{gnat_rm/implementation_of_ada_2022_features id1}@anchor{444}@anchor{gnat_rm/implementation_of_ada_2022_features implementation-of-ada-2022-features}@anchor{14}
+@chapter Implementation of Ada 2022 Features
-@geindex Ada 2012 implementation status
+@geindex Ada 2022 implementation status
-@geindex -gnat12 option (gcc)
+@geindex -gnat22 option (gcc)
-@geindex pragma Ada_2012
+@geindex pragma Ada_2022
-@geindex configuration pragma Ada_2012
+@geindex configuration pragma Ada_2022
-@geindex Ada_2012 configuration pragma
+@geindex Ada_2022 configuration pragma
-This chapter contains a complete list of Ada 2012 features that have been
-implemented.
-Generally, these features are only
-available if the `-gnat12' (Ada 2012 features enabled) option is set,
-which is the default behavior,
-or if the configuration pragma @code{Ada_2012} is used.
+This chapter contains a complete list of Ada 2022 features that have been
+implemented. Generally, these features are only available if the `-gnat22' (Ada 2022 features enabled) option is set, or if the configuration pragma @code{Ada_2022} is used.
-However, new pragmas, attributes, and restrictions are
-unconditionally available, since the Ada 95 standard allows the addition of
-new pragmas, attributes, and restrictions (there are exceptions, which are
+However, new pragmas, attributes, and restrictions are unconditionally available, since the Ada standard allows the addition of new pragmas, attributes, and restrictions (there are exceptions, which are
documented in the individual descriptions), and also certain packages
were made available in earlier versions of Ada.
@@ -26963,2138 +27000,3397 @@ implemented the feature, or implemented it as soon as it appeared as a
binding interpretation.
Each feature corresponds to an Ada Issue (‘AI’) approved by the Ada
-standardization group (ISO/IEC JTC1/SC22/WG9) for inclusion in Ada 2012.
-The features are ordered based on the relevant sections of the Ada
-Reference Manual (“RM”). When a given AI relates to multiple points
-in the RM, the earliest is used.
+standardization group (ISO/IEC JTC1/SC22/WG9) for inclusion in Ada 2022.
-A complete description of the AIs may be found in
-@indicateurl{http://www.ada-auth.org/ai05-summary.html}.
+The section “RM references” lists all modified paragraphs in the Ada 2012 reference manual. The details of each modification as well as a complete description of the AIs may be found in
+@indicateurl{http://www.ada-auth.org/AI12-SUMMARY.HTML}.
-@geindex AI-0002 (Ada 2012 feature)
+@geindex AI12-0001 (Ada 2022 feature)
@itemize *
@item
-`AI-0002 Export C with unconstrained arrays (0000-00-00)'
+`AI12-0001 Independence and Representation clauses for atomic objects (2019-11-27)'
-The compiler is not required to support exporting an Ada subprogram with
-convention C if there are parameters or a return type of an unconstrained
-array type (such as @code{String}). GNAT allows such declarations but
-generates warnings. It is possible, but complicated, to write the
-corresponding C code and certainly such code would be specific to GNAT and
-non-portable.
+The compiler accepts packing clauses in all cases, even if they have effectively no influence on the layout. Types, where packing is essentially infeasible are, for instance atomic, aliased and by-reference types.
-RM References: B.01 (17) B.03 (62) B.03 (71.1/2)
+RM references: 13.02 (6.1/2) 13.02 (7) 13.02 (8) 13.02 (9/3) C.06 (8.1/3)
+C.06 (10) C.06 (11) C.06 (21) C.06 (24)
@end itemize
-@geindex AI-0003 (Ada 2012 feature)
+@geindex AI12-0003 (Ada 2022 feature)
@itemize *
@item
-`AI-0003 Qualified expressions as names (2010-07-11)'
+`AI12-0003 Specifying the standard storage pool (2020-06-25)'
-In Ada 2012, a qualified expression is considered to be syntactically a name,
-meaning that constructs such as @code{A'(F(X)).B} are now legal. This is
-useful in disambiguating some cases of overloading.
+Allows the standard storage pool being specified with a @code{Default_Storage_Pool} pragma or aspect.
-RM References: 3.03 (11) 3.03 (21) 4.01 (2) 4.04 (7) 4.07 (3)
-5.04 (7)
+RM references: 8.02 (11) 13.11.03 (1/3) 13.11.03 (3.1/3) 13.11.03 (4/3)
+13.11.03 (4.1/3) 13.11.03 (5/3) 13.11.03 (6.2/3) 13.11.03
+(6.3/3)
@end itemize
-@geindex AI-0007 (Ada 2012 feature)
+@geindex AI12-0004 (Ada 2022 feature)
@itemize *
@item
-`AI-0007 Stream read and private scalar types (0000-00-00)'
+`AI12-0004 Normalization and allowed characters for identifiers (2020-06-11)'
-The RM as written appeared to limit the possibilities of declaring read
-attribute procedures for private scalar types. This limitation was not
-intended, and has never been enforced by GNAT.
+This AI clarifies that Ada identifiers containing characters which are not
+allowed in Normalization Form KC are illegal.
-RM References: 13.13.02 (50/2) 13.13.02 (51/2)
+RM references: 2.01 (4.1/3) 2.03 (4/3) A.03.02 (4/3) A.03.02 (32.5/3)
+A.03.05 (18/3) A.03.05 (51/3)
@end itemize
-@geindex AI-0008 (Ada 2012 feature)
+@geindex AI12-0020 (Ada 2022 feature)
@itemize *
@item
-`AI-0008 General access to constrained objects (0000-00-00)'
+`AI12-0020 ‘Image for all types (2020-03-30)'
-The wording in the RM implied that if you have a general access to a
-constrained object, it could be used to modify the discriminants. This was
-obviously not intended. @code{Constraint_Error} should be raised, and GNAT
-has always done so in this situation.
+Put_Image prints out a human-readable representation of an object. The
+functionality in Ada2022 RM is fully implemented except the support for
+types in the @code{Remote_Types} packages.
-RM References: 3.03 (23) 3.10.02 (26/2) 4.01 (9) 6.04.01 (17) 8.05.01 (5/2)
+RM references: 4.10 (0) 3.05 (27.1/2) 3.05 (27.2/2) 3.05 (27.3/2) 3.05
+(27.4/2) 3.05 (27.5/2) 3.05 (27.6/2) 3.05 (27.7/2) 3.05 (28) 3.05
+(29) 3.05 (30/3) 3.05 (31) 3.05 (32) 3.05 (33/3) 3.05 (37.1/2)
+3.05 (38) 3.05 (39) 3.05 (43/3) 3.05 (55/3) 3.05 (55.1/5) 3.05
+(55.2/4) 3.05 (55.3/4) 3.05 (55.4/4) 3.05 (59) H.04 (23) H.04 (23.8/2)
@end itemize
-@geindex AI-0009 (Ada 2012 feature)
+@geindex AI12-0022 (Ada 2022 feature)
@itemize *
@item
-`AI-0009 Pragma Independent[_Components] (2010-07-23)'
+`AI12-0022 Raise_Expressions (2013-01-27)'
-This AI introduces the new pragmas @code{Independent} and
-@code{Independent_Components},
-which control guaranteeing independence of access to objects and components.
-The AI also requires independence not unaffected by confirming rep clauses.
+This feature allows you to write “raise NAME [with STRING]” in an
+expression to rise given exception. It is particularly useful in the case of
+assertions such as preconditions allowing to specify which exception a
+precondition raises if it fails.
-RM References: 9.10 (1) 13.01 (15/1) 13.02 (9) 13.03 (13) C.06 (2)
-C.06 (4) C.06 (6) C.06 (9) C.06 (13) C.06 (14)
+RM references: 4.04 (3/3) 11.02 (6) 11.03 (2/2) 11.03 (3) 11.03 (3.1/2)
+11.03 (4/2) 11.04.01 (10.1/3)
@end itemize
-@geindex AI-0012 (Ada 2012 feature)
+@geindex AI12-0027 (Ada 2022 feature)
@itemize *
@item
-`AI-0012 Pack/Component_Size for aliased/atomic (2010-07-15)'
+`AI12-0027 Access values should never designate unaliased components (2020-06-15)'
-It is now illegal to give an inappropriate component size or a pragma
-@code{Pack} that attempts to change the component size in the case of atomic
-or aliased components. Previously GNAT ignored such an attempt with a
-warning.
+AI12-0027 adds a requirement for a value conversion that converts from an array of unaliased components to an array of aliased components to make a copy. It defines such conversions to have a local accessibility, effectively preventing the possibility of unsafe accesses to unaliased components.
-RM References: 13.02 (6.1/2) 13.02 (7) C.06 (10) C.06 (11) C.06 (21)
+RM references: 4.06 (24.17/3) 4.06 (24.21/2) 4.06 (58) 6.02 (10/3) 3.10.02 (10/3)
@end itemize
-@geindex AI-0015 (Ada 2012 feature)
+@geindex AI12-0028 (Ada 2022 feature)
@itemize *
@item
-`AI-0015 Constant return objects (0000-00-00)'
+`AI12-0028 Import of variadic C functions (2020-03-03)'
-The return object declared in an `extended_return_statement' may be
-declared constant. This was always intended, and GNAT has always allowed it.
+Ada programs can now properly call variadic C functions by means of the
+conventions C_Variadic_<n>, for small integer values <n>.
-RM References: 6.05 (2.1/2) 3.03 (10/2) 3.03 (21) 6.05 (5/2)
-6.05 (5.7/2)
+RM references: B.03 (1/3) B.03 (60.15/3) B.03 (75)
@end itemize
-@geindex AI-0017 (Ada 2012 feature)
+@geindex AI12-0030 (Ada 2022 feature)
@itemize *
@item
-`AI-0017 Freezing and incomplete types (0000-00-00)'
+`AI12-0030 Formal derived types and stream attribute availability (2020-08-21)'
-So-called ‘Taft-amendment types’ (i.e., types that are completed in package
-bodies) are not frozen by the occurrence of bodies in the
-enclosing declarative part. GNAT always implemented this properly.
+Corner cases involving streaming operations for formal derived limited types
+that are now defined to raise Program_Error. Before, behavior in these cases
+was undefined. Stream attribute availability is more precisely computed in cases where a derived type declaration occurs ahead of a streaming attribute specification for the parent type.
-RM References: 13.14 (3/1)
+RM references: 12.05.01 (21/3) 13.13.02 (49/2)
@end itemize
-@geindex AI-0019 (Ada 2012 feature)
+@geindex AI12-0031 (Ada 2022 feature)
@itemize *
@item
-`AI-0019 Freezing of primitives for tagged types (0000-00-00)'
+`AI12-0031 All_Calls_Remote and indirect calls (0000-00-00)'
-The RM suggests that primitive subprograms of a specific tagged type are
-frozen when the tagged type is frozen. This would be an incompatible change
-and is not intended. GNAT has never attempted this kind of freezing and its
-behavior is consistent with the recommendation of this AI.
+Remote indirect calls (i.e., calls through a remote access-to-subprogram type)
+behave the same as remote direct calls.
-RM References: 13.14 (2) 13.14 (3/1) 13.14 (8.1/1) 13.14 (10) 13.14 (14) 13.14 (15.1/2)
+RM references: E.02.03 (19/3)
@end itemize
-@geindex AI-0026 (Ada 2012 feature)
+@geindex AI12-0032 (Ada 2022 feature)
@itemize *
@item
-`AI-0026 Missing rules for Unchecked_Union (2010-07-07)'
+`AI12-0032 Questions on ‘Old (2020-04-24)'
-Record representation clauses concerning Unchecked_Union types cannot mention
-the discriminant of the type. The type of a component declared in the variant
-part of an Unchecked_Union cannot be controlled, have controlled components,
-nor have protected or task parts. If an Unchecked_Union type is declared
-within the body of a generic unit or its descendants, then the type of a
-component declared in the variant part cannot be a formal private type or a
-formal private extension declared within the same generic unit.
+AI12-0032 resolves several issues related to the ‘Old attribute. The GNAT
+compiler already implemented what the AI requires in most of those cases, but two having to do with static and dynamic checking of the accessibility level of the constant object implicitly declared for an ‘Old attribute reference were not yet implemented. Accessibility checking for these constants is now implemented as defined in the AI.
-RM References: 7.06 (9.4/2) B.03.03 (9/2) B.03.03 (10/2)
+RM references: 4.01.03 (9/3) 6.01.01 (22/3) 6.01.01 (26/3) 6.01.01 (35/3)
@end itemize
-@geindex AI-0030 (Ada 2012 feature)
+@geindex AI12-0033 (Ada 2022 feature)
@itemize *
@item
-`AI-0030 Requeue on synchronized interfaces (2010-07-19)'
+`AI12-0033 Sets of CPUs when defining dispatching domains (0000-00-00)'
-Requeue is permitted to a protected, synchronized or task interface primitive
-providing it is known that the overriding operation is an entry. Otherwise
-the requeue statement has the same effect as a procedure call. Use of pragma
-@code{Implemented} provides a way to impose a static requirement on the
-overriding operation by adhering to one of the implementation kinds: entry,
-protected procedure or any of the above.
+The set of CPUs associated with a dispatching domain is no longer required
+to be a contiguous range of CPU values.
-RM References: 9.05 (9) 9.05.04 (2) 9.05.04 (3) 9.05.04 (5)
-9.05.04 (6) 9.05.04 (7) 9.05.04 (12)
+RM references: D.16.01 (7/3) D.16.01 (9/3) D.16.01 (20/3) D.16.01 (23/3)
+D.16.01 (24/3) D.16.01 (26/3)
@end itemize
-@geindex AI-0031 (Ada 2012 feature)
+@geindex AI12-0035 (Ada 2022 feature)
@itemize *
@item
-`AI-0031 Add From parameter to Find_Token (2010-07-25)'
+`AI12-0035 Accessibility checks for indefinite elements of containers (0000-00-00)'
-A new version of @code{Find_Token} is added to all relevant string packages,
-with an extra parameter @code{From}. Instead of starting at the first
-character of the string, the search for a matching Token starts at the
-character indexed by the value of @code{From}.
-These procedures are available in all versions of Ada
-but if used in versions earlier than Ada 2012 they will generate a warning
-that an Ada 2012 subprogram is being used.
+If the element type for an instance of one of the indefinite container generics has an access discriminant, then accessibility checks (at run-time) prevent inserting a value into a container object if the value’s discriminant designates an object that is too short-lived (that is, if the designated object has an accessibility level that is deeper than that of the instance). Without this check, dangling references would be possible. GNAT handled this correctly already before this AI was issued.
-RM References: A.04.03 (16) A.04.03 (67) A.04.03 (68/1) A.04.04 (51)
-A.04.05 (46)
+RM references: A.18 (5/3) A.18.11 (8/2) A.18.12 (7/2) A.18.13 (8/2)
+A.18.14 (8/2) A.18.15 (4/2) A.18.16 (4/2) A.18.17 (7/3) A.18.18
+(39/3) A.18.18 (47/3)
@end itemize
-@geindex AI-0032 (Ada 2012 feature)
+@geindex AI12-0036 (Ada 2022 feature)
@itemize *
@item
-`AI-0032 Extended return for class-wide functions (0000-00-00)'
+`AI12-0036 The actual for an untagged formal derived type cannot be tagged (2019-10-21)'
-If a function returns a class-wide type, the object of an extended return
-statement can be declared with a specific type that is covered by the class-
-wide type. This has been implemented in GNAT since the introduction of
-extended returns. Note AI-0103 complements this AI by imposing matching
-rules for constrained return types.
+AI12-0036 is a binding interpretation that adds the following legality rule:
+The actual type for a formal derived type shall be tagged if and only if the
+formal derived type is a private extension. The check is implemented for all Ada dialects, not just Ada 2022.
-RM References: 6.05 (5.2/2) 6.05 (5.3/2) 6.05 (5.6/2) 6.05 (5.8/2)
-6.05 (8/2)
+RM references: 12.05.01 (5.1/3)
@end itemize
-@geindex AI-0033 (Ada 2012 feature)
+@geindex AI12-0037 (Ada 2022 feature)
@itemize *
@item
-`AI-0033 Attach/Interrupt_Handler in generic (2010-07-24)'
+`AI12-0037 New types in Ada.Locales can’t be converted to/from strings (2016-09-10)'
-Neither of these two pragmas may appear within a generic template, because
-the generic might be instantiated at other than the library level.
+The type definitions for Language_Code and Country_Code are now using dynamic
+predicates.
-RM References: 13.11.02 (16) C.03.01 (7/2) C.03.01 (8/2)
+RM references: A.19 (4/3)
@end itemize
-@geindex AI-0034 (Ada 2012 feature)
+@geindex AI12-0039 (Ada 2022 feature)
@itemize *
@item
-`AI-0034 Categorization of limited views (0000-00-00)'
+`AI12-0039 Ambiguity in syntax for membership expression removed (0000-00-00)'
-The RM makes certain limited with clauses illegal because of categorization
-considerations, when the corresponding normal with would be legal. This is
-not intended, and GNAT has always implemented the recommended behavior.
+An ambiguity in the syntax for membership expressions was resolved. For example, “A in B and C” can be parsed in only one way because of this AI.
-RM References: 10.02.01 (11/1) 10.02.01 (17/2)
+RM references: 4.04 (3/3) 4.04 (3.2/3) 4.05.02 (3.1/3) 4.05.02 (4) 4.05.02
+(4.1/3) 4.05.02 (27/3) 4.05.02 (27.1/3) 4.05.02 (28.1/3) 4.05.02
+(28.2/3) 4.05.02 (29/3) 4.05.02 (30/3) 4.05.02 (30.1/3) 4.05.02
+(30.2/3) 4.05.02 (30.3/3) 4.09 (11/3) 4.09 (32.6/3) 8.06 (27.1/3)
+3.02.04 (17/3)
@end itemize
-@geindex AI-0035 (Ada 2012 feature)
+@geindex AI12-0040 (Ada 2022 feature)
@itemize *
@item
-`AI-0035 Inconsistencies with Pure units (0000-00-00)'
+`AI12-0040 Resolving the selecting_expression of a case_expression (0000-00-00)'
-This AI remedies some inconsistencies in the legality rules for Pure units.
-Derived access types are legal in a pure unit (on the assumption that the
-rule for a zero storage pool size has been enforced on the ancestor type).
-The rules are enforced in generic instances and in subunits. GNAT has always
-implemented the recommended behavior.
+The definition of “complete context” is corrected so that selectors of case expressions
+and of case statements are treated uniformly.
-RM References: 10.02.01 (15.1/2) 10.02.01 (15.4/2) 10.02.01 (15.5/2) 10.02.01 (17/2)
+RM references: 8.06 (9)
@end itemize
-@geindex AI-0037 (Ada 2012 feature)
+@geindex AI12-0041 (Ada 2022 feature)
@itemize *
@item
-`AI-0037 Out-of-range box associations in aggregate (0000-00-00)'
+`AI12-0041 Type_Invariant’Class for interface types (2016-12-12)'
-This AI confirms that an association of the form @code{Indx => <>} in an
-array aggregate must raise @code{Constraint_Error} if @code{Indx}
-is out of range. The RM specified a range check on other associations, but
-not when the value of the association was defaulted. GNAT has always inserted
-a constraint check on the index value.
+Subprogram calls within class-wide type invariant expressions get resolved
+as primitive operations instead of being dynamically dispatched.
-RM References: 4.03.03 (29)
+RM references: 7.03.02 (1/3) 7.03.02 (3/3)
@end itemize
-@geindex AI-0038 (Ada 2012 feature)
+@geindex AI12-0042 (Ada 2022 feature)
@itemize *
@item
-`AI-0038 Minor errors in Text_IO (0000-00-00)'
+`AI12-0042 Type invariant checking rules (2020-06-05)'
-These are minor errors in the description on three points. The intent on
-all these points has always been clear, and GNAT has always implemented the
-correct intended semantics.
+AI12-0042 adds rules for type invariants.
+Specifically, when inheriting a private dispatching operation when the ancestor operation is visible at the point of the type extension, the operation must be abstract or else overridden. In addition, for a class-wide view conversion from an object of a specific type T to which a type invariant applies, an invariant check is performed when the conversion is within the immediate scope of T.
-RM References: A.10.05 (37) A.10.07 (8/1) A.10.07 (10) A.10.07 (12) A.10.08 (10) A.10.08 (24)
+RM references: 7.03.02 (6/3) 7.03.02 (17/3) 7.03.02 (18/3) 7.03.02 (19/3)
+7.03.02 (20/3)
@end itemize
-@geindex AI-0039 (Ada 2012 feature)
+@geindex AI12-0043 (Ada 2022 feature)
@itemize *
@item
-`AI-0039 Stream attributes cannot be dynamic (0000-00-00)'
+`AI12-0043 Details of the storage pool used when Storage_Size is specified (0000-00-00)'
-The RM permitted the use of dynamic expressions (such as @code{ptr.all})
-for stream attributes, but these were never useful and are now illegal. GNAT
-has always regarded such expressions as illegal.
+Clarify that a Storage_Size specification for an access type specifies both an upper bound and a lower bound (not just a lower bound) of the amount of storage allowed for allocated objects.
-RM References: 13.03 (4) 13.03 (6) 13.13.02 (38/2)
+RM references: 13.11 (18)
@end itemize
-@geindex AI-0040 (Ada 2012 feature)
+@geindex AI12-0044 (Ada 2022 feature)
@itemize *
@item
-`AI-0040 Limited with clauses on descendant (0000-00-00)'
+`AI12-0044 Calling visible functions from type invariant expressions (2020-05-11)'
+
+AI05-0289-1 extends invariant checking to @cite{in} parameters. However, this makes
+it impossible to call a public function of the type from an invariant
+expression, as that public function will attempt to check the invariant,
+resulting in an infinite recursion.
-This AI confirms that a limited with clause in a child unit cannot name
-an ancestor of the unit. This has always been checked in GNAT.
+This AI specifies, that type-invariant checking is performed on parameters
+of mode @cite{in} upon return from procedure calls, but not of @cite{in}-mode
+parameters in functions.
-RM References: 10.01.02 (20/2)
+RM references: 7.03.02 (19/3)
@end itemize
-@geindex AI-0042 (Ada 2012 feature)
+@geindex AI12-0045 (Ada 2022 feature)
@itemize *
@item
-`AI-0042 Overriding versus implemented-by (0000-00-00)'
+`AI12-0045 Pre- and Postconditions are allowed on generic subprograms (2015-03-17)'
-This AI fixes a wording gap in the RM. An operation of a synchronized
-interface can be implemented by a protected or task entry, but the abstract
-operation is not being overridden in the usual sense, and it must be stated
-separately that this implementation is legal. This has always been the case
-in GNAT.
+The SPARK toolset now supports contracts on generic subprograms, packages and
+their respective bodies.
-RM References: 9.01 (9.2/2) 9.04 (11.1/2)
+RM references: 6.01.01 (1/3)
@end itemize
-@geindex AI-0043 (Ada 2012 feature)
+@geindex AI12-0046 (Ada 2022 feature)
@itemize *
@item
-`AI-0043 Rules about raising exceptions (0000-00-00)'
+`AI12-0046 Enforcing legality for anonymous access components in record aggregates (0000-00-00)'
+
+For a record aggregate of the form (X | Y => ….), any relevant legality rules are checked for both for X and Y.
+
+For example,
-This AI covers various omissions in the RM regarding the raising of
-exceptions. GNAT has always implemented the intended semantics.
+@example
+X : aliased constant String := ... ;
+type R is record
+ F1 : access constant String;
+ F2 : access String;
+end record;
+Obj : R := (F1 | F2 => X'Access); -- ok for F1, but illegal for F2
+@end example
-RM References: 11.04.01 (10.1/2) 11 (2)
+RM references: 4.03.01 (16/3)
@end itemize
-@geindex AI-0044 (Ada 2012 feature)
+@geindex AI12-0047 (Ada 2022 feature)
@itemize *
@item
-`AI-0044 Restrictions on container instantiations (0000-00-00)'
+`AI12-0047 Generalized iterators and discriminant-dependent components (0000-00-00)'
-This AI places restrictions on allowed instantiations of generic containers.
-These restrictions are not checked by the compiler, so there is nothing to
-change in the implementation. This affects only the RM documentation.
+Iterating over the elements of an array is subject to the same legality checks as renaming the array. For example, if an assignment to an enclosing discriminated object could cause an array object to cease to exist then we don’t allow renaming the array. So it is similarly not allowed to iterate over the elements of such an array.
-RM References: A.18 (4/2) A.18.02 (231/2) A.18.03 (145/2) A.18.06 (56/2) A.18.08 (66/2) A.18.09 (79/2) A.18.26 (5/2) A.18.26 (9/2)
+RM references: 5.05.02 (6/3)
@end itemize
-@geindex AI-0046 (Ada 2012 feature)
+@geindex AI12-0048 (Ada 2022 feature)
@itemize *
@item
-`AI-0046 Null exclusion match for full conformance (2010-07-17)'
+`AI12-0048 Default behavior of tasks on a multiprocessor with a specified dispatching policy (0000-00-00)'
-For full conformance, in the case of access parameters, the null exclusion
-must match (either both or neither must have @code{not null}).
+Clarify that if the user does not impose requirements about what CPUs a given task might execute on, then the implementation does not get to impose such requirements. This avoids potential problems with priority inversion.
-RM References: 6.03.02 (18)
+RM references: D.16.01 (30/3)
@end itemize
-@geindex AI-0050 (Ada 2012 feature)
+@geindex AI12-0049 (Ada 2022 feature)
@itemize *
@item
-`AI-0050 Raising Constraint_Error early for function call (0000-00-00)'
+`AI12-0049 Invariants need to be checked on the initialization of deferred constants (0000-00-00)'
-The implementation permissions for raising @code{Constraint_Error} early on a function call
-when it was clear an exception would be raised were over-permissive and allowed
-mishandling of discriminants in some cases. GNAT did
-not take advantage of these incorrect permissions in any case.
+Invariant checking for deferred constants (and subcomponents thereof) is performed. Corrects a clear oversight in the previous RM wording.
-RM References: 6.05 (24/2)
+RM references: 7.03.02 (10/3)
@end itemize
-@geindex AI-0056 (Ada 2012 feature)
+@geindex AI12-0050 (Ada 2022 feature)
@itemize *
@item
-`AI-0056 Index on null string returns zero (0000-00-00)'
+`AI12-0050 Conformance of quantified expressions (2016-07-22)'
-The wording in the Ada 2005 RM implied an incompatible handling of the
-@code{Index} functions, resulting in raising an exception instead of
-returning zero in some situations.
-This was not intended and has been corrected.
-GNAT always returned zero, and is thus consistent with this AI.
+Compiler rejects a subprogram body when an expression for a boolean formal
+parameter includes a quantified expression, and the subprogram declaration
+contains a textual copy of the same.
-RM References: A.04.03 (56.2/2) A.04.03 (58.5/2)
+RM references: 6.03.01 (20) 6.03.01 (21)
@end itemize
-@geindex AI-0058 (Ada 2012 feature)
+@geindex AI12-0051 (Ada 2022 feature)
@itemize *
@item
-`AI-0058 Abnormal completion of an extended return (0000-00-00)'
+`AI12-0051 The Priority aspect can be specified when Attach_Handler is specified (0000-00-00)'
-The RM had some incorrect wording implying wrong treatment of abnormal
-completion in an extended return. GNAT has always implemented the intended
-correct semantics as described by this AI.
+Previous RM wording had two contradictory rules for determining (in some cases) the priority of a protected subprogram that is attached to an interrupt. The AI clarifies which one of the rules takes precedence.
-RM References: 6.05 (22/2)
+RM references: D.03 (10/3)
@end itemize
-@geindex AI-0060 (Ada 2012 feature)
+@geindex AI12-0052 (Ada 2022 feature)
@itemize *
@item
-`AI-0060 Extended definition of remote access types (0000-00-00)'
+`AI12-0052 Implicit objects are considered overlapping (0000-00-00)'
-This AI extends the definition of remote access types to include access
-to limited, synchronized, protected or task class-wide interface types.
-GNAT already implemented this extension.
+Clarify that the rules about unsynchronized concurrent access apply as one would expect in the case of predefined routines that access Text_IO’s default input and default output files. There was no compiler changes needed to implement this.
-RM References: A (4) E.02.02 (9/1) E.02.02 (9.2/1) E.02.02 (14/2) E.02.02 (18)
+RM references: A (3/2) A.10.03 (21)
@end itemize
-@geindex AI-0062 (Ada 2012 feature)
+@geindex AI12-0054-2 (Ada 2022 feature)
@itemize *
@item
-`AI-0062 Null exclusions and deferred constants (0000-00-00)'
+`AI12-0054-2 Aspect Predicate_Failure (0000-00-00)'
-A full constant may have a null exclusion even if its associated deferred
-constant does not. GNAT has always allowed this.
+New aspect Predicate_Failure is defined. A solution for the problem that a predicate like
-RM References: 7.04 (6/2) 7.04 (7.1/2)
+@example
+subtype Open_File is File with Dynamic_Predicate =\> Is_Open (Open_File) or else (raise File_Not_Open);
+@end example
+
+does the wrong thing in the case of a membership test.
+
+RM references: 3.02.04 (14/3) 3.02.04 (31/3) 3.02.04 (35/3)
@end itemize
-@geindex AI-0064 (Ada 2012 feature)
+@geindex AI12-0055 (Ada 2022 feature)
@itemize *
@item
-`AI-0064 Redundant finalization rule (0000-00-00)'
+`AI12-0055 All properties of a usage profile are defined by pragmas (2020-06-09)'
-This is an editorial change only. The intended behavior is already checked
-by an existing ACATS test, which GNAT has always executed correctly.
+AI12-0055 allows the use of the No_Dynamic_CPU_Assignment restriction in pragmas Restrictions and Restrictions_Warnings.
-RM References: 7.06.01 (17.1/1)
+RM references: D.07 (10/3) D.13 (6/3) D.13 (8/3) D.13 (10/3)
@end itemize
-@geindex AI-0065 (Ada 2012 feature)
+@geindex AI12-0059 (Ada 2022 feature)
@itemize *
@item
-`AI-0065 Remote access types and external streaming (0000-00-00)'
+`AI12-0059 Object_Size attribute (2019-12-02)'
-This AI clarifies the fact that all remote access types support external
-streaming. This fixes an obvious oversight in the definition of the
-language, and GNAT always implemented the intended correct rules.
+AI12-0059 brings GNAT-defined attribute Object_Size to Ada standard
+and clarifies its semantics. Given that the attribute already existed in
+GNAT compiler, the feature is supported for all language versions.
-RM References: 13.13.02 (52/2)
+RM references: 4.09.01 (2/3) 13.01 (14) 13.01 (23) 13.03 (9/3) 13.03
+(50/2) 13.03 (51) 13.03 (52) 13.03 (58)
@end itemize
-@geindex AI-0070 (Ada 2012 feature)
+@geindex AI12-0061 (Ada 2022 feature)
@itemize *
@item
-`AI-0070 Elaboration of interface types (0000-00-00)'
+`AI12-0061 Iterated component associations in array aggregates (2016-09-01)'
-This is an editorial change only, there are no testable consequences short of
-checking for the absence of generated code for an interface declaration.
+Ada issue AI12-061 introduces a new construct in array aggregates allowing
+component associations to be parameterized by a loop variable, for example:
-RM References: 3.09.04 (18/2)
+@example
+Array (1 .. 10) of Integer :=
+ (for I in 1 .. 10 => I ** 2);
+type Matrix is
+array
+ (Positive range <>, Positive range <>) of Float;
+G : constant Matrix
+:=
+ (for I in 1 .. 4 =>
+ (for J in 1 .. 4 =>
+ (if I=J then
+1.0 else 0.0))); -- Identity matrix
+@end example
+
+The expression in such an association can also be a function that returns a
+limited type, and the range can be specified by the ‘others’ choice.
+
+RM references: 4.03.03 (5/2) 4.03.03 (6) 4.03.03 (17/3) 4.03.03 (20)
+4.03.03 (23.1/4) 4.03.03 (32/3) 4.03.03 (43) 3.01 (6/3) 3.03 (6)
+3.03 (18.1/3) 3.03.01 (23/3) 5.05 (6) 8.01 (2.1/4)
@end itemize
-@geindex AI-0072 (Ada 2012 feature)
+@geindex AI12-0062 (Ada 2022 feature)
@itemize *
@item
-`AI-0072 Task signalling using ‘Terminated (0000-00-00)'
+`AI12-0062 Raise exception with failing string function (0000-00-00)'
-This AI clarifies that task signalling for reading @code{'Terminated} only
-occurs if the result is True. GNAT semantics has always been consistent with
-this notion of task signalling.
+Clarify that if raising exception E1 is accompanied with a String-valued
+expression whose evaluation raises exception E2, then E2 is what gets propagated.
-RM References: 9.10 (6.1/1)
+RM references: 11.03 (4/2)
@end itemize
-@geindex AI-0073 (Ada 2012 feature)
+@geindex AI12-0065 (Ada 2022 feature)
@itemize *
@item
-`AI-0073 Functions returning abstract types (2010-07-10)'
+`AI12-0065 Descendants of incomplete views (0000-00-00)'
-This AI covers a number of issues regarding returning abstract types. In
-particular generic functions cannot have abstract result types or access
-result types designated an abstract type. There are some other cases which
-are detailed in the AI. Note that this binding interpretation has not been
-retrofitted to operate before Ada 2012 mode, since it caused a significant
-number of regressions.
+This AI is a clarification of potentially confusing wording. GNAT correctly handles the example given in AARM 7.3.1(5.b-5.d), which illustrates the topic of this AI.
-RM References: 3.09.03 (8) 3.09.03 (10) 6.05 (8/2)
+RM references: 7.03.01 (5.2/3)
@end itemize
-@geindex AI-0076 (Ada 2012 feature)
+@geindex AI12-0067 (Ada 2022 feature)
@itemize *
@item
-`AI-0076 function with controlling result (0000-00-00)'
+`AI12-0067 Accessibility level of explicitly aliased parameters of procedures and entries (0000-00-00)'
-This is an editorial change only. The RM defines calls with controlling
-results, but uses the term ‘function with controlling result’ without an
-explicit definition.
+The AI fixes a case where the intent was fairly obvious but the RM wording failed to mention a case (with the result that the accessibility level of an explicitly aliased parameter of a procedure or entry was undefined even though the intent was clear).
-RM References: 3.09.02 (2/2)
+RM references: 3.10.02 (7/3)
@end itemize
-@geindex AI-0077 (Ada 2012 feature)
+@geindex AI12-0068 (Ada 2022 feature)
@itemize *
@item
-`AI-0077 Limited withs and scope of declarations (0000-00-00)'
+`AI12-0068 Predicates and the current instance of a subtype (2020-05-06)'
-This AI clarifies that a declaration does not include a context clause,
-and confirms that it is illegal to have a context in which both a limited
-and a nonlimited view of a package are accessible. Such double visibility
-was always rejected by GNAT.
+AI12-0068 is a binding interpretation that defines the current instance name in a type or subtype aspect to be a value rather than an object. This affects
+attributes whose prefix is a current instance in predicates, type invariants, and @code{Default_Initial_Condition} aspects. In particular, in the case of the @code{Constrained} attribute the value will always be True, and formerly legal attributes that require an object as their prefix (such as @code{Size}, @code{Access}, @code{Address}, etc.) are illegal when applied to a current instance in type and subtype aspects.
-RM References: 10.01.02 (12/2) 10.01.02 (21/2) 10.01.02 (22/2)
+RM references: 8.06 (17/3)
@end itemize
-@geindex AI-0078 (Ada 2012 feature)
+@geindex AI12-0069 (Ada 2022 feature)
@itemize *
@item
-`AI-0078 Relax Unchecked_Conversion alignment rules (0000-00-00)'
+`AI12-0069 Inconsistency in Tree container definition (0000-00-00)'
-In Ada 2012, compilers are required to support unchecked conversion where the
-target alignment is a multiple of the source alignment. GNAT always supported
-this case (and indeed all cases of differing alignments, doing copies where
-required if the alignment was reduced).
+The description of how iteration over a Tree container’s elements was contradictory in some cases regarding whether a cursor designating the Root node is included in the iteration. This contradiction was resolved. In the “!ACATS Test” section of the AI, it says that if an implementation were to get this wrong then almost any attempt to iterate over any tree would fail at runtime.
-RM References: 13.09 (7)
+RM references: A.18.10 (153/3) A.18.10 (155/3) A.18.10 (157/3) A.18.10 (159/3)
@end itemize
-@geindex AI-0079 (Ada 2012 feature)
+@geindex AI12-0070 (Ada 2022 feature)
@itemize *
@item
-`AI-0079 Allow other_format characters in source (2010-07-10)'
+`AI12-0070 9.3(2) does not work for anonymous access types (0000-00-00)'
-Wide characters in the unicode category `other_format' are now allowed in
-source programs between tokens, but not within a token such as an identifier.
+The RM contained some old wording about the master of an allocated object that only made sense for named access types. The AI clarifies the wording to clearly state the scope of validity and ensures that the paragraph does not contradict 3.10.2’s rules for anonymous access types.
-RM References: 2.01 (4/2) 2.02 (7)
+RM references: 3.10.02 (13.1/3) 9.03 (2)
@end itemize
-@geindex AI-0080 (Ada 2012 feature)
+@geindex AI12-0071 (Ada 2022 feature)
@itemize *
@item
-`AI-0080 ‘View of’ not needed if clear from context (0000-00-00)'
+`AI12-0071 Order of evaluation when multiple predicates apply (2015-08-10)'
-This is an editorial change only, described as non-testable in the AI.
+AI12-0071 specifies the semantics of multiple/inherited predicates on a
+single subtype.
-RM References: 3.01 (7)
+RM references: 3.02.04 (4/3) 3.02.04 (6/3) 3.02.04 (30/3) 3.02.04 (31/3)
+3.02.04 (32/3) 3.02.04 (33/3) 3.02.04 (35/3) 3.05.05 (7.1/3)
+3.05.05 (7.2/3) 3.05.05 (7.3/3) 3.08.01 (10.1/3) 3.08.01 (15/3)
+4.05.02 (29/3) 4.05.02 (30/3) 4.06 (51/3) 4.09.01 (10/3) 5.04
+(7/3) 5.05 (9/3) 13.09.02 (3/3) 13.09.02 (12)
@end itemize
-@geindex AI-0087 (Ada 2012 feature)
+@geindex AI12-0072 (Ada 2022 feature)
@itemize *
@item
-`AI-0087 Actual for formal nonlimited derived type (2010-07-15)'
+`AI12-0072 Missing rules for Discard_Names aspect (0000-00-00)'
-The actual for a formal nonlimited derived type cannot be limited. In
-particular, a formal derived type that extends a limited interface but which
-is not explicitly limited cannot be instantiated with a limited type.
+Clarify that Discard_Names is an aspect, not just a pragma.
-RM References: 7.05 (5/2) 12.05.01 (5.1/2)
+RM references: C.05 (1) C.05 (5) C.05 (7/2) C.05 (8)
@end itemize
-@geindex AI-0088 (Ada 2012 feature)
+@geindex AI12-0073 (Ada 2022 feature)
@itemize *
@item
-`AI-0088 The value of exponentiation (0000-00-00)'
+`AI12-0073 Synchronous Barriers are not allowed with Ravenscar (2020-02-24)'
-This AI clarifies the equivalence rule given for the dynamic semantics of
-exponentiation: the value of the operation can be obtained by repeated
-multiplication, but the operation can be implemented otherwise (for example
-using the familiar divide-by-two-and-square algorithm, even if this is less
-accurate), and does not imply repeated reads of a volatile base.
+Ada 2022 adds (as a binding interpretation) a @code{No_Dependence =>
+Ada.Synchronous_Barriers} restriction to the Ravenscar profile.
-RM References: 4.05.06 (11)
+RM references: D.13 (6/3)
@end itemize
-@geindex AI-0091 (Ada 2012 feature)
+@geindex AI12-0074 (Ada 2022 feature)
@itemize *
@item
-`AI-0091 Do not allow other_format in identifiers (0000-00-00)'
+`AI12-0074 View conversions and out parameters passed by copy (2020-03-26)'
-Wide characters in the unicode category `other_format' are not permitted
-within an identifier, since this can be a security problem. The error
-message for this case has been improved to be more specific, but GNAT has
-never allowed such characters to appear in identifiers.
+This Ada 2022 AI makes illegal some cases of out parameters whose type has a
+@code{Default_Value} aspect.
-RM References: 2.03 (3.1/2) 2.03 (4/2) 2.03 (5/2) 2.03 (5.1/2) 2.03 (5.2/2) 2.03 (5.3/2) 2.09 (2/2)
+RM references: 4.06 (56) 6.04.01 (6.25/3) 6.04.01 (13.1/3)
@end itemize
-@geindex AI-0093 (Ada 2012 feature)
+@geindex AI12-0075 (Ada 2022 feature)
@itemize *
@item
-`AI-0093 Additional rules use immutably limited (0000-00-00)'
+`AI12-0075 Static expression functions (2020-04-13)'
-This is an editorial change only, to make more widespread use of the Ada 2012
-‘immutably limited’.
+Ada 2022 defines a new aspect @code{Static} that can be specified on expression
+functions. Such an expression function can be called in contexts requiring static expressions when the actual parameters are all static, allowing for greater abstraction in complex static expressions.
-RM References: 3.03 (23.4/3)
+RM references: 4.09 (21) 6.08 (3/4) 6.08 (5/4) 6.08 (6/4) 7.03.02 (8.2/5)
+7.03.02 (15/4) 7.03.02 (16/4) 7.03.02 (17/4) 7.03.02 (19/4)
+7.03.02 (20/5)
@end itemize
-@geindex AI-0095 (Ada 2012 feature)
+@geindex AI12-0076 (Ada 2022 feature)
@itemize *
@item
-`AI-0095 Address of intrinsic subprograms (0000-00-00)'
+`AI12-0076 Variable state in pure packages (0000-00-00)'
-The prefix of @code{'Address} cannot statically denote a subprogram with
-convention @code{Intrinsic}. The use of the @code{Address} attribute raises
-@code{Program_Error} if the prefix denotes a subprogram with convention
-@code{Intrinsic}.
+Defines an obscure constant-modifying construct to be erroneous. The issue is that the current instance of a type is a variable object, so the following is legal:
-RM References: 13.03 (11/1)
+@example
+ type T;
+ type T_Ref (Access_To_Variable : access T) is null record;
+ type T is limited record
+ Self : T_Ref (T'Access);
+ Int : Integer;
+ end record;
+
+ Obj : constant T := (Self => <>, Int => 123);
+begin
+ Obj.Self.Access_To_Variable.Int := 456; -- modifying a component of a constant
+@end example
+
+In cases where constancy is really needed (e.g., for an object declared in a Pure context), such a case needs to be erroneous.
+
+RM references: 10.02.01 (17/3) E.02.02 (17/2)
@end itemize
-@geindex AI-0096 (Ada 2012 feature)
+@geindex AI12-0077 (Ada 2022 feature)
@itemize *
@item
-`AI-0096 Deriving from formal private types (2010-07-20)'
+`AI12-0077 Has_Same_Storage on objects of size zero (2020-03-30)'
-In general it is illegal for a type derived from a formal limited type to be
-nonlimited. This AI makes an exception to this rule: derivation is legal
-if it appears in the private part of the generic, and the formal type is not
-tagged. If the type is tagged, the legality check must be applied to the
-private part of the package.
+This binding interpretation requires the Has_Same_Storage attribute
+to return always @cite{false} for objects that have a size of zero.
-RM References: 3.04 (5.1/2) 6.02 (7)
+RM references: 13.03 (73.4/3)
@end itemize
-@geindex AI-0097 (Ada 2012 feature)
+@geindex AI12-0078 (Ada 2022 feature)
@itemize *
@item
-`AI-0097 Treatment of abstract null extension (2010-07-19)'
+`AI12-0078 Definition of node for tree container is confusing (0000-00-00)'
-The RM as written implied that in some cases it was possible to create an
-object of an abstract type, by having an abstract extension inherit a non-
-abstract constructor from its parent type. This mistake has been corrected
-in GNAT and in the RM, and this construct is now illegal.
+Clarifies the expected behavior in processing tree containers.
-RM References: 3.09.03 (4/2)
+RM references: A.18.10 (2/3) A.18.10 (3/3)
@end itemize
-@geindex AI-0098 (Ada 2012 feature)
+@geindex AI12-0081 (Ada 2022 feature)
@itemize *
@item
-`AI-0098 Anonymous subprogram access restrictions (0000-00-00)'
+`AI12-0081 Real-time aspects need to specify when they are evaluated (0000-00-00)'
-An unintentional omission in the RM implied some inconsistent restrictions on
-the use of anonymous access to subprogram values. These restrictions were not
-intentional, and have never been enforced by GNAT.
+Clarify the point at which Priority and Interrupt_Priority aspect expressions are evaluated.
-RM References: 3.10.01 (6) 3.10.01 (9.2/2)
+RM references: D.01 (17/3) D.16 (9/3)
@end itemize
-@geindex AI-0099 (Ada 2012 feature)
+@geindex AI12-0084 (Ada 2022 feature)
@itemize *
@item
-`AI-0099 Tag determines whether finalization needed (0000-00-00)'
+`AI12-0084 Box expressions in array aggregates (2014-12-15)'
-This AI clarifies that ‘needs finalization’ is part of dynamic semantics,
-and therefore depends on the run-time characteristics of an object (i.e. its
-tag) and not on its nominal type. As the AI indicates: “we do not expect
-this to affect any implementation”.
+This AI addresses an issue where compiler used to fail to initialize
+components of a multidimensional aggregates with box initialization when
+scalar components have a specified default value. The AI clarifies that
+in an array aggregate with box (i.e., @code{<>}) component values, the
+@code{Default_Component_Value} of the array type (if any) should not be ignored.
-RM References: 7.06.01 (6) 7.06.01 (7) 7.06.01 (8) 7.06.01 (9/2)
+RM references: 4.03.03 (23.1/2)
@end itemize
-@geindex AI-0100 (Ada 2012 feature)
+@geindex AI12-0085 (Ada 2022 feature)
@itemize *
@item
-`AI-0100 Placement of pragmas (2010-07-01)'
+`AI12-0085 Missing aspect cases for Remote_Types (0000-00-00)'
-This AI is an earlier version of AI-163. It simplifies the rules
-for legal placement of pragmas. In the case of lists that allow pragmas, if
-the list may have no elements, then the list may consist solely of pragmas.
+A distributed systems annex (Annex E) clarification. Aspect specifications
+that are forbidden using attribute definition clause syntax are also forbidden
+using aspect_specification syntax.
-RM References: 2.08 (7)
+RM references: E.02.02 (17/2)
@end itemize
-@geindex AI-0102 (Ada 2012 feature)
+@geindex AI12-0086 (Ada 2022 feature)
@itemize *
@item
-`AI-0102 Some implicit conversions are illegal (0000-00-00)'
+`AI12-0086 Aggregates and variant parts (2019-08-14)'
-It is illegal to assign an anonymous access constant to an anonymous access
-variable. The RM did not have a clear rule to prevent this, but GNAT has
-always generated an error for this usage.
+In Ada 2012, a discriminant value that governs an active variant part in an
+aggregate had to be static. AI12-0086 relaxes this restriction: If the subtype of the discriminant value is a static subtype all of whose values select the same variant, then the expression for the discriminant is allowed to be nonstatic.
-RM References: 3.07 (16) 3.07.01 (9) 6.04.01 (6) 8.06 (27/2)
+RM references: 4.03.01 (17/3) 4.03.01 (19/3)
@end itemize
-@geindex AI-0103 (Ada 2012 feature)
+@geindex AI12-0088 (Ada 2022 feature)
@itemize *
@item
-`AI-0103 Static matching for extended return (2010-07-23)'
+`AI12-0088 UTF_Encoding.Conversions and overlong characters on input (0000-00-00)'
-If the return subtype of a function is an elementary type or a constrained
-type, the subtype indication in an extended return statement must match
-statically this return subtype.
+Clarify that overlong characters are acceptable on input even if we never generate them as output.
-RM References: 6.05 (5.2/2)
+RM references: A.04.11 (54/3) A.04.11 (55/3)
@end itemize
-@geindex AI-0104 (Ada 2012 feature)
+@geindex AI12-0089 (Ada 2022 feature)
@itemize *
@item
-`AI-0104 Null exclusion and uninitialized allocator (2010-07-15)'
+`AI12-0089 Accessibility rules need to take into account that a generic function is not a (0000-00-00)'
-The assignment @code{Ptr := new not null Some_Ptr;} will raise
-@code{Constraint_Error} because the default value of the allocated object is
-`null'. This useless construct is illegal in Ada 2012.
+Fix cases in RM wording where the accessibility rules for a function failed to take into account the fact that a generic function is not a function. For example, a generic function with an explicitly aliased parameter should be able to return references to that parameter in the same ways that a (non-generic) function can. The previous wording did not allow that.
-RM References: 4.08 (2)
+RM references: 3.10.02 (7/3) 3.10.02 (19.2/3) 3.10.02 (19.3/3) 6.05 (4/3)
@end itemize
-@geindex AI-0106 (Ada 2012 feature)
+@geindex AI12-0093 (Ada 2022 feature)
@itemize *
@item
-`AI-0106 No representation pragmas on generic formals (0000-00-00)'
+`AI12-0093 Iterator with indefinite cursor (0000-00-00)'
-The RM appeared to allow representation pragmas on generic formal parameters,
-but this was not intended, and GNAT has never permitted this usage.
+A clarification that confirms what GNAT is already doing.
-RM References: 13.01 (9.1/1)
+RM references: 5.05.02 (8/3) 5.05.02 (10/3)
@end itemize
-@geindex AI-0108 (Ada 2012 feature)
+@geindex AI12-0094 (Ada 2022 feature)
@itemize *
@item
-`AI-0108 Limited incomplete view and discriminants (0000-00-00)'
+`AI12-0094 An access_definition should be a declarative region (0000-00-00)'
-This AI confirms that an incomplete type from a limited view does not have
-discriminants. This has always been the case in GNAT.
+Fixes wording omission in the RM, confirming that the behaviour of GNAT is
+correct.
-RM References: 10.01.01 (12.3/2)
+RM references: 8.03 (2) 8.03 (26/3)
@end itemize
-@geindex AI-0109 (Ada 2012 feature)
+@geindex AI12-0095 (Ada 2022 feature)
@itemize *
@item
-`AI-0109 Redundant check in S’Class’Input (0000-00-00)'
+`AI12-0095 Generic formal types and constrained partial views (0000-00-00)'
-This AI is an editorial change only. It removes the need for a tag check
-that can never fail.
+Deciding whether an actual parameter corresponding to an explicitly aliased formal parameter is legal depends on (among other things) whether the parameter type has a constrained partial view. The AI clarifies how this compile-time checking works in the case of a generic formal type (assume the best in the spec and recheck each instance, assume the worst in a generic body).
-RM References: 13.13.02 (34/2)
+RM references: 3.10.02 (27.2/3) 4.06 (24.16/2) 6.04.01 (6.2/3) 12.05.01 (15)
@end itemize
-@geindex AI-0112 (Ada 2012 feature)
+@geindex AI12-0096 (Ada 2022 feature)
@itemize *
@item
-`AI-0112 Detection of duplicate pragmas (2010-07-24)'
+`AI12-0096 The exception raised when a subtype conversion fails a predicate check (0000-00-00)'
-This AI concerns giving names to various representation aspects, but the
-practical effect is simply to make the use of duplicate
-@code{Atomic[_Components]},
-@code{Volatile[_Components]}, and
-@code{Independent[_Components]} pragmas illegal, and GNAT
-now performs this required check.
+Clarify that the Predicate_Failure aspect works the same in a subtype conversion as in any other context.
-RM References: 13.01 (8)
+RM references: 4.06 (57/3)
@end itemize
-@geindex AI-0114 (Ada 2012 feature)
+@geindex AI12-0097 (Ada 2022 feature)
@itemize *
@item
-`AI-0114 Classification of letters (0000-00-00)'
+`AI12-0097 Tag of the return object of a simple return expression (0000-00-00)'
-The code points 170 (@code{FEMININE ORDINAL INDICATOR}),
-181 (@code{MICRO SIGN}), and
-186 (@code{MASCULINE ORDINAL INDICATOR}) are technically considered
-lower case letters by Unicode.
-However, they are not allowed in identifiers, and they
-return @code{False} to @code{Ada.Characters.Handling.Is_Letter/Is_Lower}.
-This behavior is consistent with that defined in Ada 95.
+Clarify wording about the tag of a function result in the case of a simple (i.e. not extended) return statement in a function with a class-wide result type.
-RM References: A.03.02 (59) A.04.06 (7)
+RM references: 6.05 (8/3)
@end itemize
-@geindex AI-0116 (Ada 2012 feature)
+@geindex AI12-0098 (Ada 2022 feature)
@itemize *
@item
-`AI-0116 Alignment of class-wide objects (0000-00-00)'
+`AI12-0098 Problematic examples for ATC (0000-00-00)'
-This AI requires that the alignment of a class-wide object be no greater
-than the alignment of any type in the class. GNAT has always followed this
-recommendation.
+The AI clarifies reference manual examples, there is no compiler impact.
-RM References: 13.03 (29) 13.11 (16)
+RM references: 9.07.04 (13)
@end itemize
-@geindex AI-0118 (Ada 2012 feature)
+@geindex AI12-0099 (Ada 2022 feature)
@itemize *
@item
-`AI-0118 The association of parameter associations (0000-00-00)'
+`AI12-0099 Wording problems with predicates (2020-05-04)'
-This AI clarifies the rules for named associations in subprogram calls and
-generic instantiations. The rules have been in place since Ada 83.
+When extending a task or protected type from an ancestor interface subtype with a predicate, a link error can occur due to the compiler failing to generate the predicate-checking function. This AI clarifies the requirement for such predicate inheritance for concurrent types.
-RM References: 6.04.01 (2) 12.03 (9)
+RM references: 3.02.04 (4/4) 3.02.04 (12/3) 3.02.04 (20/3)
@end itemize
-@geindex AI-0120 (Ada 2012 feature)
+@geindex AI12-0100 (Ada 2022 feature)
@itemize *
@item
-`AI-0120 Constant instance of protected object (0000-00-00)'
+`AI12-0100 A qualified expression makes a predicate check (2020-02-17)'
-This is an RM editorial change only. The section that lists objects that are
-constant failed to include the current instance of a protected object
-within a protected function. This has always been treated as a constant
-in GNAT.
+The compiler now enforces predicate checks on qualified expressions when the
+qualifying subtype imposes a predicate.
-RM References: 3.03 (21)
+RM references: 4.07 (4)
@end itemize
-@geindex AI-0122 (Ada 2012 feature)
+@geindex AI12-0101 (Ada 2022 feature)
@itemize *
@item
-`AI-0122 Private with and children of generics (0000-00-00)'
+`AI12-0101 Incompatibility of hidden untagged record equality (2019-10-31)'
+
+AI12-0101 is a binding interpretation that removes a legality rule that
+prohibited the declaration of a primitive equality function for a private type in the private part of its enclosing package (either before or after the completion of the type) when the type is completed as an untagged record type. Such declarations are now accepted in Ada 2012 and later Ada versions.
-This AI clarifies the visibility of private children of generic units within
-instantiations of a parent. GNAT has always handled this correctly.
+As a consequence of this work, some cases where the implementation of AI05-0123 was incomplete were corrected.
+More specifically, if a user-defined equality operator is present for an untagged record type in an Ada 2012 program, that user-defined equality operator will be (correctly) executed in some difficult-to-characterize cases where the predefined component-by-component comparison was previously being (incorrectly) executed. This can arise, for example, in the case of the predefined equality operation for an enclosing composite type that has a component of the user-defined primitive equality op’s operand type.
+This correction means that the impact of this change is not limited solely to code that was previously rejected at compile time.
-RM References: 10.01.02 (12/2)
+RM references: 4.05.02 (9.8/3)
@end itemize
-@geindex AI-0123 (Ada 2012 feature)
+@geindex AI12-0102 (Ada 2022 feature)
@itemize *
@item
-`AI-0123 Composability of equality (2010-04-13)'
+`AI12-0102 Stream_IO.File_Type has Preelaborable_Initialization (0000-00-00)'
+
+Modifies the declaration of one type in a predefined package. GNAT’s version of @code{Ada.Streams.Stream_IO} already had this modification (the @code{Preelaborable__Initialization} pragma).
+
+RM references: A.12.01 (5)
+@end itemize
-Equality of untagged record composes, so that the predefined equality for a
-composite type that includes a component of some untagged record type
-@code{R} uses the equality operation of @code{R} (which may be user-defined
-or predefined). This makes the behavior of untagged records identical to that
-of tagged types in this respect.
+@geindex AI12-0103 (Ada 2022 feature)
-This change is an incompatibility with previous versions of Ada, but it
-corrects a non-uniformity that was often a source of confusion. Analysis of
-a large number of industrial programs indicates that in those rare cases
-where a composite type had an untagged record component with a user-defined
-equality, either there was no use of the composite equality, or else the code
-expected the same composability as for tagged types, and thus had a bug that
-would be fixed by this change.
-RM References: 4.05.02 (9.7/2) 4.05.02 (14) 4.05.02 (15) 4.05.02 (24)
-8.05.04 (8)
+@itemize *
+
+@item
+`AI12-0103 Expression functions that are completions in package specifications (0000-00-00)'
+
+Clarifies that expression functions that are completions do not cause “general” freeze-everybody-in-sight freezing like a subprogram body.
+
+RM references: 13.14 (3/3) 13.14 (5/3)
@end itemize
-@geindex AI-0125 (Ada 2012 feature)
+@geindex AI12-0104 (Ada 2022 feature)
@itemize *
@item
-`AI-0125 Nonoverridable operations of an ancestor (2010-09-28)'
+`AI12-0104 Overriding an aspect is undefined (0000-00-00)'
-In Ada 2012, the declaration of a primitive operation of a type extension
-or private extension can also override an inherited primitive that is not
-visible at the point of this declaration.
+A clarification of the wording in RM, no compiler impact.
-RM References: 7.03.01 (6) 8.03 (23) 8.03.01 (5/2) 8.03.01 (6/2)
+RM references: 4.01.06 (4/3) 4.01.06 (17/3)
@end itemize
-@geindex AI-0126 (Ada 2012 feature)
+@geindex AI12-0105 (Ada 2022 feature)
@itemize *
@item
-`AI-0126 Dispatching with no declared operation (0000-00-00)'
+`AI12-0105 Pre and Post are not allowed on any subprogram completion (0000-00-00)'
-This AI clarifies dispatching rules, and simply confirms that dispatching
-executes the operation of the parent type when there is no explicitly or
-implicitly declared operation for the descendant type. This has always been
-the case in all versions of GNAT.
+Language-defined aspects (e.g., @code{Post}) cannot be specified as part of the completion of a subprogram declaration. Fix a hole in the RM wording to clarify that this general rule applies even in the special cases where the completion is either an expression function or a null procedure.
-RM References: 3.09.02 (20/2) 3.09.02 (20.1/2) 3.09.02 (20.2/2)
+RM references: 13.01.01 (18/3)
@end itemize
-@geindex AI-0127 (Ada 2012 feature)
+@geindex AI12-0106 (Ada 2022 feature)
@itemize *
@item
-`AI-0127 Adding Locale Capabilities (2010-09-29)'
+`AI12-0106 Write’Class aspect (0000-00-00)'
-This package provides an interface for identifying the current locale.
+Clarify that the syntax used in an ACATS test BDD2005 for specifying a class-wide streaming aspect is correct.
-RM References: A.19 A.19.01 A.19.02 A.19.03 A.19.05 A.19.06
-A.19.07 A.19.08 A.19.09 A.19.10 A.19.11 A.19.12 A.19.13
+RM references: 13.01.01 (28/3) 13.13.02 (38/3)
@end itemize
-@geindex AI-0128 (Ada 2012 feature)
+@geindex AI12-0107 (Ada 2022 feature)
@itemize *
@item
-`AI-0128 Inequality is a primitive operation (0000-00-00)'
+`AI12-0107 A prefixed view of a By_Protected_Procedure interface has convention protected (2020-06-05)'
-If an equality operator (“=”) is declared for a type, then the implicitly
-declared inequality operator (“/=”) is a primitive operation of the type.
-This is the only reasonable interpretation, and is the one always implemented
-by GNAT, but the RM was not entirely clear in making this point.
+A prefixed view of a subprogram with aspect Synchronization set to
+By_Protected_Procedure has convention protected.
-RM References: 3.02.03 (6) 6.06 (6)
+RM references: 6.03.01 (10.1/2) 6.03.01 (12) 6.03.01 (13)
@end itemize
-@geindex AI-0129 (Ada 2012 feature)
+@geindex AI12-0109 (Ada 2022 feature)
@itemize *
@item
-`AI-0129 Limited views and incomplete types (0000-00-00)'
+`AI12-0109 Representation of untagged derived types (2019-11-12)'
-This AI clarifies the description of limited views: a limited view of a
-package includes only one view of a type that has an incomplete declaration
-and a full declaration (there is no possible ambiguity in a client package).
-This AI also fixes an omission: a nested package in the private part has no
-limited view. GNAT always implemented this correctly.
+Ada disallows a nonconforming specification of a type-related representation
+aspect of an untagged by-reference type. The motivation for this rule is to ensure that a parent type and a later type derived from the parent agree with respect to such aspects. AI12-0109 disallows a construct that otherwise could be used to get around this rule: an aspect specification for the parent type that occurs after the declaration of the derived type.
-RM References: 10.01.01 (12.2/2) 10.01.01 (12.3/2)
+RM references: 13.01 (10/3)
@end itemize
-@geindex AI-0132 (Ada 2012 feature)
+@geindex AI12-0110 (Ada 2022 feature)
@itemize *
@item
-`AI-0132 Placement of library unit pragmas (0000-00-00)'
+`AI12-0110 Tampering checks are performed first (2020-04-14)'
-This AI fills a gap in the description of library unit pragmas. The pragma
-clearly must apply to a library unit, even if it does not carry the name
-of the enclosing unit. GNAT has always enforced the required check.
+AI12-0110 requires tampering checks in the containers library to be
+performed first, before any other checks.
-RM References: 10.01.05 (7)
+RM references: A.18.02 (97.1/3) A.18.03 (69.1/3) A.18.04 (15.1/3) A.18.07
+(14.1/3) A.18.10 (90/3) A.18.18 (35/3)
@end itemize
-@geindex AI-0134 (Ada 2012 feature)
+@geindex AI12-0112 (Ada 2022 feature)
@itemize *
@item
-`AI-0134 Profiles must match for full conformance (0000-00-00)'
+`AI12-0112 Contracts for container operations (0000-00-00)'
-For full conformance, the profiles of anonymous-access-to-subprogram
-parameters must match. GNAT has always enforced this rule.
+A representation change replacing english descriptions of contracts for
+operations on predefined container types with pre/post-conditions. No compiler
+impact.
-RM References: 6.03.01 (18)
+RM references: A.18.02 (99/3) 11.04.02 (23.1/3) 11.05 (23) 11.05 (26) A
+(4) A.18 (10)
@end itemize
-@geindex AI-0137 (Ada 2012 feature)
+@geindex AI12-0114 (Ada 2022 feature)
@itemize *
@item
-`AI-0137 String encoding package (2010-03-25)'
+`AI12-0114 Overlapping objects designated by access parameters are not thread-safe (0000-00-00)'
-The packages @code{Ada.Strings.UTF_Encoding}, together with its child
-packages, @code{Conversions}, @code{Strings}, @code{Wide_Strings},
-and @code{Wide_Wide_Strings} have been
-implemented. These packages (whose documentation can be found in the spec
-files @code{a-stuten.ads}, @code{a-suenco.ads}, @code{a-suenst.ads},
-@code{a-suewst.ads}, @code{a-suezst.ads}) allow encoding and decoding of
-@code{String}, @code{Wide_String}, and @code{Wide_Wide_String}
-values using UTF coding schemes (including UTF-8, UTF-16LE, UTF-16BE, and
-UTF-16), as well as conversions between the different UTF encodings. With
-the exception of @code{Wide_Wide_Strings}, these packages are available in
-Ada 95 and Ada 2005 mode as well as Ada 2012 mode.
-The @code{Wide_Wide_Strings} package
-is available in Ada 2005 mode as well as Ada 2012 mode (but not in Ada 95
-mode since it uses @code{Wide_Wide_Character}).
+There are rules saying that concurrent calls to predefined subprograms don’t interfere with each other unless actual parameters overlap. The AI clarifies that such an interference is also possible if overlapping objects are reachable via access dereferencing from actual parameters of the two calls.
-RM References: A.04.11
+RM references: A (3/2)
@end itemize
-@geindex AI-0139-2 (Ada 2012 feature)
+@geindex AI12-0116 (Ada 2022 feature)
@itemize *
@item
-`AI-0139-2 Syntactic sugar for iterators (2010-09-29)'
+`AI12-0116 Private types and predicates (0000-00-00)'
-The new syntax for iterating over arrays and containers is now implemented.
-Iteration over containers is for now limited to read-only iterators. Only
-default iterators are supported, with the syntax: @code{for Elem of C}.
+Clarify that the same aspect cannot be specified twice for the same type. @code{Dynamic_Predicate}, for example, can be specified on either the partial view of a type or on the completion in the private part, but not on both.
-RM References: 5.05
+RM references: 13.01 (9/3) 13.01 (9.1/3)
@end itemize
-@geindex AI-0146 (Ada 2012 feature)
+@geindex AI12-0117 (Ada 2022 feature)
@itemize *
@item
-`AI-0146 Type invariants (2009-09-21)'
+`AI12-0117 Restriction No_Tasks_Unassigned_To_CPU (2020-06-12)'
-Type invariants may be specified for private types using the aspect notation.
-Aspect @code{Type_Invariant} may be specified for any private type,
-@code{Type_Invariant'Class} can
-only be specified for tagged types, and is inherited by any descendent of the
-tagged types. The invariant is a boolean expression that is tested for being
-true in the following situations: conversions to the private type, object
-declarations for the private type that are default initialized, and
-[`in'] `out'
-parameters and returned result on return from any primitive operation for
-the type that is visible to a client.
-GNAT defines the synonyms @code{Invariant} for @code{Type_Invariant} and
-@code{Invariant'Class} for @code{Type_Invariant'Class}.
+This AI adds a restriction No_Tasks_Unassigned_To_CPU to provide safe
+use of Ravenscar.
-RM References: 13.03.03 (00)
+The CPU aspect is specified for the environment task. No CPU aspect is
+specified to be statically equal to @code{Not_A_Specific_CPU}. If aspect CPU
+is specified (dynamically) to the value @code{Not_A_Specific_CPU}, then
+Program_Error is raised. If Set_CPU or @code{Delay_Until_And_Set_CPU} are called
+with the CPU parameter equal to @code{Not_A_Specific_CPU}, then @code{Program_Error} is raised.
+
+RM references: D.07 (10.8/3)
@end itemize
-@geindex AI-0147 (Ada 2012 feature)
+@geindex AI12-0120 (Ada 2022 feature)
@itemize *
@item
-`AI-0147 Conditional expressions (2009-03-29)'
+`AI12-0120 Legality and exceptions of generalized loop iteration (0000-00-00)'
-Conditional expressions are permitted. The form of such an expression is:
+Clarify that the expansion-based definition of generalized loop iteration
+includes legality checking. If the expansion would be illegal (for example,
+because of passing a constant actual parameter in a call when the mode of
+the corresponding formal parameter is in-out), then the loop is illegal too.
-@example
-(if expr then expr @{elsif expr then expr@} [else expr])
-@end example
+RM references: 5.05.02 (6.1/4) 5.05.02 (10/3) 5.05.02 (13/3)
+@end itemize
-The parentheses can be omitted in contexts where parentheses are present
-anyway, such as subprogram arguments and pragma arguments. If the `else'
-clause is omitted, `else' `True' is assumed;
-thus @code{(if A then B)} is a way to conveniently represent
-`(A implies B)' in standard logic.
+@geindex AI12-0121 (Ada 2022 feature)
-RM References: 4.03.03 (15) 4.04 (1) 4.04 (7) 4.05.07 (0) 4.07 (2)
-4.07 (3) 4.09 (12) 4.09 (33) 5.03 (3) 5.03 (4) 7.05 (2.1/2)
+
+@itemize *
+
+@item
+`AI12-0121 Stream-oriented aspects (0000-00-00)'
+
+Clarify that streaming-oriented aspects (e.g., Read) can be specified using
+aspect_specification syntax, not just via an attribute definition clause.
+
+RM references: 13.13.02 (38/3)
@end itemize
-@geindex AI-0152 (Ada 2012 feature)
+@geindex AI12-0124 (Ada 2022 feature)
@itemize *
@item
-`AI-0152 Restriction No_Anonymous_Allocators (2010-09-08)'
+`AI12-0124 Add Object’Image (2017-03-24)'
-Restriction @code{No_Anonymous_Allocators} prevents the use of allocators
-where the type of the returned value is an anonymous access type.
+The corrigendum of Ada 2012 extends attribute @code{'Image following} the syntax for the GNAT @code{'Img} attribute. This AI fixes a gap in the earlier implementation, which did not recognize function calls and attributes that are functions as valid object prefixes.
-RM References: H.04 (8/1)
+RM references: 3.05 (55/3)
@end itemize
-@geindex AI-0157 (Ada 2012 feature)
+@geindex AI12-0125-3 (Ada 2022 feature)
@itemize *
@item
-`AI-0157 Allocation/Deallocation from empty pool (2010-07-11)'
+`AI12-0125-3 Add @@ as an abbreviation for the LHS of an assignment (2016-11-11)'
-Allocation and Deallocation from an empty storage pool (i.e. allocation or
-deallocation of a pointer for which a static storage size clause of zero
-has been given) is now illegal and is detected as such. GNAT
-previously gave a warning but not an error.
+This AI introduces the use of the character ‘@@’ as an abbreviation for the left-hand side of an assignment statement, usable anywhere within the expression on the right-hand side. To use this feature the compilation flag -gnat2022 must be specified.
-RM References: 4.08 (5.3/2) 13.11.02 (4) 13.11.02 (17)
+RM references: 5.02.01 (0) 2.02 (9) 3.03 (21.1/3) 4.01 (2/3) 8.06 (9/4)
@end itemize
-@geindex AI-0158 (Ada 2012 feature)
+@geindex AI12-0127 (Ada 2022 feature)
@itemize *
@item
-`AI-0158 Generalizing membership tests (2010-09-16)'
+`AI12-0127 Partial aggregate notation (2016-10-12)'
-This AI extends the syntax of membership tests to simplify complex conditions
-that can be expressed as membership in a subset of values of any type. It
-introduces syntax for a list of expressions that may be used in loop contexts
-as well.
+This AI describes a new constructor for aggregates, in terms of an existing record or array object, and a series of component-wise modifications of its value, given by named associations for the modified components. To use this feature the compilation flag @code{-gnat2022} must be specified.
-RM References: 3.08.01 (5) 4.04 (3) 4.05.02 (3) 4.05.02 (5) 4.05.02 (27)
+RM references: 4.03 (2) 4.03 (3/2) 4.03 (4) 4.03.01 (9) 4.03.01 (15/3)
+4.03.01 (16/4) 4.03.01 (17/5) 4.03.01 (17.1/2) 4.03.03 (4) 4.03.03
+(14) 4.03.03 (17/5) 4.03.04 (0) 7.05 (2.6/2)
@end itemize
-@geindex AI-0161 (Ada 2012 feature)
+@geindex AI12-0128 (Ada 2022 feature)
@itemize *
@item
-`AI-0161 Restriction No_Default_Stream_Attributes (2010-09-11)'
+`AI12-0128 Exact size access to parts of composite atomic objects (2019-11-24)'
-A new restriction @code{No_Default_Stream_Attributes} prevents the use of any
-of the default stream attributes for elementary types. If this restriction is
-in force, then it is necessary to provide explicit subprograms for any
-stream attributes used.
+According to this AI, the compiler generates full access to atomic composite objects even if the access is only partial in the source code. To use this feature the compilation flag @code{-gnat2022} must be specified.
-RM References: 13.12.01 (4/2) 13.13.02 (40/2) 13.13.02 (52/2)
+RM references: C.06 (13.2/3) C.06 (19) C.06 (20) C.06 (22/2) C.06 (25/4)
@end itemize
-@geindex AI-0162 (Ada 2012 feature)
+@geindex AI12-0129 (Ada 2022 feature)
@itemize *
@item
-`AI-0162 Incomplete type completed by partial view (2010-09-15)'
+`AI12-0129 Make protected objects more protecting (2020-07-01)'
-Incomplete types are made more useful by allowing them to be completed by
-private types and private extensions.
+A new aspect Exclusive_Functions has been added to the language to force the
+use of read/write locks on protected functions when needed.
-RM References: 3.10.01 (2.5/2) 3.10.01 (2.6/2) 3.10.01 (3) 3.10.01 (4/2)
+RM references: 9.05.01 (2) 9.05.01 (4) 9.05.01 (5) 9.05.01 (7) 9.05.03
+(15) 9.05.03 (23)
@end itemize
-@geindex AI-0163 (Ada 2012 feature)
+@geindex AI12-0130 (Ada 2022 feature)
@itemize *
@item
-`AI-0163 Pragmas in place of null (2010-07-01)'
+`AI12-0130 All I/O packages should have Flush (2016-07-03)'
-A statement sequence may be composed entirely of pragmas. It is no longer
-necessary to add a dummy @code{null} statement to make the sequence legal.
+The Flush routine has been added for the @code{Sequential_IO} and @code{Direct_IO} standard packages in the Ada 2012 COR.1:2016. The Flush routine here is equivalent to the one found in @code{Text_IO}. The @code{Flush} procedure synchronizes the external file with the internal file (by flushing any internal buffers) without closing the file.
-RM References: 2.08 (7) 2.08 (16)
+RM references: A.08.01 (10) A.08.02 (28/3) A.08.04 (10) A.10.03 (21)
+A.12.01 (28/2) A.12.01 (28.6/1)
@end itemize
-@geindex AI-0171 (Ada 2012 feature)
+@geindex AI12-0131 (Ada 2022 feature)
@itemize *
@item
-`AI-0171 Pragma CPU and Ravenscar Profile (2010-09-24)'
+`AI12-0131 Inherited Pre’Class when unspecified on initial subprogram (0000-00-00)'
-A new package @code{System.Multiprocessors} is added, together with the
-definition of pragma @code{CPU} for controlling task affinity. A new no
-dependence restriction, on @code{System.Multiprocessors.Dispatching_Domains},
-is added to the Ravenscar profile.
+If T1 is a tagged type with a primitive P that has no class-wide precondition,
+and if T2 is an extension of T1 which overrides the inherited primitive P, then that overriding P is not allowed to have a class-wide precondition. Allowing it would be ineffective except in corner cases where it would be confusing.
-RM References: D.13.01 (4/2) D.16
+RM references: 6.01.01 (17/3) 6.01.01 (18/3)
@end itemize
-@geindex AI-0173 (Ada 2012 feature)
+@geindex AI12-0132 (Ada 2022 feature)
@itemize *
@item
-`AI-0173 Testing if tags represent abstract types (2010-07-03)'
+`AI12-0132 Freezing of renames-as-body (2020-06-13)'
-The function @code{Ada.Tags.Type_Is_Abstract} returns @code{True} if invoked
-with the tag of an abstract type, and @code{False} otherwise.
+This AI clarifies that a renames-as-body freezes the expression of any
+expression function that it renames.
-RM References: 3.09 (7.4/2) 3.09 (12.4/2)
+RM references: 13.14 (5/3)
@end itemize
-@geindex AI-0176 (Ada 2012 feature)
+@geindex AI12-0133 (Ada 2022 feature)
@itemize *
@item
-`AI-0176 Quantified expressions (2010-09-29)'
+`AI12-0133 Type invariants and default initialized objects (0000-00-00)'
-Both universally and existentially quantified expressions are implemented.
-They use the new syntax for iterators proposed in AI05-139-2, as well as
-the standard Ada loop syntax.
+Clarify that invariant checking for a default-initialized object is performed regardless of where the object is declared (in particular, even when the full view of the type is visible).
-RM References: 1.01.04 (12) 2.09 (2/2) 4.04 (7) 4.05.09 (0)
+RM references: 7.03.02 (10.3/3)
@end itemize
-@geindex AI-0177 (Ada 2012 feature)
+@geindex AI12-0135 (Ada 2022 feature)
@itemize *
@item
-`AI-0177 Parameterized expressions (2010-07-10)'
+`AI12-0135 Enumeration types should be eligible for convention C (0000-00-00)'
-The new Ada 2012 notion of parameterized expressions is implemented. The form
-is:
+Ada previously allowed but did not require supporting specifying convention C for an enumeration type. Now it is required that an implementation shall support it.
+
+RM references: B.01 (14/3) B.01 (41/3) B.03 (65)
+@end itemize
+
+@geindex AI12-0136 (Ada 2022 feature)
+
+
+@itemize *
+
+@item
+`AI12-0136 Language-defined packages and aspect Default_Storage_Pool (0000-00-00)'
+
+Clarify that the effect of specifying Default_Storage_Pool for an instance of a predefined generic is implementation-defined. No compiler impact.
+
+RM references: 13.11.03 (5/3)
+@end itemize
+
+@geindex AI12-0137 (Ada 2022 feature)
+
+
+@itemize *
+
+@item
+`AI12-0137 Incomplete views and access to class-wide types (0000-00-00)'
+
+If the designated type of an access type is incomplete when the access type is declared, then we have rules about whether we get a complete view when a value of the access type is dereferenced. Clarify that analogous rules apply if the designated type is class-wide.
+
+RM references: 3.10.01 (2.1/2)
+@end itemize
+
+@geindex AI12-0138 (Ada 2022 feature)
+
+
+@itemize *
+
+@item
+`AI12-0138 Iterators of formal derived types (2021-02-11)'
+
+AI12-0138 specifies the legality rules for confirming specifications of
+nonoverridable aspects. This completes the legality checks for aspect @code{Implicit_Dereference} and simplifies the checks for those aspects that are inherited operations.
+
+RM references: 13.01.01 (18/4) 13.01.01 (34/3) 4.01.05 (6/3) 4.01.06 (5/3)
+4.01.06 (6/3) 4.01.06 (7/3) 4.01.06 (8/3) 4.01.06 (9/3) 5.05.01 (11/3)
+@end itemize
+
+@geindex AI12-0140 (Ada 2022 feature)
+
+
+@itemize *
+
+@item
+`AI12-0140 Access to unconstrained partial view when full view is constrained (0000-00-00)'
+
+Clarify some confusion about about whether what matters when checking whether designated subtypes statically match is the view of the designated type that is currently available v.s. the view that was available when the access type was declared.
+
+RM references: 3.02 (7/2) 7.03.01 (5/1)
+@end itemize
+
+@geindex AI12-0143 (Ada 2022 feature)
+
+
+@itemize *
+
+@item
+`AI12-0143 Using an entry index of a family in a precondition (2022-04-05)'
+
+Ada 2022 adds the @code{Index} attribute, which allows the use of the entry family index of an entry call within preconditions and post-conditions.
+
+RM references: 6.01.01 (30/3) 9.05.04 (5/3)
+@end itemize
+
+@geindex AI12-0144 (Ada 2022 feature)
+
+
+@itemize *
+
+@item
+`AI12-0144 Make Discrete_Random more flexible (2020-01-31)'
+
+A new function Random with First/Last parameters is provided in the
+@code{Ada.Numerics.Discrete_Random} package.
+
+RM references: A.05.02 (20) A.05.02 (32) A.05.02 (41) A.05.02 (42)
+@end itemize
+
+@geindex AI12-0145 (Ada 2022 feature)
+
+
+@itemize *
+
+@item
+`AI12-0145 Pool_of_Subpool returns null when called too early (0000-00-00)'
+
+Clarify that if you ask for the pool of a subpool (by calling @code{Pool_Of_Subpool}) before @code{Set_Pool_of_Subpool} is called, then the result is null.
+
+RM references: 13.11.04 (20/3)
+@end itemize
+
+@geindex AI12-0147 (Ada 2022 feature)
+
+
+@itemize *
+
+@item
+`AI12-0147 Expression functions and null procedures can be declared in a protected_body (2015-03-05)'
+
+AI12-0147 specifies that null procedures and expression functions are now
+allowed in protected bodies.
+
+RM references: 9.04 (8/1)
+@end itemize
+
+@geindex AI12-0149 (Ada 2022 feature)
+
+
+@itemize *
+
+@item
+`AI12-0149 Type invariants are checked for functions returning access-to-type (0000-00-00)'
+
+Extend the rule saying that @code{Type_Invariant} checks are performed for access-to-T parameters (where T has a specified @code{Type_Invariant}) so that the rule also applies to function results.
+
+RM references: 7.03.02 (19.3/4)
+@end itemize
+
+@geindex AI12-0150 (Ada 2022 feature)
+
+
+@itemize *
+
+@item
+`AI12-0150 Class-wide type invariants and statically bound calls (0000-00-00)'
+
+The same approach used in AI12-0113 to ensure that contract-related calls associated with a call to a subprogram “match” with respect to dispatching also applies to @code{Type_Invariant} checking.
+
+RM references: 7.03.02 (3/3) 7.03.02 (5/3) 7.03.02 (9/3) 7.03.02 (22/3)
+@end itemize
+
+@geindex AI12-0154 (Ada 2022 feature)
+
+
+@itemize *
+
+@item
+`AI12-0154 Aspects of library units (0000-00-00)'
+
+Clarify that an aspect_specification for a library unit is equivalent to a corresponding aspect-specifying pragma.
+
+RM references: 13.01.01 (32/3)
+@end itemize
+
+@geindex AI12-0156 (Ada 2022 feature)
+
+
+@itemize *
+
+@item
+`AI12-0156 Use subtype_indication in generalized iterators (0000-00-00)'
+
+For iterating over an array, we already allow (but do not require) explicitly providing a subtype indication in an iterator_specification. Tee AI generalizes this to handle the case where the element type of the array is of an anonymous access type. This also allows (but does not require) explicitly naming the cursor subtype in a generalized iterator.
+The main motivation for allowing these new cases is improving readability by making it easy to infer the (sub)type of the iteration object just by looking at the loop.
+
+RM references: 5.05.02 (2/3) 5.05.02 (5/4) 5.05.02 (7/3) 3.10.02 (11.1/2)
+@end itemize
+
+@geindex AI12-0157 (Ada 2022 feature)
+
+
+@itemize *
+
+@item
+`AI12-0157 Missing rules for expression functions (0000-00-00)'
+
+Clarify that an expression function behaves like a single-return-statement
+function in more cases: it can return an aggregate without extra parens, the expression has an applicable index constraint, and the same accessibility rules apply in both cases.
+
+For instance, the code below is legal:
@example
-function-specification is (expression)
+subtype S is String (1 .. 10);
+function f return S is (others => '?');
@end example
-This is exactly equivalent to the
-corresponding function body that returns the expression, but it can appear
-in a package spec. Note that the expression must be parenthesized.
+RM references: 3.10.02 (19.2/4) 3.10.02 (19.3/4) 4.03.03 (11/2) 6.08 (2/3)
+6.08 (3/3) 6.08 (5/3) 6.08 (6/3) 6.08 (7/3) 7.05 (2.9/3) 13.14
+(5.1/4) 13.14 (5.2/4) 13.14 (8/3) 13.14 (10.1/3) 13.14 (10.2/3)
+13.14 (10.3/3)
+@end itemize
+
+@geindex AI12-0160 (Ada 2022 feature)
-RM References: 13.11.01 (3/2)
+
+@itemize *
+
+@item
+`AI12-0160 Adding an indexing aspect to an indexable container type (0000-00-00)'
+
+If the parent type of a derived type has exactly one of the two indexing aspects (that is, constant_indexing and variable_indexing) specified, then the derived type cannot have a specification for the other one.
+
+RM references: 4.01.06 (6/4) 4.01.06 (9/4) 3.06 (22.2/3)
@end itemize
-@geindex AI-0178 (Ada 2012 feature)
+@geindex AI12-0162 (Ada 2022 feature)
@itemize *
@item
-`AI-0178 Incomplete views are limited (0000-00-00)'
+`AI12-0162 Memberships and Unchecked_Unions (0000-00-00)'
-This AI clarifies the role of incomplete views and plugs an omission in the
-RM. GNAT always correctly restricted the use of incomplete views and types.
+Clarify that membership tests for unchecked_union types work consistently when
+testing membership in more than one subtype (X in AA | BB | CC) as when
+testing for one.
-RM References: 7.05 (3/2) 7.05 (6/2)
+RM references: B.03.03 (25/2)
@end itemize
-@geindex AI-0179 (Ada 2012 feature)
+@geindex AI12-0164 (Ada 2022 feature)
@itemize *
@item
-`AI-0179 Statement not required after label (2010-04-10)'
+`AI12-0164 Max_Entry_Queue_Length aspect for entries (2019-06-11)'
-It is not necessary to have a statement following a label, so a label
-can appear at the end of a statement sequence without the need for putting a
-null statement afterwards, but it is not allowable to have only labels and
-no real statements in a statement sequence.
+AI12-0164 defines pragma and aspect @code{Max_Entry_Queue_Length} in addition
+to the GNAT-specific equivalents @code{Max_Queue_Length} and @code{Max_Entry_Queue_Depth}.
-RM References: 5.01 (2)
+RM references: D.04 (16)
@end itemize
-@geindex AI-0181 (Ada 2012 feature)
+@geindex AI12-0165 (Ada 2022 feature)
@itemize *
@item
-`AI-0181 Soft hyphen is a non-graphic character (2010-07-23)'
+`AI12-0165 Operations of class-wide types and formal abstract subprograms (2021-10-19)'
-From Ada 2005 on, soft hyphen is considered a non-graphic character, which
-means that it has a special name (@code{SOFT_HYPHEN}) in conjunction with the
-@code{Image} and @code{Value} attributes for the character types. Strictly
-speaking this is an inconsistency with Ada 95, but in practice the use of
-these attributes is so obscure that it will not cause problems.
+Ada 2022 specifies that when the controlling type of a formal abstract
+subprogram declaration is a formal type, and the actual type is a class-wide type T’Class, the actual subprogram can be an implicitly declared subprogram corresponding to a primitive operation of type T.
-RM References: 3.05.02 (2/2) A.01 (35/2) A.03.03 (21)
+RM references: 12.06 (8.5/2)
@end itemize
-@geindex AI-0182 (Ada 2012 feature)
+@geindex AI12-0166 (Ada 2022 feature)
@itemize *
@item
-`AI-0182 Additional forms for' @code{Character'Value} `(0000-00-00)'
+`AI12-0166 External calls to protected functions that appear to be internal calls (2016-11-15)'
-This AI allows @code{Character'Value} to accept the string @code{'?'} where
-@code{?} is any character including non-graphic control characters. GNAT has
-always accepted such strings. It also allows strings such as
-@code{HEX_00000041} to be accepted, but GNAT does not take advantage of this
-permission and raises @code{Constraint_Error}, as is certainly still
-permitted.
+According to this AI, the compiler rejects a call to a protected operation when the call appears within a precondition for another protected operation.
-RM References: 3.05 (56/2)
+RM references: 6.01.01 (34/3) 9.05 (3/3) 9.05 (7.1/3)
@end itemize
-@geindex AI-0183 (Ada 2012 feature)
+@geindex AI12-0167 (Ada 2022 feature)
@itemize *
@item
-`AI-0183 Aspect specifications (2010-08-16)'
+`AI12-0167 Type_Invariants and tagged-type View Conversions (0000-00-00)'
+
+This AI clarifies that no invariant check is performed in a case where an invariant-violating value is assigned to a component. This confirms the current compiler behavior.
-Aspect specifications have been fully implemented except for pre and post-
-conditions, and type invariants, which have their own separate AI’s. All
-forms of declarations listed in the AI are supported. The following is a
-list of the aspects supported (with GNAT implementation aspects marked)
+RM references: 7.03.02 (9/4)
@end itemize
+@geindex AI12-0168 (Ada 2022 feature)
-@multitable {xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx} {xxxxxxxxxxxxx}
-@headitem
-Supported Aspect
+@itemize *
-@tab
+@item
+`AI12-0168 Freezing of generic instantiations of generics with bodies (0000-00-00)'
-Source
+Adjust freezing rules to be compatible with AI12-0103-1. The change confirms the current compiler behavior.
-@item
+RM references: 13.14 (3/4)
+@end itemize
-@code{Ada_2005}
+@geindex AI12-0169 (Ada 2022 feature)
-@tab
-– GNAT
+@itemize *
-@item
+@item
+`AI12-0169 Aspect specifications for entry bodies (0000-00-00)'
-@code{Ada_2012}
+Change syntax to allow aspect specifications for implementation-defined aspects on entry bodies. The change doesn’t influence any of the language-defined aspects and is solely required for SPARK.
-@tab
+RM references: 9.05.02 (5)
+@end itemize
-– GNAT
+@geindex AI12-0170 (Ada 2022 feature)
-@item
-@code{Address}
+@itemize *
-@tab
+@item
+`AI12-0170 Abstract subprogram calls in class-wide precondition expressions (2020-07-06)'
-@item
+This AI specifies rules for calls to abstract functions within class-wide preconditions and postconditions.
-@code{Alignment}
+RM references: 3.09.03 (7) 6.01.01 (7/4) 6.01.01 (18/4) 6.01.01 (18.2/4)
+@end itemize
-@tab
+@geindex AI12-0172 (Ada 2022 feature)
-@item
-@code{Atomic}
+@itemize *
-@tab
+@item
+`AI12-0172 Raise expressions in limited contexts (2019-07-29)'
-@item
+The compiler has been enhanced to support the use of raise expressions in
+limited contexts.
-@code{Atomic_Components}
+RM references: 7.05 (2.1/3)
+@end itemize
-@tab
+@geindex AI12-0173 (Ada 2022 feature)
-@item
-@code{Bit_Order}
+@itemize *
-@tab
+@item
+`AI12-0173 Expression of an extended return statement (0000-00-00)'
-@item
+Fix the wording related to expression of an extended return statement that was made ambiguous by changes of syntax in other AI’s. No compiler changes involved.
-@code{Component_Size}
+RM references: 6.05 (3/2) 6.05 (5/3)
+@end itemize
-@tab
+@geindex AI12-0174 (Ada 2022 feature)
-@item
-@code{Contract_Cases}
+@itemize *
-@tab
+@item
+`AI12-0174 Aggregates of Unchecked_Unions using named notation (0000-00-00)'
-– GNAT
+In many cases, it is illegal to name a discriminant of an unchecked_union type. Relax this rule to allow the use of named notation in an aggregate of an unchecked_union type.
-@item
+RM references: B.03.03 (9/3)
+@end itemize
-@code{Discard_Names}
+@geindex AI12-0175 (Ada 2022 feature)
-@tab
-@item
+@itemize *
-@code{External_Tag}
+@item
+`AI12-0175 Preelaborable packages with address clauses (2020-03-20)'
-@tab
+The compiler nows accepts calls to certain functions that are essentially unchecked conversions in preelaborated library units. To use this feature the compilation flag @code{-gnat2022} must be specified.
-@item
+RM references: 10.02.01 (7)
+@end itemize
-@code{Favor_Top_Level}
+@geindex AI12-0179 (Ada 2022 feature)
-@tab
-– GNAT
+@itemize *
-@item
+@item
+`AI12-0179 Failure of postconditions of language-defined units (0000-00-00)'
-@code{Inline}
+A clarification that expressing postconditions for predefined units via RM wording or via @code{Post} aspect specifications are equivalent. In particular, the expression in such a @code{Post} aspect specification should not yield False. No implementation changes needed.
-@tab
+RM references: 1.01.03 (17/3) 11.04.02 (23.1/3)
+@end itemize
-@item
+@geindex AI12-0180 (Ada 2022 feature)
-@code{Inline_Always}
-@tab
+@itemize *
-– GNAT
+@item
+`AI12-0180 Using protected subprograms and entries within an invariant (2020-06-22)'
-@item
+AI12-0180 makes entries and protected subprograms directly visible within Invariant aspects of a task or protected type.
-@code{Invariant}
+RM references: 13.01.01 (12/3)
+@end itemize
-@tab
+@geindex AI12-0181 (Ada 2022 feature)
-– GNAT
-@item
+@itemize *
-@code{Machine_Radix}
+@item
+`AI12-0181 Self-referencing representation aspects (0000-00-00)'
-@tab
+Clarify that a name or expression which freezes an entity cannot occur in an aspect specification for that entity.
-@item
+RM references: 13.01 (9/4) 13.01 (9.1/4) 13.14 (19)
+@end itemize
-@code{No_Return}
+@geindex AI12-0182 (Ada 2022 feature)
-@tab
-@item
+@itemize *
-@code{Object_Size}
+@item
+`AI12-0182 Pre’Class and protected operations (0000-00-00)'
-@tab
+Confirm that Pre’Class and Post’Class cannot be specified for a protected operation. No language change.
-– GNAT
+RM references: 13.01.01 (16/3)
+@end itemize
-@item
+@geindex AI12-0184 (Ada 2022 feature)
-@code{Pack}
-@tab
+@itemize *
-@item
+@item
+`AI12-0184 Long Long C Data Types (2020-01-30)'
-@code{Persistent_BSS}
+Two new types @code{long_long} and @code{unsigned_long_long} are introduced in the package @code{Interfaces.C}.
-@tab
+RM references: B.03 (71.3/3)
+@end itemize
-– GNAT
+@geindex AI12-0185 (Ada 2022 feature)
-@item
-@code{Post}
+@itemize *
-@tab
+@item
+`AI12-0185 Resolution of postcondition-specific attributes (0000-00-00)'
-@item
+Clarify resolution rules for @code{'Old} and @code{'Result} attribute references to match original intent.
-@code{Pre}
+RM references: 6.01.01 (7/4) 6.01.01 (8/3) 6.01.01 (26.10/4) 6.01.01 (29/3)
+@end itemize
-@tab
+@geindex AI12-0186 (Ada 2022 feature)
-@item
-@code{Predicate}
+@itemize *
-@tab
+@item
+`AI12-0186 Profile freezing for the Access attribute (0000-00-00)'
-@item
+Clarify that the use of Some_Subprogram’Access does not freeze the profile of Some_Subprogram.
-@code{Preelaborable_Initialization}
+RM references: 13.14 (15)
+@end itemize
-@tab
+@geindex AI12-0187 (Ada 2022 feature)
-@item
-@code{Pure_Function}
+@itemize *
-@tab
+@item
+`AI12-0187 Stable properties of abstract data types (2020-11-04)'
-– GNAT
+Ada 2022 defines a new aspect, @code{Stable_Properties}, for use in
+generating additional postcondition checks for subprograms.
-@item
+RM references: 7.03.04 (0) 13.01.01 (4/3)
+@end itemize
-@code{Remote_Access_Type}
+@geindex AI12-0191 (Ada 2022 feature)
-@tab
-– GNAT
+@itemize *
-@item
+@item
+`AI12-0191 Clarify “part” for type invariants (0000-00-00)'
-@code{Shared}
+Clarify that for purposes of determining whether an invariant check is required for a “part” of an object, we do not look at “parts” which do not correspond to “parts” of the nominal type of the object. For example, if we have a parameter Param of a tagged type T1 (or equivalently of type T1’Class), and type T2 is an extension of T1 which declares a component Foo, and T1’Class (Param)’Tag = T2’Tag, then no invariant check is performed for Param’s Foo component (or any subcomponent thereof).
-@tab
+RM references: 3.03 (23/5) 3.09.01 (4.1/2) 6.08 (5.8/5) 7.03.02 (8.3/5)
+7.03.02 (8.4/5) 7.03.02 (8.5/5) 7.03.02 (8.6/5) 7.03.02 (8.7/5)
+7.03.02 (8.8/5) 7.03.02 (8.9/5) 7.03.02 (8.10/5) 7.03.02 (8.11/5)
+7.03.02 (8.12/5) 7.03.02 (10.1/4) 7.03.02 (15/5) 7.03.02 (17/4)
+7.03.02 (18/4) 7.03.02 (19/4) 13.13.02 (9/3)
+@end itemize
-– GNAT
+@geindex AI12-0192 (Ada 2022 feature)
-@item
-@code{Size}
+@itemize *
-@tab
+@item
+`AI12-0192 “requires late initialization” and protected types (2020-03-11)'
-@item
+This AI clarifies that components of a protected type require late initialization when their initialization references (implicitly) the current instance of the type.
-@code{Storage_Pool}
+RM references: 3.03.01 (8.1/2)
+@end itemize
-@tab
+@geindex AI12-0194 (Ada 2022 feature)
-@item
-@code{Storage_Size}
+@itemize *
-@tab
+@item
+`AI12-0194 Language-defined aspects and entry bodies (0000-00-00)'
-@item
+The AI Includes entry bodies on the list of bodies for which no language-defined aspects can be specified (although specifying an implementation-defined aspect may be allowed).
-@code{Stream_Size}
+A wording change, no implementation impact.
-@tab
+RM references: 13.01.01 (17/3)
+@end itemize
-@item
+@geindex AI12-0195 (Ada 2022 feature)
-@code{Suppress}
-@tab
+@itemize *
-@item
+@item
+`AI12-0195 Inheriting body but overriding precondition or postcondition (2021-08-11)'
-@code{Suppress_Debug_Info}
+Ada 2022 specifies that if a primitive with a class-wide precondition or
+postcondition is inherited, and some primitive function called in the class-wide precondition or postcondition is overridden, then a dispatching call to the first primitive with a controlling operand that has the tag of the overriding type is required to check both the interpretation using the overriding function and the interpretation using the original overridden function.
-@tab
+RM references: 6.01.01 (38/4)
+@end itemize
-– GNAT
+@geindex AI12-0196 (Ada 2022 feature)
-@item
-@code{Test_Case}
+@itemize *
-@tab
+@item
+`AI12-0196 Concurrent access to Ada container libraries (0000-00-00)'
-– GNAT
+Clarify that parallel execution of operations which use cursors to refer to different elements of the same container does not violate the rules about erroneous concurrent access in some cases. That is, if C1 and C2 are cursors that refer to different elements of some container, then it is ok to concurrently execute an operation that is passed C1 and which accesses one element of the container, with another operation (perhaps the same operation, perhaps not) that is passed C2 and which accesses another element of the container.
-@item
+RM references: A.18 (2/2) A.18.02 (125/2) A.18.02 (133/3) A.18.02 (135/3)
+A.18.03 (81/3) A.18.04 (36/3) A.18.07 (34/2) A.18.10 (116/3)
+@end itemize
-@code{Thread_Local_Storage}
+@geindex AI12-0198 (Ada 2022 feature)
-@tab
-– GNAT
+@itemize *
-@item
+@item
+`AI12-0198 Potentially unevaluated components of array aggregates (2020-05-13)'
-@code{Type_Invariant}
+Ada 2022 enforces the detection of components that belong to a nonstatic or
+null range of index values of an array aggregate.
-@tab
+RM references: 6.01.01 (22.1/4)
+@end itemize
-@item
+@geindex AI12-0199 (Ada 2022 feature)
-@code{Unchecked_Union}
-@tab
+@itemize *
-@item
+@item
+`AI12-0199 Abstract subprogram calls in class-wide invariant expressions (0000-00-00)'
-@code{Universal_Aliasing}
+Class-wide type invariants do not apply to abstract types, to avoid various
+problems. Define the notion of a “corresponding expression” for a class-wide
+type invariant, replacing references to components as appropriate, taking into
+account rules for corresponding and specified discriminants when applying them
+to a nonabstract descendant.
-@tab
+RM references: 7.03.02 (5/4) 7.03.02 (8/3)
+@end itemize
-– GNAT
+@geindex AI12-0201 (Ada 2022 feature)
-@item
-@code{Unmodified}
+@itemize *
-@tab
+@item
+`AI12-0201 Missing operations of static string types (2020-02-25)'
-– GNAT
+Relational operators and type conversions of static string types are now static in Ada 2022.
-@item
+RM references: 4.09 (9) 4.09 (19) 4.09 (20) 4.09 (24)
+@end itemize
-@code{Unreferenced}
+@geindex AI12-0203 (Ada 2022 feature)
-@tab
-– GNAT
+@itemize *
-@item
+@item
+`AI12-0203 Overriding a nonoverridable aspect (0000-00-00)'
-@code{Unreferenced_Objects}
+A corner case wording clarification that has no impact on compilers.
-@tab
+RM references: 4.01.05 (5.1/4) 4.01.05 (7/3)
+@end itemize
-– GNAT
+@geindex AI12-0204 (Ada 2022 feature)
-@item
-@code{Unsuppress}
+@itemize *
-@tab
+@item
+`AI12-0204 Renaming of a prefixed view (2020-02-24)'
-@item
+AI12-0204 clarifies that the prefix of a prefixed view that is renamed or
+passed as a formal subprogram must be renameable as an object.
-@code{Value_Size}
+RM references: 8.05.04 (5.2/2) 12.06 (8.3/2) 4.01.03 (13.1/2) 4.01.06 (9/5)
+@end itemize
-@tab
+@geindex AI12-0205 (Ada 2022 feature)
-– GNAT
-@item
+@itemize *
-@code{Volatile}
+@item
+`AI12-0205 Defaults for generic formal types (2021-04-01)'
-@tab
+AI12-0205 specifies syntax and semantics that provide defaults for formal types of generic units. The legality rules guarantee that the default subtype_mark that is specified for a formal type would be a legal actual in any instantiation of the generic unit.
-@item
+RM references: 12.03 (7/3) 12.03 (10) 12.05 (2.1/3) 12.05 (2.2/3) 12.05 (7/2)
+@end itemize
-@code{Volatile_Components}
+@geindex AI12-0206 (Ada 2022 feature)
-@tab
-@item
+@itemize *
+
+@item
+`AI12-0206 Nonoverridable should allow arbitrary kinds of aspects (0000-00-00)'
-@code{Warnings}
+A non-overridable aspect can have a value other than a name; for example, @code{Max_Entry_Queue_Length} is non-overridable and it has a scalar value.
+Part of adding support for @code{Max_Entry_Queue_Length} (which is already supported by GNAT).
-@tab
+RM references: 13.01.01 (18.2/4) 13.01.01 (18.3/4) 13.01.01 (18.6/4)
+@end itemize
-– GNAT
+@geindex AI12-0207 (Ada 2022 feature)
-@end multitable
+@itemize *
-@quotation
+@item
+`AI12-0207 Convention of anonymous access types (2020-02-01)'
-Note that for aspects with an expression, e.g. @code{Size}, the expression is
-treated like a default expression (visibility is analyzed at the point of
-occurrence of the aspect, but evaluation of the expression occurs at the
-freeze point of the entity involved).
-
-RM References: 3.02.01 (3) 3.02.02 (2) 3.03.01 (2/2) 3.08 (6)
-3.09.03 (1.1/2) 6.01 (2/2) 6.07 (2/2) 9.05.02 (2/2) 7.01 (3) 7.03
-(2) 7.03 (3) 9.01 (2/2) 9.01 (3/2) 9.04 (2/2) 9.04 (3/2)
-9.05.02 (2/2) 11.01 (2) 12.01 (3) 12.03 (2/2) 12.04 (2/2) 12.05 (2)
-12.06 (2.1/2) 12.06 (2.2/2) 12.07 (2) 13.01 (0.1/2) 13.03 (5/1)
-13.03.01 (0)
-@end quotation
+The convention of anonymous access elements of arrays now have the same convention as the array instead of convention Ada.
+
+RM references: 6.03.01 (13.1/3) B.01 (19) B.01 (21/3)
+@end itemize
+
+@geindex AI12-0208 (Ada 2022 feature)
+
+
+@itemize *
+
+@item
+`AI12-0208 Predefined Big numbers support (0000-00-00)'
+
+Add predefined package @code{Ada.Numerics.Big_Numbers}.
+
+RM references: A.05.05 (0) A.05.06 (0) A.05.07 (0)
+@end itemize
+
+@geindex AI12-0211 (Ada 2022 feature)
+
+
+@itemize *
+
+@item
+`AI12-0211 Interface types and inherited nonoverridable aspects (2020-08-24)'
+
+AI12-0211 introduces two new legality rules for Ada 2022. The first says that
+if a nonoverridable aspect is explicitly specified for a type that also inherits that aspect from another type (an ancestor or a progenitor), then the explicit aspect specification shall be confirming. The second says that if a type inherits a nonoverridable aspect from two different sources (this can only occur if at least one of the two is an interface type), then the two sources shall agree with respect to the given aspect. This AI is a binding interpretation, so these checks are performed even for earlier Ada versions. Because of compatibility concerns, an escape mechanism for suppressing these legality checks is provided: these new checks always pass if the @code{-gnatd.M} switch (relaxed RM semantics) is specified.
+
+RM references: 13.01.01 (18.3/5) 13.01.01 (18.4/4)
+@end itemize
+
+@geindex AI12-0212 (Ada 2022 feature)
+
+
+@itemize *
+
+@item
+`AI12-0212 Container aggregates; generalized array aggregates (0000-00-00)'
+
+The AI defines a new feature: generalized array aggregates that already exists in GNAT.
+
+RM references: 4.03.05 (0) 1.01.04 (12) 1.01.04 (13) 2.01 (15) 2.02 (9/5)
+3.07.01 (3) 3.08.01 (4) 4.03 (2/5) 4.03 (3/5) 4.03.01 (5) 4.03.03
+(3/2) 4.03.03 (4/5) 4.03.03 (5.1/5) 4.03.03 (9) 4.03.03 (17/5)
+4.03.03 (21) 4.03.03 (23.2/5) 4.03.03 (26) 4.03.03 (27) 4.03.03
+(31) 4.03.04 (4/5) 4.04 (3.1/3) 11.02 (3) 13.01.01 (5/3)
+13.01.01 (7/3) A.18.02 (8/3) A.18.02 (14/2) A.18.02 (47/2) A.18.02
+(175/2) A.18.03 (6/3) A.18.05 (3/3) A.18.06 (4/3) A.18.08 (3/3)
+A.18.09 (4/3)
+@end itemize
+
+@geindex AI12-0216 (Ada 2022 feature)
+
+
+@itemize *
+
+@item
+`AI12-0216 6.4.1(6.16-17/3) should never apply to composite objects (0000-00-00)'
+
+Fix wording so that parameter passing cases where there isn’t really any aliasing problems or evaluation order dependency are classified as acceptable.
+
+No compiler impact.
+
+RM references: 6.04.01 (6.17/3)
+@end itemize
+
+@geindex AI12-0217 (Ada 2022 feature)
+
+
+@itemize *
+
+@item
+`AI12-0217 Rules regarding restrictions on the use of the Old attribute are too strict (2020-03-25)'
+
+AI12-0217 loosens the rules regarding what is allowed as the prefix of a ‘Old
+attribute reference. In particular, a prefix is now only required to “statically name” (as opposed to the previous “statically denote”) an object. This means that components of composite objects that previously would have been illegal are now legal prefixes.
+
+RM references: 6.01.01 (24/3) 6.01.01 (27/3)
+@end itemize
+
+@geindex AI12-0220 (Ada 2022 feature)
+
+
+@itemize *
+
+@item
+`AI12-0220 Pre/Post for access-to-subprogram types (2020-04-14)'
+
+Contract aspects can now be specified for access-to-subprogram types, as
+defined for Ada 2022 in this AI.
+
+RM references: 6.01.01 (1/4) 6.01.01 (2/3) 6.01.01 (4/3) 6.01.01 (19/3)
+6.01.01 (28/3) 6.01.01 (29/3) 6.01.01 (39/3) 13.01.01 (12/5)
+@end itemize
+
+@geindex AI12-0222 (Ada 2022 feature)
+
+
+@itemize *
+
+@item
+`AI12-0222 Representation aspects and private types (0000-00-00)'
+
+Clarify that the rule against specifying a representation aspect for a type before the type is completely defined also applies in the case where aspect_specification syntax is used (not just in the case where a pragma or some other kind of representation item is used).
+
+GNAT already implements this.
+
+RM references: 13.01 (9/5) 13.01 (9.1/4) 13.01 (9.2/5)
+@end itemize
+
+@geindex AI12-0225 (Ada 2022 feature)
+
+
+@itemize *
+
+@item
+`AI12-0225 Prefix of Obj’Image (0000-00-00)'
+
+Clarify some Object vs. Value corner cases to allow names that do not denote objects in more contexts, such as a qualified expression as a prefix of an Image attribute.
+
+RM references: 3.05 (55.1/4)
+@end itemize
+
+@geindex AI12-0226 (Ada 2022 feature)
+
+
+@itemize *
+
+@item
+`AI12-0226 Make objects more consistent (0000-00-00)'
+
+Allow value conversions as objects. For instance this example becomes legal: @code{Long_Integer (Duration'Last)'Image}.
+
+RM references: 3.03 (11.1/3) 3.03 (21.1/3) 3.03 (23.8/5) 4.06 (58.1/4)
+4.06 (58.3/4)
+@end itemize
+
+@geindex AI12-0227 (Ada 2022 feature)
+
+
+@itemize *
+
+@item
+`AI12-0227 Evaluation of nonstatic universal expressions when no operators are involved (0000-00-00)'
+
+Nonstatic universal integer expressions are always evaluated at runtime as values of type root_integer; similarly, nonstatic universal real expressions are always evaluated at runtime as values of type root_real.
+This AI corrects a wording oversight. Previously, the above was only true if a call to operator was involved. With this change it is true in all cases.
+
+No compiler impact.
+
+RM references: 4.04 (10) 8.06 (29)
+@end itemize
+
+@geindex AI12-0228 (Ada 2022 feature)
+
+
+@itemize *
+
+@item
+`AI12-0228 Properties of qualified expressions used as names (2020-02-19)'
+
+This AI clarifies that properties of a qualified object pass through a
+qualified expression used as a name. Specifically, “aliased” and “known to be
+constrained” are not changed by a qualified expression.
+
+RM references: 3.03 (23.7/3) 3.10 (9/3)
+@end itemize
+
+@geindex AI12-0231 (Ada 2022 feature)
+
+
+@itemize *
+
+@item
+`AI12-0231 Null_Task_Id and Activation_Is_Complete (0000-00-00)'
+
+Add @code{Activation_Is_Complete} to the list of functions that raise P_E if passed @code{Null_Task_Id}, correcting an oversight.
+
+RM references: C.07.01 (15)
+@end itemize
+
+@geindex AI12-0232 (Ada 2022 feature)
+
+
+@itemize *
+
+@item
+`AI12-0232 Rules for pure generic bodies (0000-00-00)'
+
+Clarify the rules for a generic body nested in a pure library unit.
+
+RM references: 10.02.01 (9/3) 10.02.01 (15.1/3) 10.02.01 (15.5/3)
+@end itemize
+
+@geindex AI12-0233 (Ada 2022 feature)
+
+
+@itemize *
+
+@item
+`AI12-0233 Pre’Class for hidden operations of private types (0000-00-00)'
+
+Clarify how @code{Pre'Class} checking interacts with private-part overriding of inherited subprograms. A class-wide precondition can be checked at runtime even if it is specified in a private part that the caller cannot see into.
+
+RM references: 6.01.01 (38/4)
+@end itemize
+
+@geindex AI12-0234 (Ada 2022 feature)
+
+
+@itemize *
+
+@item
+`AI12-0234 Compare-and-swap for atomic objects (0000-00-00)'
+
+New predefined units for atomic operations (@code{System.Atomic_Operations} and child units thereof).
+
+RM references: C.06.01 (0) C.06.02 (0)
+@end itemize
+
+@geindex AI12-0235 (Ada 2022 feature)
+
+
+@itemize *
+
+@item
+`AI12-0235 System.Storage_Pools should be pure (0000-00-00)'
+
+Change the predefined package System.Storage_Pools from preelaborated to pure.
+
+RM references: 13.11 (5)
+@end itemize
+
+@geindex AI12-0236 (Ada 2022 feature)
+
+
+@itemize *
+
+@item
+`AI12-0236 declare expressions (2020-04-08)'
+
+A @code{declare expression} allows constant objects and renamings to be
+declared within an expression.
+
+RM references: 2.08 (6) 3.09.02 (3) 3.10.02 (9.1/3) 3.10.02 (16.1/3)
+3.10.02 (32.2/3) 4.03.02 (5.4/3) 4.03.03 (15.1/3) 4.04 (7/3)
+4.05.09 (0) 6.02 (10/4) 7.05 (2.1/5) 8.01 (2.1/4)
+@end itemize
+
+@geindex AI12-0237 (Ada 2022 feature)
+
+
+@itemize *
+
+@item
+`AI12-0237 Getting the representation of an enumeration value (2020-01-31)'
+
+The GNAT-specific attributes @code{Enum_Rep} and @code{Enum_Val} have been standardized and are now also supported as Ada 2022 attributes.
+
+RM references: 13.04 (10) 13.04 (11/3)
+@end itemize
+
+@geindex AI12-0242 (Ada 2022 feature)
+
+
+@itemize *
+
+@item
+`AI12-0242 Shorthand Reduction Expressions for Objects (0000-00-00)'
+
+Allow reduction expressions to iterate over an an array or an iterable object without having to explicitly create a value sequence.
+
+This allows, for instance, writing @code{A'Reduce("+", 0)} instead of the equivalent (but more verbose) @code{[for Value of A => Value]'Reduce("+", 0);}.
+
+RM references: 4.05.10 (0) 4.01.04 (6)
+@end itemize
+
+@geindex AI12-0247 (Ada 2022 feature)
+
+
+@itemize *
+
+@item
+`AI12-0247 Potentially Blocking goes too far for Detect_Blocking (0000-00-00)'
+
+During a protected action, a call on a subprogram that contains a potentially blocking operation is considered a bounded error (so raising P_E is optional).
+This rule imposed an unreasonable implementation burden.
+The new rule introduced by this AI allows ignoring (i.e., not detecting) the problem until execution of a potentially blocking operation is actually attempted.
+
+RM references: 9.05 (55/5) 9.05 (56/5) 9.05.01 (18/5) H.05 (5/2)
+@end itemize
+
+@geindex AI12-0249 (Ada 2022 feature)
+
+
+@itemize *
+
+@item
+`AI12-0249 User-defined numeric literals (2020-04-07)'
+
+Compiler support is added for three new aspects (@code{Integer_Literal}, @code{Real_Literal}, and @code{String_Literal}) as described in AI12-0249 (for @code{Integer_Literal} and @code{Real_Literal}), AI12-0295 (for @code{String_Literal}), and in two follow-up AIs (AI12-0325 and AI12-0342). For pre-Ada 2022 versions of Ada, these are treated as implementation-defined
+aspects. Some implementation work remains, particularly in the interactions between these aspects and tagged types.
+
+RM references: 4.02 (9) 4.02.01 (0) 4.09 (3)
+@end itemize
+
+@geindex AI12-0250 (Ada 2022 feature)
+
+
+@itemize *
+
+@item
+`AI12-0250 Iterator Filters (2020-05-19)'
+
+This AI defines Ada 2022 feature of iterator filters, which can be
+applied to loop parameter specifications and iterator specifications.
+
+RM references: 4.03.03 (21) 4.03.03 (26) 4.03.03 (31) 4.03.05 (0) 4.05.10
+(0) 5.05 (4) 5.05 (7) 5.05 (9/4) 5.05 (9.1/4) 5.05 (10)
+5.05.02 (2/3) 5.05.02 (10/3) 5.05.02 (11/3)
+@end itemize
+
+@geindex AI12-0252 (Ada 2022 feature)
+
+
+@itemize *
+
+@item
+`AI12-0252 Duplicate interrupt handlers under Ravenscar (2018-07-05)'
+
+Ada Issue AI12-0252 requires that the runtime shall terminate with a
+Program_Error when more than one interrupt handler is attached to the same interrupt and the restriction No_Dynamic_Attachment is in effect.
+
+RM references: C.03.01 (13)
+@end itemize
+
+@geindex AI12-0256 (Ada 2022 feature)
+
+
+@itemize *
+
+@item
+`AI12-0256 Aspect No_Controlled_Parts (2021-01-26)'
+
+The compiler now supports the Ada 2022 aspect No_Controlled_Parts (see
+AI12-0256). When specified for a type, this aspect requires that the type and any of its ancestors must not have any controlled parts.
+
+RM references: H.04.01 (0) 13.01.01 (18.7/5)
+@end itemize
+
+@geindex AI12-0258 (Ada 2022 feature)
+
+
+@itemize *
+
+@item
+`AI12-0258 Containers and controlled element types (0000-00-00)'
-@geindex AI-0185 (Ada 2012 feature)
+Most predefined containers are allowed to defer finalization of container elements until the finalization of the container. This allows implementation flexibility but causes problems in some cases. AI12-0258 tightens up the rules for the indefinite containers to say that finalization happens earlier - if a client needs the tighter finalization guarantees, then it can use the indefinite containers (even if the element subtype in question is definite). Other solutions involving the holder generic are also possible.
+
+GNAT implements these tighter element finalization requirements for instances of the indefinite container generics.
+
+RM references: A.18 (10/4)
+@end itemize
+
+@geindex AI12-0259 (Ada 2022 feature)
+
+
+@itemize *
+
+@item
+`AI12-0259 Lower bound of strings returned from Ada.Command_Line (0000-00-00)'
+
+Specify that the low-bound of a couple of predefined String-valued functions will always be one.
+
+RM references: A.15 (14) A.15 (16/3)
+@end itemize
+
+@geindex AI12-0260 (Ada 2022 feature)
+
+
+@itemize *
+
+@item
+`AI12-0260 Functions Is_Basic and To_Basic in Wide_Characters.Handling (2020-04-01)'
+
+AI12-0260 is implemented for Ada 2022, providing the new functions @code{Is_Basic} and @code{To_Basic} in package @code{Ada.Wide_Characters.Handling}.
+
+RM references: 1.02 (8/3) A.03.05 (8/3) A.03.05 (20/3) A.03.05 (21/3)
+A.03.05 (33/3) A.03.05 (61/3)
+@end itemize
+
+@geindex AI12-0261 (Ada 2022 feature)
+
+
+@itemize *
+
+@item
+`AI12-0261 Conflict in “private with” rules (0000-00-00)'
+
+If a library unit is only visible at some point because of a “private with”, there are legality rules about a name denoting that entity. The AI cleans up the wording so that it captures the intent in a corner case involving a private-child library-unit subprogram. The previous wording incorrectly caused this case to be illegal.
+
+RM references: 10.01.02 (12/3) 10.01.02 (13/2) 10.01.02 (14/2) 10.01.02
+(15/2) 10.01.02 (16/2)
+@end itemize
+
+@geindex AI12-0262 (Ada 2022 feature)
+
+
+@itemize *
+
+@item
+`AI12-0262 Map-Reduce attribute (0000-00-00)'
+
+The AI defines Reduction Expressions to allow the programmer to apply the
+Map-Reduce paradigm to map/transform a set of values to a new set of values,
+and then summarize/reduce the transformed values into a single result value.
+
+RM references: 4.01.04 (1) 4.01.04 (6) 4.01.04 (11) 4.05.10 (0)
+@end itemize
+
+@geindex AI12-0263 (Ada 2022 feature)
+
+
+@itemize *
+
+@item
+`AI12-0263 Update references to ISO/IEC 10646 (0000-00-00)'
+
+Change RM references to ISO/IEC 10646:2011 to instead refer to ISO/IEC 10646:2017. No compiler impact.
+
+RM references: 1.01.04 (14.2/3) 2.01 (1/3) 2.01 (3.1/3) 2.01 (4/3) 2.01
+(4.1/5) 2.01 (5/3) 2.01 (15/3) 2.01 (4.1/5) 2.01 (5/3) 2.03
+(4.1/5) 2.03 (5/3) 3.05.02 (2/3) 3.05.02 (3/3) 3.05.02 (4/3) A.01
+(36.1/3) A.01 (36.2/3) A.03.02 (32.6/5) A.03.05 (51.2/5) A.03.05
+(55/3) A.03.05 (59/3) A.04.10 (3/3) B.05 (21/5)
+@end itemize
+
+@geindex AI12-0264 (Ada 2022 feature)
+
+
+@itemize *
+
+@item
+`AI12-0264 Overshifting and overrotating (0000-00-00)'
+
+Clarify Shift and Rotate op behavior with large shift/rotate amounts.
+
+RM references: B.02 (9)
+@end itemize
+
+@geindex AI12-0265 (Ada 2022 feature)
+
+
+@itemize *
+
+@item
+`AI12-0265 Default_Initial_Condition for types (2020-11-13)'
+
+The aspect @code{Default_Initial_Condition}, originally proposed by SPARK and
+supported in GNAT, is now also included in Ada 2022. One change from the
+original implementation is that when the aspect is specified on ancestor types of a derived type, the ancestors’ check expressions also apply to the derived type.
+@code{Default_Initial_Condition} checks are also now applied in cases of default
+initialization of components, allocators, ancestor parts of extension aggregates, and box associations of aggregates.
+
+RM references: 7.03.03 (0) 1.01.03 (17.1/5) 11.04.02 (23.2/5) 11.04.02 (23.3/5)
+@end itemize
+
+@geindex AI12-0269 (Ada 2022 feature)
+
+
+@itemize *
+
+@item
+`AI12-0269 Aspect No_Return for functions reprise (2020-03-19)'
+
+This amendment has been implemented under the @code{-gnat2022} switch, and the
+compiler now accepts the aspect/pragma No_Return for functions and generic
+functions.
+
+RM references: 6.05.01 (0) 6.05.01 (1/3) 6.05.01 (3.1/3) 6.05.01 (3.4/3)
+6.05.01 (5/2) 6.05.01 (6/2) 6.05.01 (7/2) J.15.02 (2/3) J.15.02
+(3/3) J.15.02 (4/3)
+@end itemize
+
+@geindex AI12-0272 (Ada 2022 feature)
+
+
+@itemize *
+
+@item
+`AI12-0272 (part 1) Pre/Postconditions for formal subprograms (0000-00-00)'
+
+Pre and Post aspects can be specified for a generic formal subprogram. @code{Default_Initial_Condition} can be specified for a generic formal private type.
+
+GNAT implements this with an exception of the part related to @code{Default_Initial_Condition}.
+
+RM references: 6.01.01 (1/5) 6.01.01 (39/5) 7.03.03 (1/5) 7.03.03 (2/5)
+7.03.03 (8/5) 7.03.04 (5/5) F.01 (1)
+@end itemize
+
+@geindex AI12-0275 (Ada 2022 feature)
+
+
+@itemize *
+
+@item
+`AI12-0275 Make subtype_mark optional in object renames (2020-01-28)'
+
+AI12-0275 allows object renamings to be declared without an explicit
+subtype_mark or access_definition. This feature can be used by compiling
+with the switch @code{-gnat2022}.
+
+RM references: 8.05.01 (2/3) 8.05.01 (3/2)
+@end itemize
+
+@geindex AI12-0277 (Ada 2022 feature)
@itemize *
@item
-`AI-0185 Ada.Wide_[Wide_]Characters.Handling (2010-07-06)'
+`AI12-0277 The meaning of “accessibility level of the body of F” (0000-00-00)'
-Two new packages @code{Ada.Wide_[Wide_]Characters.Handling} provide
-classification functions for @code{Wide_Character} and
-@code{Wide_Wide_Character}, as well as providing
-case folding routines for @code{Wide_[Wide_]Character} and
-@code{Wide_[Wide_]String}.
+Clarify that the only time that an explicitly aliased formal parameter has different accessibility properties than an aliased part of a “normal” parameter is for the accessibility checking associated with a return statement.
-RM References: A.03.05 (0) A.03.06 (0)
+RM references: 3.10.02 (19.2/4)
@end itemize
-@geindex AI-0188 (Ada 2012 feature)
+@geindex AI12-0278 (Ada 2022 feature)
@itemize *
@item
-`AI-0188 Case expressions (2010-01-09)'
+`AI12-0278 Implicit conversions of anonymous return types (0000-00-00)'
+
+If a call to a function with an anonymous-access-type result is converted to a named access type, it doesn’t matter whether the conversion is implicit or explicit. the AI fixes hole where the previous rules didn’t cover the implicit conversion case.
+
+RM references: 3.10.02 (10.3/3)
+@end itemize
-Case expressions are permitted. This allows use of constructs such as:
+@geindex AI12-0279 (Ada 2022 feature)
+
+
+@itemize *
+
+@item
+`AI12-0279 Nonpreemptive dispatching needs more dispatching points (2020-04-17)'
+
+Ada 2022 defines a new aspect @cite{Yield} that can be specified in the declaration of a noninstance subprogram (including a generic formal subprogram), a generic subprogram, or an entry, to ensure that the associated subprogram has at least one task dispatching point during each invocation.
+
+RM references: D.02.01 (1.5/2) D.02.01 (7/5)
+@end itemize
+
+@geindex AI12-0280-2 (Ada 2022 feature)
+
+
+@itemize *
+
+@item
+`AI12-0280-2 Making ‘Old more flexible (2020-07-24)'
+
+For Ada 2022, AI12-0280-2 relaxes Ada’s restrictions on ‘Old attribute
+references whose attribute prefix does not statically name an entity. Previously, it was required that such an attribute reference must be unconditionally evaluated when the postcondition is evaluated; with the new rule, conditional evaluation is permitted if the relevant conditions can be evaluated upon entry to the subprogram with the same results as evaluation at the time of the postcondition’s evaluation. In this case, the ‘Old attribute prefix is evaluated conditionally (more specifically, the prefix is evaluated only if the result of that evaluation is going to be referenced later when the
+postcondition is evaluated).
+
+RM references: 6.01.01 (20/3) 6.01.01 (21/3) 6.01.01 (22/3) 6.01.01
+(22.1/4) 6.01.01 (22.2/5) 6.01.01 (23/3) 6.01.01 (24/3) 6.01.01
+(26/4) 6.01.01 (27/5) 6.01.01 (39/5)
+@end itemize
+
+@geindex AI12-0282 (Ada 2022 feature)
+
+
+@itemize *
+
+@item
+`AI12-0282 Atomic, Volatile, and Independent generic formal types (0000-00-00)'
+
+The AI specifies that the aspects @code{Atomic}, @code{Volatile}, @code{Independent}, @code{Atomic_Components}, @code{Volatile_Components}, and @code{Independent_Components} are specifiable for generic formal types. The actual type must have a matching specification.
+
+RM references: C.06 (6.1/3) C.06 (6.3/3) C.06 (6.5/3) C.06 (6.8/3) C.06
+(12/3) C.06 (12.1/3) C.06 (21/4)
+@end itemize
+
+@geindex AI12-0285 (Ada 2022 feature)
+
+
+@itemize *
+
+@item
+`AI12-0285 Syntax for Stable_Properties aspects (0000-00-00)'
+
+The AI establishes the required named notation for a Stable_Properties aspect specification in order to avoid syntactic ambiguities.
+
+With the old syntax, an example like
+
+@example
+type Ugh is ...
+ with Stable_Properties =\> Foo, Bar, Nonblocking, Pack;
+@end example
+
+was problematic; @code{Nonblocking} and @code{Pack} are other aspects, while @code{Foo} and @code{Bar} are @code{Stable_Properties} functions. With the clarified syntax, the example above shall be written as:
@example
-X := (case Y is when 1 => 2, when 2 => 3, when others => 31)
+type Ugh is ...
+ with Stable_Properties => (Foo, Bar), Nonblocking, Pack;
@end example
-RM References: 4.05.07 (0) 4.05.08 (0) 4.09 (12) 4.09 (33)
+RM references: 7.03.04 (2/5) 7.03.04 (3/5) 7.03.04 (4/5) 7.03.04 (6/5)
+7.03.04 (7/5) 7.03.04 (9/5) 7.03.04 (10/5) 7.03.04 (14/5) 13.01.01 (4/5)
+@end itemize
+
+@geindex AI12-0287 (Ada 2022 feature)
+
+
+@itemize *
+
+@item
+`AI12-0287 Legality Rules for null exclusions in renaming are too fierce (2020-02-17)'
+
+The null exclusion legality rules for generic formal object matching and object renaming now only apply to generic formal objects with mode in out.
+
+RM references: 8.05.01 (4.4/2) 8.05.01 (4.5/2) 8.05.01 (4.6/2) 8.05.04
+(4.2/2) 12.04 (8.3/2) 12.04 (8.4/2) 12.04 (8.5/2) 12.04 (8.2/5)
+12.06 (8.2/5)
+@end itemize
+
+@geindex AI12-0289 (Ada 2022 feature)
+
+
+@itemize *
+
+@item
+`AI12-0289 Implicitly null excluding anonymous access types and conformance (2020-06-09)'
+
+AI12-0289 is implemented for Ada 2022, allowing safer use of access parameters
+when the partial view of the designated type is untagged, but the full view is
+tagged.
+
+RM references: 3.10 (26)
+@end itemize
+
+@geindex AI12-0290 (Ada 2022 feature)
+
+
+@itemize *
+
+@item
+`AI12-0290 Restriction Pure_Barriers (2020-02-18)'
+
+The GNAT implementation of the Pure_Barriers restriction has
+been updated to match the Ada RM’s definition as specified
+in this AI. Some constructs that were accepted by the previous
+implementation are now rejected, and vice versa. In
+particular, the use of a component of a component of a
+protected record in a barrier expression, as in “when
+Some_Component.Another_Component =>”, formerly was (at least
+in some cases) not considered to be a violation of the
+Pure_Barriers restriction; that is no longer the case.
+
+RM references: D.07 (2) D.07 (10.10/4)
+@end itemize
+
+@geindex AI12-0291 (Ada 2022 feature)
+
+
+@itemize *
+
+@item
+`AI12-0291 Jorvik Profile (2020-02-19)'
+
+The Jorvik profile is now implemented, as defined in this AI.
+For Ada 2012 and earlier versions of Ada, Jorvik is an implementation-defined
+profile whose definition matches its Ada 2022 definition.
+
+RM references: D.13 (0) D.13 (1/3) D.13 (4/3) D.13 (6/4) D.13 (9/3) D.13
+(10/3) D.13 (11/4) D.13 (12/4)
+@end itemize
+
+@geindex AI12-0293 (Ada 2022 feature)
+
+
+@itemize *
+
+@item
+`AI12-0293 Add predefined FIFO_Streams packages (0000-00-00)'
+
+The AI adds @code{Ada.Streams.Storage} and its two subunits @code{Bounded} and @code{Unbounded}.
+
+RM references: 13.13.01 (1) 13.13.01 (9) 13.13.01 (9.1/1)
+@end itemize
+
+@geindex AI12-0295 (Ada 2022 feature)
+
+
+@itemize *
+
+@item
+`AI12-0295 User-defined string (2020-04-07)'
+
+Compiler support is added for three new aspects (@code{Integer_Literal}, @code{Real_Literal}, and @code{String_Literal}) as described in AI12-0249 (for @code{Integer_Literal} and @code{Real_Literal}), AI12-0295 (for @code{String_Literal}), and in two follow-up AIs (AI12-0325 and AI12-0342). For pre-Ada 2022 versions of Ada, these are treated as implementation-defined aspects. Some implementation work remains, particularly in the interactions between these aspects and tagged types.
+
+RM references: 4.02 (6) 4.02 (10) 4.02 (11) 3.06.03 (1) 4.02.01 (0) 4.09 (26/3)
+@end itemize
+
+@geindex AI12-0301 (Ada 2022 feature)
+
+
+@itemize *
+
+@item
+`AI12-0301 Predicates should be checked like constraints for types with Default_Value (2020-02-25)'
+
+This AI clarifies that predicate checks apply for objects that are initialized
+by default and that are of a type that has any components whose subtypes specify @code{Default_Value} or @code{Default_Component_Value}.
+
+RM references: 3.02.04 (31/4)
+@end itemize
+
+@geindex AI12-0304 (Ada 2022 feature)
+
+
+@itemize *
+
+@item
+`AI12-0304 Image attributes of language-defined types (2020-07-07)'
+
+According to this AI, @code{Put_Image} (and therefore @code{'Image}) is provided for
+the containers and for unbounded strings.
+
+RM references: 4.10 (0)
+@end itemize
+
+@geindex AI12-0306 (Ada 2022 feature)
+
+
+@itemize *
+
+@item
+`AI12-0306 Split null array aggregates from positional array aggregates (0000-00-00)'
+
+The AI clarifies the wording of the references RM paragraphs without introducing any language changes.
+
+RM references: 4.03.03 (2) 4.03.03 (3/2) 4.03.03 (9/5) 4.03.03 (26/5)
+4.03.03 (26.1/5) 4.03.03 (33/3) 4.03.03 (38) 4.03.03 (39) 4.03.03 (42)
+@end itemize
+
+@geindex AI12-0307 (Ada 2022 feature)
+
+
+@itemize *
+
+@item
+`AI12-0307 Resolution of aggregates (2020-08-13)'
+
+The proposed new syntax for aggregates in Ada 2022 uses square brackets as
+delimiters, and in particular allows @code{[]} as a notation for empty array and container aggregates. This syntax is currently available as an experimental feature under the @code{-gnatX} flag.
+
+RM references: 4.03 (3/5)
+@end itemize
+
+@geindex AI12-0309 (Ada 2022 feature)
+
+
+@itemize *
+
+@item
+`AI12-0309 Missing checks for pragma Suppress (0000-00-00)'
+
+The AI includes some previously overlooked run-time checks in the list of checks that are potentially suppressed via a pragma @code{Suppress}. For example, AI12-0251-1 adds a check that the number of chunks in a chunk_specification is not zero or negative. Clarify that suppressing @code{Program_Error_Check} suppresses that check too.
+
+RM references: 11.05 (10) 11.05 (19) 11.05 (20) 11.05 (22) 11.05 (24)
+@end itemize
+
+@geindex AI12-0311 (Ada 2022 feature)
+
+
+@itemize *
+
+@item
+`AI12-0311 Suppressing client-side assertions for language-defined units (0000-00-00)'
+
+The AI defines some new assertion policies that can be given as arguments in a Suppress pragma (e.g., Calendar_Assertion_Check). GNAT recognizes and ignores those new policies, the checks are not implemented.
+
+RM references: 11.04.02 (23.5/5) 11.05 (23) 11.05 (26)
+@end itemize
+
+@geindex AI12-0315 (Ada 2022 feature)
+
+
+@itemize *
+
+@item
+`AI12-0315 Image Attributes subclause improvements (0000-00-00)'
+
+Clarify that a named number or similar can be the prefix of an Image attribute reference.
+
+RM references: 4.10 (0)
+@end itemize
+
+@geindex AI12-0318 (Ada 2022 feature)
+
+
+@itemize *
+
+@item
+`AI12-0318 No_IO should apply to Ada.Directories (2020-01-31)'
+
+The restriction No_IO now applies to and prevents the use of the
+@code{Ada.Directories package}.
+
+RM references: H.04 (20/2) H.04 (24/3)
+@end itemize
+
+@geindex AI12-0321 (Ada 2022 feature)
+
+
+@itemize *
+
+@item
+`AI12-0321 Support for Arithmetic Atomic Operations and Test and Set (0000-00-00)'
+
+The AI adds some predefined atomic operations, e.g. package System.`@w{`}Atomic_Operations.Test_And_Set`@w{`}.
+
+RM references: C.06.03 (0) C.06.04 (0)
+@end itemize
+
+@geindex AI12-0325 (Ada 2022 feature)
+
+
+@itemize *
+
+@item
+`AI12-0325 Various issues with user-defined literals (2020-04-07)'
+
+Compiler support is added for three new aspects (@code{Integer_Literal}, @code{Real_Literal}, and @code{String_Literal}) as described in AI12-0249 (for @code{Integer_Literal} and @code{Real_Literal}), AI12-0295 (for @code{String_Literal}), and in two follow-up AIs (AI12-0325 and AI12-0342). For pre-Ada 2022 versions of Ada, these are treated as implementation-defined aspects. Some implementation work remains, particularly in the interactions between these aspects and tagged types.
+
+RM references: 4.02 (6) 4.02 (10) 4.02 (11) 4.02.01 (0)
+@end itemize
+
+@geindex AI12-0329 (Ada 2022 feature)
+
+
+@itemize *
+
+@item
+`AI12-0329 Naming of FIFO_Streams packages (0000-00-00)'
+
+The AI changes the name of predefined package @code{Ada.Streams.FIFO_Streams} to @code{Ada.Streams.Storage}.
+
+RM references: 13.13.01 (9/5) 13.13.01 (9.1/5)
+@end itemize
+
+@geindex AI12-0331 (Ada 2022 feature)
+
+
+@itemize *
+
+@item
+`AI12-0331 Order of finalization of a subpool (0000-00-00)'
+
+Clarify that when a subpool is being finalized, objects allocated from that subpool are finalized before (not after) they cease to exist (i.e. object’s storage has been reclaimed).
+
+RM references: 13.11.05 (5/3) 13.11.05 (6/3) 13.11.05 (7/3) 13.11.05
+(7.1/4) 13.11.05 (8/3) 13.11.05 (9/3)
+@end itemize
+
+@geindex AI12-0333 (Ada 2022 feature)
+
+
+@itemize *
+
+@item
+`AI12-0333 Predicate checks on out parameters (0000-00-00)'
+
+If a view conversion is passed as an actual parameter corresponding to an out-mode formal parameter, and if the subtype of the formal parameter has a predicate, then no predicate check associated with the conversion is performed.
+
+RM references: 3.02.04 (31/5) 4.06 (51/4) 6.04.01 (14)
+@end itemize
+
+@geindex AI12-0335 (Ada 2022 feature)
+
+
+@itemize *
+
+@item
+`AI12-0335 Dynamic accessibility check needed for some requeue targets (0000-00-00)'
+
+Define a new runtime accessibility check for a corner case involving requeue statements.
+
+RM references: 9.05.04 (7/4)
+@end itemize
+
+@geindex AI12-0336 (Ada 2022 feature)
+
+
+@itemize *
+
+@item
+`AI12-0336 Meaning of Time_Offset (0000-00-00)'
+
+The AI introduces changes to the predefined package @code{Ada.Calendar.Time_Zones}.
+
+RM references: 9.06.01 (6/2) 9.06.01 (35/2) 9.06.01 (40/2) 9.06.01 (41/2)
+9.06.01 (42/3) 9.06.01 (90/2) 9.06.01 (91/2)
+@end itemize
+
+@geindex AI12-0337 (Ada 2022 feature)
+
+
+@itemize *
+
+@item
+`AI12-0337 Simple_Name(“/”) in Ada.Directories (0000-00-00)'
+
+Clarify behavior of subprograms in the predefined package @code{Ada.Directories}. In particular, Simple_Name (“/”) should return “/” on Unix-like systems.
+
+RM references: A.16 (47/2) A.16 (74/2) A.16 (82/3)
+@end itemize
+
+@geindex AI12-0338 (Ada 2022 feature)
+
+
+@itemize *
+
+@item
+`AI12-0338 Type invariant checking and incomplete types (0000-00-00)'
+
+Clarify that type invariants for type T are not checked for incomplete types whose completion is not available, even if that completion has components of type T.
+
+RM references: 7.03.02 (20/5)
+@end itemize
+
+@geindex AI12-0339 (Ada 2022 feature)
+
+
+@itemize *
+
+@item
+`AI12-0339 Empty function for Container aggregates (2020-08-06)'
+
+To provide uniform support for container aggregates, all standard container
+libraries have been enhanced with a function Empty, to be used when initializing an aggregate prior to inserting the specified elements in the object being constructed. All products have been updated to remove the ambiguities that may have arisen from previous uses of entities named Empty in our sources, and the expansion of container aggregates uses Empty wherever needed.
+
+RM references: A.18.02 (8/5) A.18.02 (12.3/5) A.18.02 (78.2/5) A.18.02
+(98.6/5) A.18.03 (6/5) A.18.03 (10.2/5) A.18.03 (50.2/5) A.18.05
+(3/5) A.18.05 (7.2/5) A.18.05 (37.3/5) A.18.05 (46/2) A.18.06
+(4/5) A.18.06 (8.2/5) A.18.06 (51.4/5) A.18.08 (3/5) A.18.08
+(8.1/5) A.18.08 (59.2/5) A.18.08 (68/2) A.18.09 (4/5) A.18.09
+(9.1/5) A.18.09 (74.2/5) A.18.10 (15.2/5) A.18.18 (8.1/5) A.18.19
+(6.1/5) A.18.20 (6/3) A.18.21 (6/3) A.18.22 (6/3) A.18.23 (6/3)
+A.18.24 (6/3) A.18.25 (8/3)
+@end itemize
+
+@geindex AI12-0340 (Ada 2022 feature)
+
+
+@itemize *
+
+@item
+`AI12-0340 Put_Image should use a Text_Buffer (0000-00-00)'
+
+Add a new predefined package Ada.Strings.Text_Buffers (along with child units) and change the definition of Put_Image attribute to refer to it.
+
+RM references: A.04.12 (0) 4.10 (3.1/5) 4.10 (3.2/5) 4.10 (6/5) 4.10
+(25.2/5) 4.10 (28/5) 4.10 (31/5) 4.10 (41/5) H.04 (23.2/5) H.04 (23.11/5)
+@end itemize
+
+@geindex AI12-0342 (Ada 2022 feature)
+
+
+@itemize *
+
+@item
+`AI12-0342 Various issues with user-defined literals (part 2) (2020-04-07)'
+
+Compiler support is added for three new aspects (@code{Integer_Literal}, @code{Real_Literal}, and @code{String_Literal}) as described in AI12-0249 (for @code{Integer_Literal} and @code{Real_Literal}), AI12-0295 (for @code{String_Literal}), and in two follow-up AIs (AI12-0325 and AI12-0342). For pre-Ada 2022 versions of Ada, these are treated as implementation-defined aspects. Some implementation work remains, particularly in the interactions between these aspects and tagged types.
+
+RM references: 4.02.01 (0) 3.09.02 (1/2) 6.03.01 (22)
+@end itemize
+
+@geindex AI12-0343 (Ada 2022 feature)
+
+
+@itemize *
+
+@item
+`AI12-0343 Return Statement Checks (2020-04-02)'
+
+This binding interpretation has been implemented and the accessibility,
+predicate, and tag checks prescribed by RM 6.5 are now performed at the appropriate points, as required by this AI.
+
+RM references: 6.05 (5.12/5) 6.05 (8/4) 6.05 (8.1/3) 6.05 (21/3)
+@end itemize
+
+@geindex AI12-0345 (Ada 2022 feature)
+
+
+@itemize *
+
+@item
+`AI12-0345 Dynamic accessibility of explicitly aliased parameters (0000-00-00)'
+
+Further clarify (after AI12-0277) accessibility rules for explicitly aliased parameters.
+
+RM references: 3.10.02 (5) 3.10.02 (7/4) 3.10.02 (10.5/3) 3.10.02 (13.4/4)
+3.10.02 (19.2/5) 3.10.02 (21)
+@end itemize
+
+@geindex AI12-0350 (Ada 2022 feature)
+
+
+@itemize *
+
+@item
+`AI12-0350 Swap for Indefinite_Holders (0000-00-00)'
+
+Add a @code{Swap} procedure to the predefined package
+@code{Ada.Containers.Indefinite_Holders}. The AI also contains implementation advice for @code{Ada.Containers.Bounded_Indefinite_Holders}, a package that is not implemented by GNAT.
+
+RM references: A.18.18 (22/5) A.18.18 (67/5) A.18.18 (73/3) A.18.32 (13/5)
+@end itemize
+
+@geindex AI12-0351 (Ada 2022 feature)
+
+
+@itemize *
+
+@item
+`AI12-0351 Matching for actuals for formal derived types (2020-04-03)'
+
+This binding interpretation requires the compiler to checks
+that an actual subtype in a generic parameter association of an instantiation is statically compatible (even when the actual is unconstrained) with the ancestor of an associated nondiscriminated generic formal derived type.
+
+RM references: 12.05.01 (7) 12.05.01 (8)
+@end itemize
+
+@geindex AI12-0352 (Ada 2022 feature)
+
+
+@itemize *
+
+@item
+`AI12-0352 Early derivation and equality of untagged types (2020-07-09)'
+
+AI12-0352 clarifies that declaring a user-defined primitive equality operation for a record type T is illegal if it occurs after a type has been derived from T.
+
+RM references: 4.05.02 (9.8/4)
+@end itemize
+
+@geindex AI12-0356 (Ada 2022 feature)
+
+
+@itemize *
+
+@item
+`AI12-0356 Root_Storage_Pool_With_Subpools should have Preelaborable_Initialization (0000-00-00)'
+
+Add Preelaborable_Initialization pragmas for predefined types @code{Root_Storage_Pool_With_Subpools} and @code{Root_Subpool}.
+
+RM references: 13.11.04 (4/3) 13.11.04 (5/3)
+@end itemize
+
+@geindex AI12-0363 (Ada 2022 feature)
+
+
+@itemize *
+
+@item
+`AI12-0363 Fixes for Atomic and Volatile (2020-09-08)'
+
+This amendment has been implemented under the @code{-gnat2022} switch and the compiler now supports the @code{Full_Access_Only} aspect, which is mostly equivalent to GNAT’s @code{Volatile_Full_Access}.
+
+RM references: 3.10.02 (26/3) 9.10 (1/5) C.06 (6.4/3) C.06 (6.10/3) C.06
+(8.1/4) C.06 (12/5) C.06 (12.1/5) C.06 (13.3/5) C.06 (19.1/5)
+@end itemize
+
+@geindex AI12-0364 (Ada 2022 feature)
+
+
+@itemize *
+
+@item
+`AI12-0364 Add a modular atomic arithmetic package (0000-00-00)'
+
+Generalize support for atomic integer operations to extend to modular types. Add new predefined generic package,
+@code{System.Atomic_Operations.Modular_Arithmetic}.
+
+RM references: C.06.05 (0) C.06.04 (1/5) C.06.04 (2/5) C.06.04 (3/5)
+C.06.04 (9/5)
+@end itemize
+
+@geindex AI12-0366 (Ada 2022 feature)
+
+
+@itemize *
+
+@item
+`AI12-0366 Changes to Big_Integer and Big_Real (0000-00-00)'
+
+Simplify @code{Big_Integer `@w{`}and `@w{`}Big_Real} specs by eliminating explicit support for creating “invalid” values. No more
+@code{Optional_Big_[Integer,Real]} types.
+
+RM references: A.05.06 (0) A.05.07 (0)
+@end itemize
+
+@geindex AI12-0367 (Ada 2022 feature)
+
+
+@itemize *
+
+@item
+`AI12-0367 Glitches in aspect specifications (0000-00-00)'
+
+The AI clarifies a few wording omissions. For example, a specified Small value for a fixed point type has to be positive.
+
+RM references: 3.05.09 (8/2) 3.05.10 (2/1) 13.01 (9.1/5) 13.14 (10)
+@end itemize
+
+@geindex AI12-0368 (Ada 2022 feature)
+
+
+@itemize *
+
+@item
+`AI12-0368 Declare expressions can be static (2020-05-30)'
+
+AI12-0368 allows declare expressions to be static in Ada 2022.
+
+RM references: 4.09 (8) 4.09 (12.1/3) 4.09 (17) 6.01.01 (24.2/5) 6.01.01
+(24.3/5) 6.01.01 (24.4/5) 6.01.01 (24.5/5) C.04 (9)
@end itemize
-@geindex AI-0189 (Ada 2012 feature)
+@geindex AI12-0369 (Ada 2022 feature)
@itemize *
@item
-`AI-0189 No_Allocators_After_Elaboration (2010-01-23)'
+`AI12-0369 Relaxing barrier restrictions (2020-03-25)'
-This AI introduces a new restriction @code{No_Allocators_After_Elaboration},
-which says that no dynamic allocation will occur once elaboration is
-completed.
-In general this requires a run-time check, which is not required, and which
-GNAT does not attempt. But the static cases of allocators in a task body or
-in the body of the main program are detected and flagged at compile or bind
-time.
+The definitions of the @code{Simple_Barriers} and @code{Pure_Barriers} restrictions were modified by this AI, replacing uses of “statically denotes” with “statically names”. This means that in many cases (but not all) a barrier expression that references a subcomponent of a component of the protected type while subject to either of the two restrictions is now allowed; with the previous restriction definitions, such a barrier expression would not have been legal.
-RM References: D.07 (19.1/2) H.04 (23.3/2)
+RM references: D.07 (1.3/5) D.07 (10.12/5)
@end itemize
-@geindex AI-0190 (Ada 2012 feature)
+@geindex AI12-0372 (Ada 2022 feature)
@itemize *
@item
-`AI-0190 pragma Default_Storage_Pool (2010-09-15)'
+`AI12-0372 Static accessibility of “master of the call” (0000-00-00)'
-This AI introduces a new pragma @code{Default_Storage_Pool}, which can be
-used to control storage pools globally.
-In particular, you can force every access
-type that is used for allocation (`new') to have an explicit storage pool,
-or you can declare a pool globally to be used for all access types that lack
-an explicit one.
+Add an extra compile-time accessibility check for explicitly aliased parameters needed to prevent dangling references.
-RM References: D.07 (8)
+RM references: 3.10.02 (10.5/5) 3.10.02 (19.3/4) 6.04.01 (6.4/3)
@end itemize
-@geindex AI-0193 (Ada 2012 feature)
+@geindex AI12-0373 (Ada 2022 feature)
@itemize *
@item
-`AI-0193 Alignment of allocators (2010-09-16)'
+`AI12-0373 Bunch of fixes (0000-00-00)'
-This AI introduces a new attribute @code{Max_Alignment_For_Allocation},
-analogous to @code{Max_Size_In_Storage_Elements}, but for alignment instead
-of size.
+Small clarifications to various RM entries with minor impact on compiler implementation.
-RM References: 13.11 (16) 13.11 (21) 13.11.01 (0) 13.11.01 (1)
-13.11.01 (2) 13.11.01 (3)
+RM references: 3.01 (1) 4.02 (4) 4.02 (8/2) 4.02.01 (3/5) 4.02.01 (4/5)
+4.02.01 (5/5) 4.09 (17.3/5) 6.01.01 (41/5) 8.05.04 (4/3) 13.01.01
+(4/3) 13.01.01 (11/3) 13.14 (3/5)
@end itemize
-@geindex AI-0194 (Ada 2012 feature)
+@geindex AI12-0376 (Ada 2022 feature)
@itemize *
@item
-`AI-0194 Value of Stream_Size attribute (0000-00-00)'
+`AI12-0376 Representation changes finally allowed for untagged derived types (0000-00-00)'
-The @code{Stream_Size} attribute returns the default number of bits in the
-stream representation of the given type.
-This value is not affected by the presence
-of stream subprogram attributes for the type. GNAT has always implemented
-this interpretation.
+A change of representation for a derived type is allowed in some previously-illegal cases where a change of representation is required to implement a call to a derived subprogram.
-RM References: 13.13.02 (1.2/2)
+RM references: 13.01 (10/4)
@end itemize
-@geindex AI-0195 (Ada 2012 feature)
+@geindex AI12-0377 (Ada 2022 feature)
@itemize *
@item
-`AI-0195 Invalid value handling is implementation defined (2010-07-03)'
+`AI12-0377 View conversions and out parameters of types with Default_Value revisited (2020-06-17)'
-The handling of invalid values is now designated to be implementation
-defined. This is a documentation change only, requiring Annex M in the GNAT
-Reference Manual to document this handling.
-In GNAT, checks for invalid values are made
-only when necessary to avoid erroneous behavior. Operations like assignments
-which cannot cause erroneous behavior ignore the possibility of invalid
-values and do not do a check. The date given above applies only to the
-documentation change, this behavior has always been implemented by GNAT.
+This AI clarifies that an actual of an out parameter that is a view conversion
+is illegal if either the target or operand type has Default_Value specified while the other does not.
-RM References: 13.09.01 (10)
+RM references: 6.04.01 (5.1/4) 6.04.01 (5.2/4) 6.04.01 (5.3/4) 6.04.01
+(13.1/4) 6.04.01 (13.2/4) 6.04.01 (13.3/4) 6.04.01 (13.4/4) 6.04.01 (15/3)
@end itemize
-@geindex AI-0196 (Ada 2012 feature)
+@geindex AI12-0381 (Ada 2022 feature)
@itemize *
@item
-`AI-0196 Null exclusion tests for out parameters (0000-00-00)'
+`AI12-0381 Tag of a delta aggregate (0000-00-00)'
-Null exclusion checks are not made for @code{out} parameters when
-evaluating the actual parameters. GNAT has never generated these checks.
+In the case of a delta aggregate of a specific tagged type, the tag of the aggregate comes from the specific type (as opposed to somehow from the base object).
-RM References: 6.04.01 (13)
+RM references: 4.03.04 (14/5)
@end itemize
-@geindex AI-0198 (Ada 2012 feature)
+@geindex AI12-0382 (Ada 2022 feature)
@itemize *
@item
-`AI-0198 Inheriting abstract operators (0000-00-00)'
+`AI12-0382 Loosen type-invariant overriding requirement of AI12-0042-1 (0000-00-00)'
-This AI resolves a conflict between two rules involving inherited abstract
-operations and predefined operators. If a derived numeric type inherits
-an abstract operator, it overrides the predefined one. This interpretation
-was always the one implemented in GNAT.
+The AI relaxes some corner-case legality rules about type invariants that were added by AI12-0042-1.
-RM References: 3.09.03 (4/3)
+RM references: 7.3.2(6.1/4)
@end itemize
-@geindex AI-0199 (Ada 2012 feature)
+@geindex AI12-0383 (Ada 2022 feature)
@itemize *
@item
-`AI-0199 Aggregate with anonymous access components (2010-07-14)'
+`AI12-0383 Renaming values (2020-06-17)'
-A choice list in a record aggregate can include several components of
-(distinct) anonymous access types as long as they have matching designated
-subtypes.
+This AI allow names that denote values rather than objects to nevertheless be
+renamed using an object renaming.
-RM References: 4.03.01 (16)
+RM references: 8.05.01 (1) 8.05.01 (4) 8.05.01 (4.1/2) 8.05.01 (6/2) 8.05.01 (8)
@end itemize
-@geindex AI-0200 (Ada 2012 feature)
+@geindex AI12-0384-2 (Ada 2022 feature)
@itemize *
@item
-`AI-0200 Mismatches in formal package declarations (0000-00-00)'
+`AI12-0384-2 Fixups for Put_Image and Text_Buffers (2021-04-29)'
-This AI plugs a gap in the RM which appeared to allow some obviously intended
-illegal instantiations. GNAT has never allowed these instantiations.
+In GNAT’s initial implementation of the Ada 2022 @code{Put_Image} aspect and
+attribute, buffering was performed using a GNAT-defined package,
+@code{Ada.Strings.Text_Output}. Ada 2022 requires a different package, Ada.`@w{`}Strings.Text_Buffers`@w{`}, for this role, and that package is now provided, and the older package is eliminated.
-RM References: 12.07 (16)
+RM references: 4.10 (0) A.04.12 (0)
@end itemize
-@geindex AI-0201 (Ada 2012 feature)
+@geindex AI12-0385 (Ada 2022 feature)
@itemize *
@item
-`AI-0201 Independence of atomic object components (2010-07-22)'
+`AI12-0385 Predefined shifts and rotates should be static (0000-00-00)'
-If an Atomic object has a pragma @code{Pack} or a @code{Component_Size}
-attribute, then individual components may not be addressable by independent
-tasks. However, if the representation clause has no effect (is confirming),
-then independence is not compromised. Furthermore, in GNAT, specification of
-other appropriately addressable component sizes (e.g. 16 for 8-bit
-characters) also preserves independence. GNAT now gives very clear warnings
-both for the declaration of such a type, and for any assignment to its components.
+This AI allows Shift and Rotate operations in static expressions. GNAT implements this AI partially.
-RM References: 9.10 (1/3) C.06 (22/2) C.06 (23/2)
+RM references: 4.09 (20)
@end itemize
-@geindex AI-0203 (Ada 2012 feature)
+@geindex AI12-0389 (Ada 2022 feature)
@itemize *
@item
-`AI-0203 Extended return cannot be abstract (0000-00-00)'
+`AI12-0389 Ignoring unrecognized aspects (2020-10-08)'
-A return_subtype_indication cannot denote an abstract subtype. GNAT has never
-permitted such usage.
+Two new restrictions, @code{No_Unrecognized_Aspects} and @code{No_Unrecognized_Pragmas}, are available to make the compiler emit error messages on unrecognized pragmas and aspects.
-RM References: 3.09.03 (8/3)
+RM references: 13.01.01 (38/3) 13.12.01 (6.3/3)
@end itemize
-@geindex AI-0205 (Ada 2012 feature)
+@geindex AI12-0394 (Ada 2022 feature)
@itemize *
@item
-`AI-0205 Extended return declares visible name (0000-00-00)'
+`AI12-0394 Named Numbers and User-Defined Numeric Literals (2020-10-05)'
-This AI corrects a simple omission in the RM. Return objects have always
-been visible within an extended return statement.
+Ada 2022 allows using integer named numbers with types that have an
+@code{Integer_Literal} aspect. Similarly, real named numbers may now be used with types that have a @code{Real_Literal} aspect with an overloading that takes two strings, to be used in particular with
+@code{Ada.Numerics.Big_Numbers.Big_Reals}.
-RM References: 8.03 (17)
+RM references: 3.03.02 (3) 4.02.01 (4/5) 4.02.01 (8/5) 4.02.01 (12/5)
+4.02.01 (13/5) 4.09 (5)
@end itemize
-@geindex AI-0206 (Ada 2012 feature)
+@geindex AI12-0395 (Ada 2022 feature)
@itemize *
@item
-`AI-0206 Remote types packages and preelaborate (2010-07-24)'
+`AI12-0395 Allow aspect_specifications on formal parameters (0000-00-00)'
-Remote types packages are now allowed to depend on preelaborated packages.
-This was formerly considered illegal.
+Change syntax rules to allow aspect_specifications on formal parameters, if an implementation if an implementation wants to define one. Currently, GNAT doesn’t define any such aspect_specifications.
-RM References: E.02.02 (6)
+RM references: 6.01 (15/3)
@end itemize
-@geindex AI-0207 (Ada 2012 feature)
+@geindex AI12-0397 (Ada 2022 feature)
@itemize *
@item
-`AI-0207 Mode conformance and access constant (0000-00-00)'
+`AI12-0397 Default_Initial_Condition applied to derived type (2020-12-09)'
-This AI confirms that access_to_constant indication must match for mode
-conformance. This was implemented in GNAT when the qualifier was originally
-introduced in Ada 2005.
+The compiler now implements the rules for resolving @code{Default_Initial_Condition}
+expressions that involve references to the current instance of types with the aspect, as specified by this AI. The type of the current instance is defined to be like a formal derived type, so for a derived type that inherits the aspect, a call passing the current instance to a primitive means that the call will resolve to invoke the corresponding primitive of the descendant type. This also now permits calls to abstract primitives to occur within the aspect expression of an abstract type.
-RM References: 6.03.01 (16/2)
+RM references: 7.03.03 (3/5) 7.03.03 (6/5) 7.03.03 (8/5)
@end itemize
-@geindex AI-0208 (Ada 2012 feature)
+@geindex AI12-0398 (Ada 2022 feature)
@itemize *
@item
-`AI-0208 Characteristics of incomplete views (0000-00-00)'
+`AI12-0398 Most declarations should have aspect specifications (2020-11-19)'
-The wording in the Ada 2005 RM concerning characteristics of incomplete views
-was incorrect and implied that some programs intended to be legal were now
-illegal. GNAT had never considered such programs illegal, so it has always
-implemented the intent of this AI.
+It is now possible to specify aspects for discriminant specifications, extended return object declarations, and entry index specifications. This is an extension added for Ada 2022 by this AI.
-RM References: 3.10.01 (2.4/2) 3.10.01 (2.6/2)
+RM references: 3.07 (5/2) 6.03.01 (25) 6.05 (2.1/3) 9.05.02 (8)
@end itemize
-@geindex AI-0210 (Ada 2012 feature)
+@geindex AI12-0399 (Ada 2022 feature)
@itemize *
@item
-`AI-0210 Correct Timing_Events metric (0000-00-00)'
+`AI12-0399 Aspect specification for Preelaborable_Initialization (0000-00-00)'
-This is a documentation only issue regarding wording of metric requirements,
-that does not affect the implementation of the compiler.
+Semantics-preserving presentation change. Replace @code{Preelaborable_Initialization} pragmas with equivalent aspect specs in the listed predefined packages. GNAT follows the guidance of this AI partially.
-RM References: D.15 (24/2)
+RM references: 9.05 (53/5) 3.09 (6/5) 7.06 (5/2) 7.06 (7/2) 11.04.01 (2/5)
+11.04.01 (3/2) 13.11 (6/2) 13.11.04 (4/5) 13.11.04 (5/5) 13.13.01
+(3/2) A.04.02 (4/2) A.04.02 (20/2) A.04.05 (4/2) A.04.07 (4/2)
+A.04.07 (20/2) A.04.08 (4/2) A.04.08 (20/2) A.12.01 (5/4) A.18.02
+(8/5) A.18.02 (9/2) A.18.02 (79.2/5) A.18.02 (79.3/5) A.18.03
+(6/5) A.18.03 (7/2) A.18.03 (50.2/5) A.18.03 (50.3/5) A.18.05
+(3/5) A.18.05 (4/2) A.18.05 (37.3/5) A.18.05 (37.4/5) A.18.06
+(4/5) A.18.06 (5/2) A.18.06 (51.4/5) A.18.06 (51.5/5) A.18.08
+(3/5) A.18.08 (4/2) A.18.08 (58.2/5) A.18.08 (58.3/5) A.18.09
+(4/5) A.18.09 (5/2) A.18.09 (74.2/5) A.18.09 (74.3/5) A.18.10
+(8/5) A.18.10 (9/3) A.18.10 (70.2/5) A.18.10 (70.3/5) A.18.18
+(6/5) B.03.01 (5/2) C.07.01 (2/5) G.01.01 (4/2)
@end itemize
-@geindex AI-0211 (Ada 2012 feature)
+@geindex AI12-0400 (Ada 2022 feature)
@itemize *
@item
-`AI-0211 No_Relative_Delays forbids Set_Handler use (2010-07-09)'
+`AI12-0400 Ambiguities associated with Vector Append and container aggregates (0000-00-00)'
-The restriction @code{No_Relative_Delays} forbids any calls to the subprogram
-@code{Ada.Real_Time.Timing_Events.Set_Handler}.
+Change the names of subprograms in the predefined Vector containers from @code{Append} to @code{Append_Vector} and from @code{Prepend} to @code{Prepend_Vector} in order to resolve some ambiguity problems. GNAT adds the subprograms with new names but also keeps the old ones for backward compatibility.
-RM References: D.07 (5) D.07 (10/2) D.07 (10.4/2) D.07 (10.7/2)
+RM references: A.18.02 (8/5) A.18.02 (36/5) A.18.02 (37/5) A.18.02 (38/5)
+A.18.02 (44/5) A.18.02 (46/5) A.18.02 (47/5) A.18.02 (58/5)
+A.18.02 (79.2/5) A.18.02 (150/5) A.18.02 (151/5) A.18.02 (152/5)
+A.18.02 (153/5) A.18.02 (154/5) A.18.02 (155/5) A.18.02 (156/5)
+A.18.02 (168/5) A.18.02 (169/5) A.18.02 (172/5) A.18.02 (173/5)
+A.18.02 (174/5) A.18.02 (175.1/5) A.18.03 (23/5) A.18.03 (23.1/5)
+A.18.03 (58.2/5) A.18.03 (96/5) A.18.03 (97.1/5)
@end itemize
-@geindex AI-0214 (Ada 2012 feature)
+@geindex AI12-0401 (Ada 2022 feature)
@itemize *
@item
-`AI-0214 Defaulted discriminants for limited tagged (2010-10-01)'
+`AI12-0401 Renaming of qualified expression of variable (2020-10-31)'
-Ada 2012 relaxes the restriction that forbids discriminants of tagged types
-to have default expressions by allowing them when the type is limited. It
-is often useful to define a default value for a discriminant even though
-it can’t be changed by assignment.
+Ada 2022 AI12-0401 restricts renaming of a qualified expression to cases where
+the operand is a constant, or the target subtype statically matches the nominal subtype of the operand, or is unconstrained with no predicates, to prevent setting variables to values outside their range or constraints.
-RM References: 3.07 (9.1/2) 3.07.02 (3)
+RM references: 3.03 (23.2/3) 8.05.01 (4.7/5) 8.05.01 (5/3)
@end itemize
-@geindex AI-0216 (Ada 2012 feature)
+@geindex AI12-0409 (Ada 2022 feature)
@itemize *
@item
-`AI-0216 No_Task_Hierarchy forbids local tasks (0000-00-00)'
+`AI12-0409 Preelaborable_Initialization and bounded containers (2021-06-23)'
+
+As defined by this AI, the @code{Preelaborable_Initializatio} aspect now has a
+corresponding attribute of the same name. Types declared within a generic package specification are permitted to specify the expression of a @code{Prelaborable_Initialization} aspect by including one or more references to the attribute applied to a formal private or formal derived type conjoined by @code{and} operators. This permits the full type of a private type with such an aspect expression to have components of the named formal types, and such a type will have preelaborable initialization in an instance when the
+actual types for all referenced formal types have preelaborable initialization.
+
+RM references: 10.02.01 (4.1/2) 10.02.01 (4.2/2) 10.02.01 (11.1/2)
+10.02.01 (11.2/2) 10.02.01 (11.6/2) 10.02.01 (11.7/2) 10.02.01
+(11.8/2) 13.01 (11/3) A.18.19 (5/5) A.18.20 (5/5) A.18.21 (5/5)
+A.18.22 (5/5) A.18.23 (5/5) A.18.24 (5/5) A.18.25 (5/5) A.18.32
+(6/5) J.15.14 (0)
+@end itemize
+
+@geindex AI12-0411 (Ada 2022 feature)
-It is clearly the intention that @code{No_Task_Hierarchy} is intended to
-forbid tasks declared locally within subprograms, or functions returning task
-objects, and that is the implementation that GNAT has always provided.
-However the language in the RM was not sufficiently clear on this point.
-Thus this is a documentation change in the RM only.
-RM References: D.07 (3/3)
+@itemize *
+
+@item
+`AI12-0411 Add “bool” to Interfaces.C (0000-00-00)'
+
+RM references: B.03 (13) B.03 (43/2) B.03 (65.1/4)
@end itemize
-@geindex AI-0219 (Ada 2012 feature)
+@geindex AI12-0412 (Ada 2022 feature)
@itemize *
@item
-`AI-0219 Pure permissions and limited parameters (2010-05-25)'
+`AI12-0412 Abstract Pre/Post’Class on primitive of abstract type (2021-05-19)'
-This AI refines the rules for the cases with limited parameters which do not
-allow the implementations to omit ‘redundant’. GNAT now properly conforms
-to the requirements of this binding interpretation.
+In Ada 2022, by AI12-0412, it’s legal to specify Pre’Class and Post’Class
+aspects on nonabstract primitive subprograms of an abstract type, but if the
+expression of such an aspect is nonstatic, then it’s illegal to make a nondispatching call to such a primitive, to apply @code{'Access} to it, or to pass such a primitive as an actual subprogram for a concrete formal subprogram in a generic instantiation.
-RM References: 10.02.01 (18/2)
+RM references: 6.01.01 (18.2/4)
@end itemize
-@geindex AI-0220 (Ada 2012 feature)
+@geindex AI12-0413 (Ada 2022 feature)
@itemize *
@item
-`AI-0220 Needed components for aggregates (0000-00-00)'
+`AI12-0413 Reemergence of “=” when defined to be abstract (0000-00-00)'
-This AI addresses a wording problem in the RM that appears to permit some
-complex cases of aggregates with nonstatic discriminants. GNAT has always
-implemented the intended semantics.
+The AI clarifies rules about operator reemergence in instances, and nondispatching calls to abstract subprograms.
-RM References: 4.03.01 (17)
+RM references: 3.09.03 (7) 4.05.02 (14.1/3) 4.05.02 (24.1/3) 12.05 (8/3)
@end itemize
-@node GNAT language extensions,Security Hardening Features,Implementation of Ada 2012 Features,Top
-@anchor{gnat_rm/gnat_language_extensions doc}@anchor{442}@anchor{gnat_rm/gnat_language_extensions gnat-language-extensions}@anchor{443}@anchor{gnat_rm/gnat_language_extensions id1}@anchor{444}
+@geindex AI12-0423 (Ada 2022 feature)
+
+
+@itemize *
+
+@item
+`AI12-0423 Aspect inheritance fixups (0000-00-00)'
+
+Clarify that the No_Return aspect behaves as one would expect for an inherited subprogram and that inheritance works as one would expect for a multi-part aspect whose value is specified via an aggregate (e.g., the Aggregate aspect).
+
+RM references: 6.05.01 (3.3/3) 13.01 (15.7/5) 13.01 (15.8/5)
+@end itemize
+
+@geindex AI12-0432 (Ada 2022 feature)
+
+
+@itemize *
+
+@item
+`AI12-0432 View conversions of assignments and predicate checks (2021-05-05)'
+
+When a predicate applies to a tagged type, a view conversion to that type
+normally requires a predicate check. However, as specified by AI12-0432, when the view conversion appears as the target of an assignment, a predicate check is not applied to the object in the conversion.
+
+RM references: 3.02.04 (31/5) 4.06 (51.1/5)
+@end itemize
+
+@node GNAT language extensions,Security Hardening Features,Implementation of Ada 2022 Features,Top
+@anchor{gnat_rm/gnat_language_extensions doc}@anchor{445}@anchor{gnat_rm/gnat_language_extensions gnat-language-extensions}@anchor{446}@anchor{gnat_rm/gnat_language_extensions id1}@anchor{447}
@chapter GNAT language extensions
@@ -29126,7 +30422,7 @@ These features might be removed or heavily modified at any time.
@end menu
@node How to activate the extended GNAT Ada superset,Curated Extensions,,GNAT language extensions
-@anchor{gnat_rm/gnat_language_extensions how-to-activate-the-extended-gnat-ada-superset}@anchor{445}
+@anchor{gnat_rm/gnat_language_extensions how-to-activate-the-extended-gnat-ada-superset}@anchor{448}
@section How to activate the extended GNAT Ada superset
@@ -29167,7 +30463,7 @@ for use in playground experiments.
@end cartouche
@node Curated Extensions,Experimental Language Extensions,How to activate the extended GNAT Ada superset,GNAT language extensions
-@anchor{gnat_rm/gnat_language_extensions curated-extensions}@anchor{446}@anchor{gnat_rm/gnat_language_extensions curated-language-extensions}@anchor{6a}
+@anchor{gnat_rm/gnat_language_extensions curated-extensions}@anchor{449}@anchor{gnat_rm/gnat_language_extensions curated-language-extensions}@anchor{6a}
@section Curated Extensions
@@ -29188,7 +30484,7 @@ Features activated via @code{-gnatX} or
@end menu
@node Local Declarations Without Block,Deep delta Aggregates,,Curated Extensions
-@anchor{gnat_rm/gnat_language_extensions local-declarations-without-block}@anchor{447}
+@anchor{gnat_rm/gnat_language_extensions local-declarations-without-block}@anchor{44a}
@subsection Local Declarations Without Block
@@ -29281,7 +30577,7 @@ And as such the second `@w{`}A`@w{`} declaration is hiding the first one.
@end cartouche
@node Deep delta Aggregates,Fixed lower bounds for array types and subtypes,Local Declarations Without Block,Curated Extensions
-@anchor{gnat_rm/gnat_language_extensions deep-delta-aggregates}@anchor{448}
+@anchor{gnat_rm/gnat_language_extensions deep-delta-aggregates}@anchor{44b}
@subsection Deep delta Aggregates
@@ -29303,7 +30599,7 @@ The syntax of delta aggregates in the extended version is the following:
@end menu
@node Syntax,Legality Rules,,Deep delta Aggregates
-@anchor{gnat_rm/gnat_language_extensions syntax}@anchor{449}
+@anchor{gnat_rm/gnat_language_extensions syntax}@anchor{44c}
@subsubsection Syntax
@@ -29349,7 +30645,7 @@ array_subcomponent_choice ::=
@end example
@node Legality Rules,Dynamic Semantics,Syntax,Deep delta Aggregates
-@anchor{gnat_rm/gnat_language_extensions legality-rules}@anchor{44a}
+@anchor{gnat_rm/gnat_language_extensions legality-rules}@anchor{44d}
@subsubsection Legality Rules
@@ -29386,7 +30682,7 @@ the object denoted by the base_expression, prior to any update.]
@end enumerate
@node Dynamic Semantics,Examples,Legality Rules,Deep delta Aggregates
-@anchor{gnat_rm/gnat_language_extensions dynamic-semantics}@anchor{44b}
+@anchor{gnat_rm/gnat_language_extensions dynamic-semantics}@anchor{44e}
@subsubsection Dynamic Semantics
@@ -29443,7 +30739,7 @@ and assigned to the corresponding subcomponent of the anonymous object.
@end itemize
@node Examples,,Dynamic Semantics,Deep delta Aggregates
-@anchor{gnat_rm/gnat_language_extensions examples}@anchor{44c}
+@anchor{gnat_rm/gnat_language_extensions examples}@anchor{44f}
@subsubsection Examples
@@ -29471,7 +30767,7 @@ end;
@end example
@node Fixed lower bounds for array types and subtypes,Prefixed-view notation for calls to primitive subprograms of untagged types,Deep delta Aggregates,Curated Extensions
-@anchor{gnat_rm/gnat_language_extensions fixed-lower-bounds-for-array-types-and-subtypes}@anchor{44d}
+@anchor{gnat_rm/gnat_language_extensions fixed-lower-bounds-for-array-types-and-subtypes}@anchor{450}
@subsection Fixed lower bounds for array types and subtypes
@@ -29522,7 +30818,7 @@ lower bound of unconstrained array formals when the formal’s subtype has index
ranges with static fixed lower bounds.
@node Prefixed-view notation for calls to primitive subprograms of untagged types,Expression defaults for generic formal functions,Fixed lower bounds for array types and subtypes,Curated Extensions
-@anchor{gnat_rm/gnat_language_extensions prefixed-view-notation-for-calls-to-primitive-subprograms-of-untagged-types}@anchor{44e}
+@anchor{gnat_rm/gnat_language_extensions prefixed-view-notation-for-calls-to-primitive-subprograms-of-untagged-types}@anchor{451}
@subsection Prefixed-view notation for calls to primitive subprograms of untagged types
@@ -29572,7 +30868,7 @@ pragma Assert (V.Nth_Element(1) = 42);
@end example
@node Expression defaults for generic formal functions,String interpolation,Prefixed-view notation for calls to primitive subprograms of untagged types,Curated Extensions
-@anchor{gnat_rm/gnat_language_extensions expression-defaults-for-generic-formal-functions}@anchor{44f}
+@anchor{gnat_rm/gnat_language_extensions expression-defaults-for-generic-formal-functions}@anchor{452}
@subsection Expression defaults for generic formal functions
@@ -29603,7 +30899,7 @@ If the default is used (i.e. there is no actual corresponding to Copy),
then calls to Copy in the instance will simply return Item.
@node String interpolation,Constrained attribute for generic objects,Expression defaults for generic formal functions,Curated Extensions
-@anchor{gnat_rm/gnat_language_extensions string-interpolation}@anchor{450}
+@anchor{gnat_rm/gnat_language_extensions string-interpolation}@anchor{453}
@subsection String interpolation
@@ -29770,7 +31066,7 @@ a double quote is " and an open brace is @{
@end example
@node Constrained attribute for generic objects,Static aspect on intrinsic functions,String interpolation,Curated Extensions
-@anchor{gnat_rm/gnat_language_extensions constrained-attribute-for-generic-objects}@anchor{451}
+@anchor{gnat_rm/gnat_language_extensions constrained-attribute-for-generic-objects}@anchor{454}
@subsection Constrained attribute for generic objects
@@ -29778,7 +31074,7 @@ The @code{Constrained} attribute is permitted for objects of generic types. The
result indicates whether the corresponding actual is constrained.
@node Static aspect on intrinsic functions,First Controlling Parameter,Constrained attribute for generic objects,Curated Extensions
-@anchor{gnat_rm/gnat_language_extensions static-aspect-on-intrinsic-functions}@anchor{452}
+@anchor{gnat_rm/gnat_language_extensions static-aspect-on-intrinsic-functions}@anchor{455}
@subsection @code{Static} aspect on intrinsic functions
@@ -29787,7 +31083,7 @@ and the compiler will evaluate some of these intrinsics statically, in
particular the @code{Shift_Left} and @code{Shift_Right} intrinsics.
@node First Controlling Parameter,,Static aspect on intrinsic functions,Curated Extensions
-@anchor{gnat_rm/gnat_language_extensions first-controlling-parameter}@anchor{453}
+@anchor{gnat_rm/gnat_language_extensions first-controlling-parameter}@anchor{456}
@subsection First Controlling Parameter
@@ -29887,7 +31183,7 @@ The result of a function is never a controlling result.
@end itemize
@node Experimental Language Extensions,,Curated Extensions,GNAT language extensions
-@anchor{gnat_rm/gnat_language_extensions experimental-language-extensions}@anchor{6b}@anchor{gnat_rm/gnat_language_extensions id2}@anchor{454}
+@anchor{gnat_rm/gnat_language_extensions experimental-language-extensions}@anchor{6b}@anchor{gnat_rm/gnat_language_extensions id2}@anchor{457}
@section Experimental Language Extensions
@@ -29896,6 +31192,7 @@ Features activated via @code{-gnatX0} or
@menu
* Conditional when constructs::
+* Implicit With::
* Storage Model::
* Attribute Super::
* Simpler Accessibility Model::
@@ -29906,11 +31203,12 @@ Features activated via @code{-gnatX0} or
* Inference of Dependent Types in Generic Instantiations::
* External_Initialization Aspect::
* Finally construct::
+* Continue statement::
@end menu
-@node Conditional when constructs,Storage Model,,Experimental Language Extensions
-@anchor{gnat_rm/gnat_language_extensions conditional-when-constructs}@anchor{455}
+@node Conditional when constructs,Implicit With,,Experimental Language Extensions
+@anchor{gnat_rm/gnat_language_extensions conditional-when-constructs}@anchor{458}
@subsection Conditional when constructs
@@ -29978,8 +31276,25 @@ begin
end;
@end example
-@node Storage Model,Attribute Super,Conditional when constructs,Experimental Language Extensions
-@anchor{gnat_rm/gnat_language_extensions storage-model}@anchor{456}
+@node Implicit With,Storage Model,Conditional when constructs,Experimental Language Extensions
+@anchor{gnat_rm/gnat_language_extensions implicit-with}@anchor{459}
+@subsection Implicit With
+
+
+This feature allows a standalone @code{use} clause in the context clause of a
+compilation unit to imply an implicit @code{with} of the same library unit where
+an equivalent @code{with} clause would be allowed.
+
+@example
+use Ada.Text_IO;
+procedure Main is
+begin
+ Put_Line ("Hello");
+end;
+@end example
+
+@node Storage Model,Attribute Super,Implicit With,Experimental Language Extensions
+@anchor{gnat_rm/gnat_language_extensions storage-model}@anchor{45a}
@subsection Storage Model
@@ -29996,7 +31311,7 @@ memory models, in particular to support interactions with GPU.
@end menu
@node Aspect Storage_Model_Type,Aspect Designated_Storage_Model,,Storage Model
-@anchor{gnat_rm/gnat_language_extensions aspect-storage-model-type}@anchor{457}
+@anchor{gnat_rm/gnat_language_extensions aspect-storage-model-type}@anchor{45b}
@subsubsection Aspect Storage_Model_Type
@@ -30130,7 +31445,7 @@ end CUDA_Memory;
@end example
@node Aspect Designated_Storage_Model,Legacy Storage Pools,Aspect Storage_Model_Type,Storage Model
-@anchor{gnat_rm/gnat_language_extensions aspect-designated-storage-model}@anchor{458}
+@anchor{gnat_rm/gnat_language_extensions aspect-designated-storage-model}@anchor{45c}
@subsubsection Aspect Designated_Storage_Model
@@ -30208,7 +31523,7 @@ begin
@end example
@node Legacy Storage Pools,,Aspect Designated_Storage_Model,Storage Model
-@anchor{gnat_rm/gnat_language_extensions legacy-storage-pools}@anchor{459}
+@anchor{gnat_rm/gnat_language_extensions legacy-storage-pools}@anchor{45d}
@subsubsection Legacy Storage Pools
@@ -30259,7 +31574,7 @@ type Acc is access Integer_Array with Storage_Pool => My_Pool;
can still be accepted as a shortcut for the new syntax.
@node Attribute Super,Simpler Accessibility Model,Storage Model,Experimental Language Extensions
-@anchor{gnat_rm/gnat_language_extensions attribute-super}@anchor{45a}
+@anchor{gnat_rm/gnat_language_extensions attribute-super}@anchor{45e}
@subsection Attribute Super
@@ -30294,7 +31609,7 @@ end;
@end example
@node Simpler Accessibility Model,Case pattern matching,Attribute Super,Experimental Language Extensions
-@anchor{gnat_rm/gnat_language_extensions simpler-accessibility-model}@anchor{45b}
+@anchor{gnat_rm/gnat_language_extensions simpler-accessibility-model}@anchor{45f}
@subsection Simpler Accessibility Model
@@ -30325,7 +31640,7 @@ All of the refined rules are compatible with the [use of anonymous access types
@end menu
@node Stand-alone objects,Subprogram parameters,,Simpler Accessibility Model
-@anchor{gnat_rm/gnat_language_extensions stand-alone-objects}@anchor{45c}
+@anchor{gnat_rm/gnat_language_extensions stand-alone-objects}@anchor{460}
@subsubsection Stand-alone objects
@@ -30373,7 +31688,7 @@ of the RM 4.6 rule “The accessibility level of the operand type shall not be
statically deeper than that of the target type …”.
@node Subprogram parameters,Function results,Stand-alone objects,Simpler Accessibility Model
-@anchor{gnat_rm/gnat_language_extensions subprogram-parameters}@anchor{45d}
+@anchor{gnat_rm/gnat_language_extensions subprogram-parameters}@anchor{461}
@subsubsection Subprogram parameters
@@ -30466,7 +31781,7 @@ end;
@end example
@node Function results,,Subprogram parameters,Simpler Accessibility Model
-@anchor{gnat_rm/gnat_language_extensions function-results}@anchor{45e}
+@anchor{gnat_rm/gnat_language_extensions function-results}@anchor{462}
@subsubsection Function results
@@ -30594,7 +31909,7 @@ end;
@end example
@node Case pattern matching,Mutably Tagged Types with Size’Class Aspect,Simpler Accessibility Model,Experimental Language Extensions
-@anchor{gnat_rm/gnat_language_extensions case-pattern-matching}@anchor{45f}
+@anchor{gnat_rm/gnat_language_extensions case-pattern-matching}@anchor{463}
@subsection Case pattern matching
@@ -30724,81 +32039,111 @@ message generated in such cases is usually “Capacity exceeded in compiling
case statement with composite selector type”.
@node Mutably Tagged Types with Size’Class Aspect,Generalized Finalization,Case pattern matching,Experimental Language Extensions
-@anchor{gnat_rm/gnat_language_extensions mutably-tagged-types-with-size-class-aspect}@anchor{460}
+@anchor{gnat_rm/gnat_language_extensions mutably-tagged-types-with-size-class-aspect}@anchor{464}
@subsection Mutably Tagged Types with Size’Class Aspect
-The @code{Size'Class} aspect can be applied to a tagged type to specify a size
-constraint for the type and its descendants. When this aspect is specified
-on a tagged type, the class-wide type of that type is considered to be a
-“mutably tagged” type - meaning that objects of the class-wide type can have
-their tag changed by assignment from objects with a different tag.
+For a specific tagged nonformal type T that satisfies some conditions
+described later in this section, the universal-integer-valued type-related
+representation aspect @code{Size'Class} may be specified; any such specified
+aspect value shall be static.
-Example:
+Specifying this aspect imposes an upper bound on the sizes of all specific
+descendants of T (including T itself). T’Class (but not T) is then said to be
+a “mutably tagged” type - meaning that T’Class is a definite subtype and that
+the tag of a variable of type T’Class may be modified by assignment in some
+cases described later in this section. An inherited @code{Size'Class} aspect
+value may be overridden, but not with a larger value.
-@example
-type Base is tagged null record
- with Size'Class => 16 * 8; -- Size in bits (128 bits, or 16 bytes)
+If the @code{Size'Class} aspect is specified for a type T, then every specific
+descendant of T (including T itself)
-type Derived_Type is new Base with record
- Data_Field : Integer;
-end record; -- ERROR if Derived_Type exceeds 16 bytes
-@end example
-
-Class-wide types with a specified @code{Size'Class} can be used as the type of
-array components, record components, and stand-alone objects.
-@example
-Inst : Base'Class;
-type Array_of_Base is array (Positive range <>) of Base'Class;
-@end example
-
-If the @code{Size'Class} aspect is specified for a type @code{T}, then every
-specific descendant of @code{T} [redundant: (including @code{T})]
-
-
-@itemize -
+@itemize *
@item
shall have a Size that does not exceed the specified value; and
@item
-shall be undiscriminated; and
+shall have a (possibly inherited) @code{Size'Class} aspect that does not exceed
+the specifed value; and
@item
-shall have no composite subcomponent whose subtype is subject to a
-dynamic constraint; and
+shall be undiscriminated; and
@item
-shall have no interface progenitors; and
+shall have no composite subcomponent whose subtype is subject to a nonstatic
+constraint; and
@item
shall not have a tagged partial view other than a private extension; and
@item
-shall not have a statically deeper accessibility level than that of @code{T}.
+shall not be a descendant of an interface type; and
+
+@item
+shall not have a statically deeper accessibility level than that of T.
@end itemize
-In addition to the places where Legality Rules normally apply (see 12.3),
-these legality rules apply also in the private part and in the body of an
-instance of a generic unit.
+If the @code{Size'Class} aspect is not specified for a type T (either explicitly
+or by inheritance), then it shall not be specified for any descendant of T.
+
+Example:
+
+@example
+type Root_Type is tagged null record with Size'Class => 16 * 8;
+
+type Derived_Type is new Root_Type with record
+ Stuff : Some_Type;
+end record; -- ERROR if Derived_Type exceeds 16 bytes
+@end example
+
+Because any subtype of a mutably tagged type is definite, it can be used as a
+component subtype for enclosing array or record types, as the subtype of a
+default-initialized stand-alone object, or as the subtype of an uninitialized
+allocator, as in this example:
+
+@example
+Obj : Root_Type'Class;
+type Array_of_Roots is array (Positive range <>) of Root_Type'Class;
+@end example
-For any subtype @code{S} that is a subtype of a descendant of @code{T}, @code{S'Class'Size} is
-defined to yield the specified value [redundant:, although @code{S'Class'Size} is
-not a static expression].
+Default initialization of an object of such a definite subtype proceeds as
+for the corresponding specific type, except that Program_Error is raised if
+the specific type is abstract. In particular, the initial tag of the object
+is that of the corresponding specific type.
-A class-wide descendant of a type with a specified @code{Size'Class} aspect is
-defined to be a “mutably tagged” type. Any subtype of a mutably tagged type is,
-by definition, a definite subtype (RM 3.3 notwithstanding). Default
-initialization of an object of such a definite subtype proceeds as for the
-corresponding specific type, except that @code{Program_Error} is raised if the
-specific type is abstract. [In particular, the initial tag of the object is
-that of the corresponding specific type.]
+There is a general design principle that if a type has a tagged partial view,
+then the type’s @code{Size'Class} aspect (or lack thereof) should be determinable
+by looking only at the partial view. That provides the motivation for the
+rules of the next two paragraphs.
-An object of a tagged type is defined to be “tag-constrained” if it is
+If a type has a tagged partial view, then a @code{Size'Class} aspect specification
+may be provided only at the point of the partial view declaration (in other
+words, no such aspect specification may be provided when the full view of
+the type is declared). All of the above rules (in particular, the rule that
+an overriding @code{Size'Class} aspect value shall not be larger than the
+overridden inherited value) are also enforced when the full view (which may
+have a different ancestor type than that of the partial view) is declared.
+If a partial view for a type inherits a @code{Size'Class} aspect value and does
+not override that value with an explicit aspect specification, then the
+(static) aspect values inherited by the partial view and by the full view
+shall be equal.
+An actual parameter of an instantiation whose corresponding formal parameter
+is a formal tagged private type shall not be either mutably tagged or the
+corresponding specific type of a mutably tagged type.
+
+For the legality rules in this section, the RM 12.3(11) rule about legality
+checking in the visible part and formal part of an instance is extended (in
+the same way that it is extended in many other places in the RM) to include
+the private part of an instance.
+
+An object (or a view thereof) of a tagged type is defined to be
+“tag-constrained” if it is
-@itemize -
+
+@itemize *
@item
an object whose type is not mutably tagged; or
@@ -30810,52 +32155,62 @@ a constant object; or
a view conversion of a tag-constrained object; or
@item
-a formal @code{in out} or @code{out} parameter whose corresponding
-actual parameter is tag-constrained.
+a view conversion to a type that is not a descendant of the operand’s
+type; or
+
+@item
+a formal in out or out parameter whose corresponding actual parameter is
+tag-constrained; or
+
+@item
+a dereference of an access value.
@end itemize
-In the case of an assignment to a tagged variable that
-is not tag-constrained, no check is performed that the tag of the value of
-the expression is the same as that of the target (RM 5.2 notwithstanding).
+In the case of an assignment to a tagged variable that is not
+tag-constrained, no check is performed that the tag of the value
+of the expression is the same as that of the target (RM 5.2 notwithstanding).
Instead, the tag of the target object becomes that of the source object of
-the assignment.
+the assignment. Note that the tag of an object of a mutably tagged type MT
+will always be the tag of some specific type that is a descendant of MT.
An assignment to a composite object similarly copies the tags of any
-subcomponents of the source object that have a mutably-tagged type.
-
-The @code{Constrained} attribute is defined for any name denoting an object of a
-mutably tagged type (RM 3.7.2 notwithstanding). In this case, the Constrained
-attribute yields the value True if the object is tag-constrained and False
-otherwise.
-
-Renaming is not allowed (see 8.5.1) for a type conversion having an operand of
-a mutably tagged type @code{MT} and a target type @code{TT} such that @code{TT'Class}
-does not cover @code{MT}, nor for any part of such an object, nor for any slice
-of such an object. This rule also applies in any context where a name is
-required to be one for which “renaming is allowed” (for example, see RM 12.4).
-
-A name denoting a view of a variable of a mutably tagged type shall not
-occur as an operative constituent of the prefix of a name denoting a
-prefixed view of a callable entity, except as the callee name in a call to
-the callable entity.
-
-For a type conversion between two general access types, either both or neither
-of the designated types shall be mutably tagged. For an @code{Access} (or
-@code{Unchecked_Access}) attribute reference, the designated type of the type of the
-attribute reference and the type of the prefix of the attribute shall either
-both or neither be mutably tagged.
+subcomponents of the source object that have a mutably tagged type.
+
+The Constrained attribute is defined for any name denoting an object of a
+mutably tagged type (RM 3.7.2 notwithstanding). In this case, the
+Constrained attribute yields the value True if the object is
+tag-constrained and False otherwise.
+
+Renaming is not allowed (see RM 8.5.1) for a type conversion having an operand
+of a mutably tagged type MT and a target type TT such that TT (or its
+corresponding specific type if TT is class-wide) is not an ancestor of MT
+(this is sometimes called a “downward” conversion), nor for any part of
+such an object, nor for any slice of any part of such an object. This
+rule also applies in any context where a name is required to be one for
+which “renaming is allowed” (for example, see RM 12.4).
+[This is analogous to the way that renaming is not allowed for a
+discriminant-dependent component of an unconstrained variable.]
+
+A name denoting a view of a variable of a mutably tagged type shall not occur
+as an operative constituent of the prefix of a name denoting a prefixed
+view of a callable entity, except as the callee name in a call to the
+callable entity. This disallows, for example, renaming such a prefixed view,
+passing the prefixed view name as a generic actual parameter, or using the
+prefixed view name as the prefix of an attribute.
The execution of a construct is erroneous if the construct has a constituent
that is a name denoting a subcomponent of a tagged object and the object’s
-tag is changed by this execution between evaluating the name and the last use
-(within this execution) of the subcomponent denoted by the name.
+tag is changed by this execution between evaluating the name and the last
+use (within this execution) of the subcomponent denoted by the name.
+This is analogous to the RM 3.7.2(4) rule about discriminant-dependent
+subcomponents.
-If the type of a formal parameter is a specific tagged type then the execution
+If the type of a formal parameter is a specific tagged type, then the execution
of the call is erroneous if the tag of the actual is changed while the formal
-parameter exists (that is, before leaving the corresponding callable
-construct).
+parameter exists (that is, before leaving the corresponding callable construct).
+This is analogous to the RM 6.4.1(18) rule about discriminated parameters.
@node Generalized Finalization,No_Raise aspect,Mutably Tagged Types with Size’Class Aspect,Experimental Language Extensions
-@anchor{gnat_rm/gnat_language_extensions generalized-finalization}@anchor{461}
+@anchor{gnat_rm/gnat_language_extensions generalized-finalization}@anchor{465}
@subsection Generalized Finalization
@@ -30867,27 +32222,24 @@ that the record type must be a root type, in other words not a derived type.
The aspect additionally makes it possible to specify relaxed semantics for
the finalization operations by means of the @code{Relaxed_Finalization} setting.
-
-Example:
+Here is the archetypal example:
@example
-type Ctrl is record
- Id : Natural := 0;
+type T is record
+ ...
end record
with Finalizable => (Initialize => Initialize,
Adjust => Adjust,
Finalize => Finalize,
Relaxed_Finalization => True);
-procedure Adjust (Obj : in out Ctrl);
-procedure Finalize (Obj : in out Ctrl);
-procedure Initialize (Obj : in out Ctrl);
+procedure Adjust (Obj : in out T);
+procedure Finalize (Obj : in out T);
+procedure Initialize (Obj : in out T);
@end example
-The three procedures have the same profile, taking a single @code{in out T}
-parameter.
-
-We follow the same dynamic semantics as controlled objects:
+The three procedures have the same profile, with a single @code{in out} parameter,
+and also have the same dynamic semantics as for controlled types:
@quotation
@@ -30896,98 +32248,49 @@ We follow the same dynamic semantics as controlled objects:
@item
@code{Initialize} is called when an object of type @code{T} is declared without
-default expression.
+initialization expression.
@item
@code{Adjust} is called after an object of type @code{T} is assigned a new value.
@item
@code{Finalize} is called when an object of type @code{T} goes out of scope (for
-stack-allocated objects) or is explicitly deallocated (for heap-allocated
-objects). It is also called when on the value being replaced in an
-assignment.
+stack-allocated objects) or is deallocated (for heap-allocated objects).
+It is also called when the value is replaced by an assignment.
@end itemize
@end quotation
-However the following differences are enforced by default when compared to the
-current Ada controlled-objects finalization model:
+However, when @code{Relaxed_Finalization} is either @code{True} or not explicitly
+specified, the following differences are implemented relative to the semantics
+of controlled types:
@itemize *
@item
-No automatic finalization of heap allocated objects: @code{Finalize} is only
-called when an object is implicitly deallocated. As a consequence, no-runtime
-support is needed for the implicit case, and no header will be maintained for
-this in heap-allocated controlled objects.
+The compiler has permission to perform no automatic finalization of
+heap-allocated objects: @code{Finalize} is only called when such an object
+is explicitly deallocated, or when the designated object is assigned a new
+value. As a consequence, no runtime support is needed for performing
+implicit deallocation. In particular, no per-object header data is needed
+for heap-allocated objects.
-Heap-allocated objects allocated through a nested access type definition will
-hence `not' be deallocated either. The result is simply that memory will be
-leaked in those cases.
+Heap-allocated objects allocated through a nested access type will therefore
+`not' be deallocated either. The result is simply that memory will be leaked
+in this case.
@item
-The @code{Finalize} procedure should have have the @ref{462,,No_Raise aspect} specified.
-If that’s not the case, a compilation error will be raised.
+The @code{Adjust} and @code{Finalize} procedures are automatically considered as
+having the @ref{466,,No_Raise aspect} specified for them. In particular, the
+compiler has permission to enforce none of the guarantees specified by the
+RM 7.6.1 (14/1) and subsequent subclauses.
@end itemize
-Additionally, two other configuration aspects are added,
-@code{Legacy_Heap_Finalization} and @code{Exceptions_In_Finalize}:
-
-
-@itemize *
-
-@item
-@code{Legacy_Heap_Finalization}: Uses the legacy automatic finalization of
-heap-allocated objects
-
-@item
-@code{Exceptions_In_Finalize}: Allow users to have a finalizer that raises exceptions
-`NB!' note that using this aspect introduces execution time penalities.
-@end itemize
-
-@node No_Raise aspect,Inference of Dependent Types in Generic Instantiations,Generalized Finalization,Experimental Language Extensions
-@anchor{gnat_rm/gnat_language_extensions id3}@anchor{463}@anchor{gnat_rm/gnat_language_extensions no-raise-aspect}@anchor{462}
-@subsection No_Raise aspect
-
-
-The @code{No_Raise} aspect can be applied to a subprogram to declare that this subprogram is not
-expected to raise any exceptions. Should an exception still occur during the execution of
-this subprogram, @code{Program_Error} is raised.
-
-@menu
-* New specification for Ada.Finalization.Controlled: New specification for Ada Finalization Controlled.
-* Finalized tagged types::
-* Composite types::
-* Interoperability with controlled types::
-
-@end menu
-
-@node New specification for Ada Finalization Controlled,Finalized tagged types,,No_Raise aspect
-@anchor{gnat_rm/gnat_language_extensions new-specification-for-ada-finalization-controlled}@anchor{464}
-@subsubsection New specification for @code{Ada.Finalization.Controlled}
-
-
-@code{Ada.Finalization.Controlled} is now specified as:
-
-@example
-type Controlled is abstract tagged null record
- with Initialize => Initialize,
- Adjust => Adjust,
- Finalize => Finalize,
- Legacy_Heap_Finalization, Exceptions_In_Finalize;
-
- procedure Initialize (Self : in out Controlled) is abstract;
- procedure Adjust (Self : in out Controlled) is abstract;
- procedure Finalize (Self : in out Controlled) is abstract;
-@end example
-
-### Examples
-
-A simple example of a ref-counted type:
+Simple example of ref-counted type:
@example
type T is record
- Value : Integer;
+ Value : Integer;
Ref_Count : Natural := 0;
end record;
@@ -30999,8 +32302,8 @@ type T_Access is access all T;
type T_Ref is record
Value : T_Access;
end record
- with Adjust => Adjust,
- Finalize => Finalize;
+ with Finalizable => (Adjust => Adjust,
+ Finalize => Finalize);
procedure Adjust (Ref : in out T_Ref) is
begin
@@ -31013,7 +32316,7 @@ begin
end Finalize;
@end example
-A simple file handle that ensures resources are properly released:
+Simple file handle that ensures resources are properly released:
@example
package P is
@@ -31022,66 +32325,64 @@ package P is
function Open (Path : String) return File;
procedure Close (F : in out File);
+
private
type File is limited record
Handle : ...;
end record
- with Finalize => Close;
+ with Finalizable (Finalize => Close);
+end P;
@end example
-@node Finalized tagged types,Composite types,New specification for Ada Finalization Controlled,No_Raise aspect
-@anchor{gnat_rm/gnat_language_extensions finalized-tagged-types}@anchor{465}
-@subsubsection Finalized tagged types
+@menu
+* Finalizable tagged types::
+* Composite types::
+* Interoperability with controlled types::
+@end menu
-Aspects are inherited by derived types and optionally overriden by those. The
-compiler-generated calls to the user-defined operations are then
-dispatching whenever it makes sense, i.e. the object in question is of
-class-wide type and the class includes at least one finalized tagged type.
+@node Finalizable tagged types,Composite types,,Generalized Finalization
+@anchor{gnat_rm/gnat_language_extensions finalizable-tagged-types}@anchor{467}
+@subsubsection Finalizable tagged types
-However note that for simplicity, it is forbidden to change the value of any of
-those new aspects in derived types.
-@node Composite types,Interoperability with controlled types,Finalized tagged types,No_Raise aspect
-@anchor{gnat_rm/gnat_language_extensions composite-types}@anchor{466}
-@subsubsection Composite types
+The aspect is inherited by derived types and the primitives may be overridden
+by the derivation. The compiler-generated calls to these operations are then
+dispatching whenever it makes sense, i.e. when the object in question is of a
+class-wide type and the class includes at least one finalizable tagged type.
+@node Composite types,Interoperability with controlled types,Finalizable tagged types,Generalized Finalization
+@anchor{gnat_rm/gnat_language_extensions composite-types}@anchor{468}
+@subsubsection Composite types
-When a finalized type is used as a component of a composite type, the latter
-becomes finalized as well. The three primitives are derived automatically
-in order to call the primitives of their components.
-
-If that composite type was already user-finalized, then the compiler
-calls the primitives of the components so as to stay consistent with today’s
-controlled types’s behavior.
-So, @code{Initialize} and @code{Adjust} are called on components before they
-are called on the composite object, but @code{Finalize} is called on the composite
-object first.
+When a finalizable type is used as a component of a composite type, the latter
+becomes finalizable as well. The three primitives are derived automatically
+in order to call the primitives of their components. The dynamic semantics is
+the same as for controlled components of composite types.
-@node Interoperability with controlled types,,Composite types,No_Raise aspect
-@anchor{gnat_rm/gnat_language_extensions interoperability-with-controlled-types}@anchor{467}
+@node Interoperability with controlled types,,Composite types,Generalized Finalization
+@anchor{gnat_rm/gnat_language_extensions interoperability-with-controlled-types}@anchor{469}
@subsubsection Interoperability with controlled types
-As a consequence of the redefinition of the @code{Controlled} type as a base type
-with the new aspects defined, interoperability with controlled type naturally
-follows the definition of the above rules. In particular:
+Finalizable types are fully interoperable with controlled types, in particular
+it is possible for a finalizable type to have a controlled component and vice
+versa, but the stricter dynamic semantics, in other words that of controlled
+types, is applied in this case.
+@node No_Raise aspect,Inference of Dependent Types in Generic Instantiations,Generalized Finalization,Experimental Language Extensions
+@anchor{gnat_rm/gnat_language_extensions id3}@anchor{46a}@anchor{gnat_rm/gnat_language_extensions no-raise-aspect}@anchor{466}
+@subsection No_Raise aspect
-@itemize *
-
-@item
-It is possible to have a new finalized type have a controlled type
-component
-@item
-It is possible to have a controlled type have a finalized type
-component
-@end itemize
+The @code{No_Raise} aspect can be applied to a subprogram to declare that this
+subprogram is not expected to raise an exception. Should an exception still
+be raised during the execution of the subprogram, it is caught at the end of
+this execution and @code{Program_Error} is propagated to the caller.
@node Inference of Dependent Types in Generic Instantiations,External_Initialization Aspect,No_Raise aspect,Experimental Language Extensions
-@anchor{gnat_rm/gnat_language_extensions inference-of-dependent-types-in-generic-instantiations}@anchor{468}
+@anchor{gnat_rm/gnat_language_extensions inference-of-dependent-types-in-generic-instantiations}@anchor{46b}
@subsection Inference of Dependent Types in Generic Instantiations
@@ -31158,7 +32459,7 @@ package Int_Array_Operations is new Array_Operations
@end example
@node External_Initialization Aspect,Finally construct,Inference of Dependent Types in Generic Instantiations,Experimental Language Extensions
-@anchor{gnat_rm/gnat_language_extensions external-initialization-aspect}@anchor{469}
+@anchor{gnat_rm/gnat_language_extensions external-initialization-aspect}@anchor{46c}
@subsection External_Initialization Aspect
@@ -31198,8 +32499,8 @@ The maximum size of loaded files is limited to 2@w{^31} bytes.
@end quotation
@end cartouche
-@node Finally construct,,External_Initialization Aspect,Experimental Language Extensions
-@anchor{gnat_rm/gnat_language_extensions finally-construct}@anchor{46a}
+@node Finally construct,Continue statement,External_Initialization Aspect,Experimental Language Extensions
+@anchor{gnat_rm/gnat_language_extensions finally-construct}@anchor{46d}
@subsection Finally construct
@@ -31216,7 +32517,7 @@ This feature is similar to the one with the same name in other languages such as
@end menu
@node Syntax<2>,Legality Rules<2>,,Finally construct
-@anchor{gnat_rm/gnat_language_extensions id4}@anchor{46b}
+@anchor{gnat_rm/gnat_language_extensions id4}@anchor{46e}
@subsubsection Syntax
@@ -31231,7 +32532,7 @@ handled_sequence_of_statements ::=
@end example
@node Legality Rules<2>,Dynamic Semantics<2>,Syntax<2>,Finally construct
-@anchor{gnat_rm/gnat_language_extensions id5}@anchor{46c}
+@anchor{gnat_rm/gnat_language_extensions id5}@anchor{46f}
@subsubsection Legality Rules
@@ -31241,7 +32542,7 @@ to be transferred outside the finally part are forbidden.
Goto & exit where the target is outside of the finally’s @code{sequence_of_statements} are forbidden
@node Dynamic Semantics<2>,,Legality Rules<2>,Finally construct
-@anchor{gnat_rm/gnat_language_extensions id6}@anchor{46d}
+@anchor{gnat_rm/gnat_language_extensions id6}@anchor{470}
@subsubsection Dynamic Semantics
@@ -31255,8 +32556,26 @@ Abort/ATC (asynchronous transfer of control) cannot interrupt a finally block, n
execution, that is the finally block must be executed in full even if the containing task is
aborted, or if the control is transferred out of the block.
+@node Continue statement,,Finally construct,Experimental Language Extensions
+@anchor{gnat_rm/gnat_language_extensions continue-statement}@anchor{471}
+@subsection Continue statement
+
+
+The @code{continue} keyword makes it possible to stop execution of a loop iteration
+and continue with the next one. A continue statement has the same syntax
+(except “exit” is replaced with “continue”), static semantics, and legality
+rules as an exit statement. The difference is in the dynamic semantics: where an
+exit statement would cause a transfer of control that completes the (implicitly
+or explicitly) specified loop_statement, a continue statement would instead
+cause a transfer of control that completes only the current iteration of that
+loop_statement, like a goto statement targeting a label following the last
+statement in the sequence of statements of the specified loop_statement.
+
+Note that @code{continue} is a keyword but it is not a reserved word. This is a
+configuration that does not exist in standard Ada.
+
@node Security Hardening Features,Obsolescent Features,GNAT language extensions,Top
-@anchor{gnat_rm/security_hardening_features doc}@anchor{46e}@anchor{gnat_rm/security_hardening_features id1}@anchor{46f}@anchor{gnat_rm/security_hardening_features security-hardening-features}@anchor{15}
+@anchor{gnat_rm/security_hardening_features doc}@anchor{472}@anchor{gnat_rm/security_hardening_features id1}@anchor{473}@anchor{gnat_rm/security_hardening_features security-hardening-features}@anchor{15}
@chapter Security Hardening Features
@@ -31278,7 +32597,7 @@ change.
@end menu
@node Register Scrubbing,Stack Scrubbing,,Security Hardening Features
-@anchor{gnat_rm/security_hardening_features register-scrubbing}@anchor{470}
+@anchor{gnat_rm/security_hardening_features register-scrubbing}@anchor{474}
@section Register Scrubbing
@@ -31314,7 +32633,7 @@ programming languages, see @cite{Using the GNU Compiler Collection (GCC)}.
@c Stack Scrubbing:
@node Stack Scrubbing,Hardened Conditionals,Register Scrubbing,Security Hardening Features
-@anchor{gnat_rm/security_hardening_features stack-scrubbing}@anchor{471}
+@anchor{gnat_rm/security_hardening_features stack-scrubbing}@anchor{475}
@section Stack Scrubbing
@@ -31458,7 +32777,7 @@ Bar_Callable_Ptr.
@c Hardened Conditionals:
@node Hardened Conditionals,Hardened Booleans,Stack Scrubbing,Security Hardening Features
-@anchor{gnat_rm/security_hardening_features hardened-conditionals}@anchor{472}
+@anchor{gnat_rm/security_hardening_features hardened-conditionals}@anchor{476}
@section Hardened Conditionals
@@ -31548,7 +32867,7 @@ be used with other programming languages supported by GCC.
@c Hardened Booleans:
@node Hardened Booleans,Control Flow Redundancy,Hardened Conditionals,Security Hardening Features
-@anchor{gnat_rm/security_hardening_features hardened-booleans}@anchor{473}
+@anchor{gnat_rm/security_hardening_features hardened-booleans}@anchor{477}
@section Hardened Booleans
@@ -31609,7 +32928,7 @@ and more details on that attribute, see @cite{Using the GNU Compiler Collection
@c Control Flow Redundancy:
@node Control Flow Redundancy,,Hardened Booleans,Security Hardening Features
-@anchor{gnat_rm/security_hardening_features control-flow-redundancy}@anchor{474}
+@anchor{gnat_rm/security_hardening_features control-flow-redundancy}@anchor{478}
@section Control Flow Redundancy
@@ -31777,7 +33096,7 @@ see @cite{Using the GNU Compiler Collection (GCC)}. These options
can be used with other programming languages supported by GCC.
@node Obsolescent Features,Compatibility and Porting Guide,Security Hardening Features,Top
-@anchor{gnat_rm/obsolescent_features doc}@anchor{475}@anchor{gnat_rm/obsolescent_features id1}@anchor{476}@anchor{gnat_rm/obsolescent_features obsolescent-features}@anchor{16}
+@anchor{gnat_rm/obsolescent_features doc}@anchor{479}@anchor{gnat_rm/obsolescent_features id1}@anchor{47a}@anchor{gnat_rm/obsolescent_features obsolescent-features}@anchor{16}
@chapter Obsolescent Features
@@ -31796,7 +33115,7 @@ compatibility purposes.
@end menu
@node pragma No_Run_Time,pragma Ravenscar,,Obsolescent Features
-@anchor{gnat_rm/obsolescent_features id2}@anchor{477}@anchor{gnat_rm/obsolescent_features pragma-no-run-time}@anchor{478}
+@anchor{gnat_rm/obsolescent_features id2}@anchor{47b}@anchor{gnat_rm/obsolescent_features pragma-no-run-time}@anchor{47c}
@section pragma No_Run_Time
@@ -31809,7 +33128,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{479}@anchor{gnat_rm/obsolescent_features pragma-ravenscar}@anchor{47a}
+@anchor{gnat_rm/obsolescent_features id3}@anchor{47d}@anchor{gnat_rm/obsolescent_features pragma-ravenscar}@anchor{47e}
@section pragma Ravenscar
@@ -31818,7 +33137,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 id4}@anchor{47b}@anchor{gnat_rm/obsolescent_features pragma-restricted-run-time}@anchor{47c}
+@anchor{gnat_rm/obsolescent_features id4}@anchor{47f}@anchor{gnat_rm/obsolescent_features pragma-restricted-run-time}@anchor{480}
@section pragma Restricted_Run_Time
@@ -31828,7 +33147,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 id5}@anchor{47d}@anchor{gnat_rm/obsolescent_features pragma-task-info}@anchor{47e}
+@anchor{gnat_rm/obsolescent_features id5}@anchor{481}@anchor{gnat_rm/obsolescent_features pragma-task-info}@anchor{482}
@section pragma Task_Info
@@ -31854,7 +33173,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{47f}@anchor{gnat_rm/obsolescent_features package-system-task-info-s-tasinf-ads}@anchor{480}
+@anchor{gnat_rm/obsolescent_features package-system-task-info}@anchor{483}@anchor{gnat_rm/obsolescent_features package-system-task-info-s-tasinf-ads}@anchor{484}
@section package System.Task_Info (@code{s-tasinf.ads})
@@ -31864,7 +33183,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 doc}@anchor{481}@anchor{gnat_rm/compatibility_and_porting_guide compatibility-and-porting-guide}@anchor{17}@anchor{gnat_rm/compatibility_and_porting_guide id1}@anchor{482}
+@anchor{gnat_rm/compatibility_and_porting_guide doc}@anchor{485}@anchor{gnat_rm/compatibility_and_porting_guide compatibility-and-porting-guide}@anchor{17}@anchor{gnat_rm/compatibility_and_porting_guide id1}@anchor{486}
@chapter Compatibility and Porting Guide
@@ -31886,7 +33205,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{483}@anchor{gnat_rm/compatibility_and_porting_guide writing-portable-fixed-point-declarations}@anchor{484}
+@anchor{gnat_rm/compatibility_and_porting_guide id2}@anchor{487}@anchor{gnat_rm/compatibility_and_porting_guide writing-portable-fixed-point-declarations}@anchor{488}
@section Writing Portable Fixed-Point Declarations
@@ -32008,13 +33327,13 @@ 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{485}@anchor{gnat_rm/compatibility_and_porting_guide id3}@anchor{486}
+@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-ada-83}@anchor{489}@anchor{gnat_rm/compatibility_and_porting_guide id3}@anchor{48a}
@section Compatibility with Ada 83
-@geindex Compatibility (between Ada 83 and Ada 95 / Ada 2005 / Ada 2012)
+@geindex Compatibility (between Ada 83 and Ada 95 / Ada 2005 / Ada 2012 / Ada 2022)
-Ada 95 and the subsequent revisions Ada 2005 and Ada 2012
+Ada 95 and the subsequent revisions Ada 2005, Ada 2012, Ada 2022
are highly upwards compatible with Ada 83. In
particular, the design intention was that the difficulties associated
with moving from Ada 83 to later versions of the standard should be no greater
@@ -32036,7 +33355,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{487}@anchor{gnat_rm/compatibility_and_porting_guide legal-ada-83-programs-that-are-illegal-in-ada-95}@anchor{488}
+@anchor{gnat_rm/compatibility_and_porting_guide id4}@anchor{48b}@anchor{gnat_rm/compatibility_and_porting_guide legal-ada-83-programs-that-are-illegal-in-ada-95}@anchor{48c}
@subsection Legal Ada 83 programs that are illegal in Ada 95
@@ -32136,7 +33455,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 id5}@anchor{489}@anchor{gnat_rm/compatibility_and_porting_guide more-deterministic-semantics}@anchor{48a}
+@anchor{gnat_rm/compatibility_and_porting_guide id5}@anchor{48d}@anchor{gnat_rm/compatibility_and_porting_guide more-deterministic-semantics}@anchor{48e}
@subsection More deterministic semantics
@@ -32164,7 +33483,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 changed-semantics}@anchor{48b}@anchor{gnat_rm/compatibility_and_porting_guide id6}@anchor{48c}
+@anchor{gnat_rm/compatibility_and_porting_guide changed-semantics}@anchor{48f}@anchor{gnat_rm/compatibility_and_porting_guide id6}@anchor{490}
@subsection Changed semantics
@@ -32206,7 +33525,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 id7}@anchor{48d}@anchor{gnat_rm/compatibility_and_porting_guide other-language-compatibility-issues}@anchor{48e}
+@anchor{gnat_rm/compatibility_and_porting_guide id7}@anchor{491}@anchor{gnat_rm/compatibility_and_porting_guide other-language-compatibility-issues}@anchor{492}
@subsection Other language compatibility issues
@@ -32239,7 +33558,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{48f}@anchor{gnat_rm/compatibility_and_porting_guide id8}@anchor{490}
+@anchor{gnat_rm/compatibility_and_porting_guide compatibility-between-ada-95-and-ada-2005}@anchor{493}@anchor{gnat_rm/compatibility_and_porting_guide id8}@anchor{494}
@section Compatibility between Ada 95 and Ada 2005
@@ -32311,7 +33630,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 id9}@anchor{491}@anchor{gnat_rm/compatibility_and_porting_guide implementation-dependent-characteristics}@anchor{492}
+@anchor{gnat_rm/compatibility_and_porting_guide id9}@anchor{495}@anchor{gnat_rm/compatibility_and_porting_guide implementation-dependent-characteristics}@anchor{496}
@section Implementation-dependent characteristics
@@ -32334,7 +33653,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 id10}@anchor{493}@anchor{gnat_rm/compatibility_and_porting_guide implementation-defined-pragmas}@anchor{494}
+@anchor{gnat_rm/compatibility_and_porting_guide id10}@anchor{497}@anchor{gnat_rm/compatibility_and_porting_guide implementation-defined-pragmas}@anchor{498}
@subsection Implementation-defined pragmas
@@ -32356,7 +33675,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{495}@anchor{gnat_rm/compatibility_and_porting_guide implementation-defined-attributes}@anchor{496}
+@anchor{gnat_rm/compatibility_and_porting_guide id11}@anchor{499}@anchor{gnat_rm/compatibility_and_porting_guide implementation-defined-attributes}@anchor{49a}
@subsection Implementation-defined attributes
@@ -32370,7 +33689,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 id12}@anchor{497}@anchor{gnat_rm/compatibility_and_porting_guide libraries}@anchor{498}
+@anchor{gnat_rm/compatibility_and_porting_guide id12}@anchor{49b}@anchor{gnat_rm/compatibility_and_porting_guide libraries}@anchor{49c}
@subsection Libraries
@@ -32399,7 +33718,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{499}@anchor{gnat_rm/compatibility_and_porting_guide id13}@anchor{49a}
+@anchor{gnat_rm/compatibility_and_porting_guide elaboration-order}@anchor{49d}@anchor{gnat_rm/compatibility_and_porting_guide id13}@anchor{49e}
@subsection Elaboration order
@@ -32435,7 +33754,7 @@ pragmas either globally (as an effect of the `-gnatE' switch) or locally
@end itemize
@node Target-specific aspects,,Elaboration order,Implementation-dependent characteristics
-@anchor{gnat_rm/compatibility_and_porting_guide id14}@anchor{49b}@anchor{gnat_rm/compatibility_and_porting_guide target-specific-aspects}@anchor{49c}
+@anchor{gnat_rm/compatibility_and_porting_guide id14}@anchor{49f}@anchor{gnat_rm/compatibility_and_porting_guide target-specific-aspects}@anchor{4a0}
@subsection Target-specific aspects
@@ -32445,13 +33764,13 @@ such an Ada 83 application is being ported to different target hardware (for
example where the byte endianness has changed) then you will need to
carefully examine the program logic; the porting effort will heavily depend
on the robustness of the original design. Moreover, Ada 95 (and thus
-Ada 2005 and Ada 2012) are sometimes
+Ada 2005, Ada 2012, and Ada 2022) 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{49d,,Representation Clauses}.
+GNAT’s approach to these issues is described in @ref{4a1,,Representation Clauses}.
@node Compatibility with Other Ada Systems,Representation Clauses,Implementation-dependent characteristics,Compatibility and Porting Guide
-@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-other-ada-systems}@anchor{49e}@anchor{gnat_rm/compatibility_and_porting_guide id15}@anchor{49f}
+@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-other-ada-systems}@anchor{4a2}@anchor{gnat_rm/compatibility_and_porting_guide id15}@anchor{4a3}
@section Compatibility with Other Ada Systems
@@ -32494,7 +33813,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 id16}@anchor{4a0}@anchor{gnat_rm/compatibility_and_porting_guide representation-clauses}@anchor{49d}
+@anchor{gnat_rm/compatibility_and_porting_guide id16}@anchor{4a4}@anchor{gnat_rm/compatibility_and_porting_guide representation-clauses}@anchor{4a1}
@section Representation Clauses
@@ -32587,7 +33906,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{4a1}@anchor{gnat_rm/compatibility_and_porting_guide id17}@anchor{4a2}
+@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-hp-ada-83}@anchor{4a5}@anchor{gnat_rm/compatibility_and_porting_guide id17}@anchor{4a6}
@section Compatibility with HP Ada 83
@@ -32617,7 +33936,7 @@ extension of package System.
@end itemize
@node GNU Free Documentation License,Index,Compatibility and Porting Guide,Top
-@anchor{share/gnu_free_documentation_license doc}@anchor{4a3}@anchor{share/gnu_free_documentation_license gnu-fdl}@anchor{1}@anchor{share/gnu_free_documentation_license gnu-free-documentation-license}@anchor{4a4}
+@anchor{share/gnu_free_documentation_license doc}@anchor{4a7}@anchor{share/gnu_free_documentation_license gnu-fdl}@anchor{1}@anchor{share/gnu_free_documentation_license gnu-free-documentation-license}@anchor{4a8}
@chapter GNU Free Documentation License
diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi
index 2579b31..6cd0bed 100644
--- a/gcc/ada/gnat_ugn.texi
+++ b/gcc/ada/gnat_ugn.texi
@@ -3,7 +3,7 @@
@setfilename gnat_ugn.info
@documentencoding UTF-8
@ifinfo
-@*Generated by Sphinx 8.0.2.@*
+@*Generated by Sphinx 8.2.3.@*
@end ifinfo
@settitle GNAT User's Guide for Native Platforms
@defindex ge
@@ -19,7 +19,7 @@
@copying
@quotation
-GNAT User's Guide for Native Platforms , Jan 13, 2025
+GNAT User's Guide for Native Platforms , Jun 27, 2025
AdaCore
@@ -334,6 +334,7 @@ GNAT and Program Execution
* Performing Dimensionality Analysis in GNAT::
* Stack Related Facilities::
* Memory Management Issues::
+* Sanitizers for Ada::
Running and Debugging Ada Programs
@@ -415,6 +416,12 @@ Memory Management Issues
* Some Useful Memory Pools::
* The GNAT Debug Pool Facility::
+Sanitizers for Ada
+
+* AddressSanitizer::
+* UndefinedBehaviorSanitizer::
+* Sanitizers in mixed-language applications::
+
Platform-Specific Information
* Run-Time Libraries::
@@ -2911,6 +2918,10 @@ You can place configuration pragmas either appear at the start of a compilation
unit or in a configuration pragma file that applies to
all compilations performed in a given compilation environment.
+Configuration pragmas placed before a library level package specification
+are not propagated to the corresponding package body (see RM 10.1.5(8));
+they must be added explicitly to the package body.
+
GNAT includes the @code{gnatchop} utility to provide an automatic
way to handle configuration pragmas that follows the semantics for
compilations (that is, files with multiple units) described in the RM.
@@ -9846,7 +9857,7 @@ Treat pragma Restrictions as Restriction_Warnings.
@table @asis
-@item @code{-gnatR[0|1|2|3|4][e][j][m][s]}
+@item @code{-gnatR[0|1|2|3|4][e][h][m][j][s]}
Output representation information for declared types, objects and
subprograms. Note that this switch is not allowed if a previous
@@ -10072,7 +10083,7 @@ Library (RTL) ALI files.
@code{n} controls the optimization level:
-@multitable {xxxxxxxxx} {xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx}
+@multitable {xxxxxxxxx} {xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx}
@item
`n'
@@ -10087,7 +10098,7 @@ Effect
@tab
-No optimization, the default setting if no @code{-O} appears
+No optimization, the default setting if no @code{-O} appears.
@item
@@ -10095,9 +10106,8 @@ No optimization, the default setting if no @code{-O} appears
@tab
-Normal optimization, the default if you specify @code{-O} without an
-operand. A good compromise between code quality and compilation
-time.
+Moderate optimization, same as @code{-O} without an operand.
+A good compromise between code quality and compilation time.
@item
@@ -10105,7 +10115,7 @@ time.
@tab
-Extensive optimization, may improve execution time, possibly at
+Extensive optimization, should improve execution time, possibly at
the cost of substantially increased compilation time.
@item
@@ -10114,8 +10124,8 @@ the cost of substantially increased compilation time.
@tab
-Same as @code{-O2}, and also includes inline expansion for small
-subprograms in the same unit.
+Full optimization, may further improve execution time, possibly at
+the cost of substantially larger generated code.
@item
@@ -10123,7 +10133,23 @@ subprograms in the same unit.
@tab
-Optimize space usage
+Optimize for size (code and data) rather than speed.
+
+@item
+
+`z'
+
+@tab
+
+Optimize aggressively for size (code and data) rather than speed.
+
+@item
+
+`g'
+
+@tab
+
+Optimize for debugging experience rather than speed.
@end multitable
@@ -15266,7 +15292,7 @@ restriction warnings rather than restrictions.
@table @asis
-@item @code{-gnatR[0|1|2|3|4][e][j][m][s]}
+@item @code{-gnatR[0|1|2|3|4][e][h][m][j][s]}
This switch controls output from the compiler of a listing showing
representation information for declared types, objects and subprograms.
@@ -15295,17 +15321,21 @@ If the switch is followed by an @code{e} (e.g. @code{-gnatR2e}), then
extended representation information for record sub-components of records
is included.
+If the switch is followed by a @code{h} (e.g. @code{-gnatR3h}), then
+the components of records are sorted by increasing offsets and holes
+between consecutive components are flagged.
+
If the switch is followed by an @code{m} (e.g. @code{-gnatRm}), then
subprogram conventions and parameter passing mechanisms for all the
subprograms are included.
-If the switch is followed by a @code{j} (e.g., @code{-gnatRj}), then
+If the switch is followed by a @code{j} (e.g. @code{-gnatRj}), then
the output is in the JSON data interchange format specified by the
ECMA-404 standard. The semantic description of this JSON output is
available in the specification of the Repinfo unit present in the
compiler sources.
-If the switch is followed by an @code{s} (e.g., @code{-gnatR3s}), then
+If the switch is followed by an @code{s} (e.g. @code{-gnatR3s}), then
the output is to a file with the name @code{file.rep} where @code{file} is
the name of the corresponding source file, except if @code{j} is also
specified, in which case the file name is @code{file.json}.
@@ -17634,6 +17664,9 @@ file with @code{gprconfig} and using it with @code{gprbuild}; see the
can determine from the first line of the @code{.ali} file
which version of GNAT built that file because it contains either
@code{GNAT} or @code{GNAT-LLVM}.
+
+You can also explicitly select GNAT LLVM in your existing GPR project
+file by adding @code{for Toolchain_Name("Ada") use "GNAT_LLVM";}
@end itemize
@@ -18331,6 +18364,9 @@ This chapter covers several topics:
@item
@ref{151,,Memory Management Issues}
+
+@item
+@ref{152,,Sanitizers for Ada}
@end itemize
@menu
@@ -18341,11 +18377,12 @@ This chapter covers several topics:
* Performing Dimensionality Analysis in GNAT::
* Stack Related Facilities::
* Memory Management Issues::
+* Sanitizers for Ada::
@end menu
@node Running and Debugging Ada Programs,Profiling,,GNAT and Program Execution
-@anchor{gnat_ugn/gnat_and_program_execution id2}@anchor{14b}@anchor{gnat_ugn/gnat_and_program_execution running-and-debugging-ada-programs}@anchor{152}
+@anchor{gnat_ugn/gnat_and_program_execution id2}@anchor{14b}@anchor{gnat_ugn/gnat_and_program_execution running-and-debugging-ada-programs}@anchor{153}
@section Running and Debugging Ada Programs
@@ -18399,7 +18436,7 @@ the incorrect user program.
@end menu
@node The GNAT Debugger GDB,Running GDB,,Running and Debugging Ada Programs
-@anchor{gnat_ugn/gnat_and_program_execution id3}@anchor{153}@anchor{gnat_ugn/gnat_and_program_execution the-gnat-debugger-gdb}@anchor{154}
+@anchor{gnat_ugn/gnat_and_program_execution id3}@anchor{154}@anchor{gnat_ugn/gnat_and_program_execution the-gnat-debugger-gdb}@anchor{155}
@subsection The GNAT Debugger GDB
@@ -18457,7 +18494,7 @@ the debugging information and can respond to user commands to inspect
variables and more generally to report on the state of execution.
@node Running GDB,Introduction to GDB Commands,The GNAT Debugger GDB,Running and Debugging Ada Programs
-@anchor{gnat_ugn/gnat_and_program_execution id4}@anchor{155}@anchor{gnat_ugn/gnat_and_program_execution running-gdb}@anchor{156}
+@anchor{gnat_ugn/gnat_and_program_execution id4}@anchor{156}@anchor{gnat_ugn/gnat_and_program_execution running-gdb}@anchor{157}
@subsection Running GDB
@@ -18484,7 +18521,7 @@ exactly as if the debugger were not present. The following section
describes some of the additional commands that you can give to @code{GDB}.
@node Introduction to GDB Commands,Using Ada Expressions,Running GDB,Running and Debugging Ada Programs
-@anchor{gnat_ugn/gnat_and_program_execution id5}@anchor{157}@anchor{gnat_ugn/gnat_and_program_execution introduction-to-gdb-commands}@anchor{158}
+@anchor{gnat_ugn/gnat_and_program_execution id5}@anchor{158}@anchor{gnat_ugn/gnat_and_program_execution introduction-to-gdb-commands}@anchor{159}
@subsection Introduction to GDB Commands
@@ -18698,7 +18735,7 @@ characters need be typed to disambiguate the command (e.g., “br” for
@code{breakpoint}).
@node Using Ada Expressions,Calling User-Defined Subprograms,Introduction to GDB Commands,Running and Debugging Ada Programs
-@anchor{gnat_ugn/gnat_and_program_execution id6}@anchor{159}@anchor{gnat_ugn/gnat_and_program_execution using-ada-expressions}@anchor{15a}
+@anchor{gnat_ugn/gnat_and_program_execution id6}@anchor{15a}@anchor{gnat_ugn/gnat_and_program_execution using-ada-expressions}@anchor{15b}
@subsection Using Ada Expressions
@@ -18736,7 +18773,7 @@ their packages, regardless of context. Where this causes ambiguity,
For details on the supported Ada syntax, see @cite{Debugging with GDB}.
@node Calling User-Defined Subprograms,Using the next Command in a Function,Using Ada Expressions,Running and Debugging Ada Programs
-@anchor{gnat_ugn/gnat_and_program_execution calling-user-defined-subprograms}@anchor{15b}@anchor{gnat_ugn/gnat_and_program_execution id7}@anchor{15c}
+@anchor{gnat_ugn/gnat_and_program_execution calling-user-defined-subprograms}@anchor{15c}@anchor{gnat_ugn/gnat_and_program_execution id7}@anchor{15d}
@subsection Calling User-Defined Subprograms
@@ -18795,7 +18832,7 @@ elements directly from GDB, you can write a callable procedure that prints
the elements in the format you desire.
@node Using the next Command in a Function,Stopping When Ada Exceptions Are Raised,Calling User-Defined Subprograms,Running and Debugging Ada Programs
-@anchor{gnat_ugn/gnat_and_program_execution id8}@anchor{15d}@anchor{gnat_ugn/gnat_and_program_execution using-the-next-command-in-a-function}@anchor{15e}
+@anchor{gnat_ugn/gnat_and_program_execution id8}@anchor{15e}@anchor{gnat_ugn/gnat_and_program_execution using-the-next-command-in-a-function}@anchor{15f}
@subsection Using the `next' Command in a Function
@@ -18818,7 +18855,7 @@ The value returned is always that from the first return statement
that was stepped through.
@node Stopping When Ada Exceptions Are Raised,Ada Tasks,Using the next Command in a Function,Running and Debugging Ada Programs
-@anchor{gnat_ugn/gnat_and_program_execution id9}@anchor{15f}@anchor{gnat_ugn/gnat_and_program_execution stopping-when-ada-exceptions-are-raised}@anchor{160}
+@anchor{gnat_ugn/gnat_and_program_execution id9}@anchor{160}@anchor{gnat_ugn/gnat_and_program_execution stopping-when-ada-exceptions-are-raised}@anchor{161}
@subsection Stopping When Ada Exceptions Are Raised
@@ -18875,7 +18912,7 @@ argument, prints out only those exceptions whose name matches `regexp'.
@geindex Tasks (in gdb)
@node Ada Tasks,Debugging Generic Units,Stopping When Ada Exceptions Are Raised,Running and Debugging Ada Programs
-@anchor{gnat_ugn/gnat_and_program_execution ada-tasks}@anchor{161}@anchor{gnat_ugn/gnat_and_program_execution id10}@anchor{162}
+@anchor{gnat_ugn/gnat_and_program_execution ada-tasks}@anchor{162}@anchor{gnat_ugn/gnat_and_program_execution id10}@anchor{163}
@subsection Ada Tasks
@@ -18962,7 +18999,7 @@ see @cite{Debugging with GDB}.
@geindex Generics
@node Debugging Generic Units,Remote Debugging with gdbserver,Ada Tasks,Running and Debugging Ada Programs
-@anchor{gnat_ugn/gnat_and_program_execution debugging-generic-units}@anchor{163}@anchor{gnat_ugn/gnat_and_program_execution id11}@anchor{164}
+@anchor{gnat_ugn/gnat_and_program_execution debugging-generic-units}@anchor{164}@anchor{gnat_ugn/gnat_and_program_execution id11}@anchor{165}
@subsection Debugging Generic Units
@@ -19022,7 +19059,7 @@ variables, as you do for other units.
@geindex Remote Debugging with gdbserver
@node Remote Debugging with gdbserver,GNAT Abnormal Termination or Failure to Terminate,Debugging Generic Units,Running and Debugging Ada Programs
-@anchor{gnat_ugn/gnat_and_program_execution id12}@anchor{165}@anchor{gnat_ugn/gnat_and_program_execution remote-debugging-with-gdbserver}@anchor{166}
+@anchor{gnat_ugn/gnat_and_program_execution id12}@anchor{166}@anchor{gnat_ugn/gnat_and_program_execution remote-debugging-with-gdbserver}@anchor{167}
@subsection Remote Debugging with gdbserver
@@ -19081,7 +19118,7 @@ x86_64-linux.
@geindex Abnormal Termination or Failure to Terminate
@node GNAT Abnormal Termination or Failure to Terminate,Naming Conventions for GNAT Source Files,Remote Debugging with gdbserver,Running and Debugging Ada Programs
-@anchor{gnat_ugn/gnat_and_program_execution gnat-abnormal-termination-or-failure-to-terminate}@anchor{167}@anchor{gnat_ugn/gnat_and_program_execution id13}@anchor{168}
+@anchor{gnat_ugn/gnat_and_program_execution gnat-abnormal-termination-or-failure-to-terminate}@anchor{168}@anchor{gnat_ugn/gnat_and_program_execution id13}@anchor{169}
@subsection GNAT Abnormal Termination or Failure to Terminate
@@ -19136,7 +19173,7 @@ Finally, you can start
@code{gdb} directly on the @code{gnat1} executable. @code{gnat1} is the
front-end of GNAT and can be run independently (normally it is just
called from @code{gcc}). You can use @code{gdb} on @code{gnat1} as you
-would on a C program (but @ref{154,,The GNAT Debugger GDB} for caveats). The
+would on a C program (but @ref{155,,The GNAT Debugger GDB} for caveats). The
@code{where} command is the first line of attack; the variable
@code{lineno} (seen by @code{print lineno}), used by the second phase of
@code{gnat1} and by the @code{gcc} back end, indicates the source line at
@@ -19145,7 +19182,7 @@ the source file.
@end itemize
@node Naming Conventions for GNAT Source Files,Getting Internal Debugging Information,GNAT Abnormal Termination or Failure to Terminate,Running and Debugging Ada Programs
-@anchor{gnat_ugn/gnat_and_program_execution id14}@anchor{169}@anchor{gnat_ugn/gnat_and_program_execution naming-conventions-for-gnat-source-files}@anchor{16a}
+@anchor{gnat_ugn/gnat_and_program_execution id14}@anchor{16a}@anchor{gnat_ugn/gnat_and_program_execution naming-conventions-for-gnat-source-files}@anchor{16b}
@subsection Naming Conventions for GNAT Source Files
@@ -19235,7 +19272,7 @@ the other @code{.c} files are modifications of common @code{gcc} files.
@end itemize
@node Getting Internal Debugging Information,Stack Traceback,Naming Conventions for GNAT Source Files,Running and Debugging Ada Programs
-@anchor{gnat_ugn/gnat_and_program_execution getting-internal-debugging-information}@anchor{16b}@anchor{gnat_ugn/gnat_and_program_execution id15}@anchor{16c}
+@anchor{gnat_ugn/gnat_and_program_execution getting-internal-debugging-information}@anchor{16c}@anchor{gnat_ugn/gnat_and_program_execution id15}@anchor{16d}
@subsection Getting Internal Debugging Information
@@ -19263,7 +19300,7 @@ are replaced with run-time calls.
@geindex stack unwinding
@node Stack Traceback,Pretty-Printers for the GNAT runtime,Getting Internal Debugging Information,Running and Debugging Ada Programs
-@anchor{gnat_ugn/gnat_and_program_execution id16}@anchor{16d}@anchor{gnat_ugn/gnat_and_program_execution stack-traceback}@anchor{16e}
+@anchor{gnat_ugn/gnat_and_program_execution id16}@anchor{16e}@anchor{gnat_ugn/gnat_and_program_execution stack-traceback}@anchor{16f}
@subsection Stack Traceback
@@ -19292,7 +19329,7 @@ is enabled and no exception is raised during program execution.
@end menu
@node Non-Symbolic Traceback,Symbolic Traceback,,Stack Traceback
-@anchor{gnat_ugn/gnat_and_program_execution id17}@anchor{16f}@anchor{gnat_ugn/gnat_and_program_execution non-symbolic-traceback}@anchor{170}
+@anchor{gnat_ugn/gnat_and_program_execution id17}@anchor{170}@anchor{gnat_ugn/gnat_and_program_execution non-symbolic-traceback}@anchor{171}
@subsubsection Non-Symbolic Traceback
@@ -19614,7 +19651,7 @@ addresses need to be specified in C format, with a leading ‘0x’).
@geindex symbolic
@node Symbolic Traceback,,Non-Symbolic Traceback,Stack Traceback
-@anchor{gnat_ugn/gnat_and_program_execution id18}@anchor{171}@anchor{gnat_ugn/gnat_and_program_execution symbolic-traceback}@anchor{172}
+@anchor{gnat_ugn/gnat_and_program_execution id18}@anchor{172}@anchor{gnat_ugn/gnat_and_program_execution symbolic-traceback}@anchor{173}
@subsubsection Symbolic Traceback
@@ -19733,7 +19770,7 @@ traceback, which will also be printed if an unhandled exception
terminates the program.
@node Pretty-Printers for the GNAT runtime,,Stack Traceback,Running and Debugging Ada Programs
-@anchor{gnat_ugn/gnat_and_program_execution id19}@anchor{173}@anchor{gnat_ugn/gnat_and_program_execution pretty-printers-for-the-gnat-runtime}@anchor{174}
+@anchor{gnat_ugn/gnat_and_program_execution id19}@anchor{174}@anchor{gnat_ugn/gnat_and_program_execution pretty-printers-for-the-gnat-runtime}@anchor{175}
@subsection Pretty-Printers for the GNAT runtime
@@ -19842,7 +19879,7 @@ for more information.
@geindex Profiling
@node Profiling,Improving Performance,Running and Debugging Ada Programs,GNAT and Program Execution
-@anchor{gnat_ugn/gnat_and_program_execution id20}@anchor{175}@anchor{gnat_ugn/gnat_and_program_execution profiling}@anchor{14c}
+@anchor{gnat_ugn/gnat_and_program_execution id20}@anchor{176}@anchor{gnat_ugn/gnat_and_program_execution profiling}@anchor{14c}
@section Profiling
@@ -19858,7 +19895,7 @@ This section describes how to use the @code{gprof} profiler tool on Ada programs
@end menu
@node Profiling an Ada Program with gprof,,,Profiling
-@anchor{gnat_ugn/gnat_and_program_execution id21}@anchor{176}@anchor{gnat_ugn/gnat_and_program_execution profiling-an-ada-program-with-gprof}@anchor{177}
+@anchor{gnat_ugn/gnat_and_program_execution id21}@anchor{177}@anchor{gnat_ugn/gnat_and_program_execution profiling-an-ada-program-with-gprof}@anchor{178}
@subsection Profiling an Ada Program with gprof
@@ -19913,7 +19950,7 @@ to interpret the results.
@end menu
@node Compilation for profiling,Program execution,,Profiling an Ada Program with gprof
-@anchor{gnat_ugn/gnat_and_program_execution compilation-for-profiling}@anchor{178}@anchor{gnat_ugn/gnat_and_program_execution id22}@anchor{179}
+@anchor{gnat_ugn/gnat_and_program_execution compilation-for-profiling}@anchor{179}@anchor{gnat_ugn/gnat_and_program_execution id22}@anchor{17a}
@subsubsection Compilation for profiling
@@ -19944,7 +19981,7 @@ Note that on Windows, @code{gprof} does not support PIE. You should add
the @code{-no-pie} switch to the linker flags to disable PIE.
@node Program execution,Running gprof,Compilation for profiling,Profiling an Ada Program with gprof
-@anchor{gnat_ugn/gnat_and_program_execution id23}@anchor{17a}@anchor{gnat_ugn/gnat_and_program_execution program-execution}@anchor{17b}
+@anchor{gnat_ugn/gnat_and_program_execution id23}@anchor{17b}@anchor{gnat_ugn/gnat_and_program_execution program-execution}@anchor{17c}
@subsubsection Program execution
@@ -19959,7 +19996,7 @@ generated in the directory where the program was launched from. If this file
already exists, it will be overwritten by running the program.
@node Running gprof,Interpretation of profiling results,Program execution,Profiling an Ada Program with gprof
-@anchor{gnat_ugn/gnat_and_program_execution id24}@anchor{17c}@anchor{gnat_ugn/gnat_and_program_execution running-gprof}@anchor{17d}
+@anchor{gnat_ugn/gnat_and_program_execution id24}@anchor{17d}@anchor{gnat_ugn/gnat_and_program_execution running-gprof}@anchor{17e}
@subsubsection Running gprof
@@ -20071,7 +20108,7 @@ switch.
@end table
@node Interpretation of profiling results,,Running gprof,Profiling an Ada Program with gprof
-@anchor{gnat_ugn/gnat_and_program_execution id25}@anchor{17e}@anchor{gnat_ugn/gnat_and_program_execution interpretation-of-profiling-results}@anchor{17f}
+@anchor{gnat_ugn/gnat_and_program_execution id25}@anchor{17f}@anchor{gnat_ugn/gnat_and_program_execution interpretation-of-profiling-results}@anchor{180}
@subsubsection Interpretation of profiling results
@@ -20088,7 +20125,7 @@ and the subprograms that it calls. It also provides an estimate of the time
spent in each of those callers and called subprograms.
@node Improving Performance,Overflow Check Handling in GNAT,Profiling,GNAT and Program Execution
-@anchor{gnat_ugn/gnat_and_program_execution id26}@anchor{14d}@anchor{gnat_ugn/gnat_and_program_execution improving-performance}@anchor{180}
+@anchor{gnat_ugn/gnat_and_program_execution id26}@anchor{14d}@anchor{gnat_ugn/gnat_and_program_execution improving-performance}@anchor{181}
@section Improving Performance
@@ -20109,7 +20146,7 @@ which can reduce the size of program executables.
@end menu
@node Performance Considerations,Text_IO Suggestions,,Improving Performance
-@anchor{gnat_ugn/gnat_and_program_execution id27}@anchor{181}@anchor{gnat_ugn/gnat_and_program_execution performance-considerations}@anchor{182}
+@anchor{gnat_ugn/gnat_and_program_execution id27}@anchor{182}@anchor{gnat_ugn/gnat_and_program_execution performance-considerations}@anchor{183}
@subsection Performance Considerations
@@ -20170,7 +20207,7 @@ some guidelines on debugging optimized code.
@end menu
@node Controlling Run-Time Checks,Use of Restrictions,,Performance Considerations
-@anchor{gnat_ugn/gnat_and_program_execution controlling-run-time-checks}@anchor{183}@anchor{gnat_ugn/gnat_and_program_execution id28}@anchor{184}
+@anchor{gnat_ugn/gnat_and_program_execution controlling-run-time-checks}@anchor{184}@anchor{gnat_ugn/gnat_and_program_execution id28}@anchor{185}
@subsubsection Controlling Run-Time Checks
@@ -20222,7 +20259,7 @@ remove checks) or @code{pragma Unsuppress} (to add back suppressed
checks) in your program source.
@node Use of Restrictions,Optimization Levels,Controlling Run-Time Checks,Performance Considerations
-@anchor{gnat_ugn/gnat_and_program_execution id29}@anchor{185}@anchor{gnat_ugn/gnat_and_program_execution use-of-restrictions}@anchor{186}
+@anchor{gnat_ugn/gnat_and_program_execution id29}@anchor{186}@anchor{gnat_ugn/gnat_and_program_execution use-of-restrictions}@anchor{187}
@subsubsection Use of Restrictions
@@ -20258,7 +20295,7 @@ this, it also means you can write code without worrying about the
possibility of an immediate abort at any point.
@node Optimization Levels,Debugging Optimized Code,Use of Restrictions,Performance Considerations
-@anchor{gnat_ugn/gnat_and_program_execution id30}@anchor{187}@anchor{gnat_ugn/gnat_and_program_execution optimization-levels}@anchor{f0}
+@anchor{gnat_ugn/gnat_and_program_execution id30}@anchor{188}@anchor{gnat_ugn/gnat_and_program_execution optimization-levels}@anchor{f0}
@subsubsection Optimization Levels
@@ -20277,13 +20314,12 @@ Turning on optimization makes the compiler attempt to improve the
performance and/or code size at the expense of compilation time and
possibly the ability to debug the program.
-If you use multiple @code{-O} switches, with or without level
-numbers, the last such switch is the one that’s used.
-
-You can use the
-@code{-O} switch (the permitted forms are @code{-O0}, @code{-O1}
-@code{-O2}, @code{-O3}, and @code{-Os})
-to @code{gcc} to control the optimization level:
+You can pass the @code{-O} switch, with or without an operand
+(the permitted forms with an operand are @code{-O0}, @code{-O1},
+@code{-O2}, @code{-O3}, @code{-Os}, @code{-Oz}, and
+@code{-Og}) to @code{gcc} to control the optimization level. If you
+pass multiple @code{-O} switches, with or without an operand,
+the last such switch is the one that’s used:
@itemize *
@@ -20294,8 +20330,7 @@ to @code{gcc} to control the optimization level:
@item @code{-O0}
-No optimization (the default);
-generates unoptimized code but has
+No optimization (the default); generates unoptimized code but has
the fastest compilation time. Debugging is easiest with this switch.
Note that many other compilers do substantial optimization even if
@@ -20312,10 +20347,11 @@ mind when doing performance comparisons.
@item @code{-O1}
-Moderate optimization; optimizes reasonably well but does not
-degrade compilation time significantly. You may not be able to see
-some variables in the debugger and changing the value of some
-variables in the debugger may not have the effect you desire.
+Moderate optimization (same as @code{-O} without an operand);
+optimizes reasonably well but does not degrade compilation time
+significantly. You may not be able to see some variables in the
+debugger, and changing the value of some variables in the debugger
+may not have the effect you desire.
@end table
@item
@@ -20324,9 +20360,8 @@ variables in the debugger may not have the effect you desire.
@item @code{-O2}
-Full optimization;
-generates highly optimized code and has
-the slowest compilation time. You may see significant impacts on
+Extensive optimization; generates highly optimized code but has
+an increased compilation time. You may see significant impacts on
your ability to display and modify variables in the debugger.
@end table
@@ -20336,9 +20371,9 @@ your ability to display and modify variables in the debugger.
@item @code{-O3}
-Full optimization as in @code{-O2};
-also uses more aggressive automatic inlining of subprograms within a unit
-(@ref{104,,Inlining of Subprograms}) and attempts to vectorize loops.
+Full optimization; attempts more sophisticated transformations, in
+particular on loops, possibly at the cost of larger generated code.
+You may be hardly able to use the debugger at this optimization level.
@end table
@item
@@ -20347,16 +20382,41 @@ also uses more aggressive automatic inlining of subprograms within a unit
@item @code{-Os}
-Optimize space usage (code and data) of resulting program.
+Optimize for size (code and data) of resulting binary rather than
+speed; based on the @code{-O2} optimization level, but disables
+some of its transformations that often increase code size, as well
+as performs further optimizations designed to reduce code size.
+@end table
+
+@item
+
+@table @asis
+
+@item @code{-Oz}
+
+Optimize aggressively for size (code and data) of resulting binary
+rather than speed; may increase the number of instructions executed
+if these instructions require fewer bytes to be encoded.
+@end table
+
+@item
+
+@table @asis
+
+@item @code{-Og}
+
+Optimize for debugging experience rather than speed; based on the
+@code{-O1} optimization level, but attempts to eliminate all the
+negative effects of optimization on debugging.
@end table
@end itemize
Higher optimization levels perform more global transformations on the
program and apply more expensive analysis algorithms in order to generate
faster and more compact code. The price in compilation time, and the
-resulting improvement in execution time,
-both depend on the particular application and the hardware environment.
-You should experiment to find the best level for your application.
+resulting improvement in execution time, both depend on the particular
+application and the hardware environment. You should experiment to find
+the best level for your application.
Since the precise set of optimizations done at each level will vary from
release to release (and sometime from target to target), it is best to think
@@ -20381,7 +20441,7 @@ since it often results in larger executables which may run more slowly.
See further discussion of this point in @ref{104,,Inlining of Subprograms}.
@node Debugging Optimized Code,Inlining of Subprograms,Optimization Levels,Performance Considerations
-@anchor{gnat_ugn/gnat_and_program_execution debugging-optimized-code}@anchor{188}@anchor{gnat_ugn/gnat_and_program_execution id31}@anchor{189}
+@anchor{gnat_ugn/gnat_and_program_execution debugging-optimized-code}@anchor{189}@anchor{gnat_ugn/gnat_and_program_execution id31}@anchor{18a}
@subsubsection Debugging Optimized Code
@@ -20509,7 +20569,7 @@ on the resulting executable,
which removes both debugging information and global symbols.
@node Inlining of Subprograms,Floating Point Operations,Debugging Optimized Code,Performance Considerations
-@anchor{gnat_ugn/gnat_and_program_execution id32}@anchor{18a}@anchor{gnat_ugn/gnat_and_program_execution inlining-of-subprograms}@anchor{104}
+@anchor{gnat_ugn/gnat_and_program_execution id32}@anchor{18b}@anchor{gnat_ugn/gnat_and_program_execution inlining-of-subprograms}@anchor{104}
@subsubsection Inlining of Subprograms
@@ -20653,7 +20713,7 @@ indeed you should use @code{-O3} only if tests show that it actually
improves performance for your program.
@node Floating Point Operations,Vectorization of loops,Inlining of Subprograms,Performance Considerations
-@anchor{gnat_ugn/gnat_and_program_execution floating-point-operations}@anchor{18b}@anchor{gnat_ugn/gnat_and_program_execution id33}@anchor{18c}
+@anchor{gnat_ugn/gnat_and_program_execution floating-point-operations}@anchor{18c}@anchor{gnat_ugn/gnat_and_program_execution id33}@anchor{18d}
@subsubsection Floating Point Operations
@@ -20700,7 +20760,7 @@ Note that the ABI has the same form for both floating-point models,
so you can mix units compiled with and without these switches.
@node Vectorization of loops,Other Optimization Switches,Floating Point Operations,Performance Considerations
-@anchor{gnat_ugn/gnat_and_program_execution id34}@anchor{18d}@anchor{gnat_ugn/gnat_and_program_execution vectorization-of-loops}@anchor{18e}
+@anchor{gnat_ugn/gnat_and_program_execution id34}@anchor{18e}@anchor{gnat_ugn/gnat_and_program_execution vectorization-of-loops}@anchor{18f}
@subsubsection Vectorization of loops
@@ -20856,7 +20916,7 @@ omit the non-vectorized version of the loop as well as the run-time test.
This is also currently only supported by the GCC back end.
@node Other Optimization Switches,Optimization and Strict Aliasing,Vectorization of loops,Performance Considerations
-@anchor{gnat_ugn/gnat_and_program_execution id35}@anchor{18f}@anchor{gnat_ugn/gnat_and_program_execution other-optimization-switches}@anchor{190}
+@anchor{gnat_ugn/gnat_and_program_execution id35}@anchor{190}@anchor{gnat_ugn/gnat_and_program_execution other-optimization-switches}@anchor{191}
@subsubsection Other Optimization Switches
@@ -20873,7 +20933,7 @@ full details of these switches, see the `Submodel Options' section in
the `Hardware Models and Configurations' chapter of @cite{Using the GNU Compiler Collection (GCC)}.
@node Optimization and Strict Aliasing,Aliased Variables and Optimization,Other Optimization Switches,Performance Considerations
-@anchor{gnat_ugn/gnat_and_program_execution id36}@anchor{191}@anchor{gnat_ugn/gnat_and_program_execution optimization-and-strict-aliasing}@anchor{e7}
+@anchor{gnat_ugn/gnat_and_program_execution id36}@anchor{192}@anchor{gnat_ugn/gnat_and_program_execution optimization-and-strict-aliasing}@anchor{e7}
@subsubsection Optimization and Strict Aliasing
@@ -21167,7 +21227,7 @@ review any uses of unchecked conversion, particularly if you are
getting the warnings described above.
@node Aliased Variables and Optimization,Atomic Variables and Optimization,Optimization and Strict Aliasing,Performance Considerations
-@anchor{gnat_ugn/gnat_and_program_execution aliased-variables-and-optimization}@anchor{192}@anchor{gnat_ugn/gnat_and_program_execution id37}@anchor{193}
+@anchor{gnat_ugn/gnat_and_program_execution aliased-variables-and-optimization}@anchor{193}@anchor{gnat_ugn/gnat_and_program_execution id37}@anchor{194}
@subsubsection Aliased Variables and Optimization
@@ -21227,7 +21287,7 @@ avoid code such as this if possible because it’s not portable and may not
functin as you expect with all compilers.
@node Atomic Variables and Optimization,Passive Task Optimization,Aliased Variables and Optimization,Performance Considerations
-@anchor{gnat_ugn/gnat_and_program_execution atomic-variables-and-optimization}@anchor{194}@anchor{gnat_ugn/gnat_and_program_execution id38}@anchor{195}
+@anchor{gnat_ugn/gnat_and_program_execution atomic-variables-and-optimization}@anchor{195}@anchor{gnat_ugn/gnat_and_program_execution id38}@anchor{196}
@subsubsection Atomic Variables and Optimization
@@ -21308,7 +21368,7 @@ such synchronization code is not required, you may find it
useful to disable it.
@node Passive Task Optimization,,Atomic Variables and Optimization,Performance Considerations
-@anchor{gnat_ugn/gnat_and_program_execution id39}@anchor{196}@anchor{gnat_ugn/gnat_and_program_execution passive-task-optimization}@anchor{197}
+@anchor{gnat_ugn/gnat_and_program_execution id39}@anchor{197}@anchor{gnat_ugn/gnat_and_program_execution passive-task-optimization}@anchor{198}
@subsubsection Passive Task Optimization
@@ -21353,7 +21413,7 @@ that typically clients of the tasks who call entries will not have
to be modified, only the task definitions themselves.
@node Text_IO Suggestions,Reducing Size of Executables with Unused Subprogram/Data Elimination,Performance Considerations,Improving Performance
-@anchor{gnat_ugn/gnat_and_program_execution id40}@anchor{198}@anchor{gnat_ugn/gnat_and_program_execution text-io-suggestions}@anchor{199}
+@anchor{gnat_ugn/gnat_and_program_execution id40}@anchor{199}@anchor{gnat_ugn/gnat_and_program_execution text-io-suggestions}@anchor{19a}
@subsection @code{Text_IO} Suggestions
@@ -21376,7 +21436,7 @@ of the standard output file or change the standard output file to
be buffered using @code{Interfaces.C_Streams.setvbuf}.
@node Reducing Size of Executables with Unused Subprogram/Data Elimination,,Text_IO Suggestions,Improving Performance
-@anchor{gnat_ugn/gnat_and_program_execution id41}@anchor{19a}@anchor{gnat_ugn/gnat_and_program_execution reducing-size-of-executables-with-unused-subprogram-data-elimination}@anchor{19b}
+@anchor{gnat_ugn/gnat_and_program_execution id41}@anchor{19b}@anchor{gnat_ugn/gnat_and_program_execution reducing-size-of-executables-with-unused-subprogram-data-elimination}@anchor{19c}
@subsection Reducing Size of Executables with Unused Subprogram/Data Elimination
@@ -21393,7 +21453,7 @@ your executable just by setting options at compilation time.
@end menu
@node About unused subprogram/data elimination,Compilation options,,Reducing Size of Executables with Unused Subprogram/Data Elimination
-@anchor{gnat_ugn/gnat_and_program_execution about-unused-subprogram-data-elimination}@anchor{19c}@anchor{gnat_ugn/gnat_and_program_execution id42}@anchor{19d}
+@anchor{gnat_ugn/gnat_and_program_execution about-unused-subprogram-data-elimination}@anchor{19d}@anchor{gnat_ugn/gnat_and_program_execution id42}@anchor{19e}
@subsubsection About unused subprogram/data elimination
@@ -21407,7 +21467,7 @@ architecture and on all cross platforms using the ELF binary file format.
In both cases, GNU binutils version 2.16 or later are required to enable it.
@node Compilation options,Example of unused subprogram/data elimination,About unused subprogram/data elimination,Reducing Size of Executables with Unused Subprogram/Data Elimination
-@anchor{gnat_ugn/gnat_and_program_execution compilation-options}@anchor{19e}@anchor{gnat_ugn/gnat_and_program_execution id43}@anchor{19f}
+@anchor{gnat_ugn/gnat_and_program_execution compilation-options}@anchor{19f}@anchor{gnat_ugn/gnat_and_program_execution id43}@anchor{1a0}
@subsubsection Compilation options
@@ -21448,7 +21508,7 @@ eliminate the unused code and data of the GNAT library from your
executable.
@node Example of unused subprogram/data elimination,,Compilation options,Reducing Size of Executables with Unused Subprogram/Data Elimination
-@anchor{gnat_ugn/gnat_and_program_execution example-of-unused-subprogram-data-elimination}@anchor{1a0}@anchor{gnat_ugn/gnat_and_program_execution id44}@anchor{1a1}
+@anchor{gnat_ugn/gnat_and_program_execution example-of-unused-subprogram-data-elimination}@anchor{1a1}@anchor{gnat_ugn/gnat_and_program_execution id44}@anchor{1a2}
@subsubsection Example of unused subprogram/data elimination
@@ -21518,7 +21578,7 @@ appropriate switches.
@geindex Checks (overflow)
@node Overflow Check Handling in GNAT,Performing Dimensionality Analysis in GNAT,Improving Performance,GNAT and Program Execution
-@anchor{gnat_ugn/gnat_and_program_execution id45}@anchor{14e}@anchor{gnat_ugn/gnat_and_program_execution overflow-check-handling-in-gnat}@anchor{1a2}
+@anchor{gnat_ugn/gnat_and_program_execution id45}@anchor{14e}@anchor{gnat_ugn/gnat_and_program_execution overflow-check-handling-in-gnat}@anchor{1a3}
@section Overflow Check Handling in GNAT
@@ -21534,7 +21594,7 @@ This section explains how to control the handling of overflow checks.
@end menu
@node Background,Management of Overflows in GNAT,,Overflow Check Handling in GNAT
-@anchor{gnat_ugn/gnat_and_program_execution background}@anchor{1a3}@anchor{gnat_ugn/gnat_and_program_execution id46}@anchor{1a4}
+@anchor{gnat_ugn/gnat_and_program_execution background}@anchor{1a4}@anchor{gnat_ugn/gnat_and_program_execution id46}@anchor{1a5}
@subsection Background
@@ -21660,7 +21720,7 @@ exception raised because of the intermediate overflow (and we really
would prefer this precondition to be considered @code{True} at run time).
@node Management of Overflows in GNAT,Specifying the Desired Mode,Background,Overflow Check Handling in GNAT
-@anchor{gnat_ugn/gnat_and_program_execution id47}@anchor{1a5}@anchor{gnat_ugn/gnat_and_program_execution management-of-overflows-in-gnat}@anchor{1a6}
+@anchor{gnat_ugn/gnat_and_program_execution id47}@anchor{1a6}@anchor{gnat_ugn/gnat_and_program_execution management-of-overflows-in-gnat}@anchor{1a7}
@subsection Management of Overflows in GNAT
@@ -21774,7 +21834,7 @@ out in the normal manner (with infinite values always failing all
range checks).
@node Specifying the Desired Mode,Default Settings,Management of Overflows in GNAT,Overflow Check Handling in GNAT
-@anchor{gnat_ugn/gnat_and_program_execution id48}@anchor{1a7}@anchor{gnat_ugn/gnat_and_program_execution specifying-the-desired-mode}@anchor{ec}
+@anchor{gnat_ugn/gnat_and_program_execution id48}@anchor{1a8}@anchor{gnat_ugn/gnat_and_program_execution specifying-the-desired-mode}@anchor{ec}
@subsection Specifying the Desired Mode
@@ -21898,7 +21958,7 @@ equivalent to @code{-gnato11}, causing all intermediate operations
to be computed using the base type (@code{STRICT} mode).
@node Default Settings,Implementation Notes,Specifying the Desired Mode,Overflow Check Handling in GNAT
-@anchor{gnat_ugn/gnat_and_program_execution default-settings}@anchor{1a8}@anchor{gnat_ugn/gnat_and_program_execution id49}@anchor{1a9}
+@anchor{gnat_ugn/gnat_and_program_execution default-settings}@anchor{1a9}@anchor{gnat_ugn/gnat_and_program_execution id49}@anchor{1aa}
@subsection Default Settings
@@ -21922,7 +21982,7 @@ checking but has no effect on the method used for computing
intermediate results.
@node Implementation Notes,,Default Settings,Overflow Check Handling in GNAT
-@anchor{gnat_ugn/gnat_and_program_execution id50}@anchor{1aa}@anchor{gnat_ugn/gnat_and_program_execution implementation-notes}@anchor{1ab}
+@anchor{gnat_ugn/gnat_and_program_execution id50}@anchor{1ab}@anchor{gnat_ugn/gnat_and_program_execution implementation-notes}@anchor{1ac}
@subsection Implementation Notes
@@ -21970,7 +22030,7 @@ platforms for which @code{Long_Long_Integer} is at least 64-bits (nearly all GNA
platforms).
@node Performing Dimensionality Analysis in GNAT,Stack Related Facilities,Overflow Check Handling in GNAT,GNAT and Program Execution
-@anchor{gnat_ugn/gnat_and_program_execution id51}@anchor{14f}@anchor{gnat_ugn/gnat_and_program_execution performing-dimensionality-analysis-in-gnat}@anchor{1ac}
+@anchor{gnat_ugn/gnat_and_program_execution id51}@anchor{14f}@anchor{gnat_ugn/gnat_and_program_execution performing-dimensionality-analysis-in-gnat}@anchor{1ad}
@section Performing Dimensionality Analysis in GNAT
@@ -22373,7 +22433,7 @@ package Mks_Numerics is new
@end quotation
@node Stack Related Facilities,Memory Management Issues,Performing Dimensionality Analysis in GNAT,GNAT and Program Execution
-@anchor{gnat_ugn/gnat_and_program_execution id52}@anchor{150}@anchor{gnat_ugn/gnat_and_program_execution stack-related-facilities}@anchor{1ad}
+@anchor{gnat_ugn/gnat_and_program_execution id52}@anchor{150}@anchor{gnat_ugn/gnat_and_program_execution stack-related-facilities}@anchor{1ae}
@section Stack Related Facilities
@@ -22389,7 +22449,7 @@ particular, it deals with dynamic and static stack usage measurements.
@end menu
@node Stack Overflow Checking,Static Stack Usage Analysis,,Stack Related Facilities
-@anchor{gnat_ugn/gnat_and_program_execution id53}@anchor{1ae}@anchor{gnat_ugn/gnat_and_program_execution stack-overflow-checking}@anchor{e8}
+@anchor{gnat_ugn/gnat_and_program_execution id53}@anchor{1af}@anchor{gnat_ugn/gnat_and_program_execution stack-overflow-checking}@anchor{e8}
@subsection Stack Overflow Checking
@@ -22437,7 +22497,7 @@ When using the LLVM back end, this switch doesn’t perform full stack overflow
checking, but just checks for very large local dynamic allocations.
@node Static Stack Usage Analysis,Dynamic Stack Usage Analysis,Stack Overflow Checking,Stack Related Facilities
-@anchor{gnat_ugn/gnat_and_program_execution id54}@anchor{1af}@anchor{gnat_ugn/gnat_and_program_execution static-stack-usage-analysis}@anchor{e9}
+@anchor{gnat_ugn/gnat_and_program_execution id54}@anchor{1b0}@anchor{gnat_ugn/gnat_and_program_execution static-stack-usage-analysis}@anchor{e9}
@subsection Static Stack Usage Analysis
@@ -22489,7 +22549,7 @@ consistent with that in the file documented above.
This is not supported by the LLVM back end.
@node Dynamic Stack Usage Analysis,,Static Stack Usage Analysis,Stack Related Facilities
-@anchor{gnat_ugn/gnat_and_program_execution dynamic-stack-usage-analysis}@anchor{117}@anchor{gnat_ugn/gnat_and_program_execution id55}@anchor{1b0}
+@anchor{gnat_ugn/gnat_and_program_execution dynamic-stack-usage-analysis}@anchor{117}@anchor{gnat_ugn/gnat_and_program_execution id55}@anchor{1b1}
@subsection Dynamic Stack Usage Analysis
@@ -22573,8 +22633,8 @@ This is not suppored by the LLVM back end.
The package @code{GNAT.Task_Stack_Usage} provides facilities to get
stack-usage reports at run time. See its body for the details.
-@node Memory Management Issues,,Stack Related Facilities,GNAT and Program Execution
-@anchor{gnat_ugn/gnat_and_program_execution id56}@anchor{151}@anchor{gnat_ugn/gnat_and_program_execution memory-management-issues}@anchor{1b1}
+@node Memory Management Issues,Sanitizers for Ada,Stack Related Facilities,GNAT and Program Execution
+@anchor{gnat_ugn/gnat_and_program_execution id56}@anchor{151}@anchor{gnat_ugn/gnat_and_program_execution memory-management-issues}@anchor{1b2}
@section Memory Management Issues
@@ -22590,7 +22650,7 @@ incorrect uses of access values (including ‘dangling references’).
@end menu
@node Some Useful Memory Pools,The GNAT Debug Pool Facility,,Memory Management Issues
-@anchor{gnat_ugn/gnat_and_program_execution id57}@anchor{1b2}@anchor{gnat_ugn/gnat_and_program_execution some-useful-memory-pools}@anchor{1b3}
+@anchor{gnat_ugn/gnat_and_program_execution id57}@anchor{1b3}@anchor{gnat_ugn/gnat_and_program_execution some-useful-memory-pools}@anchor{1b4}
@subsection Some Useful Memory Pools
@@ -22672,7 +22732,7 @@ for T1'Storage_Size use 10_000;
@end quotation
@node The GNAT Debug Pool Facility,,Some Useful Memory Pools,Memory Management Issues
-@anchor{gnat_ugn/gnat_and_program_execution id58}@anchor{1b4}@anchor{gnat_ugn/gnat_and_program_execution the-gnat-debug-pool-facility}@anchor{1b5}
+@anchor{gnat_ugn/gnat_and_program_execution id58}@anchor{1b5}@anchor{gnat_ugn/gnat_and_program_execution the-gnat-debug-pool-facility}@anchor{1b6}
@subsection The GNAT Debug Pool Facility
@@ -22831,11 +22891,415 @@ Debug Pool info:
@end quotation
+@node Sanitizers for Ada,,Memory Management Issues,GNAT and Program Execution
+@anchor{gnat_ugn/gnat_and_program_execution id63}@anchor{152}@anchor{gnat_ugn/gnat_and_program_execution sanitizers-for-ada}@anchor{1b7}
+@section Sanitizers for Ada
+
+
+@geindex Sanitizers
+
+This section explains how to use sanitizers with Ada code. Sanitizers offer code
+instrumentation and run-time libraries that detect certain memory issues and
+undefined behaviors during execution. They provide dynamic analysis capabilities
+useful for debugging and testing.
+
+While many sanitizer capabilities overlap with Ada’s built-in runtime checks,
+they are particularly valuable for identifying issues that arise from unchecked
+features or low-level operations.
+
+@menu
+* AddressSanitizer::
+* UndefinedBehaviorSanitizer::
+* Sanitizers in mixed-language applications::
+
+@end menu
+
+@node AddressSanitizer,UndefinedBehaviorSanitizer,,Sanitizers for Ada
+@anchor{gnat_ugn/gnat_and_program_execution addresssanitizer}@anchor{1b8}@anchor{gnat_ugn/gnat_and_program_execution id64}@anchor{1b9}
+@subsection AddressSanitizer
+
+
+@geindex AddressSanitizer
+
+@geindex ASan
+
+@geindex -fsanitize=address
+
+AddressSanitizer (aka ASan) is a memory error detector activated with the
+@code{-fsanitize=address} switch. Note that many of the typical memory errors,
+such as use after free or buffer overflow, are detected by Ada’s @code{Access_Check}
+and @code{Index_Check}.
+
+It can detect the following types of problems:
+
+
+@itemize *
+
+@item
+Wrong memory overlay
+
+A memory overlay is a situation in which an object of one type is placed at the
+same memory location as a distinct object of a different type, thus overlaying
+one object over the other in memory. When there is an overflow because the
+objects do not overlap (like in the following example), the sanitizer can signal
+it.
+
+@quotation
+
+@example
+procedure Wrong_Size_Overlay is
+ type Block is array (Natural range <>) of Integer;
+
+ Block4 : aliased Block := (1 .. 4 => 4);
+ Block5 : Block (1 .. 5) with Address => Block4'Address;
+begin
+ Block5 (Block5'Last) := 5; -- Outside the object
+end Wrong_Size_Overlay;
+@end example
+@end quotation
+
+If the code is built with the @code{-fsanitize=address} and @code{-g} options,
+the following error is shown at execution time:
+
+@quotation
+
+@example
+...
+SUMMARY: AddressSanitizer: stack-buffer-overflow wrong_size_overlay.adb:7 in _ada_wrong_size_overlay
+...
+@end example
+@end quotation
+
+@item
+Buffer overflow
+
+Ada’s @code{Index_Check} detects buffer overflows caused by out-of-bounds array
+access. If run-time checks are disabled, the sanitizer can still detect such
+overflows at execution time the same way as it signalled the previous wrong
+memory overlay. Note that if both the Ada run-time checks and the sanitizer
+are enabled, the Ada run-time exception takes precedence.
+
+@quotation
+
+@example
+procedure Buffer_Overrun is
+ Size : constant := 100;
+ Buffer : array (1 .. Size) of Integer := (others => 0);
+ Wrong_Index : Integer := Size + 1 with Export;
+begin
+ -- Access outside the boundaries
+ Put_Line ("Value: " & Integer'Image (Buffer (Wrong_Index)));
+end Buffer_Overrun;
+@end example
+@end quotation
+
+@item
+Use after lifetime
+
+Ada’s @code{Accessibility_Check} helps prevent use-after-return and
+use-after-scope errors by enforcing lifetime rules. When these checks are
+bypassed using @code{Unchecked_Access}, sanitizers can still detect such
+violations during execution.
+
+@quotation
+
+@example
+with Ada.Text_IO; use Ada.Text_IO;
+
+procedure Use_After_Return is
+ type Integer_Access is access all Integer;
+ Ptr : Integer_Access;
+
+ procedure Inner;
+
+ procedure Inner is
+ Local : aliased Integer := 42;
+ begin
+ Ptr := Local'Unchecked_Access;
+ end Inner;
+
+begin
+ Inner;
+ -- Accessing Local after it has gone out of scope
+ Put_Line ("Value: " & Integer'Image (Ptr.all));
+end Use_After_Return;
+@end example
+@end quotation
+
+If the code is built with the @code{-fsanitize=address} and @code{-g}
+options, the following error is shown at execution time:
+
+@quotation
+
+@example
+...
+==1793927==ERROR: AddressSanitizer: stack-use-after-return on address 0xf6fa1a409060 at pc 0xb20b6cb6cac0 bp 0xffffcc89c8b0 sp 0xffffcc89c8c8
+READ of size 4 at 0xf6fa1a409060 thread T0
+ #0 0xb20b6cb6cabc in _ada_use_after_return use_after_return.adb:18
+ ...
+
+Address 0xf6fa1a409060 is located in stack of thread T0 at offset 32 in frame
+ #0 0xb20b6cb6c794 in use_after_return__inner use_after_return.adb:9
+
+ This frame has 1 object(s):
+ [32, 36) 'local' (line 10) <== Memory access at offset 32 is inside this variable
+SUMMARY: AddressSanitizer: stack-use-after-return use_after_return.adb:18 in _ada_use_after_return
+...
+@end example
+@end quotation
+
+@item
+Memory leak
+
+A memory leak happens when a program allocates memory from the heap but fails
+to release it after it is no longer needed and loses all references to it like
+in the following example.
+
+@quotation
+
+@example
+procedure Memory_Leak is
+ type Integer_Access is access Integer;
+
+ procedure Allocate is
+ Ptr : Integer_Access := new Integer'(42);
+ begin
+ null;
+ end Allocate;
+begin
+ -- Memory leak occurs in the following procedure
+ Allocate;
+end Memory_Leak;
+@end example
+@end quotation
+
+If the code is built with the @code{-fsanitize=address} and @code{-g}
+options, the following error is emitted at execution time showing the
+location of the offending allocation.
+
+@quotation
+
+@example
+==1810634==ERROR: LeakSanitizer: detected memory leaks
+
+Direct leak of 4 byte(s) in 1 object(s) allocated from:
+ #0 0xe3cbee4bb4a8 in __interceptor_malloc asan_malloc_linux.cpp:69
+ #1 0xc15bb25d0af8 in __gnat_malloc (memory_leak+0x10af8) (BuildId: f5914a6eac10824f81d512de50b514e7d5f733be)
+ #2 0xc15bb25c9060 in memory_leak__allocate memory_leak.adb:5
+ ...
+
+SUMMARY: AddressSanitizer: 4 byte(s) leaked in 1 allocation(s).
+@end example
+@end quotation
+@end itemize
+
+@node UndefinedBehaviorSanitizer,Sanitizers in mixed-language applications,AddressSanitizer,Sanitizers for Ada
+@anchor{gnat_ugn/gnat_and_program_execution id65}@anchor{1ba}@anchor{gnat_ugn/gnat_and_program_execution undefinedbehaviorsanitizer}@anchor{1bb}
+@subsection UndefinedBehaviorSanitizer
+
+
+@geindex UndefinedBehaviorSanitizer
+
+@geindex UBSan
+
+@geindex -fsanitize=undefined
+
+UndefinedBehaviorSanitizer (aka UBSan) modifies the program at compile-time to
+catch various kinds of undefined behavior during program execution.
+
+Different sanitize options (@code{-fsanitize=alignment,float-cast-overflow,signed-integer-overflow})
+detect the following types of problems:
+
+
+@itemize *
+
+@item
+Wrong alignment
+
+The @code{-fsanitize=alignment} flag (included also in
+@code{-fsanitize=undefined}) enables run-time checks for misaligned memory
+accesses, ensuring that objects are accessed at addresses that conform to the
+alignment constraints of their declared types. Violations may lead to crashes
+or performance penalties on certain architectures.
+
+In the following example:
+
+@quotation
+
+@example
+with Ada.Text_IO; use Ada.Text_IO;
+with System.Storage_Elements; use System.Storage_Elements;
+
+procedure Misaligned_Address is
+ type Aligned_Integer is new Integer with
+ Alignment => 4; -- Ensure 4-byte alignment
+
+ Reference : Aligned_Integer := 42; -- Properly aligned object
+
+ -- Create a misaligned object by modifying the address manually
+ Misaligned : Aligned_Integer with Address => Reference'Address + 1;
+
+begin
+ -- This causes undefined behavior or an alignment exception on strict architectures
+ Put_Line ("Misaligned Value: " & Aligned_Integer'Image (Misaligned));
+end Misaligned_Address;
+@end example
+@end quotation
+
+If the code is built with the @code{-fsanitize=alignment} and @code{-g}
+options, the following error is shown at execution time.
+
+@quotation
+
+@example
+misaligned_address.adb:15:51: runtime error: load of misaligned address 0xffffd836dd45 for type 'volatile misaligned_address__aligned_integer', which requires 4 byte alignment
+@end example
+@end quotation
+
+@item
+Signed integer overflow
+
+Ada performs range checks at runtime in arithmetic operation on signed integers
+to ensure the value is within the target type’s bounds. If this check is removed,
+the @code{-fsanitize=signed-integer-overflow} flag (included also in
+@code{-fsanitize=undefined}) enables run-time checks for signed integer
+overflows.
+
+In the following example:
+
+@quotation
+
+@example
+procedure Signed_Integer_Overflow is
+ type Small_Int is range -128 .. 127;
+ X, Y, Z : Small_Int with Export;
+begin
+ X := 100;
+ Y := 50;
+ -- This addition will exceed 127, causing an overflow
+ Z := X + Y;
+end Signed_Integer_Overflow;
+@end example
+@end quotation
+
+If the code is built with the @code{-fsanitize=signed-integer-overflow} and
+@code{-g} options, the following error is shown at execution time.
+
+@quotation
+
+@example
+signed_integer_overflow.adb:8:11: runtime error: signed integer overflow: 100 + 50 cannot be represented in type 'signed_integer_overflow__small_int'
+@end example
+@end quotation
+
+@item
+Float to integer overflow
+
+When converting a floating-point value to an integer type, Ada performs a range
+check at runtime to ensure the value is within the target type’s bounds. If this
+check is removed, the sanitizer can detect overflows in conversions from
+floating point to integer types.
+
+In the following code:
+
+@quotation
+
+@example
+procedure Float_Cast_Overflow is
+ Flt : Float := Float'Last with Export;
+ Int : Integer;
+begin
+ Int := Integer (Flt); -- Overflow
+end Float_Cast_Overflow;
+@end example
+@end quotation
+
+If the code is built with the @code{-fsanitize=float-cast-overflow} and
+@code{-g} options, the following error is shown at execution time.
+
+@quotation
+
+@example
+float_cast_overflow.adb:5:20: runtime error: 3.40282e+38 is outside the range of representable values of type 'integer'
+@end example
+@end quotation
+@end itemize
+
+@node Sanitizers in mixed-language applications,,UndefinedBehaviorSanitizer,Sanitizers for Ada
+@anchor{gnat_ugn/gnat_and_program_execution sanitizers-in-mixed-language-applications}@anchor{1bc}
+@subsection Sanitizers in mixed-language applications
+
+
+Most of the checks performed by sanitizers operate at a global level, which
+means they can detect issues even when they span across language boundaries.
+This applies notably to:
+
+
+@itemize *
+
+@item
+All checks performed by the AddressSanitizer: wrong memory overlays, buffer
+overflows, uses after lifetime, memory leaks. These checks apply globally,
+regardless of where the objects are allocated or defined, or where they are
+destroyed
+
+@item
+Wrong alignment checks performed by the UndefinedBehaviorSanitizer. It will
+check whether an object created in a given language is accessed in another
+with an incompatible alignment
+@end itemize
+
+An interesting case that highlights the benefit of global sanitization is a
+buffer overflow caused by a mismatch in language bindings. Consider the
+following C function, which allocates an array of 4 characters:
+
+@quotation
+
+@example
+char *get_str (void) @{
+ char *str = malloc (4 * sizeof (char));
+@}
+@end example
+@end quotation
+
+This function is then bound to Ada code, which incorrectly assumes the buffer
+is of size 5:
+
+@quotation
+
+@example
+type Buffer is array (1 .. 5) of Character;
+
+function Get_Str return access Buffer
+ with Import => True, Convention => C, External_Name => "get_str";
+
+Str : access Buffer := Get_Str;
+Ch : Character := S (S'Last); -- Detected by AddressSanitizer as erroneous
+@end example
+@end quotation
+
+On the Ada side, accessing @code{Str (5)} appears valid because the array type
+declares five elements. However, the actual memory allocated in C only holds
+four. This mismatch is not detectable by Ada run-time checks, because Ada has
+no visibility into how the memory was allocated.
+
+However, the AddressSanitizer will detect the heap buffer overflow at runtime,
+halting execution and providing a clear diagnostic:
+
+@quotation
+
+@example
+...
+SUMMARY: AddressSanitizer: heap-buffer-overflow buffer_overflow.adb:20 in _ada_buffer_overflow
+...
+@end example
+@end quotation
+
@c -- Non-breaking space in running text
@c -- E.g. Ada |nbsp| 95
@node Platform-Specific Information,Example of Binder Output File,GNAT and Program Execution,Top
-@anchor{gnat_ugn/platform_specific_information doc}@anchor{1b6}@anchor{gnat_ugn/platform_specific_information id1}@anchor{1b7}@anchor{gnat_ugn/platform_specific_information platform-specific-information}@anchor{e}
+@anchor{gnat_ugn/platform_specific_information doc}@anchor{1bd}@anchor{gnat_ugn/platform_specific_information id1}@anchor{1be}@anchor{gnat_ugn/platform_specific_information platform-specific-information}@anchor{e}
@chapter Platform-Specific Information
@@ -22853,7 +23317,7 @@ related to the GNAT implementation on specific Operating Systems.
@end menu
@node Run-Time Libraries,Specifying a Run-Time Library,,Platform-Specific Information
-@anchor{gnat_ugn/platform_specific_information id2}@anchor{1b8}@anchor{gnat_ugn/platform_specific_information run-time-libraries}@anchor{1b9}
+@anchor{gnat_ugn/platform_specific_information id2}@anchor{1bf}@anchor{gnat_ugn/platform_specific_information run-time-libraries}@anchor{1c0}
@section Run-Time Libraries
@@ -22914,7 +23378,7 @@ are supplied on various GNAT platforms.
@end menu
@node Summary of Run-Time Configurations,,,Run-Time Libraries
-@anchor{gnat_ugn/platform_specific_information id3}@anchor{1ba}@anchor{gnat_ugn/platform_specific_information summary-of-run-time-configurations}@anchor{1bb}
+@anchor{gnat_ugn/platform_specific_information id3}@anchor{1c1}@anchor{gnat_ugn/platform_specific_information summary-of-run-time-configurations}@anchor{1c2}
@subsection Summary of Run-Time Configurations
@@ -23014,7 +23478,7 @@ ZCX
@node Specifying a Run-Time Library,GNU/Linux Topics,Run-Time Libraries,Platform-Specific Information
-@anchor{gnat_ugn/platform_specific_information id4}@anchor{1bc}@anchor{gnat_ugn/platform_specific_information specifying-a-run-time-library}@anchor{1bd}
+@anchor{gnat_ugn/platform_specific_information id4}@anchor{1c3}@anchor{gnat_ugn/platform_specific_information specifying-a-run-time-library}@anchor{1c4}
@section Specifying a Run-Time Library
@@ -23107,7 +23571,7 @@ by using the @code{--RTS} switch, e.g., @code{--RTS=sjlj}
@geindex GNU/Linux
@node GNU/Linux Topics,Microsoft Windows Topics,Specifying a Run-Time Library,Platform-Specific Information
-@anchor{gnat_ugn/platform_specific_information gnu-linux-topics}@anchor{1be}@anchor{gnat_ugn/platform_specific_information id5}@anchor{1bf}
+@anchor{gnat_ugn/platform_specific_information gnu-linux-topics}@anchor{1c5}@anchor{gnat_ugn/platform_specific_information id5}@anchor{1c6}
@section GNU/Linux Topics
@@ -23122,7 +23586,7 @@ This section describes topics that are specific to GNU/Linux platforms.
@end menu
@node Required Packages on GNU/Linux,Position Independent Executable PIE Enabled by Default on Linux,,GNU/Linux Topics
-@anchor{gnat_ugn/platform_specific_information id6}@anchor{1c0}@anchor{gnat_ugn/platform_specific_information required-packages-on-gnu-linux}@anchor{1c1}
+@anchor{gnat_ugn/platform_specific_information id6}@anchor{1c7}@anchor{gnat_ugn/platform_specific_information required-packages-on-gnu-linux}@anchor{1c8}
@subsection Required Packages on GNU/Linux
@@ -23159,7 +23623,7 @@ Other GNU/Linux distributions might choose different name
for those packages.
@node Position Independent Executable PIE Enabled by Default on Linux,Choosing the Scheduling Policy with GNU/Linux,Required Packages on GNU/Linux,GNU/Linux Topics
-@anchor{gnat_ugn/platform_specific_information pie-enabled-by-default-on-linux}@anchor{1c2}@anchor{gnat_ugn/platform_specific_information position-independent-executable-pie-enabled-by-default-on-linux}@anchor{1c3}
+@anchor{gnat_ugn/platform_specific_information pie-enabled-by-default-on-linux}@anchor{1c9}@anchor{gnat_ugn/platform_specific_information position-independent-executable-pie-enabled-by-default-on-linux}@anchor{1ca}
@subsection Position Independent Executable (PIE) Enabled by Default on Linux
@@ -23207,9 +23671,9 @@ and linked with @code{-pie}).
@geindex SCHED_RR scheduling policy
@geindex SCHED_OTHER scheduling policy
-@anchor{gnat_ugn/platform_specific_information choosing-the-scheduling-policy-with-gnu-linux}@anchor{1c4}
+@anchor{gnat_ugn/platform_specific_information choosing-the-scheduling-policy-with-gnu-linux}@anchor{1cb}
@node Choosing the Scheduling Policy with GNU/Linux,A GNU/Linux Debug Quirk,Position Independent Executable PIE Enabled by Default on Linux,GNU/Linux Topics
-@anchor{gnat_ugn/platform_specific_information id7}@anchor{1c5}
+@anchor{gnat_ugn/platform_specific_information id7}@anchor{1cc}
@subsection Choosing the Scheduling Policy with GNU/Linux
@@ -23267,7 +23731,7 @@ but not on the host machine running the container, so check that you also
have sufficient priviledge for running the container image.
@node A GNU/Linux Debug Quirk,,Choosing the Scheduling Policy with GNU/Linux,GNU/Linux Topics
-@anchor{gnat_ugn/platform_specific_information a-gnu-linux-debug-quirk}@anchor{1c6}@anchor{gnat_ugn/platform_specific_information id8}@anchor{1c7}
+@anchor{gnat_ugn/platform_specific_information a-gnu-linux-debug-quirk}@anchor{1cd}@anchor{gnat_ugn/platform_specific_information id8}@anchor{1ce}
@subsection A GNU/Linux Debug Quirk
@@ -23287,7 +23751,7 @@ the symptoms most commonly observed.
@geindex Windows
@node Microsoft Windows Topics,Mac OS Topics,GNU/Linux Topics,Platform-Specific Information
-@anchor{gnat_ugn/platform_specific_information id9}@anchor{1c8}@anchor{gnat_ugn/platform_specific_information microsoft-windows-topics}@anchor{1c9}
+@anchor{gnat_ugn/platform_specific_information id9}@anchor{1cf}@anchor{gnat_ugn/platform_specific_information microsoft-windows-topics}@anchor{1d0}
@section Microsoft Windows Topics
@@ -23309,7 +23773,7 @@ platforms.
@end menu
@node Using GNAT on Windows,Using a network installation of GNAT,,Microsoft Windows Topics
-@anchor{gnat_ugn/platform_specific_information id10}@anchor{1ca}@anchor{gnat_ugn/platform_specific_information using-gnat-on-windows}@anchor{1cb}
+@anchor{gnat_ugn/platform_specific_information id10}@anchor{1d1}@anchor{gnat_ugn/platform_specific_information using-gnat-on-windows}@anchor{1d2}
@subsection Using GNAT on Windows
@@ -23388,7 +23852,7 @@ different GNAT products.
@end itemize
@node Using a network installation of GNAT,CONSOLE and WINDOWS subsystems,Using GNAT on Windows,Microsoft Windows Topics
-@anchor{gnat_ugn/platform_specific_information id11}@anchor{1cc}@anchor{gnat_ugn/platform_specific_information using-a-network-installation-of-gnat}@anchor{1cd}
+@anchor{gnat_ugn/platform_specific_information id11}@anchor{1d3}@anchor{gnat_ugn/platform_specific_information using-a-network-installation-of-gnat}@anchor{1d4}
@subsection Using a network installation of GNAT
@@ -23415,7 +23879,7 @@ transfer of large amounts of data across the network and will likely cause
a serious performance penalty.
@node CONSOLE and WINDOWS subsystems,Temporary Files,Using a network installation of GNAT,Microsoft Windows Topics
-@anchor{gnat_ugn/platform_specific_information console-and-windows-subsystems}@anchor{1ce}@anchor{gnat_ugn/platform_specific_information id12}@anchor{1cf}
+@anchor{gnat_ugn/platform_specific_information console-and-windows-subsystems}@anchor{1d5}@anchor{gnat_ugn/platform_specific_information id12}@anchor{1d6}
@subsection CONSOLE and WINDOWS subsystems
@@ -23440,7 +23904,7 @@ $ gnatmake winprog -largs -mwindows
@end quotation
@node Temporary Files,Disabling Command Line Argument Expansion,CONSOLE and WINDOWS subsystems,Microsoft Windows Topics
-@anchor{gnat_ugn/platform_specific_information id13}@anchor{1d0}@anchor{gnat_ugn/platform_specific_information temporary-files}@anchor{1d1}
+@anchor{gnat_ugn/platform_specific_information id13}@anchor{1d7}@anchor{gnat_ugn/platform_specific_information temporary-files}@anchor{1d8}
@subsection Temporary Files
@@ -23478,7 +23942,7 @@ environments where you may not have write access to some
directories.
@node Disabling Command Line Argument Expansion,Choosing the Scheduling Policy with Windows,Temporary Files,Microsoft Windows Topics
-@anchor{gnat_ugn/platform_specific_information disabling-command-line-argument-expansion}@anchor{1d2}
+@anchor{gnat_ugn/platform_specific_information disabling-command-line-argument-expansion}@anchor{1d9}
@subsection Disabling Command Line Argument Expansion
@@ -23549,7 +24013,7 @@ Ada.Command_Line.Argument (1) -> "'*.txt'"
@end example
@node Choosing the Scheduling Policy with Windows,Windows Socket Timeouts,Disabling Command Line Argument Expansion,Microsoft Windows Topics
-@anchor{gnat_ugn/platform_specific_information choosing-the-scheduling-policy-with-windows}@anchor{1d3}@anchor{gnat_ugn/platform_specific_information id14}@anchor{1d4}
+@anchor{gnat_ugn/platform_specific_information choosing-the-scheduling-policy-with-windows}@anchor{1da}@anchor{gnat_ugn/platform_specific_information id14}@anchor{1db}
@subsection Choosing the Scheduling Policy with Windows
@@ -23567,7 +24031,7 @@ in @code{system.ads}. For more information about Windows priorities, please
refer to Microsoft documentation.
@node Windows Socket Timeouts,Mixed-Language Programming on Windows,Choosing the Scheduling Policy with Windows,Microsoft Windows Topics
-@anchor{gnat_ugn/platform_specific_information windows-socket-timeouts}@anchor{1d5}
+@anchor{gnat_ugn/platform_specific_information windows-socket-timeouts}@anchor{1dc}
@subsection Windows Socket Timeouts
@@ -23615,7 +24079,7 @@ socket timeout shorter than 500 ms. If a socket timeout shorter than
operations.
@node Mixed-Language Programming on Windows,Windows Specific Add-Ons,Windows Socket Timeouts,Microsoft Windows Topics
-@anchor{gnat_ugn/platform_specific_information id15}@anchor{1d6}@anchor{gnat_ugn/platform_specific_information mixed-language-programming-on-windows}@anchor{1d7}
+@anchor{gnat_ugn/platform_specific_information id15}@anchor{1dd}@anchor{gnat_ugn/platform_specific_information mixed-language-programming-on-windows}@anchor{1de}
@subsection Mixed-Language Programming on Windows
@@ -23637,12 +24101,12 @@ to use the Microsoft tools for your C++ code, you have two choices:
You can encapsulate your C++ code in a DLL to be linked with your Ada
application. In this case, use the Microsoft or other environment to
build the DLL and use GNAT to build your executable
-(@ref{1d8,,Using DLLs with GNAT}).
+(@ref{1df,,Using DLLs with GNAT}).
@item
You can encapsulate your Ada code in a DLL to be linked with the
other part of your application. In this case, use GNAT to build the DLL
-(@ref{1d9,,Building DLLs with GNAT Project files}) and use the Microsoft
+(@ref{1e0,,Building DLLs with GNAT Project files}) and use the Microsoft
or other environment to build your executable.
@end itemize
@@ -23699,7 +24163,7 @@ native SEH support is used.
@end menu
@node Windows Calling Conventions,Introduction to Dynamic Link Libraries DLLs,,Mixed-Language Programming on Windows
-@anchor{gnat_ugn/platform_specific_information id16}@anchor{1da}@anchor{gnat_ugn/platform_specific_information windows-calling-conventions}@anchor{1db}
+@anchor{gnat_ugn/platform_specific_information id16}@anchor{1e1}@anchor{gnat_ugn/platform_specific_information windows-calling-conventions}@anchor{1e2}
@subsubsection Windows Calling Conventions
@@ -23744,7 +24208,7 @@ are available for Windows:
@end menu
@node C Calling Convention,Stdcall Calling Convention,,Windows Calling Conventions
-@anchor{gnat_ugn/platform_specific_information c-calling-convention}@anchor{1dc}@anchor{gnat_ugn/platform_specific_information id17}@anchor{1dd}
+@anchor{gnat_ugn/platform_specific_information c-calling-convention}@anchor{1e3}@anchor{gnat_ugn/platform_specific_information id17}@anchor{1e4}
@subsubsection @code{C} Calling Convention
@@ -23786,10 +24250,10 @@ the @code{External_Name} with a leading underscore.
When importing a variable defined in C, you should always use the @code{C}
calling convention unless the object containing the variable is part of a
DLL (in which case you should use the @code{Stdcall} calling
-convention, @ref{1de,,Stdcall Calling Convention}).
+convention, @ref{1e5,,Stdcall Calling Convention}).
@node Stdcall Calling Convention,Win32 Calling Convention,C Calling Convention,Windows Calling Conventions
-@anchor{gnat_ugn/platform_specific_information id18}@anchor{1df}@anchor{gnat_ugn/platform_specific_information stdcall-calling-convention}@anchor{1de}
+@anchor{gnat_ugn/platform_specific_information id18}@anchor{1e6}@anchor{gnat_ugn/platform_specific_information stdcall-calling-convention}@anchor{1e5}
@subsubsection @code{Stdcall} Calling Convention
@@ -23887,7 +24351,7 @@ Note that to ease building cross-platform bindings, this convention
will be handled as a @code{C} calling convention on non-Windows platforms.
@node Win32 Calling Convention,DLL Calling Convention,Stdcall Calling Convention,Windows Calling Conventions
-@anchor{gnat_ugn/platform_specific_information id19}@anchor{1e0}@anchor{gnat_ugn/platform_specific_information win32-calling-convention}@anchor{1e1}
+@anchor{gnat_ugn/platform_specific_information id19}@anchor{1e7}@anchor{gnat_ugn/platform_specific_information win32-calling-convention}@anchor{1e8}
@subsubsection @code{Win32} Calling Convention
@@ -23895,7 +24359,7 @@ This convention, which is GNAT-specific, is fully equivalent to the
@code{Stdcall} calling convention described above.
@node DLL Calling Convention,,Win32 Calling Convention,Windows Calling Conventions
-@anchor{gnat_ugn/platform_specific_information dll-calling-convention}@anchor{1e2}@anchor{gnat_ugn/platform_specific_information id20}@anchor{1e3}
+@anchor{gnat_ugn/platform_specific_information dll-calling-convention}@anchor{1e9}@anchor{gnat_ugn/platform_specific_information id20}@anchor{1ea}
@subsubsection @code{DLL} Calling Convention
@@ -23903,7 +24367,7 @@ This convention, which is GNAT-specific, is fully equivalent to the
@code{Stdcall} calling convention described above.
@node Introduction to Dynamic Link Libraries DLLs,Using DLLs with GNAT,Windows Calling Conventions,Mixed-Language Programming on Windows
-@anchor{gnat_ugn/platform_specific_information id21}@anchor{1e4}@anchor{gnat_ugn/platform_specific_information introduction-to-dynamic-link-libraries-dlls}@anchor{1e5}
+@anchor{gnat_ugn/platform_specific_information id21}@anchor{1eb}@anchor{gnat_ugn/platform_specific_information introduction-to-dynamic-link-libraries-dlls}@anchor{1ec}
@subsubsection Introduction to Dynamic Link Libraries (DLLs)
@@ -23987,10 +24451,10 @@ As a side note, an interesting difference between Microsoft DLLs and
Unix shared libraries is the fact that on most Unix systems all public
routines are exported by default in a Unix shared library, while under
Windows it is possible (but not required) to list exported routines in
-a definition file (see @ref{1e6,,The Definition File}).
+a definition file (see @ref{1ed,,The Definition File}).
@node Using DLLs with GNAT,Building DLLs with GNAT Project files,Introduction to Dynamic Link Libraries DLLs,Mixed-Language Programming on Windows
-@anchor{gnat_ugn/platform_specific_information id22}@anchor{1e7}@anchor{gnat_ugn/platform_specific_information using-dlls-with-gnat}@anchor{1d8}
+@anchor{gnat_ugn/platform_specific_information id22}@anchor{1ee}@anchor{gnat_ugn/platform_specific_information using-dlls-with-gnat}@anchor{1df}
@subsubsection Using DLLs with GNAT
@@ -24081,7 +24545,7 @@ example a fictitious DLL called @code{API.dll}.
@end menu
@node Creating an Ada Spec for the DLL Services,Creating an Import Library,,Using DLLs with GNAT
-@anchor{gnat_ugn/platform_specific_information creating-an-ada-spec-for-the-dll-services}@anchor{1e8}@anchor{gnat_ugn/platform_specific_information id23}@anchor{1e9}
+@anchor{gnat_ugn/platform_specific_information creating-an-ada-spec-for-the-dll-services}@anchor{1ef}@anchor{gnat_ugn/platform_specific_information id23}@anchor{1f0}
@subsubsection Creating an Ada Spec for the DLL Services
@@ -24121,7 +24585,7 @@ end API;
@end quotation
@node Creating an Import Library,,Creating an Ada Spec for the DLL Services,Using DLLs with GNAT
-@anchor{gnat_ugn/platform_specific_information creating-an-import-library}@anchor{1ea}@anchor{gnat_ugn/platform_specific_information id24}@anchor{1eb}
+@anchor{gnat_ugn/platform_specific_information creating-an-import-library}@anchor{1f1}@anchor{gnat_ugn/platform_specific_information id24}@anchor{1f2}
@subsubsection Creating an Import Library
@@ -24135,7 +24599,7 @@ as in this case it is possible to link directly against the
DLL. Otherwise read on.
@geindex Definition file
-@anchor{gnat_ugn/platform_specific_information the-definition-file}@anchor{1e6}
+@anchor{gnat_ugn/platform_specific_information the-definition-file}@anchor{1ed}
@subsubheading The Definition File
@@ -24183,17 +24647,17 @@ EXPORTS
@end table
Note that you must specify the correct suffix (@code{@@@var{nn}})
-(see @ref{1db,,Windows Calling Conventions}) for a Stdcall
+(see @ref{1e2,,Windows Calling Conventions}) for a Stdcall
calling convention function in the exported symbols list.
There can actually be other sections in a definition file, but these
sections are not relevant to the discussion at hand.
-@anchor{gnat_ugn/platform_specific_information create-def-file-automatically}@anchor{1ec}
+@anchor{gnat_ugn/platform_specific_information create-def-file-automatically}@anchor{1f3}
@subsubheading Creating a Definition File Automatically
You can automatically create the definition file @code{API.def}
-(see @ref{1e6,,The Definition File}) from a DLL.
+(see @ref{1ed,,The Definition File}) from a DLL.
To do that, use the @code{dlltool} program as follows:
@quotation
@@ -24203,7 +24667,7 @@ $ dlltool API.dll -z API.def --export-all-symbols
@end example
Note that if some routines in the DLL have the @code{Stdcall} convention
-(@ref{1db,,Windows Calling Conventions}) with stripped @code{@@@var{nn}}
+(@ref{1e2,,Windows Calling Conventions}) with stripped @code{@@@var{nn}}
suffix then you’ll have to edit @code{api.def} to add it and specify
@code{-k} to @code{gnatdll} when creating the import library.
@@ -24228,13 +24692,13 @@ tells you what symbol is expected. You then can go back to the
definition file and add the right suffix.
@end itemize
@end quotation
-@anchor{gnat_ugn/platform_specific_information gnat-style-import-library}@anchor{1ed}
+@anchor{gnat_ugn/platform_specific_information gnat-style-import-library}@anchor{1f4}
@subsubheading GNAT-Style Import Library
To create a static import library from @code{API.dll} with the GNAT tools,
you should create the @code{.def} file and use the @code{gnatdll} tool
-(see @ref{1ee,,Using gnatdll}) as follows:
+(see @ref{1f5,,Using gnatdll}) as follows:
@quotation
@@ -24250,15 +24714,15 @@ definition file name is @code{xyz.def}, the import library name will
be @code{libxyz.a}. Note that in the previous example, the switch
@code{-e} could have been removed because the name of the definition
file (before the @code{.def} suffix) is the same as the name of the
-DLL (@ref{1ee,,Using gnatdll} for more information about @code{gnatdll}).
+DLL (@ref{1f5,,Using gnatdll} for more information about @code{gnatdll}).
@end quotation
-@anchor{gnat_ugn/platform_specific_information msvs-style-import-library}@anchor{1ef}
+@anchor{gnat_ugn/platform_specific_information msvs-style-import-library}@anchor{1f6}
@subsubheading Microsoft-Style Import Library
A Microsoft import library is needed only if you plan to make an
Ada DLL available to applications developed with Microsoft
-tools (@ref{1d7,,Mixed-Language Programming on Windows}).
+tools (@ref{1de,,Mixed-Language Programming on Windows}).
To create a Microsoft-style import library for @code{API.dll} you
should create the @code{.def} file, then build the actual import library using
@@ -24282,7 +24746,7 @@ See the Microsoft documentation for further details about the usage of
@end quotation
@node Building DLLs with GNAT Project files,Building DLLs with GNAT,Using DLLs with GNAT,Mixed-Language Programming on Windows
-@anchor{gnat_ugn/platform_specific_information building-dlls-with-gnat-project-files}@anchor{1d9}@anchor{gnat_ugn/platform_specific_information id25}@anchor{1f0}
+@anchor{gnat_ugn/platform_specific_information building-dlls-with-gnat-project-files}@anchor{1e0}@anchor{gnat_ugn/platform_specific_information id25}@anchor{1f7}
@subsubsection Building DLLs with GNAT Project files
@@ -24298,7 +24762,7 @@ when inside the @code{DllMain} routine which is used for auto-initialization
of shared libraries, so you can’t have library level tasks in SALs.
@node Building DLLs with GNAT,Building DLLs with gnatdll,Building DLLs with GNAT Project files,Mixed-Language Programming on Windows
-@anchor{gnat_ugn/platform_specific_information building-dlls-with-gnat}@anchor{1f1}@anchor{gnat_ugn/platform_specific_information id26}@anchor{1f2}
+@anchor{gnat_ugn/platform_specific_information building-dlls-with-gnat}@anchor{1f8}@anchor{gnat_ugn/platform_specific_information id26}@anchor{1f9}
@subsubsection Building DLLs with GNAT
@@ -24329,7 +24793,7 @@ $ gcc -shared -shared-libgcc -o api.dll obj1.o obj2.o ...
It’s important to note that in this case all symbols found in the
object files are automatically exported. You can restrict
the set of symbols to export by passing to @code{gcc} a definition
-file (see @ref{1e6,,The Definition File}).
+file (see @ref{1ed,,The Definition File}).
For example:
@example
@@ -24367,7 +24831,7 @@ $ gnatmake main -Iapilib -bargs -shared -largs -Lapilib -lAPI
@end quotation
@node Building DLLs with gnatdll,Ada DLLs and Finalization,Building DLLs with GNAT,Mixed-Language Programming on Windows
-@anchor{gnat_ugn/platform_specific_information building-dlls-with-gnatdll}@anchor{1f3}@anchor{gnat_ugn/platform_specific_information id27}@anchor{1f4}
+@anchor{gnat_ugn/platform_specific_information building-dlls-with-gnatdll}@anchor{1fa}@anchor{gnat_ugn/platform_specific_information id27}@anchor{1fb}
@subsubsection Building DLLs with gnatdll
@@ -24375,8 +24839,8 @@ $ gnatmake main -Iapilib -bargs -shared -largs -Lapilib -lAPI
@geindex building
Note that it is preferred to use GNAT Project files
-(@ref{1d9,,Building DLLs with GNAT Project files}) or the built-in GNAT
-DLL support (@ref{1f1,,Building DLLs with GNAT}) to build DLLs.
+(@ref{1e0,,Building DLLs with GNAT Project files}) or the built-in GNAT
+DLL support (@ref{1f8,,Building DLLs with GNAT}) to build DLLs.
This section explains how to build DLLs containing Ada code using
@code{gnatdll}. These DLLs will be referred to as Ada DLLs in the
@@ -24392,20 +24856,20 @@ non-Ada applications are as follows:
You need to mark each Ada entity exported by the DLL with a @code{C} or
@code{Stdcall} calling convention to avoid any Ada name mangling for the
entities exported by the DLL
-(see @ref{1f5,,Exporting Ada Entities}). You can
+(see @ref{1fc,,Exporting Ada Entities}). You can
skip this step if you plan to use the Ada DLL only from Ada applications.
@item
Your Ada code must export an initialization routine which calls the routine
@code{adainit} (generated by @code{gnatbind}) to perform the elaboration of
-the Ada code in the DLL (@ref{1f6,,Ada DLLs and Elaboration}). The initialization
+the Ada code in the DLL (@ref{1fd,,Ada DLLs and Elaboration}). The initialization
routine exported by the Ada DLL must be invoked by the clients of the DLL
to initialize the DLL.
@item
When useful, the DLL should also export a finalization routine which calls
routine @code{adafinal} (also generated by @code{gnatbind}) to perform the
-finalization of the Ada code in the DLL (@ref{1f7,,Ada DLLs and Finalization}).
+finalization of the Ada code in the DLL (@ref{1fe,,Ada DLLs and Finalization}).
The finalization routine exported by the Ada DLL must be invoked by the
clients of the DLL when the DLL services are no further needed.
@@ -24415,11 +24879,11 @@ of the programming languages to which you plan to make the DLL available.
@item
You must provide a definition file listing the exported entities
-(@ref{1e6,,The Definition File}).
+(@ref{1ed,,The Definition File}).
@item
Finally, you must use @code{gnatdll} to produce the DLL and the import
-library (@ref{1ee,,Using gnatdll}).
+library (@ref{1f5,,Using gnatdll}).
@end itemize
Note that a relocatable DLL stripped using the @code{strip}
@@ -24439,7 +24903,7 @@ chapter of the `GPRbuild User’s Guide'.
@end menu
@node Limitations When Using Ada DLLs from Ada,Exporting Ada Entities,,Building DLLs with gnatdll
-@anchor{gnat_ugn/platform_specific_information limitations-when-using-ada-dlls-from-ada}@anchor{1f8}
+@anchor{gnat_ugn/platform_specific_information limitations-when-using-ada-dlls-from-ada}@anchor{1ff}
@subsubsection Limitations When Using Ada DLLs from Ada
@@ -24460,7 +24924,7 @@ It is completely safe to exchange plain elementary, array or record types,
Windows object handles, etc.
@node Exporting Ada Entities,Ada DLLs and Elaboration,Limitations When Using Ada DLLs from Ada,Building DLLs with gnatdll
-@anchor{gnat_ugn/platform_specific_information exporting-ada-entities}@anchor{1f5}@anchor{gnat_ugn/platform_specific_information id28}@anchor{1f9}
+@anchor{gnat_ugn/platform_specific_information exporting-ada-entities}@anchor{1fc}@anchor{gnat_ugn/platform_specific_information id28}@anchor{200}
@subsubsection Exporting Ada Entities
@@ -24560,10 +25024,10 @@ end API;
Note that if you do not export the Ada entities with a @code{C} or
@code{Stdcall} convention, you will have to provide the mangled Ada names
in the definition file of the Ada DLL
-(@ref{1fa,,Creating the Definition File}).
+(@ref{201,,Creating the Definition File}).
@node Ada DLLs and Elaboration,,Exporting Ada Entities,Building DLLs with gnatdll
-@anchor{gnat_ugn/platform_specific_information ada-dlls-and-elaboration}@anchor{1f6}@anchor{gnat_ugn/platform_specific_information id29}@anchor{1fb}
+@anchor{gnat_ugn/platform_specific_information ada-dlls-and-elaboration}@anchor{1fd}@anchor{gnat_ugn/platform_specific_information id29}@anchor{202}
@subsubsection Ada DLLs and Elaboration
@@ -24581,7 +25045,7 @@ the Ada elaboration routine @code{adainit} generated by the GNAT binder
(@ref{7f,,Binding with Non-Ada Main Programs}). See the body of
@code{Initialize_Api} for an example. Note that the GNAT binder is
automatically invoked during the DLL build process by the @code{gnatdll}
-tool (@ref{1ee,,Using gnatdll}).
+tool (@ref{1f5,,Using gnatdll}).
When a DLL is loaded, Windows systematically invokes a routine called
@code{DllMain}. It should therefore be possible to call @code{adainit}
@@ -24594,7 +25058,7 @@ time), which means that the GNAT run-time will deadlock waiting for a
newly created task to complete its initialization.
@node Ada DLLs and Finalization,Creating a Spec for Ada DLLs,Building DLLs with gnatdll,Mixed-Language Programming on Windows
-@anchor{gnat_ugn/platform_specific_information ada-dlls-and-finalization}@anchor{1f7}@anchor{gnat_ugn/platform_specific_information id30}@anchor{1fc}
+@anchor{gnat_ugn/platform_specific_information ada-dlls-and-finalization}@anchor{1fe}@anchor{gnat_ugn/platform_specific_information id30}@anchor{203}
@subsubsection Ada DLLs and Finalization
@@ -24609,10 +25073,10 @@ routine @code{adafinal} generated by the GNAT binder
See the body of @code{Finalize_Api} for an
example. As already pointed out the GNAT binder is automatically invoked
during the DLL build process by the @code{gnatdll} tool
-(@ref{1ee,,Using gnatdll}).
+(@ref{1f5,,Using gnatdll}).
@node Creating a Spec for Ada DLLs,GNAT and Windows Resources,Ada DLLs and Finalization,Mixed-Language Programming on Windows
-@anchor{gnat_ugn/platform_specific_information creating-a-spec-for-ada-dlls}@anchor{1fd}@anchor{gnat_ugn/platform_specific_information id31}@anchor{1fe}
+@anchor{gnat_ugn/platform_specific_information creating-a-spec-for-ada-dlls}@anchor{204}@anchor{gnat_ugn/platform_specific_information id31}@anchor{205}
@subsubsection Creating a Spec for Ada DLLs
@@ -24670,7 +25134,7 @@ end API;
@end menu
@node Creating the Definition File,Using gnatdll,,Creating a Spec for Ada DLLs
-@anchor{gnat_ugn/platform_specific_information creating-the-definition-file}@anchor{1fa}@anchor{gnat_ugn/platform_specific_information id32}@anchor{1ff}
+@anchor{gnat_ugn/platform_specific_information creating-the-definition-file}@anchor{201}@anchor{gnat_ugn/platform_specific_information id32}@anchor{206}
@subsubsection Creating the Definition File
@@ -24706,7 +25170,7 @@ EXPORTS
@end quotation
@node Using gnatdll,,Creating the Definition File,Creating a Spec for Ada DLLs
-@anchor{gnat_ugn/platform_specific_information id33}@anchor{200}@anchor{gnat_ugn/platform_specific_information using-gnatdll}@anchor{1ee}
+@anchor{gnat_ugn/platform_specific_information id33}@anchor{207}@anchor{gnat_ugn/platform_specific_information using-gnatdll}@anchor{1f5}
@subsubsection Using @code{gnatdll}
@@ -24910,7 +25374,7 @@ asks @code{gnatlink} to generate the routines @code{DllMain} and
is loaded into memory.
@item
-uses @code{dlltool} (see @ref{201,,Using dlltool}) to build the
+uses @code{dlltool} (see @ref{208,,Using dlltool}) to build the
export table (@code{api.exp}). The export table contains the relocation
information in a form which can be used during the final link to ensure
that the Windows loader is able to place the DLL anywhere in memory.
@@ -24948,7 +25412,7 @@ $ gnatbind -n api
$ gnatlink api api.exp -o api.dll -mdll
@end example
@end itemize
-@anchor{gnat_ugn/platform_specific_information using-dlltool}@anchor{201}
+@anchor{gnat_ugn/platform_specific_information using-dlltool}@anchor{208}
@subsubheading Using @code{dlltool}
@@ -25006,7 +25470,7 @@ DLL in the static import library generated by @code{dlltool} with switch
@item @code{-k}
Kill @code{@@@var{nn}} from exported names
-(@ref{1db,,Windows Calling Conventions}
+(@ref{1e2,,Windows Calling Conventions}
for a discussion about @code{Stdcall}-style symbols).
@end table
@@ -25062,7 +25526,7 @@ Use @code{assembler-name} as the assembler. The default is @code{as}.
@end table
@node GNAT and Windows Resources,Using GNAT DLLs from Microsoft Visual Studio Applications,Creating a Spec for Ada DLLs,Mixed-Language Programming on Windows
-@anchor{gnat_ugn/platform_specific_information gnat-and-windows-resources}@anchor{202}@anchor{gnat_ugn/platform_specific_information id34}@anchor{203}
+@anchor{gnat_ugn/platform_specific_information gnat-and-windows-resources}@anchor{209}@anchor{gnat_ugn/platform_specific_information id34}@anchor{20a}
@subsubsection GNAT and Windows Resources
@@ -25154,7 +25618,7 @@ the corresponding Microsoft documentation.
@end menu
@node Building Resources,Compiling Resources,,GNAT and Windows Resources
-@anchor{gnat_ugn/platform_specific_information building-resources}@anchor{204}@anchor{gnat_ugn/platform_specific_information id35}@anchor{205}
+@anchor{gnat_ugn/platform_specific_information building-resources}@anchor{20b}@anchor{gnat_ugn/platform_specific_information id35}@anchor{20c}
@subsubsection Building Resources
@@ -25174,7 +25638,7 @@ complete description of the resource script language can be found in
the Microsoft documentation.
@node Compiling Resources,Using Resources,Building Resources,GNAT and Windows Resources
-@anchor{gnat_ugn/platform_specific_information compiling-resources}@anchor{206}@anchor{gnat_ugn/platform_specific_information id36}@anchor{207}
+@anchor{gnat_ugn/platform_specific_information compiling-resources}@anchor{20d}@anchor{gnat_ugn/platform_specific_information id36}@anchor{20e}
@subsubsection Compiling Resources
@@ -25216,7 +25680,7 @@ $ windres -i myres.res -o myres.o
@end quotation
@node Using Resources,,Compiling Resources,GNAT and Windows Resources
-@anchor{gnat_ugn/platform_specific_information id37}@anchor{208}@anchor{gnat_ugn/platform_specific_information using-resources}@anchor{209}
+@anchor{gnat_ugn/platform_specific_information id37}@anchor{20f}@anchor{gnat_ugn/platform_specific_information using-resources}@anchor{210}
@subsubsection Using Resources
@@ -25236,7 +25700,7 @@ $ gnatmake myprog -largs myres.o
@end quotation
@node Using GNAT DLLs from Microsoft Visual Studio Applications,Debugging a DLL,GNAT and Windows Resources,Mixed-Language Programming on Windows
-@anchor{gnat_ugn/platform_specific_information using-gnat-dll-from-msvs}@anchor{20a}@anchor{gnat_ugn/platform_specific_information using-gnat-dlls-from-microsoft-visual-studio-applications}@anchor{20b}
+@anchor{gnat_ugn/platform_specific_information using-gnat-dll-from-msvs}@anchor{211}@anchor{gnat_ugn/platform_specific_information using-gnat-dlls-from-microsoft-visual-studio-applications}@anchor{212}
@subsubsection Using GNAT DLLs from Microsoft Visual Studio Applications
@@ -25271,7 +25735,7 @@ $ gprbuild -p mylib.gpr
@item
Produce a @code{.def} file for the symbols you need to interface
with, either by hand or automatically with possibly some manual
-adjustments (see @ref{1ec,,Creating Definition File Automatically}):
+adjustments (see @ref{1f3,,Creating Definition File Automatically}):
@end enumerate
@quotation
@@ -25288,7 +25752,7 @@ $ dlltool libmylib.dll -z libmylib.def --export-all-symbols
Make sure that MSVS command-line tools are accessible on the path.
@item
-Create the Microsoft-style import library (see @ref{1ef,,MSVS-Style Import Library}):
+Create the Microsoft-style import library (see @ref{1f6,,MSVS-Style Import Library}):
@end enumerate
@quotation
@@ -25331,7 +25795,7 @@ the @code{.exe}.
@end enumerate
@node Debugging a DLL,Setting Stack Size from gnatlink,Using GNAT DLLs from Microsoft Visual Studio Applications,Mixed-Language Programming on Windows
-@anchor{gnat_ugn/platform_specific_information debugging-a-dll}@anchor{20c}@anchor{gnat_ugn/platform_specific_information id38}@anchor{20d}
+@anchor{gnat_ugn/platform_specific_information debugging-a-dll}@anchor{213}@anchor{gnat_ugn/platform_specific_information id38}@anchor{214}
@subsubsection Debugging a DLL
@@ -25368,7 +25832,7 @@ debugger compatible with the tools suite used to build the DLL.
@end menu
@node Program and DLL Both Built with GCC/GNAT,Program Built with Foreign Tools and DLL Built with GCC/GNAT,,Debugging a DLL
-@anchor{gnat_ugn/platform_specific_information id39}@anchor{20e}@anchor{gnat_ugn/platform_specific_information program-and-dll-both-built-with-gcc-gnat}@anchor{20f}
+@anchor{gnat_ugn/platform_specific_information id39}@anchor{215}@anchor{gnat_ugn/platform_specific_information program-and-dll-both-built-with-gcc-gnat}@anchor{216}
@subsubsection Program and DLL Both Built with GCC/GNAT
@@ -25378,7 +25842,7 @@ the process. Let’s suppose the main procedure is named
@code{ada_main} and in the DLL there’s an entry point named
@code{ada_dll}.
-The DLL (@ref{1e5,,Introduction to Dynamic Link Libraries (DLLs)}) and
+The DLL (@ref{1ec,,Introduction to Dynamic Link Libraries (DLLs)}) and
program must have been built with the debugging information (see the GNAT
@code{-g} switch). Here are the step-by-step instructions for debugging it:
@@ -25415,10 +25879,10 @@ Set a breakpoint inside the DLL
At this stage, a breakpoint is set inside the DLL. From there on
you can use standard @code{GDB} commands to debug the whole program
-(@ref{152,,Running and Debugging Ada Programs}).
+(@ref{153,,Running and Debugging Ada Programs}).
@node Program Built with Foreign Tools and DLL Built with GCC/GNAT,,Program and DLL Both Built with GCC/GNAT,Debugging a DLL
-@anchor{gnat_ugn/platform_specific_information id40}@anchor{210}@anchor{gnat_ugn/platform_specific_information program-built-with-foreign-tools-and-dll-built-with-gcc-gnat}@anchor{211}
+@anchor{gnat_ugn/platform_specific_information id40}@anchor{217}@anchor{gnat_ugn/platform_specific_information program-built-with-foreign-tools-and-dll-built-with-gcc-gnat}@anchor{218}
@subsubsection Program Built with Foreign Tools and DLL Built with GCC/GNAT
@@ -25435,7 +25899,7 @@ case, for example, for some C code built with Microsoft Visual C) and that
there’s a DLL named @code{test.dll} containing an Ada entry point named
@code{ada_dll}.
-The DLL (see @ref{1e5,,Introduction to Dynamic Link Libraries (DLLs)}) must have
+The DLL (see @ref{1ec,,Introduction to Dynamic Link Libraries (DLLs)}) must have
been built with debugging information (see the GNAT @code{-g} switch).
@subsubheading Debugging the DLL Directly
@@ -25502,7 +25966,7 @@ Continue the program.
This runs the program until it reaches the breakpoint that you’ve
set. From that point, you can use standard @code{GDB} commands to debug
a program as described in
-(@ref{152,,Running and Debugging Ada Programs}).
+(@ref{153,,Running and Debugging Ada Programs}).
@end itemize
You can also debug the DLL by attaching @code{GDB} to a running process.
@@ -25572,21 +26036,22 @@ Continue process execution.
This last step will resume the process execution and stop at
the breakpoint we have set. From there you can use standard
@code{GDB} commands to debug a program, as described in
-@ref{152,,Running and Debugging Ada Programs}.
+@ref{153,,Running and Debugging Ada Programs}.
@node Setting Stack Size from gnatlink,Setting Heap Size from gnatlink,Debugging a DLL,Mixed-Language Programming on Windows
-@anchor{gnat_ugn/platform_specific_information id41}@anchor{212}@anchor{gnat_ugn/platform_specific_information setting-stack-size-from-gnatlink}@anchor{12b}
+@anchor{gnat_ugn/platform_specific_information id41}@anchor{219}@anchor{gnat_ugn/platform_specific_information setting-stack-size-from-gnatlink}@anchor{12b}
@subsubsection Setting Stack Size from @code{gnatlink}
You can specify the program stack size at link time. On most versions
of Windows, starting with XP, this is mostly useful to set the size of
the main stack (environment task). The other task stacks are set with
-pragma Storage_Size or with the `gnatbind -d' command.
+pragma Storage_Size or with the `gnatbind -d' command. The specified size will
+become the reserved memory size of the underlying thread.
Since very old versions of Windows (2000, NT4, etc.) don’t allow setting the
-reserve size of individual tasks, the link-time stack size applies to all
-tasks, and pragma Storage_Size has no effect.
+reserve size of individual tasks, for those versions the link-time stack size
+applies to all tasks, and pragma Storage_Size has no effect.
In particular, Stack Overflow checks are made against this
link-time specified size.
@@ -25618,7 +26083,7 @@ because the comma is a separator for this switch.
@end itemize
@node Setting Heap Size from gnatlink,,Setting Stack Size from gnatlink,Mixed-Language Programming on Windows
-@anchor{gnat_ugn/platform_specific_information id42}@anchor{213}@anchor{gnat_ugn/platform_specific_information setting-heap-size-from-gnatlink}@anchor{12c}
+@anchor{gnat_ugn/platform_specific_information id42}@anchor{21a}@anchor{gnat_ugn/platform_specific_information setting-heap-size-from-gnatlink}@anchor{12c}
@subsubsection Setting Heap Size from @code{gnatlink}
@@ -25651,7 +26116,7 @@ because the comma is a separator for this switch.
@end itemize
@node Windows Specific Add-Ons,,Mixed-Language Programming on Windows,Microsoft Windows Topics
-@anchor{gnat_ugn/platform_specific_information win32-specific-addons}@anchor{214}@anchor{gnat_ugn/platform_specific_information windows-specific-add-ons}@anchor{215}
+@anchor{gnat_ugn/platform_specific_information win32-specific-addons}@anchor{21b}@anchor{gnat_ugn/platform_specific_information windows-specific-add-ons}@anchor{21c}
@subsection Windows Specific Add-Ons
@@ -25664,7 +26129,7 @@ This section describes the Windows specific add-ons.
@end menu
@node Win32Ada,wPOSIX,,Windows Specific Add-Ons
-@anchor{gnat_ugn/platform_specific_information id43}@anchor{216}@anchor{gnat_ugn/platform_specific_information win32ada}@anchor{217}
+@anchor{gnat_ugn/platform_specific_information id43}@anchor{21d}@anchor{gnat_ugn/platform_specific_information win32ada}@anchor{21e}
@subsubsection Win32Ada
@@ -25695,7 +26160,7 @@ gprbuild p.gpr
@end quotation
@node wPOSIX,,Win32Ada,Windows Specific Add-Ons
-@anchor{gnat_ugn/platform_specific_information id44}@anchor{218}@anchor{gnat_ugn/platform_specific_information wposix}@anchor{219}
+@anchor{gnat_ugn/platform_specific_information id44}@anchor{21f}@anchor{gnat_ugn/platform_specific_information wposix}@anchor{220}
@subsubsection wPOSIX
@@ -25728,7 +26193,7 @@ gprbuild p.gpr
@end quotation
@node Mac OS Topics,,Microsoft Windows Topics,Platform-Specific Information
-@anchor{gnat_ugn/platform_specific_information id45}@anchor{21a}@anchor{gnat_ugn/platform_specific_information mac-os-topics}@anchor{21b}
+@anchor{gnat_ugn/platform_specific_information id45}@anchor{221}@anchor{gnat_ugn/platform_specific_information mac-os-topics}@anchor{222}
@section Mac OS Topics
@@ -25743,7 +26208,7 @@ platform.
@end menu
@node Codesigning the Debugger,,,Mac OS Topics
-@anchor{gnat_ugn/platform_specific_information codesigning-the-debugger}@anchor{21c}
+@anchor{gnat_ugn/platform_specific_information codesigning-the-debugger}@anchor{223}
@subsection Codesigning the Debugger
@@ -25825,7 +26290,7 @@ installed GNAT. Also, be sure that users of @code{GDB} are in the Unix
group @code{_developer}.
@node Example of Binder Output File,Elaboration Order Handling in GNAT,Platform-Specific Information,Top
-@anchor{gnat_ugn/example_of_binder_output doc}@anchor{21d}@anchor{gnat_ugn/example_of_binder_output example-of-binder-output-file}@anchor{f}@anchor{gnat_ugn/example_of_binder_output id1}@anchor{21e}
+@anchor{gnat_ugn/example_of_binder_output doc}@anchor{224}@anchor{gnat_ugn/example_of_binder_output example-of-binder-output-file}@anchor{f}@anchor{gnat_ugn/example_of_binder_output id1}@anchor{225}
@chapter Example of Binder Output File
@@ -26575,7 +27040,7 @@ elaboration code in your own application).
@c -- Example: A |withing| unit has a |with| clause, it |withs| a |withed| unit
@node Elaboration Order Handling in GNAT,Inline Assembler,Example of Binder Output File,Top
-@anchor{gnat_ugn/elaboration_order_handling_in_gnat doc}@anchor{21f}@anchor{gnat_ugn/elaboration_order_handling_in_gnat elaboration-order-handling-in-gnat}@anchor{10}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id1}@anchor{220}
+@anchor{gnat_ugn/elaboration_order_handling_in_gnat doc}@anchor{226}@anchor{gnat_ugn/elaboration_order_handling_in_gnat elaboration-order-handling-in-gnat}@anchor{10}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id1}@anchor{227}
@chapter Elaboration Order Handling in GNAT
@@ -26605,7 +27070,7 @@ GNAT, either automatically or with explicit programming features.
@end menu
@node Elaboration Code,Elaboration Order,,Elaboration Order Handling in GNAT
-@anchor{gnat_ugn/elaboration_order_handling_in_gnat elaboration-code}@anchor{221}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id2}@anchor{222}
+@anchor{gnat_ugn/elaboration_order_handling_in_gnat elaboration-code}@anchor{228}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id2}@anchor{229}
@section Elaboration Code
@@ -26754,7 +27219,7 @@ elaborated.
@end itemize
@node Elaboration Order,Checking the Elaboration Order,Elaboration Code,Elaboration Order Handling in GNAT
-@anchor{gnat_ugn/elaboration_order_handling_in_gnat elaboration-order}@anchor{223}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id3}@anchor{224}
+@anchor{gnat_ugn/elaboration_order_handling_in_gnat elaboration-order}@anchor{22a}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id3}@anchor{22b}
@section Elaboration Order
@@ -26924,7 +27389,7 @@ however a compiler may not always find such an order due to complications with
respect to control and data flow.
@node Checking the Elaboration Order,Controlling the Elaboration Order in Ada,Elaboration Order,Elaboration Order Handling in GNAT
-@anchor{gnat_ugn/elaboration_order_handling_in_gnat checking-the-elaboration-order}@anchor{225}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id4}@anchor{226}
+@anchor{gnat_ugn/elaboration_order_handling_in_gnat checking-the-elaboration-order}@anchor{22c}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id4}@anchor{22d}
@section Checking the Elaboration Order
@@ -26985,7 +27450,7 @@ order.
@end itemize
@node Controlling the Elaboration Order in Ada,Controlling the Elaboration Order in GNAT,Checking the Elaboration Order,Elaboration Order Handling in GNAT
-@anchor{gnat_ugn/elaboration_order_handling_in_gnat controlling-the-elaboration-order-in-ada}@anchor{227}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id5}@anchor{228}
+@anchor{gnat_ugn/elaboration_order_handling_in_gnat controlling-the-elaboration-order-in-ada}@anchor{22e}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id5}@anchor{22f}
@section Controlling the Elaboration Order in Ada
@@ -27314,7 +27779,7 @@ is that the program continues to stay in the last state (one or more correct
orders exist) even if maintenance changes the bodies of targets.
@node Controlling the Elaboration Order in GNAT,Mixing Elaboration Models,Controlling the Elaboration Order in Ada,Elaboration Order Handling in GNAT
-@anchor{gnat_ugn/elaboration_order_handling_in_gnat controlling-the-elaboration-order-in-gnat}@anchor{229}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id6}@anchor{22a}
+@anchor{gnat_ugn/elaboration_order_handling_in_gnat controlling-the-elaboration-order-in-gnat}@anchor{230}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id6}@anchor{231}
@section Controlling the Elaboration Order in GNAT
@@ -27445,7 +27910,7 @@ that in this mode, GNAT may not diagnose certain elaboration issues or
install run-time checks.
@node Mixing Elaboration Models,ABE Diagnostics,Controlling the Elaboration Order in GNAT,Elaboration Order Handling in GNAT
-@anchor{gnat_ugn/elaboration_order_handling_in_gnat id7}@anchor{22b}@anchor{gnat_ugn/elaboration_order_handling_in_gnat mixing-elaboration-models}@anchor{22c}
+@anchor{gnat_ugn/elaboration_order_handling_in_gnat id7}@anchor{232}@anchor{gnat_ugn/elaboration_order_handling_in_gnat mixing-elaboration-models}@anchor{233}
@section Mixing Elaboration Models
@@ -27492,7 +27957,7 @@ warning: "y.ads" which has static elaboration checks
You can suppress these warnings by specifying binder switch @code{-ws}.
@node ABE Diagnostics,SPARK Diagnostics,Mixing Elaboration Models,Elaboration Order Handling in GNAT
-@anchor{gnat_ugn/elaboration_order_handling_in_gnat abe-diagnostics}@anchor{22d}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id8}@anchor{22e}
+@anchor{gnat_ugn/elaboration_order_handling_in_gnat abe-diagnostics}@anchor{234}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id8}@anchor{235}
@section ABE Diagnostics
@@ -27599,7 +28064,7 @@ declaration @code{Safe} because the body of function @code{ABE} has already been
elaborated at that point.
@node SPARK Diagnostics,Elaboration Circularities,ABE Diagnostics,Elaboration Order Handling in GNAT
-@anchor{gnat_ugn/elaboration_order_handling_in_gnat id9}@anchor{22f}@anchor{gnat_ugn/elaboration_order_handling_in_gnat spark-diagnostics}@anchor{230}
+@anchor{gnat_ugn/elaboration_order_handling_in_gnat id9}@anchor{236}@anchor{gnat_ugn/elaboration_order_handling_in_gnat spark-diagnostics}@anchor{237}
@section SPARK Diagnostics
@@ -27625,7 +28090,7 @@ rules.
@end quotation
@node Elaboration Circularities,Resolving Elaboration Circularities,SPARK Diagnostics,Elaboration Order Handling in GNAT
-@anchor{gnat_ugn/elaboration_order_handling_in_gnat elaboration-circularities}@anchor{231}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id10}@anchor{232}
+@anchor{gnat_ugn/elaboration_order_handling_in_gnat elaboration-circularities}@anchor{238}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id10}@anchor{239}
@section Elaboration Circularities
@@ -27725,7 +28190,7 @@ This section enumerates various tactics for eliminating the circularity.
@end itemize
@node Resolving Elaboration Circularities,Elaboration-related Compiler Switches,Elaboration Circularities,Elaboration Order Handling in GNAT
-@anchor{gnat_ugn/elaboration_order_handling_in_gnat id11}@anchor{233}@anchor{gnat_ugn/elaboration_order_handling_in_gnat resolving-elaboration-circularities}@anchor{234}
+@anchor{gnat_ugn/elaboration_order_handling_in_gnat id11}@anchor{23a}@anchor{gnat_ugn/elaboration_order_handling_in_gnat resolving-elaboration-circularities}@anchor{23b}
@section Resolving Elaboration Circularities
@@ -27996,7 +28461,7 @@ Use the relaxed dynamic-elaboration model, with compiler switches
@end itemize
@node Elaboration-related Compiler Switches,Summary of Procedures for Elaboration Control,Resolving Elaboration Circularities,Elaboration Order Handling in GNAT
-@anchor{gnat_ugn/elaboration_order_handling_in_gnat elaboration-related-compiler-switches}@anchor{235}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id12}@anchor{236}
+@anchor{gnat_ugn/elaboration_order_handling_in_gnat elaboration-related-compiler-switches}@anchor{23c}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id12}@anchor{23d}
@section Elaboration-related Compiler Switches
@@ -28177,7 +28642,7 @@ checks. The example above will still fail at run time with an ABE.
@end table
@node Summary of Procedures for Elaboration Control,Inspecting the Chosen Elaboration Order,Elaboration-related Compiler Switches,Elaboration Order Handling in GNAT
-@anchor{gnat_ugn/elaboration_order_handling_in_gnat id13}@anchor{237}@anchor{gnat_ugn/elaboration_order_handling_in_gnat summary-of-procedures-for-elaboration-control}@anchor{238}
+@anchor{gnat_ugn/elaboration_order_handling_in_gnat id13}@anchor{23e}@anchor{gnat_ugn/elaboration_order_handling_in_gnat summary-of-procedures-for-elaboration-control}@anchor{23f}
@section Summary of Procedures for Elaboration Control
@@ -28235,7 +28700,7 @@ Use the relaxed dynamic elaboration model, with compiler switches
@end itemize
@node Inspecting the Chosen Elaboration Order,,Summary of Procedures for Elaboration Control,Elaboration Order Handling in GNAT
-@anchor{gnat_ugn/elaboration_order_handling_in_gnat id14}@anchor{239}@anchor{gnat_ugn/elaboration_order_handling_in_gnat inspecting-the-chosen-elaboration-order}@anchor{23a}
+@anchor{gnat_ugn/elaboration_order_handling_in_gnat id14}@anchor{240}@anchor{gnat_ugn/elaboration_order_handling_in_gnat inspecting-the-chosen-elaboration-order}@anchor{241}
@section Inspecting the Chosen Elaboration Order
@@ -28378,7 +28843,7 @@ gdbstr (body)
@end quotation
@node Inline Assembler,GNU Free Documentation License,Elaboration Order Handling in GNAT,Top
-@anchor{gnat_ugn/inline_assembler doc}@anchor{23b}@anchor{gnat_ugn/inline_assembler id1}@anchor{23c}@anchor{gnat_ugn/inline_assembler inline-assembler}@anchor{11}
+@anchor{gnat_ugn/inline_assembler doc}@anchor{242}@anchor{gnat_ugn/inline_assembler id1}@anchor{243}@anchor{gnat_ugn/inline_assembler inline-assembler}@anchor{11}
@chapter Inline Assembler
@@ -28437,7 +28902,7 @@ and assembly language programming.
@end menu
@node Basic Assembler Syntax,A Simple Example of Inline Assembler,,Inline Assembler
-@anchor{gnat_ugn/inline_assembler basic-assembler-syntax}@anchor{23d}@anchor{gnat_ugn/inline_assembler id2}@anchor{23e}
+@anchor{gnat_ugn/inline_assembler basic-assembler-syntax}@anchor{244}@anchor{gnat_ugn/inline_assembler id2}@anchor{245}
@section Basic Assembler Syntax
@@ -28553,7 +29018,7 @@ Intel: Destination first; for example @code{mov eax, 4}@w{ }
@node A Simple Example of Inline Assembler,Output Variables in Inline Assembler,Basic Assembler Syntax,Inline Assembler
-@anchor{gnat_ugn/inline_assembler a-simple-example-of-inline-assembler}@anchor{23f}@anchor{gnat_ugn/inline_assembler id3}@anchor{240}
+@anchor{gnat_ugn/inline_assembler a-simple-example-of-inline-assembler}@anchor{246}@anchor{gnat_ugn/inline_assembler id3}@anchor{247}
@section A Simple Example of Inline Assembler
@@ -28702,7 +29167,7 @@ If there are no errors, @code{as} generates an object file called
@code{nothing.out}.
@node Output Variables in Inline Assembler,Input Variables in Inline Assembler,A Simple Example of Inline Assembler,Inline Assembler
-@anchor{gnat_ugn/inline_assembler id4}@anchor{241}@anchor{gnat_ugn/inline_assembler output-variables-in-inline-assembler}@anchor{242}
+@anchor{gnat_ugn/inline_assembler id4}@anchor{248}@anchor{gnat_ugn/inline_assembler output-variables-in-inline-assembler}@anchor{249}
@section Output Variables in Inline Assembler
@@ -29069,7 +29534,7 @@ end Get_Flags_3;
@end quotation
@node Input Variables in Inline Assembler,Inlining Inline Assembler Code,Output Variables in Inline Assembler,Inline Assembler
-@anchor{gnat_ugn/inline_assembler id5}@anchor{243}@anchor{gnat_ugn/inline_assembler input-variables-in-inline-assembler}@anchor{244}
+@anchor{gnat_ugn/inline_assembler id5}@anchor{24a}@anchor{gnat_ugn/inline_assembler input-variables-in-inline-assembler}@anchor{24b}
@section Input Variables in Inline Assembler
@@ -29158,7 +29623,7 @@ _increment__incr.1:
@end quotation
@node Inlining Inline Assembler Code,Other Asm Functionality,Input Variables in Inline Assembler,Inline Assembler
-@anchor{gnat_ugn/inline_assembler id6}@anchor{245}@anchor{gnat_ugn/inline_assembler inlining-inline-assembler-code}@anchor{246}
+@anchor{gnat_ugn/inline_assembler id6}@anchor{24c}@anchor{gnat_ugn/inline_assembler inlining-inline-assembler-code}@anchor{24d}
@section Inlining Inline Assembler Code
@@ -29229,7 +29694,7 @@ movl %esi,%eax
thus saving the overhead of stack frame setup and an out-of-line call.
@node Other Asm Functionality,,Inlining Inline Assembler Code,Inline Assembler
-@anchor{gnat_ugn/inline_assembler id7}@anchor{247}@anchor{gnat_ugn/inline_assembler other-asm-functionality}@anchor{248}
+@anchor{gnat_ugn/inline_assembler id7}@anchor{24e}@anchor{gnat_ugn/inline_assembler other-asm-functionality}@anchor{24f}
@section Other @code{Asm} Functionality
@@ -29244,7 +29709,7 @@ and @code{Volatile}, which inhibits unwanted optimizations.
@end menu
@node The Clobber Parameter,The Volatile Parameter,,Other Asm Functionality
-@anchor{gnat_ugn/inline_assembler id8}@anchor{249}@anchor{gnat_ugn/inline_assembler the-clobber-parameter}@anchor{24a}
+@anchor{gnat_ugn/inline_assembler id8}@anchor{250}@anchor{gnat_ugn/inline_assembler the-clobber-parameter}@anchor{251}
@subsection The @code{Clobber} Parameter
@@ -29308,7 +29773,7 @@ Use ‘register’ name @code{memory} if you changed a memory location
@end itemize
@node The Volatile Parameter,,The Clobber Parameter,Other Asm Functionality
-@anchor{gnat_ugn/inline_assembler id9}@anchor{24b}@anchor{gnat_ugn/inline_assembler the-volatile-parameter}@anchor{24c}
+@anchor{gnat_ugn/inline_assembler id9}@anchor{252}@anchor{gnat_ugn/inline_assembler the-volatile-parameter}@anchor{253}
@subsection The @code{Volatile} Parameter
@@ -29344,7 +29809,7 @@ to @code{True} only if the compiler’s optimizations have created
problems.
@node GNU Free Documentation License,Index,Inline Assembler,Top
-@anchor{share/gnu_free_documentation_license doc}@anchor{24d}@anchor{share/gnu_free_documentation_license gnu-fdl}@anchor{1}@anchor{share/gnu_free_documentation_license gnu-free-documentation-license}@anchor{24e}
+@anchor{share/gnu_free_documentation_license doc}@anchor{254}@anchor{share/gnu_free_documentation_license gnu-fdl}@anchor{1}@anchor{share/gnu_free_documentation_license gnu-free-documentation-license}@anchor{255}
@chapter GNU Free Documentation License
@@ -29832,8 +30297,8 @@ to permit their use in free software.
@printindex ge
-@anchor{d2}@w{ }
@anchor{gnat_ugn/gnat_utility_programs switches-related-to-project-files}@w{ }
+@anchor{d2}@w{ }
@c %**end of body
@bye
diff --git a/gcc/ada/gnatcmd.adb b/gcc/ada/gnatcmd.adb
index 546dbca..5e3802e 100644
--- a/gcc/ada/gnatcmd.adb
+++ b/gcc/ada/gnatcmd.adb
@@ -368,7 +368,7 @@ begin
-- --help flag.
Set_Standard_Output;
Write_Eol;
- Write_Line ("Report bugs to report@adacore.com");
+ Write_Line ("Report bugs to support@adacore.com");
return;
end if;
diff --git a/gcc/ada/gnatls.adb b/gcc/ada/gnatls.adb
index 4e549a9..5f7e490 100644
--- a/gcc/ada/gnatls.adb
+++ b/gcc/ada/gnatls.adb
@@ -117,7 +117,6 @@ procedure Gnatls is
Also_Predef : Boolean := False; -- -a
Dependable : Boolean := False; -- -d
- License : Boolean := False; -- -l
Very_Verbose_Mode : Boolean := False; -- -V
-- Command line flags
@@ -188,9 +187,6 @@ procedure Gnatls is
procedure Usage;
-- Print usage message
- procedure Output_License_Information;
- -- Output license statement, and if not found, output reference to COPYING
-
function Image (Restriction : Restriction_Id) return String;
-- Returns the capitalized image of Restriction
@@ -881,20 +877,6 @@ procedure Gnatls is
return Normalize_Pathname (Path);
end Normalize;
- --------------------------------
- -- Output_License_Information --
- --------------------------------
-
- procedure Output_License_Information is
- begin
- case Build_Type is
- when others =>
- Write_Str ("Please refer to file COPYING in your distribution"
- & " for license terms.");
- Write_Eol;
- end case;
- end Output_License_Information;
-
-------------------
-- Output_Object --
-------------------
@@ -1605,7 +1587,9 @@ procedure Gnatls is
Name_Len := 0;
if not Is_Absolute_Path (Self (First .. Last)) then
- Add_Str_To_Name_Buffer (Get_Current_Dir); -- ??? System call
+ Add_Str_To_Name_Buffer
+ (GNAT.Directory_Operations.Get_Current_Dir);
+
Add_Char_To_Name_Buffer (Directory_Separator);
end if;
@@ -1792,7 +1776,6 @@ procedure Gnatls is
when 'o' => Reset_Print; Print_Object := True;
when 'v' => Verbose_Mode := True;
when 'd' => Dependable := True;
- when 'l' => License := True;
when 'V' => Very_Verbose_Mode := True;
when others => OK := False;
@@ -1946,11 +1929,6 @@ procedure Gnatls is
"depend");
Write_Eol;
- -- Line for -l
-
- Write_Str (" -l output license information");
- Write_Eol;
-
-- Line for -v
Write_Str (" -v verbose output, full path and unit " &
@@ -2046,21 +2024,6 @@ begin
Next_Arg := Next_Arg + 1;
end loop Scan_Args;
- -- If -l (output license information) is given, it must be the only switch
-
- if License then
- if Arg_Count = 2 then
- Output_License_Information;
-
- else
- Set_Standard_Error;
- Write_Str ("Can't use -l with another switch");
- Write_Eol;
- Try_Help;
- Exit_Program (E_Fatal);
- end if;
- end if;
-
-- Handle --RTS switch
if RTS_Specified /= null then
diff --git a/gcc/ada/init.c b/gcc/ada/init.c
index 1be90ec..35b7773 100644
--- a/gcc/ada/init.c
+++ b/gcc/ada/init.c
@@ -47,6 +47,7 @@
#ifdef __vxworks
#include "vxWorks.h"
#include "version.h" /* for _WRS_VXWORKS_MAJOR */
+#include <string.h> /* for strncmp */
#endif
#ifdef __ANDROID__
diff --git a/gcc/ada/inline.adb b/gcc/ada/inline.adb
index 494f1f8..e8eeebd 100644
--- a/gcc/ada/inline.adb
+++ b/gcc/ada/inline.adb
@@ -320,6 +320,7 @@ package body Inline is
-- Exit_Cases
-- Postcondition
-- Precondition
+ -- Program_Exit
-- Refined_Global
-- Refined_Depends
-- Refined_Post
@@ -1005,9 +1006,9 @@ package body Inline is
end loop;
-- The list of inlined subprograms is an overestimate, because it
- -- includes inlined functions called from functions that are compiled
- -- as part of an inlined package, but are not themselves called. An
- -- accurate computation of just those subprograms that are needed
+ -- includes inlined subprograms called from subprograms that are
+ -- declared in an inlined package, but are not themselves called.
+ -- An accurate computation of just those subprograms that are needed
-- requires that we perform a transitive closure over the call graph,
-- starting from calls in the main compilation unit.
@@ -3396,10 +3397,6 @@ package body Inline is
-- If the function body is a single expression, replace call with
-- expression, else insert block appropriately.
- procedure Rewrite_Procedure_Call (N : Node_Id; Blk : Node_Id);
- -- If procedure body has no local variables, inline body without
- -- creating block, otherwise rewrite call with block.
-
---------------------
-- Make_Exit_Label --
---------------------
@@ -3784,35 +3781,6 @@ package body Inline is
end if;
end Rewrite_Function_Call;
- ----------------------------
- -- Rewrite_Procedure_Call --
- ----------------------------
-
- procedure Rewrite_Procedure_Call (N : Node_Id; Blk : Node_Id) is
- HSS : constant Node_Id := Handled_Statement_Sequence (Blk);
-
- begin
- -- If there is a transient scope for N, this will be the scope of the
- -- actions for N, and the statements in Blk need to be within this
- -- scope. For example, they need to have visibility on the constant
- -- declarations created for the formals.
-
- -- If N needs no transient scope, and if there are no declarations in
- -- the inlined body, we can do a little optimization and insert the
- -- statements for the body directly after N, and rewrite N to a
- -- null statement, instead of rewriting N into a full-blown block
- -- statement.
-
- if not Scope_Is_Transient
- and then Is_Empty_List (Declarations (Blk))
- then
- Insert_List_After (N, Statements (HSS));
- Rewrite (N, Make_Null_Statement (Loc));
- else
- Rewrite (N, Blk);
- end if;
- end Rewrite_Procedure_Call;
-
-- Start of processing for Expand_Inlined_Call
begin
@@ -4077,6 +4045,7 @@ package body Inline is
-- Replace call with temporary and create its declaration
Temp := Make_Temporary (Loc, 'C');
+ Mutate_Ekind (Temp, E_Constant);
Set_Is_Internal (Temp);
-- For the unconstrained case, the generated temporary has the
@@ -4271,7 +4240,7 @@ package body Inline is
end;
if Ekind (Subp) = E_Procedure then
- Rewrite_Procedure_Call (N, Blk);
+ Rewrite (N, Blk);
else
Rewrite_Function_Call (N, Blk);
@@ -4922,11 +4891,17 @@ package body Inline is
and then Ekind (Info.Fin_Scop) = E_Package_Body
then
Set_In_Package_Body (Spec_Entity (Info.Fin_Scop), True);
+ Instantiate_Package_Body (Info);
+ Set_In_Package_Body (Spec_Entity (Info.Fin_Scop), False);
+ else
+ Instantiate_Package_Body (Info);
end if;
- Instantiate_Package_Body (Info);
+ -- No need to generate cleanups if the main unit is generic
- if Present (Info.Fin_Scop) then
+ if Present (Info.Fin_Scop)
+ and then not Is_Generic_Unit (Main_Unit_Entity)
+ then
Scop := Info.Fin_Scop;
-- If the enclosing finalization scope is dynamic, the instance
@@ -4939,12 +4914,6 @@ package body Inline is
end if;
Add_Scope_To_Clean (Scop);
-
- -- Reset the In_Package_Body flag if it was set above
-
- if Ekind (Info.Fin_Scop) = E_Package_Body then
- Set_In_Package_Body (Spec_Entity (Info.Fin_Scop), False);
- end if;
end if;
-- For subprogram instances, always instantiate the body
@@ -4965,10 +4934,6 @@ package body Inline is
Push_Scope (Standard_Standard);
To_Clean := New_Elmt_List;
- if Is_Generic_Unit (Cunit_Entity (Main_Unit)) then
- Start_Generic;
- end if;
-
-- A body instantiation may generate additional instantiations, so
-- the following loop must scan to the end of a possibly expanding
-- set (that's why we cannot simply use a FOR loop here). We must
@@ -5007,16 +4972,10 @@ package body Inline is
Pending_Instantiations.Init;
end if;
- -- We can now complete the cleanup actions of scopes that contain
- -- pending instantiations (skipped for generic units, since we
- -- never need any cleanups in generic units).
+ -- Expand the cleanup actions of scopes that contain instantiations
- if Expander_Active
- and then not Is_Generic_Unit (Main_Unit_Entity)
- then
+ if Expander_Active then
Cleanup_Scopes;
- elsif Is_Generic_Unit (Cunit_Entity (Main_Unit)) then
- End_Generic;
end if;
Pop_Scope;
@@ -5271,6 +5230,7 @@ package body Inline is
| Name_Exit_Cases
| Name_Postcondition
| Name_Precondition
+ | Name_Program_Exit
| Name_Refined_Global
| Name_Refined_Depends
| Name_Refined_Post
diff --git a/gcc/ada/diagnostics-json_utils.adb b/gcc/ada/json_utils.adb
index 072cab4..61b0693 100644
--- a/gcc/ada/diagnostics-json_utils.adb
+++ b/gcc/ada/json_utils.adb
@@ -22,9 +22,13 @@
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
+
+with Namet; use Namet;
+with Osint;
with Output; use Output;
+with System.OS_Lib;
-package body Diagnostics.JSON_Utils is
+package body JSON_Utils is
-----------------
-- Begin_Block --
@@ -64,6 +68,141 @@ package body Diagnostics.JSON_Utils is
end if;
end NL_And_Indent;
+ -----------------
+ -- To_File_Uri --
+ -----------------
+
+ function To_File_Uri (Path : String) return String is
+
+ function Normalize_Uri (Path : String) return String;
+ -- Construct a normalized URI from the path name by replacing reserved
+ -- URI characters that can appear in paths with their escape character
+ -- combinations.
+ --
+ -- According to the URI standard reserved charcthers within the paths
+ -- should be percent encoded:
+ --
+ -- https://www.rfc-editor.org/info/rfc3986
+ --
+ -- Reserved charcters are defined as:
+ --
+ -- reserved = gen-delims / sub-delims
+ -- gen-delims = ":" / "/" / "?" / "#" / "[" / "]" / "@"
+ -- sub-delims = "!" / "$" / "&" / "’" / "(" / ")"
+ -- / "*" / "+" / "," / ";" / "="
+
+ -------------------
+ -- Normalize_Uri --
+ -------------------
+
+ function Normalize_Uri (Path : String) return String is
+ Buf : Bounded_String;
+ begin
+ for C of Path loop
+ case C is
+ when '\' =>
+
+ -- Use forward slashes instead of backward slashes as
+ -- separators on Windows and on Linux simply encode the
+ -- symbol if part of a directory name.
+
+ if Osint.On_Windows then
+ Append (Buf, '/');
+ else
+ Append (Buf, "%5C");
+ end if;
+
+ when ' ' =>
+ Append (Buf, "%20");
+
+ when '!' =>
+ Append (Buf, "%21");
+
+ when '#' =>
+ Append (Buf, "%23");
+
+ when '$' =>
+ Append (Buf, "%24");
+
+ when '&' =>
+ Append (Buf, "%26");
+
+ when ''' =>
+ Append (Buf, "%27");
+
+ when '(' =>
+ Append (Buf, "%28");
+
+ when ')' =>
+ Append (Buf, "%29");
+
+ when '*' =>
+ Append (Buf, "%2A");
+
+ when '+' =>
+ Append (Buf, "%2A");
+
+ when ',' =>
+ Append (Buf, "%2A");
+
+ when '/' =>
+ -- Forward slash is a valid file separator on both Unix and
+ -- Windows based machines and should be treated as such
+ -- within a path.
+ Append (Buf, '/');
+
+ when ':' =>
+ Append (Buf, "%3A");
+
+ when ';' =>
+ Append (Buf, "%3B");
+
+ when '=' =>
+ Append (Buf, "%3D");
+
+ when '?' =>
+ Append (Buf, "%3F");
+
+ when '@' =>
+ Append (Buf, "%40");
+
+ when '[' =>
+ Append (Buf, "%5B");
+
+ when ']' =>
+ Append (Buf, "%5D");
+
+ when others =>
+ Append (Buf, C);
+ end case;
+ end loop;
+
+ return To_String (Buf);
+ end Normalize_Uri;
+
+ Norm_Uri : constant String := Normalize_Uri (Path);
+
+ -- Start of processing for To_File_Uri
+
+ begin
+ if System.OS_Lib.Is_Absolute_Path (Path) then
+ -- URI-s using the file scheme should start with the following
+ -- prefix:
+ --
+ -- "file:///"
+
+ if Osint.On_Windows then
+ return "file:///" & Norm_Uri;
+ else
+ -- Full paths on linux based systems already start with '/'
+
+ return "file://" & Norm_Uri;
+ end if;
+ else
+ return Norm_Uri;
+ end if;
+ end To_File_Uri;
+
-----------------------------
-- Write_Boolean_Attribute --
-----------------------------
@@ -112,4 +251,4 @@ package body Diagnostics.JSON_Utils is
Write_Char ('"');
end Write_String_Attribute;
-end Diagnostics.JSON_Utils;
+end JSON_Utils;
diff --git a/gcc/ada/diagnostics-json_utils.ads b/gcc/ada/json_utils.ads
index 526e09e..b251def 100644
--- a/gcc/ada/diagnostics-json_utils.ads
+++ b/gcc/ada/json_utils.ads
@@ -22,8 +22,9 @@
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
+with Types; use Types;
-package Diagnostics.JSON_Utils is
+package JSON_Utils is
JSON_FORMATTING : constant Boolean := True;
-- Adds newlines and indentation to the output JSON.
@@ -49,6 +50,11 @@ package Diagnostics.JSON_Utils is
procedure NL_And_Indent;
-- Print a new line
+ function To_File_Uri (Path : String) return String;
+ -- Converts an absolute Path into a file URI string by adding the file
+ -- schema prefix "file:///" and replacing all of the URI reserved
+ -- characters in the absolute path.
+
procedure Write_Boolean_Attribute (Name : String; Value : Boolean);
-- Write a JSON attribute with a boolean value.
--
@@ -72,4 +78,4 @@ package Diagnostics.JSON_Utils is
-- The Value is surrounded by double quotes ("") and the special characters
-- within the string are escaped.
-end Diagnostics.JSON_Utils;
+end JSON_Utils;
diff --git a/gcc/ada/lib-load.adb b/gcc/ada/lib-load.adb
index 46de911..bdeea1c 100644
--- a/gcc/ada/lib-load.adb
+++ b/gcc/ada/lib-load.adb
@@ -226,13 +226,11 @@ package body Lib.Load is
Fatal_Error => Error_Detected,
Generate_Code => False,
Has_RACW => False,
- Filler => False,
Ident_String => Empty,
Is_Predefined_Renaming => Ren_Name,
Is_Predefined_Unit => Pre_Name or Ren_Name,
Is_Internal_Unit => Pre_Name or Ren_Name or GNAT_Name,
- Filler2 => False,
Loading => False,
Main_Priority => Default_Main_Priority,
@@ -374,13 +372,11 @@ package body Lib.Load is
Fatal_Error => None,
Generate_Code => True,
Has_RACW => False,
- Filler => False,
Ident_String => Empty,
Is_Predefined_Renaming => Ren_Name,
Is_Predefined_Unit => Pre_Name or Ren_Name,
Is_Internal_Unit => Pre_Name or Ren_Name or GNAT_Name,
- Filler2 => False,
Loading => True,
Main_Priority => Default_Main_Priority,
@@ -760,13 +756,11 @@ package body Lib.Load is
Fatal_Error => None,
Generate_Code => False,
Has_RACW => False,
- Filler => False,
Ident_String => Empty,
Is_Predefined_Renaming => Ren_Name,
Is_Predefined_Unit => Pre_Name or Ren_Name,
Is_Internal_Unit => Pre_Name or Ren_Name or GNAT_Name,
- Filler2 => False,
Loading => True,
Main_Priority => Default_Main_Priority,
diff --git a/gcc/ada/lib-writ.adb b/gcc/ada/lib-writ.adb
index ccb0bd2..b7a7f12 100644
--- a/gcc/ada/lib-writ.adb
+++ b/gcc/ada/lib-writ.adb
@@ -116,12 +116,10 @@ package body Lib.Writ is
Fatal_Error => None,
Generate_Code => False,
Has_RACW => False,
- Filler => False,
Ident_String => Empty,
Is_Predefined_Renaming => False,
Is_Internal_Unit => False,
Is_Predefined_Unit => False,
- Filler2 => False,
Loading => False,
Main_Priority => -1,
Main_CPU => -1,
@@ -175,12 +173,10 @@ package body Lib.Writ is
Fatal_Error => None,
Generate_Code => False,
Has_RACW => False,
- Filler => False,
Ident_String => Empty,
Is_Predefined_Renaming => False,
Is_Internal_Unit => True,
Is_Predefined_Unit => True,
- Filler2 => False,
Loading => False,
Main_Priority => -1,
Main_CPU => -1,
diff --git a/gcc/ada/lib.adb b/gcc/ada/lib.adb
index 2c6a682..a727f48 100644
--- a/gcc/ada/lib.adb
+++ b/gcc/ada/lib.adb
@@ -1129,15 +1129,6 @@ package body Lib is
Units.Locked := True;
end Lock;
- ---------------
- -- Num_Units --
- ---------------
-
- function Num_Units return Nat is
- begin
- return Int (Units.Last) - Int (Main_Unit) + 1;
- end Num_Units;
-
-----------------
-- Remove_Unit --
-----------------
diff --git a/gcc/ada/lib.ads b/gcc/ada/lib.ads
index c902ca2..a085aa7 100644
--- a/gcc/ada/lib.ads
+++ b/gcc/ada/lib.ads
@@ -633,10 +633,8 @@ package Lib is
-- Same as above, but for Source_Ptr
function ipu (N : Node_Or_Entity_Id) return Boolean;
- -- Same as In_Predefined_Unit, but renamed so it can assist debugging.
- -- Otherwise, there is a disambiguous name conflict in the two versions of
- -- In_Predefined_Unit which makes it inconvient to set as a breakpoint
- -- condition.
+ -- Same as In_Predefined_Unit, but renamed to this unambiguous name for use
+ -- in the debugger.
function In_Predefined_Unit (N : Node_Or_Entity_Id) return Boolean;
-- Returns True if the given node or entity appears within the source text
@@ -720,12 +718,9 @@ package Lib is
procedure Lock;
-- Lock internal tables before calling back end
- function Num_Units return Nat;
- -- Number of units currently in unit table
-
procedure Remove_Unit (U : Unit_Number_Type);
- -- Remove unit U from unit table. Currently this is effective only if U is
- -- the last unit currently stored in the unit table.
+ -- Remove unit U from unit table. U must be the last unit currently stored
+ -- in the unit table.
procedure Replace_Linker_Option_String
(S : String_Id;
@@ -871,55 +866,14 @@ private
Has_RACW : Boolean;
Dynamic_Elab : Boolean;
No_Elab_Code_All : Boolean;
- Filler : Boolean;
Loading : Boolean;
OA_Setting : Character;
Is_Predefined_Renaming : Boolean;
Is_Internal_Unit : Boolean;
Is_Predefined_Unit : Boolean;
- Filler2 : Boolean;
- end record;
-
- -- The following representation clause ensures that the above record
- -- has no holes. We do this so that when instances of this record are
- -- written by Tree_Gen, we do not write uninitialized values to the file.
-
- for Unit_Record use record
- Unit_File_Name at 0 range 0 .. 31;
- Unit_Name at 4 range 0 .. 31;
- Munit_Index at 8 range 0 .. 31;
- Expected_Unit at 12 range 0 .. 31;
- Source_Index at 16 range 0 .. 31;
- Cunit at 20 range 0 .. 31;
- Cunit_Entity at 24 range 0 .. 31;
- Dependency_Num at 28 range 0 .. 31;
- Ident_String at 32 range 0 .. 31;
- Main_Priority at 36 range 0 .. 31;
- Main_CPU at 40 range 0 .. 31;
- Primary_Stack_Count at 44 range 0 .. 31;
- Sec_Stack_Count at 48 range 0 .. 31;
- Serial_Number at 52 range 0 .. 31;
- Version at 56 range 0 .. 31;
- Error_Location at 60 range 0 .. 31;
- Fatal_Error at 64 range 0 .. 7;
- Generate_Code at 65 range 0 .. 7;
- Has_RACW at 66 range 0 .. 7;
- Dynamic_Elab at 67 range 0 .. 7;
- No_Elab_Code_All at 68 range 0 .. 7;
- Filler at 69 range 0 .. 7;
- OA_Setting at 70 range 0 .. 7;
- Loading at 71 range 0 .. 7;
-
- Is_Predefined_Renaming at 72 range 0 .. 7;
- Is_Internal_Unit at 73 range 0 .. 7;
- Is_Predefined_Unit at 74 range 0 .. 7;
- Filler2 at 75 range 0 .. 7;
end record;
- for Unit_Record'Size use 76 * 8;
- -- This ensures that we did not leave out any fields
-
package Units is new Table.Table (
Table_Component_Type => Unit_Record,
Table_Index_Type => Unit_Number_Type,
diff --git a/gcc/ada/libgnarl/s-linux__android-aarch64.ads b/gcc/ada/libgnarl/s-linux__android-aarch64.ads
index 4f9e81d..537c46b 100644
--- a/gcc/ada/libgnarl/s-linux__android-aarch64.ads
+++ b/gcc/ada/libgnarl/s-linux__android-aarch64.ads
@@ -118,13 +118,19 @@ package System.Linux is
SIG33 : constant := 33; -- glibc internal signal
SIG34 : constant := 34; -- glibc internal signal
- -- struct_sigaction offsets
-
- -- sa_flags come first on aarch64-android (sa_flags, sa_handler, sa_mask)
-
- sa_flags_pos : constant := 0;
- sa_handler_pos : constant := sa_flags_pos + Interfaces.C.int'Size / 8;
- sa_mask_pos : constant := sa_handler_pos + Standard'Address_Size / 8;
+ -- struct_sigaction
+
+ generic
+ type sigset_t is private;
+ package Android_Sigaction is
+ type struct_sigaction is record
+ sa_flags : Interfaces.C.int;
+ sa_handler : System.Address;
+ sa_mask : sigset_t;
+ sa_restorer : System.Address;
+ end record;
+ pragma Convention (C, struct_sigaction);
+ end Android_Sigaction;
SA_SIGINFO : constant := 16#00000004#;
SA_ONSTACK : constant := 16#08000000#;
diff --git a/gcc/ada/libgnarl/s-linux__android-arm.ads b/gcc/ada/libgnarl/s-linux__android-arm.ads
index 3e0325e..07bca55 100644
--- a/gcc/ada/libgnarl/s-linux__android-arm.ads
+++ b/gcc/ada/libgnarl/s-linux__android-arm.ads
@@ -118,11 +118,19 @@ package System.Linux is
SIG33 : constant := 33; -- glibc internal signal
SIG34 : constant := 34; -- glibc internal signal
- -- struct_sigaction offsets
-
- sa_handler_pos : constant := 0;
- sa_mask_pos : constant := Standard'Address_Size / 8;
- sa_flags_pos : constant := 4 + sa_mask_pos;
+ -- struct_sigaction
+
+ generic
+ type sigset_t is private;
+ package Android_Sigaction is
+ type struct_sigaction is record
+ sa_handler : System.Address;
+ sa_mask : sigset_t;
+ sa_flags : Interfaces.C.int;
+ sa_restorer : System.Address;
+ end record;
+ pragma Convention (C, struct_sigaction);
+ end Android_Sigaction;
SA_SIGINFO : constant := 16#00000004#;
SA_ONSTACK : constant := 16#08000000#;
diff --git a/gcc/ada/libgnarl/s-osinte__android.ads b/gcc/ada/libgnarl/s-osinte__android.ads
index cd7e148..4383860 100644
--- a/gcc/ada/libgnarl/s-osinte__android.ads
+++ b/gcc/ada/libgnarl/s-osinte__android.ads
@@ -147,7 +147,20 @@ package System.OS_Interface is
-- Not clear why these two signals are reserved. Perhaps they are not
-- supported by this version of GNU/Linux ???
- type sigset_t is private;
+ -- struct sigaction fields are of different sizes and come in different
+ -- order on ARM vs aarch64. As this source is shared by the two
+ -- configurations, fetch the type definition through System.Linux, which
+ -- is specialized.
+
+ type sigset_t is
+ array (0 .. OS_Constants.SIZEOF_sigset - 1) of Interfaces.C.unsigned_char;
+ pragma Convention (C, sigset_t);
+ for sigset_t'Alignment use Interfaces.C.unsigned_long'Alignment;
+
+ package Android_Sigaction is new
+ System.Linux.Android_Sigaction (sigset_t => sigset_t);
+
+ type struct_sigaction is new Android_Sigaction.struct_sigaction;
function sigaddset (set : access sigset_t; sig : Signal) return int;
pragma Import (C, sigaddset, "_sigaddset");
@@ -173,14 +186,6 @@ package System.OS_Interface is
end record;
pragma Convention (C, siginfo_t);
- type struct_sigaction is record
- sa_handler : System.Address;
- sa_mask : sigset_t;
- sa_flags : Interfaces.C.int;
- sa_restorer : System.Address;
- end record;
- pragma Convention (C, struct_sigaction);
-
type struct_sigaction_ptr is access all struct_sigaction;
SA_SIGINFO : constant := System.Linux.SA_SIGINFO;
@@ -258,6 +263,14 @@ package System.OS_Interface is
function getpid return pid_t;
pragma Import (C, getpid, "getpid");
+ PR_SET_NAME : constant := 15;
+ PR_GET_NAME : constant := 16;
+
+ function prctl
+ (option : int;
+ arg : unsigned_long) return int;
+ pragma Import (C_Variadic_1, prctl, "prctl");
+
-------------
-- Threads --
-------------
@@ -276,9 +289,11 @@ package System.OS_Interface is
new Ada.Unchecked_Conversion (unsigned_long, pthread_t);
subtype pthread_mutex_t is System.OS_Locks.pthread_mutex_t;
+ type pthread_rwlock_t is limited private;
type pthread_cond_t is limited private;
type pthread_attr_t is limited private;
type pthread_mutexattr_t is limited private;
+ type pthread_rwlockattr_t is limited private;
type pthread_condattr_t is limited private;
type pthread_key_t is private;
@@ -287,11 +302,6 @@ package System.OS_Interface is
PTHREAD_SCOPE_PROCESS : constant := 1;
PTHREAD_SCOPE_SYSTEM : constant := 0;
- -- Read/Write lock not supported on Android.
-
- subtype pthread_rwlock_t is pthread_mutex_t;
- subtype pthread_rwlockattr_t is pthread_mutexattr_t;
-
-----------
-- Stack --
-----------
@@ -389,6 +399,43 @@ package System.OS_Interface is
function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int;
pragma Import (C, pthread_mutex_unlock, "pthread_mutex_unlock");
+ function pthread_rwlockattr_init
+ (attr : access pthread_rwlockattr_t) return int;
+ pragma Import (C, pthread_rwlockattr_init, "pthread_rwlockattr_init");
+
+ function pthread_rwlockattr_destroy
+ (attr : access pthread_rwlockattr_t) return int;
+ pragma Import (C, pthread_rwlockattr_destroy, "pthread_rwlockattr_destroy");
+
+ PTHREAD_RWLOCK_PREFER_READER_NP : constant := 0;
+ PTHREAD_RWLOCK_PREFER_WRITER_NONRECURSIVE_NP : constant := 1;
+
+ -- No PTHREAD_RWLOCK_PREFER_WRITER_NP in Android's pthread.h API level 29
+
+ function pthread_rwlockattr_setkind_np
+ (attr : access pthread_rwlockattr_t;
+ pref : int) return int;
+ pragma Import
+ (C, pthread_rwlockattr_setkind_np, "pthread_rwlockattr_setkind_np");
+
+ function pthread_rwlock_init
+ (mutex : access pthread_rwlock_t;
+ attr : access pthread_rwlockattr_t) return int;
+ pragma Import (C, pthread_rwlock_init, "pthread_rwlock_init");
+
+ function pthread_rwlock_destroy
+ (mutex : access pthread_rwlock_t) return int;
+ pragma Import (C, pthread_rwlock_destroy, "pthread_rwlock_destroy");
+
+ function pthread_rwlock_rdlock (mutex : access pthread_rwlock_t) return int;
+ pragma Import (C, pthread_rwlock_rdlock, "pthread_rwlock_rdlock");
+
+ function pthread_rwlock_wrlock (mutex : access pthread_rwlock_t) return int;
+ pragma Import (C, pthread_rwlock_wrlock, "pthread_rwlock_wrlock");
+
+ function pthread_rwlock_unlock (mutex : access pthread_rwlock_t) return int;
+ pragma Import (C, pthread_rwlock_unlock, "pthread_rwlock_unlock");
+
function pthread_condattr_init
(attr : access pthread_condattr_t) return int;
pragma Import (C, pthread_condattr_init, "pthread_condattr_init");
@@ -581,23 +628,6 @@ package System.OS_Interface is
private
- type sigset_t is
- array (0 .. OS_Constants.SIZEOF_sigset - 1) of unsigned_char;
- pragma Convention (C, sigset_t);
- for sigset_t'Alignment use Interfaces.C.unsigned_long'Alignment;
-
- pragma Warnings (Off);
- for struct_sigaction use record
- sa_handler at Linux.sa_handler_pos range 0 .. Standard'Address_Size - 1;
- sa_mask at Linux.sa_mask_pos
- range 0 .. OS_Constants.SIZEOF_sigset * 8 - 1;
- sa_flags at Linux.sa_flags_pos
- range 0 .. Interfaces.C.int'Size - 1;
- end record;
- -- We intentionally leave sa_restorer unspecified and let the compiler
- -- append it after the last field, so disable corresponding warning.
- pragma Warnings (On);
-
type pid_t is new int;
type time_t is range -2 ** (System.Parameters.time_t_bits - 1)
@@ -632,6 +662,18 @@ private
pragma Convention (C, pthread_mutexattr_t);
for pthread_mutexattr_t'Alignment use Interfaces.C.int'Alignment;
+ type pthread_rwlockattr_t is record
+ Data : char_array (1 .. OS_Constants.PTHREAD_RWLOCKATTR_SIZE);
+ end record;
+ pragma Convention (C, pthread_rwlockattr_t);
+ for pthread_rwlockattr_t'Alignment use Interfaces.C.unsigned_long'Alignment;
+
+ type pthread_rwlock_t is record
+ Data : char_array (1 .. OS_Constants.PTHREAD_RWLOCK_SIZE);
+ end record;
+ pragma Convention (C, pthread_rwlock_t);
+ for pthread_rwlock_t'Alignment use Interfaces.C.unsigned_long'Alignment;
+
type pthread_cond_t is record
Data : char_array (1 .. OS_Constants.PTHREAD_COND_SIZE);
end record;
diff --git a/gcc/ada/libgnarl/s-stusta.adb b/gcc/ada/libgnarl/s-stusta.adb
index 5aca435..c9848a0 100644
--- a/gcc/ada/libgnarl/s-stusta.adb
+++ b/gcc/ada/libgnarl/s-stusta.adb
@@ -32,6 +32,7 @@
-- This is why this package is part of GNARL:
with System.Tasking.Debug;
+with System.Tasking.Stages;
with System.Task_Primitives.Operations;
with System.IO;
@@ -103,7 +104,9 @@ package body System.Stack_Usage.Tasking is
-- Calculate the task usage for a given task
- Report_For_Task (Id);
+ if not System.Tasking.Stages.Terminated (Id) then
+ Report_For_Task (Id);
+ end if;
end loop;
end if;
diff --git a/gcc/ada/libgnat/a-except.adb b/gcc/ada/libgnat/a-except.adb
index c776623..d0a1d7f 100644
--- a/gcc/ada/libgnat/a-except.adb
+++ b/gcc/ada/libgnat/a-except.adb
@@ -450,6 +450,8 @@ package body Ada.Exceptions is
(File : System.Address; Line : Integer);
procedure Rcheck_CE_Tag_Check
(File : System.Address; Line : Integer);
+ procedure Rcheck_PE_Abstract_Type_Component
+ (File : System.Address; Line : Integer);
procedure Rcheck_PE_Access_Before_Elaboration
(File : System.Address; Line : Integer);
procedure Rcheck_PE_Accessibility_Check
@@ -542,6 +544,8 @@ package body Ada.Exceptions is
"__gnat_rcheck_CE_Range_Check");
pragma Export (C, Rcheck_CE_Tag_Check,
"__gnat_rcheck_CE_Tag_Check");
+ pragma Export (C, Rcheck_PE_Abstract_Type_Component,
+ "__gnat_rcheck_PE_Abstract_Type_Component");
pragma Export (C, Rcheck_PE_Access_Before_Elaboration,
"__gnat_rcheck_PE_Access_Before_Elaboration");
pragma Export (C, Rcheck_PE_Accessibility_Check,
@@ -620,6 +624,7 @@ package body Ada.Exceptions is
pragma No_Return (Rcheck_CE_Partition_Check);
pragma No_Return (Rcheck_CE_Range_Check);
pragma No_Return (Rcheck_CE_Tag_Check);
+ pragma No_Return (Rcheck_PE_Abstract_Type_Component);
pragma No_Return (Rcheck_PE_Access_Before_Elaboration);
pragma No_Return (Rcheck_PE_Accessibility_Check);
pragma No_Return (Rcheck_PE_Address_Of_Intrinsic);
@@ -683,6 +688,8 @@ package body Ada.Exceptions is
"expected_throw");
pragma Machine_Attribute (Rcheck_CE_Tag_Check,
"expected_throw");
+ pragma Machine_Attribute (Rcheck_PE_Abstract_Type_Component,
+ "expected_throw");
pragma Machine_Attribute (Rcheck_PE_Access_Before_Elaboration,
"expected_throw");
pragma Machine_Attribute (Rcheck_PE_Accessibility_Check,
@@ -775,6 +782,8 @@ package body Ada.Exceptions is
"strub", "callable");
pragma Machine_Attribute (Rcheck_CE_Tag_Check,
"strub", "callable");
+ pragma Machine_Attribute (Rcheck_PE_Abstract_Type_Component,
+ "strub", "callable");
pragma Machine_Attribute (Rcheck_PE_Access_Before_Elaboration,
"strub", "callable");
pragma Machine_Attribute (Rcheck_PE_Accessibility_Check,
@@ -885,6 +894,8 @@ package body Ada.Exceptions is
Rmsg_36 : constant String := "stream operation not allowed" & NUL;
Rmsg_37 : constant String := "build-in-place mismatch" & NUL;
Rmsg_38 : constant String := "raise check failed" & NUL;
+ Rmsg_39 : constant String := "initialization of abstract type" &
+ " component not allowed" & NUL;
---------
-- AAA --
@@ -1471,6 +1482,13 @@ package body Ada.Exceptions is
Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_13'Address);
end Rcheck_CE_Tag_Check;
+ procedure Rcheck_PE_Abstract_Type_Component
+ (File : System.Address; Line : Integer)
+ is
+ begin
+ Raise_Program_Error_Msg (File, Line, Rmsg_39'Address);
+ end Rcheck_PE_Abstract_Type_Component;
+
procedure Rcheck_PE_Access_Before_Elaboration
(File : System.Address; Line : Integer)
is
diff --git a/gcc/ada/libgnat/a-nbnbig.adb b/gcc/ada/libgnat/a-nbnbig.adb
deleted file mode 100644
index e487a05..0000000
--- a/gcc/ada/libgnat/a-nbnbig.adb
+++ /dev/null
@@ -1,81 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME COMPONENTS --
--- --
--- ADA.NUMERICS.BIG_NUMBERS.BIG_INTEGERS_GHOST --
--- --
--- B o d y --
--- --
--- Copyright (C) 2021-2025, Free Software Foundation, Inc. --
--- --
--- GNAT is 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 body is provided as a work-around for a GNAT compiler bug, as GNAT
--- currently does not compile instantiations of the spec with imported ghost
--- generics for packages Signed_Conversions and Unsigned_Conversions.
-
--- Ghost code in this unit is meant for analysis only, not for run-time
--- checking. This is enforced by setting the assertion policy to Ignore.
-
-pragma Assertion_Policy (Ghost => Ignore);
-
-package body Ada.Numerics.Big_Numbers.Big_Integers_Ghost with
- SPARK_Mode => Off
-is
-
- package body Signed_Conversions with
- SPARK_Mode => Off
- is
-
- function To_Big_Integer (Arg : Int) return Valid_Big_Integer is
- begin
- raise Program_Error;
- return (null record);
- end To_Big_Integer;
-
- function From_Big_Integer (Arg : Valid_Big_Integer) return Int is
- begin
- raise Program_Error;
- return 0;
- end From_Big_Integer;
-
- end Signed_Conversions;
-
- package body Unsigned_Conversions with
- SPARK_Mode => Off
- is
-
- function To_Big_Integer (Arg : Int) return Valid_Big_Integer is
- begin
- raise Program_Error;
- return (null record);
- end To_Big_Integer;
-
- function From_Big_Integer (Arg : Valid_Big_Integer) return Int is
- begin
- raise Program_Error;
- return 0;
- end From_Big_Integer;
-
- end Unsigned_Conversions;
-
-end Ada.Numerics.Big_Numbers.Big_Integers_Ghost;
diff --git a/gcc/ada/libgnat/a-nbnbig.ads b/gcc/ada/libgnat/a-nbnbig.ads
deleted file mode 100644
index 04aa62a..0000000
--- a/gcc/ada/libgnat/a-nbnbig.ads
+++ /dev/null
@@ -1,241 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME COMPONENTS --
--- --
--- ADA.NUMERICS.BIG_NUMBERS.BIG_INTEGERS_GHOST --
--- --
--- S p e c --
--- --
--- This specification is derived from the Ada Reference Manual for use with --
--- GNAT. In accordance with the copyright of that document, you can freely --
--- copy and modify this specification, provided that if you redistribute a --
--- modified version, any changes that you have made are clearly indicated. --
--- --
-------------------------------------------------------------------------------
-
--- This package provides a reduced and non-executable implementation of the
--- ARM A.5.6 defined ``Ada.Numerics.Big_Numbers.Big_Integers`` for use in
--- SPARK proofs in the runtime. As it is only intended for SPARK proofs, this
--- package is marked as a Ghost package and consequently does not have a
--- runtime footprint.
-
--- Contrary to Ada.Numerics.Big_Numbers.Big_Integers, this unit does not
--- depend on System or Ada.Finalization, which makes it more convenient for
--- use in run-time units. Note, since it is a ghost unit, all subprograms are
--- marked as imported.
-
--- Ghost code in this unit is meant for analysis only, not for run-time
--- checking. This is enforced by setting the assertion policy to Ignore.
-
-pragma Assertion_Policy (Ghost => Ignore);
-
-package Ada.Numerics.Big_Numbers.Big_Integers_Ghost with
- SPARK_Mode,
- Ghost,
- Pure,
- Always_Terminates
-is
-
- type Big_Integer is private
- with Integer_Literal => From_Universal_Image;
- -- Private type that holds the integer value
-
- function Is_Valid (Arg : Big_Integer) return Boolean
- with
- Import,
- Global => null;
- -- Return whether a passed big integer is valid
-
- subtype Valid_Big_Integer is Big_Integer
- with Dynamic_Predicate => Is_Valid (Valid_Big_Integer),
- Predicate_Failure => raise Program_Error;
- -- Holds a valid Big_Integer
-
- -- Comparison operators defined for valid Big_Integer values
- function "=" (L, R : Valid_Big_Integer) return Boolean with
- Import,
- Global => null;
-
- function "<" (L, R : Valid_Big_Integer) return Boolean with
- Import,
- Global => null;
-
- function "<=" (L, R : Valid_Big_Integer) return Boolean with
- Import,
- Global => null;
-
- function ">" (L, R : Valid_Big_Integer) return Boolean with
- Import,
- Global => null;
-
- function ">=" (L, R : Valid_Big_Integer) return Boolean with
- Import,
- Global => null;
-
- function To_Big_Integer (Arg : Integer) return Valid_Big_Integer
- with
- Import,
- Global => null;
- -- Create a Big_Integer from an Integer value
-
- subtype Big_Positive is Big_Integer
- with Dynamic_Predicate =>
- (if Is_Valid (Big_Positive)
- then Big_Positive > To_Big_Integer (0)),
- Predicate_Failure => raise Constraint_Error;
- -- Positive subtype of Big_Integers, analogous to Positive and Integer
-
- subtype Big_Natural is Big_Integer
- with Dynamic_Predicate =>
- (if Is_Valid (Big_Natural)
- then Big_Natural >= To_Big_Integer (0)),
- Predicate_Failure => raise Constraint_Error;
- -- Natural subtype of Big_Integers, analogous to Natural and Integer
-
- function In_Range
- (Arg : Valid_Big_Integer; Low, High : Big_Integer) return Boolean
- is (Low <= Arg and Arg <= High)
- with
- Import,
- Global => null;
- -- Check whether Arg is in the range Low .. High
-
- function To_Integer (Arg : Valid_Big_Integer) return Integer
- with
- Import,
- Pre => In_Range (Arg,
- Low => To_Big_Integer (Integer'First),
- High => To_Big_Integer (Integer'Last))
- or else raise Constraint_Error,
- Global => null;
- -- Convert a valid Big_Integer into an Integer
-
- generic
- type Int is range <>;
- package Signed_Conversions is
- -- Generic package to implement conversion functions for
- -- arbitrary ranged types.
-
- function To_Big_Integer (Arg : Int) return Valid_Big_Integer
- with
- Global => null;
- -- Convert a ranged type into a valid Big_Integer
-
- function From_Big_Integer (Arg : Valid_Big_Integer) return Int
- with
- Pre => In_Range (Arg,
- Low => To_Big_Integer (Int'First),
- High => To_Big_Integer (Int'Last))
- or else raise Constraint_Error,
- Global => null;
- -- Convert a valid Big_Integer into a ranged type
- end Signed_Conversions;
-
- generic
- type Int is mod <>;
- package Unsigned_Conversions is
- -- Generic package to implement conversion functions for
- -- arbitrary modular types.
-
- function To_Big_Integer (Arg : Int) return Valid_Big_Integer
- with
- Global => null;
- -- Convert a modular type into a valid Big_Integer
-
- function From_Big_Integer (Arg : Valid_Big_Integer) return Int
- with
- Pre => In_Range (Arg,
- Low => To_Big_Integer (Int'First),
- High => To_Big_Integer (Int'Last))
- or else raise Constraint_Error,
- Global => null;
- -- Convert a valid Big_Integer into a modular type
-
- end Unsigned_Conversions;
-
- function From_String (Arg : String) return Valid_Big_Integer
- with
- Import,
- Global => null;
- -- Create a valid Big_Integer from a String
-
- function From_Universal_Image (Arg : String) return Valid_Big_Integer
- renames From_String;
-
- -- Mathematical operators defined for valid Big_Integer values
- function "+" (L : Valid_Big_Integer) return Valid_Big_Integer
- with
- Import,
- Global => null;
-
- function "-" (L : Valid_Big_Integer) return Valid_Big_Integer
- with
- Import,
- Global => null;
-
- function "abs" (L : Valid_Big_Integer) return Valid_Big_Integer
- with
- Import,
- Global => null;
-
- function "+" (L, R : Valid_Big_Integer) return Valid_Big_Integer
- with
- Import,
- Global => null;
-
- function "-" (L, R : Valid_Big_Integer) return Valid_Big_Integer
- with
- Import,
- Global => null;
-
- function "*" (L, R : Valid_Big_Integer) return Valid_Big_Integer
- with
- Import,
- Global => null;
-
- function "/" (L, R : Valid_Big_Integer) return Valid_Big_Integer
- with
- Import,
- Global => null;
-
- function "mod" (L, R : Valid_Big_Integer) return Valid_Big_Integer
- with
- Import,
- Global => null;
-
- function "rem" (L, R : Valid_Big_Integer) return Valid_Big_Integer
- with
- Import,
- Global => null;
-
- function "**" (L : Valid_Big_Integer; R : Natural) return Valid_Big_Integer
- with
- Import,
- Global => null;
-
- function Min (L, R : Valid_Big_Integer) return Valid_Big_Integer
- with
- Import,
- Global => null;
-
- function Max (L, R : Valid_Big_Integer) return Valid_Big_Integer
- with
- Import,
- Global => null;
-
- function Greatest_Common_Divisor
- (L, R : Valid_Big_Integer) return Big_Positive
- with
- Import,
- Pre => (L /= To_Big_Integer (0) and R /= To_Big_Integer (0))
- or else raise Constraint_Error,
- Global => null;
- -- Calculate the greatest common divisor for two Big_Integer values
-
-private
- pragma SPARK_Mode (Off);
-
- type Big_Integer is null record;
- -- Solely consists of Ghost code
-
-end Ada.Numerics.Big_Numbers.Big_Integers_Ghost;
diff --git a/gcc/ada/libgnat/a-ngelfu.adb b/gcc/ada/libgnat/a-ngelfu.adb
index 7ce2a4c..d7b6c0c 100644
--- a/gcc/ada/libgnat/a-ngelfu.adb
+++ b/gcc/ada/libgnat/a-ngelfu.adb
@@ -965,7 +965,6 @@ is
P, Q, R : Float_Type'Base;
Y : constant Float_Type'Base := abs X;
- G : constant Float_Type'Base := Y * Y;
Float_Type_Digits_15_Or_More : constant Boolean :=
Float_Type'Digits > 14;
@@ -983,10 +982,14 @@ is
elsif Y < Half_Ln3
and then Float_Type_Digits_15_Or_More
then
- P := (P2 * G + P1) * G + P0;
- Q := ((Q3 * G + Q2) * G + Q1) * G + Q0;
- R := G * (P / Q);
- return X + X * R;
+ declare
+ G : constant Float_Type'Base := Y * Y;
+ begin
+ P := (P2 * G + P1) * G + P0;
+ Q := ((Q3 * G + Q2) * G + Q1) * G + Q0;
+ R := G * (P / Q);
+ return X + X * R;
+ end;
else
return Aux.Tanh (X);
diff --git a/gcc/ada/libgnat/a-nudira.ads b/gcc/ada/libgnat/a-nudira.ads
index 647470b..3b2ca18 100644
--- a/gcc/ada/libgnat/a-nudira.ads
+++ b/gcc/ada/libgnat/a-nudira.ads
@@ -44,38 +44,60 @@ generic
type Result_Subtype is (<>);
package Ada.Numerics.Discrete_Random with
- SPARK_Mode => Off
+ SPARK_Mode => On,
+ Always_Terminates
is
-- Basic facilities
- type Generator is limited private;
+ type Generator is limited private with Default_Initial_Condition;
- function Random (Gen : Generator) return Result_Subtype;
+ function Random (Gen : Generator) return Result_Subtype with
+ Global => null,
+ Side_Effects;
+ pragma Annotate (GNATprove, Mutable_In_Parameters, Generator);
function Random
(Gen : Generator;
First : Result_Subtype;
Last : Result_Subtype) return Result_Subtype
- with Post => Random'Result in First .. Last;
+ with
+ Post => Random'Result in First .. Last,
+ Global => null,
+ Side_Effects;
+ pragma Annotate (GNATprove, Mutable_In_Parameters, Generator);
- procedure Reset (Gen : Generator; Initiator : Integer);
- procedure Reset (Gen : Generator);
+ procedure Reset (Gen : Generator; Initiator : Integer) with
+ Global => null;
+ pragma Annotate (GNATprove, Mutable_In_Parameters, Generator);
+
+ procedure Reset (Gen : Generator) with
+ Global => null;
+ pragma Annotate (GNATprove, Mutable_In_Parameters, Generator);
-- Advanced facilities
type State is private;
- procedure Save (Gen : Generator; To_State : out State);
- procedure Reset (Gen : Generator; From_State : State);
+ procedure Save (Gen : Generator; To_State : out State) with
+ Global => null;
+ pragma Annotate (GNATprove, Mutable_In_Parameters, Generator);
+
+ procedure Reset (Gen : Generator; From_State : State) with
+ Global => null;
+ pragma Annotate (GNATprove, Mutable_In_Parameters, Generator);
Max_Image_Width : constant := System.Random_Numbers.Max_Image_Width;
- function Image (Of_State : State) return String;
- function Value (Coded_State : String) return State;
+ function Image (Of_State : State) return String with
+ Global => null;
+ function Value (Coded_State : String) return State with
+ Global => null;
private
+ pragma SPARK_Mode (Off);
+
type Generator is new System.Random_Numbers.Generator;
type State is new System.Random_Numbers.State;
diff --git a/gcc/ada/libgnat/a-nuflra.ads b/gcc/ada/libgnat/a-nuflra.ads
index 7eb0494..9ea73d4 100644
--- a/gcc/ada/libgnat/a-nuflra.ads
+++ b/gcc/ada/libgnat/a-nuflra.ads
@@ -39,34 +39,50 @@
with System.Random_Numbers;
package Ada.Numerics.Float_Random with
- SPARK_Mode => Off
+ SPARK_Mode => On,
+ Always_Terminates
is
-- Basic facilities
- type Generator is limited private;
+ type Generator is limited private with Default_Initial_Condition;
subtype Uniformly_Distributed is Float range 0.0 .. 1.0;
- function Random (Gen : Generator) return Uniformly_Distributed;
+ function Random (Gen : Generator) return Uniformly_Distributed with
+ Global => null,
+ Side_Effects;
+ pragma Annotate (GNATprove, Mutable_In_Parameters, Generator);
+ procedure Reset (Gen : Generator) with
+ Global => null;
+ pragma Annotate (GNATprove, Mutable_In_Parameters, Generator);
- procedure Reset (Gen : Generator);
- procedure Reset (Gen : Generator; Initiator : Integer);
+ procedure Reset (Gen : Generator; Initiator : Integer) with
+ Global => null;
+ pragma Annotate (GNATprove, Mutable_In_Parameters, Generator);
-- Advanced facilities
type State is private;
- procedure Save (Gen : Generator; To_State : out State);
- procedure Reset (Gen : Generator; From_State : State);
+ procedure Save (Gen : Generator; To_State : out State) with
+ Global => null;
+ pragma Annotate (GNATprove, Mutable_In_Parameters, Generator);
+ procedure Reset (Gen : Generator; From_State : State) with
+ Global => null;
+ pragma Annotate (GNATprove, Mutable_In_Parameters, Generator);
Max_Image_Width : constant := System.Random_Numbers.Max_Image_Width;
- function Image (Of_State : State) return String;
- function Value (Coded_State : String) return State;
+ function Image (Of_State : State) return String with
+ Global => null;
+ function Value (Coded_State : String) return State with
+ Global => null;
private
+ pragma SPARK_Mode (Off);
+
type Generator is new System.Random_Numbers.Generator;
type State is new System.Random_Numbers.State;
diff --git a/gcc/ada/libgnat/a-strfix.adb b/gcc/ada/libgnat/a-strfix.adb
index 5acfef4..50bb214 100644
--- a/gcc/ada/libgnat/a-strfix.adb
+++ b/gcc/ada/libgnat/a-strfix.adb
@@ -38,14 +38,6 @@
-- bounds of function return results were also fixed, and use of & removed for
-- efficiency reasons.
--- Ghost code, loop invariants and assertions in this unit are meant for
--- analysis only, not for run-time checking, as it would be too costly
--- otherwise. This is enforced by setting the assertion policy to Ignore.
-
-pragma Assertion_Policy (Ghost => Ignore,
- Loop_Invariant => Ignore,
- Assert => Ignore);
-
with Ada.Strings.Maps; use Ada.Strings.Maps;
package body Ada.Strings.Fixed with SPARK_Mode is
@@ -153,12 +145,9 @@ package body Ada.Strings.Fixed with SPARK_Mode is
Right : Character) return String
is
begin
- return Result : String (1 .. Left) with Relaxed_Initialization do
+ return Result : String (1 .. Left) do
for J in Result'Range loop
Result (J) := Right;
- pragma Loop_Invariant
- (for all K in 1 .. J =>
- Result (K)'Initialized and then Result (K) = Right);
end loop;
end return;
end "*";
@@ -168,82 +157,15 @@ package body Ada.Strings.Fixed with SPARK_Mode is
Right : String) return String
is
Ptr : Integer := 0;
-
- -- Parts of the proof involving manipulations with the modulo operator
- -- are complicated for the prover and can't be done automatically in
- -- the global subprogram. That's why we isolate them in these two ghost
- -- lemmas.
-
- procedure Lemma_Mod (K : Integer) with
- Ghost,
- Pre =>
- Right'Length /= 0
- and then Ptr mod Right'Length = 0
- and then Ptr in 0 .. Natural'Last - Right'Length
- and then K in Ptr .. Ptr + Right'Length - 1,
- Post => K mod Right'Length = K - Ptr;
- -- Lemma_Mod is applied to an index considered in Lemma_Split to prove
- -- that it has the right value modulo Right'Length.
-
- procedure Lemma_Split (Result : String) with
- Ghost,
- Relaxed_Initialization => Result,
- Pre =>
- Right'Length /= 0
- and then Result'First = 1
- and then Result'Last >= 0
- and then Ptr mod Right'Length = 0
- and then Ptr in 0 .. Result'Last - Right'Length
- and then Result (Result'First .. Ptr + Right'Length)'Initialized
- and then Result (Ptr + 1 .. Ptr + Right'Length) = Right,
- Post =>
- (for all K in Ptr + 1 .. Ptr + Right'Length =>
- Result (K) = Right (Right'First + (K - 1) mod Right'Length));
- -- Lemma_Split is used after Result (Ptr + 1 .. Ptr + Right'Length) is
- -- updated to Right and concludes that the characters match for each
- -- index when taken modulo Right'Length, as the considered slice starts
- -- at index 1 modulo Right'Length.
-
- ---------------
- -- Lemma_Mod --
- ---------------
-
- procedure Lemma_Mod (K : Integer) is null;
-
- -----------------
- -- Lemma_Split --
- -----------------
-
- procedure Lemma_Split (Result : String)
- is
- begin
- for K in Ptr + 1 .. Ptr + Right'Length loop
- Lemma_Mod (K - 1);
- pragma Loop_Invariant
- (for all J in Ptr + 1 .. K =>
- Result (J) = Right (Right'First + (J - 1) mod Right'Length));
- end loop;
- end Lemma_Split;
-
- -- Start of processing for "*"
-
begin
if Right'Length = 0 then
return "";
end if;
- return Result : String (1 .. Left * Right'Length)
- with Relaxed_Initialization
- do
+ return Result : String (1 .. Left * Right'Length) do
for J in 1 .. Left loop
Result (Ptr + 1 .. Ptr + Right'Length) := Right;
- Lemma_Split (Result);
Ptr := Ptr + Right'Length;
- pragma Loop_Invariant (Ptr = J * Right'Length);
- pragma Loop_Invariant (Result (1 .. Ptr)'Initialized);
- pragma Loop_Invariant
- (for all K in 1 .. Ptr =>
- Result (K) = Right (Right'First + (K - 1) mod Right'Length));
end loop;
end return;
end "*";
@@ -255,8 +177,7 @@ package body Ada.Strings.Fixed with SPARK_Mode is
function Delete
(Source : String;
From : Positive;
- Through : Natural) return String
- is
+ Through : Natural) return String is
begin
if From > Through then
declare
@@ -279,9 +200,7 @@ package body Ada.Strings.Fixed with SPARK_Mode is
Result_Length : constant Integer := Front_Len + Back_Len;
-- Length of result
begin
- return Result : String (1 .. Result_Length)
- with Relaxed_Initialization
- do
+ return Result : String (1 .. Result_Length) do
Result (1 .. Front_Len) :=
Source (Source'First .. From - 1);
@@ -325,14 +244,11 @@ package body Ada.Strings.Fixed with SPARK_Mode is
Result_Type (Source (Source'First .. Source'First + (Count - 1)));
else
- return Result : Result_Type with Relaxed_Initialization do
+ return Result : Result_Type do
Result (1 .. Source'Length) := Source;
for J in Source'Length + 1 .. Count loop
Result (J) := Pad;
- pragma Loop_Invariant
- (for all K in Source'Length + 1 .. J =>
- Result (K)'Initialized and then Result (K) = Pad);
end loop;
end return;
end if;
@@ -342,8 +258,7 @@ package body Ada.Strings.Fixed with SPARK_Mode is
(Source : in out String;
Count : Natural;
Justify : Alignment := Left;
- Pad : Character := Space)
- is
+ Pad : Character := Space) is
begin
Move (Source => Head (Source, Count, Pad),
Target => Source,
@@ -362,37 +277,21 @@ package body Ada.Strings.Fixed with SPARK_Mode is
New_Item : String) return String
is
Front : constant Integer := Before - Source'First;
-
begin
if Before - 1 not in Source'First - 1 .. Source'Last then
raise Index_Error;
end if;
- return Result : String (1 .. Source'Length + New_Item'Length)
- with Relaxed_Initialization
- do
+ return Result : String (1 .. Source'Length + New_Item'Length) do
Result (1 .. Front) :=
Source (Source'First .. Before - 1);
Result (Front + 1 .. Front + New_Item'Length) :=
New_Item;
- pragma Assert
- (Result (1 .. Before - Source'First)
- = Source (Source'First .. Before - 1));
- pragma Assert
- (Result
- (Before - Source'First + 1
- .. Before - Source'First + New_Item'Length)
- = New_Item);
-
if Before <= Source'Last then
Result (Front + New_Item'Length + 1 .. Result'Last) :=
Source (Before .. Source'Last);
end if;
-
- pragma Assert
- (Result (1 .. Before - Source'First)
- = Source (Source'First .. Before - 1));
end return;
end Insert;
@@ -400,8 +299,7 @@ package body Ada.Strings.Fixed with SPARK_Mode is
(Source : in out String;
Before : Positive;
New_Item : String;
- Drop : Truncation := Error)
- is
+ Drop : Truncation := Error) is
begin
Move (Source => Insert (Source, Before, New_Item),
Target => Source,
@@ -536,38 +434,14 @@ package body Ada.Strings.Fixed with SPARK_Mode is
Front : constant Integer := Position - Source'First;
begin
- return Result : String (1 .. Result_Length)
- with Relaxed_Initialization
- do
+ return Result : String (1 .. Result_Length) do
Result (1 .. Front) := Source (Source'First .. Position - 1);
- pragma Assert
- (Result (1 .. Position - Source'First)
- = Source (Source'First .. Position - 1));
Result (Front + 1 .. Front + New_Item'Length) := New_Item;
- pragma Assert
- (Result
- (Position - Source'First + 1
- .. Position - Source'First + New_Item'Length)
- = New_Item);
if Position <= Source'Last - New_Item'Length then
Result (Front + New_Item'Length + 1 .. Result'Last) :=
Source (Position + New_Item'Length .. Source'Last);
-
- pragma Assert
- (Result
- (Position - Source'First + New_Item'Length + 1
- .. Result'Last)
- = Source (Position + New_Item'Length .. Source'Last));
end if;
-
- pragma Assert
- (if Position <= Source'Last - New_Item'Length
- then
- Result
- (Position - Source'First + New_Item'Length + 1
- .. Result'Last)
- = Source (Position + New_Item'Length .. Source'Last));
end return;
end;
end Overwrite;
@@ -576,8 +450,7 @@ package body Ada.Strings.Fixed with SPARK_Mode is
(Source : in out String;
Position : Positive;
New_Item : String;
- Drop : Truncation := Right)
- is
+ Drop : Truncation := Right) is
begin
Move (Source => Overwrite (Source, Position, New_Item),
Target => Source,
@@ -612,39 +485,14 @@ package body Ada.Strings.Fixed with SPARK_Mode is
-- Length of result
begin
- return Result : String (1 .. Result_Length)
- with Relaxed_Initialization do
+ return Result : String (1 .. Result_Length) do
Result (1 .. Front_Len) := Source (Source'First .. Low - 1);
- pragma Assert
- (Result (1 .. Integer'Max (0, Low - Source'First))
- = Source (Source'First .. Low - 1));
Result (Front_Len + 1 .. Front_Len + By'Length) := By;
- pragma Assert
- (Result
- (Integer'Max (0, Low - Source'First) + 1
- .. Integer'Max (0, Low - Source'First) + By'Length)
- = By);
if High < Source'Last then
Result (Front_Len + By'Length + 1 .. Result'Last) :=
Source (High + 1 .. Source'Last);
end if;
-
- pragma Assert
- (Result (1 .. Integer'Max (0, Low - Source'First))
- = Source (Source'First .. Low - 1));
- pragma Assert
- (Result
- (Integer'Max (0, Low - Source'First) + 1
- .. Integer'Max (0, Low - Source'First) + By'Length)
- = By);
- pragma Assert
- (if High < Source'Last
- then
- Result
- (Integer'Max (0, Low - Source'First) + By'Length + 1
- .. Result'Last)
- = Source (High + 1 .. Source'Last));
end return;
end;
else
@@ -659,8 +507,7 @@ package body Ada.Strings.Fixed with SPARK_Mode is
By : String;
Drop : Truncation := Error;
Justify : Alignment := Left;
- Pad : Character := Space)
- is
+ Pad : Character := Space) is
begin
Move (Replace_Slice (Source, Low, High, By), Source, Drop, Justify, Pad);
end Replace_Slice;
@@ -675,7 +522,6 @@ package body Ada.Strings.Fixed with SPARK_Mode is
Pad : Character := Space) return String
is
subtype Result_Type is String (1 .. Count);
-
begin
if Count = 0 then
return "";
@@ -686,12 +532,9 @@ package body Ada.Strings.Fixed with SPARK_Mode is
-- Pad on left
else
- return Result : Result_Type with Relaxed_Initialization do
+ return Result : Result_Type do
for J in 1 .. Count - Source'Length loop
Result (J) := Pad;
- pragma Loop_Invariant
- (for all K in 1 .. J =>
- Result (K)'Initialized and then Result (K) = Pad);
end loop;
if Source'Length /= 0 then
@@ -705,8 +548,7 @@ package body Ada.Strings.Fixed with SPARK_Mode is
(Source : in out String;
Count : Natural;
Justify : Alignment := Left;
- Pad : Character := Space)
- is
+ Pad : Character := Space) is
begin
Move (Source => Tail (Source, Count, Pad),
Target => Source,
@@ -721,35 +563,21 @@ package body Ada.Strings.Fixed with SPARK_Mode is
function Translate
(Source : String;
- Mapping : Maps.Character_Mapping) return String
- is
+ Mapping : Maps.Character_Mapping) return String is
begin
- return Result : String (1 .. Source'Length)
- with Relaxed_Initialization
- do
+ return Result : String (1 .. Source'Length) do
for J in Source'Range loop
Result (J - (Source'First - 1)) := Value (Mapping, Source (J));
- pragma Loop_Invariant
- (for all K in Source'First .. J =>
- Result (K - (Source'First - 1))'Initialized);
- pragma Loop_Invariant
- (for all K in Source'First .. J =>
- Result (K - (Source'First - 1)) =
- Value (Mapping, Source (K)));
end loop;
end return;
end Translate;
procedure Translate
(Source : in out String;
- Mapping : Maps.Character_Mapping)
- is
+ Mapping : Maps.Character_Mapping) is
begin
for J in Source'Range loop
Source (J) := Value (Mapping, Source (J));
- pragma Loop_Invariant
- (for all K in Source'First .. J =>
- Source (K) = Value (Mapping, Source'Loop_Entry (K)));
end loop;
end Translate;
@@ -759,23 +587,9 @@ package body Ada.Strings.Fixed with SPARK_Mode is
is
pragma Unsuppress (Access_Check);
begin
- return Result : String (1 .. Source'Length)
- with Relaxed_Initialization
- do
+ return Result : String (1 .. Source'Length) do
for J in Source'Range loop
Result (J - (Source'First - 1)) := Mapping.all (Source (J));
- pragma Annotate (GNATprove, False_Positive,
- "call via access-to-subprogram",
- "function Mapping must always terminate");
- pragma Loop_Invariant
- (for all K in Source'First .. J =>
- Result (K - (Source'First - 1))'Initialized);
- pragma Loop_Invariant
- (for all K in Source'First .. J =>
- Result (K - (Source'First - 1)) = Mapping (Source (K)));
- pragma Annotate (GNATprove, False_Positive,
- "call via access-to-subprogram",
- "function Mapping must always terminate");
end loop;
end return;
end Translate;
@@ -788,15 +602,6 @@ package body Ada.Strings.Fixed with SPARK_Mode is
begin
for J in Source'Range loop
Source (J) := Mapping.all (Source (J));
- pragma Annotate (GNATprove, False_Positive,
- "call via access-to-subprogram",
- "function Mapping must always terminate");
- pragma Loop_Invariant
- (for all K in Source'First .. J =>
- Source (K) = Mapping (Source'Loop_Entry (K)));
- pragma Annotate (GNATprove, False_Positive,
- "call via access-to-subprogram",
- "function Mapping must always terminate");
end loop;
end Translate;
@@ -872,8 +677,7 @@ package body Ada.Strings.Fixed with SPARK_Mode is
(Source : in out String;
Side : Trim_End;
Justify : Alignment := Left;
- Pad : Character := Space)
- is
+ Pad : Character := Space) is
begin
Move (Trim (Source, Side),
Source,
@@ -887,7 +691,6 @@ package body Ada.Strings.Fixed with SPARK_Mode is
Right : Maps.Character_Set) return String
is
High, Low : Integer;
-
begin
Low := Index (Source, Set => Left, Test => Outside, Going => Forward);
@@ -908,7 +711,6 @@ package body Ada.Strings.Fixed with SPARK_Mode is
declare
Result_Length : constant Integer := High - Low + 1;
subtype Result_Type is String (1 .. Result_Length);
-
begin
return Result_Type (Source (Low .. High));
end;
@@ -919,8 +721,7 @@ package body Ada.Strings.Fixed with SPARK_Mode is
Left : Maps.Character_Set;
Right : Maps.Character_Set;
Justify : Alignment := Strings.Left;
- Pad : Character := Space)
- is
+ Pad : Character := Space) is
begin
Move (Source => Trim (Source, Left, Right),
Target => Source,
diff --git a/gcc/ada/libgnat/a-strmap.adb b/gcc/ada/libgnat/a-strmap.adb
index 7490780..2f4cceb 100644
--- a/gcc/ada/libgnat/a-strmap.adb
+++ b/gcc/ada/libgnat/a-strmap.adb
@@ -35,14 +35,6 @@
-- is bit-by-bit or character-by-character and therefore rather slow.
-- Generally for character sets we favor the full 32-byte representation.
--- Assertions, ghost code and loop invariants in this unit are meant for
--- analysis only, not for run-time checking, as it would be too costly
--- otherwise. This is enforced by setting the assertion policy to Ignore.
-
-pragma Assertion_Policy (Assert => Ignore,
- Ghost => Ignore,
- Loop_Invariant => Ignore);
-
package body Ada.Strings.Maps
with SPARK_Mode
is
@@ -131,36 +123,15 @@ is
---------------
function To_Domain (Map : Character_Mapping) return Character_Sequence is
- Result : String (1 .. Map'Length) with Relaxed_Initialization;
+ Result : String (1 .. Map'Length);
J : Natural;
-
- type Character_Index is array (Character) of Natural with Ghost;
- Indexes : Character_Index := [others => 0] with Ghost;
-
begin
J := 0;
for C in Map'Range loop
if Map (C) /= C then
J := J + 1;
Result (J) := C;
- Indexes (C) := J;
end if;
-
- pragma Loop_Invariant (if Map = Identity then J = 0);
- pragma Loop_Invariant (J <= Character'Pos (C) + 1);
- pragma Loop_Invariant (for all K in 1 .. J => Result (K)'Initialized);
- pragma Loop_Invariant (for all K in 1 .. J => Result (K) <= C);
- pragma Loop_Invariant
- (SPARK_Proof_Sorted_Character_Sequence (Result (1 .. J)));
- pragma Loop_Invariant
- (for all D in Map'First .. C =>
- (if Map (D) = D then
- Indexes (D) = 0
- else
- Indexes (D) in 1 .. J
- and then Result (Indexes (D)) = D));
- pragma Loop_Invariant
- (for all Char of Result (1 .. J) => Map (Char) /= Char);
end loop;
return Result (1 .. J);
@@ -173,7 +144,7 @@ is
function To_Mapping
(From, To : Character_Sequence) return Character_Mapping
is
- Result : Character_Mapping with Relaxed_Initialization;
+ Result : Character_Mapping;
Inserted : Character_Set := Null_Set;
From_Len : constant Natural := From'Length;
To_Len : constant Natural := To'Length;
@@ -185,9 +156,6 @@ is
for Char in Character loop
Result (Char) := Char;
- pragma Loop_Invariant (Result (Result'First .. Char)'Initialized);
- pragma Loop_Invariant
- (for all C in Result'First .. Char => Result (C) = C);
end loop;
for J in From'Range loop
@@ -197,23 +165,6 @@ is
Result (From (J)) := To (J - From'First + To'First);
Inserted (From (J)) := True;
-
- pragma Loop_Invariant (Result'Initialized);
- pragma Loop_Invariant
- (for all K in From'First .. J =>
- Result (From (K)) = To (K - From'First + To'First)
- and then Inserted (From (K)));
- pragma Loop_Invariant
- (for all Char in Character =>
- (Inserted (Char) =
- (for some K in From'First .. J => Char = From (K))));
- pragma Loop_Invariant
- (for all Char in Character =>
- (if not Inserted (Char) then Result (Char) = Char));
- pragma Loop_Invariant
- (if (for all K in From'First .. J =>
- From (K) = To (J - From'First + To'First))
- then Result = Identity);
end loop;
return Result;
@@ -224,195 +175,16 @@ is
--------------
function To_Range (Map : Character_Mapping) return Character_Sequence is
-
- -- Extract from the postcondition of To_Domain the essential properties
- -- that define Seq as the domain of Map.
- function Is_Domain
- (Map : Character_Mapping;
- Seq : Character_Sequence)
- return Boolean
- is
- (Seq'First = 1
- and then
- SPARK_Proof_Sorted_Character_Sequence (Seq)
- and then
- (for all Char in Character =>
- (if (for all X of Seq => X /= Char)
- then Map (Char) = Char))
- and then
- (for all Char of Seq => Map (Char) /= Char))
- with
- Ghost;
-
- -- Given Map, there is a unique sequence Seq for which
- -- Is_Domain(Map,Seq) holds.
- procedure Lemma_Domain_Unicity
- (Map : Character_Mapping;
- Seq1, Seq2 : Character_Sequence)
- with
- Ghost,
- Pre => Is_Domain (Map, Seq1)
- and then Is_Domain (Map, Seq2),
- Post => Seq1 = Seq2;
-
- -- Isolate the proof that To_Domain(Map) returns a sequence for which
- -- Is_Domain holds.
- procedure Lemma_Is_Domain (Map : Character_Mapping)
- with
- Ghost,
- Post => Is_Domain (Map, To_Domain (Map));
-
- -- Deduce the alternative expression of sortedness from the one in
- -- SPARK_Proof_Sorted_Character_Sequence which compares consecutive
- -- elements.
- procedure Lemma_Is_Sorted (Seq : Character_Sequence)
- with
- Ghost,
- Pre => SPARK_Proof_Sorted_Character_Sequence (Seq),
- Post => (for all J in Seq'Range =>
- (for all K in Seq'Range =>
- (if J < K then Seq (J) < Seq (K))));
-
- --------------------------
- -- Lemma_Domain_Unicity --
- --------------------------
-
- procedure Lemma_Domain_Unicity
- (Map : Character_Mapping;
- Seq1, Seq2 : Character_Sequence)
- is
- J : Positive := 1;
-
- begin
- while J <= Seq1'Last
- and then J <= Seq2'Last
- and then Seq1 (J) = Seq2 (J)
- loop
- pragma Loop_Invariant
- (Seq1 (Seq1'First .. J) = Seq2 (Seq2'First .. J));
- pragma Loop_Variant (Increases => J);
-
- if J = Positive'Last then
- return;
- end if;
-
- J := J + 1;
- end loop;
-
- Lemma_Is_Sorted (Seq1);
- Lemma_Is_Sorted (Seq2);
-
- if J <= Seq1'Last
- and then J <= Seq2'Last
- then
- if Seq1 (J) < Seq2 (J) then
- pragma Assert (for all X of Seq2 => X /= Seq1 (J));
- pragma Assert (Map (Seq1 (J)) = Seq1 (J));
- pragma Assert (False);
- else
- pragma Assert (for all X of Seq1 => X /= Seq2 (J));
- pragma Assert (Map (Seq2 (J)) = Seq2 (J));
- pragma Assert (False);
- end if;
-
- elsif J <= Seq1'Last then
- pragma Assert (for all X of Seq2 => X /= Seq1 (J));
- pragma Assert (Map (Seq1 (J)) = Seq1 (J));
- pragma Assert (False);
-
- elsif J <= Seq2'Last then
- pragma Assert (for all X of Seq1 => X /= Seq2 (J));
- pragma Assert (Map (Seq2 (J)) = Seq2 (J));
- pragma Assert (False);
- end if;
- end Lemma_Domain_Unicity;
-
- ---------------------
- -- Lemma_Is_Domain --
- ---------------------
-
- procedure Lemma_Is_Domain (Map : Character_Mapping) is
- Ignore : constant Character_Sequence := To_Domain (Map);
- begin
- null;
- end Lemma_Is_Domain;
-
- ---------------------
- -- Lemma_Is_Sorted --
- ---------------------
-
- procedure Lemma_Is_Sorted (Seq : Character_Sequence) is
- begin
- for A in Seq'Range loop
- exit when A = Positive'Last;
-
- for B in A + 1 .. Seq'Last loop
- pragma Loop_Invariant
- (for all K in A + 1 .. B => Seq (A) < Seq (K));
- end loop;
-
- pragma Loop_Invariant
- (for all J in Seq'First .. A =>
- (for all K in Seq'Range =>
- (if J < K then Seq (J) < Seq (K))));
- end loop;
- end Lemma_Is_Sorted;
-
- -- Local variables
-
- Result : String (1 .. Map'Length) with Relaxed_Initialization;
+ Result : String (1 .. Map'Length);
J : Natural;
-
- -- Repeat the computation from To_Domain in ghost code, in order to
- -- prove the relationship between Result and To_Domain(Map).
-
- Domain : String (1 .. Map'Length) with Ghost, Relaxed_Initialization;
- type Character_Index is array (Character) of Natural with Ghost;
- Indexes : Character_Index := [others => 0] with Ghost;
-
- -- Start of processing for To_Range
-
begin
J := 0;
for C in Map'Range loop
if Map (C) /= C then
J := J + 1;
Result (J) := Map (C);
- Domain (J) := C;
- Indexes (C) := J;
end if;
-
- -- Repeat the loop invariants from To_Domain regarding Domain and
- -- Indexes. Add similar loop invariants for Result and Indexes.
-
- pragma Loop_Invariant (J <= Character'Pos (C) + 1);
- pragma Loop_Invariant (Result (1 .. J)'Initialized);
- pragma Loop_Invariant (Domain (1 .. J)'Initialized);
- pragma Loop_Invariant (for all K in 1 .. J => Domain (K) <= C);
- pragma Loop_Invariant
- (SPARK_Proof_Sorted_Character_Sequence (Domain (1 .. J)));
- pragma Loop_Invariant
- (for all D in Map'First .. C =>
- (if Map (D) = D then
- Indexes (D) = 0
- else
- Indexes (D) in 1 .. J
- and then Domain (Indexes (D)) = D
- and then Result (Indexes (D)) = Map (D)));
- pragma Loop_Invariant
- (for all Char of Domain (1 .. J) => Map (Char) /= Char);
- pragma Loop_Invariant
- (for all K in 1 .. J => Result (K) = Map (Domain (K)));
end loop;
- pragma Assert (Is_Domain (Map, Domain (1 .. J)));
-
- -- Show the equality of Domain and To_Domain(Map)
-
- Lemma_Is_Domain (Map);
- Lemma_Domain_Unicity (Map, Domain (1 .. J), To_Domain (Map));
- pragma Assert
- (for all K in 1 .. J => Domain (K) = To_Domain (Map) (K));
- pragma Assert (To_Domain (Map)'Length = J);
return Result (1 .. J);
end To_Range;
@@ -422,27 +194,18 @@ is
---------------
function To_Ranges (Set : Character_Set) return Character_Ranges is
- Max_Ranges : Character_Ranges (1 .. Set'Length / 2 + 1)
- with Relaxed_Initialization;
+ Max_Ranges : Character_Ranges (1 .. Set'Length / 2 + 1);
Range_Num : Natural;
C : Character;
- C_Iter : Character with Ghost;
begin
C := Character'First;
Range_Num := 0;
loop
- C_Iter := C;
-
-- Skip gap between subsets
while not Set (C) loop
- pragma Loop_Invariant
- (Character'Pos (C) >= Character'Pos (C'Loop_Entry));
- pragma Loop_Invariant
- (for all Char in C'Loop_Entry .. C => not Set (Char));
- pragma Loop_Variant (Increases => C);
exit when C = Character'Last;
C := Character'Succ (C);
end loop;
@@ -455,12 +218,6 @@ is
-- Span a subset
loop
- pragma Loop_Invariant
- (Character'Pos (C) >= Character'Pos (C'Loop_Entry));
- pragma Loop_Invariant
- (for all Char in C'Loop_Entry .. C =>
- (if Char /= C then Set (Char)));
- pragma Loop_Variant (Increases => C);
exit when not Set (C) or else C = Character'Last;
C := Character'Succ (C);
end loop;
@@ -471,31 +228,6 @@ is
else
Max_Ranges (Range_Num).High := Character'Pred (C);
end if;
-
- pragma Assert
- (for all Char in C_Iter .. C =>
- (Set (Char) =
- (Char in Max_Ranges (Range_Num).Low ..
- Max_Ranges (Range_Num).High)));
- pragma Assert
- (for all Char in Character'First .. C_Iter =>
- (if Char /= C_Iter then
- (Set (Char) =
- (for some Span of Max_Ranges (1 .. Range_Num - 1) =>
- Char in Span.Low .. Span.High))));
-
- pragma Loop_Invariant (2 * Range_Num <= Character'Pos (C) + 1);
- pragma Loop_Invariant (Max_Ranges (1 .. Range_Num)'Initialized);
- pragma Loop_Invariant (not Set (C));
- pragma Loop_Invariant
- (for all Char in Character'First .. C =>
- (Set (Char) =
- (for some Span of Max_Ranges (1 .. Range_Num) =>
- Char in Span.Low .. Span.High)));
- pragma Loop_Invariant
- (for all Span of Max_Ranges (1 .. Range_Num) =>
- (for all Char in Span.Low .. Span.High => Set (Char)));
- pragma Loop_Variant (Increases => Range_Num);
end loop;
return Max_Ranges (1 .. Range_Num);
@@ -506,8 +238,7 @@ is
-----------------
function To_Sequence (Set : Character_Set) return Character_Sequence is
- Result : String (1 .. Character'Pos (Character'Last) + 1)
- with Relaxed_Initialization;
+ Result : String (1 .. Character'Pos (Character'Last) + 1);
Count : Natural := 0;
begin
for Char in Set'Range loop
@@ -515,17 +246,6 @@ is
Count := Count + 1;
Result (Count) := Char;
end if;
-
- pragma Loop_Invariant (Count <= Character'Pos (Char) + 1);
- pragma Loop_Invariant (Result (1 .. Count)'Initialized);
- pragma Loop_Invariant (for all K in 1 .. Count => Result (K) <= Char);
- pragma Loop_Invariant
- (SPARK_Proof_Sorted_Character_Sequence (Result (1 .. Count)));
- pragma Loop_Invariant
- (for all C in Set'First .. Char =>
- (Set (C) = (for some X of Result (1 .. Count) => C = X)));
- pragma Loop_Invariant
- (for all Char of Result (1 .. Count) => Is_In (Char, Set));
end loop;
return Result (1 .. Count);
@@ -541,19 +261,7 @@ is
for R in Ranges'Range loop
for C in Ranges (R).Low .. Ranges (R).High loop
Result (C) := True;
- pragma Loop_Invariant
- (for all Char in Character =>
- Result (Char) =
- ((for some Prev in Ranges'First .. R - 1 =>
- Char in Ranges (Prev).Low .. Ranges (Prev).High)
- or else Char in Ranges (R).Low .. C));
end loop;
-
- pragma Loop_Invariant
- (for all Char in Character =>
- Result (Char) =
- (for some Prev in Ranges'First .. R =>
- Char in Ranges (Prev).Low .. Ranges (Prev).High));
end loop;
return Result;
@@ -564,9 +272,6 @@ is
begin
for C in Span.Low .. Span.High loop
Result (C) := True;
- pragma Loop_Invariant
- (for all Char in Character =>
- Result (Char) = (Char in Span.Low .. C));
end loop;
return Result;
@@ -577,10 +282,6 @@ is
begin
for J in Sequence'Range loop
Result (Sequence (J)) := True;
- pragma Loop_Invariant
- (for all Char in Character =>
- Result (Char) =
- (for some K in Sequence'First .. J => Char = Sequence (K)));
end loop;
return Result;
@@ -599,8 +300,6 @@ is
function Value
(Map : Character_Mapping;
- Element : Character) return Character
- is
- (Map (Element));
+ Element : Character) return Character is (Map (Element));
end Ada.Strings.Maps;
diff --git a/gcc/ada/libgnat/a-strsea.adb b/gcc/ada/libgnat/a-strsea.adb
index 45fb682..55bf767 100644
--- a/gcc/ada/libgnat/a-strsea.adb
+++ b/gcc/ada/libgnat/a-strsea.adb
@@ -35,14 +35,6 @@
-- case of identity mappings for Count and Index, and also Index_Non_Blank
-- is specialized (rather than using the general Index routine).
--- Ghost code, loop invariants and assertions in this unit are meant for
--- analysis only, not for run-time checking, as it would be too costly
--- otherwise. This is enforced by setting the assertion policy to Ignore.
-
-pragma Assertion_Policy (Ghost => Ignore,
- Loop_Invariant => Ignore,
- Assert => Ignore);
-
with Ada.Strings.Maps; use Ada.Strings.Maps;
with System; use System;
@@ -110,10 +102,6 @@ package body Ada.Strings.Search with SPARK_Mode is
Num := Num + 1;
Ind := Ind + PL1;
end if;
-
- pragma Loop_Invariant (Num <= Ind - (Source'First - 1));
- pragma Loop_Invariant (Ind >= Source'First);
- pragma Loop_Variant (Increases => Ind);
end loop;
-- Mapped case
@@ -125,25 +113,15 @@ package body Ada.Strings.Search with SPARK_Mode is
if Pattern (K) /= Value (Mapping,
Source (Ind + (K - Pattern'First)))
then
- pragma Assert (not Match (Source, Pattern, Mapping, Ind));
goto Cont;
end if;
-
- pragma Loop_Invariant
- (for all J in Pattern'First .. K =>
- Pattern (J) = Value (Mapping,
- Source (Ind + (J - Pattern'First))));
end loop;
- pragma Assert (Match (Source, Pattern, Mapping, Ind));
Num := Num + 1;
Ind := Ind + PL1;
<<Cont>>
null;
- pragma Loop_Invariant (Num <= Ind - (Source'First - 1));
- pragma Loop_Invariant (Ind >= Source'First);
- pragma Loop_Variant (Increases => Ind);
end loop;
end if;
@@ -185,30 +163,15 @@ package body Ada.Strings.Search with SPARK_Mode is
Ind := Ind + 1;
for K in Pattern'Range loop
if Pattern (K) /= Mapping (Source (Ind + (K - Pattern'First))) then
- pragma Annotate (GNATprove, False_Positive,
- "call via access-to-subprogram",
- "function Mapping must always terminate");
- pragma Assert (not Match (Source, Pattern, Mapping, Ind));
goto Cont;
end if;
-
- pragma Loop_Invariant
- (for all J in Pattern'First .. K =>
- Pattern (J) = Mapping (Source (Ind + (J - Pattern'First))));
- pragma Annotate (GNATprove, False_Positive,
- "call via access-to-subprogram",
- "function Mapping must always terminate");
end loop;
- pragma Assert (Match (Source, Pattern, Mapping, Ind));
Num := Num + 1;
Ind := Ind + PL1;
<<Cont>>
null;
- pragma Loop_Invariant (Num <= Ind - (Source'First - 1));
- pragma Loop_Invariant (Ind >= Source'First);
- pragma Loop_Variant (Increases => Ind);
end loop;
return Num;
@@ -219,10 +182,8 @@ package body Ada.Strings.Search with SPARK_Mode is
Set : Maps.Character_Set) return Natural
is
N : Natural := 0;
-
begin
for J in Source'Range loop
- pragma Loop_Invariant (N <= J - Source'First);
if Is_In (Source (J), Set) then
N := N + 1;
end if;
@@ -241,8 +202,7 @@ package body Ada.Strings.Search with SPARK_Mode is
From : Positive;
Test : Membership;
First : out Positive;
- Last : out Natural)
- is
+ Last : out Natural) is
begin
-- AI05-031: Raise Index error if Source non-empty and From not in range
@@ -264,10 +224,6 @@ package body Ada.Strings.Search with SPARK_Mode is
Last := K - 1;
return;
end if;
-
- pragma Loop_Invariant
- (for all L in J .. K =>
- Belongs (Source (L), Set, Test));
end loop;
end if;
@@ -277,10 +233,6 @@ package body Ada.Strings.Search with SPARK_Mode is
Last := Source'Last;
return;
end if;
-
- pragma Loop_Invariant
- (for all K in Integer'Max (From, Source'First) .. J =>
- not Belongs (Source (K), Set, Test));
end loop;
-- Here if no token found
@@ -294,8 +246,7 @@ package body Ada.Strings.Search with SPARK_Mode is
Set : Maps.Character_Set;
Test : Membership;
First : out Positive;
- Last : out Natural)
- is
+ Last : out Natural) is
begin
for J in Source'Range loop
if Belongs (Source (J), Set, Test) then
@@ -307,10 +258,6 @@ package body Ada.Strings.Search with SPARK_Mode is
Last := K - 1;
return;
end if;
-
- pragma Loop_Invariant
- (for all L in J .. K =>
- Belongs (Source (L), Set, Test));
end loop;
end if;
@@ -320,10 +267,6 @@ package body Ada.Strings.Search with SPARK_Mode is
Last := Source'Last;
return;
end if;
-
- pragma Loop_Invariant
- (for all K in Source'First .. J =>
- not Belongs (Source (K), Set, Test));
end loop;
-- Here if no token found
@@ -335,7 +278,6 @@ package body Ada.Strings.Search with SPARK_Mode is
if Source'First not in Positive then
raise Constraint_Error;
-
else
First := Source'First;
Last := 0;
@@ -353,7 +295,6 @@ package body Ada.Strings.Search with SPARK_Mode is
Mapping : Maps.Character_Mapping := Maps.Identity) return Natural
is
PL1 : constant Integer := Pattern'Length - 1;
-
begin
if Pattern = "" then
raise Pattern_Error;
@@ -374,13 +315,8 @@ package body Ada.Strings.Search with SPARK_Mode is
if Is_Identity (Mapping) then
for Ind in Source'First .. Source'Last - PL1 loop
if Pattern = Source (Ind .. Ind + PL1) then
- pragma Assert (Match (Source, Pattern, Mapping, Ind));
return Ind;
end if;
-
- pragma Loop_Invariant
- (for all J in Source'First .. Ind =>
- not Match (Source, Pattern, Mapping, J));
end loop;
-- Mapped forward case
@@ -393,20 +329,11 @@ package body Ada.Strings.Search with SPARK_Mode is
then
goto Cont1;
end if;
-
- pragma Loop_Invariant
- (for all J in Pattern'First .. K =>
- Pattern (J) = Value (Mapping,
- Source (Ind + (J - Pattern'First))));
end loop;
- pragma Assert (Match (Source, Pattern, Mapping, Ind));
return Ind;
<<Cont1>>
- pragma Loop_Invariant
- (for all J in Source'First .. Ind =>
- not Match (Source, Pattern, Mapping, J));
null;
end loop;
end if;
@@ -419,13 +346,8 @@ package body Ada.Strings.Search with SPARK_Mode is
if Is_Identity (Mapping) then
for Ind in reverse Source'First .. Source'Last - PL1 loop
if Pattern = Source (Ind .. Ind + PL1) then
- pragma Assert (Match (Source, Pattern, Mapping, Ind));
return Ind;
end if;
-
- pragma Loop_Invariant
- (for all J in Ind .. Source'Last - PL1 =>
- not Match (Source, Pattern, Mapping, J));
end loop;
-- Mapped backward case
@@ -438,20 +360,11 @@ package body Ada.Strings.Search with SPARK_Mode is
then
goto Cont2;
end if;
-
- pragma Loop_Invariant
- (for all J in Pattern'First .. K =>
- Pattern (J) = Value (Mapping,
- Source (Ind + (J - Pattern'First))));
end loop;
- pragma Assert (Match (Source, Pattern, Mapping, Ind));
return Ind;
<<Cont2>>
- pragma Loop_Invariant
- (for all J in Ind .. Source'Last - PL1 =>
- not Match (Source, Pattern, Mapping, J));
null;
end loop;
end if;
@@ -495,27 +408,17 @@ package body Ada.Strings.Search with SPARK_Mode is
if Pattern (K) /= Mapping.all
(Source (Ind + (K - Pattern'First)))
then
- pragma Annotate (GNATprove, False_Positive,
- "call via access-to-subprogram",
- "function Mapping must always terminate");
goto Cont1;
end if;
pragma Loop_Invariant
(for all J in Pattern'First .. K =>
Pattern (J) = Mapping (Source (Ind + (J - Pattern'First))));
- pragma Annotate (GNATprove, False_Positive,
- "call via access-to-subprogram",
- "function Mapping must always terminate");
end loop;
- pragma Assert (Match (Source, Pattern, Mapping, Ind));
return Ind;
<<Cont1>>
- pragma Loop_Invariant
- (for all J in Source'First .. Ind =>
- not Match (Source, Pattern, Mapping, J));
null;
end loop;
@@ -527,26 +430,13 @@ package body Ada.Strings.Search with SPARK_Mode is
if Pattern (K) /= Mapping.all
(Source (Ind + (K - Pattern'First)))
then
- pragma Annotate (GNATprove, False_Positive,
- "call via access-to-subprogram",
- "function Mapping must always terminate");
goto Cont2;
end if;
-
- pragma Loop_Invariant
- (for all J in Pattern'First .. K =>
- Pattern (J) = Mapping (Source (Ind + (J - Pattern'First))));
- pragma Annotate (GNATprove, False_Positive,
- "call via access-to-subprogram",
- "function Mapping must always terminate");
end loop;
return Ind;
<<Cont2>>
- pragma Loop_Invariant
- (for all J in Ind .. Source'Last - PL1 =>
- not Match (Source, Pattern, Mapping, J));
null;
end loop;
end if;
@@ -561,8 +451,7 @@ package body Ada.Strings.Search with SPARK_Mode is
(Source : String;
Set : Maps.Character_Set;
Test : Membership := Inside;
- Going : Direction := Forward) return Natural
- is
+ Going : Direction := Forward) return Natural is
begin
-- Forwards case
@@ -571,10 +460,6 @@ package body Ada.Strings.Search with SPARK_Mode is
if Belongs (Source (J), Set, Test) then
return J;
end if;
-
- pragma Loop_Invariant
- (for all C of Source (Source'First .. J) =>
- not Belongs (C, Set, Test));
end loop;
-- Backwards case
@@ -584,10 +469,6 @@ package body Ada.Strings.Search with SPARK_Mode is
if Belongs (Source (J), Set, Test) then
return J;
end if;
-
- pragma Loop_Invariant
- (for all C of Source (J .. Source'Last) =>
- not Belongs (C, Set, Test));
end loop;
end if;
@@ -604,7 +485,6 @@ package body Ada.Strings.Search with SPARK_Mode is
Mapping : Maps.Character_Mapping := Maps.Identity) return Natural
is
Result : Natural;
- PL1 : constant Integer := Pattern'Length - 1;
begin
-- AI05-056: If source is empty result is always zero
@@ -619,12 +499,6 @@ package body Ada.Strings.Search with SPARK_Mode is
Result :=
Index (Source (From .. Source'Last), Pattern, Forward, Mapping);
- pragma Assert
- (if (for some J in From .. Source'Last - PL1 =>
- Match (Source, Pattern, Mapping, J))
- then Result in From .. Source'Last - PL1
- and then Match (Source, Pattern, Mapping, Result)
- else Result = 0);
else
if From > Source'Last then
@@ -633,12 +507,6 @@ package body Ada.Strings.Search with SPARK_Mode is
Result :=
Index (Source (Source'First .. From), Pattern, Backward, Mapping);
- pragma Assert
- (if (for some J in Source'First .. From - PL1 =>
- Match (Source, Pattern, Mapping, J))
- then Result in Source'First .. From - PL1
- and then Match (Source, Pattern, Mapping, Result)
- else Result = 0);
end if;
return Result;
@@ -722,9 +590,6 @@ package body Ada.Strings.Search with SPARK_Mode is
if Source (J) /= ' ' then
return J;
end if;
-
- pragma Loop_Invariant
- (for all C of Source (Source'First .. J) => C = ' ');
end loop;
else -- Going = Backward
@@ -732,9 +597,6 @@ package body Ada.Strings.Search with SPARK_Mode is
if Source (J) /= ' ' then
return J;
end if;
-
- pragma Loop_Invariant
- (for all C of Source (J .. Source'Last) => C = ' ');
end loop;
end if;
diff --git a/gcc/ada/libgnat/a-strsup.adb b/gcc/ada/libgnat/a-strsup.adb
index 6540924..8afde71 100644
--- a/gcc/ada/libgnat/a-strsup.adb
+++ b/gcc/ada/libgnat/a-strsup.adb
@@ -29,15 +29,6 @@
-- --
------------------------------------------------------------------------------
--- Ghost code, loop (in)variants and assertions in this unit are meant for
--- analysis only, not for run-time checking, as it would be too costly
--- otherwise. This is enforced by setting the assertion policy to Ignore.
-
-pragma Assertion_Policy (Ghost => Ignore,
- Loop_Invariant => Ignore,
- Loop_Variant => Ignore,
- Assert => Ignore);
-
with Ada.Strings.Maps; use Ada.Strings.Maps;
package body Ada.Strings.Superbounded with SPARK_Mode is
@@ -1438,91 +1429,6 @@ package body Ada.Strings.Superbounded with SPARK_Mode is
Indx : Natural;
Ilen : constant Natural := Item'Length;
- -- Parts of the proof involving manipulations with the modulo operator
- -- are complicated for the prover and can't be done automatically in
- -- the global subprogram. That's why we isolate them in these two ghost
- -- lemmas.
-
- procedure Lemma_Mod (K : Natural; Q : Natural) with
- Ghost,
- Pre => Ilen /= 0
- and then Q mod Ilen = 0
- and then K - Q in 0 .. Ilen - 1,
- Post => K mod Ilen = K - Q;
- -- Lemma_Mod is applied to an index considered in Lemma_Split to prove
- -- that it has the right value modulo Item'Length.
-
- procedure Lemma_Mod_Zero (X : Natural) with
- Ghost,
- Pre => Ilen /= 0
- and then X mod Ilen = 0
- and then X <= Natural'Last - Ilen,
- Post => (X + Ilen) mod Ilen = 0;
- -- Lemma_Mod_Zero is applied to prove that the length of the range
- -- of indexes considered in the loop, when dropping on the Left, is
- -- a multiple of Item'Length.
-
- procedure Lemma_Split (Going : Direction) with
- Ghost,
- Pre =>
- Ilen /= 0
- and then Indx in 0 .. Max_Length - Ilen
- and then
- (if Going = Forward
- then Indx mod Ilen = 0
- else (Max_Length - Indx - Ilen) mod Ilen = 0)
- and then Result.Data (Indx + 1 .. Indx + Ilen)'Initialized
- and then String (Result.Data (Indx + 1 .. Indx + Ilen)) = Item,
- Post =>
- (if Going = Forward then
- (for all J in Indx + 1 .. Indx + Ilen =>
- Result.Data (J) = Item (Item'First + (J - 1) mod Ilen))
- else
- (for all J in Indx + 1 .. Indx + Ilen =>
- Result.Data (J) =
- Item (Item'Last - (Max_Length - J) mod Ilen)));
- -- Lemma_Split is used after Result.Data (Indx + 1 .. Indx + Ilen) is
- -- updated to Item and concludes that the characters match for each
- -- index when taken modulo Item'Length, as the considered slice starts
- -- at index 1 (or ends at index Max_Length, if Going = Backward) modulo
- -- Item'Length.
-
- ---------------
- -- Lemma_Mod --
- ---------------
-
- procedure Lemma_Mod (K : Natural; Q : Natural) is null;
-
- --------------------
- -- Lemma_Mod_Zero --
- --------------------
-
- procedure Lemma_Mod_Zero (X : Natural) is null;
-
- -----------------
- -- Lemma_Split --
- -----------------
-
- procedure Lemma_Split (Going : Direction) is
- begin
- if Going = Forward then
- for K in Indx + 1 .. Indx + Ilen loop
- Lemma_Mod (K - 1, Indx);
- pragma Loop_Invariant
- (for all J in Indx + 1 .. K =>
- Result.Data (J) = Item (Item'First + (J - 1) mod Ilen));
- end loop;
- else
- for K in Indx + 1 .. Indx + Ilen loop
- Lemma_Mod (Max_Length - K, Max_Length - Indx - Ilen);
- pragma Loop_Invariant
- (for all J in Indx + 1 .. K =>
- Result.Data (J) =
- Item (Item'Last - (Max_Length - J) mod Ilen));
- end loop;
- end if;
- end Lemma_Split;
-
begin
if Count = 0 or else Ilen <= Max_Length / Count then
if Count * Ilen > 0 then
@@ -1531,19 +1437,7 @@ package body Ada.Strings.Superbounded with SPARK_Mode is
for J in 1 .. Count loop
Result.Data (Indx + 1 .. Indx + Ilen) :=
Super_String_Data (Item);
- pragma Assert
- (for all K in 1 .. Ilen =>
- Result.Data (Indx + K) = Item (Item'First - 1 + K));
- pragma Assert
- (String (Result.Data (Indx + 1 .. Indx + Ilen)) = Item);
- Lemma_Split (Forward);
Indx := Indx + Ilen;
- pragma Loop_Invariant (Indx = J * Ilen);
- pragma Loop_Invariant (Result.Data (1 .. Indx)'Initialized);
- pragma Loop_Invariant
- (for all K in 1 .. Indx =>
- Result.Data (K) =
- Item (Item'First + (K - 1) mod Ilen));
end loop;
end if;
@@ -1557,36 +1451,11 @@ package body Ada.Strings.Superbounded with SPARK_Mode is
while Indx < Max_Length - Ilen loop
Result.Data (Indx + 1 .. Indx + Ilen) :=
Super_String_Data (Item);
- pragma Assert
- (for all K in 1 .. Ilen =>
- Result.Data (Indx + K) = Item (Item'First - 1 + K));
- pragma Assert
- (String (Result.Data (Indx + 1 .. Indx + Ilen)) = Item);
- Lemma_Split (Forward);
Indx := Indx + Ilen;
- pragma Loop_Invariant (Indx mod Ilen = 0);
- pragma Loop_Invariant (Indx in 0 .. Max_Length - 1);
- pragma Loop_Invariant (Result.Data (1 .. Indx)'Initialized);
- pragma Loop_Invariant
- (for all K in 1 .. Indx =>
- Result.Data (K) =
- Item (Item'First + (K - 1) mod Ilen));
- pragma Loop_Variant (Increases => Indx);
end loop;
Result.Data (Indx + 1 .. Max_Length) := Super_String_Data
(Item (Item'First .. Item'First + (Max_Length - Indx - 1)));
- pragma Assert
- (for all J in Indx + 1 .. Max_Length =>
- Result.Data (J) = Item (Item'First - 1 - Indx + J));
-
- for J in Indx + 1 .. Max_Length loop
- Lemma_Mod (J - 1, Indx);
- pragma Loop_Invariant
- (for all K in 1 .. J =>
- Result.Data (K) =
- Item (Item'First + (K - 1) mod Ilen));
- end loop;
when Strings.Left =>
Indx := Max_Length;
@@ -1595,40 +1464,10 @@ package body Ada.Strings.Superbounded with SPARK_Mode is
Indx := Indx - Ilen;
Result.Data (Indx + 1 .. Indx + Ilen) :=
Super_String_Data (Item);
- pragma Assert
- (for all K in 1 .. Ilen =>
- Result.Data (Indx + K) = Item (Item'First - 1 + K));
- pragma Assert
- (String (Result.Data (Indx + 1 .. Indx + Ilen)) = Item);
- Lemma_Split (Backward);
- Lemma_Mod_Zero (Max_Length - Indx - Ilen);
- pragma Loop_Invariant
- ((Max_Length - Indx) mod Ilen = 0);
- pragma Loop_Invariant (Indx in 1 .. Max_Length);
- pragma Loop_Invariant
- (Result.Data (Indx + 1 .. Max_Length)'Initialized);
- pragma Loop_Invariant
- (for all K in Indx + 1 .. Max_Length =>
- Result.Data (K) =
- Item (Item'Last - (Max_Length - K) mod Ilen));
- pragma Loop_Variant (Decreases => Indx);
end loop;
Result.Data (1 .. Indx) :=
Super_String_Data (Item (Item'Last - Indx + 1 .. Item'Last));
- pragma Assert
- (for all J in 1 .. Indx =>
- Result.Data (J) = Item (Item'Last - Indx + J));
-
- for J in reverse 1 .. Indx loop
- Lemma_Mod (Max_Length - J, Max_Length - Indx);
- pragma Loop_Invariant
- (for all K in J .. Max_Length =>
- Result.Data (K) =
- Item (Item'Last - (Max_Length - K) mod Ilen));
- end loop;
- pragma Assert
- (Result.Data (1 .. Max_Length)'Initialized);
when Strings.Error =>
raise Ada.Strings.Length_Error;
@@ -1643,8 +1482,7 @@ package body Ada.Strings.Superbounded with SPARK_Mode is
function Super_Replicate
(Count : Natural;
Item : Super_String;
- Drop : Strings.Truncation := Strings.Error) return Super_String
- is
+ Drop : Strings.Truncation := Strings.Error) return Super_String is
begin
return
Super_Replicate (Count, Super_To_String (Item), Drop, Item.Max_Length);
@@ -1820,14 +1658,9 @@ package body Ada.Strings.Superbounded with SPARK_Mode is
Mapping : Maps.Character_Mapping) return Super_String
is
Result : Super_String (Source.Max_Length);
-
begin
for J in 1 .. Source.Current_Length loop
Result.Data (J) := Value (Mapping, Source.Data (J));
- pragma Loop_Invariant (Result.Data (1 .. J)'Initialized);
- pragma Loop_Invariant
- (for all K in 1 .. J =>
- Result.Data (K) = Value (Mapping, Source.Data (K)));
end loop;
Result.Current_Length := Source.Current_Length;
@@ -1836,14 +1669,10 @@ package body Ada.Strings.Superbounded with SPARK_Mode is
procedure Super_Translate
(Source : in out Super_String;
- Mapping : Maps.Character_Mapping)
- is
+ Mapping : Maps.Character_Mapping) is
begin
for J in 1 .. Source.Current_Length loop
Source.Data (J) := Value (Mapping, Source.Data (J));
- pragma Loop_Invariant
- (for all K in 1 .. J =>
- Source.Data (K) = Value (Mapping, Source'Loop_Entry.Data (K)));
end loop;
end Super_Translate;
@@ -1852,20 +1681,9 @@ package body Ada.Strings.Superbounded with SPARK_Mode is
Mapping : Maps.Character_Mapping_Function) return Super_String
is
Result : Super_String (Source.Max_Length);
-
begin
for J in 1 .. Source.Current_Length loop
Result.Data (J) := Mapping.all (Source.Data (J));
- pragma Annotate (GNATprove, False_Positive,
- "call via access-to-subprogram",
- "function Mapping must always terminate");
- pragma Loop_Invariant (Result.Data (1 .. J)'Initialized);
- pragma Loop_Invariant
- (for all K in 1 .. J =>
- Result.Data (K) = Mapping (Source.Data (K)));
- pragma Annotate (GNATprove, False_Positive,
- "call via access-to-subprogram",
- "function Mapping must always terminate");
end loop;
Result.Current_Length := Source.Current_Length;
@@ -1874,20 +1692,10 @@ package body Ada.Strings.Superbounded with SPARK_Mode is
procedure Super_Translate
(Source : in out Super_String;
- Mapping : Maps.Character_Mapping_Function)
- is
+ Mapping : Maps.Character_Mapping_Function) is
begin
for J in 1 .. Source.Current_Length loop
Source.Data (J) := Mapping.all (Source.Data (J));
- pragma Annotate (GNATprove, False_Positive,
- "call via access-to-subprogram",
- "function Mapping must always terminate");
- pragma Loop_Invariant
- (for all K in 1 .. J =>
- Source.Data (K) = Mapping (Source'Loop_Entry.Data (K)));
- pragma Annotate (GNATprove, False_Positive,
- "call via access-to-subprogram",
- "function Mapping must always terminate");
end loop;
end Super_Translate;
@@ -1901,7 +1709,6 @@ package body Ada.Strings.Superbounded with SPARK_Mode is
is
Result : Super_String (Source.Max_Length);
Last : constant Natural := Source.Current_Length;
-
begin
case Side is
when Strings.Left =>
@@ -2101,13 +1908,9 @@ package body Ada.Strings.Superbounded with SPARK_Mode is
begin
if Left > Max_Length then
raise Ada.Strings.Length_Error;
-
else
for J in 1 .. Left loop
Result.Data (J) := Right;
- pragma Loop_Invariant (Result.Data (1 .. J)'Initialized);
- pragma Loop_Invariant
- (for all K in 1 .. J => Result.Data (K) = Right);
end loop;
Result.Current_Length := Left;
@@ -2126,80 +1929,15 @@ package body Ada.Strings.Superbounded with SPARK_Mode is
Rlen : constant Natural := Right'Length;
Nlen : constant Natural := Left * Rlen;
- -- Parts of the proof involving manipulations with the modulo operator
- -- are complicated for the prover and can't be done automatically in
- -- the global subprogram. That's why we isolate them in these two ghost
- -- lemmas.
-
- procedure Lemma_Mod (K : Integer) with
- Ghost,
- Pre =>
- Rlen /= 0
- and then Pos mod Rlen = 0
- and then Pos in 0 .. Max_Length - Rlen
- and then K in Pos .. Pos + Rlen - 1,
- Post => K mod Rlen = K - Pos;
- -- Lemma_Mod is applied to an index considered in Lemma_Split to prove
- -- that it has the right value modulo Right'Length.
-
- procedure Lemma_Split with
- Ghost,
- Pre =>
- Rlen /= 0
- and then Pos mod Rlen = 0
- and then Pos in 0 .. Max_Length - Rlen
- and then Result.Data (1 .. Pos + Rlen)'Initialized
- and then String (Result.Data (Pos + 1 .. Pos + Rlen)) = Right,
- Post =>
- (for all K in Pos + 1 .. Pos + Rlen =>
- Result.Data (K) = Right (Right'First + (K - 1) mod Rlen));
- -- Lemma_Split is used after Result.Data (Pos + 1 .. Pos + Rlen) is
- -- updated to Right and concludes that the characters match for each
- -- index when taken modulo Right'Length, as the considered slice starts
- -- at index 1 modulo Right'Length.
-
- ---------------
- -- Lemma_Mod --
- ---------------
-
- procedure Lemma_Mod (K : Integer) is null;
-
- -----------------
- -- Lemma_Split --
- -----------------
-
- procedure Lemma_Split is
- begin
- for K in Pos + 1 .. Pos + Rlen loop
- Lemma_Mod (K - 1);
- pragma Loop_Invariant
- (for all J in Pos + 1 .. K =>
- Result.Data (J) = Right (Right'First + (J - 1) mod Rlen));
- end loop;
- end Lemma_Split;
-
begin
if Nlen > Max_Length then
raise Ada.Strings.Length_Error;
-
else
if Nlen > 0 then
for J in 1 .. Left loop
Result.Data (Pos + 1 .. Pos + Rlen) :=
Super_String_Data (Right);
- pragma Assert
- (for all K in 1 .. Rlen => Result.Data (Pos + K) =
- Right (Right'First - 1 + K));
- pragma Assert
- (String (Result.Data (Pos + 1 .. Pos + Rlen)) = Right);
- Lemma_Split;
Pos := Pos + Rlen;
- pragma Loop_Invariant (Pos = J * Rlen);
- pragma Loop_Invariant (Result.Data (1 .. Pos)'Initialized);
- pragma Loop_Invariant
- (for all K in 1 .. Pos =>
- Result.Data (K) =
- Right (Right'First + (K - 1) mod Rlen));
end loop;
end if;
@@ -2221,19 +1959,12 @@ package body Ada.Strings.Superbounded with SPARK_Mode is
begin
if Nlen > Right.Max_Length then
raise Ada.Strings.Length_Error;
-
else
if Nlen > 0 then
for J in 1 .. Left loop
Result.Data (Pos + 1 .. Pos + Rlen) :=
Right.Data (1 .. Rlen);
Pos := Pos + Rlen;
- pragma Loop_Invariant (Pos = J * Rlen);
- pragma Loop_Invariant (Result.Data (1 .. Pos)'Initialized);
- pragma Loop_Invariant
- (for all K in 1 .. Pos =>
- Result.Data (K) =
- Right.Data (1 + (K - 1) mod Rlen));
end loop;
end if;
@@ -2259,7 +1990,6 @@ package body Ada.Strings.Superbounded with SPARK_Mode is
if Slen <= Max_Length then
Result.Data (1 .. Slen) := Super_String_Data (Source);
Result.Current_Length := Slen;
-
else
case Drop is
when Strings.Right =>
diff --git a/gcc/ada/libgnat/a-strsup.ads b/gcc/ada/libgnat/a-strsup.ads
index 65d13ed..68098ea 100644
--- a/gcc/ada/libgnat/a-strsup.ads
+++ b/gcc/ada/libgnat/a-strsup.ads
@@ -42,10 +42,11 @@
-- contract cases should not be executed at runtime as well, in order not to
-- slow down the execution of these functions.
-pragma Assertion_Policy (Pre => Ignore,
- Post => Ignore,
- Contract_Cases => Ignore,
- Ghost => Ignore);
+pragma Assertion_Policy (Pre => Ignore,
+ Post => Ignore,
+ Contract_Cases => Ignore,
+ Ghost => Ignore,
+ Ghost_Predicate => Ignore);
with Ada.Strings.Maps; use type Ada.Strings.Maps.Character_Mapping_Function;
with Ada.Strings.Search;
diff --git a/gcc/ada/libgnat/g-dyntab.ads b/gcc/ada/libgnat/g-dyntab.ads
index 7e2e3b2..7810986 100644
--- a/gcc/ada/libgnat/g-dyntab.ads
+++ b/gcc/ada/libgnat/g-dyntab.ads
@@ -168,8 +168,9 @@ package GNAT.Dynamic_Tables is
--
-- Tab : Table_Type renames X.Table (First .. X.Last);
--
- -- Note: The Table component must come first. See declarations of
- -- SCO_Unit_Table and SCO_Table in scos.h.
+ -- Note: The Table component must come first to simplify interfacing
+ -- with C, similar to how we do it for the Table unit; see declarations
+ -- of Names_Ptr and Names_Char_Ptr in namet.h.
Locked : Boolean := False;
-- Table reallocation is permitted only if this is False. A client may
diff --git a/gcc/ada/libgnat/i-c.adb b/gcc/ada/libgnat/i-c.adb
index d248ceb..e63c014 100644
--- a/gcc/ada/libgnat/i-c.adb
+++ b/gcc/ada/libgnat/i-c.adb
@@ -29,78 +29,10 @@
-- --
------------------------------------------------------------------------------
--- Ghost code, loop invariants and assertions in this unit are meant for
--- analysis only, not for run-time checking, as it would be too costly
--- otherwise. This is enforced by setting the assertion policy to Ignore.
-
-pragma Assertion_Policy (Ghost => Ignore,
- Loop_Invariant => Ignore,
- Assert => Ignore);
-
package body Interfaces.C
with SPARK_Mode
is
- --------------------
- -- C_Length_Ghost --
- --------------------
-
- function C_Length_Ghost (Item : char_array) return size_t is
- begin
- for J in Item'Range loop
- if Item (J) = nul then
- return J - Item'First;
- end if;
-
- pragma Loop_Invariant
- (for all K in Item'First .. J => Item (K) /= nul);
- end loop;
-
- raise Program_Error;
- end C_Length_Ghost;
-
- function C_Length_Ghost (Item : wchar_array) return size_t is
- begin
- for J in Item'Range loop
- if Item (J) = wide_nul then
- return J - Item'First;
- end if;
-
- pragma Loop_Invariant
- (for all K in Item'First .. J => Item (K) /= wide_nul);
- end loop;
-
- raise Program_Error;
- end C_Length_Ghost;
-
- function C_Length_Ghost (Item : char16_array) return size_t is
- begin
- for J in Item'Range loop
- if Item (J) = char16_nul then
- return J - Item'First;
- end if;
-
- pragma Loop_Invariant
- (for all K in Item'First .. J => Item (K) /= char16_nul);
- end loop;
-
- raise Program_Error;
- end C_Length_Ghost;
-
- function C_Length_Ghost (Item : char32_array) return size_t is
- begin
- for J in Item'Range loop
- if Item (J) = char32_nul then
- return J - Item'First;
- end if;
-
- pragma Loop_Invariant
- (for all K in Item'First .. J => Item (K) /= char32_nul);
- end loop;
-
- raise Program_Error;
- end C_Length_Ghost;
-
-----------------------
-- Is_Nul_Terminated --
-----------------------
@@ -113,9 +45,6 @@ is
if Item (J) = nul then
return True;
end if;
-
- pragma Loop_Invariant
- (for all K in Item'First .. J => Item (K) /= nul);
end loop;
return False;
@@ -129,9 +58,6 @@ is
if Item (J) = wide_nul then
return True;
end if;
-
- pragma Loop_Invariant
- (for all K in Item'First .. J => Item (K) /= wide_nul);
end loop;
return False;
@@ -145,9 +71,6 @@ is
if Item (J) = char16_nul then
return True;
end if;
-
- pragma Loop_Invariant
- (for all K in Item'First .. J => Item (K) /= char16_nul);
end loop;
return False;
@@ -161,9 +84,6 @@ is
if Item (J) = char32_nul then
return True;
end if;
-
- pragma Loop_Invariant
- (for all K in Item'First .. J => Item (K) /= char32_nul);
end loop;
return False;
@@ -194,14 +114,6 @@ is
From := Item'First;
loop
- pragma Loop_Invariant (From in Item'Range);
- pragma Loop_Invariant
- (for some J in From .. Item'Last => Item (J) = nul);
- pragma Loop_Invariant
- (for all J in Item'First .. From when J /= From =>
- Item (J) /= nul);
- pragma Loop_Variant (Increases => From);
-
if From > Item'Last then
raise Terminator_Error;
elsif Item (From) = nul then
@@ -211,8 +123,6 @@ is
end if;
end loop;
- pragma Assert (From = Item'First + C_Length_Ghost (Item));
-
Count := Natural (From - Item'First);
else
@@ -220,17 +130,10 @@ is
end if;
declare
- Count_Cst : constant Natural := Count;
- R : String (1 .. Count_Cst) with Relaxed_Initialization;
-
+ R : String (1 .. Count);
begin
for J in R'Range loop
R (J) := To_Ada (Item (size_t (J) - 1 + Item'First));
-
- pragma Loop_Invariant (for all K in 1 .. J => R (K)'Initialized);
- pragma Loop_Invariant
- (for all K in 1 .. J =>
- R (K) = To_Ada (Item (size_t (K) - 1 + Item'First)));
end loop;
return R;
@@ -252,14 +155,6 @@ is
if Trim_Nul then
From := Item'First;
loop
- pragma Loop_Invariant (From in Item'Range);
- pragma Loop_Invariant
- (for some J in From .. Item'Last => Item (J) = nul);
- pragma Loop_Invariant
- (for all J in Item'First .. From when J /= From =>
- Item (J) /= nul);
- pragma Loop_Variant (Increases => From);
-
if From > Item'Last then
raise Terminator_Error;
elsif Item (From) = nul then
@@ -285,19 +180,6 @@ is
for J in 1 .. Count loop
Target (To) := Character (Item (From));
- pragma Loop_Invariant (From in Item'Range);
- pragma Loop_Invariant (To in Target'Range);
- pragma Loop_Invariant (To = Target'First + (J - 1));
- pragma Loop_Invariant (From = Item'First + size_t (J - 1));
- pragma Loop_Invariant
- (for all J in Target'First .. To => Target (J)'Initialized);
- pragma Loop_Invariant
- (Target (Target'First .. To)'Initialized);
- pragma Loop_Invariant
- (for all K in Target'First .. To =>
- Target (K) =
- To_Ada (Item (size_t (K - Target'First) + Item'First)));
-
-- Avoid possible overflow when incrementing To in the last
-- iteration of the loop.
exit when J = Count;
@@ -329,14 +211,6 @@ is
From := Item'First;
loop
- pragma Loop_Invariant (From in Item'Range);
- pragma Loop_Invariant
- (for some J in From .. Item'Last => Item (J) = wide_nul);
- pragma Loop_Invariant
- (for all J in Item'First .. From when J /= From =>
- Item (J) /= wide_nul);
- pragma Loop_Variant (Increases => From);
-
if From > Item'Last then
raise Terminator_Error;
elsif Item (From) = wide_nul then
@@ -346,8 +220,6 @@ is
end if;
end loop;
- pragma Assert (From = Item'First + C_Length_Ghost (Item));
-
Count := Natural (From - Item'First);
else
@@ -355,17 +227,10 @@ is
end if;
declare
- Count_Cst : constant Natural := Count;
- R : Wide_String (1 .. Count_Cst) with Relaxed_Initialization;
-
+ R : Wide_String (1 .. Count);
begin
for J in R'Range loop
R (J) := To_Ada (Item (size_t (J) - 1 + Item'First));
-
- pragma Loop_Invariant (for all K in 1 .. J => R (K)'Initialized);
- pragma Loop_Invariant
- (for all K in 1 .. J =>
- R (K) = To_Ada (Item (size_t (K) - 1 + Item'First)));
end loop;
return R;
@@ -387,14 +252,6 @@ is
if Trim_Nul then
From := Item'First;
loop
- pragma Loop_Invariant (From in Item'Range);
- pragma Loop_Invariant
- (for some J in From .. Item'Last => Item (J) = wide_nul);
- pragma Loop_Invariant
- (for all J in Item'First .. From when J /= From =>
- Item (J) /= wide_nul);
- pragma Loop_Variant (Increases => From);
-
if From > Item'Last then
raise Terminator_Error;
elsif Item (From) = wide_nul then
@@ -420,19 +277,6 @@ is
for J in 1 .. Count loop
Target (To) := To_Ada (Item (From));
- pragma Loop_Invariant (From in Item'Range);
- pragma Loop_Invariant (To in Target'Range);
- pragma Loop_Invariant (To = Target'First + (J - 1));
- pragma Loop_Invariant (From = Item'First + size_t (J - 1));
- pragma Loop_Invariant
- (for all J in Target'First .. To => Target (J)'Initialized);
- pragma Loop_Invariant
- (Target (Target'First .. To)'Initialized);
- pragma Loop_Invariant
- (for all K in Target'First .. To =>
- Target (K) =
- To_Ada (Item (size_t (K - Target'First) + Item'First)));
-
-- Avoid possible overflow when incrementing To in the last
-- iteration of the loop.
exit when J = Count;
@@ -464,14 +308,6 @@ is
From := Item'First;
loop
- pragma Loop_Invariant (From in Item'Range);
- pragma Loop_Invariant
- (for some J in From .. Item'Last => Item (J) = char16_nul);
- pragma Loop_Invariant
- (for all J in Item'First .. From when J /= From =>
- Item (J) /= char16_nul);
- pragma Loop_Variant (Increases => From);
-
if From > Item'Last then
raise Terminator_Error;
elsif Item (From) = char16_nul then
@@ -481,8 +317,6 @@ is
end if;
end loop;
- pragma Assert (From = Item'First + C_Length_Ghost (Item));
-
Count := Natural (From - Item'First);
else
@@ -490,17 +324,10 @@ is
end if;
declare
- Count_Cst : constant Natural := Count;
- R : Wide_String (1 .. Count_Cst) with Relaxed_Initialization;
-
+ R : Wide_String (1 .. Count);
begin
for J in R'Range loop
R (J) := To_Ada (Item (size_t (J) - 1 + Item'First));
-
- pragma Loop_Invariant (for all K in 1 .. J => R (K)'Initialized);
- pragma Loop_Invariant
- (for all K in 1 .. J =>
- R (K) = To_Ada (Item (size_t (K) - 1 + Item'First)));
end loop;
return R;
@@ -522,14 +349,6 @@ is
if Trim_Nul then
From := Item'First;
loop
- pragma Loop_Invariant (From in Item'Range);
- pragma Loop_Invariant
- (for some J in From .. Item'Last => Item (J) = char16_nul);
- pragma Loop_Invariant
- (for all J in Item'First .. From when J /= From =>
- Item (J) /= char16_nul);
- pragma Loop_Variant (Increases => From);
-
if From > Item'Last then
raise Terminator_Error;
elsif Item (From) = char16_nul then
@@ -555,19 +374,6 @@ is
for J in 1 .. Count loop
Target (To) := To_Ada (Item (From));
- pragma Loop_Invariant (From in Item'Range);
- pragma Loop_Invariant (To in Target'Range);
- pragma Loop_Invariant (To = Target'First + (J - 1));
- pragma Loop_Invariant (From = Item'First + size_t (J - 1));
- pragma Loop_Invariant
- (for all J in Target'First .. To => Target (J)'Initialized);
- pragma Loop_Invariant
- (Target (Target'First .. To)'Initialized);
- pragma Loop_Invariant
- (for all K in Target'First .. To =>
- Target (K) =
- To_Ada (Item (size_t (K - Target'First) + Item'First)));
-
-- Avoid possible overflow when incrementing To in the last
-- iteration of the loop.
exit when J = Count;
@@ -599,15 +405,6 @@ is
From := Item'First;
loop
- pragma Loop_Invariant (From in Item'Range);
- pragma Loop_Invariant
- (for some J in From .. Item'Last => Item (J) = char32_nul);
- pragma Loop_Invariant
- (for all J in Item'First .. From when J /= From =>
- Item (J) /= char32_nul);
- pragma Loop_Invariant (From <= Item'First + C_Length_Ghost (Item));
- pragma Loop_Variant (Increases => From);
-
if From > Item'Last then
raise Terminator_Error;
elsif Item (From) = char32_nul then
@@ -617,8 +414,6 @@ is
end if;
end loop;
- pragma Assert (From = Item'First + C_Length_Ghost (Item));
-
Count := Natural (From - Item'First);
else
@@ -626,17 +421,11 @@ is
end if;
declare
- Count_Cst : constant Natural := Count;
- R : Wide_Wide_String (1 .. Count_Cst) with Relaxed_Initialization;
+ R : Wide_Wide_String (1 .. Count);
begin
for J in R'Range loop
R (J) := To_Ada (Item (size_t (J) - 1 + Item'First));
-
- pragma Loop_Invariant (for all K in 1 .. J => R (K)'Initialized);
- pragma Loop_Invariant
- (for all K in 1 .. J =>
- R (K) = To_Ada (Item (size_t (K) - 1 + Item'First)));
end loop;
return R;
@@ -658,14 +447,6 @@ is
if Trim_Nul then
From := Item'First;
loop
- pragma Loop_Invariant (From in Item'Range);
- pragma Loop_Invariant
- (for some J in From .. Item'Last => Item (J) = char32_nul);
- pragma Loop_Invariant
- (for all J in Item'First .. From when J /= From =>
- Item (J) /= char32_nul);
- pragma Loop_Variant (Increases => From);
-
if From > Item'Last then
raise Terminator_Error;
elsif Item (From) = char32_nul then
@@ -691,19 +472,6 @@ is
for J in 1 .. Count loop
Target (To) := To_Ada (Item (From));
- pragma Loop_Invariant (From in Item'Range);
- pragma Loop_Invariant (To in Target'Range);
- pragma Loop_Invariant (To = Target'First + (J - 1));
- pragma Loop_Invariant (From = Item'First + size_t (J - 1));
- pragma Loop_Invariant
- (for all J in Target'First .. To => Target (J)'Initialized);
- pragma Loop_Invariant
- (Target (Target'First .. To)'Initialized);
- pragma Loop_Invariant
- (for all K in Target'First .. To =>
- Target (K) =
- To_Ada (Item (size_t (K - Target'First) + Item'First)));
-
-- Avoid possible overflow when incrementing To in the last
-- iteration of the loop.
exit when J = Count;
@@ -734,26 +502,14 @@ is
begin
if Append_Nul then
declare
- R : char_array (0 .. Item'Length) with Relaxed_Initialization;
-
+ R : char_array (0 .. Item'Length);
begin
for J in Item'Range loop
R (size_t (J - Item'First)) := To_C (Item (J));
-
- pragma Loop_Invariant
- (for all K in 0 .. size_t (J - Item'First) =>
- R (K)'Initialized);
- pragma Loop_Invariant
- (for all K in Item'First .. J =>
- R (size_t (K - Item'First)) = To_C (Item (K)));
end loop;
R (R'Last) := nul;
- pragma Assert
- (for all J in Item'Range =>
- R (size_t (J - Item'First)) = To_C (Item (J)));
-
return R;
end;
@@ -774,19 +530,10 @@ is
else
declare
- R : char_array (0 .. Item'Length - 1)
- with Relaxed_Initialization;
-
+ R : char_array (0 .. Item'Length - 1);
begin
for J in Item'Range loop
R (size_t (J - Item'First)) := To_C (Item (J));
-
- pragma Loop_Invariant
- (for all K in 0 .. size_t (J - Item'First) =>
- R (K)'Initialized);
- pragma Loop_Invariant
- (for all K in Item'First .. J =>
- R (size_t (K - Item'First)) = To_C (Item (K)));
end loop;
return R;
@@ -814,18 +561,6 @@ is
for From in Item'Range loop
Target (To) := char (Item (From));
- pragma Loop_Invariant (To in Target'Range);
- pragma Loop_Invariant
- (To - Target'First = size_t (From - Item'First));
- pragma Loop_Invariant
- (for all J in Target'First .. To => Target (J)'Initialized);
- pragma Loop_Invariant
- (Target (Target'First .. To)'Initialized);
- pragma Loop_Invariant
- (for all J in Item'First .. From =>
- Target (Target'First + size_t (J - Item'First)) =
- To_C (Item (J)));
-
To := To + 1;
end loop;
@@ -836,7 +571,6 @@ is
Target (To) := nul;
Count := Item'Length + 1;
end if;
-
else
Count := Item'Length;
end if;
@@ -859,26 +593,14 @@ is
begin
if Append_Nul then
declare
- R : wchar_array (0 .. Item'Length) with Relaxed_Initialization;
-
+ R : wchar_array (0 .. Item'Length);
begin
for J in Item'Range loop
R (size_t (J - Item'First)) := To_C (Item (J));
-
- pragma Loop_Invariant
- (for all K in 0 .. size_t (J - Item'First) =>
- R (K)'Initialized);
- pragma Loop_Invariant
- (for all K in Item'First .. J =>
- R (size_t (K - Item'First)) = To_C (Item (K)));
end loop;
R (R'Last) := wide_nul;
- pragma Assert
- (for all J in Item'Range =>
- R (size_t (J - Item'First)) = To_C (Item (J)));
-
return R;
end;
@@ -895,19 +617,10 @@ is
else
declare
- R : wchar_array (0 .. Item'Length - 1)
- with Relaxed_Initialization;
-
+ R : wchar_array (0 .. Item'Length - 1);
begin
for J in Item'Range loop
R (size_t (J - Item'First)) := To_C (Item (J));
-
- pragma Loop_Invariant
- (for all K in 0 .. size_t (J - Item'First) =>
- R (K)'Initialized);
- pragma Loop_Invariant
- (for all K in Item'First .. J =>
- R (size_t (K - Item'First)) = To_C (Item (K)));
end loop;
return R;
@@ -925,40 +638,17 @@ is
Append_Nul : Boolean := True)
is
To : size_t;
-
begin
if Target'Length < Item'Length then
raise Constraint_Error;
-
else
To := Target'First;
for From in Item'Range loop
Target (To) := To_C (Item (From));
- pragma Loop_Invariant (To in Target'Range);
- pragma Loop_Invariant
- (To - Target'First = size_t (From - Item'First));
- pragma Loop_Invariant
- (for all J in Target'First .. To => Target (J)'Initialized);
- pragma Loop_Invariant
- (Target (Target'First .. To)'Initialized);
- pragma Loop_Invariant
- (for all J in Item'First .. From =>
- Target (Target'First + size_t (J - Item'First)) =
- To_C (Item (J)));
-
To := To + 1;
end loop;
- pragma Assert
- (for all J in Item'Range =>
- Target (Target'First + size_t (J - Item'First)) =
- To_C (Item (J)));
- pragma Assert
- (if Item'Length /= 0 then
- Target (Target'First ..
- Target'First + (Item'Length - 1))'Initialized);
-
if Append_Nul then
if To > Target'Last then
raise Constraint_Error;
@@ -966,7 +656,6 @@ is
Target (To) := wide_nul;
Count := Item'Length + 1;
end if;
-
else
Count := Item'Length;
end if;
@@ -989,26 +678,14 @@ is
begin
if Append_Nul then
declare
- R : char16_array (0 .. Item'Length) with Relaxed_Initialization;
-
+ R : char16_array (0 .. Item'Length);
begin
for J in Item'Range loop
R (size_t (J - Item'First)) := To_C (Item (J));
-
- pragma Loop_Invariant
- (for all K in 0 .. size_t (J - Item'First) =>
- R (K)'Initialized);
- pragma Loop_Invariant
- (for all K in Item'First .. J =>
- R (size_t (K - Item'First)) = To_C (Item (K)));
end loop;
R (R'Last) := char16_nul;
- pragma Assert
- (for all J in Item'Range =>
- R (size_t (J - Item'First)) = To_C (Item (J)));
-
return R;
end;
@@ -1022,22 +699,12 @@ is
if Item'Length = 0 then
raise Constraint_Error;
-
else
declare
- R : char16_array (0 .. Item'Length - 1)
- with Relaxed_Initialization;
-
+ R : char16_array (0 .. Item'Length - 1);
begin
for J in Item'Range loop
R (size_t (J - Item'First)) := To_C (Item (J));
-
- pragma Loop_Invariant
- (for all K in 0 .. size_t (J - Item'First) =>
- R (K)'Initialized);
- pragma Loop_Invariant
- (for all K in Item'First .. J =>
- R (size_t (K - Item'First)) = To_C (Item (K)));
end loop;
return R;
@@ -1055,7 +722,6 @@ is
Append_Nul : Boolean := True)
is
To : size_t;
-
begin
if Target'Length < Item'Length then
raise Constraint_Error;
@@ -1065,30 +731,9 @@ is
for From in Item'Range loop
Target (To) := To_C (Item (From));
- pragma Loop_Invariant (To in Target'Range);
- pragma Loop_Invariant
- (To - Target'First = size_t (From - Item'First));
- pragma Loop_Invariant
- (for all J in Target'First .. To => Target (J)'Initialized);
- pragma Loop_Invariant
- (Target (Target'First .. To)'Initialized);
- pragma Loop_Invariant
- (for all J in Item'First .. From =>
- Target (Target'First + size_t (J - Item'First)) =
- To_C (Item (J)));
-
To := To + 1;
end loop;
- pragma Assert
- (for all J in Item'Range =>
- Target (Target'First + size_t (J - Item'First)) =
- To_C (Item (J)));
- pragma Assert
- (if Item'Length /= 0 then
- Target (Target'First ..
- Target'First + (Item'Length - 1))'Initialized);
-
if Append_Nul then
if To > Target'Last then
raise Constraint_Error;
@@ -1096,7 +741,6 @@ is
Target (To) := char16_nul;
Count := Item'Length + 1;
end if;
-
else
Count := Item'Length;
end if;
@@ -1119,26 +763,14 @@ is
begin
if Append_Nul then
declare
- R : char32_array (0 .. Item'Length) with Relaxed_Initialization;
-
+ R : char32_array (0 .. Item'Length);
begin
for J in Item'Range loop
R (size_t (J - Item'First)) := To_C (Item (J));
-
- pragma Loop_Invariant
- (for all K in 0 .. size_t (J - Item'First) =>
- R (K)'Initialized);
- pragma Loop_Invariant
- (for all K in Item'First .. J =>
- R (size_t (K - Item'First)) = To_C (Item (K)));
end loop;
R (R'Last) := char32_nul;
- pragma Assert
- (for all J in Item'Range =>
- R (size_t (J - Item'First)) = To_C (Item (J)));
-
return R;
end;
@@ -1154,19 +786,10 @@ is
else
declare
- R : char32_array (0 .. Item'Length - 1)
- with Relaxed_Initialization;
-
+ R : char32_array (0 .. Item'Length - 1);
begin
for J in Item'Range loop
R (size_t (J - Item'First)) := To_C (Item (J));
-
- pragma Loop_Invariant
- (for all K in 0 .. size_t (J - Item'First) =>
- R (K)'Initialized);
- pragma Loop_Invariant
- (for all K in Item'First .. J =>
- R (size_t (K - Item'First)) = To_C (Item (K)));
end loop;
return R;
@@ -1188,36 +811,15 @@ is
begin
if Target'Length < Item'Length + (if Append_Nul then 1 else 0) then
raise Constraint_Error;
-
else
To := Target'First;
+
for From in Item'Range loop
Target (To) := To_C (Item (From));
- pragma Loop_Invariant (To in Target'Range);
- pragma Loop_Invariant
- (To - Target'First = size_t (From - Item'First));
- pragma Loop_Invariant
- (for all J in Target'First .. To => Target (J)'Initialized);
- pragma Loop_Invariant
- (Target (Target'First .. To)'Initialized);
- pragma Loop_Invariant
- (for all J in Item'First .. From =>
- Target (Target'First + size_t (J - Item'First)) =
- To_C (Item (J)));
-
To := To + 1;
end loop;
- pragma Assert
- (for all J in Item'Range =>
- Target (Target'First + size_t (J - Item'First)) =
- To_C (Item (J)));
- pragma Assert
- (if Item'Length /= 0 then
- Target (Target'First ..
- Target'First + (Item'Length - 1))'Initialized);
-
if Append_Nul then
Target (To) := char32_nul;
Count := Item'Length + 1;
@@ -1226,7 +828,5 @@ is
end if;
end if;
end To_C;
- pragma Annotate (CodePeer, False_Positive, "validity check",
- "Count is only uninitialized on abnormal return.");
end Interfaces.C;
diff --git a/gcc/ada/libgnat/i-c.ads b/gcc/ada/libgnat/i-c.ads
index f9f9f75..fc77caf 100644
--- a/gcc/ada/libgnat/i-c.ads
+++ b/gcc/ada/libgnat/i-c.ads
@@ -133,6 +133,7 @@ is
function C_Length_Ghost (Item : char_array) return size_t
with
Ghost,
+ Import,
Pre => Is_Nul_Terminated (Item),
Post => C_Length_Ghost'Result <= Item'Last - Item'First
and then Item (Item'First + C_Length_Ghost'Result) = nul
@@ -274,6 +275,7 @@ is
function C_Length_Ghost (Item : wchar_array) return size_t
with
Ghost,
+ Import,
Pre => Is_Nul_Terminated (Item),
Post => C_Length_Ghost'Result <= Item'Last - Item'First
and then Item (Item'First + C_Length_Ghost'Result) = wide_nul
@@ -395,6 +397,7 @@ is
function C_Length_Ghost (Item : char16_array) return size_t
with
Ghost,
+ Import,
Pre => Is_Nul_Terminated (Item),
Post => C_Length_Ghost'Result <= Item'Last - Item'First
and then Item (Item'First + C_Length_Ghost'Result) = char16_nul
@@ -510,6 +513,7 @@ is
function C_Length_Ghost (Item : char32_array) return size_t
with
Ghost,
+ Import,
Pre => Is_Nul_Terminated (Item),
Post => C_Length_Ghost'Result <= Item'Last - Item'First
and then Item (Item'First + C_Length_Ghost'Result) = char32_nul
diff --git a/gcc/ada/libgnat/i-cheri.adb b/gcc/ada/libgnat/i-cheri.adb
index 37e5c3d..1575705 100644
--- a/gcc/ada/libgnat/i-cheri.adb
+++ b/gcc/ada/libgnat/i-cheri.adb
@@ -31,6 +31,30 @@
package body Interfaces.CHERI is
+ ----------------
+ -- Set_Bounds --
+ ----------------
+
+ procedure Set_Bounds
+ (Cap : in out Capability;
+ Length : Bounds_Length)
+ is
+ begin
+ Cap := Capability_With_Bounds (Cap, Length);
+ end Set_Bounds;
+
+ ----------------------
+ -- Set_Exact_Bounds --
+ ----------------------
+
+ procedure Set_Exact_Bounds
+ (Cap : in out Capability;
+ Length : Bounds_Length)
+ is
+ begin
+ Cap := Capability_With_Exact_Bounds (Cap, Length);
+ end Set_Exact_Bounds;
+
----------------------------
-- Set_Address_And_Bounds --
----------------------------
diff --git a/gcc/ada/libgnat/i-cheri.ads b/gcc/ada/libgnat/i-cheri.ads
index ed26e55..4186b6d 100644
--- a/gcc/ada/libgnat/i-cheri.ads
+++ b/gcc/ada/libgnat/i-cheri.ads
@@ -273,8 +273,7 @@ is
(Cap : in out Capability;
Length : Bounds_Length)
with
- Import, Convention => Intrinsic,
- External_Name => "__builtin_cheri_bounds_set";
+ Inline;
-- Narrow the bounds of a capability so that the lower bound is the
-- current address and the upper bound is suitable for the Length.
--
@@ -287,8 +286,7 @@ is
(Cap : in out Capability;
Length : Bounds_Length)
with
- Import, Convention => Intrinsic,
- External_Name => "__builtin_cheri_bounds_set_exact";
+ Inline;
-- Narrow the bounds of a capability so that the lower bound is the
-- current address and the upper bound is suitable for the Length.
--
diff --git a/gcc/ada/libgnat/i-cpoint.adb b/gcc/ada/libgnat/i-cpoint.adb
index 40a5834..994e639 100644
--- a/gcc/ada/libgnat/i-cpoint.adb
+++ b/gcc/ada/libgnat/i-cpoint.adb
@@ -148,7 +148,7 @@ package body Interfaces.C.Pointers is
S : Pointer := Source;
begin
- if Source = null or Target = null then
+ if Source = null or else Target = null then
raise Dereference_Error;
end if;
diff --git a/gcc/ada/libgnat/i-cstrin.adb b/gcc/ada/libgnat/i-cstrin.adb
index 7bf881f..8279562 100644
--- a/gcc/ada/libgnat/i-cstrin.adb
+++ b/gcc/ada/libgnat/i-cstrin.adb
@@ -66,8 +66,11 @@ is
pragma Inline ("+");
-- Address arithmetic on chars_ptr value
- function Position_Of_Nul (Into : char_array) return size_t;
- -- Returns position of the first Nul in Into or Into'Last + 1 if none
+ procedure Position_Of_Nul
+ (Into : char_array; Found : out Boolean; Index : out size_t);
+ -- If into contains a Nul character, Found is set to True and Index
+ -- contains the position of the first Nul character in Into. Otherwise
+ -- Found is set to False and the value of Index is not meaningful.
-- We can't use directly System.Memory because the categorization is not
-- compatible, so we directly import here the malloc and free routines.
@@ -107,6 +110,7 @@ is
--------------------
function New_Char_Array (Chars : char_array) return chars_ptr is
+ Found : Boolean;
Index : size_t;
Pointer : chars_ptr;
@@ -114,24 +118,25 @@ is
-- Get index of position of null. If Index > Chars'Last,
-- nul is absent and must be added explicitly.
- Index := Position_Of_Nul (Into => Chars);
- Pointer := Memory_Alloc ((Index - Chars'First + 1));
+ Position_Of_Nul (Into => Chars, Found => Found, Index => Index);
-- If nul is present, transfer string up to and including nul
- if Index <= Chars'Last then
- Update (Item => Pointer,
- Offset => 0,
- Chars => Chars (Chars'First .. Index),
- Check => False);
+ if Found then
+ Pointer := Memory_Alloc (Index - Chars'First + 1);
+
+ Update
+ (Item => Pointer,
+ Offset => 0,
+ Chars => Chars (Chars'First .. Index),
+ Check => False);
else
-- If original string has no nul, transfer whole string and add
-- terminator explicitly.
- Update (Item => Pointer,
- Offset => 0,
- Chars => Chars,
- Check => False);
+ Pointer := Memory_Alloc (Chars'Length + 1);
+
+ Update (Item => Pointer, Offset => 0, Chars => Chars, Check => False);
Poke (nul, Into => Pointer + size_t'(Chars'Length));
end if;
@@ -148,20 +153,33 @@ is
-- the result, and doesn't copy the string on the stack, otherwise its
-- use is limited when used from tasks on large strings.
- Result : constant chars_ptr := Memory_Alloc (Str'Length + 1);
+ Len : Natural := 0;
+ -- Length of the longest prefix of Str that doesn't contain NUL
- Result_Array : char_array (1 .. Str'Length + 1);
- for Result_Array'Address use To_Address (Result);
- pragma Import (Ada, Result_Array);
+ Result : chars_ptr;
+ begin
+ for C of Str loop
+ if C = ASCII.NUL then
+ exit;
+ end if;
+ Len := Len + 1;
+ end loop;
- Count : size_t;
+ Result := Memory_Alloc (size_t (Len) + 1);
+
+ declare
+ Result_Array : char_array (1 .. size_t (Len) + 1)
+ with Address => To_Address (Result), Import, Convention => Ada;
+
+ Count : size_t;
+ begin
+ To_C
+ (Item => Str (Str'First .. Str'First + Len - 1),
+ Target => Result_Array,
+ Count => Count,
+ Append_Nul => True);
+ end;
- begin
- To_C
- (Item => Str,
- Target => Result_Array,
- Count => Count,
- Append_Nul => True);
return Result;
end New_String;
@@ -187,19 +205,19 @@ is
-- Position_Of_Nul --
---------------------
- function Position_Of_Nul (Into : char_array) return size_t is
+ procedure Position_Of_Nul
+ (Into : char_array; Found : out Boolean; Index : out size_t) is
begin
- pragma Annotate (Gnatcheck, Exempt_On, "Improper_Returns",
- "early returns for performance");
+ Found := False;
+ Index := 0;
+
for J in Into'Range loop
if Into (J) = nul then
- return J;
+ Found := True;
+ Index := J;
+ return;
end if;
end loop;
-
- return Into'Last + 1;
-
- pragma Annotate (Gnatcheck, Exempt_Off, "Improper_Returns");
end Position_Of_Nul;
------------
@@ -231,19 +249,22 @@ is
(Item : char_array_access;
Nul_Check : Boolean := False) return chars_ptr
is
+ Found : Boolean;
+ Index : size_t;
begin
pragma Annotate (Gnatcheck, Exempt_On, "Improper_Returns",
"early returns for performance");
if Item = null then
return Null_Ptr;
- elsif Nul_Check
- and then Position_Of_Nul (Into => Item.all) > Item'Last
- then
- raise Terminator_Error;
- else
- return To_chars_ptr (Item (Item'First)'Address);
+ elsif Nul_Check then
+ Position_Of_Nul (Item.all, Found, Index);
+ if not Found then
+ raise Terminator_Error;
+ end if;
end if;
+ return To_chars_ptr (Item (Item'First)'Address);
+
pragma Annotate (Gnatcheck, Exempt_Off, "Improper_Returns");
end To_Chars_Ptr;
@@ -260,6 +281,11 @@ is
Index : chars_ptr := Item + Offset;
begin
+ -- Check for null pointer as mandated by the RM.
+ if Item = Null_Ptr then
+ raise Dereference_Error;
+ end if;
+
if Check and then Offset + Chars'Length > Strlen (Item) then
raise Update_Error;
end if;
diff --git a/gcc/ada/libgnat/s-aridou.adb b/gcc/ada/libgnat/s-aridou.adb
index e4140e8..dd2f150 100644
--- a/gcc/ada/libgnat/s-aridou.adb
+++ b/gcc/ada/libgnat/s-aridou.adb
@@ -29,74 +29,20 @@
-- --
------------------------------------------------------------------------------
-pragma Annotate (Gnatcheck, Exempt_On, "Metrics_LSLOC",
- "limit exceeded due to proof code");
-
with Ada.Unchecked_Conversion;
-with System.SPARK.Cut_Operations; use System.SPARK.Cut_Operations;
package body System.Arith_Double
with SPARK_Mode
is
- -- Contracts, ghost code, loop invariants and assertions in this unit are
- -- meant for analysis only, not for run-time checking, as it would be too
- -- costly otherwise. This is enforced by setting the assertion policy to
- -- Ignore.
-
- pragma Assertion_Policy (Pre => Ignore,
- Post => Ignore,
- Contract_Cases => Ignore,
- Ghost => Ignore,
- Loop_Invariant => Ignore,
- Assert => Ignore,
- Assert_And_Cut => Ignore);
-
pragma Suppress (Overflow_Check);
pragma Suppress (Range_Check);
- pragma Warnings
- (Off, "statement has no effect",
- Reason => "Ghost code on dead paths is used for verification only");
-
function To_Uns is new Ada.Unchecked_Conversion (Double_Int, Double_Uns);
function To_Int is new Ada.Unchecked_Conversion (Double_Uns, Double_Int);
Double_Size : constant Natural := Double_Int'Size;
Single_Size : constant Natural := Double_Int'Size / 2;
- -- Log of Single_Size in base 2, so that Single_Size = 2 ** Log_Single_Size
- Log_Single_Size : constant Natural :=
- (case Single_Size is
- when 32 => 5,
- when 64 => 6,
- when 128 => 7,
- when others => raise Program_Error)
- with Ghost;
-
- -- Power-of-two constants
-
- pragma Warnings
- (Off, "non-preelaborable call not allowed in preelaborated unit",
- Reason => "Ghost code is not compiled");
- pragma Warnings
- (Off, "non-static constant in preelaborated unit",
- Reason => "Ghost code is not compiled");
- Big_0 : constant Big_Integer :=
- Big (Double_Uns'(0))
- with Ghost;
- Big_2xxSingle : constant Big_Integer :=
- Big (Double_Int'(2 ** Single_Size))
- with Ghost;
- Big_2xxDouble_Minus_1 : constant Big_Integer :=
- Big (Double_Uns'(2 ** (Double_Size - 1)))
- with Ghost;
- Big_2xxDouble : constant Big_Integer :=
- Big (Double_Uns'(2 ** Double_Size - 1)) + 1
- with Ghost;
- pragma Warnings
- (On, "non-preelaborable call not allowed in preelaborated unit");
- pragma Warnings (On, "non-static constant in preelaborated unit");
-
pragma Annotate (Gnatcheck, Exempt_On, "Improper_Returns",
"early returns for performance");
@@ -115,9 +61,7 @@ is
-- Length doubling multiplication
function "/" (A : Double_Uns; B : Single_Uns) return Double_Uns is
- (A / Double_Uns (B))
- with
- Pre => B /= 0;
+ (A / Double_Uns (B));
-- Length doubling division
function "&" (Hi, Lo : Single_Uns) return Double_Uns is
@@ -127,37 +71,15 @@ is
function "abs" (X : Double_Int) return Double_Uns is
(if X = Double_Int'First
then Double_Uns'(2 ** (Double_Size - 1))
- else Double_Uns (Double_Int'(abs X)))
- with Post => abs Big (X) = Big ("abs"'Result),
- Annotate => (GNATprove, Hide_Info, "Expression_Function_Body");
+ else Double_Uns (Double_Int'(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 = Double_Int'First.
function "rem" (A : Double_Uns; B : Single_Uns) return Double_Uns is
- (A rem Double_Uns (B))
- with
- Pre => B /= 0;
+ (A rem Double_Uns (B));
-- Length doubling remainder
- function Big_2xx (N : Natural) return Big_Positive is
- (Big (Double_Uns'(2 ** N)))
- with
- Ghost,
- Pre => N < Double_Size,
- Post => Big_2xx'Result > 0;
- -- 2**N as a big integer
-
- function Big3 (X1, X2, X3 : Single_Uns) return Big_Natural is
- (Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (X1))
- + Big_2xxSingle * Big (Double_Uns (X2))
- + Big (Double_Uns (X3)))
- with
- Ghost;
- -- X1&X2&X3 as a big integer
-
- function Le3 (X1, X2, X3, Y1, Y2, Y3 : Single_Uns) return Boolean
- with
- Post => Le3'Result = (Big3 (X1, X2, X3) <= Big3 (Y1, Y2, Y3));
+ function Le3 (X1, X2, X3, Y1, Y2, Y3 : Single_Uns) return Boolean;
-- Determines if (3 * Single_Size)-bit value X1&X2&X3 <= Y1&Y2&Y3
function Lo (A : Double_Uns) return Single_Uns is
@@ -168,654 +90,41 @@ is
(Single_Uns (Shift_Right (A, Single_Size)));
-- High order half of double value
- procedure Sub3 (X1, X2, X3 : in out Single_Uns; Y1, Y2, Y3 : Single_Uns)
- with
- Pre => Big3 (X1, X2, X3) >= Big3 (Y1, Y2, Y3),
- Post => Big3 (X1, X2, X3) = Big3 (X1, X2, X3)'Old - Big3 (Y1, Y2, Y3);
+ procedure Sub3 (X1, X2, X3 : in out Single_Uns; Y1, Y2, Y3 : Single_Uns);
-- Computes X1&X2&X3 := X1&X2&X3 - Y1&Y1&Y3 mod 2 ** (3 * Single_Size)
- function To_Neg_Int (A : Double_Uns) return Double_Int
- with
- Pre => In_Double_Int_Range (-Big (A)),
- Post => Big (To_Neg_Int'Result) = -Big (A);
+ function To_Neg_Int (A : Double_Uns) return Double_Int;
-- Convert to negative integer equivalent. If the input is in the range
-- 0 .. 2 ** (Double_Size - 1), then the corresponding nonpositive signed
-- integer (obtained by negating the given value) is returned, otherwise
-- constraint error is raised.
- function To_Pos_Int (A : Double_Uns) return Double_Int
- with
- Pre => In_Double_Int_Range (Big (A)),
- Post => Big (To_Pos_Int'Result) = Big (A);
+ function To_Pos_Int (A : Double_Uns) return Double_Int;
-- Convert to positive integer equivalent. If the input is in the range
-- 0 .. 2 ** (Double_Size - 1) - 1, then the corresponding non-negative
-- signed integer is returned, otherwise constraint error is raised.
- procedure Raise_Error with
- Exceptional_Cases => (Constraint_Error => True);
- pragma No_Return (Raise_Error);
+ procedure Raise_Error with No_Return;
-- Raise constraint error with appropriate message
- ------------------
- -- Local Lemmas --
- ------------------
-
- procedure Inline_Le3 (X1, X2, X3, Y1, Y2, Y3 : Single_Uns)
- with
- Ghost,
- Pre => Le3 (X1, X2, X3, Y1, Y2, Y3),
- Post => Big3 (X1, X2, X3) <= Big3 (Y1, Y2, Y3);
-
- procedure Lemma_Abs_Commutation (X : Double_Int)
- with
- Ghost,
- Post => abs Big (X) = Big (Double_Uns'(abs X));
-
- procedure Lemma_Abs_Div_Commutation (X, Y : Big_Integer)
- with
- Ghost,
- Pre => Y /= 0,
- Post => abs (X / Y) = abs X / abs Y;
-
- procedure Lemma_Abs_Mult_Commutation (X, Y : Big_Integer)
- with
- Ghost,
- Post => abs (X * Y) = abs X * abs Y;
-
- procedure Lemma_Abs_Range (X : Big_Integer)
- with
- Ghost,
- Pre => In_Double_Int_Range (X),
- Post => abs X <= Big_2xxDouble_Minus_1
- and then In_Double_Int_Range (-abs X);
-
- procedure Lemma_Abs_Rem_Commutation (X, Y : Big_Integer)
- with
- Ghost,
- Pre => Y /= 0,
- Post => abs (X rem Y) = (abs X) rem (abs Y);
-
- procedure Lemma_Add_Commutation (X : Double_Uns; Y : Single_Uns)
- with
- Ghost,
- Pre => X <= 2 ** Double_Size - 2 ** Single_Size,
- Post => Big (X) + Big (Double_Uns (Y)) = Big (X + Double_Uns (Y));
-
- procedure Lemma_Add_One (X : Double_Uns)
- with
- Ghost,
- Pre => X /= Double_Uns'Last,
- Post => Big (X + Double_Uns'(1)) = Big (X) + 1;
-
- procedure Lemma_Big_Of_Double_Uns (X : Double_Uns)
- with
- Ghost,
- Post => Big (X) < Big_2xxDouble;
-
- procedure Lemma_Big_Of_Double_Uns_Of_Single_Uns (X : Single_Uns)
- with
- Ghost,
- Post => Big (Double_Uns (X)) >= 0
- and then Big (Double_Uns (X)) < Big_2xxSingle;
-
- procedure Lemma_Bounded_Powers_Of_2_Increasing (M, N : Natural)
- with
- Ghost,
- Pre => M < N and then N < Double_Size,
- Post => Double_Uns'(2)**M < Double_Uns'(2)**N;
-
- procedure Lemma_Concat_Definition (X, Y : Single_Uns)
- with
- Ghost,
- Post => Big (X & Y) = Big_2xxSingle * Big (Double_Uns (X))
- + Big (Double_Uns (Y));
-
- procedure Lemma_Deep_Mult_Commutation
- (Factor : Big_Integer;
- X, Y : Single_Uns)
- with
- Ghost,
- Post =>
- Factor * Big (Double_Uns (X)) * Big (Double_Uns (Y)) =
- Factor * Big (Double_Uns (X) * Double_Uns (Y));
-
- procedure Lemma_Div_Commutation (X, Y : Double_Uns)
- with
- Ghost,
- Pre => Y /= 0,
- Post => Big (X) / Big (Y) = Big (X / Y);
-
- procedure Lemma_Div_Definition
- (A : Double_Uns;
- B : Single_Uns;
- Q : Double_Uns;
- R : Double_Uns)
- with
- Ghost,
- Pre => B /= 0 and then Q = A / B and then R = A rem B,
- Post => Big (A) = Big (Double_Uns (B)) * Big (Q) + Big (R);
-
- procedure Lemma_Div_Ge (X, Y, Z : Big_Integer)
- with
- Ghost,
- Pre => Z > 0 and then X >= Y * Z,
- Post => X / Z >= Y;
-
- procedure Lemma_Div_Lt (X, Y, Z : Big_Natural)
- with
- Ghost,
- Pre => Z > 0 and then X < Y * Z,
- Post => X / Z < Y;
-
- procedure Lemma_Div_Eq (A, B, S, R : Big_Integer)
- with
- Ghost,
- Pre => A * S = B * S + R and then S /= 0,
- Post => A = B + R / S;
-
- procedure Lemma_Div_Mult (X : Big_Natural; Y : Big_Positive)
- with
- Ghost,
- Post => X / Y * Y > X - Y;
-
- procedure Lemma_Double_Big_2xxSingle
- with
- Ghost,
- Post => Big_2xxSingle * Big_2xxSingle = Big_2xxDouble;
-
- procedure Lemma_Double_Shift (X : Double_Uns; S, S1 : Double_Uns)
- with
- Ghost,
- Pre => S <= Double_Uns (Double_Size)
- and then S1 <= Double_Uns (Double_Size),
- Post => Shift_Left (Shift_Left (X, Natural (S)), Natural (S1)) =
- Shift_Left (X, Natural (S + S1));
-
- procedure Lemma_Double_Shift (X : Single_Uns; S, S1 : Natural)
- with
- Ghost,
- Pre => S <= Single_Size - S1,
- Post => Shift_Left (Shift_Left (X, S), S1) = Shift_Left (X, S + S1);
-
- procedure Lemma_Double_Shift (X : Double_Uns; S, S1 : Natural)
- with
- Ghost,
- Pre => S <= Double_Size - S1,
- Post => Shift_Left (Shift_Left (X, S), S1) = Shift_Left (X, S + S1);
-
- procedure Lemma_Double_Shift_Left (X : Double_Uns; S, S1 : Double_Uns)
- with
- Ghost,
- Pre => S <= Double_Uns (Double_Size)
- and then S1 <= Double_Uns (Double_Size),
- Post => Shift_Left (Shift_Left (X, Natural (S)), Natural (S1)) =
- Shift_Left (X, Natural (S + S1));
-
- procedure Lemma_Double_Shift_Left (X : Double_Uns; S, S1 : Natural)
- with
- Ghost,
- Pre => S <= Double_Size - S1,
- Post => Shift_Left (Shift_Left (X, S), S1) = Shift_Left (X, S + S1);
-
- procedure Lemma_Double_Shift_Right (X : Double_Uns; S, S1 : Double_Uns)
- with
- Ghost,
- Pre => S <= Double_Uns (Double_Size)
- and then S1 <= Double_Uns (Double_Size),
- Post => Shift_Right (Shift_Right (X, Natural (S)), Natural (S1)) =
- Shift_Right (X, Natural (S + S1));
-
- procedure Lemma_Double_Shift_Right (X : Double_Uns; S, S1 : Natural)
- with
- Ghost,
- Pre => S <= Double_Size - S1,
- Post => Shift_Right (Shift_Right (X, S), S1) = Shift_Right (X, S + S1);
-
- procedure Lemma_Ge_Commutation (A, B : Double_Uns)
- with
- Ghost,
- Pre => A >= B,
- Post => Big (A) >= Big (B);
-
- procedure Lemma_Ge_Mult (A, B, C, D : Big_Integer)
- with
- Ghost,
- Pre => A >= B and then B * C >= D and then C > 0,
- Post => A * C >= D;
-
- procedure Lemma_Gt_Commutation (A, B : Double_Uns)
- with
- Ghost,
- Pre => A > B,
- Post => Big (A) > Big (B);
-
- procedure Lemma_Gt_Mult (A, B, C, D : Big_Integer)
- with
- Ghost,
- Pre => A >= B and then B * C > D and then C > 0,
- Post => A * C > D;
-
- procedure Lemma_Hi_Lo (Xu : Double_Uns; Xhi, Xlo : Single_Uns)
- with
- Ghost,
- Pre => Xhi = Hi (Xu) and Xlo = Lo (Xu),
- Post => Big (Xu) =
- Big_2xxSingle * Big (Double_Uns (Xhi)) + Big (Double_Uns (Xlo));
-
- procedure Lemma_Hi_Lo_3 (Xu : Double_Uns; Xhi, Xlo : Single_Uns)
- with
- Ghost,
- Pre => Xhi = Hi (Xu) and then Xlo = Lo (Xu),
- Post => Big (Xu) = Big3 (0, Xhi, Xlo);
-
- procedure Lemma_Lo_Is_Ident (X : Double_Uns)
- with
- Ghost,
- Pre => Big (X) < Big_2xxSingle,
- Post => Double_Uns (Lo (X)) = X;
-
- procedure Lemma_Lt_Commutation (A, B : Double_Uns)
- with
- Ghost,
- Pre => A < B,
- Post => Big (A) < Big (B);
-
- procedure Lemma_Lt_Mult (A, B, C, D : Big_Integer)
- with
- Ghost,
- Pre => A < B and then B * C <= D and then C > 0,
- Post => A * C < D;
-
- procedure Lemma_Mult_Commutation (X, Y : Single_Uns)
- with
- Ghost,
- Post =>
- Big (Double_Uns (X)) * Big (Double_Uns (Y)) =
- Big (Double_Uns (X) * Double_Uns (Y));
-
- procedure Lemma_Mult_Commutation (X, Y : Double_Int)
- with
- Ghost,
- Pre => In_Double_Int_Range (Big (X) * Big (Y)),
- Post => Big (X) * Big (Y) = Big (X * Y);
-
- procedure Lemma_Mult_Commutation (X, Y, Z : Double_Uns)
- with
- Ghost,
- Pre => Big (X) * Big (Y) < Big_2xxDouble and then Z = X * Y,
- Post => Big (X) * Big (Y) = Big (Z);
-
- procedure Lemma_Mult_Decomposition
- (Mult : Big_Integer;
- Xu, Yu : Double_Uns;
- Xhi, Xlo, Yhi, Ylo : Single_Uns)
- with
- Ghost,
- Pre => Mult = Big (Xu) * Big (Yu)
- and then Xhi = Hi (Xu)
- and then Xlo = Lo (Xu)
- and then Yhi = Hi (Yu)
- and then Ylo = Lo (Yu),
- Post => Mult =
- Big_2xxSingle * Big_2xxSingle * (Big (Double_Uns'(Xhi * Yhi)))
- + Big_2xxSingle * (Big (Double_Uns'(Xhi * Ylo)))
- + Big_2xxSingle * (Big (Double_Uns'(Xlo * Yhi)))
- + (Big (Double_Uns'(Xlo * Ylo)));
-
- procedure Lemma_Mult_Distribution (X, Y, Z : Big_Integer)
- with
- Ghost,
- Post => X * (Y + Z) = X * Y + X * Z;
-
- procedure Lemma_Mult_Div (A, B : Big_Integer)
- with
- Ghost,
- Pre => B /= 0,
- Post => A * B / B = A;
-
- procedure Lemma_Mult_Non_Negative (X, Y : Big_Integer)
- with
- Ghost,
- Pre => (X >= 0 and then Y >= 0)
- or else (X <= 0 and then Y <= 0),
- Post => X * Y >= 0;
-
- procedure Lemma_Mult_Non_Positive (X, Y : Big_Integer)
- with
- Ghost,
- Pre => (X <= Big_0 and then Y >= Big_0)
- or else (X >= Big_0 and then Y <= Big_0),
- Post => X * Y <= Big_0;
-
- procedure Lemma_Mult_Positive (X, Y : Big_Integer)
- with
- Ghost,
- Pre => (X > Big_0 and then Y > Big_0)
- or else (X < Big_0 and then Y < Big_0),
- Post => X * Y > Big_0;
-
- procedure Lemma_Neg_Div (X, Y : Big_Integer)
- with
- Ghost,
- Pre => Y /= 0,
- Post => X / Y = (-X) / (-Y);
-
- procedure Lemma_Neg_Rem (X, Y : Big_Integer)
- with
- Ghost,
- Pre => Y /= 0,
- Post => X rem Y = X rem (-Y);
-
- procedure Lemma_Not_In_Range_Big2xx64
- with
- Post => not In_Double_Int_Range (Big_2xxDouble)
- and then not In_Double_Int_Range (-Big_2xxDouble);
-
- procedure Lemma_Powers (A : Big_Natural; B, C : Natural)
- with
- Ghost,
- Pre => B <= Natural'Last - C,
- Post => A**B * A**C = A**(B + C);
-
- procedure Lemma_Powers_Of_2 (M, N : Natural)
- with
- Ghost,
- Pre => M < Double_Size
- and then N < Double_Size
- and then M + N <= Double_Size,
- Post =>
- Big_2xx (M) * Big_2xx (N) =
- (if M + N = Double_Size then Big_2xxDouble else Big_2xx (M + N));
-
- procedure Lemma_Powers_Of_2_Commutation (M : Natural)
- with
- Ghost,
- Subprogram_Variant => (Decreases => M),
- Pre => M <= Double_Size,
- Post => Big (Double_Uns'(2))**M =
- (if M < Double_Size then Big_2xx (M) else Big_2xxDouble);
-
- procedure Lemma_Powers_Of_2_Increasing (M, N : Natural)
- with
- Ghost,
- Subprogram_Variant => (Increases => M),
- Pre => M < N,
- Post => Big (Double_Uns'(2))**M < Big (Double_Uns'(2))**N;
-
- procedure Lemma_Rem_Abs (X, Y : Big_Integer)
- with
- Ghost,
- Pre => Y /= 0,
- Post => X rem Y = X rem (abs Y);
- pragma Unreferenced (Lemma_Rem_Abs);
-
- procedure Lemma_Rem_Commutation (X, Y : Double_Uns)
- with
- Ghost,
- Pre => Y /= 0,
- Post => Big (X) rem Big (Y) = Big (X rem Y);
-
- procedure Lemma_Rem_Is_Ident (X, Y : Big_Integer)
- with
- Ghost,
- Pre => abs X < abs Y,
- Post => X rem Y = X;
- pragma Unreferenced (Lemma_Rem_Is_Ident);
-
- procedure Lemma_Rem_Sign (X, Y : Big_Integer)
- with
- Ghost,
- Pre => Y /= 0,
- Post => Same_Sign (X rem Y, X);
- pragma Unreferenced (Lemma_Rem_Sign);
-
- procedure Lemma_Rev_Div_Definition (A, B, Q, R : Big_Natural)
- with
- Ghost,
- Pre => A = B * Q + R and then R < B,
- Post => Q = A / B and then R = A rem B;
-
- procedure Lemma_Shift_Left (X : Double_Uns; Shift : Natural)
- with
- Ghost,
- Pre => Shift < Double_Size
- and then Big (X) * Big_2xx (Shift) < Big_2xxDouble,
- Post => Big (Shift_Left (X, Shift)) = Big (X) * Big_2xx (Shift);
-
- procedure Lemma_Shift_Right (X : Double_Uns; Shift : Natural)
- with
- Ghost,
- Pre => Shift < Double_Size,
- Post => Big (Shift_Right (X, Shift)) = Big (X) / Big_2xx (Shift);
-
- procedure Lemma_Shift_Without_Drop
- (X, Y : Double_Uns;
- Mask : Single_Uns;
- Shift : Natural)
- with
- Ghost,
- Pre => (Hi (X) and Mask) = 0 -- X has the first Shift bits off
- and then Shift <= Single_Size
- and then Mask = Shift_Left (Single_Uns'Last, Single_Size - Shift)
- and then Y = Shift_Left (X, Shift),
- Post => Big (Y) = Big_2xx (Shift) * Big (X);
-
- procedure Lemma_Simplify (X, Y : Big_Integer)
- with
- Ghost,
- Pre => Y /= 0,
- Post => X * Y / Y = X;
-
- procedure Lemma_Substitution (A, B, C, C1, D : Big_Integer)
- with
- Ghost,
- Pre => C = C1 and then A = B * C + D,
- Post => A = B * C1 + D;
-
- procedure Lemma_Subtract_Commutation (X, Y : Double_Uns)
- with
- Ghost,
- Pre => X >= Y,
- Post => Big (X) - Big (Y) = Big (X - Y);
-
- procedure Lemma_Subtract_Double_Uns (X, Y : Double_Int)
- with
- Ghost,
- Pre => X >= 0 and then X <= Y,
- Post => Double_Uns (Y - X) = Double_Uns (Y) - Double_Uns (X);
-
- procedure Lemma_Word_Commutation (X : Single_Uns)
- with
- Ghost,
- Post => Big_2xxSingle * Big (Double_Uns (X))
- = Big (2**Single_Size * Double_Uns (X));
-
- -----------------------------
- -- Local lemma null bodies --
- -----------------------------
-
- procedure Inline_Le3 (X1, X2, X3, Y1, Y2, Y3 : Single_Uns) is null;
- procedure Lemma_Abs_Commutation (X : Double_Int) is null;
- procedure Lemma_Abs_Mult_Commutation (X, Y : Big_Integer) is null;
- procedure Lemma_Abs_Range (X : Big_Integer) is null;
- procedure Lemma_Add_Commutation (X : Double_Uns; Y : Single_Uns) is null;
- procedure Lemma_Add_One (X : Double_Uns) is null;
- procedure Lemma_Big_Of_Double_Uns (X : Double_Uns) is null;
- procedure Lemma_Big_Of_Double_Uns_Of_Single_Uns (X : Single_Uns) is null;
- procedure Lemma_Bounded_Powers_Of_2_Increasing (M, N : Natural) is null;
- procedure Lemma_Deep_Mult_Commutation
- (Factor : Big_Integer;
- X, Y : Single_Uns)
- is null;
- procedure Lemma_Div_Commutation (X, Y : Double_Uns) is null;
- procedure Lemma_Div_Definition
- (A : Double_Uns;
- B : Single_Uns;
- Q : Double_Uns;
- R : Double_Uns)
- is null;
- procedure Lemma_Div_Ge (X, Y, Z : Big_Integer) is null;
- procedure Lemma_Div_Lt (X, Y, Z : Big_Natural) is null;
- procedure Lemma_Div_Mult (X : Big_Natural; Y : Big_Positive) is null;
- procedure Lemma_Double_Big_2xxSingle is null;
- procedure Lemma_Double_Shift (X : Double_Uns; S, S1 : Double_Uns) is null;
- procedure Lemma_Double_Shift (X : Single_Uns; S, S1 : Natural) is null;
- procedure Lemma_Double_Shift_Left (X : Double_Uns; S, S1 : Double_Uns)
- is null;
- procedure Lemma_Double_Shift_Right (X : Double_Uns; S, S1 : Double_Uns)
- is null;
- procedure Lemma_Ge_Commutation (A, B : Double_Uns) is null;
- procedure Lemma_Ge_Mult (A, B, C, D : Big_Integer) is null;
- procedure Lemma_Gt_Commutation (A, B : Double_Uns) is null;
- procedure Lemma_Gt_Mult (A, B, C, D : Big_Integer) is null;
- procedure Lemma_Lo_Is_Ident (X : Double_Uns) is null;
- procedure Lemma_Lt_Commutation (A, B : Double_Uns) is null;
- procedure Lemma_Lt_Mult (A, B, C, D : Big_Integer) is null;
- procedure Lemma_Mult_Commutation (X, Y : Single_Uns) is null;
- procedure Lemma_Mult_Commutation (X, Y : Double_Int) is null;
- procedure Lemma_Mult_Commutation (X, Y, Z : Double_Uns) is null;
- procedure Lemma_Mult_Distribution (X, Y, Z : Big_Integer) is null;
- procedure Lemma_Mult_Non_Negative (X, Y : Big_Integer) is null;
- procedure Lemma_Mult_Non_Positive (X, Y : Big_Integer) is null;
- procedure Lemma_Mult_Positive (X, Y : Big_Integer) is null;
- procedure Lemma_Neg_Rem (X, Y : Big_Integer) is null;
- procedure Lemma_Not_In_Range_Big2xx64 is null;
- procedure Lemma_Powers (A : Big_Natural; B, C : Natural) is null;
- procedure Lemma_Rem_Commutation (X, Y : Double_Uns) is null;
- procedure Lemma_Rem_Is_Ident (X, Y : Big_Integer) is null;
- procedure Lemma_Rem_Sign (X, Y : Big_Integer) is null;
- procedure Lemma_Rev_Div_Definition (A, B, Q, R : Big_Natural) is null;
- procedure Lemma_Simplify (X, Y : Big_Integer) is null;
- procedure Lemma_Substitution (A, B, C, C1, D : Big_Integer) is null;
- procedure Lemma_Subtract_Commutation (X, Y : Double_Uns) is null;
- procedure Lemma_Subtract_Double_Uns (X, Y : Double_Int) is null;
- procedure Lemma_Word_Commutation (X : Single_Uns) is null;
-
--------------------------
-- Add_With_Ovflo_Check --
--------------------------
function Add_With_Ovflo_Check (X, Y : Double_Int) return Double_Int is
R : constant Double_Int := To_Int (To_Uns (X) + To_Uns (Y));
-
- -- Local lemmas
-
- procedure Prove_Negative_X
- with
- Ghost,
- Pre => X < 0 and then (Y > 0 or else R < 0),
- Post => R = X + Y;
-
- procedure Prove_Non_Negative_X
- with
- Ghost,
- Pre => X >= 0 and then (Y < 0 or else R >= 0),
- Post => R = X + Y;
-
- procedure Prove_Overflow_Case
- with
- Ghost,
- Pre =>
- (if X >= 0 then Y >= 0 and then R < 0
- else Y <= 0 and then R >= 0),
- Post => not In_Double_Int_Range (Big (X) + Big (Y));
-
- ----------------------
- -- Prove_Negative_X --
- ----------------------
-
- procedure Prove_Negative_X is
- begin
- if X = Double_Int'First then
- if Y > 0 then
- null;
- else
- pragma Assert
- (To_Uns (X) + To_Uns (Y) =
- 2 ** (Double_Size - 1) - Double_Uns (-Y));
- pragma Assert -- as R < 0
- (To_Uns (X) + To_Uns (Y) >= 2 ** (Double_Size - 1));
- pragma Assert (Y = 0);
- end if;
-
- elsif Y = Double_Int'First then
- pragma Assert
- (To_Uns (X) + To_Uns (Y) =
- 2 ** (Double_Size - 1) - Double_Uns (-X));
- pragma Assert (False);
-
- elsif Y <= 0 then
- pragma Assert
- (To_Uns (X) + To_Uns (Y) = -Double_Uns (-X) - Double_Uns (-Y));
-
- else -- Y > 0, 0 > X > Double_Int'First
- declare
- Ru : constant Double_Uns := To_Uns (X) + To_Uns (Y);
- begin
- pragma Assert (Ru = -Double_Uns (-X) + Double_Uns (Y));
- if Ru < 2 ** (Double_Size - 1) then -- R >= 0
- Lemma_Subtract_Double_Uns (-X, Y);
- pragma Assert (Ru = Double_Uns (X + Y));
-
- elsif Ru = 2 ** (Double_Size - 1) then
- pragma Assert (Double_Uns (Y) < 2 ** (Double_Size - 1));
- pragma Assert (Double_Uns (-X) < 2 ** (Double_Size - 1));
- pragma Assert (False);
-
- else
- pragma Assert
- (R = -Double_Int (-(-Double_Uns (-X) + Double_Uns (Y))));
- pragma Assert
- (R = -Double_Int (-Double_Uns (Y) + Double_Uns (-X)));
- end if;
- end;
- end if;
- end Prove_Negative_X;
-
- --------------------------
- -- Prove_Non_Negative_X --
- --------------------------
-
- procedure Prove_Non_Negative_X is
- begin
- if Y >= 0 or else Y = Double_Int'First then
- null;
- else
- pragma Assert
- (To_Uns (X) + To_Uns (Y) = Double_Uns (X) - Double_Uns (-Y));
- end if;
- end Prove_Non_Negative_X;
-
- -------------------------
- -- Prove_Overflow_Case --
- -------------------------
-
- procedure Prove_Overflow_Case is
- begin
- if X < 0 and then X /= Double_Int'First and then Y /= Double_Int'First
- then
- pragma Assert
- (To_Uns (X) + To_Uns (Y) = -Double_Uns (-X) - Double_Uns (-Y));
- end if;
- end Prove_Overflow_Case;
-
- -- Start of processing for Add_With_Ovflo_Check
-
begin
if X >= 0 then
if Y < 0 or else R >= 0 then
- Prove_Non_Negative_X;
return R;
end if;
else -- X < 0
if Y > 0 or else R < 0 then
- Prove_Negative_X;
return R;
end if;
end if;
- Prove_Overflow_Case;
Raise_Error;
end Add_With_Ovflo_Check;
@@ -823,8 +132,6 @@ is
-- Double_Divide --
-------------------
- pragma Annotate (Gnatcheck, Exempt_On, "Metrics_Cyclomatic_Complexity",
- "limit exceeded due to proof code");
procedure Double_Divide
(X, Y, Z : Double_Int;
Q, R : out Double_Int;
@@ -844,183 +151,11 @@ is
Du, Qu, Ru : Double_Uns;
Den_Pos : constant Boolean := (Y < 0) = (Z < 0);
- -- Local ghost variables
-
- Mult : constant Big_Integer := abs (Big (Y) * Big (Z)) with Ghost;
- Quot : Big_Integer with Ghost;
- Big_R : Big_Integer with Ghost;
- Big_Q : Big_Integer with Ghost;
-
- -- Local lemmas
-
- procedure Prove_Overflow_Case
- with
- Ghost,
- Pre => X = Double_Int'First and then Big (Y) * Big (Z) = -1,
- Post => not In_Double_Int_Range (Big (X) / (Big (Y) * Big (Z)))
- and then not In_Double_Int_Range
- (Round_Quotient (Big (X), Big (Y) * Big (Z),
- Big (X) / (Big (Y) * Big (Z)),
- Big (X) rem (Big (Y) * Big (Z))));
- -- Proves the special case where -2**(Double_Size - 1) is divided by -1,
- -- generating an overflow.
-
- procedure Prove_Quotient_Zero
- with
- Ghost,
- Pre => Mult >= Big_2xxDouble
- and then
- not (Mult = Big_2xxDouble
- and then X = Double_Int'First
- and then Round)
- and then Q = 0
- and then R = X,
- Post => Big (R) = Big (X) rem (Big (Y) * Big (Z))
- and then
- (if Round then
- Big (Q) = Round_Quotient (Big (X), Big (Y) * Big (Z),
- Big (X) / (Big (Y) * Big (Z)),
- Big (R))
- else Big (Q) = Big (X) / (Big (Y) * Big (Z)));
- -- Proves the general case where divisor doesn't fit in Double_Uns and
- -- quotient is 0.
-
- procedure Prove_Round_To_One
- with
- Ghost,
- Pre => Mult = Big_2xxDouble
- and then X = Double_Int'First
- and then Q = (if Den_Pos then -1 else 1)
- and then R = X
- and then Round,
- Post => Big (R) = Big (X) rem (Big (Y) * Big (Z))
- and then Big (Q) = Round_Quotient (Big (X), Big (Y) * Big (Z),
- Big (X) / (Big (Y) * Big (Z)),
- Big (R));
- -- Proves the special case where the divisor doesn't fit in Double_Uns
- -- but quotient is still 1 or -1 due to rounding
- -- (abs (Y*Z) = 2**Double_Size and X = -2**(Double_Size - 1) and Round).
-
- procedure Prove_Rounding_Case
- with
- Ghost,
- Pre => Mult /= 0
- and then Quot = Big (X) / (Big (Y) * Big (Z))
- and then Big_R = Big (X) rem (Big (Y) * Big (Z))
- and then Big_Q =
- Round_Quotient (Big (X), Big (Y) * Big (Z), Quot, Big_R)
- and then Big (Ru) = abs Big_R
- and then Big (Du) = Mult
- and then Big (Qu) =
- (if Ru > (Du - Double_Uns'(1)) / Double_Uns'(2)
- then abs Quot + 1
- else abs Quot),
- Post => abs Big_Q = Big (Qu);
- -- Proves correctness of the rounding of the unsigned quotient
-
- procedure Prove_Sign_Quotient
- with
- Ghost,
- Pre => Mult /= 0
- and then Quot = Big (X) / (Big (Y) * Big (Z))
- and then Big_R = Big (X) rem (Big (Y) * Big (Z))
- and then Big_Q =
- (if Round then
- Round_Quotient (Big (X), Big (Y) * Big (Z), Quot, Big_R)
- else Quot),
- Post =>
- (if X >= 0 then
- (if Den_Pos then Big_Q >= 0 else Big_Q <= 0)
- else
- (if Den_Pos then Big_Q <= 0 else Big_Q >= 0));
- -- Proves the correct sign of the signed quotient Big_Q
-
- procedure Prove_Signs
- with
- Ghost,
- Pre => Mult /= 0
- and then Quot = Big (X) / (Big (Y) * Big (Z))
- and then Big_R = Big (X) rem (Big (Y) * Big (Z))
- and then Big_Q =
- (if Round then
- Round_Quotient (Big (X), Big (Y) * Big (Z), Quot, Big_R)
- else Quot)
- and then Big (Ru) = abs Big_R
- and then Big (Qu) = abs Big_Q
- and then R = (if X >= 0 then To_Int (Ru) else To_Int (-Ru))
- and then
- Q = (if (X >= 0) = Den_Pos then To_Int (Qu) else To_Int (-Qu))
- and then not (X = Double_Int'First and then Big (Y) * Big (Z) = -1),
- Post => Big (R) = Big (X) rem (Big (Y) * Big (Z))
- and then
- (if Round then
- Big (Q) = Round_Quotient (Big (X), Big (Y) * Big (Z),
- Big (X) / (Big (Y) * Big (Z)),
- Big (R))
- else Big (Q) = Big (X) / (Big (Y) * Big (Z)));
- -- Proves final signs match the intended result after the unsigned
- -- division is done.
-
- -----------------------------
- -- Local lemma null bodies --
- -----------------------------
-
- procedure Prove_Overflow_Case is null;
- procedure Prove_Quotient_Zero is null;
- procedure Prove_Round_To_One is null;
- procedure Prove_Sign_Quotient is null;
-
- -------------------------
- -- Prove_Rounding_Case --
- -------------------------
-
- procedure Prove_Rounding_Case is
- begin
- if Same_Sign (Big (X), Big (Y) * Big (Z)) then
- pragma Assert (abs Big_Q = Big (Qu));
- end if;
- end Prove_Rounding_Case;
-
- -----------------
- -- Prove_Signs --
- -----------------
-
- procedure Prove_Signs is
- begin
- if (X >= 0) = Den_Pos then
- pragma Assert (Quot >= 0);
- pragma Assert (Big_Q >= 0);
- pragma Assert (Q >= 0);
- pragma Assert (Big (Q) = Big_Q);
- else
- pragma Assert ((X >= 0) /= (Big (Y) * Big (Z) >= 0));
- pragma Assert (Quot <= 0);
- pragma Assert (Big_Q <= 0);
- pragma Assert (if X >= 0 then R >= 0);
- pragma Assert (if X < 0 then R <= 0);
- pragma Assert (Big (R) = Big_R);
- end if;
- end Prove_Signs;
-
- -- Start of processing for Double_Divide
-
begin
if Yu = 0 or else Zu = 0 then
Raise_Error;
end if;
- pragma Assert (Mult /= 0);
- pragma Assert (Den_Pos = (Big (Y) * Big (Z) > 0));
- Quot := Big (X) / (Big (Y) * Big (Z));
- Big_R := Big (X) rem (Big (Y) * Big (Z));
- if Round then
- Big_Q := Round_Quotient (Big (X), Big (Y) * Big (Z), Quot, Big_R);
- else
- Big_Q := Quot;
- end if;
- Lemma_Abs_Mult_Commutation (Big (Y), Big (Z));
- Lemma_Mult_Decomposition (Mult, Yu, Zu, Yhi, Ylo, Zhi, Zlo);
-
-- Compute Y * Z. Note that if the result overflows Double_Uns, then
-- the rounded result is zero, except for the very special case where
-- X = -2 ** (Double_Size - 1) and abs (Y * Z) = 2 ** Double_Size, when
@@ -1040,66 +175,21 @@ is
and then Round
then
Q := (if Den_Pos then -1 else 1);
-
- Prove_Round_To_One;
-
else
Q := 0;
-
- pragma Assert (Double_Uns'(Yhi * Zhi) >= Double_Uns (Yhi));
- pragma Assert (Double_Uns'(Yhi * Zhi) >= Double_Uns (Zhi));
- pragma Assert (Big (Double_Uns'(Yhi * Zhi)) >= 1);
- if Yhi > 1 or else Zhi > 1 then
- pragma Assert (Big (Double_Uns'(Yhi * Zhi)) > 1);
- pragma Assert (if X = Double_Int'First and then Round then
- Mult > Big_2xxDouble);
- elsif Zlo > 0 then
- pragma Assert (Big (Double_Uns'(Yhi * Zlo)) > 0);
- pragma Assert (if X = Double_Int'First and then Round then
- Mult > Big_2xxDouble);
- elsif Ylo > 0 then
- pragma Assert (Double_Uns'(Ylo * Zhi) > 0);
- pragma Assert (Big (Double_Uns'(Ylo * Zhi)) > 0);
- pragma Assert (if X = Double_Int'First and then Round then
- Mult > Big_2xxDouble);
- else
- pragma Assert (not (X = Double_Int'First and then Round));
- end if;
- Prove_Quotient_Zero;
end if;
return;
else
T2 := Yhi * Zlo;
- pragma Assert (Big (T2) = Big (Double_Uns'(Yhi * Zlo)));
- pragma Assert (Big_0 = Big (Double_Uns'(Ylo * Zhi)));
end if;
-
else
T2 := Ylo * Zhi;
- pragma Assert (Big (T2) = Big (Double_Uns'(Ylo * Zhi)));
- pragma Assert (Big_0 = Big (Double_Uns'(Yhi * Zlo)));
end if;
T1 := Ylo * Zlo;
-
- Lemma_Mult_Distribution (Big_2xxSingle,
- Big (Double_Uns'(Yhi * Zlo)),
- Big (Double_Uns'(Ylo * Zhi)));
- Lemma_Hi_Lo (T1, Hi (T1), Lo (T1));
- Lemma_Mult_Distribution (Big_2xxSingle,
- Big (T2),
- Big (Double_Uns (Hi (T1))));
- Lemma_Add_Commutation (T2, Hi (T1));
-
T2 := T2 + Hi (T1);
- Lemma_Hi_Lo (T2, Hi (T2), Lo (T2));
- Lemma_Mult_Distribution (Big_2xxSingle,
- Big (Double_Uns (Hi (T2))),
- Big (Double_Uns (Lo (T2))));
- Lemma_Double_Big_2xxSingle;
-
if Hi (T2) /= 0 then
R := X;
@@ -1112,41 +202,8 @@ is
and then Round
then
Q := (if Den_Pos then -1 else 1);
-
- Prove_Round_To_One;
-
else
Q := 0;
-
- pragma Assert (Big (Double_Uns (Hi (T2))) >= 1);
- pragma Assert (Big (Double_Uns (Lo (T2))) >= 0);
- pragma Assert (Big (Double_Uns (Lo (T1))) >= 0);
- pragma Assert (Big_2xxSingle * Big (Double_Uns (Lo (T2)))
- + Big (Double_Uns (Lo (T1))) >= 0);
- pragma Assert (Mult >= Big_2xxDouble * Big (Double_Uns (Hi (T2))));
- pragma Assert (Mult >= Big_2xxDouble);
- if Hi (T2) > 1 then
- pragma Assert (Big (Double_Uns (Hi (T2))) > 1);
- pragma Assert (if X = Double_Int'First and then Round then
- Mult > Big_2xxDouble);
- elsif Lo (T2) > 0 then
- pragma Assert (Big (Double_Uns (Lo (T2))) > 0);
- pragma Assert (Big_2xxSingle > 0);
- pragma Assert (Big_2xxSingle * Big (Double_Uns (Lo (T2))) > 0);
- pragma Assert (Big_2xxSingle * Big (Double_Uns (Lo (T2)))
- + Big (Double_Uns (Lo (T1))) > 0);
- pragma Assert (if X = Double_Int'First and then Round then
- Mult > Big_2xxDouble);
- elsif Lo (T1) > 0 then
- pragma Assert (Double_Uns (Lo (T1)) > 0);
- Lemma_Gt_Commutation (Double_Uns (Lo (T1)), 0);
- pragma Assert (Big (Double_Uns (Lo (T1))) > 0);
- pragma Assert (if X = Double_Int'First and then Round then
- Mult > Big_2xxDouble);
- else
- pragma Assert (not (X = Double_Int'First and then Round));
- end if;
- Prove_Quotient_Zero;
end if;
return;
@@ -1154,22 +211,9 @@ is
Du := Lo (T2) & Lo (T1);
- Lemma_Hi_Lo (Du, Lo (T2), Lo (T1));
- pragma Assert (Mult = Big (Du));
- pragma Assert (Du /= 0);
- -- Multiplication of 2-limb arguments Yu and Zu leads to 4-limb result
- -- (where each limb is a single value). Cases where 4 limbs are needed
- -- require Yhi /= 0 and Zhi /= 0 and lead to early exit. Remaining cases
- -- where 3 limbs are needed correspond to Hi(T2) /= 0 and lead to early
- -- exit. Thus, at this point, the result fits in 2 limbs which are
- -- exactly Lo (T2) and Lo (T1), which corresponds to the value of Du.
- -- As the case where one of Yu or Zu is null also led to early exit,
- -- we have Du /= 0 here.
-
-- Check overflow case of largest negative number divided by -1
if X = Double_Int'First and then Du = 1 and then not Den_Pos then
- Prove_Overflow_Case;
Raise_Error;
end if;
@@ -1188,29 +232,14 @@ is
Qu := Xu / Du;
Ru := Xu rem Du;
- Lemma_Div_Commutation (Xu, Du);
- Lemma_Abs_Div_Commutation (Big (X), Big (Y) * Big (Z));
- Lemma_Abs_Commutation (X);
- pragma Assert (abs Quot = Big (Qu));
- Lemma_Rem_Commutation (Xu, Du);
- Lemma_Abs_Rem_Commutation (Big (X), Big (Y) * Big (Z));
- pragma Assert (abs Big_R = Big (Ru));
-
-- Deal with rounding case
if Round then
if Ru > (Du - Double_Uns'(1)) / Double_Uns'(2) then
- Lemma_Add_Commutation (Qu, 1);
-
Qu := Qu + Double_Uns'(1);
end if;
-
- Prove_Rounding_Case;
end if;
- pragma Assert (abs Big_Q = Big (Qu));
- Prove_Sign_Quotient;
-
-- Set final signs (RM 4.5.5(27-30))
-- Case of dividend (X) sign positive
@@ -1229,10 +258,7 @@ is
R := To_Int (-Ru);
Q := (if Den_Pos then To_Int (-Qu) else To_Int (Qu));
end if;
-
- Prove_Signs;
end Double_Divide;
- pragma Annotate (Gnatcheck, Exempt_Off, "Metrics_Cyclomatic_Complexity");
---------
-- Le3 --
@@ -1254,418 +280,6 @@ is
end Le3;
-------------------------------
- -- Lemma_Abs_Div_Commutation --
- -------------------------------
-
- procedure Lemma_Abs_Div_Commutation (X, Y : Big_Integer) is
- begin
- if Y < 0 then
- if X < 0 then
- pragma Assert (abs (X / Y) = abs (X / (-Y)));
- else
- Lemma_Neg_Div (X, Y);
- pragma Assert (abs (X / Y) = abs ((-X) / (-Y)));
- end if;
- end if;
- end Lemma_Abs_Div_Commutation;
-
- -------------------------------
- -- Lemma_Abs_Rem_Commutation --
- -------------------------------
-
- procedure Lemma_Abs_Rem_Commutation (X, Y : Big_Integer) is
- begin
- if Y < 0 then
- Lemma_Neg_Rem (X, Y);
- if X < 0 then
- pragma Assert (X rem Y = -((-X) rem (-Y)));
- pragma Assert (abs (X rem Y) = (abs X) rem (abs Y));
- else
- pragma Assert (abs (X rem Y) = (abs X) rem (abs Y));
- end if;
- end if;
- end Lemma_Abs_Rem_Commutation;
-
- -----------------------------
- -- Lemma_Concat_Definition --
- -----------------------------
-
- procedure Lemma_Concat_Definition (X, Y : Single_Uns) is
- Hi : constant Double_Uns := Shift_Left (Double_Uns (X), Single_Size);
- Lo : constant Double_Uns := Double_Uns (Y);
- begin
- pragma Assert (Hi = Double_Uns'(2 ** Single_Size) * Double_Uns (X));
- pragma Assert ((Hi or Lo) = Hi + Lo);
- end Lemma_Concat_Definition;
-
- ------------------
- -- Lemma_Div_Eq --
- ------------------
-
- procedure Lemma_Div_Eq (A, B, S, R : Big_Integer) is
- begin
- pragma Assert ((A - B) * S = R);
- pragma Assert ((A - B) * S / S = R / S);
- Lemma_Mult_Div (A - B, S);
- pragma Assert (A - B = R / S);
- end Lemma_Div_Eq;
-
- ------------------------
- -- Lemma_Double_Shift --
- ------------------------
-
- procedure Lemma_Double_Shift (X : Double_Uns; S, S1 : Natural) is
- begin
- Lemma_Double_Shift (X, Double_Uns (S), Double_Uns (S1));
- pragma Assert (Shift_Left (Shift_Left (X, S), S1)
- = Shift_Left (Shift_Left (X, S), Natural (Double_Uns (S1))));
- pragma Assert (Shift_Left (X, S + S1)
- = Shift_Left (X, Natural (Double_Uns (S + S1))));
- end Lemma_Double_Shift;
-
- -----------------------------
- -- Lemma_Double_Shift_Left --
- -----------------------------
-
- procedure Lemma_Double_Shift_Left (X : Double_Uns; S, S1 : Natural) is
- begin
- Lemma_Double_Shift_Left (X, Double_Uns (S), Double_Uns (S1));
- pragma Assert (Shift_Left (Shift_Left (X, S), S1)
- = Shift_Left (Shift_Left (X, S), Natural (Double_Uns (S1))));
- pragma Assert (Shift_Left (X, S + S1)
- = Shift_Left (X, Natural (Double_Uns (S + S1))));
- end Lemma_Double_Shift_Left;
-
- ------------------------------
- -- Lemma_Double_Shift_Right --
- ------------------------------
-
- procedure Lemma_Double_Shift_Right (X : Double_Uns; S, S1 : Natural) is
- begin
- Lemma_Double_Shift_Right (X, Double_Uns (S), Double_Uns (S1));
- pragma Assert (Shift_Right (Shift_Right (X, S), S1)
- = Shift_Right (Shift_Right (X, S), Natural (Double_Uns (S1))));
- pragma Assert (Shift_Right (X, S + S1)
- = Shift_Right (X, Natural (Double_Uns (S + S1))));
- end Lemma_Double_Shift_Right;
-
- -----------------
- -- Lemma_Hi_Lo --
- -----------------
-
- procedure Lemma_Hi_Lo (Xu : Double_Uns; Xhi, Xlo : Single_Uns) is
- begin
- pragma Assert (Double_Uns (Xhi) = Xu / Double_Uns'(2 ** Single_Size));
- pragma Assert (Double_Uns (Xlo) = Xu mod 2 ** Single_Size);
- end Lemma_Hi_Lo;
-
- -------------------
- -- Lemma_Hi_Lo_3 --
- -------------------
-
- procedure Lemma_Hi_Lo_3 (Xu : Double_Uns; Xhi, Xlo : Single_Uns) is
- begin
- Lemma_Hi_Lo (Xu, Xhi, Xlo);
- end Lemma_Hi_Lo_3;
-
- ------------------------------
- -- Lemma_Mult_Decomposition --
- ------------------------------
-
- procedure Lemma_Mult_Decomposition
- (Mult : Big_Integer;
- Xu, Yu : Double_Uns;
- Xhi, Xlo, Yhi, Ylo : Single_Uns)
- is
- begin
- Lemma_Hi_Lo (Xu, Xhi, Xlo);
- Lemma_Hi_Lo (Yu, Yhi, Ylo);
-
- pragma Assert
- (Mult =
- (Big_2xxSingle * Big (Double_Uns (Xhi)) + Big (Double_Uns (Xlo))) *
- (Big_2xxSingle * Big (Double_Uns (Yhi)) + Big (Double_Uns (Ylo))));
- pragma Assert (Mult =
- Big_2xxSingle
- * Big_2xxSingle * Big (Double_Uns (Xhi)) * Big (Double_Uns (Yhi))
- + Big_2xxSingle * Big (Double_Uns (Xhi)) * Big (Double_Uns (Ylo))
- + Big_2xxSingle * Big (Double_Uns (Xlo)) * Big (Double_Uns (Yhi))
- + Big (Double_Uns (Xlo)) * Big (Double_Uns (Ylo)));
- Lemma_Deep_Mult_Commutation (Big_2xxSingle * Big_2xxSingle, Xhi, Yhi);
- Lemma_Deep_Mult_Commutation (Big_2xxSingle, Xhi, Ylo);
- Lemma_Deep_Mult_Commutation (Big_2xxSingle, Xlo, Yhi);
- Lemma_Mult_Commutation (Xlo, Ylo);
- pragma Assert (Mult =
- Big_2xxSingle * Big_2xxSingle * Big (Double_Uns'(Xhi * Yhi))
- + Big_2xxSingle * Big (Double_Uns'(Xhi * Ylo))
- + Big_2xxSingle * Big (Double_Uns'(Xlo * Yhi))
- + Big (Double_Uns'(Xlo * Ylo)));
- end Lemma_Mult_Decomposition;
-
- --------------------
- -- Lemma_Mult_Div --
- --------------------
-
- procedure Lemma_Mult_Div (A, B : Big_Integer) is
- begin
- if B > 0 then
- pragma Assert (A * B / B = A);
- else
- pragma Assert (A * (-B) / (-B) = A);
- end if;
- end Lemma_Mult_Div;
-
- -------------------
- -- Lemma_Neg_Div --
- -------------------
-
- procedure Lemma_Neg_Div (X, Y : Big_Integer) is
- begin
- pragma Assert ((-X) / (-Y) = -(X / (-Y)));
- pragma Assert (X / (-Y) = -(X / Y));
- end Lemma_Neg_Div;
-
- -----------------------
- -- Lemma_Powers_Of_2 --
- -----------------------
-
- procedure Lemma_Powers_Of_2 (M, N : Natural) is
- begin
- if M + N < Double_Size then
- pragma Assert (Double_Uns'(2**M) * Double_Uns'(2**N)
- = Double_Uns'(2**(M + N)));
- end if;
-
- Lemma_Powers_Of_2_Commutation (M);
- Lemma_Powers_Of_2_Commutation (N);
- Lemma_Powers_Of_2_Commutation (M + N);
- Lemma_Powers (Big (Double_Uns'(2)), M, N);
-
- if M + N < Double_Size then
- pragma Assert (Big (Double_Uns'(2))**M * Big (Double_Uns'(2))**N
- = Big (Double_Uns'(2))**(M + N));
- Lemma_Powers_Of_2_Increasing (M + N, Double_Size);
- Lemma_Mult_Commutation (2 ** M, 2 ** N, 2 ** (M + N));
- else
- pragma Assert (Big (Double_Uns'(2))**M * Big (Double_Uns'(2))**N
- = Big (Double_Uns'(2))**(M + N));
- end if;
- end Lemma_Powers_Of_2;
-
- -----------------------------------
- -- Lemma_Powers_Of_2_Commutation --
- -----------------------------------
-
- procedure Lemma_Powers_Of_2_Commutation (M : Natural) is
- begin
- if M > 0 then
- Lemma_Powers_Of_2_Commutation (M - 1);
- pragma Assert (Big (Double_Uns'(2))**(M - 1) = Big_2xx (M - 1));
- pragma Assert (Big (Double_Uns'(2))**M = Big_2xx (M - 1) * 2);
- if M < Double_Size then
- Lemma_Powers_Of_2_Increasing (M - 1, Double_Size - 1);
- Lemma_Bounded_Powers_Of_2_Increasing (M - 1, Double_Size - 1);
- pragma Assert (Double_Uns'(2 ** (M - 1)) * 2 = Double_Uns'(2**M));
- Lemma_Mult_Commutation
- (Double_Uns'(2 ** (M - 1)), 2, Double_Uns'(2**M));
- pragma Assert (Big (Double_Uns'(2))**M = Big_2xx (M));
- end if;
- else
- pragma Assert (Big (Double_Uns'(2))**M = Big_2xx (M));
- end if;
- end Lemma_Powers_Of_2_Commutation;
-
- ----------------------------------
- -- Lemma_Powers_Of_2_Increasing --
- ----------------------------------
-
- procedure Lemma_Powers_Of_2_Increasing (M, N : Natural) is
- begin
- if M + 1 < N then
- Lemma_Powers_Of_2_Increasing (M + 1, N);
- end if;
- end Lemma_Powers_Of_2_Increasing;
-
- -------------------
- -- Lemma_Rem_Abs --
- -------------------
-
- procedure Lemma_Rem_Abs (X, Y : Big_Integer) is
- begin
- Lemma_Neg_Rem (X, Y);
- end Lemma_Rem_Abs;
-
- ----------------------
- -- Lemma_Shift_Left --
- ----------------------
-
- procedure Lemma_Shift_Left (X : Double_Uns; Shift : Natural) is
-
- procedure Lemma_Mult_Pow2 (X : Double_Uns; I : Natural)
- with
- Ghost,
- Pre => I < Double_Size - 1,
- Post => X * Double_Uns'(2) ** I * Double_Uns'(2)
- = X * Double_Uns'(2) ** (I + 1);
-
- procedure Lemma_Mult_Pow2 (X : Double_Uns; I : Natural) is
- Mul1 : constant Double_Uns := Double_Uns'(2) ** I;
- Mul2 : constant Double_Uns := Double_Uns'(2);
- Left : constant Double_Uns := X * Mul1 * Mul2;
- begin
- pragma Assert (Left = X * (Mul1 * Mul2));
- pragma Assert (Mul1 * Mul2 = Double_Uns'(2) ** (I + 1));
- end Lemma_Mult_Pow2;
-
- XX : Double_Uns := X;
-
- begin
- for J in 1 .. Shift loop
- declare
- Cur_XX : constant Double_Uns := XX;
- begin
- XX := Shift_Left (XX, 1);
- pragma Assert (XX = Cur_XX * Double_Uns'(2));
- Lemma_Mult_Pow2 (X, J - 1);
- end;
- Lemma_Double_Shift_Left (X, J - 1, 1);
- pragma Loop_Invariant (XX = Shift_Left (X, J));
- pragma Loop_Invariant (XX = X * Double_Uns'(2) ** J);
- end loop;
- end Lemma_Shift_Left;
-
- -----------------------
- -- Lemma_Shift_Right --
- -----------------------
-
- procedure Lemma_Shift_Right (X : Double_Uns; Shift : Natural) is
-
- procedure Lemma_Div_Pow2 (X : Double_Uns; I : Natural)
- with
- Ghost,
- Pre => I < Double_Size - 1,
- Post => X / Double_Uns'(2) ** I / Double_Uns'(2)
- = X / Double_Uns'(2) ** (I + 1);
-
- procedure Lemma_Quot_Rem (X, Div, Q, R : Double_Uns)
- with
- Ghost,
- Pre => Div /= 0
- and then X = Q * Div + R
- and then Q <= Double_Uns'Last / Div
- and then R <= Double_Uns'Last - Q * Div
- and then R < Div,
- Post => Q = X / Div;
- pragma Annotate (GNATprove, False_Positive, "postcondition might fail",
- "Q is the quotient of X by Div");
-
- procedure Lemma_Div_Pow2 (X : Double_Uns; I : Natural) is
-
- -- Local lemmas
-
- procedure Lemma_Mult_Le (X, Y, Z : Double_Uns)
- with
- Ghost,
- Pre => X <= 1,
- Post => X * Z <= Z;
-
- procedure Lemma_Mult_Le (X, Y, Z : Double_Uns) is null;
-
- -- Local variables
-
- Div1 : constant Double_Uns := Double_Uns'(2) ** I;
- Div2 : constant Double_Uns := Double_Uns'(2);
- Left : constant Double_Uns := X / Div1 / Div2;
- R2 : constant Double_Uns := X / Div1 - Left * Div2;
- pragma Assert (R2 <= Div2 - 1);
- R1 : constant Double_Uns := X - X / Div1 * Div1;
- pragma Assert (R1 < Div1);
-
- -- Start of processing for Lemma_Div_Pow2
-
- begin
- pragma Assert (X = Left * (Div1 * Div2) + R2 * Div1 + R1);
- Lemma_Mult_Le (R2, Div2 - 1, Div1);
- pragma Assert (R2 * Div1 + R1 < Div1 * Div2);
- Lemma_Quot_Rem (X, Div1 * Div2, Left, R2 * Div1 + R1);
- pragma Assert (Left = X / (Div1 * Div2));
- pragma Assert (Div1 * Div2 = Double_Uns'(2) ** (I + 1));
- end Lemma_Div_Pow2;
-
- procedure Lemma_Quot_Rem (X, Div, Q, R : Double_Uns) is null;
-
- XX : Double_Uns := X;
-
- begin
- for J in 1 .. Shift loop
- declare
- Cur_XX : constant Double_Uns := XX;
- begin
- XX := Shift_Right (XX, 1);
- pragma Assert (XX = Cur_XX / Double_Uns'(2));
- Lemma_Div_Pow2 (X, J - 1);
- end;
- Lemma_Double_Shift_Right (X, J - 1, 1);
- pragma Loop_Invariant (XX = Shift_Right (X, J));
- pragma Loop_Invariant (XX = X / Double_Uns'(2) ** J);
- end loop;
- Lemma_Div_Commutation (X, Double_Uns'(2) ** Shift);
- end Lemma_Shift_Right;
-
- ------------------------------
- -- Lemma_Shift_Without_Drop --
- ------------------------------
-
- procedure Lemma_Shift_Without_Drop
- (X, Y : Double_Uns;
- Mask : Single_Uns;
- Shift : Natural)
- is
- pragma Unreferenced (Mask);
-
- procedure Lemma_Bound
- with
- Pre => Shift <= Single_Size
- and then X <= 2**Single_Size
- * Double_Uns'(2**(Single_Size - Shift) - 1)
- + Single_Uns'(2**Single_Size - 1),
- Post => X <= 2**(Double_Size - Shift) - 1;
-
- procedure Lemma_Exp_Pos (N : Integer)
- with
- Pre => N in 0 .. Double_Size - 1,
- Post => Double_Uns'(2**N) > 0;
-
- -----------------------------
- -- Local lemma null bodies --
- -----------------------------
-
- procedure Lemma_Bound is null;
- procedure Lemma_Exp_Pos (N : Integer) is null;
-
- -- Start of processing for Lemma_Shift_Without_Drop
-
- begin
- if Shift = 0 then
- pragma Assert (Big (Y) = Big_2xx (Shift) * Big (X));
- return;
- end if;
-
- Lemma_Bound;
- Lemma_Exp_Pos (Double_Size - Shift);
- pragma Assert (X < 2**(Double_Size - Shift));
- pragma Assert (Big (X) < Big_2xx (Double_Size - Shift));
- pragma Assert (Y = 2**Shift * X);
- Lemma_Lt_Mult (Big (X), Big_2xx (Double_Size - Shift), Big_2xx (Shift),
- Big_2xx (Shift) * Big_2xx (Double_Size - Shift));
- pragma Assert (Big_2xx (Shift) * Big (X)
- < Big_2xx (Shift) * Big_2xx (Double_Size - Shift));
- Lemma_Powers_Of_2 (Shift, Double_Size - Shift);
- Lemma_Mult_Commutation (2**Shift, X, Y);
- pragma Assert (Big (Y) = Big_2xx (Shift) * Big (X));
- end Lemma_Shift_Without_Drop;
-
- -------------------------------
-- Multiply_With_Ovflo_Check --
-------------------------------
@@ -1680,160 +294,16 @@ is
T1, T2 : Double_Uns;
- -- Local ghost variables
-
- Mult : constant Big_Integer := abs (Big (X) * Big (Y)) with Ghost;
-
- -- Local lemmas
-
- procedure Prove_Both_Too_Large
- with
- Ghost,
- Pre => Xhi /= 0
- and then Yhi /= 0
- and then Mult =
- Big_2xxSingle * Big_2xxSingle * (Big (Double_Uns'(Xhi * Yhi)))
- + Big_2xxSingle * (Big (Double_Uns'(Xhi * Ylo)))
- + Big_2xxSingle * (Big (Double_Uns'(Xlo * Yhi)))
- + (Big (Double_Uns'(Xlo * Ylo))),
- Post => not In_Double_Int_Range (Big (X) * Big (Y));
-
- procedure Prove_Final_Decomposition
- with
- Ghost,
- Pre => In_Double_Int_Range (Big (X) * Big (Y))
- and then Mult = Big_2xxSingle * Big (T2) + Big (Double_Uns (Lo (T1)))
- and then Hi (T2) = 0,
- Post => Mult = Big (Lo (T2) & Lo (T1));
-
- procedure Prove_Neg_Int
- with
- Ghost,
- Pre => In_Double_Int_Range (Big (X) * Big (Y))
- and then Mult = Big (T2)
- and then ((X >= 0 and then Y < 0) or else (X < 0 and then Y >= 0)),
- Post => To_Neg_Int (T2) = X * Y;
-
- procedure Prove_Pos_Int
- with
- Ghost,
- Pre => In_Double_Int_Range (Big (X) * Big (Y))
- and then Mult = Big (T2)
- and then ((X >= 0 and then Y >= 0) or else (X < 0 and then Y < 0)),
- Post => In_Double_Int_Range (Big (T2))
- and then To_Pos_Int (T2) = X * Y;
-
- procedure Prove_Result_Too_Large
- with
- Ghost,
- Pre => Mult = Big_2xxSingle * Big (T2) + Big (Double_Uns (Lo (T1)))
- and then Hi (T2) /= 0,
- Post => not In_Double_Int_Range (Big (X) * Big (Y));
-
- procedure Prove_Too_Large
- with
- Ghost,
- Pre => abs (Big (X) * Big (Y)) >= Big_2xxDouble,
- Post => not In_Double_Int_Range (Big (X) * Big (Y));
-
- --------------------------
- -- Prove_Both_Too_Large --
- --------------------------
-
- procedure Prove_Both_Too_Large is
- begin
- pragma Assert (Mult >=
- Big_2xxSingle * Big_2xxSingle * Big (Double_Uns'(Xhi * Yhi)));
- pragma Assert (Double_Uns (Xhi) * Double_Uns (Yhi) >= 1);
- pragma Assert (Mult >= Big_2xxSingle * Big_2xxSingle);
- Prove_Too_Large;
- end Prove_Both_Too_Large;
-
- -------------------------------
- -- Prove_Final_Decomposition --
- -------------------------------
-
- procedure Prove_Final_Decomposition is
- begin
- Lemma_Hi_Lo (T2, Hi (T2), Lo (T2));
- pragma Assert (Mult = Big_2xxSingle * Big (Double_Uns (Lo (T2)))
- + Big (Double_Uns (Lo (T1))));
- pragma Assert (Mult <= Big_2xxDouble_Minus_1);
- Lemma_Mult_Commutation (X, Y);
- pragma Assert (Mult = abs Big (X * Y));
- Lemma_Word_Commutation (Lo (T2));
- pragma Assert (Mult = Big (Double_Uns'(2 ** Single_Size)
- * Double_Uns (Lo (T2)))
- + Big (Double_Uns (Lo (T1))));
- Lemma_Add_Commutation (Double_Uns'(2 ** Single_Size)
- * Double_Uns (Lo (T2)),
- Lo (T1));
- pragma Assert (Mult = Big (Double_Uns'(2 ** Single_Size)
- * Double_Uns (Lo (T2)) + Lo (T1)));
- pragma Assert (Lo (T2) & Lo (T1) = Double_Uns'(2 ** Single_Size)
- * Double_Uns (Lo (T2)) + Lo (T1));
- end Prove_Final_Decomposition;
-
- -------------------
- -- Prove_Neg_Int --
- -------------------
-
- procedure Prove_Neg_Int is
- begin
- pragma Assert (X * Y <= 0);
- pragma Assert (Mult = -Big (X * Y));
- end Prove_Neg_Int;
-
- -------------------
- -- Prove_Pos_Int --
- -------------------
-
- procedure Prove_Pos_Int is
- begin
- pragma Assert (X * Y >= 0);
- pragma Assert (Mult = Big (X * Y));
- end Prove_Pos_Int;
-
- ----------------------------
- -- Prove_Result_Too_Large --
- ----------------------------
-
- procedure Prove_Result_Too_Large is
- begin
- pragma Assert (Mult >= Big_2xxSingle * Big (T2));
- Lemma_Hi_Lo (T2, Hi (T2), Lo (T2));
- pragma Assert (Mult >=
- Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (Hi (T2))));
- pragma Assert (Double_Uns (Hi (T2)) >= 1);
- pragma Assert (Mult >= Big_2xxSingle * Big_2xxSingle);
- Prove_Too_Large;
- end Prove_Result_Too_Large;
-
- ---------------------
- -- Prove_Too_Large --
- ---------------------
-
- procedure Prove_Too_Large is null;
-
- -- Start of processing for Multiply_With_Ovflo_Check
-
begin
- Lemma_Mult_Decomposition (Mult, Xu, Yu, Xhi, Xlo, Yhi, Ylo);
-
if Xhi /= 0 then
if Yhi /= 0 then
- Prove_Both_Too_Large;
Raise_Error;
else
T2 := Xhi * Ylo;
- pragma Assert (Big (T2) = Big (Double_Uns'(Xhi * Ylo))
- + Big (Double_Uns'(Xlo * Yhi)));
end if;
elsif Yhi /= 0 then
T2 := Xlo * Yhi;
- pragma Assert (Big (T2) = Big (Double_Uns'(Xhi * Ylo))
- + Big (Double_Uns'(Xlo * Yhi)));
else -- Yhi = Xhi = 0
T2 := 0;
@@ -1843,57 +313,27 @@ is
-- result from the upper halves of the input values.
T1 := Xlo * Ylo;
-
- pragma Assert (Big (T2) = Big (Double_Uns'(Xhi * Ylo))
- + Big (Double_Uns'(Xlo * Yhi)));
- Lemma_Mult_Distribution (Big_2xxSingle, Big (Double_Uns'(Xhi * Ylo)),
- Big (Double_Uns'(Xlo * Yhi)));
- pragma Assert (Mult = Big_2xxSingle * Big (T2) + Big (T1));
- Lemma_Add_Commutation (T2, Hi (T1));
- pragma Assert
- (Big (T2 + Hi (T1)) = Big (T2) + Big (Double_Uns (Hi (T1))));
-
T2 := T2 + Hi (T1);
- Lemma_Hi_Lo (T1, Hi (T1), Lo (T1));
- pragma Assert
- (Mult = Big_2xxSingle * Big (T2) + Big (Double_Uns (Lo (T1))));
-
if Hi (T2) /= 0 then
- Prove_Result_Too_Large;
Raise_Error;
end if;
- Prove_Final_Decomposition;
-
T2 := Lo (T2) & Lo (T1);
- pragma Assert (Mult = Big (T2));
-
if X >= 0 then
if Y >= 0 then
- Prove_Pos_Int;
return To_Pos_Int (T2);
- pragma Annotate (CodePeer, Intentional, "precondition",
- "Intentional Unsigned->Signed conversion");
else
- Prove_Neg_Int;
- Lemma_Abs_Range (Big (X) * Big (Y));
return To_Neg_Int (T2);
end if;
else -- X < 0
if Y < 0 then
- Prove_Pos_Int;
return To_Pos_Int (T2);
- pragma Annotate (CodePeer, Intentional, "precondition",
- "Intentional Unsigned->Signed conversion");
else
- Prove_Neg_Int;
- Lemma_Abs_Range (Big (X) * Big (Y));
return To_Neg_Int (T2);
end if;
end if;
-
end Multiply_With_Ovflo_Check;
-----------------
@@ -1909,8 +349,6 @@ is
-- Scaled_Divide --
-------------------
- pragma Annotate (Gnatcheck, Exempt_On, "Metrics_Cyclomatic_Complexity",
- "limit exceeded due to proof code");
procedure Scaled_Divide
(X, Y, Z : Double_Int;
Q, R : out Double_Int;
@@ -1928,10 +366,10 @@ is
Zhi : Single_Uns := Hi (Zu);
Zlo : Single_Uns := Lo (Zu);
- D : array (1 .. 4) of Single_Uns with Relaxed_Initialization;
+ D : array (1 .. 4) of Single_Uns;
-- The dividend, four digits (D(1) is high order)
- Qd : array (1 .. 2) of Single_Uns with Relaxed_Initialization;
+ Qd : array (1 .. 2) of Single_Uns;
-- The quotient digits, two digits (Qd(1) is high order)
S1, S2, S3 : Single_Uns;
@@ -1956,605 +394,6 @@ is
T1, T2, T3 : Double_Uns;
-- Temporary values
- -- Local ghost variables
-
- Mult : constant Big_Natural := abs (Big (X) * Big (Y)) with Ghost;
- Quot : Big_Integer with Ghost;
- Big_R : Big_Integer with Ghost;
- Big_Q : Big_Integer with Ghost;
- Inter : Natural with Ghost;
-
- -- Local ghost functions
-
- function Is_Mult_Decomposition
- (D1, D2, D3, D4 : Big_Integer)
- return Boolean
- is
- (Mult = Big_2xxSingle * Big_2xxSingle * Big_2xxSingle * D1
- + Big_2xxSingle * Big_2xxSingle * D2
- + Big_2xxSingle * D3
- + D4)
- with
- Ghost,
- Annotate => (GNATprove, Inline_For_Proof);
-
- function Is_Scaled_Mult_Decomposition
- (D1, D2, D3, D4 : Big_Integer)
- return Boolean
- is
- (Mult * Big_2xx (Scale)
- = Big_2xxSingle * Big_2xxSingle * Big_2xxSingle * D1
- + Big_2xxSingle * Big_2xxSingle * D2
- + Big_2xxSingle * D3
- + D4)
- with
- Ghost,
- Annotate => (GNATprove, Inline_For_Proof),
- Pre => Scale < Double_Size;
-
- -- Local lemmas
-
- procedure Prove_Dividend_Scaling
- with
- Ghost,
- Pre => D'Initialized
- and then Scale <= Single_Size
- and then Is_Mult_Decomposition (Big (Double_Uns (D (1))),
- Big (Double_Uns (D (2))),
- Big (Double_Uns (D (3))),
- Big (Double_Uns (D (4))))
- and then Big (D (1) & D (2)) * Big_2xx (Scale) < Big_2xxDouble
- and then T1 = Shift_Left (D (1) & D (2), Scale)
- and then T2 = Shift_Left (Double_Uns (D (3)), Scale)
- and then T3 = Shift_Left (Double_Uns (D (4)), Scale),
- Post => Is_Scaled_Mult_Decomposition
- (Big (Double_Uns (Hi (T1))),
- Big (Double_Uns (Lo (T1) or Hi (T2))),
- Big (Double_Uns (Lo (T2) or Hi (T3))),
- Big (Double_Uns (Lo (T3))));
- -- Proves the scaling of the 4-digit dividend actually multiplies it by
- -- 2**Scale.
-
- procedure Prove_Multiplication (Q : Single_Uns)
- with
- Ghost,
- Pre => T1 = Q * Lo (Zu)
- and then T2 = Q * Hi (Zu)
- and then S3 = Lo (T1)
- and then T3 = Hi (T1) + Lo (T2)
- and then S2 = Lo (T3)
- and then S1 = Hi (T3) + Hi (T2),
- Post => Big3 (S1, S2, S3) = Big (Double_Uns (Q)) * Big (Zu);
- -- Proves correctness of the multiplication of divisor by quotient to
- -- compute amount to subtract.
-
- procedure Prove_Mult_Decomposition_Split2
- (D1, D2, D2_Hi, D2_Lo, D3, D4 : Big_Integer)
- with
- Ghost,
- Pre => Is_Mult_Decomposition (D1, D2, D3, D4)
- and then D2 = Big_2xxSingle * D2_Hi + D2_Lo,
- Post => Is_Mult_Decomposition (D1 + D2_Hi, D2_Lo, D3, D4);
- -- Proves decomposition of Mult after splitting second component
-
- procedure Prove_Mult_Decomposition_Split3
- (D1, D2, D3, D3_Hi, D3_Lo, D4 : Big_Integer)
- with
- Ghost,
- Pre => Is_Mult_Decomposition (D1, D2, D3, D4)
- and then D3 = Big_2xxSingle * D3_Hi + D3_Lo,
- Post => Is_Mult_Decomposition (D1, D2 + D3_Hi, D3_Lo, D4);
- -- Proves decomposition of Mult after splitting third component
-
- procedure Prove_Negative_Dividend
- with
- Ghost,
- Pre => Z /= 0
- and then Big (Qu) = abs Big_Q
- and then In_Double_Int_Range (Big_Q)
- and then Big (Ru) = abs Big_R
- and then ((X >= 0 and Y < 0) or (X < 0 and Y >= 0))
- and then Big_Q =
- (if Round then Round_Quotient (Big (X) * Big (Y), Big (Z),
- Big (X) * Big (Y) / Big (Z),
- Big (X) * Big (Y) rem Big (Z))
- else Big (X) * Big (Y) / Big (Z))
- and then Big_R = Big (X) * Big (Y) rem Big (Z),
- Post =>
- (if Z > 0 then Big_Q <= Big_0
- and then In_Double_Int_Range (-Big (Qu))
- else Big_Q >= Big_0
- and then In_Double_Int_Range (Big (Qu)))
- and then In_Double_Int_Range (-Big (Ru));
- -- Proves the sign of rounded quotient when dividend is non-positive
-
- procedure Prove_Overflow
- with
- Ghost,
- Pre => Z /= 0
- and then Mult >= Big_2xxDouble * Big (Double_Uns'(abs Z)),
- Post => not In_Double_Int_Range (Big (X) * Big (Y) / Big (Z))
- and then not In_Double_Int_Range
- (Round_Quotient (Big (X) * Big (Y), Big (Z),
- Big (X) * Big (Y) / Big (Z),
- Big (X) * Big (Y) rem Big (Z)));
- -- Proves overflow case when the quotient has at least 3 digits
-
- procedure Prove_Positive_Dividend
- with
- Ghost,
- Pre => Z /= 0
- and then Big (Qu) = abs Big_Q
- and then In_Double_Int_Range (Big_Q)
- and then Big (Ru) = abs Big_R
- and then ((X >= 0 and Y >= 0) or (X < 0 and Y < 0))
- and then Big_Q =
- (if Round then Round_Quotient (Big (X) * Big (Y), Big (Z),
- Big (X) * Big (Y) / Big (Z),
- Big (X) * Big (Y) rem Big (Z))
- else Big (X) * Big (Y) / Big (Z))
- and then Big_R = Big (X) * Big (Y) rem Big (Z),
- Post =>
- (if Z > 0 then Big_Q >= Big_0
- and then In_Double_Int_Range (Big (Qu))
- else Big_Q <= Big_0
- and then In_Double_Int_Range (-Big (Qu)))
- and then In_Double_Int_Range (Big (Ru));
- -- Proves the sign of rounded quotient when dividend is non-negative
-
- procedure Prove_Qd_Calculation_Part_1 (J : Integer)
- with
- Ghost,
- Pre => J in 1 .. 2
- and then D'Initialized
- and then D (J) < Zhi
- and then Hi (Zu) = Zhi
- and then Qd (J)'Initialized
- and then Qd (J) = Lo ((D (J) & D (J + 1)) / Zhi),
- Post => Big (Double_Uns (Qd (J))) >=
- Big3 (D (J), D (J + 1), D (J + 2)) / Big (Zu);
- -- When dividing 3 digits by 2 digits, proves the initial calculation
- -- of the quotient given by dividing the first 2 digits of the dividend
- -- by the first digit of the divisor is not an underestimate (so
- -- readjusting down works).
-
- procedure Prove_Q_Too_Big
- with
- Ghost,
- Pre => In_Double_Int_Range (Big_Q)
- and then abs Big_Q = Big_2xxDouble,
- Post => False;
- -- Proves the inconsistency when Q is equal to Big_2xx64
-
- procedure Prove_Rescaling
- with
- Ghost,
- Pre => Scale <= Single_Size
- and then Z /= 0
- and then Mult * Big_2xx (Scale) = Big (Zu) * Big (Qu) + Big (Ru)
- and then Big (Ru) < Big (Zu)
- and then Big (Zu) = Big (Double_Uns'(abs Z)) * Big_2xx (Scale)
- and then Quot = Big (X) * Big (Y) / Big (Z)
- and then Big_R = Big (X) * Big (Y) rem Big (Z),
- Post => abs Quot = Big (Qu)
- and then abs Big_R = Big (Shift_Right (Ru, Scale));
- -- Proves scaling back only the remainder is the right thing to do after
- -- computing the scaled division.
-
- procedure Prove_Rounding_Case
- with
- Ghost,
- Pre => Z /= 0
- and then Quot = Big (X) * Big (Y) / Big (Z)
- and then Big_R = Big (X) * Big (Y) rem Big (Z)
- and then Big_Q =
- Round_Quotient (Big (X) * Big (Y), Big (Z), Quot, Big_R)
- and then Big (Ru) = abs Big_R
- and then Big (Zu) = Big (Double_Uns'(abs Z)),
- Post => abs Big_Q =
- (if Ru > (Zu - Double_Uns'(1)) / Double_Uns'(2)
- then abs Quot + 1
- else abs Quot);
- -- Proves correctness of the rounding of the unsigned quotient
-
- procedure Prove_Scaled_Mult_Decomposition_Regroup24
- (D1, D2, D3, D4 : Big_Integer)
- with
- Ghost,
- Pre => Scale < Double_Size
- and then Is_Scaled_Mult_Decomposition (D1, D2, D3, D4),
- Post => Is_Scaled_Mult_Decomposition
- (0, Big_2xxSingle * D1 + D2, 0, Big_2xxSingle * D3 + D4);
- -- Proves scaled decomposition of Mult after regrouping on second and
- -- fourth component.
-
- procedure Prove_Scaled_Mult_Decomposition_Regroup3
- (D1, D2, D3, D4 : Single_Uns)
- with
- Ghost,
- Pre => Scale < Double_Size
- and then Is_Scaled_Mult_Decomposition
- (Big (Double_Uns (D1)), Big (Double_Uns (D2)),
- Big (Double_Uns (D3)), Big (Double_Uns (D4))),
- Post => Is_Scaled_Mult_Decomposition (0, 0, Big3 (D1, D2, D3),
- Big (Double_Uns (D4)));
- -- Proves scaled decomposition of Mult after regrouping on third
- -- component.
-
- procedure Prove_Sign_R
- with
- Ghost,
- Pre => Z /= 0 and then Big_R = Big (X) * Big (Y) rem Big (Z),
- Post => In_Double_Int_Range (Big_R);
-
- procedure Prove_Signs
- with
- Ghost,
- Pre => Z /= 0
- and then Quot = Big (X) * Big (Y) / Big (Z)
- and then Big_R = Big (X) * Big (Y) rem Big (Z)
- and then Big_Q =
- (if Round then
- Round_Quotient (Big (X) * Big (Y), Big (Z), Quot, Big_R)
- else Quot)
- and then Big (Ru) = abs Big_R
- and then Big (Qu) = abs Big_Q
- and then In_Double_Int_Range (Big_Q)
- and then In_Double_Int_Range (Big_R)
- and then R =
- (if (X >= 0) = (Y >= 0) then To_Pos_Int (Ru) else To_Neg_Int (Ru))
- and then Q =
- (if ((X >= 0) = (Y >= 0)) = (Z >= 0) then To_Pos_Int (Qu)
- else To_Neg_Int (Qu)), -- need to ensure To_Pos_Int precondition
- Post => Big (R) = Big_R and then Big (Q) = Big_Q;
- -- Proves final signs match the intended result after the unsigned
- -- division is done.
-
- procedure Prove_Z_Low
- with
- Ghost,
- Pre => Z /= 0
- and then D'Initialized
- and then Hi (abs Z) = 0
- and then Lo (abs Z) = Zlo
- and then Mult =
- Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (D (2)))
- + Big_2xxSingle * Big (Double_Uns (D (3)))
- + Big (Double_Uns (D (4)))
- and then D (2) < Zlo
- and then Quot = (Big (X) * Big (Y)) / Big (Z)
- and then Big_R = (Big (X) * Big (Y)) rem Big (Z)
- and then T1 = D (2) & D (3)
- and then T2 = Lo (T1 rem Zlo) & D (4)
- and then Qu = Lo (T1 / Zlo) & Lo (T2 / Zlo)
- and then Ru = T2 rem Zlo,
- Post => Big (Qu) = abs Quot
- and then Big (Ru) = abs Big_R;
- -- Proves the case where the divisor is only one digit
-
- ----------------------------
- -- Prove_Dividend_Scaling --
- ----------------------------
-
- procedure Prove_Dividend_Scaling is
- Big_D12 : constant Big_Integer :=
- Big_2xx (Scale) * Big (D (1) & D (2));
- Big_T1 : constant Big_Integer := Big (T1);
- Big_D3 : constant Big_Integer :=
- Big_2xx (Scale) * Big (Double_Uns (D (3)));
- Big_T2 : constant Big_Integer := Big (T2);
- Big_D4 : constant Big_Integer :=
- Big_2xx (Scale) * Big (Double_Uns (D (4)));
- Big_T3 : constant Big_Integer := Big (T3);
-
- begin
- Lemma_Shift_Left (D (1) & D (2), Scale);
- Lemma_Ge_Mult (Big_2xxSingle, Big_2xx (Scale), Big_2xxSingle,
- Big_2xxSingle * Big_2xx (Scale));
- Lemma_Lt_Mult (Big (Double_Uns (D (3))), Big_2xxSingle,
- Big_2xx (Scale), Big_2xxDouble);
- Lemma_Shift_Left (Double_Uns (D (3)), Scale);
- Lemma_Lt_Mult (Big (Double_Uns (D (4))), Big_2xxSingle,
- Big_2xx (Scale), Big_2xxDouble);
- Lemma_Shift_Left (Double_Uns (D (4)), Scale);
- Lemma_Hi_Lo (D (1) & D (2), D (1), D (2));
- pragma Assert (Mult * Big_2xx (Scale) =
- Big_2xxSingle * Big_2xxSingle * Big_D12
- + Big_2xxSingle * Big_D3
- + Big_D4);
- pragma Assert (Big_2xx (Scale) > 0);
- declare
- Two_xx_Scale : constant Double_Uns := Double_Uns'(2 ** Scale);
- D12 : constant Double_Uns := D (1) & D (2);
- begin
- pragma Assert (Big_2xx (Scale) * Big (D12) < Big_2xxDouble);
- pragma Assert (Big (Two_xx_Scale) * Big (D12) < Big_2xxDouble);
- Lemma_Mult_Commutation (Two_xx_Scale, D12, T1);
- end;
- pragma Assert (Big_D12 = Big_T1);
- pragma Assert (Big_2xxSingle * Big_2xxSingle * Big_D12
- = Big_2xxSingle * Big_2xxSingle * Big_T1);
- Lemma_Mult_Commutation (2 ** Scale, Double_Uns (D (3)), T2);
- pragma Assert (Big_D3 = Big_T2);
- pragma Assert (Big_2xxSingle * Big_D3 = Big_2xxSingle * Big_T2);
- Lemma_Mult_Commutation (2 ** Scale, Double_Uns (D (4)), T3);
- pragma Assert
- (Is_Scaled_Mult_Decomposition (0, Big_T1, Big_T2, Big_T3));
- Lemma_Hi_Lo (T1, Hi (T1), Lo (T1));
- Lemma_Hi_Lo (T2, Hi (T2), Lo (T2));
- Lemma_Hi_Lo (T3, Hi (T3), Lo (T3));
- Lemma_Mult_Distribution (Big_2xxSingle * Big_2xxSingle,
- Big_2xxSingle * Big (Double_Uns (Hi (T1))),
- Big (Double_Uns (Lo (T1))));
- Lemma_Mult_Distribution (Big_2xxSingle,
- Big_2xxSingle * Big (Double_Uns (Hi (T2))),
- Big (Double_Uns (Lo (T2))));
- Lemma_Mult_Distribution (Big_2xxSingle * Big_2xxSingle,
- Big (Double_Uns (Lo (T1))),
- Big (Double_Uns (Hi (T2))));
- Lemma_Mult_Distribution (Big_2xxSingle,
- Big (Double_Uns (Lo (T2))),
- Big (Double_Uns (Hi (T3))));
- Lemma_Mult_Distribution (Big_2xxSingle * Big_2xxSingle,
- Big (Double_Uns (Lo (T1))),
- Big (Double_Uns (Hi (T2))));
- pragma Assert (Double_Uns (Lo (T1) or Hi (T2)) =
- Double_Uns (Lo (T1)) + Double_Uns (Hi (T2)));
- pragma Assert (Double_Uns (Lo (T2) or Hi (T3)) =
- Double_Uns (Lo (T2)) + Double_Uns (Hi (T3)));
- Lemma_Add_Commutation (Double_Uns (Lo (T1)), Hi (T2));
- Lemma_Add_Commutation (Double_Uns (Lo (T2)), Hi (T3));
- end Prove_Dividend_Scaling;
-
- --------------------------
- -- Prove_Multiplication --
- --------------------------
-
- procedure Prove_Multiplication (Q : Single_Uns) is
- begin
- Lemma_Hi_Lo (Zu, Hi (Zu), Lo (Zu));
- Lemma_Hi_Lo (T1, Hi (T1), S3);
- Lemma_Hi_Lo (T2, Hi (T2), Lo (T2));
- Lemma_Hi_Lo (T3, Hi (T3), S2);
- Lemma_Mult_Commutation (Double_Uns (Q), Double_Uns (Lo (Zu)), T1);
- Lemma_Mult_Commutation (Double_Uns (Q), Double_Uns (Hi (Zu)), T2);
- Lemma_Mult_Distribution (Big (Double_Uns (Q)),
- Big_2xxSingle * Big (Double_Uns (Hi (Zu))),
- Big (Double_Uns (Lo (Zu))));
- Lemma_Substitution
- (Big (Double_Uns (Q)) * Big (Zu),
- Big (Double_Uns (Q)),
- Big (Zu),
- Big_2xxSingle * Big (Double_Uns (Hi (Zu)))
- + Big (Double_Uns (Lo (Zu))),
- Big_0);
- pragma Assert (Big (Double_Uns (Q)) * Big (Zu) =
- Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (Hi (T2)))
- + Big_2xxSingle * Big (Double_Uns (Lo (T2)))
- + Big_2xxSingle * Big (Double_Uns (Hi (T1)))
- + Big (Double_Uns (S3)));
- Lemma_Add_Commutation (Double_Uns (Lo (T2)), Hi (T1));
- pragma Assert
- (By (Big (Double_Uns (Q)) * Big (Zu) =
- Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (Hi (T2)))
- + Big_2xxSingle * Big (T3)
- + Big (Double_Uns (S3)),
- By (Big_2xxSingle * Big (Double_Uns (Lo (T2)))
- + Big_2xxSingle * Big (Double_Uns (Hi (T1)))
- = Big_2xxSingle * Big (T3),
- Double_Uns (Lo (T2))
- + Double_Uns (Hi (T1)) = T3)));
- pragma Assert (Double_Uns (Hi (T3)) + Hi (T2) = Double_Uns (S1));
- Lemma_Add_Commutation (Double_Uns (Hi (T3)), Hi (T2));
- pragma Assert
- (Big (Double_Uns (Hi (T3))) + Big (Double_Uns (Hi (T2))) =
- Big (Double_Uns (S1)));
- Lemma_Mult_Distribution (Big_2xxSingle * Big_2xxSingle,
- Big (Double_Uns (Hi (T3))),
- Big (Double_Uns (Hi (T2))));
- end Prove_Multiplication;
-
- -------------------------------------
- -- Prove_Mult_Decomposition_Split2 --
- -------------------------------------
-
- procedure Prove_Mult_Decomposition_Split2
- (D1, D2, D2_Hi, D2_Lo, D3, D4 : Big_Integer)
- is null;
-
- -------------------------------------
- -- Prove_Mult_Decomposition_Split3 --
- -------------------------------------
-
- procedure Prove_Mult_Decomposition_Split3
- (D1, D2, D3, D3_Hi, D3_Lo, D4 : Big_Integer)
- is null;
-
- -----------------------------
- -- Prove_Negative_Dividend --
- -----------------------------
-
- procedure Prove_Negative_Dividend is
- begin
- Lemma_Mult_Non_Positive (Big (X), Big (Y));
- end Prove_Negative_Dividend;
-
- --------------------
- -- Prove_Overflow --
- --------------------
-
- procedure Prove_Overflow is
- begin
- Lemma_Div_Ge (Mult, Big_2xxDouble, Big (Double_Uns'(abs Z)));
- Lemma_Abs_Commutation (Z);
- Lemma_Abs_Div_Commutation (Big (X) * Big (Y), Big (Z));
- end Prove_Overflow;
-
- -----------------------------
- -- Prove_Positive_Dividend --
- -----------------------------
-
- procedure Prove_Positive_Dividend is
- begin
- Lemma_Mult_Non_Negative (Big (X), Big (Y));
- end Prove_Positive_Dividend;
-
- ---------------------------------
- -- Prove_Qd_Calculation_Part_1 --
- ---------------------------------
-
- procedure Prove_Qd_Calculation_Part_1 (J : Integer) is
- begin
- Lemma_Hi_Lo (D (J) & D (J + 1), D (J), D (J + 1));
- Lemma_Lt_Commutation (Double_Uns (D (J)), Double_Uns (Zhi));
- Lemma_Gt_Mult (Big (Double_Uns (Zhi)),
- Big (Double_Uns (D (J))) + 1,
- Big_2xxSingle, Big (D (J) & D (J + 1)));
- Lemma_Div_Lt
- (Big (D (J) & D (J + 1)), Big_2xxSingle, Big (Double_Uns (Zhi)));
- Lemma_Div_Commutation (D (J) & D (J + 1), Double_Uns (Zhi));
- Lemma_Lo_Is_Ident ((D (J) & D (J + 1)) / Zhi);
- Lemma_Div_Definition (D (J) & D (J + 1), Zhi, Double_Uns (Qd (J)),
- (D (J) & D (J + 1)) rem Zhi);
- Lemma_Lt_Commutation
- ((D (J) & D (J + 1)) rem Zhi, Double_Uns (Zhi));
- Lemma_Gt_Mult
- ((Big (Double_Uns (Qd (J))) + 1) * Big (Double_Uns (Zhi)),
- Big (D (J) & D (J + 1)) + 1, Big_2xxSingle,
- Big3 (D (J), D (J + 1), D (J + 2)));
- Lemma_Hi_Lo (Zu, Zhi, Lo (Zu));
- Lemma_Gt_Mult (Big (Zu), Big_2xxSingle * Big (Double_Uns (Zhi)),
- Big (Double_Uns (Qd (J))) + 1,
- Big3 (D (J), D (J + 1), D (J + 2)));
- Lemma_Div_Lt (Big3 (D (J), D (J + 1), D (J + 2)),
- Big (Double_Uns (Qd (J))) + 1, Big (Zu));
- end Prove_Qd_Calculation_Part_1;
-
- ---------------------
- -- Prove_Q_Too_Big --
- ---------------------
-
- procedure Prove_Q_Too_Big is
- begin
- pragma Assert (Big_Q = Big_2xxDouble or Big_Q = -Big_2xxDouble);
- Lemma_Not_In_Range_Big2xx64;
- end Prove_Q_Too_Big;
-
- ---------------------
- -- Prove_Rescaling --
- ---------------------
-
- procedure Prove_Rescaling is
- begin
- Lemma_Div_Lt (Big (Ru), Big (Double_Uns'(abs Z)), Big_2xx (Scale));
- Lemma_Div_Eq (Mult, Big (Double_Uns'(abs Z)) * Big (Qu),
- Big_2xx (Scale), Big (Ru));
- Lemma_Rev_Div_Definition (Mult, Big (Double_Uns'(abs Z)),
- Big (Qu), Big (Ru) / Big_2xx (Scale));
- Lemma_Abs_Div_Commutation (Big (X) * Big (Y), Big (Z));
- Lemma_Abs_Rem_Commutation (Big (X) * Big (Y), Big (Z));
- Lemma_Abs_Commutation (Z);
- Lemma_Shift_Right (Ru, Scale);
- end Prove_Rescaling;
-
- -------------------------
- -- Prove_Rounding_Case --
- -------------------------
-
- procedure Prove_Rounding_Case is
- begin
- if Same_Sign (Big (X) * Big (Y), Big (Z)) then
- pragma Assert
- (abs Big_Q =
- (if Ru > (Zu - Double_Uns'(1)) / Double_Uns'(2)
- then abs Quot + 1
- else abs Quot));
- end if;
- end Prove_Rounding_Case;
-
- -----------------------------------------------
- -- Prove_Scaled_Mult_Decomposition_Regroup24 --
- -----------------------------------------------
-
- procedure Prove_Scaled_Mult_Decomposition_Regroup24
- (D1, D2, D3, D4 : Big_Integer)
- is null;
-
- ----------------------------------------------
- -- Prove_Scaled_Mult_Decomposition_Regroup3 --
- ----------------------------------------------
-
- procedure Prove_Scaled_Mult_Decomposition_Regroup3
- (D1, D2, D3, D4 : Single_Uns)
- is null;
-
- ------------------
- -- Prove_Sign_R --
- ------------------
-
- procedure Prove_Sign_R is
- begin
- pragma Assert (In_Double_Int_Range (Big (Z)));
- end Prove_Sign_R;
-
- -----------------
- -- Prove_Signs --
- -----------------
-
- procedure Prove_Signs is null;
-
- -----------------
- -- Prove_Z_Low --
- -----------------
-
- procedure Prove_Z_Low is
- begin
- Lemma_Hi_Lo (T1, D (2), D (3));
- Lemma_Add_Commutation (Double_Uns (D (2)), 1);
- pragma Assert
- (Big (Double_Uns (D (2))) + 1 <= Big (Double_Uns (Zlo)));
- Lemma_Div_Definition (T1, Zlo, T1 / Zlo, T1 rem Zlo);
- pragma Assert
- (By (Lo (T1 rem Zlo) = Hi (T2),
- By (Double_Uns (Lo (T1 rem Zlo)) = T1 rem Zlo,
- T1 rem Zlo <= Double_Uns (Zlo))));
- Lemma_Hi_Lo (T2, Lo (T1 rem Zlo), D (4));
- pragma Assert (T1 rem Zlo < Double_Uns (Zlo));
- pragma Assert (T1 rem Zlo + Double_Uns'(1) <= Double_Uns (Zlo));
- Lemma_Ge_Commutation (Double_Uns (Zlo), T1 rem Zlo + Double_Uns'(1));
- Lemma_Add_Commutation (T1 rem Zlo, 1);
- pragma Assert (Big (T1 rem Zlo) + 1 <= Big (Double_Uns (Zlo)));
- Lemma_Div_Definition (T2, Zlo, T2 / Zlo, Ru);
- pragma Assert
- (By (Big_2xxSingle * Big (Double_Uns (D (2)))
- + Big (Double_Uns (D (3)))
- < Big_2xxSingle * (Big (Double_Uns (D (2))) + 1),
- Mult = Big (Double_Uns (Zlo)) *
- (Big_2xxSingle * Big (T1 / Zlo) + Big (T2 / Zlo)) + Big (Ru)));
- Lemma_Div_Lt (Big (T1), Big_2xxSingle, Big (Double_Uns (Zlo)));
- Lemma_Div_Commutation (T1, Double_Uns (Zlo));
- Lemma_Lo_Is_Ident (T1 / Zlo);
- pragma Assert
- (Big (T2) <= Big_2xxSingle * (Big (Double_Uns (Zlo)) - 1)
- + Big (Double_Uns (D (4))));
- Lemma_Hi_Lo (Qu, Lo (T1 / Zlo), Lo (T2 / Zlo));
- Lemma_Div_Lt (Big (T2), Big_2xxSingle, Big (Double_Uns (Zlo)));
- Lemma_Div_Commutation (T2, Double_Uns (Zlo));
- Lemma_Lo_Is_Ident (T2 / Zlo);
- Lemma_Substitution (Mult, Big (Double_Uns (Zlo)),
- Big_2xxSingle * Big (T1 / Zlo) + Big (T2 / Zlo),
- Big (Qu), Big (Ru));
- pragma Assert
- (By (Ru < Double_Uns (Zlo), Ru = T2 rem Zlo));
- Lemma_Lt_Commutation (Ru, Double_Uns (Zlo));
- Lemma_Rev_Div_Definition
- (Mult, Big (Double_Uns (Zlo)), Big (Qu), Big (Ru));
- pragma Assert (Double_Uns (Zlo) = abs Z);
- Lemma_Abs_Commutation (Z);
- Lemma_Abs_Div_Commutation (Big (X) * Big (Y), Big (Z));
- Lemma_Abs_Rem_Commutation (Big (X) * Big (Y), Big (Z));
- end Prove_Z_Low;
-
-- Start of processing for Scaled_Divide
begin
@@ -2562,237 +401,56 @@ is
Raise_Error;
end if;
- Quot := Big (X) * Big (Y) / Big (Z);
- Big_R := Big (X) * Big (Y) rem Big (Z);
- if Round then
- Big_Q := Round_Quotient (Big (X) * Big (Y), Big (Z), Quot, Big_R);
- else
- Big_Q := Quot;
- end if;
-
-- First do the multiplication, giving the four digit dividend
- Lemma_Abs_Mult_Commutation (Big (X), Big (Y));
- Lemma_Abs_Commutation (X);
- Lemma_Abs_Commutation (Y);
- Lemma_Mult_Decomposition (Mult, Xu, Yu, Xhi, Xlo, Yhi, Ylo);
-
T1 := Xlo * Ylo;
D (4) := Lo (T1);
D (3) := Hi (T1);
- Lemma_Hi_Lo (T1, D (3), D (4));
-
if Yhi /= 0 then
T1 := Xlo * Yhi;
-
- Lemma_Hi_Lo (T1, Hi (T1), Lo (T1));
-
T2 := D (3) + Lo (T1);
- Lemma_Add_Commutation (Double_Uns (Lo (T1)), D (3));
- Lemma_Mult_Distribution (Big_2xxSingle,
- Big (Double_Uns (D (3))),
- Big (Double_Uns (Lo (T1))));
- Lemma_Hi_Lo (T2, Hi (T2), Lo (T2));
-
D (3) := Lo (T2);
D (2) := Hi (T1) + Hi (T2);
- pragma Assert (Double_Uns (Hi (T1)) + Hi (T2) = Double_Uns (D (2)));
- Lemma_Add_Commutation (Double_Uns (Hi (T1)), Hi (T2));
- pragma Assert
- (Big (Double_Uns (Hi (T1))) + Big (Double_Uns (Hi (T2))) =
- Big (Double_Uns (D (2))));
-
if Xhi /= 0 then
T1 := Xhi * Ylo;
-
- Lemma_Hi_Lo (T1, Hi (T1), Lo (T1));
-
T2 := D (3) + Lo (T1);
- Lemma_Add_Commutation (Double_Uns (D (3)), Lo (T1));
- Lemma_Hi_Lo (T2, Hi (T2), Lo (T2));
- Prove_Mult_Decomposition_Split3
- (D1 => 0,
- D2 => Big (Double_Uns'(Xhi * Yhi)) + Big (Double_Uns (D (2)))
- + Big (Double_Uns (Hi (T1))),
- D3 => Big (T2),
- D3_Hi => Big (Double_Uns (Hi (T2))),
- D3_Lo => Big (Double_Uns (Lo (T2))),
- D4 => Big (Double_Uns (D (4))));
-
D (3) := Lo (T2);
T3 := D (2) + Hi (T1);
- Lemma_Add_Commutation (Double_Uns (D (2)), Hi (T1));
- Lemma_Add_Commutation (T3, Hi (T2));
-
T3 := T3 + Hi (T2);
T2 := Double_Uns'(Xhi * Yhi);
- Lemma_Hi_Lo (T2, Hi (T2), Lo (T2));
- pragma Assert
- (Is_Mult_Decomposition
- (D1 => Big (Double_Uns (Hi (T2))),
- D2 => Big (T3) + Big (Double_Uns (Lo (T2))),
- D3 => Big (Double_Uns (D (3))),
- D4 => Big (Double_Uns (D (4)))));
-
T1 := T3 + Lo (T2);
D (2) := Lo (T1);
-
- Lemma_Add_Commutation (T3, Lo (T2));
- Lemma_Hi_Lo (T1, Hi (T1), Lo (T1));
- Prove_Mult_Decomposition_Split2
- (D1 => Big (Double_Uns (Hi (T2))),
- D2 => Big (T1),
- D2_Lo => Big (Double_Uns (Lo (T1))),
- D2_Hi => Big (Double_Uns (Hi (T1))),
- D3 => Big (Double_Uns (D (3))),
- D4 => Big (Double_Uns (D (4))));
-
D (1) := Hi (T2) + Hi (T1);
- pragma Assert_And_Cut
- (D'Initialized
- and Is_Mult_Decomposition (D1 => Big (Double_Uns (D (1))),
- D2 => Big (Double_Uns (D (2))),
- D3 => Big (Double_Uns (D (3))),
- D4 => Big (Double_Uns (D (4)))));
else
- pragma Assert
- (Is_Mult_Decomposition
- (D1 => 0,
- D2 => Big (Double_Uns (D (2))),
- D3 => Big (Double_Uns (D (3)))
- + Big (Double_Uns (Xhi)) * Big (Yu),
- D4 => Big (Double_Uns (D (4)))));
-
D (1) := 0;
-
- pragma Assert_And_Cut
- (D'Initialized
- and Is_Mult_Decomposition (D1 => Big (Double_Uns (D (1))),
- D2 => Big (Double_Uns (D (2))),
- D3 => Big (Double_Uns (D (3))),
- D4 => Big (Double_Uns (D (4)))));
end if;
-
else
if Xhi /= 0 then
T1 := Xhi * Ylo;
-
- Lemma_Hi_Lo (T1, Hi (T1), Lo (T1));
- pragma Assert
- (Is_Mult_Decomposition
- (D1 => 0,
- D2 => Big (Double_Uns (Hi (T1))),
- D3 => Big (Double_Uns (Lo (T1))) + Big (Double_Uns (D (3))),
- D4 => Big (Double_Uns (D (4)))));
-
T2 := D (3) + Lo (T1);
- Lemma_Add_Commutation (Double_Uns (Lo (T1)), D (3));
- pragma Assert
- (Is_Mult_Decomposition
- (D1 => 0,
- D2 => Big (Double_Uns (Hi (T1))),
- D3 => Big (T2),
- D4 => Big (Double_Uns (D (4)))));
- Lemma_Hi_Lo (T2, Hi (T2), Lo (T2));
-
D (3) := Lo (T2);
D (2) := Hi (T1) + Hi (T2);
- pragma Assert
- (Double_Uns (Hi (T1)) + Hi (T2) = Double_Uns (D (2)));
- Lemma_Add_Commutation (Double_Uns (Hi (T1)), Hi (T2));
- pragma Assert
- (Big (Double_Uns (Hi (T1))) + Big (Double_Uns (Hi (T2))) =
- Big (Double_Uns (D (2))));
- pragma Assert
- (Is_Mult_Decomposition
- (D1 => 0,
- D2 => Big (Double_Uns (D (2))),
- D3 => Big (Double_Uns (D (3))),
- D4 => Big (Double_Uns (D (4)))));
else
D (2) := 0;
-
- pragma Assert
- (Is_Mult_Decomposition
- (D1 => 0,
- D2 => Big (Double_Uns (D (2))),
- D3 => Big (Double_Uns (D (3))),
- D4 => Big (Double_Uns (D (4)))));
end if;
D (1) := 0;
-
- pragma Assert_And_Cut
- (D'Initialized
- and Is_Mult_Decomposition (D1 => Big (Double_Uns (D (1))),
- D2 => Big (Double_Uns (D (2))),
- D3 => Big (Double_Uns (D (3))),
- D4 => Big (Double_Uns (D (4)))));
end if;
- pragma Assert_And_Cut
- -- Restate the precondition
- (Z /= 0
- and then In_Double_Int_Range
- (if Round then Round_Quotient (Big (X) * Big (Y), Big (Z),
- Big (X) * Big (Y) / Big (Z),
- Big (X) * Big (Y) rem Big (Z))
- else Big (X) * Big (Y) / Big (Z))
- -- Restate the value of local variables
- and then Zu = abs Z
- and then Zhi = Hi (Zu)
- and then Zlo = Lo (Zu)
- and then Mult = abs (Big (X) * Big (Y))
- and then Quot = Big (X) * Big (Y) / Big (Z)
- and then Big_R = Big (X) * Big (Y) rem Big (Z)
- and then
- (if Round then
- Big_Q = Round_Quotient (Big (X) * Big (Y), Big (Z), Quot, Big_R)
- else
- Big_Q = Quot)
- -- Summarize first part of the procedure
- and then D'Initialized
- and then Is_Mult_Decomposition (D1 => Big (Double_Uns (D (1))),
- D2 => Big (Double_Uns (D (2))),
- D3 => Big (Double_Uns (D (3))),
- D4 => Big (Double_Uns (D (4)))));
-
-- Now it is time for the dreaded multiple precision division. First an
-- easy case, check for the simple case of a one digit divisor.
if Zhi = 0 then
if D (1) /= 0 or else D (2) >= Zlo then
- if D (1) > 0 then
- Lemma_Double_Big_2xxSingle;
- Lemma_Mult_Positive (Big_2xxDouble, Big_2xxSingle);
- Lemma_Ge_Mult (Big (Double_Uns (D (1))),
- 1,
- Big_2xxDouble * Big_2xxSingle,
- Big_2xxDouble * Big_2xxSingle);
- Lemma_Mult_Positive (Big_2xxSingle, Big (Double_Uns (D (1))));
- Lemma_Ge_Mult (Big_2xxSingle * Big_2xxSingle, Big_2xxDouble,
- Big_2xxSingle * Big (Double_Uns (D (1))),
- Big_2xxDouble * Big_2xxSingle);
- pragma Assert (Mult >= Big_2xxDouble * Big_2xxSingle);
- Lemma_Ge_Commutation (2 ** Single_Size, Zu);
- Lemma_Ge_Mult (Big_2xxSingle, Big (Zu), Big_2xxDouble,
- Big_2xxDouble * Big (Zu));
- pragma Assert (Mult >= Big_2xxDouble * Big (Zu));
- else
- Lemma_Ge_Commutation (Double_Uns (D (2)), Zu);
- pragma Assert (Mult >= Big_2xxDouble * Big (Zu));
- end if;
-
- Prove_Overflow;
Raise_Error;
-- Here we are dividing at most three digits by one digit
@@ -2803,18 +461,11 @@ is
Qu := Lo (T1 / Zlo) & Lo (T2 / Zlo);
Ru := T2 rem Zlo;
-
- Prove_Z_Low;
end if;
-- If divisor is double digit and dividend is too large, raise error
elsif (D (1) & D (2)) >= Zu then
- Lemma_Hi_Lo (D (1) & D (2), D (1), D (2));
- Lemma_Ge_Commutation (D (1) & D (2), Zu);
- pragma Assert
- (Mult >= Big_2xxSingle * Big_2xxSingle * Big (D (1) & D (2)));
- Prove_Overflow;
Raise_Error;
-- This is the complex case where we definitely have a double digit
@@ -2827,489 +478,87 @@ is
-- First normalize the divisor so that it has the leading bit on.
-- We do this by finding the appropriate left shift amount.
- Lemma_Hi_Lo (D (1) & D (2), D (1), D (2));
- Lemma_Lt_Commutation (D (1) & D (2), Zu);
- pragma Assert
- (Mult < Big_2xxDouble * Big (Zu));
-
Shift := Single_Size;
Mask := Single_Uns'Last;
Scale := 0;
- Inter := 0;
- pragma Assert (Big_2xx (Scale) = 1);
-
while Shift > 1 loop
- pragma Loop_Invariant (Scale <= Single_Size - Shift);
- pragma Loop_Invariant ((Hi (Zu) and Mask) /= 0);
- pragma Loop_Invariant
- (Mask = Shift_Left (Single_Uns'Last, Single_Size - Shift));
- pragma Loop_Invariant (Zu = Shift_Left (abs Z, Scale));
- pragma Loop_Invariant (Big (Zu) =
- Big (Double_Uns'(abs Z)) * Big_2xx (Scale));
- pragma Loop_Invariant (Inter in 0 .. Log_Single_Size - 1);
- pragma Loop_Invariant (Shift = 2 ** (Log_Single_Size - Inter));
- pragma Loop_Invariant (Shift mod 2 = 0);
-
- declare
- -- Local ghost variables
-
- Shift_Prev : constant Natural := Shift with Ghost;
- Mask_Prev : constant Single_Uns := Mask with Ghost;
- Zu_Prev : constant Double_Uns := Zu with Ghost;
-
- -- Local lemmas
-
- procedure Prove_Power
- with
- Ghost,
- Pre => Inter in 0 .. Log_Single_Size - 1
- and then Shift = 2 ** (Log_Single_Size - Inter),
- Post => Shift / 2 = 2 ** (Log_Single_Size - (Inter + 1))
- and then (Shift = 2 or (Shift / 2) mod 2 = 0);
-
- procedure Prove_Prev_And_Mask (Prev, Mask : Single_Uns)
- with
- Ghost,
- Pre => Prev /= 0
- and then (Prev and Mask) = 0,
- Post => (Prev and not Mask) /= 0;
-
- procedure Prove_Shift_Progress
- with
- Ghost,
- Pre => Shift <= Single_Size / 2
- and then Shift_Prev = 2 * Shift
- and then Mask_Prev =
- Shift_Left (Single_Uns'Last, Single_Size - Shift_Prev)
- and then Mask =
- Shift_Left (Single_Uns'Last,
- Single_Size - Shift_Prev + Shift),
- Post => Mask_Prev =
- Shift_Left (Single_Uns'Last, Single_Size - 2 * Shift)
- and then Mask =
- Shift_Left (Single_Uns'Last, Single_Size - Shift);
-
- procedure Prove_Shifting
- with
- Ghost,
- Pre => Shift <= Single_Size / 2
- and then Zu = Shift_Left (Zu_Prev, Shift)
- and then Mask_Prev =
- Shift_Left (Single_Uns'Last, Single_Size - 2 * Shift)
- and then Mask =
- Shift_Left (Single_Uns'Last, Single_Size - Shift)
- and then (Hi (Zu_Prev) and Mask_Prev and not Mask) /= 0,
- Post => (Hi (Zu) and Mask) /= 0;
-
- -----------------------------
- -- Local lemma null bodies --
- -----------------------------
-
- procedure Prove_Prev_And_Mask (Prev, Mask : Single_Uns) is null;
- procedure Prove_Power is null;
- procedure Prove_Shifting is null;
- procedure Prove_Shift_Progress is null;
-
- begin
- pragma Assert (Mask = Shift_Left (Single_Uns'Last,
- Single_Size - Shift_Prev));
- Prove_Power;
-
- Shift := Shift / 2;
-
- Inter := Inter + 1;
- pragma Assert (Shift_Prev = 2 * Shift);
-
- Mask := Shift_Left (Mask, Shift);
-
- Lemma_Double_Shift
- (Single_Uns'Last, Single_Size - Shift_Prev, Shift);
- Prove_Shift_Progress;
-
- if (Hi (Zu) and Mask) = 0 then
- Zu := Shift_Left (Zu, Shift);
-
- pragma Assert ((Hi (Zu_Prev) and Mask_Prev) /= 0);
- pragma Assert
- (By ((Hi (Zu_Prev) and Mask_Prev and Mask) = 0,
- (Hi (Zu_Prev) and Mask) = 0
- and then
- (Hi (Zu_Prev) and Mask_Prev and Mask)
- = (Hi (Zu_Prev) and Mask and Mask_Prev)
- ));
- Prove_Prev_And_Mask (Hi (Zu_Prev) and Mask_Prev, Mask);
- Prove_Shifting;
- pragma Assert (Big (Zu_Prev) =
- Big (Double_Uns'(abs Z)) * Big_2xx (Scale));
- Lemma_Shift_Without_Drop (Zu_Prev, Zu, Mask, Shift);
- Lemma_Substitution
- (Big (Zu), Big_2xx (Shift),
- Big (Zu_Prev), Big (Double_Uns'(abs Z)) * Big_2xx (Scale),
- 0);
- Lemma_Powers_Of_2 (Shift, Scale);
- Lemma_Substitution
- (Big (Zu), Big (Double_Uns'(abs Z)),
- Big_2xx (Shift) * Big_2xx (Scale),
- Big_2xx (Shift + Scale), 0);
- Lemma_Double_Shift (abs Z, Scale, Shift);
-
- Scale := Scale + Shift;
-
- pragma Assert (Zu = Shift_Left (abs Z, Scale));
- pragma Assert
- (Big (Zu) = Big (Double_Uns'(abs Z)) * Big_2xx (Scale));
- end if;
-
- pragma Assert
- (Big (Zu) = Big (Double_Uns'(abs Z)) * Big_2xx (Scale));
- end;
+ Shift := Shift / 2;
+ Mask := Shift_Left (Mask, Shift);
+
+ if (Hi (Zu) and Mask) = 0 then
+ Zu := Shift_Left (Zu, Shift);
+ Scale := Scale + Shift;
+ end if;
end loop;
- pragma Assert_And_Cut
- (Scale <= Single_Size - 1
- and then (Hi (Zu) and Mask) /= 0
- and then Mask = Shift_Left (Single_Uns'Last, Single_Size - 1)
- and then Zu = Shift_Left (abs Z, Scale)
- and then Big (Zu) = Big (Double_Uns'(abs Z)) * Big_2xx (Scale)
- and then Mult < Big_2xxDouble * Big (Double_Uns'(abs Z)));
Zhi := Hi (Zu);
Zlo := Lo (Zu);
- pragma Assert ((Zhi and Mask) /= 0);
- pragma Assert (Zhi >= 2 ** (Single_Size - 1));
- pragma Assert (Big (Zu) = Big (Double_Uns'(abs Z)) * Big_2xx (Scale));
- -- We have Hi (Zu) /= 0 before normalization. The sequence of
- -- Shift_Left operations results in the leading bit of Zu being 1 by
- -- moving the leftmost 1-bit in Zu to leading position, thus
- -- Zhi = Hi (Zu) >= 2 ** (Single_Size - 1) here.
-
-- Note that when we scale up the dividend, it still fits in four
-- digits, since we already tested for overflow, and scaling does
-- not change the invariant that (D (1) & D (2)) < Zu.
- Lemma_Lt_Commutation (D (1) & D (2), abs Z);
- Lemma_Big_Of_Double_Uns (Zu);
- Lemma_Lt_Mult (Big (D (1) & D (2)),
- Big (Double_Uns'(abs Z)), Big_2xx (Scale),
- Big_2xxDouble);
-
T1 := Shift_Left (D (1) & D (2), Scale);
T2 := Shift_Left (Double_Uns (D (3)), Scale);
T3 := Shift_Left (Double_Uns (D (4)), Scale);
- Prove_Dividend_Scaling;
-
D (1) := Hi (T1);
D (2) := Lo (T1) or Hi (T2);
D (3) := Lo (T2) or Hi (T3);
D (4) := Lo (T3);
- pragma Assert (D (1) = Hi (T1) and D (2) = (Lo (T1) or Hi (T2))
- and D (3) = (Lo (T2) or Hi (T3)) and D (4) = Lo (T3));
- Lemma_Substitution (Big_2xxDouble * Big (Zu), Big_2xxDouble, Big (Zu),
- Big (Double_Uns'(abs Z)) * Big_2xx (Scale), 0);
- pragma Assert (Mult < Big_2xxDouble * Big (Double_Uns'(abs Z)));
- Lemma_Lt_Mult (Mult, Big_2xxDouble * Big (Double_Uns'(abs Z)),
- Big_2xx (Scale), Big_2xxDouble * Big (Zu));
- pragma Assert (Mult >= Big_0);
- pragma Assert (Big_2xx (Scale) >= Big_0);
- Lemma_Mult_Non_Negative (Mult, Big_2xx (Scale));
- Lemma_Div_Lt (Mult * Big_2xx (Scale), Big (Zu), Big_2xxDouble);
- Lemma_Concat_Definition (D (1), D (2));
- Lemma_Double_Big_2xxSingle;
- Prove_Scaled_Mult_Decomposition_Regroup24
- (Big (Double_Uns (D (1))),
- Big (Double_Uns (D (2))),
- Big (Double_Uns (D (3))),
- Big (Double_Uns (D (4))));
- Lemma_Substitution
- (Mult * Big_2xx (Scale), Big_2xxSingle * Big_2xxSingle,
- Big_2xxSingle * Big (Double_Uns (D (1)))
- + Big (Double_Uns (D (2))),
- Big (D (1) & D (2)),
- Big_2xxSingle * Big (Double_Uns (D (3)))
- + Big (Double_Uns (D (4))));
- pragma Assert
- (By (Big (D (1) & D (2)) < Big (Zu),
- Big_2xxDouble * (Big (Zu) - Big (D (1) & D (2))) >
- Big_2xxSingle * Big (Double_Uns (D (3)))
- + Big (Double_Uns (D (4)))));
-
-- Loop to compute quotient digits, runs twice for Qd (1) and Qd (2)
- declare
- -- Local lemmas
-
- procedure Prove_First_Iteration (X1, X2, X3, X4 : Single_Uns)
- with
- Ghost,
- Pre => X1 = 0,
- Post =>
- Big_2xxSingle * Big3 (X1, X2, X3) + Big (Double_Uns (X4))
- = Big3 (X2, X3, X4);
-
- ---------------------------
- -- Prove_First_Iteration --
- ---------------------------
-
- procedure Prove_First_Iteration (X1, X2, X3, X4 : Single_Uns) is
- null;
-
- -- Local ghost variables
-
- Qd1 : Single_Uns := 0 with Ghost;
- D234 : Big_Integer with Ghost, Relaxed_Initialization;
- D123 : constant Big_Integer := Big3 (D (1), D (2), D (3))
- with Ghost;
- D4 : constant Big_Integer := Big (Double_Uns (D (4)))
- with Ghost;
-
- begin
- Prove_Scaled_Mult_Decomposition_Regroup3
- (D (1), D (2), D (3), D (4));
- pragma Assert
- (By (Mult * Big_2xx (Scale) = Big_2xxSingle * D123 + D4,
- Is_Scaled_Mult_Decomposition (0, 0, D123, D4)));
-
- for J in 1 .. 2 loop
- Lemma_Hi_Lo (D (J) & D (J + 1), D (J), D (J + 1));
- pragma Assert (Big (D (J) & D (J + 1)) < Big (Zu));
-
- -- Compute next quotient digit. We have to divide three digits
- -- by two digits. We estimate the quotient by dividing the
- -- leading two digits by the leading digit. Given the scaling
- -- we did above which ensured the first bit of the divisor is
- -- set, this gives an estimate of the quotient that is at most
- -- two too high.
-
- if D (J) > Zhi then
- Lemma_Lt_Commutation (Zu, D (J) & D (J + 1));
- pragma Assert (False);
-
- elsif D (J) = Zhi then
- Qd (J) := Single_Uns'Last;
-
- Lemma_Concat_Definition (D (J), D (J + 1));
- Lemma_Big_Of_Double_Uns_Of_Single_Uns (D (J + 2));
- pragma Assert (Big_2xxSingle > Big (Double_Uns (D (J + 2))));
- pragma Assert
- (By (Big3 (D (J), D (J + 1), 0) + Big_2xxSingle
- > Big3 (D (J), D (J + 1), D (J + 2)),
- Big3 (D (J), D (J + 1), 0) =
- Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (D (J)))
- + Big_2xxSingle * Big (Double_Uns (D (J + 1)))));
- pragma Assert (Big (Double_Uns'(0)) = 0);
- pragma Assert (Big (D (J) & D (J + 1)) * Big_2xxSingle =
- Big_2xxSingle * (Big_2xxSingle * Big (Double_Uns (D (J)))
- + Big (Double_Uns (D (J + 1)))));
- pragma Assert (Big (D (J) & D (J + 1)) * Big_2xxSingle =
- Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (D (J)))
- + Big_2xxSingle * Big (Double_Uns (D (J + 1))));
- pragma Assert (Big (D (J) & D (J + 1)) * Big_2xxSingle
- = Big3 (D (J), D (J + 1), 0));
- pragma Assert ((Big (D (J) & D (J + 1)) + 1) * Big_2xxSingle
- = Big3 (D (J), D (J + 1), 0) + Big_2xxSingle);
- Lemma_Gt_Mult (Big (Zu), Big (D (J) & D (J + 1)) + 1,
- Big_2xxSingle,
- Big3 (D (J), D (J + 1), D (J + 2)));
- Lemma_Div_Lt
- (Big3 (D (J), D (J + 1), D (J + 2)),
- Big_2xxSingle, Big (Zu));
- pragma Assert
- (By (Big (Double_Uns (Qd (J))) >=
- Big3 (D (J), D (J + 1), D (J + 2)) / Big (Zu),
- Big (Double_Uns (Qd (J))) = Big_2xxSingle - 1));
-
- else
- Qd (J) := Lo ((D (J) & D (J + 1)) / Zhi);
-
- Prove_Qd_Calculation_Part_1 (J);
- end if;
-
- pragma Assert (for all K in 1 .. J => Qd (K)'Initialized);
- Lemma_Div_Mult (Big3 (D (J), D (J + 1), D (J + 2)), Big (Zu));
- Lemma_Gt_Mult
- (Big (Double_Uns (Qd (J))),
- Big3 (D (J), D (J + 1), D (J + 2)) / Big (Zu),
- Big (Zu), Big3 (D (J), D (J + 1), D (J + 2)) - Big (Zu));
-
- -- Compute amount to subtract
-
- T1 := Qd (J) * Zlo;
- T2 := Qd (J) * Zhi;
- S3 := Lo (T1);
- T3 := Hi (T1) + Lo (T2);
- S2 := Lo (T3);
- S1 := Hi (T3) + Hi (T2);
-
- Prove_Multiplication (Qd (J));
-
- -- Adjust quotient digit if it was too high
-
- -- We use the version of the algorithm in the 2nd Edition
- -- of "The Art of Computer Programming". This had a bug not
- -- discovered till 1995, see Vol 2 errata:
- -- http://www-cs-faculty.stanford.edu/~uno/err2-2e.ps.gz.
- -- Under rare circumstances the expression in the test could
- -- overflow. This version was further corrected in 2005, see
- -- Vol 2 errata:
- -- http://www-cs-faculty.stanford.edu/~uno/all2-pre.ps.gz.
- -- This implementation is not impacted by these bugs, due
- -- to the use of a word-size comparison done in function Le3
- -- instead of a comparison on two-word integer quantities in
- -- the original algorithm.
-
- Lemma_Hi_Lo_3 (Zu, Zhi, Zlo);
-
- while not Le3 (S1, S2, S3, D (J), D (J + 1), D (J + 2)) loop
- pragma Loop_Invariant
- (Qd (1)'Initialized
- and (if J = 2 then Qd (2)'Initialized));
- pragma Loop_Invariant (if J = 2 then Qd (1) = Qd1);
- pragma Loop_Invariant
- (Big3 (S1, S2, S3) = Big (Double_Uns (Qd (J))) * Big (Zu));
- pragma Loop_Invariant
- (Big3 (S1, S2, S3) > Big3 (D (J), D (J + 1), D (J + 2)));
- pragma Assert (Big3 (S1, S2, S3) > 0);
- if Qd (J) = 0 then
- pragma Assert (Big3 (S1, S2, S3) = 0);
- pragma Assert (False);
- end if;
- Lemma_Ge_Commutation (Double_Uns (Qd (J)), 1);
- Lemma_Ge_Mult
- (Big (Double_Uns (Qd (J))), 1, Big (Zu), Big (Zu));
-
- Sub3 (S1, S2, S3, 0, Zhi, Zlo);
-
- pragma Assert
- (Big3 (S1, S2, S3) >
- Big3 (D (J), D (J + 1), D (J + 2)) - Big (Zu));
- Lemma_Subtract_Commutation (Double_Uns (Qd (J)), 1);
- pragma Assert (Double_Uns (Qd (J)) - Double_Uns'(1)
- = Double_Uns (Qd (J) - 1));
- pragma Assert (Big (Double_Uns'(1)) = 1);
-
- declare
- Prev : constant Single_Uns := Qd (J) with Ghost;
- begin
- Qd (J) := Qd (J) - 1;
- Lemma_Substitution (Big3 (S1, S2, S3), Big (Zu),
- Big (Double_Uns (Prev)) - 1,
- Big (Double_Uns (Qd (J))), 0);
- end;
-
- pragma Assert
- (Big3 (S1, S2, S3) = Big (Double_Uns (Qd (J))) * Big (Zu));
- end loop;
-
- pragma Assert_And_Cut
- (Qd (1)'Initialized
- and then (if J = 2 then Qd (2)'Initialized and Qd (1) = Qd1)
- and then D'Initialized
- and then (if J = 2 then D234'Initialized)
- and then Big3 (D (J), D (J + 1), D (J + 2)) =
- (if J = 1 then D123 else D234)
- and then (if J = 1 then D4 = Big (Double_Uns (D (4))))
- and then Big3 (S1, S2, S3) =
- Big (Double_Uns (Qd (J))) * Big (Zu)
- and then Le3 (S1, S2, S3, D (J), D (J + 1), D (J + 2))
- and then Big3 (D (J), D (J + 1), D (J + 2)) -
- Big3 (S1, S2, S3) < Big (Zu));
-
- -- Now subtract S1&S2&S3 from D1&D2&D3 ready for next step
-
- Inline_Le3 (S1, S2, S3, D (J), D (J + 1), D (J + 2));
-
- declare
- D4_G : constant Single_Uns := D (4) with Ghost;
- begin
- Sub3 (D (J), D (J + 1), D (J + 2), S1, S2, S3);
- pragma Assert (if J = 1 then D (4) = D4_G);
- pragma Assert
- (By
- (D'Initialized,
- D (1)'Initialized and D (2)'Initialized
- and D (3)'Initialized and D (4)'Initialized));
- pragma Assert
- (Big3 (D (J), D (J + 1), D (J + 2)) =
- (if J = 1 then D123 else D234)
- - Big3 (S1, S2, S3));
- end;
-
- pragma Assert
- (Big3 (D (J), D (J + 1), D (J + 2)) < Big (Zu));
-
- if D (J) > 0 then
- Lemma_Double_Big_2xxSingle;
- pragma Assert (Big3 (D (J), D (J + 1), D (J + 2)) =
- Big_2xxSingle
- * Big_2xxSingle * Big (Double_Uns (D (J)))
- + Big_2xxSingle * Big (Double_Uns (D (J + 1)))
- + Big (Double_Uns (D (J + 2))));
- pragma Assert (Big_2xxSingle >= 0);
- Lemma_Big_Of_Double_Uns_Of_Single_Uns (D (J + 1));
- pragma Assert (Big (Double_Uns (D (J + 1))) >= 0);
- Lemma_Mult_Non_Negative
- (Big_2xxSingle, Big (Double_Uns (D (J + 1))));
- pragma Assert
- (Big3 (D (J), D (J + 1), D (J + 2)) >=
- Big_2xxSingle * Big_2xxSingle
- * Big (Double_Uns (D (J))));
- Lemma_Ge_Commutation (Double_Uns (D (J)), Double_Uns'(1));
- Lemma_Ge_Mult (Big (Double_Uns (D (J))),
- Big (Double_Uns'(1)),
- Big_2xxDouble,
- Big (Double_Uns'(1)) * Big_2xxDouble);
- pragma Assert
- (Big_2xxDouble * Big (Double_Uns'(1)) = Big_2xxDouble);
- pragma Assert
- (Big3 (D (J), D (J + 1), D (J + 2)) >= Big_2xxDouble);
- pragma Assert (False);
- end if;
-
- if J = 1 then
- Qd1 := Qd (1);
- D234 := Big3 (D (2), D (3), D (4));
- pragma Assert (D4 = Big (Double_Uns (D (4))));
- Lemma_Substitution
- (Mult * Big_2xx (Scale), Big_2xxSingle, D123,
- Big3 (D (1), D (2), D (3)) + Big3 (S1, S2, S3),
- Big (Double_Uns (D (4))));
- Prove_First_Iteration (D (1), D (2), D (3), D (4));
- Lemma_Substitution (Mult * Big_2xx (Scale), Big_2xxSingle,
- Big3 (S1, S2, S3),
- Big (Double_Uns (Qd1)) * Big (Zu),
- D234);
- else
- pragma Assert (Qd1 = Qd (1));
- pragma Assert
- (By (Mult * Big_2xx (Scale) =
- Big_2xxSingle * Big (Double_Uns (Qd (1))) * Big (Zu)
- + Big (Double_Uns (Qd (2))) * Big (Zu)
- + Big_2xxSingle * Big (Double_Uns (D (3)))
- + Big (Double_Uns (D (4))),
- By (Mult * Big_2xx (Scale) =
- Big_2xxSingle * Big (Double_Uns (Qd (1))) * Big (Zu)
- + Big3 (D (2), D (3), D (4)) + Big3 (S1, S2, S3),
- Mult * Big_2xx (Scale) =
- Big_2xxSingle * Big (Double_Uns (Qd (1))) * Big (Zu)
- + D234)));
-
- end if;
+ for J in 1 .. 2 loop
+ -- Compute next quotient digit. We have to divide three digits
+ -- by two digits. We estimate the quotient by dividing the
+ -- leading two digits by the leading digit. Given the scaling
+ -- we did above which ensured the first bit of the divisor is
+ -- set, this gives an estimate of the quotient that is at most
+ -- two too high.
+
+ pragma Assert (D (J) <= Zhi);
+
+ if D (J) = Zhi then
+ Qd (J) := Single_Uns'Last;
+ else
+ Qd (J) := Lo ((D (J) & D (J + 1)) / Zhi);
+ end if;
+
+ -- Compute amount to subtract
+
+ T1 := Qd (J) * Zlo;
+ T2 := Qd (J) * Zhi;
+ S3 := Lo (T1);
+ T3 := Hi (T1) + Lo (T2);
+ S2 := Lo (T3);
+ S1 := Hi (T3) + Hi (T2);
+
+ -- Adjust quotient digit if it was too high
+
+ -- We use the version of the algorithm in the 2nd Edition
+ -- of "The Art of Computer Programming". This had a bug not
+ -- discovered till 1995, see Vol 2 errata:
+ -- http://www-cs-faculty.stanford.edu/~uno/err2-2e.ps.gz.
+ -- Under rare circumstances the expression in the test could
+ -- overflow. This version was further corrected in 2005, see
+ -- Vol 2 errata:
+ -- http://www-cs-faculty.stanford.edu/~uno/all2-pre.ps.gz.
+ -- This implementation is not impacted by these bugs, due
+ -- to the use of a word-size comparison done in function Le3
+ -- instead of a comparison on two-word integer quantities in
+ -- the original algorithm.
+
+ while not Le3 (S1, S2, S3, D (J), D (J + 1), D (J + 2)) loop
+ Sub3 (S1, S2, S3, 0, Zhi, Zlo);
+ Qd (J) := Qd (J) - 1;
end loop;
- pragma Assert_And_Cut
- (Qd (1)'Initialized and then Qd (2)'Initialized
- and then D'Initialized
- and then Big_2xxSingle * Big (Double_Uns (D (3)))
- + Big (Double_Uns (D (4))) < Big (Zu)
- and then Mult * Big_2xx (Scale) =
- Big_2xxSingle * Big (Double_Uns (Qd (1))) * Big (Zu)
- + Big (Double_Uns (Qd (2))) * Big (Zu)
- + Big_2xxSingle * Big (Double_Uns (D (3)))
- + Big (Double_Uns (D (4))));
- end;
+ -- Now subtract S1&S2&S3 from D1&D2&D3 ready for next step
+
+ Sub3 (D (J), D (J + 1), D (J + 2), S1, S2, S3);
+ end loop;
-- The two quotient digits are now set, and the remainder of the
-- scaled division is in D3&D4. To get the remainder for the
@@ -3321,271 +570,68 @@ is
Qu := Qd (1) & Qd (2);
Ru := D (3) & D (4);
- Lemma_Hi_Lo (Qu, Qd (1), Qd (2));
- Lemma_Hi_Lo (Ru, D (3), D (4));
- Lemma_Substitution
- (Mult * Big_2xx (Scale), Big (Zu),
- Big_2xxSingle * Big (Double_Uns (Qd (1)))
- + Big (Double_Uns (Qd (2))),
- Big (Qu), Big (Ru));
- Prove_Rescaling;
-
Ru := Shift_Right (Ru, Scale);
- declare
- -- Local lemma required to help automatic provers
- procedure Lemma_Div_Congruent
- (X, Y : Big_Natural;
- Z : Big_Positive)
- with
- Ghost,
- Pre => X = Y,
- Post => X / Z = Y / Z;
-
- procedure Lemma_Div_Congruent
- (X, Y : Big_Natural;
- Z : Big_Positive)
- is null;
-
- begin
- Lemma_Shift_Right (Zu, Scale);
- Lemma_Div_Congruent (Big (Zu),
- Big (Double_Uns'(abs Z)) * Big_2xx (Scale),
- Big_2xx (Scale));
-
- Zu := Shift_Right (Zu, Scale);
-
- Lemma_Simplify (Big (Double_Uns'(abs Z)), Big_2xx (Scale));
- pragma Assert (Big (Zu) = Big (Double_Uns'(abs Z)));
- end;
+ Zu := Shift_Right (Zu, Scale);
end if;
- pragma Assert (Big (Ru) = abs Big_R);
- pragma Assert (Big (Qu) = abs Quot);
- pragma Assert (Big (Zu) = Big (Double_Uns'(abs Z)));
-
-- Deal with rounding case
if Round then
- Prove_Rounding_Case;
-
if Ru > (Zu - Double_Uns'(1)) / Double_Uns'(2) then
- pragma Assert (abs Big_Q = Big (Qu) + 1);
-
-- Protect against wrapping around when rounding, by signaling
-- an overflow when the quotient is too large.
if Qu = Double_Uns'Last then
- Prove_Q_Too_Big;
Raise_Error;
end if;
- Lemma_Add_One (Qu);
-
Qu := Qu + Double_Uns'(1);
end if;
end if;
- pragma Assert (Big (Qu) = abs Big_Q);
-
-- 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
- Prove_Positive_Dividend;
-
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
- Prove_Negative_Dividend;
-
R := To_Neg_Int (Ru);
Q := (if Z > 0 then To_Neg_Int (Qu) else To_Pos_Int (Qu));
end if;
-
- Prove_Sign_R;
- Prove_Signs;
end Scaled_Divide;
- pragma Annotate (Gnatcheck, Exempt_Off, "Metrics_Cyclomatic_Complexity");
----------
-- Sub3 --
----------
procedure Sub3 (X1, X2, X3 : in out Single_Uns; Y1, Y2, Y3 : Single_Uns) is
-
- -- Local ghost variables
-
- XX1 : constant Single_Uns := X1 with Ghost;
- XX2 : constant Single_Uns := X2 with Ghost;
- XX3 : constant Single_Uns := X3 with Ghost;
-
- -- Local lemmas
-
- procedure Lemma_Add3_No_Carry (X1, X2, X3, Y1, Y2, Y3 : Single_Uns)
- with
- Ghost,
- Pre => X1 <= Single_Uns'Last - Y1
- and then X2 <= Single_Uns'Last - Y2
- and then X3 <= Single_Uns'Last - Y3,
- Post => Big3 (X1 + Y1, X2 + Y2, X3 + Y3)
- = Big3 (X1, X2, X3) + Big3 (Y1, Y2, Y3);
-
- procedure Lemma_Ge_Expand (X1, X2, X3, Y1, Y2, Y3 : Single_Uns)
- with
- Ghost,
- Pre => Big3 (X1, X2, X3) >= Big3 (Y1, Y2, Y3),
- Post => X1 > Y1
- or else (X1 = Y1 and then X2 > Y2)
- or else (X1 = Y1 and then X2 = Y2 and then X3 >= Y3);
-
- procedure Lemma_Sub3_No_Carry (X1, X2, X3, Y1, Y2, Y3 : Single_Uns)
- with
- Ghost,
- Pre => X1 >= Y1 and then X2 >= Y2 and then X3 >= Y3,
- Post => Big3 (X1 - Y1, X2 - Y2, X3 - Y3)
- = Big3 (X1, X2, X3) - Big3 (Y1, Y2, Y3);
-
- procedure Lemma_Sub3_With_Carry2 (X1, X2, X3, Y2 : Single_Uns)
- with
- Ghost,
- Pre => X2 < Y2,
- Post => Big3 (X1, X2 - Y2, X3)
- = Big3 (X1, X2, X3) + Big3 (Single_Uns'(1), 0, 0) - Big3 (0, Y2, 0);
-
- procedure Lemma_Sub3_With_Carry3 (X1, X2, X3, Y3 : Single_Uns)
- with
- Ghost,
- Pre => X3 < Y3,
- Post => Big3 (X1, X2, X3 - Y3)
- = Big3 (X1, X2, X3) + Big3 (Single_Uns'(0), 1, 0) - Big3 (0, 0, Y3);
-
- -------------------------
- -- Lemma_Add3_No_Carry --
- -------------------------
-
- procedure Lemma_Add3_No_Carry (X1, X2, X3, Y1, Y2, Y3 : Single_Uns) is
- begin
- Lemma_Add_Commutation (Double_Uns (X1), Y1);
- Lemma_Add_Commutation (Double_Uns (X2), Y2);
- Lemma_Add_Commutation (Double_Uns (X3), Y3);
- end Lemma_Add3_No_Carry;
-
- ---------------------
- -- Lemma_Ge_Expand --
- ---------------------
-
- procedure Lemma_Ge_Expand (X1, X2, X3, Y1, Y2, Y3 : Single_Uns) is null;
-
- -------------------------
- -- Lemma_Sub3_No_Carry --
- -------------------------
-
- procedure Lemma_Sub3_No_Carry (X1, X2, X3, Y1, Y2, Y3 : Single_Uns) is
- begin
- Lemma_Subtract_Commutation (Double_Uns (X1), Double_Uns (Y1));
- Lemma_Subtract_Commutation (Double_Uns (X2), Double_Uns (Y2));
- Lemma_Subtract_Commutation (Double_Uns (X3), Double_Uns (Y3));
- end Lemma_Sub3_No_Carry;
-
- ----------------------------
- -- Lemma_Sub3_With_Carry2 --
- ----------------------------
-
- procedure Lemma_Sub3_With_Carry2 (X1, X2, X3, Y2 : Single_Uns) is
- pragma Unreferenced (X1, X3);
- begin
- Lemma_Add_Commutation
- (Double_Uns'(2 ** Single_Size) - Double_Uns (Y2), X2);
- Lemma_Subtract_Commutation
- (Double_Uns'(2 ** Single_Size), Double_Uns (Y2));
- end Lemma_Sub3_With_Carry2;
-
- ----------------------------
- -- Lemma_Sub3_With_Carry3 --
- ----------------------------
-
- procedure Lemma_Sub3_With_Carry3 (X1, X2, X3, Y3 : Single_Uns) is
- pragma Unreferenced (X1, X2);
- begin
- Lemma_Add_Commutation
- (Double_Uns'(2 ** Single_Size) - Double_Uns (Y3), X3);
- Lemma_Subtract_Commutation
- (Double_Uns'(2 ** Single_Size), Double_Uns (Y3));
- end Lemma_Sub3_With_Carry3;
-
- -- Start of processing for Sub3
-
begin
- Lemma_Ge_Expand (X1, X2, X3, Y1, Y2, Y3);
-
if Y3 > X3 then
if X2 = 0 then
pragma Assert (X1 >= 1);
- Lemma_Sub3_No_Carry (X1, X2, X3, 1, 0, 0);
X1 := X1 - 1;
-
- pragma Assert
- (Big3 (X1, X2, X3) =
- Big3 (XX1, XX2, XX3) - Big3 (Single_Uns'(1), 0, 0));
- pragma Assert
- (Big3 (X1, X2, X3) = Big3 (XX1, XX2, XX3)
- - Big3 (Single_Uns'(0), Single_Uns'Last, 0)
- - Big3 (Single_Uns'(0), 1, 0));
- Lemma_Add3_No_Carry (X1, X2, X3, 0, Single_Uns'Last, 0);
- else
- Lemma_Sub3_No_Carry (X1, X2, X3, 0, 1, 0);
end if;
X2 := X2 - 1;
-
- pragma Assert
- (Big3 (X1, X2, X3) =
- Big3 (XX1, XX2, XX3) - Big3 (Single_Uns'(0), 1, 0));
- Lemma_Sub3_With_Carry3 (X1, X2, X3, Y3);
- else
- Lemma_Sub3_No_Carry (X1, X2, X3, 0, 0, Y3);
end if;
X3 := X3 - Y3;
- pragma Assert
- (Big3 (X1, X2, X3) = Big3 (XX1, XX2, XX3) - Big3 (0, 0, Y3));
-
if Y2 > X2 then
pragma Assert (X1 >= 1);
- Lemma_Sub3_No_Carry (X1, X2, X3, 1, 0, 0);
X1 := X1 - 1;
-
- pragma Assert
- (Big3 (X1, X2, X3) = Big3 (XX1, XX2, XX3)
- - Big3 (0, 0, Y3) - Big3 (Single_Uns'(1), 0, 0));
- Lemma_Sub3_With_Carry2 (X1, X2, X3, Y2);
- else
- Lemma_Sub3_No_Carry (X1, X2, X3, 0, Y2, 0);
end if;
X2 := X2 - Y2;
-
- pragma Assert
- (Big3 (X1, X2, X3) = Big3 (XX1, XX2, XX3) - Big3 (0, Y2, Y3));
- pragma Assert (X1 >= Y1);
- Lemma_Sub3_No_Carry (X1, Y2, X3, Y1, 0, 0);
-
X1 := X1 - Y1;
-
- pragma Assert
- (Big3 (X1, X2, X3) = Big3 (XX1, XX2, XX3)
- - Big3 (0, Y2, Y3) - Big3 (Y1, 0, 0));
- Lemma_Add3_No_Carry (0, Y2, Y3, Y1, 0, 0);
- pragma Assert
- (Big3 (X1, X2, X3) = Big3 (XX1, XX2, XX3) - Big3 (Y1, Y2, Y3));
end Sub3;
-------------------------------
@@ -3594,128 +640,18 @@ is
function Subtract_With_Ovflo_Check (X, Y : Double_Int) return Double_Int is
R : constant Double_Int := To_Int (To_Uns (X) - To_Uns (Y));
-
- -- Local lemmas
-
- procedure Prove_Negative_X
- with
- Ghost,
- Pre => X < 0 and then (Y <= 0 or else R < 0),
- Post => R = X - Y;
-
- procedure Prove_Non_Negative_X
- with
- Ghost,
- Pre => X >= 0 and then (Y > 0 or else R >= 0),
- Post => R = X - Y;
-
- procedure Prove_Overflow_Case
- with
- Ghost,
- Pre =>
- (if X >= 0 then Y <= 0 and then R < 0
- else Y > 0 and then R >= 0),
- Post => not In_Double_Int_Range (Big (X) - Big (Y));
-
- ----------------------
- -- Prove_Negative_X --
- ----------------------
-
- procedure Prove_Negative_X is
- begin
- if X = Double_Int'First then
- if Y = Double_Int'First or else Y > 0 then
- null;
- else
- pragma Assert
- (To_Uns (X) - To_Uns (Y) =
- 2 ** (Double_Size - 1) + Double_Uns (-Y));
- end if;
-
- elsif Y >= 0 or else Y = Double_Int'First then
- null;
-
- else
- pragma Assert
- (To_Uns (X) - To_Uns (Y) = -Double_Uns (-X) + Double_Uns (-Y));
- end if;
- end Prove_Negative_X;
-
- --------------------------
- -- Prove_Non_Negative_X --
- --------------------------
-
- procedure Prove_Non_Negative_X is
- begin
- if Y > 0 then
- declare
- Ru : constant Double_Uns := To_Uns (X) - To_Uns (Y);
- begin
- pragma Assert (Ru = Double_Uns (X) - Double_Uns (Y));
- if Ru < 2 ** (Double_Size - 1) then -- R >= 0
- pragma Assert (To_Uns (Y) <= To_Uns (X));
- Lemma_Subtract_Double_Uns (X => Y, Y => X);
- pragma Assert (Ru = Double_Uns (X - Y));
-
- elsif Ru = 2 ** (Double_Size - 1) then
- pragma Assert (Double_Uns (Y) < 2 ** (Double_Size - 1));
- pragma Assert (False);
-
- else
- pragma Assert
- (R = -Double_Int (-(Double_Uns (X) - Double_Uns (Y))));
- pragma Assert
- (R = -Double_Int (-Double_Uns (X) + Double_Uns (Y)));
- pragma Assert
- (R = -Double_Int (Double_Uns (Y) - Double_Uns (X)));
- end if;
- end;
-
- elsif Y = Double_Int'First then
- pragma Assert
- (To_Uns (X) - To_Uns (Y) =
- Double_Uns (X) - 2 ** (Double_Size - 1));
- pragma Assert (False);
-
- else
- pragma Assert
- (To_Uns (X) - To_Uns (Y) = Double_Uns (X) + Double_Uns (-Y));
- end if;
- end Prove_Non_Negative_X;
-
- -------------------------
- -- Prove_Overflow_Case --
- -------------------------
-
- procedure Prove_Overflow_Case is
- begin
- if X >= 0 and then Y /= Double_Int'First then
- pragma Assert
- (To_Uns (X) - To_Uns (Y) = Double_Uns (X) + Double_Uns (-Y));
-
- elsif X < 0 and then X /= Double_Int'First then
- pragma Assert
- (To_Uns (X) - To_Uns (Y) = -Double_Uns (-X) - Double_Uns (Y));
- end if;
- end Prove_Overflow_Case;
-
- -- Start of processing for Subtract_With_Ovflo_Check
-
begin
if X >= 0 then
if Y > 0 or else R >= 0 then
- Prove_Non_Negative_X;
return R;
end if;
else -- X < 0
if Y <= 0 or else R < 0 then
- Prove_Negative_X;
return R;
end if;
end if;
- Prove_Overflow_Case;
Raise_Error;
end Subtract_With_Ovflo_Check;
@@ -3752,5 +688,3 @@ is
pragma Annotate (Gnatcheck, Exempt_Off, "Improper_Returns");
end System.Arith_Double;
-
-pragma Annotate (Gnatcheck, Exempt_Off, "Metrics_LSLOC");
diff --git a/gcc/ada/libgnat/s-aridou.ads b/gcc/ada/libgnat/s-aridou.ads
index 5524cd0..f7240de 100644
--- a/gcc/ada/libgnat/s-aridou.ads
+++ b/gcc/ada/libgnat/s-aridou.ads
@@ -33,8 +33,6 @@
-- double word signed integer values in cases where either overflow checking
-- is required, or intermediate results are longer than the result type.
-with Ada.Numerics.Big_Numbers.Big_Integers_Ghost;
-
generic
type Double_Int is range <>;
@@ -55,51 +53,7 @@ generic
package System.Arith_Double
with Pure, SPARK_Mode
is
- -- 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. Postconditions
- -- and contract cases should not be executed at runtime as well, in order
- -- not to slow down the execution of these functions.
-
- pragma Assertion_Policy (Pre => Ignore,
- Post => Ignore,
- Contract_Cases => Ignore,
- Ghost => Ignore);
-
- package BI_Ghost renames Ada.Numerics.Big_Numbers.Big_Integers_Ghost;
- subtype Big_Integer is BI_Ghost.Big_Integer with Ghost;
- subtype Big_Natural is BI_Ghost.Big_Natural with Ghost;
- subtype Big_Positive is BI_Ghost.Big_Positive with Ghost;
- use type BI_Ghost.Big_Integer;
-
- package Signed_Conversion is
- new BI_Ghost.Signed_Conversions (Int => Double_Int);
-
- function Big (Arg : Double_Int) return Big_Integer is
- (Signed_Conversion.To_Big_Integer (Arg))
- with
- Ghost,
- Annotate => (GNATprove, Inline_For_Proof);
-
- package Unsigned_Conversion is
- new BI_Ghost.Unsigned_Conversions (Int => Double_Uns);
-
- function Big (Arg : Double_Uns) return Big_Integer is
- (Unsigned_Conversion.To_Big_Integer (Arg))
- with
- Ghost,
- Annotate => (GNATprove, Inline_For_Proof);
-
- function In_Double_Int_Range (Arg : Big_Integer) return Boolean is
- (BI_Ghost.In_Range (Arg, Big (Double_Int'First), Big (Double_Int'Last)))
- with
- Ghost,
- Annotate => (GNATprove, Inline_For_Proof);
-
- function Add_With_Ovflo_Check (X, Y : Double_Int) return Double_Int
- with
- Pre => In_Double_Int_Range (Big (X) + Big (Y)),
- Post => Add_With_Ovflo_Check'Result = X + Y;
+ function Add_With_Ovflo_Check (X, Y : Double_Int) return Double_Int;
-- Raises Constraint_Error if sum of operands overflows Double_Int,
-- otherwise returns this sum of operands as Double_Int.
--
@@ -114,10 +68,7 @@ is
-- the exception *Constraint_Error* is raised; otherwise the result is
-- correct.
- function Subtract_With_Ovflo_Check (X, Y : Double_Int) return Double_Int
- with
- Pre => In_Double_Int_Range (Big (X) - Big (Y)),
- Post => Subtract_With_Ovflo_Check'Result = X - Y;
+ function Subtract_With_Ovflo_Check (X, Y : Double_Int) return Double_Int;
-- Raises Constraint_Error if difference of operands overflows Double_Int,
-- otherwise returns this difference of operands as Double_Int.
--
@@ -127,10 +78,7 @@ is
-- overflow.
function Multiply_With_Ovflo_Check (X, Y : Double_Int) return Double_Int
- with
- Pre => In_Double_Int_Range (Big (X) * Big (Y)),
- Post => Multiply_With_Ovflo_Check'Result = X * Y;
- pragma Convention (C, Multiply_With_Ovflo_Check);
+ with Convention => C;
-- Raises Constraint_Error if product of operands overflows Double_Int,
-- otherwise returns this product of operands as Double_Int. The code
-- generator may also generate direct calls to this routine.
@@ -140,40 +88,10 @@ is
-- signed value is returned. Overflow check is performed by looking at
-- higher digits.
- function Same_Sign (X, Y : Big_Integer) return Boolean is
- (X = Big (Double_Int'(0))
- or else Y = Big (Double_Int'(0))
- or else (X < Big (Double_Int'(0))) = (Y < Big (Double_Int'(0))))
- with Ghost;
-
- function Round_Quotient (X, Y, Q, R : Big_Integer) return Big_Integer is
- (if abs R > (abs Y - Big (Double_Int'(1))) / Big (Double_Int'(2)) then
- (if Same_Sign (X, Y) then Q + Big (Double_Int'(1))
- else Q - Big (Double_Int'(1)))
- else
- Q)
- with
- Ghost,
- Pre => Y /= 0 and then Q = X / Y and then R = X rem Y;
-
procedure Scaled_Divide
(X, Y, Z : Double_Int;
Q, R : out Double_Int;
- Round : Boolean)
- with
- Pre => Z /= 0
- and then In_Double_Int_Range
- (if Round then Round_Quotient (Big (X) * Big (Y), Big (Z),
- Big (X) * Big (Y) / Big (Z),
- Big (X) * Big (Y) rem Big (Z))
- else Big (X) * Big (Y) / Big (Z)),
- Post => Big (R) = Big (X) * Big (Y) rem Big (Z)
- and then
- (if Round then
- Big (Q) = Round_Quotient (Big (X) * Big (Y), Big (Z),
- Big (X) * Big (Y) / Big (Z), Big (R))
- else
- Big (Q) = Big (X) * Big (Y) / Big (Z));
+ Round : Boolean);
-- Performs the division of (``X`` * ``Y``) / ``Z``, storing the quotient
-- in ``Q`` and the remainder in ``R``.
--
@@ -204,22 +122,7 @@ is
procedure Double_Divide
(X, Y, Z : Double_Int;
Q, R : out Double_Int;
- Round : Boolean)
- with
- Pre => Y /= 0
- and then Z /= 0
- and then In_Double_Int_Range
- (if Round then Round_Quotient (Big (X), Big (Y) * Big (Z),
- Big (X) / (Big (Y) * Big (Z)),
- Big (X) rem (Big (Y) * Big (Z)))
- else Big (X) / (Big (Y) * Big (Z))),
- Post => Big (R) = Big (X) rem (Big (Y) * Big (Z))
- and then
- (if Round then
- Big (Q) = Round_Quotient (Big (X), Big (Y) * Big (Z),
- Big (X) / (Big (Y) * Big (Z)), Big (R))
- else
- Big (Q) = Big (X) / (Big (Y) * Big (Z)));
+ Round : Boolean);
-- Performs the division ``X`` / (``Y`` * ``Z``), storing the quotient in
-- ``Q`` and the remainder in ``R``. Constraint_Error is raised if ``Y`` or
-- ``Z`` is zero, or if the quotient does not fit in ``Double_Int``.
diff --git a/gcc/ada/libgnat/s-arit128.adb b/gcc/ada/libgnat/s-arit128.adb
index b9fcbd9..c4ef40d 100644
--- a/gcc/ada/libgnat/s-arit128.adb
+++ b/gcc/ada/libgnat/s-arit128.adb
@@ -34,7 +34,6 @@ with System.Arith_Double;
package body System.Arith_128
with SPARK_Mode
is
-
subtype Uns128 is Interfaces.Unsigned_128;
subtype Uns64 is Interfaces.Unsigned_64;
diff --git a/gcc/ada/libgnat/s-arit128.ads b/gcc/ada/libgnat/s-arit128.ads
index 9181f0b..ea4ef6b 100644
--- a/gcc/ada/libgnat/s-arit128.ads
+++ b/gcc/ada/libgnat/s-arit128.ads
@@ -36,102 +36,31 @@
pragma Restrictions (No_Elaboration_Code);
-- Allow direct call from gigi generated code
--- 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. Postconditions
--- and contract cases should not be executed at runtime as well, in order
--- not to slow down the execution of these functions.
-
-pragma Assertion_Policy (Pre => Ignore,
- Post => Ignore,
- Contract_Cases => Ignore,
- Ghost => Ignore);
-
-with Ada.Numerics.Big_Numbers.Big_Integers_Ghost;
with Interfaces;
package System.Arith_128
with Pure, SPARK_Mode
is
- use type Ada.Numerics.Big_Numbers.Big_Integers_Ghost.Big_Integer;
- use type Interfaces.Integer_128;
-
subtype Int128 is Interfaces.Integer_128;
- subtype Big_Integer is
- Ada.Numerics.Big_Numbers.Big_Integers_Ghost.Big_Integer
- with Ghost;
-
- package Signed_Conversion is new
- Ada.Numerics.Big_Numbers.Big_Integers_Ghost.Signed_Conversions
- (Int => Int128);
-
- function Big (Arg : Int128) return Big_Integer is
- (Signed_Conversion.To_Big_Integer (Arg))
- with Ghost;
-
- function In_Int128_Range (Arg : Big_Integer) return Boolean is
- (Ada.Numerics.Big_Numbers.Big_Integers_Ghost.In_Range
- (Arg, Big (Int128'First), Big (Int128'Last)))
- with Ghost;
-
- function Add_With_Ovflo_Check128 (X, Y : Int128) return Int128
- with
- Pre => In_Int128_Range (Big (X) + Big (Y)),
- Post => Add_With_Ovflo_Check128'Result = X + Y;
+ function Add_With_Ovflo_Check128 (X, Y : Int128) return Int128;
-- Raises Constraint_Error if sum of operands overflows 128 bits,
-- otherwise returns the 128-bit signed integer sum.
- function Subtract_With_Ovflo_Check128 (X, Y : Int128) return Int128
- with
- Pre => In_Int128_Range (Big (X) - Big (Y)),
- Post => Subtract_With_Ovflo_Check128'Result = X - Y;
+ function Subtract_With_Ovflo_Check128 (X, Y : Int128) return Int128;
-- Raises Constraint_Error if difference of operands overflows 128
-- bits, otherwise returns the 128-bit signed integer difference.
- function Multiply_With_Ovflo_Check128 (X, Y : Int128) return Int128
- with
- Pre => In_Int128_Range (Big (X) * Big (Y)),
- Post => Multiply_With_Ovflo_Check128'Result = X * Y;
+ function Multiply_With_Ovflo_Check128 (X, Y : Int128) return Int128;
pragma Export (C, Multiply_With_Ovflo_Check128, "__gnat_mulv128");
-- Raises Constraint_Error if product of operands overflows 128
-- bits, otherwise returns the 128-bit signed integer product.
-- The code generator may also generate direct calls to this routine.
- function Same_Sign (X, Y : Big_Integer) return Boolean is
- (X = Big (Int128'(0))
- or else Y = Big (Int128'(0))
- or else (X < Big (Int128'(0))) = (Y < Big (Int128'(0))))
- with Ghost;
-
- function Round_Quotient (X, Y, Q, R : Big_Integer) return Big_Integer is
- (if abs R > (abs Y - Big (Int128'(1))) / Big (Int128'(2)) then
- (if Same_Sign (X, Y) then Q + Big (Int128'(1))
- else Q - Big (Int128'(1)))
- else
- Q)
- with
- Ghost,
- Pre => Y /= 0 and then Q = X / Y and then R = X rem Y;
-
procedure Scaled_Divide128
(X, Y, Z : Int128;
Q, R : out Int128;
- Round : Boolean)
- with
- Pre => Z /= 0
- and then In_Int128_Range
- (if Round then Round_Quotient (Big (X) * Big (Y), Big (Z),
- Big (X) * Big (Y) / Big (Z),
- Big (X) * Big (Y) rem Big (Z))
- else Big (X) * Big (Y) / Big (Z)),
- Post => Big (R) = Big (X) * Big (Y) rem Big (Z)
- and then
- (if Round then
- Big (Q) = Round_Quotient (Big (X) * Big (Y), Big (Z),
- Big (X) * Big (Y) / Big (Z), Big (R))
- else
- Big (Q) = Big (X) * Big (Y) / Big (Z));
+ 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 128 bits. Round indicates if
@@ -143,22 +72,7 @@ is
procedure Double_Divide128
(X, Y, Z : Int128;
Q, R : out Int128;
- Round : Boolean)
- with
- Pre => Y /= 0
- and then Z /= 0
- and then In_Int128_Range
- (if Round then Round_Quotient (Big (X), Big (Y) * Big (Z),
- Big (X) / (Big (Y) * Big (Z)),
- Big (X) rem (Big (Y) * Big (Z)))
- else Big (X) / (Big (Y) * Big (Z))),
- Post => Big (R) = Big (X) rem (Big (Y) * Big (Z))
- and then
- (if Round then
- Big (Q) = Round_Quotient (Big (X), Big (Y) * Big (Z),
- Big (X) / (Big (Y) * Big (Z)), Big (R))
- else
- Big (Q) = Big (X) / (Big (Y) * Big (Z)));
+ Round : Boolean);
-- Performs the division X / (Y * Z), storing the quotient in Q and
-- the remainder in R. Constraint_Error is raised if Y or Z is zero,
-- or if the quotient does not fit in 128 bits. Round indicates if the
diff --git a/gcc/ada/libgnat/s-arit32.adb b/gcc/ada/libgnat/s-arit32.adb
index 91082e7..0cc88ed 100644
--- a/gcc/ada/libgnat/s-arit32.adb
+++ b/gcc/ada/libgnat/s-arit32.adb
@@ -34,20 +34,11 @@
-- would be too costly otherwise. This is enforced by setting the assertion
-- policy to Ignore.
-pragma Assertion_Policy (Pre => Ignore,
- Post => Ignore,
- Ghost => Ignore,
- Loop_Invariant => Ignore,
- Assert => Ignore);
-
-with Ada.Numerics.Big_Numbers.Big_Integers_Ghost;
-use Ada.Numerics.Big_Numbers.Big_Integers_Ghost;
with Ada.Unchecked_Conversion;
package body System.Arith_32
with SPARK_Mode
is
-
pragma Suppress (Overflow_Check);
pragma Suppress (Range_Check);
@@ -58,33 +49,6 @@ is
function To_Int is new Ada.Unchecked_Conversion (Uns32, Int32);
- package Unsigned_Conversion is new Unsigned_Conversions (Int => Uns32);
-
- function Big (Arg : Uns32) return Big_Integer is
- (Unsigned_Conversion.To_Big_Integer (Arg))
- with Ghost;
-
- package Unsigned_Conversion_64 is new Unsigned_Conversions (Int => Uns64);
-
- function Big (Arg : Uns64) return Big_Integer is
- (Unsigned_Conversion_64.To_Big_Integer (Arg))
- with Ghost;
-
- pragma Warnings
- (Off, "non-preelaborable call not allowed in preelaborated unit",
- Reason => "Ghost code is not compiled");
- Big_0 : constant Big_Integer :=
- Big (Uns32'(0))
- with Ghost;
- Big_2xx32 : constant Big_Integer :=
- Big (Uns32'(2 ** 32 - 1)) + 1
- with Ghost;
- Big_2xx64 : constant Big_Integer :=
- Big (Uns64'(2 ** 64 - 1)) + 1
- with Ghost;
- pragma Warnings
- (On, "non-preelaborable call not allowed in preelaborated unit");
-
-----------------------
-- Local Subprograms --
-----------------------
@@ -96,166 +60,23 @@ is
-- 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 Lo (A : Uns64) return Uns32 is (Uns32 (A and (2 ** 32 - 1)));
- -- Low order half of 64-bit value
-
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
- with
- Pre => In_Int32_Range (-Big (A)),
- Post => Big (To_Neg_Int'Result) = -Big (A);
+ 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
- with
- Pre => In_Int32_Range (Big (A)),
- Post => Big (To_Pos_Int'Result) = Big (A);
+ 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 with
- Always_Terminates,
- Exceptional_Cases => (Constraint_Error => True);
- pragma No_Return (Raise_Error);
+ procedure Raise_Error with No_Return;
-- Raise constraint error with appropriate message
- ------------------
- -- Local Lemmas --
- ------------------
-
- procedure Lemma_Abs_Commutation (X : Int32)
- with
- Ghost,
- Post => abs Big (X) = Big (Uns32'(abs X));
-
- procedure Lemma_Abs_Div_Commutation (X, Y : Big_Integer)
- with
- Ghost,
- Pre => Y /= 0,
- Post => abs (X / Y) = abs X / abs Y;
-
- procedure Lemma_Abs_Mult_Commutation (X, Y : Big_Integer)
- with
- Ghost,
- Post => abs (X * Y) = abs X * abs Y;
-
- procedure Lemma_Abs_Rem_Commutation (X, Y : Big_Integer)
- with
- Ghost,
- Pre => Y /= 0,
- Post => abs (X rem Y) = (abs X) rem (abs Y);
-
- procedure Lemma_Div_Commutation (X, Y : Uns64)
- with
- Ghost,
- Pre => Y /= 0,
- Post => Big (X) / Big (Y) = Big (X / Y);
-
- procedure Lemma_Div_Ge (X, Y, Z : Big_Integer)
- with
- Ghost,
- Pre => Z > 0 and then X >= Y * Z,
- Post => X / Z >= Y;
-
- procedure Lemma_Ge_Commutation (A, B : Uns32)
- with
- Ghost,
- Pre => A >= B,
- Post => Big (A) >= Big (B);
-
- procedure Lemma_Hi_Lo (Xu : Uns64; Xhi, Xlo : Uns32)
- with
- Ghost,
- Pre => Xhi = Hi (Xu) and Xlo = Lo (Xu),
- Post => Big (Xu) = Big_2xx32 * Big (Xhi) + Big (Xlo);
-
- procedure Lemma_Mult_Commutation (X, Y, Z : Uns64)
- with
- Ghost,
- Pre => Big (X) * Big (Y) < Big_2xx64 and then Z = X * Y,
- Post => Big (X) * Big (Y) = Big (Z);
-
- procedure Lemma_Mult_Non_Negative (X, Y : Big_Integer)
- with
- Ghost,
- Pre => (X >= Big_0 and then Y >= Big_0)
- or else (X <= Big_0 and then Y <= Big_0),
- Post => X * Y >= Big_0;
-
- procedure Lemma_Mult_Non_Positive (X, Y : Big_Integer)
- with
- Ghost,
- Pre => (X <= Big_0 and then Y >= Big_0)
- or else (X >= Big_0 and then Y <= Big_0),
- Post => X * Y <= Big_0;
-
- procedure Lemma_Neg_Rem (X, Y : Big_Integer)
- with
- Ghost,
- Pre => Y /= 0,
- Post => X rem Y = X rem (-Y);
-
- procedure Lemma_Not_In_Range_Big2xx32
- with
- Post => not In_Int32_Range (Big_2xx32)
- and then not In_Int32_Range (-Big_2xx32);
-
- procedure Lemma_Rem_Commutation (X, Y : Uns64)
- with
- Ghost,
- Pre => Y /= 0,
- Post => Big (X) rem Big (Y) = Big (X rem Y);
-
- -----------------------------
- -- Local lemma null bodies --
- -----------------------------
-
- procedure Lemma_Abs_Commutation (X : Int32) is null;
- procedure Lemma_Abs_Div_Commutation (X, Y : Big_Integer) is null;
- procedure Lemma_Abs_Mult_Commutation (X, Y : Big_Integer) is null;
- procedure Lemma_Div_Commutation (X, Y : Uns64) is null;
- procedure Lemma_Div_Ge (X, Y, Z : Big_Integer) is null;
- procedure Lemma_Ge_Commutation (A, B : Uns32) is null;
- procedure Lemma_Mult_Commutation (X, Y, Z : Uns64) is null;
- procedure Lemma_Mult_Non_Negative (X, Y : Big_Integer) is null;
- procedure Lemma_Mult_Non_Positive (X, Y : Big_Integer) is null;
- procedure Lemma_Neg_Rem (X, Y : Big_Integer) is null;
- procedure Lemma_Not_In_Range_Big2xx32 is null;
- procedure Lemma_Rem_Commutation (X, Y : Uns64) is null;
-
- -------------------------------
- -- Lemma_Abs_Rem_Commutation --
- -------------------------------
-
- procedure Lemma_Abs_Rem_Commutation (X, Y : Big_Integer) is
- begin
- if Y < 0 then
- Lemma_Neg_Rem (X, Y);
- if X < 0 then
- pragma Assert (X rem Y = -((-X) rem (-Y)));
- pragma Assert (abs (X rem Y) = (abs X) rem (abs Y));
- else
- pragma Assert (abs (X rem Y) = (abs X) rem (abs Y));
- end if;
- end if;
- end Lemma_Abs_Rem_Commutation;
-
- -----------------
- -- Lemma_Hi_Lo --
- -----------------
-
- procedure Lemma_Hi_Lo (Xu : Uns64; Xhi, Xlo : Uns32) is
- begin
- pragma Assert (Uns64 (Xhi) = Xu / Uns64'(2 ** 32));
- pragma Assert (Uns64 (Xlo) = Xu mod 2 ** 32);
- end Lemma_Hi_Lo;
-
-----------------
-- Raise_Error --
-----------------
@@ -263,9 +84,6 @@ is
procedure Raise_Error is
begin
raise Constraint_Error with "32-bit arithmetic overflow";
- pragma Annotate
- (GNATprove, Intentional, "exception might be raised",
- "Procedure Raise_Error is called to signal input errors");
end Raise_Error;
-------------------
@@ -288,197 +106,20 @@ is
Ru : Uns32;
-- Unsigned quotient and remainder
- -- Local ghost variables
-
- Mult : constant Big_Integer := abs (Big (X) * Big (Y)) with Ghost;
- Quot : Big_Integer with Ghost;
- Big_R : Big_Integer with Ghost;
- Big_Q : Big_Integer with Ghost;
-
- -- Local lemmas
-
- procedure Prove_Negative_Dividend
- with
- Ghost,
- Pre => Z /= 0
- and then ((X >= 0 and Y < 0) or (X < 0 and Y >= 0))
- and then Big_Q =
- (if Round then Round_Quotient (Big (X) * Big (Y), Big (Z),
- Big (X) * Big (Y) / Big (Z),
- Big (X) * Big (Y) rem Big (Z))
- else Big (X) * Big (Y) / Big (Z)),
- Post =>
- (if Z > 0 then Big_Q <= Big_0 else Big_Q >= Big_0);
- -- Proves the sign of rounded quotient when dividend is non-positive
-
- procedure Prove_Overflow
- with
- Ghost,
- Pre => Z /= 0 and then Mult >= Big_2xx32 * Big (Uns32'(abs Z)),
- Post => not In_Int32_Range (Big (X) * Big (Y) / Big (Z))
- and then not In_Int32_Range
- (Round_Quotient (Big (X) * Big (Y), Big (Z),
- Big (X) * Big (Y) / Big (Z),
- Big (X) * Big (Y) rem Big (Z)));
- -- Proves overflow case
-
- procedure Prove_Positive_Dividend
- with
- Ghost,
- Pre => Z /= 0
- and then ((X >= 0 and Y >= 0) or (X < 0 and Y < 0))
- and then Big_Q =
- (if Round then Round_Quotient (Big (X) * Big (Y), Big (Z),
- Big (X) * Big (Y) / Big (Z),
- Big (X) * Big (Y) rem Big (Z))
- else Big (X) * Big (Y) / Big (Z)),
- Post =>
- (if Z > 0 then Big_Q >= Big_0 else Big_Q <= Big_0);
- -- Proves the sign of rounded quotient when dividend is non-negative
-
- procedure Prove_Rounding_Case
- with
- Ghost,
- Pre => Z /= 0
- and then Quot = Big (X) * Big (Y) / Big (Z)
- and then Big_R = Big (X) * Big (Y) rem Big (Z)
- and then Big_Q =
- Round_Quotient (Big (X) * Big (Y), Big (Z), Quot, Big_R)
- and then Big (Ru) = abs Big_R
- and then Big (Zu) = Big (Uns32'(abs Z)),
- Post => abs Big_Q =
- (if Ru > (Zu - Uns32'(1)) / Uns32'(2)
- then abs Quot + 1
- else abs Quot);
- -- Proves correctness of the rounding of the unsigned quotient
-
- procedure Prove_Sign_R
- with
- Ghost,
- Pre => Z /= 0 and then Big_R = Big (X) * Big (Y) rem Big (Z),
- Post => In_Int32_Range (Big_R);
-
- procedure Prove_Signs
- with
- Ghost,
- Pre => Z /= 0
- and then Quot = Big (X) * Big (Y) / Big (Z)
- and then Big_R = Big (X) * Big (Y) rem Big (Z)
- and then Big_Q =
- (if Round then
- Round_Quotient (Big (X) * Big (Y), Big (Z), Quot, Big_R)
- else Quot)
- and then Big (Ru) = abs Big_R
- and then Big (Qu) = abs Big_Q
- and then In_Int32_Range (Big_Q)
- and then In_Int32_Range (Big_R)
- and then R =
- (if (X >= 0) = (Y >= 0) then To_Pos_Int (Ru) else To_Neg_Int (Ru))
- and then Q =
- (if ((X >= 0) = (Y >= 0)) = (Z >= 0) then To_Pos_Int (Qu)
- else To_Neg_Int (Qu)), -- need to ensure To_Pos_Int precondition
- Post => Big (R) = Big_R and then Big (Q) = Big_Q;
- -- Proves final signs match the intended result after the unsigned
- -- division is done.
-
- -----------------------------
- -- Prove_Negative_Dividend --
- -----------------------------
-
- procedure Prove_Negative_Dividend is
- begin
- Lemma_Mult_Non_Positive (Big (X), Big (Y));
- end Prove_Negative_Dividend;
-
- --------------------
- -- Prove_Overflow --
- --------------------
-
- procedure Prove_Overflow is
- begin
- Lemma_Div_Ge (Mult, Big_2xx32, Big (Uns32'(abs Z)));
- Lemma_Abs_Commutation (Z);
- Lemma_Abs_Div_Commutation (Big (X) * Big (Y), Big (Z));
- end Prove_Overflow;
-
- -----------------------------
- -- Prove_Positive_Dividend --
- -----------------------------
-
- procedure Prove_Positive_Dividend is
- begin
- Lemma_Mult_Non_Negative (Big (X), Big (Y));
- end Prove_Positive_Dividend;
-
- -------------------------
- -- Prove_Rounding_Case --
- -------------------------
-
- procedure Prove_Rounding_Case is
- begin
- if Same_Sign (Big (X) * Big (Y), Big (Z)) then
- pragma Assert
- (abs Big_Q =
- (if Ru > (Zu - Uns32'(1)) / Uns32'(2)
- then abs Quot + 1
- else abs Quot));
- end if;
- end Prove_Rounding_Case;
-
- ------------------
- -- Prove_Sign_R --
- ------------------
-
- procedure Prove_Sign_R is
- begin
- pragma Assert (In_Int32_Range (Big (Z)));
- end Prove_Sign_R;
-
- -----------------
- -- Prove_Signs --
- -----------------
-
- procedure Prove_Signs is
- begin
- if (X >= 0) = (Y >= 0) then
- pragma Assert (Big (R) = Big_R and then Big (Q) = Big_Q);
- else
- pragma Assert (Big (R) = Big_R and then Big (Q) = Big_Q);
- end if;
- end Prove_Signs;
-
- -- Start of processing for Scaled_Divide32
-
begin
-- First do the 64-bit multiplication
D := Uns64 (Xu) * Uns64 (Yu);
- Lemma_Abs_Mult_Commutation (Big (X), Big (Y));
- pragma Assert (Mult = Big (D));
- Lemma_Hi_Lo (D, Hi (D), Lo (D));
- pragma Assert (Mult = Big_2xx32 * Big (Hi (D)) + Big (Lo (D)));
-
-- If divisor is zero, raise error
if Z = 0 then
Raise_Error;
end if;
- Quot := Big (X) * Big (Y) / Big (Z);
- Big_R := Big (X) * Big (Y) rem Big (Z);
- if Round then
- Big_Q := Round_Quotient (Big (X) * Big (Y), Big (Z), Quot, Big_R);
- else
- Big_Q := Quot;
- end if;
-
-- If dividend is too large, raise error
if Hi (D) >= Zu then
- Lemma_Ge_Commutation (Hi (D), Zu);
- pragma Assert (Mult >= Big_2xx32 * Big (Zu));
- Prove_Overflow;
Raise_Error;
end if;
@@ -487,35 +128,14 @@ is
Qu := Uns32 (D / Uns64 (Zu));
Ru := Uns32 (D rem Uns64 (Zu));
- Lemma_Abs_Div_Commutation (Big (X) * Big (Y), Big (Z));
- Lemma_Abs_Rem_Commutation (Big (X) * Big (Y), Big (Z));
- Lemma_Abs_Commutation (X);
- Lemma_Abs_Commutation (Y);
- Lemma_Abs_Commutation (Z);
- Lemma_Mult_Commutation (Uns64 (Xu), Uns64 (Yu), D);
- Lemma_Div_Commutation (D, Uns64 (Zu));
- Lemma_Rem_Commutation (D, Uns64 (Zu));
-
- pragma Assert (Uns64 (Qu) = D / Uns64 (Zu));
- pragma Assert (Uns64 (Ru) = D rem Uns64 (Zu));
- pragma Assert (Big (Ru) = abs Big_R);
- pragma Assert (Big (Qu) = abs Quot);
- pragma Assert (Big (Zu) = Big (Uns32'(abs Z)));
-
-- Deal with rounding case
if Round then
- Prove_Rounding_Case;
-
if Ru > (Zu - Uns32'(1)) / Uns32'(2) then
- pragma Assert (abs Big_Q = Big (Qu) + 1);
-
-- Protect against wrapping around when rounding, by signaling
-- an overflow when the quotient is too large.
if Qu = Uns32'Last then
- pragma Assert (abs Big_Q = Big_2xx32);
- Lemma_Not_In_Range_Big2xx32;
Raise_Error;
end if;
@@ -523,31 +143,20 @@ is
end if;
end if;
- pragma Assert (In_Int32_Range (Big_Q));
- pragma Assert (Big (Qu) = abs Big_Q);
- pragma Assert (Big (Ru) = abs Big_R);
- Prove_Sign_R;
-
-- 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
- Prove_Positive_Dividend;
-
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
- Prove_Negative_Dividend;
-
R := To_Neg_Int (Ru);
Q := (if Z > 0 then To_Neg_Int (Qu) else To_Pos_Int (Qu));
end if;
-
- Prove_Signs;
end Scaled_Divide32;
----------------
@@ -559,6 +168,7 @@ is
(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;
diff --git a/gcc/ada/libgnat/s-arit32.ads b/gcc/ada/libgnat/s-arit32.ads
index a8abbdc..856dd59 100644
--- a/gcc/ada/libgnat/s-arit32.ads
+++ b/gcc/ada/libgnat/s-arit32.ads
@@ -33,79 +33,19 @@
-- signed integer values in cases where either overflow checking is
-- required, or intermediate results are longer than 32 bits.
--- 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. Postconditions
--- and contract cases should not be executed at runtime as well, in order
--- not to slow down the execution of these functions.
-
-pragma Assertion_Policy (Pre => Ignore,
- Post => Ignore,
- Contract_Cases => Ignore,
- Ghost => Ignore);
-
with Interfaces;
-with Ada.Numerics.Big_Numbers.Big_Integers_Ghost;
package System.Arith_32
with Pure, SPARK_Mode
is
- use type Ada.Numerics.Big_Numbers.Big_Integers_Ghost.Big_Integer;
use type Interfaces.Integer_32;
subtype Int32 is Interfaces.Integer_32;
- subtype Big_Integer is
- Ada.Numerics.Big_Numbers.Big_Integers_Ghost.Big_Integer
- with Ghost;
-
- package Signed_Conversion is new
- Ada.Numerics.Big_Numbers.Big_Integers_Ghost.Signed_Conversions
- (Int => Int32);
-
- function Big (Arg : Int32) return Big_Integer is
- (Signed_Conversion.To_Big_Integer (Arg))
- with Ghost;
-
- function In_Int32_Range (Arg : Big_Integer) return Boolean is
- (Ada.Numerics.Big_Numbers.Big_Integers_Ghost.In_Range
- (Arg, Big (Int32'First), Big (Int32'Last)))
- with Ghost;
-
- function Same_Sign (X, Y : Big_Integer) return Boolean is
- (X = Big (Int32'(0))
- or else Y = Big (Int32'(0))
- or else (X < Big (Int32'(0))) = (Y < Big (Int32'(0))))
- with Ghost;
-
- function Round_Quotient (X, Y, Q, R : Big_Integer) return Big_Integer is
- (if abs R > (abs Y - Big (Int32'(1))) / Big (Int32'(2)) then
- (if Same_Sign (X, Y) then Q + Big (Int32'(1))
- else Q - Big (Int32'(1)))
- else
- Q)
- with
- Ghost,
- Pre => Y /= 0 and then Q = X / Y and then R = X rem Y;
-
procedure Scaled_Divide32
(X, Y, Z : Int32;
Q, R : out Int32;
- Round : Boolean)
- with
- Pre => Z /= 0
- and then In_Int32_Range
- (if Round then Round_Quotient (Big (X) * Big (Y), Big (Z),
- Big (X) * Big (Y) / Big (Z),
- Big (X) * Big (Y) rem Big (Z))
- else Big (X) * Big (Y) / Big (Z)),
- Post => Big (R) = Big (X) * Big (Y) rem Big (Z)
- and then
- (if Round then
- Big (Q) = Round_Quotient (Big (X) * Big (Y), Big (Z),
- Big (X) * Big (Y) / Big (Z), Big (R))
- else
- Big (Q) = Big (X) * Big (Y) / Big (Z));
+ Round : Boolean);
-- Performs the division of (``X`` * ``Y``) / ``Z``, storing the quotient
-- in ``Q`` and the remainder in ``R``.
--
diff --git a/gcc/ada/libgnat/s-arit64.adb b/gcc/ada/libgnat/s-arit64.adb
index 331f328..4e0336f 100644
--- a/gcc/ada/libgnat/s-arit64.adb
+++ b/gcc/ada/libgnat/s-arit64.adb
@@ -28,14 +28,12 @@
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-pragma Assertion_Policy (Ghost => Ignore);
with System.Arith_Double;
package body System.Arith_64
with SPARK_Mode
is
-
subtype Uns64 is Interfaces.Unsigned_64;
subtype Uns32 is Interfaces.Unsigned_32;
@@ -52,9 +50,6 @@ is
function Multiply_With_Ovflo_Check64 (X, Y : Int64) return Int64
renames Impl.Multiply_With_Ovflo_Check;
- function Round_Quotient (X, Y, Q, R : Big_Integer) return Big_Integer
- renames Impl.Round_Quotient;
-
procedure Scaled_Divide64
(X, Y, Z : Int64;
Q, R : out Int64;
diff --git a/gcc/ada/libgnat/s-arit64.ads b/gcc/ada/libgnat/s-arit64.ads
index 2ddd15c..6e12789 100644
--- a/gcc/ada/libgnat/s-arit64.ads
+++ b/gcc/ada/libgnat/s-arit64.ads
@@ -36,49 +36,14 @@
pragma Restrictions (No_Elaboration_Code);
-- Allow direct call from gigi generated code
--- 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. Postconditions
--- and contract cases should not be executed at runtime as well, in order
--- not to slow down the execution of these functions.
-
-pragma Assertion_Policy (Pre => Ignore,
- Post => Ignore,
- Contract_Cases => Ignore,
- Ghost => Ignore);
-
-with Ada.Numerics.Big_Numbers.Big_Integers_Ghost;
with Interfaces;
package System.Arith_64
with Pure, SPARK_Mode
is
- use type Ada.Numerics.Big_Numbers.Big_Integers_Ghost.Big_Integer;
- use type Interfaces.Integer_64;
-
subtype Int64 is Interfaces.Integer_64;
- subtype Big_Integer is
- Ada.Numerics.Big_Numbers.Big_Integers_Ghost.Big_Integer
- with Ghost;
-
- package Signed_Conversion is new
- Ada.Numerics.Big_Numbers.Big_Integers_Ghost.Signed_Conversions
- (Int => Int64);
-
- function Big (Arg : Int64) return Big_Integer is
- (Signed_Conversion.To_Big_Integer (Arg))
- with Ghost;
-
- function In_Int64_Range (Arg : Big_Integer) return Boolean is
- (Ada.Numerics.Big_Numbers.Big_Integers_Ghost.In_Range
- (Arg, Big (Int64'First), Big (Int64'Last)))
- with Ghost;
-
- function Add_With_Ovflo_Check64 (X, Y : Int64) return Int64
- with
- Pre => In_Int64_Range (Big (X) + Big (Y)),
- Post => Add_With_Ovflo_Check64'Result = X + Y;
+ function Add_With_Ovflo_Check64 (X, Y : Int64) return Int64;
-- Raises Constraint_Error if sum of operands overflows 64 bits,
-- otherwise returns the 64-bit signed integer sum.
--
@@ -93,10 +58,7 @@ is
-- the exception *Constraint_Error* is raised; otherwise the result is
-- correct.
- function Subtract_With_Ovflo_Check64 (X, Y : Int64) return Int64
- with
- Pre => In_Int64_Range (Big (X) - Big (Y)),
- Post => Subtract_With_Ovflo_Check64'Result = X - Y;
+ function Subtract_With_Ovflo_Check64 (X, Y : Int64) return Int64;
-- Raises Constraint_Error if difference of operands overflows 64
-- bits, otherwise returns the 64-bit signed integer difference.
--
@@ -105,10 +67,7 @@ is
-- a sign of the result is compared with the sign of ``X`` to check for
-- overflow.
- function Multiply_With_Ovflo_Check64 (X, Y : Int64) return Int64
- with
- Pre => In_Int64_Range (Big (X) * Big (Y)),
- Post => Multiply_With_Ovflo_Check64'Result = X * Y;
+ function Multiply_With_Ovflo_Check64 (X, Y : Int64) return Int64;
pragma Export (C, Multiply_With_Ovflo_Check64, "__gnat_mulv64");
-- Raises Constraint_Error if product of operands overflows 64
-- bits, otherwise returns the 64-bit signed integer product.
@@ -119,40 +78,10 @@ is
-- signed value is returned. Overflow check is performed by looking at
-- higher digits.
- function Same_Sign (X, Y : Big_Integer) return Boolean is
- (X = Big (Int64'(0))
- or else Y = Big (Int64'(0))
- or else (X < Big (Int64'(0))) = (Y < Big (Int64'(0))))
- with Ghost;
-
- function Round_Quotient (X, Y, Q, R : Big_Integer) return Big_Integer with
- Ghost,
- Pre => Y /= 0 and then Q = X / Y and then R = X rem Y,
- Post => Round_Quotient'Result =
- (if abs R > (abs Y - Big (Int64'(1))) / Big (Int64'(2)) then
- (if Same_Sign (X, Y) then Q + Big (Int64'(1))
- else Q - Big (Int64'(1)))
- else
- Q);
-
procedure Scaled_Divide64
(X, Y, Z : Int64;
Q, R : out Int64;
- Round : Boolean)
- with
- Pre => Z /= 0
- and then In_Int64_Range
- (if Round then Round_Quotient (Big (X) * Big (Y), Big (Z),
- Big (X) * Big (Y) / Big (Z),
- Big (X) * Big (Y) rem Big (Z))
- else Big (X) * Big (Y) / Big (Z)),
- Post => Big (R) = Big (X) * Big (Y) rem Big (Z)
- and then
- (if Round then
- Big (Q) = Round_Quotient (Big (X) * Big (Y), Big (Z),
- Big (X) * Big (Y) / Big (Z), Big (R))
- else
- Big (Q) = Big (X) * Big (Y) / Big (Z));
+ Round : Boolean);
-- Performs the division of (``X`` * ``Y``) / ``Z``, storing the quotient
-- in ``Q`` and the remainder in ``R``.
--
@@ -189,22 +118,7 @@ is
procedure Double_Divide64
(X, Y, Z : Int64;
Q, R : out Int64;
- Round : Boolean)
- with
- Pre => Y /= 0
- and then Z /= 0
- and then In_Int64_Range
- (if Round then Round_Quotient (Big (X), Big (Y) * Big (Z),
- Big (X) / (Big (Y) * Big (Z)),
- Big (X) rem (Big (Y) * Big (Z)))
- else Big (X) / (Big (Y) * Big (Z))),
- Post => Big (R) = Big (X) rem (Big (Y) * Big (Z))
- and then
- (if Round then
- Big (Q) = Round_Quotient (Big (X), Big (Y) * Big (Z),
- Big (X) / (Big (Y) * Big (Z)), Big (R))
- else
- Big (Q) = Big (X) / (Big (Y) * Big (Z)));
+ Round : Boolean);
-- Performs the division ``X`` / (``Y`` * ``Z``), storing the quotient in
-- ``Q`` and the remainder in ``R``. Constraint_Error is raised if ``Y`` or
-- ``Z`` is zero, or if the quotient does not fit in 64-bits.
diff --git a/gcc/ada/libgnat/s-casuti.adb b/gcc/ada/libgnat/s-casuti.adb
index 58c358c..887cbbf 100644
--- a/gcc/ada/libgnat/s-casuti.adb
+++ b/gcc/ada/libgnat/s-casuti.adb
@@ -29,14 +29,6 @@
-- --
------------------------------------------------------------------------------
--- Ghost code, loop invariants and assertions in this unit are meant for
--- analysis only, not for run-time checking, as it would be too costly
--- otherwise. This is enforced by setting the assertion policy to Ignore.
-
-pragma Assertion_Policy (Ghost => Ignore,
- Loop_Invariant => Ignore,
- Assert => Ignore);
-
package body System.Case_Util
with SPARK_Mode
is
@@ -44,30 +36,6 @@ is
-- To_Lower --
--------------
- function To_Lower (A : Character) return Character is
- A_Val : constant Natural := Character'Pos (A);
-
- begin
- if A in 'A' .. 'Z'
- or else A_Val in 16#C0# .. 16#D6#
- or else A_Val in 16#D8# .. 16#DE#
- then
- return Character'Val (A_Val + 16#20#);
- else
- return A;
- end if;
- end To_Lower;
-
- procedure To_Lower (A : in out String) is
- begin
- for J in A'Range loop
- A (J) := To_Lower (A (J));
-
- pragma Loop_Invariant
- (for all K in A'First .. J => A (K) = To_Lower (A'Loop_Entry (K)));
- end loop;
- end To_Lower;
-
function To_Lower (A : String) return String is
Result : String := A;
begin
@@ -79,30 +47,6 @@ is
-- To_Mixed --
--------------
- procedure To_Mixed (A : in out String) is
- Ucase : Boolean := True;
-
- begin
- for J in A'Range loop
- if Ucase then
- A (J) := To_Upper (A (J));
- else
- A (J) := To_Lower (A (J));
- end if;
-
- pragma Loop_Invariant
- (for all K in A'First .. J =>
- (if K = A'First
- or else A'Loop_Entry (K - 1) = '_'
- then
- A (K) = To_Upper (A'Loop_Entry (K))
- else
- A (K) = To_Lower (A'Loop_Entry (K))));
-
- Ucase := A (J) = '_';
- end loop;
- end To_Mixed;
-
function To_Mixed (A : String) return String is
Result : String := A;
begin
@@ -114,30 +58,6 @@ is
-- To_Upper --
--------------
- function To_Upper (A : Character) return Character is
- A_Val : constant Natural := Character'Pos (A);
-
- begin
- if A in 'a' .. 'z'
- or else A_Val in 16#E0# .. 16#F6#
- or else A_Val in 16#F8# .. 16#FE#
- then
- return Character'Val (A_Val - 16#20#);
- else
- return A;
- end if;
- end To_Upper;
-
- procedure To_Upper (A : in out String) is
- begin
- for J in A'Range loop
- A (J) := To_Upper (A (J));
-
- pragma Loop_Invariant
- (for all K in A'First .. J => A (K) = To_Upper (A'Loop_Entry (K)));
- end loop;
- end To_Upper;
-
function To_Upper (A : String) return String is
Result : String := A;
begin
diff --git a/gcc/ada/libgnat/s-casuti.ads b/gcc/ada/libgnat/s-casuti.ads
index fbdec17..967abe0 100644
--- a/gcc/ada/libgnat/s-casuti.ads
+++ b/gcc/ada/libgnat/s-casuti.ads
@@ -40,34 +40,30 @@
-- contract cases should not be executed at runtime as well, in order not to
-- slow down the execution of these functions.
+-- The portion of this package that does not require use of the secondary
+-- stack (so all the subprograms except functions that return String)
+-- has been moved into a sibling package, Case_Util_NSS. See comments there.
+-- Clients who don't care about avoiding secondary stack usage can
+-- continue to use this package and are unaffected by this reorganization.
+
pragma Assertion_Policy (Pre => Ignore,
Post => Ignore,
Contract_Cases => Ignore,
Ghost => Ignore);
+with System.Case_Util_NSS;
+
package System.Case_Util
with Pure, SPARK_Mode
is
-- Note: all the following functions handle the full Latin-1 set
function To_Upper (A : Character) return Character
- with
- Post => (declare
- A_Val : constant Natural := Character'Pos (A);
- begin
- (if A in 'a' .. 'z'
- or else A_Val in 16#E0# .. 16#F6#
- or else A_Val in 16#F8# .. 16#FE#
- then
- To_Upper'Result = Character'Val (A_Val - 16#20#)
- else
- To_Upper'Result = A));
+ renames Case_Util_NSS.To_Upper;
-- Converts A to upper case if it is a lower case letter, otherwise
-- returns the input argument unchanged.
- procedure To_Upper (A : in out String)
- with
- Post => (for all J in A'Range => A (J) = To_Upper (A'Old (J)));
+ procedure To_Upper (A : in out String) renames Case_Util_NSS.To_Upper;
function To_Upper (A : String) return String
with
@@ -78,23 +74,12 @@ is
-- Folds all characters of string A to upper case
function To_Lower (A : Character) return Character
- with
- Post => (declare
- A_Val : constant Natural := Character'Pos (A);
- begin
- (if A in 'A' .. 'Z'
- or else A_Val in 16#C0# .. 16#D6#
- or else A_Val in 16#D8# .. 16#DE#
- then
- To_Lower'Result = Character'Val (A_Val + 16#20#)
- else
- To_Lower'Result = A));
+ renames Case_Util_NSS.To_Lower;
-- Converts A to lower case if it is an upper case letter, otherwise
-- returns the input argument unchanged.
procedure To_Lower (A : in out String)
- with
- Post => (for all J in A'Range => A (J) = To_Lower (A'Old (J)));
+ renames Case_Util_NSS.To_Lower;
function To_Lower (A : String) return String
with
@@ -105,15 +90,7 @@ is
-- Folds all characters of string A to lower case
procedure To_Mixed (A : in out String)
- with
- Post =>
- (for all J in A'Range =>
- (if J = A'First
- or else A'Old (J - 1) = '_'
- then
- A (J) = To_Upper (A'Old (J))
- else
- A (J) = To_Lower (A'Old (J))));
+ renames Case_Util_NSS.To_Mixed;
function To_Mixed (A : String) return String
with
diff --git a/gcc/ada/libgnat/s-valspe.adb b/gcc/ada/libgnat/s-cautns.adb
index b47e818..3e2d996 100644
--- a/gcc/ada/libgnat/s-valspe.adb
+++ b/gcc/ada/libgnat/s-cautns.adb
@@ -1,12 +1,12 @@
------------------------------------------------------------------------------
-- --
--- GNAT COMPILER COMPONENTS --
+-- GNAT RUN-TIME COMPONENTS --
-- --
--- S Y S T E M . V A L _ S P E C --
+-- S Y S T E M . C A S E _ U T I L _ N S S --
-- --
-- B o d y --
-- --
--- Copyright (C) 2023-2025, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2025, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -37,51 +37,91 @@ pragma Assertion_Policy (Ghost => Ignore,
Loop_Invariant => Ignore,
Assert => Ignore);
-package body System.Val_Spec
+package body System.Case_Util_NSS
with SPARK_Mode
is
+ --------------
+ -- To_Lower --
+ --------------
- ---------------------------
- -- First_Non_Space_Ghost --
- ---------------------------
+ function To_Lower (A : Character) return Character is
+ A_Val : constant Natural := Character'Pos (A);
- function First_Non_Space_Ghost
- (S : String;
- From, To : Integer) return Positive
- is
begin
- for J in From .. To loop
- if S (J) /= ' ' then
- return J;
- end if;
+ if A in 'A' .. 'Z'
+ or else A_Val in 16#C0# .. 16#D6#
+ or else A_Val in 16#D8# .. 16#DE#
+ then
+ return Character'Val (A_Val + 16#20#);
+ else
+ return A;
+ end if;
+ end To_Lower;
+
+ procedure To_Lower (A : in out String) is
+ begin
+ for J in A'Range loop
+ A (J) := To_Lower (A (J));
- pragma Loop_Invariant (for all K in From .. J => S (K) = ' ');
+ pragma Loop_Invariant
+ (for all K in A'First .. J => A (K) = To_Lower (A'Loop_Entry (K)));
end loop;
+ end To_Lower;
- raise Program_Error;
- end First_Non_Space_Ghost;
+ --------------
+ -- To_Mixed --
+ --------------
- -----------------------
- -- Last_Number_Ghost --
- -----------------------
+ procedure To_Mixed (A : in out String) is
+ Ucase : Boolean := True;
- function Last_Number_Ghost (Str : String) return Positive is
begin
- pragma Annotate (Gnatcheck, Exempt_On, "Improper_Returns",
- "occurs in ghost code, not executable");
-
- for J in Str'Range loop
- if Str (J) not in '0' .. '9' | '_' then
- return J - 1;
+ for J in A'Range loop
+ if Ucase then
+ A (J) := To_Upper (A (J));
+ else
+ A (J) := To_Lower (A (J));
end if;
pragma Loop_Invariant
- (for all K in Str'First .. J => Str (K) in '0' .. '9' | '_');
+ (for all K in A'First .. J =>
+ (if K = A'First
+ or else A'Loop_Entry (K - 1) = '_'
+ then
+ A (K) = To_Upper (A'Loop_Entry (K))
+ else
+ A (K) = To_Lower (A'Loop_Entry (K))));
+
+ Ucase := A (J) = '_';
end loop;
+ end To_Mixed;
+
+ --------------
+ -- To_Upper --
+ --------------
- return Str'Last;
+ function To_Upper (A : Character) return Character is
+ A_Val : constant Natural := Character'Pos (A);
- pragma Annotate (Gnatcheck, Exempt_Off, "Improper_Returns");
- end Last_Number_Ghost;
+ begin
+ if A in 'a' .. 'z'
+ or else A_Val in 16#E0# .. 16#F6#
+ or else A_Val in 16#F8# .. 16#FE#
+ then
+ return Character'Val (A_Val - 16#20#);
+ else
+ return A;
+ end if;
+ end To_Upper;
+
+ procedure To_Upper (A : in out String) is
+ begin
+ for J in A'Range loop
+ A (J) := To_Upper (A (J));
+
+ pragma Loop_Invariant
+ (for all K in A'First .. J => A (K) = To_Upper (A'Loop_Entry (K)));
+ end loop;
+ end To_Upper;
-end System.Val_Spec;
+end System.Case_Util_NSS;
diff --git a/gcc/ada/libgnat/s-cautns.ads b/gcc/ada/libgnat/s-cautns.ads
new file mode 100644
index 0000000..5c9c67b
--- /dev/null
+++ b/gcc/ada/libgnat/s-cautns.ads
@@ -0,0 +1,106 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . C A S E _ U T I L _ N S S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1995-2025, Free Software Foundation, Inc. --
+-- --
+-- GNAT is 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. --
+-- --
+------------------------------------------------------------------------------
+
+-- The No_Secondary_Stack portion of System.Case_Util. Some of the functions
+-- provided in System.Case_Util make use of the secondary stack, and some
+-- do not. Lumping them all together makes even the non-secondary-stack
+-- portion of the package unusable in cases where references to
+-- secondary-stack-related code must be avoided (for example, if linking with
+-- a reduced version of the runtimes where that code is missing). That's a
+-- problem in some cases, so Case_Util is split into two parts. The first
+-- part (named Case_Util_NSS) is a subset of the original version which
+-- does not use the secondary stack; the second part presents the same
+-- complete interface to users as before, but avoids code duplication by
+-- renaming entities out of the first part.
+--
+-- See comments in s-casuti.ads for further explanations (e.g., of
+-- the Assertion_Policy specified here).
+
+pragma Assertion_Policy (Pre => Ignore,
+ Post => Ignore,
+ Contract_Cases => Ignore,
+ Ghost => Ignore);
+
+package System.Case_Util_NSS
+ with Pure, SPARK_Mode
+is
+ -- Note: all the following functions handle the full Latin-1 set
+
+ function To_Upper (A : Character) return Character
+ with
+ Post => (declare
+ A_Val : constant Natural := Character'Pos (A);
+ begin
+ (if A in 'a' .. 'z'
+ or else A_Val in 16#E0# .. 16#F6#
+ or else A_Val in 16#F8# .. 16#FE#
+ then
+ To_Upper'Result = Character'Val (A_Val - 16#20#)
+ else
+ To_Upper'Result = A));
+ -- Converts A to upper case if it is a lower case letter, otherwise
+ -- returns the input argument unchanged.
+
+ procedure To_Upper (A : in out String)
+ with
+ Post => (for all J in A'Range => A (J) = To_Upper (A'Old (J)));
+
+ function To_Lower (A : Character) return Character
+ with
+ Post => (declare
+ A_Val : constant Natural := Character'Pos (A);
+ begin
+ (if A in 'A' .. 'Z'
+ or else A_Val in 16#C0# .. 16#D6#
+ or else A_Val in 16#D8# .. 16#DE#
+ then
+ To_Lower'Result = Character'Val (A_Val + 16#20#)
+ else
+ To_Lower'Result = A));
+ -- Converts A to lower case if it is an upper case letter, otherwise
+ -- returns the input argument unchanged.
+
+ procedure To_Lower (A : in out String)
+ with
+ Post => (for all J in A'Range => A (J) = To_Lower (A'Old (J)));
+
+ procedure To_Mixed (A : in out String)
+ with
+ Post =>
+ (for all J in A'Range =>
+ (if J = A'First
+ or else A'Old (J - 1) = '_'
+ then
+ A (J) = To_Upper (A'Old (J))
+ else
+ A (J) = To_Lower (A'Old (J))));
+
+end System.Case_Util_NSS;
diff --git a/gcc/ada/libgnat/s-dorepr.adb b/gcc/ada/libgnat/s-dorepr.adb
index ddc7c1d..1d9604a 100644
--- a/gcc/ada/libgnat/s-dorepr.adb
+++ b/gcc/ada/libgnat/s-dorepr.adb
@@ -134,7 +134,7 @@ package body Product is
Ahi, Alo, Bhi, Blo, E : Num;
begin
- if Is_Infinity (P) or else Is_Zero (P) then
+ if Is_Infinity_Or_NaN (P) or else Is_Zero (P) then
return (P, 0.0);
else
@@ -157,7 +157,7 @@ package body Product is
Hi, Lo, E : Num;
begin
- if Is_Infinity (Q) or else Is_Zero (Q) then
+ if Is_Infinity_Or_NaN (Q) or else Is_Zero (Q) then
return (Q, 0.0);
else
diff --git a/gcc/ada/libgnat/s-dorepr__fma.adb b/gcc/ada/libgnat/s-dorepr__fma.adb
index 0d3dc53..45a9223 100644
--- a/gcc/ada/libgnat/s-dorepr__fma.adb
+++ b/gcc/ada/libgnat/s-dorepr__fma.adb
@@ -78,7 +78,7 @@ package body Product is
E : Num;
begin
- if Is_Infinity (P) or else Is_Zero (P) then
+ if Is_Infinity_Or_NaN (P) or else Is_Zero (P) then
return (P, 0.0);
else
diff --git a/gcc/ada/libgnat/s-dourea.adb b/gcc/ada/libgnat/s-dourea.adb
index a37f2eb..68d4d9a 100644
--- a/gcc/ada/libgnat/s-dourea.adb
+++ b/gcc/ada/libgnat/s-dourea.adb
@@ -34,12 +34,12 @@ package body System.Double_Real is
function Is_NaN (N : Num) return Boolean is (N /= N);
-- Return True if N is a NaN
- function Is_Infinity (N : Num) return Boolean is (Is_NaN (N - N));
- -- Return True if N is an infinity. Used to avoid propagating meaningless
- -- errors when the result of a product is an infinity.
+ function Is_Infinity_Or_NaN (N : Num) return Boolean is (Is_NaN (N - N));
+ -- Return True if N is either an infinity or NaN. Used to avoid propagating
+ -- meaningless errors when the result of a product is an infinity or NaN.
function Is_Zero (N : Num) return Boolean is (N = -N);
- -- Return True if N is a Zero. Used to preserve the sign when the result of
+ -- Return True if N is a zero. Used to preserve the sign when the result of
-- a product is a zero.
package Product is
@@ -151,7 +151,7 @@ package body System.Double_Real is
P : constant Double_T := Two_Prod (A.Hi, B);
begin
- if Is_Infinity (P.Hi) or else Is_Zero (P.Hi) then
+ if Is_Infinity_Or_NaN (P.Hi) or else Is_Zero (P.Hi) then
return (P.Hi, 0.0);
else
return Quick_Two_Sum (P.Hi, P.Lo + A.Lo * B);
@@ -162,7 +162,7 @@ package body System.Double_Real is
P : constant Double_T := Two_Prod (A.Hi, B.Hi);
begin
- if Is_Infinity (P.Hi) or else Is_Zero (P.Hi) then
+ if Is_Infinity_Or_NaN (P.Hi) or else Is_Zero (P.Hi) then
return (P.Hi, 0.0);
else
return Quick_Two_Sum (P.Hi, P.Lo + A.Hi * B.Lo + A.Lo * B.Hi);
@@ -178,7 +178,7 @@ package body System.Double_Real is
P, R : Double_T;
begin
- if Is_Infinity (B) or else Is_Zero (B) then
+ if Is_Infinity_Or_NaN (B) or else Is_Zero (B) then
return (A.Hi / B, 0.0);
end if;
pragma Annotate (CodePeer, Intentional, "test always false",
@@ -202,7 +202,7 @@ package body System.Double_Real is
R, S : Double_T;
begin
- if Is_Infinity (B.Hi) or else Is_Zero (B.Hi) then
+ if Is_Infinity_Or_NaN (B.Hi) or else Is_Zero (B.Hi) then
return (A.Hi / B.Hi, 0.0);
end if;
pragma Annotate (CodePeer, Intentional, "test always false",
@@ -228,7 +228,7 @@ package body System.Double_Real is
Q : constant Double_T := Two_Sqr (A.Hi);
begin
- if Is_Infinity (Q.Hi) or else Is_Zero (Q.Hi) then
+ if Is_Infinity_Or_NaN (Q.Hi) or else Is_Zero (Q.Hi) then
return (Q.Hi, 0.0);
else
return Quick_Two_Sum (Q.Hi, Q.Lo + 2.0 * A.Hi * A.Lo + A.Lo * A.Lo);
diff --git a/gcc/ada/libgnat/s-exnint.ads b/gcc/ada/libgnat/s-exnint.ads
index 3a11f2c..fa46217 100644
--- a/gcc/ada/libgnat/s-exnint.ads
+++ b/gcc/ada/libgnat/s-exnint.ads
@@ -31,17 +31,6 @@
-- This package implements Integer exponentiation (checks off)
--- Preconditions, postconditions, ghost code, loop invariants and assertions
--- in this unit are meant for analysis only, not for run-time checking, as it
--- would be too costly otherwise. This is enforced by setting the assertion
--- policy to Ignore.
-
-pragma Assertion_Policy (Pre => Ignore,
- Post => Ignore,
- Ghost => Ignore,
- Loop_Invariant => Ignore,
- Assert => Ignore);
-
with System.Exponn;
package System.Exn_Int
diff --git a/gcc/ada/libgnat/s-exnlli.ads b/gcc/ada/libgnat/s-exnlli.ads
index ba67b76..63c4b88 100644
--- a/gcc/ada/libgnat/s-exnlli.ads
+++ b/gcc/ada/libgnat/s-exnlli.ads
@@ -31,17 +31,6 @@
-- This package implements Long_Long_Integer exponentiation (checks off)
--- Preconditions, postconditions, ghost code, loop invariants and assertions
--- in this unit are meant for analysis only, not for run-time checking, as it
--- would be too costly otherwise. This is enforced by setting the assertion
--- policy to Ignore.
-
-pragma Assertion_Policy (Pre => Ignore,
- Post => Ignore,
- Ghost => Ignore,
- Loop_Invariant => Ignore,
- Assert => Ignore);
-
with System.Exponn;
package System.Exn_LLI
diff --git a/gcc/ada/libgnat/s-exnllli.ads b/gcc/ada/libgnat/s-exnllli.ads
index 5ff963c..e94efe0 100644
--- a/gcc/ada/libgnat/s-exnllli.ads
+++ b/gcc/ada/libgnat/s-exnllli.ads
@@ -31,23 +31,11 @@
-- Long_Long_Long_Integer exponentiation (checks off)
--- Preconditions, postconditions, ghost code, loop invariants and assertions
--- in this unit are meant for analysis only, not for run-time checking, as it
--- would be too costly otherwise. This is enforced by setting the assertion
--- policy to Ignore.
-
-pragma Assertion_Policy (Pre => Ignore,
- Post => Ignore,
- Ghost => Ignore,
- Loop_Invariant => Ignore,
- Assert => Ignore);
-
with System.Exponn;
package System.Exn_LLLI
with SPARK_Mode
is
-
package Exponn_Integer is new Exponn (Long_Long_Long_Integer);
function Exn_Long_Long_Long_Integer
diff --git a/gcc/ada/libgnat/s-expint.ads b/gcc/ada/libgnat/s-expint.ads
index a69c8d6..d349330 100644
--- a/gcc/ada/libgnat/s-expint.ads
+++ b/gcc/ada/libgnat/s-expint.ads
@@ -31,23 +31,11 @@
-- This package implements Integer exponentiation (checks on)
--- Preconditions, postconditions, ghost code, loop invariants and assertions
--- in this unit are meant for analysis only, not for run-time checking, as it
--- would be too costly otherwise. This is enforced by setting the assertion
--- policy to Ignore.
-
-pragma Assertion_Policy (Pre => Ignore,
- Post => Ignore,
- Ghost => Ignore,
- Loop_Invariant => Ignore,
- Assert => Ignore);
-
with System.Expont;
package System.Exp_Int
with SPARK_Mode
is
-
package Expont_Integer is new Expont (Integer);
function Exp_Integer (Left : Integer; Right : Natural) return Integer
diff --git a/gcc/ada/libgnat/s-explli.ads b/gcc/ada/libgnat/s-explli.ads
index 9ea38de..af3da9c 100644
--- a/gcc/ada/libgnat/s-explli.ads
+++ b/gcc/ada/libgnat/s-explli.ads
@@ -31,23 +31,11 @@
-- This package implements Long_Long_Integer exponentiation
--- Preconditions, postconditions, ghost code, loop invariants and assertions
--- in this unit are meant for analysis only, not for run-time checking, as it
--- would be too costly otherwise. This is enforced by setting the assertion
--- policy to Ignore.
-
-pragma Assertion_Policy (Pre => Ignore,
- Post => Ignore,
- Ghost => Ignore,
- Loop_Invariant => Ignore,
- Assert => Ignore);
-
with System.Expont;
package System.Exp_LLI
with SPARK_Mode
is
-
package Expont_Integer is new Expont (Long_Long_Integer);
function Exp_Long_Long_Integer
diff --git a/gcc/ada/libgnat/s-expllli.ads b/gcc/ada/libgnat/s-expllli.ads
index 273c33c..ed100b9 100644
--- a/gcc/ada/libgnat/s-expllli.ads
+++ b/gcc/ada/libgnat/s-expllli.ads
@@ -31,23 +31,11 @@
-- Long_Long_Long_Integer exponentiation (checks on)
--- Preconditions, postconditions, ghost code, loop invariants and assertions
--- in this unit are meant for analysis only, not for run-time checking, as it
--- would be too costly otherwise. This is enforced by setting the assertion
--- policy to Ignore.
-
-pragma Assertion_Policy (Pre => Ignore,
- Post => Ignore,
- Ghost => Ignore,
- Loop_Invariant => Ignore,
- Assert => Ignore);
-
with System.Expont;
package System.Exp_LLLI
with SPARK_Mode
is
-
package Expont_Integer is new Expont (Long_Long_Long_Integer);
function Exp_Long_Long_Long_Integer
diff --git a/gcc/ada/libgnat/s-explllu.ads b/gcc/ada/libgnat/s-explllu.ads
index a0b5d47..88aa9af 100644
--- a/gcc/ada/libgnat/s-explllu.ads
+++ b/gcc/ada/libgnat/s-explllu.ads
@@ -34,24 +34,12 @@
-- The result is always full width, the caller must do a masking operation if
-- the modulus is less than 2 ** Long_Long_Long_Unsigned'Size.
--- 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. Postconditions
--- and contract cases should not be executed at runtime as well, in order
--- not to slow down the execution of these functions.
-
-pragma Assertion_Policy (Pre => Ignore,
- Post => Ignore,
- Contract_Cases => Ignore,
- Ghost => Ignore);
-
with System.Exponu;
with System.Unsigned_Types;
package System.Exp_LLLU
with SPARK_Mode
is
-
subtype Long_Long_Long_Unsigned is Unsigned_Types.Long_Long_Long_Unsigned;
function Exp_Long_Long_Long_Unsigned is
diff --git a/gcc/ada/libgnat/s-expllu.ads b/gcc/ada/libgnat/s-expllu.ads
index 98fc851..3e2b2a7 100644
--- a/gcc/ada/libgnat/s-expllu.ads
+++ b/gcc/ada/libgnat/s-expllu.ads
@@ -34,24 +34,12 @@
-- is always full width, the caller must do a masking operation if the
-- modulus is less than 2 ** (Long_Long_Unsigned'Size).
--- Note: 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.
--- Postconditions and contract cases should not be executed at run-time as
--- well, in order not to slow down the execution of these functions.
-
-pragma Assertion_Policy (Pre => Ignore,
- Post => Ignore,
- Contract_Cases => Ignore,
- Ghost => Ignore);
-
with System.Exponu;
with System.Unsigned_Types;
package System.Exp_LLU
with SPARK_Mode
is
-
subtype Long_Long_Unsigned is Unsigned_Types.Long_Long_Unsigned;
function Exp_Long_Long_Unsigned is new Exponu (Long_Long_Unsigned);
diff --git a/gcc/ada/libgnat/s-expmod.adb b/gcc/ada/libgnat/s-expmod.adb
index 28c07a1..16d6b5f 100644
--- a/gcc/ada/libgnat/s-expmod.adb
+++ b/gcc/ada/libgnat/s-expmod.adb
@@ -29,203 +29,11 @@
-- --
------------------------------------------------------------------------------
--- Preconditions, postconditions, ghost code, loop invariants and assertions
--- in this unit are meant for analysis only, not for run-time checking, as it
--- would be too costly otherwise. This is enforced by setting the assertion
--- policy to Ignore.
-
-pragma Assertion_Policy (Pre => Ignore,
- Post => Ignore,
- Ghost => Ignore,
- Loop_Invariant => Ignore,
- Assert => Ignore);
-
-with Ada.Numerics.Big_Numbers.Big_Integers_Ghost;
-use Ada.Numerics.Big_Numbers.Big_Integers_Ghost;
-
package body System.Exp_Mod
with SPARK_Mode
is
use System.Unsigned_Types;
- -- Local lemmas
-
- procedure Lemma_Add_Mod (X, Y : Big_Natural; B : Big_Positive)
- with
- Ghost,
- Post => (X + Y) mod B = ((X mod B) + (Y mod B)) mod B;
-
- procedure Lemma_Exp_Expand (A : Big_Integer; Exp : Natural)
- with
- Ghost,
- Post =>
- (if Exp rem 2 = 0 then
- A ** Exp = A ** (Exp / 2) * A ** (Exp / 2)
- else
- A ** Exp = A ** (Exp / 2) * A ** (Exp / 2) * A);
-
- procedure Lemma_Exp_Mod (A : Big_Natural; Exp : Natural; B : Big_Positive)
- with
- Ghost,
- Subprogram_Variant => (Decreases => Exp),
- Post => ((A mod B) ** Exp) mod B = (A ** Exp) mod B;
-
- procedure Lemma_Mod_Ident (A : Big_Natural; B : Big_Positive)
- with
- Ghost,
- Pre => A < B,
- Post => A mod B = A;
-
- procedure Lemma_Mod_Mod (A : Big_Integer; B : Big_Positive)
- with
- Ghost,
- Post => A mod B mod B = A mod B;
-
- procedure Lemma_Mult_Div (X : Big_Natural; Y : Big_Positive)
- with
- Ghost,
- Post => X * Y / Y = X;
-
- procedure Lemma_Mult_Mod (X, Y : Big_Natural; B : Big_Positive)
- with
- Ghost,
- -- The following subprogram variant can be added as soon as supported
- -- Subprogram_Variant => (Decreases => Y),
- Post => (X * Y) mod B = ((X mod B) * (Y mod B)) mod B;
-
- -----------------------------
- -- Local lemma null bodies --
- -----------------------------
-
- procedure Lemma_Mod_Ident (A : Big_Natural; B : Big_Positive) is null;
- procedure Lemma_Mod_Mod (A : Big_Integer; B : Big_Positive) is null;
- procedure Lemma_Mult_Div (X : Big_Natural; Y : Big_Positive) is null;
-
- -------------------
- -- Lemma_Add_Mod --
- -------------------
-
- procedure Lemma_Add_Mod (X, Y : Big_Natural; B : Big_Positive) is
-
- procedure Lemma_Euclidean_Mod (Q, F, R : Big_Natural) with
- Pre => F /= 0,
- Post => (Q * F + R) mod F = R mod F,
- Subprogram_Variant => (Decreases => Q);
-
- -------------------------
- -- Lemma_Euclidean_Mod --
- -------------------------
-
- procedure Lemma_Euclidean_Mod (Q, F, R : Big_Natural) is
- begin
- if Q > 0 then
- Lemma_Euclidean_Mod (Q - 1, F, R);
- end if;
- end Lemma_Euclidean_Mod;
-
- -- Local variables
-
- Left : constant Big_Natural := (X + Y) mod B;
- Right : constant Big_Natural := ((X mod B) + (Y mod B)) mod B;
- XQuot : constant Big_Natural := X / B;
- YQuot : constant Big_Natural := Y / B;
- AQuot : constant Big_Natural := (X mod B + Y mod B) / B;
- begin
- if Y /= 0 and B > 1 then
- pragma Assert (X = XQuot * B + X mod B);
- pragma Assert (Y = YQuot * B + Y mod B);
- pragma Assert
- (Left = ((XQuot + YQuot) * B + X mod B + Y mod B) mod B);
- pragma Assert (X mod B + Y mod B = AQuot * B + Right);
- pragma Assert (Left = ((XQuot + YQuot + AQuot) * B + Right) mod B);
- Lemma_Euclidean_Mod (XQuot + YQuot + AQuot, B, Right);
- pragma Assert (Left = (Right mod B));
- pragma Assert (Left = Right);
- end if;
- end Lemma_Add_Mod;
-
- ----------------------
- -- Lemma_Exp_Expand --
- ----------------------
-
- procedure Lemma_Exp_Expand (A : Big_Integer; Exp : Natural) is
-
- procedure Lemma_Exp_Distribution (Exp_1, Exp_2 : Natural) with
- Pre => Natural'Last - Exp_2 >= Exp_1,
- Post => A ** (Exp_1 + Exp_2) = A ** (Exp_1) * A ** (Exp_2);
-
- ----------------------------
- -- Lemma_Exp_Distribution --
- ----------------------------
-
- procedure Lemma_Exp_Distribution (Exp_1, Exp_2 : Natural) is null;
-
- begin
- if Exp rem 2 = 0 then
- pragma Assert (Exp = Exp / 2 + Exp / 2);
- else
- pragma Assert (Exp = Exp / 2 + Exp / 2 + 1);
- Lemma_Exp_Distribution (Exp / 2, Exp / 2 + 1);
- Lemma_Exp_Distribution (Exp / 2, 1);
- end if;
- end Lemma_Exp_Expand;
-
- -------------------
- -- Lemma_Exp_Mod --
- -------------------
-
- procedure Lemma_Exp_Mod (A : Big_Natural; Exp : Natural; B : Big_Positive)
- is
- begin
- if Exp /= 0 then
- declare
- Left : constant Big_Integer := ((A mod B) ** Exp) mod B;
- Right : constant Big_Integer := (A ** Exp) mod B;
- begin
- Lemma_Mult_Mod (A mod B, (A mod B) ** (Exp - 1), B);
- Lemma_Mod_Mod (A, B);
- Lemma_Exp_Mod (A, Exp - 1, B);
- Lemma_Mult_Mod (A, A ** (Exp - 1), B);
- pragma Assert
- ((A mod B) * (A mod B) ** (Exp - 1) = (A mod B) ** Exp);
- pragma Assert (A * A ** (Exp - 1) = A ** Exp);
- pragma Assert (Left = Right);
- end;
- end if;
- end Lemma_Exp_Mod;
-
- --------------------
- -- Lemma_Mult_Mod --
- --------------------
-
- procedure Lemma_Mult_Mod (X, Y : Big_Natural; B : Big_Positive) is
- Left : constant Big_Natural := (X * Y) mod B;
- Right : constant Big_Natural := ((X mod B) * (Y mod B)) mod B;
- begin
- if Y /= 0 and B > 1 then
- Lemma_Add_Mod (X * (Y - 1), X, B);
- Lemma_Mult_Mod (X, Y - 1, B);
- Lemma_Mod_Mod (X, B);
- Lemma_Add_Mod ((X mod B) * ((Y - 1) mod B), X mod B, B);
- Lemma_Add_Mod (Y - 1, 1, B);
- pragma Assert (((Y - 1) mod B + 1) mod B = Y mod B);
- if (Y - 1) mod B + 1 < B then
- Lemma_Mod_Ident ((Y - 1) mod B + 1, B);
- Lemma_Mod_Mod ((X mod B) * (Y mod B), B);
- pragma Assert (Left = Right);
- else
- pragma Assert (Y mod B = 0);
- pragma Assert (Y / B * B = Y);
- pragma Assert ((X * Y) mod B = (X * Y) - (X * Y) / B * B);
- pragma Assert
- ((X * Y) mod B = (X * Y) - (X * (Y / B) * B) / B * B);
- Lemma_Mult_Div (X * (Y / B), B);
- pragma Assert (Left = 0);
- pragma Assert (Left = Right);
- end if;
- end if;
- end Lemma_Mult_Mod;
-
-----------------
-- Exp_Modular --
-----------------
@@ -241,35 +49,7 @@ is
function Mult (X, Y : Unsigned) return Unsigned is
(Unsigned (Long_Long_Unsigned (X) * Long_Long_Unsigned (Y)
- mod Long_Long_Unsigned (Modulus)))
- with
- Pre => Modulus /= 0;
- -- Modular multiplication. Note that we can't take advantage of the
- -- compiler's circuit, because the modulus is not known statically.
-
- -- Local ghost variables, functions and lemmas
-
- M : constant Big_Positive := Big (Modulus) with Ghost;
-
- function Equal_Modulo (X, Y : Big_Integer) return Boolean is
- (X mod M = Y mod M)
- with
- Ghost,
- Pre => Modulus /= 0;
-
- procedure Lemma_Mult (X, Y : Unsigned)
- with
- Ghost,
- Post => Big (Mult (X, Y)) = (Big (X) * Big (Y)) mod M
- and then Big (Mult (X, Y)) < M;
-
- procedure Lemma_Mult (X, Y : Unsigned) is
- begin
- pragma Assert (Big (Mult (X, Y)) = (Big (X) * Big (Y)) mod M);
- end Lemma_Mult;
-
- Rest : Big_Integer with Ghost;
- -- Ghost variable to hold Factor**Exp between Exp and Factor updates
+ mod Long_Long_Unsigned (Modulus)));
begin
pragma Assert (Modulus /= 1);
@@ -284,72 +64,18 @@ is
if Exp /= 0 then
loop
- pragma Loop_Invariant (Exp > 0);
- pragma Loop_Invariant (Result < Modulus);
- pragma Loop_Invariant (Equal_Modulo
- (Big (Result) * Big (Factor) ** Exp, Big (Left) ** Right));
- pragma Loop_Variant (Decreases => Exp);
-
if Exp rem 2 /= 0 then
- pragma Assert
- (Big (Factor) ** Exp
- = Big (Factor) * Big (Factor) ** (Exp - 1));
- pragma Assert (Equal_Modulo
- ((Big (Result) * Big (Factor)) * Big (Factor) ** (Exp - 1),
- Big (Left) ** Right));
- pragma Assert (Big (Factor) >= 0);
- Lemma_Mult_Mod (Big (Result) * Big (Factor),
- Big (Factor) ** (Exp - 1),
- Big (Modulus));
- Lemma_Mult (Result, Factor);
-
Result := Mult (Result, Factor);
-
- Lemma_Mod_Ident (Big (Result), Big (Modulus));
- Lemma_Mod_Mod (Big (Factor) ** (Exp - 1), Big (Modulus));
- Lemma_Mult_Mod (Big (Result),
- Big (Factor) ** (Exp - 1),
- Big (Modulus));
- pragma Assert (Equal_Modulo
- (Big (Result) * Big (Factor) ** (Exp - 1),
- Big (Left) ** Right));
- Lemma_Exp_Expand (Big (Factor), Exp - 1);
- pragma Assert (Exp / 2 = (Exp - 1) / 2);
end if;
- Lemma_Exp_Expand (Big (Factor), Exp);
-
Exp := Exp / 2;
exit when Exp = 0;
- Rest := Big (Factor) ** Exp;
- pragma Assert (Equal_Modulo
- (Big (Result) * (Rest * Rest), Big (Left) ** Right));
- Lemma_Exp_Mod (Big (Factor) * Big (Factor), Exp, Big (Modulus));
- pragma Assert
- ((Big (Factor) * Big (Factor)) ** Exp = Rest * Rest);
- pragma Assert (Equal_Modulo
- ((Big (Factor) * Big (Factor)) ** Exp,
- Rest * Rest));
- Lemma_Mult (Factor, Factor);
-
Factor := Mult (Factor, Factor);
-
- Lemma_Mod_Mod (Rest * Rest, Big (Modulus));
- Lemma_Mod_Ident (Big (Result), Big (Modulus));
- Lemma_Mult_Mod (Big (Result), Rest * Rest, Big (Modulus));
- pragma Assert (Big (Factor) >= 0);
- Lemma_Mult_Mod (Big (Result), Big (Factor) ** Exp,
- Big (Modulus));
- pragma Assert (Equal_Modulo
- (Big (Result) * Big (Factor) ** Exp, Big (Left) ** Right));
end loop;
-
- pragma Assert (Big (Result) = Big (Left) ** Right mod Big (Modulus));
end if;
return Result;
-
end Exp_Modular;
end System.Exp_Mod;
diff --git a/gcc/ada/libgnat/s-expmod.ads b/gcc/ada/libgnat/s-expmod.ads
index 47ba39e..509ffa4 100644
--- a/gcc/ada/libgnat/s-expmod.ads
+++ b/gcc/ada/libgnat/s-expmod.ads
@@ -36,19 +36,6 @@
-- Note that 1 is a binary modulus (2**0), so the compiler should not (and
-- will not) call this function with Modulus equal to 1.
--- 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. Postconditions and
--- contract cases should not be executed at runtime as well, in order not to
--- slow down the execution of these functions.
-
-pragma Assertion_Policy (Pre => Ignore,
- Post => Ignore,
- Contract_Cases => Ignore,
- Ghost => Ignore);
-
-with Ada.Numerics.Big_Numbers.Big_Integers_Ghost;
-
with System.Unsigned_Types;
package System.Exp_Mod
@@ -57,30 +44,10 @@ is
use type System.Unsigned_Types.Unsigned;
subtype Unsigned is System.Unsigned_Types.Unsigned;
- use type Ada.Numerics.Big_Numbers.Big_Integers_Ghost.Big_Integer;
- subtype Big_Integer is
- Ada.Numerics.Big_Numbers.Big_Integers_Ghost.Big_Integer
- with Ghost;
-
- package Unsigned_Conversion is
- new Ada.Numerics.Big_Numbers.Big_Integers_Ghost.Unsigned_Conversions
- (Int => Unsigned);
-
- function Big (Arg : Unsigned) return Big_Integer is
- (Unsigned_Conversion.To_Big_Integer (Arg))
- with Ghost;
-
- subtype Power_Of_2 is Unsigned with
- Dynamic_Predicate =>
- Power_Of_2 /= 0 and then (Power_Of_2 and (Power_Of_2 - 1)) = 0;
-
function Exp_Modular
(Left : Unsigned;
Modulus : Unsigned;
- Right : Natural) return Unsigned
- with
- Pre => Modulus /= 0 and then Modulus not in Power_Of_2,
- Post => Big (Exp_Modular'Result) = Big (Left) ** Right mod Big (Modulus);
+ Right : Natural) return Unsigned;
-- Return the power of ``Left`` by ``Right` modulo ``Modulus``.
--
-- This function is implemented using the standard logarithmic approach:
diff --git a/gcc/ada/libgnat/s-exponn.adb b/gcc/ada/libgnat/s-exponn.adb
index ff79f5a..2aeb199 100644
--- a/gcc/ada/libgnat/s-exponn.adb
+++ b/gcc/ada/libgnat/s-exponn.adb
@@ -32,65 +32,6 @@
package body System.Exponn
with SPARK_Mode
is
-
- -- Preconditions, postconditions, ghost code, loop invariants and
- -- assertions in this unit are meant for analysis only, not for run-time
- -- checking, as it would be too costly otherwise. This is enforced by
- -- setting the assertion policy to Ignore.
-
- pragma Assertion_Policy (Pre => Ignore,
- Post => Ignore,
- Ghost => Ignore,
- Loop_Invariant => Ignore,
- Assert => Ignore);
-
- -- Local lemmas
-
- procedure Lemma_Exp_Expand (A : Big_Integer; Exp : Natural)
- with
- Ghost,
- Pre => A /= 0,
- Post =>
- (if Exp rem 2 = 0 then
- A ** Exp = A ** (Exp / 2) * A ** (Exp / 2)
- else
- A ** Exp = A ** (Exp / 2) * A ** (Exp / 2) * A);
-
- procedure Lemma_Exp_In_Range (A : Big_Integer; Exp : Positive)
- with
- Ghost,
- Pre => In_Int_Range (A ** Exp * A ** Exp),
- Post => In_Int_Range (A * A);
-
- procedure Lemma_Exp_Not_Zero (A : Big_Integer; Exp : Natural)
- with
- Ghost,
- Pre => A /= 0,
- Post => A ** Exp /= 0;
-
- procedure Lemma_Exp_Positive (A : Big_Integer; Exp : Natural)
- with
- Ghost,
- Pre => A /= 0
- and then Exp rem 2 = 0,
- Post => A ** Exp > 0;
-
- procedure Lemma_Mult_In_Range (X, Y, Z : Big_Integer)
- with
- Ghost,
- Pre => Y /= 0
- and then not (X = -Big (Int'First) and Y = -1)
- and then X * Y = Z
- and then In_Int_Range (Z),
- Post => In_Int_Range (X);
-
- -----------------------------
- -- Local lemma null bodies --
- -----------------------------
-
- procedure Lemma_Exp_Not_Zero (A : Big_Integer; Exp : Natural) is null;
- procedure Lemma_Mult_In_Range (X, Y, Z : Big_Integer) is null;
-
-----------
-- Expon --
-----------
@@ -104,13 +45,7 @@ is
Factor : Int := Left;
Exp : Natural := Right;
- Rest : Big_Integer with Ghost;
- -- Ghost variable to hold Factor**Exp between Exp and Factor updates
-
begin
- pragma Annotate (Gnatcheck, Exempt_On, "Improper_Returns",
- "early returns for performance");
-
-- We use the standard logarithmic approach, Exp gets shifted right
-- testing successive low order bits and Factor is the value of the
-- base raised to the next power of 2.
@@ -122,117 +57,31 @@ is
-- simpler, so we do it.
if Right = 0 then
- return 1;
+ Result := 1;
elsif Left = 0 then
- return 0;
- end if;
-
- loop
- pragma Loop_Invariant (Exp > 0);
- pragma Loop_Invariant (Factor /= 0);
- pragma Loop_Invariant
- (Big (Result) * Big (Factor) ** Exp = Big (Left) ** Right);
- pragma Loop_Variant (Decreases => Exp);
+ Result := 0;
+ else
+ loop
+ if Exp rem 2 /= 0 then
+ declare
+ pragma Suppress (Overflow_Check);
+ begin
+ Result := Result * Factor;
+ end;
+ end if;
+
+ Exp := Exp / 2;
+ exit when Exp = 0;
- if Exp rem 2 /= 0 then
declare
pragma Suppress (Overflow_Check);
begin
- pragma Assert
- (Big (Factor) ** Exp
- = Big (Factor) * Big (Factor) ** (Exp - 1));
- Lemma_Exp_Positive (Big (Factor), Exp - 1);
- Lemma_Mult_In_Range (Big (Result) * Big (Factor),
- Big (Factor) ** (Exp - 1),
- Big (Left) ** Right);
-
- Result := Result * Factor;
+ Factor := Factor * Factor;
end;
- end if;
-
- Lemma_Exp_Expand (Big (Factor), Exp);
-
- Exp := Exp / 2;
- exit when Exp = 0;
-
- Rest := Big (Factor) ** Exp;
- pragma Assert
- (Big (Result) * (Rest * Rest) = Big (Left) ** Right);
-
- declare
- pragma Suppress (Overflow_Check);
- begin
- Lemma_Mult_In_Range (Rest * Rest,
- Big (Result),
- Big (Left) ** Right);
- Lemma_Exp_In_Range (Big (Factor), Exp);
-
- Factor := Factor * Factor;
- end;
-
- pragma Assert (Big (Factor) ** Exp = Rest * Rest);
- end loop;
-
- pragma Assert (Big (Result) = Big (Left) ** Right);
+ end loop;
+ end if;
return Result;
-
- pragma Annotate (Gnatcheck, Exempt_Off, "Improper_Returns");
end Expon;
- ----------------------
- -- Lemma_Exp_Expand --
- ----------------------
-
- procedure Lemma_Exp_Expand (A : Big_Integer; Exp : Natural) is
-
- procedure Lemma_Exp_Distribution (Exp_1, Exp_2 : Natural) with
- Pre => A /= 0 and then Natural'Last - Exp_2 >= Exp_1,
- Post => A ** (Exp_1 + Exp_2) = A ** (Exp_1) * A ** (Exp_2);
-
- ----------------------------
- -- Lemma_Exp_Distribution --
- ----------------------------
-
- procedure Lemma_Exp_Distribution (Exp_1, Exp_2 : Natural) is null;
-
- begin
- if Exp rem 2 = 0 then
- pragma Assert (Exp = Exp / 2 + Exp / 2);
- else
- pragma Assert (Exp = Exp / 2 + Exp / 2 + 1);
- Lemma_Exp_Distribution (Exp / 2, Exp / 2 + 1);
- Lemma_Exp_Distribution (Exp / 2, 1);
- end if;
- end Lemma_Exp_Expand;
-
- ------------------------
- -- Lemma_Exp_In_Range --
- ------------------------
-
- procedure Lemma_Exp_In_Range (A : Big_Integer; Exp : Positive) is
- begin
- if A /= 0 and Exp /= 1 then
- pragma Assert (A ** Exp = A * A ** (Exp - 1));
- Lemma_Mult_In_Range
- (A * A, A ** (Exp - 1) * A ** (Exp - 1), A ** Exp * A ** Exp);
- end if;
- end Lemma_Exp_In_Range;
-
- ------------------------
- -- Lemma_Exp_Positive --
- ------------------------
-
- procedure Lemma_Exp_Positive (A : Big_Integer; Exp : Natural) is
- begin
- if Exp = 0 then
- pragma Assert (A ** Exp = 1);
- else
- pragma Assert (Exp = 2 * (Exp / 2));
- pragma Assert (A ** Exp = A ** (Exp / 2) * A ** (Exp / 2));
- pragma Assert (A ** Exp = (A ** (Exp / 2)) ** 2);
- Lemma_Exp_Not_Zero (A, Exp / 2);
- end if;
- end Lemma_Exp_Positive;
-
end System.Exponn;
diff --git a/gcc/ada/libgnat/s-exponn.ads b/gcc/ada/libgnat/s-exponn.ads
index 16bd393..94da5d2 100644
--- a/gcc/ada/libgnat/s-exponn.ads
+++ b/gcc/ada/libgnat/s-exponn.ads
@@ -32,44 +32,13 @@
-- This package provides functions for signed integer exponentiation. This
-- is the version of the package with checks disabled.
-with Ada.Numerics.Big_Numbers.Big_Integers_Ghost;
-
generic
-
type Int is range <>;
package System.Exponn
with Pure, SPARK_Mode
is
- -- 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. Postconditions
- -- and contract cases should not be executed at runtime as well, in order
- -- not to slow down the execution of these functions.
-
- pragma Assertion_Policy (Pre => Ignore,
- Post => Ignore,
- Contract_Cases => Ignore,
- Ghost => Ignore);
-
- package BI_Ghost renames Ada.Numerics.Big_Numbers.Big_Integers_Ghost;
- subtype Big_Integer is BI_Ghost.Big_Integer with Ghost;
- use type BI_Ghost.Big_Integer;
-
- package Signed_Conversion is new BI_Ghost.Signed_Conversions (Int => Int);
-
- function Big (Arg : Int) return Big_Integer is
- (Signed_Conversion.To_Big_Integer (Arg))
- with Ghost;
-
- function In_Int_Range (Arg : Big_Integer) return Boolean is
- (BI_Ghost.In_Range (Arg, Big (Int'First), Big (Int'Last)))
- with Ghost;
-
- function Expon (Left : Int; Right : Natural) return Int
- with
- Pre => In_Int_Range (Big (Left) ** Right),
- Post => Expon'Result = Left ** Right;
+ function Expon (Left : Int; Right : Natural) return Int;
-- Calculate ``Left`` ** ``Right``. If ``Left`` is 0 then 0 is returned
-- and if ``Right`` is 0 then 1 is returned. In all other cases the result
-- is set to 1 and then computed in a loop as follows:
diff --git a/gcc/ada/libgnat/s-expont.adb b/gcc/ada/libgnat/s-expont.adb
index 39476a9..368dd0b 100644
--- a/gcc/ada/libgnat/s-expont.adb
+++ b/gcc/ada/libgnat/s-expont.adb
@@ -32,65 +32,6 @@
package body System.Expont
with SPARK_Mode
is
-
- -- Preconditions, postconditions, ghost code, loop invariants and
- -- assertions in this unit are meant for analysis only, not for run-time
- -- checking, as it would be too costly otherwise. This is enforced by
- -- setting the assertion policy to Ignore.
-
- pragma Assertion_Policy (Pre => Ignore,
- Post => Ignore,
- Ghost => Ignore,
- Loop_Invariant => Ignore,
- Assert => Ignore);
-
- -- Local lemmas
-
- procedure Lemma_Exp_Expand (A : Big_Integer; Exp : Natural)
- with
- Ghost,
- Pre => A /= 0,
- Post =>
- (if Exp rem 2 = 0 then
- A ** Exp = A ** (Exp / 2) * A ** (Exp / 2)
- else
- A ** Exp = A ** (Exp / 2) * A ** (Exp / 2) * A);
-
- procedure Lemma_Exp_In_Range (A : Big_Integer; Exp : Positive)
- with
- Ghost,
- Pre => In_Int_Range (A ** Exp * A ** Exp),
- Post => In_Int_Range (A * A);
-
- procedure Lemma_Exp_Not_Zero (A : Big_Integer; Exp : Natural)
- with
- Ghost,
- Pre => A /= 0,
- Post => A ** Exp /= 0;
-
- procedure Lemma_Exp_Positive (A : Big_Integer; Exp : Natural)
- with
- Ghost,
- Pre => A /= 0
- and then Exp rem 2 = 0,
- Post => A ** Exp > 0;
-
- procedure Lemma_Mult_In_Range (X, Y, Z : Big_Integer)
- with
- Ghost,
- Pre => Y /= 0
- and then not (X = -Big (Int'First) and Y = -1)
- and then X * Y = Z
- and then In_Int_Range (Z),
- Post => In_Int_Range (X);
-
- -----------------------------
- -- Local lemma null bodies --
- -----------------------------
-
- procedure Lemma_Exp_Not_Zero (A : Big_Integer; Exp : Natural) is null;
- procedure Lemma_Mult_In_Range (X, Y, Z : Big_Integer) is null;
-
-----------
-- Expon --
-----------
@@ -104,13 +45,7 @@ is
Factor : Int := Left;
Exp : Natural := Right;
- Rest : Big_Integer with Ghost;
- -- Ghost variable to hold Factor**Exp between Exp and Factor updates
-
begin
- pragma Annotate (Gnatcheck, Exempt_On, "Improper_Returns",
- "early returns for performance");
-
-- We use the standard logarithmic approach, Exp gets shifted right
-- testing successive low order bits and Factor is the value of the
-- base raised to the next power of 2.
@@ -122,117 +57,31 @@ is
-- simpler, so we do it.
if Right = 0 then
- return 1;
+ Result := 1;
elsif Left = 0 then
- return 0;
- end if;
-
- loop
- pragma Loop_Invariant (Exp > 0);
- pragma Loop_Invariant (Factor /= 0);
- pragma Loop_Invariant
- (Big (Result) * Big (Factor) ** Exp = Big (Left) ** Right);
- pragma Loop_Variant (Decreases => Exp);
+ Result := 0;
+ else
+ loop
+ if Exp rem 2 /= 0 then
+ declare
+ pragma Unsuppress (Overflow_Check);
+ begin
+ Result := Result * Factor;
+ end;
+ end if;
+
+ Exp := Exp / 2;
+ exit when Exp = 0;
- if Exp rem 2 /= 0 then
declare
pragma Unsuppress (Overflow_Check);
begin
- pragma Assert
- (Big (Factor) ** Exp
- = Big (Factor) * Big (Factor) ** (Exp - 1));
- Lemma_Exp_Positive (Big (Factor), Exp - 1);
- Lemma_Mult_In_Range (Big (Result) * Big (Factor),
- Big (Factor) ** (Exp - 1),
- Big (Left) ** Right);
-
- Result := Result * Factor;
+ Factor := Factor * Factor;
end;
- end if;
-
- Lemma_Exp_Expand (Big (Factor), Exp);
-
- Exp := Exp / 2;
- exit when Exp = 0;
-
- Rest := Big (Factor) ** Exp;
- pragma Assert
- (Big (Result) * (Rest * Rest) = Big (Left) ** Right);
-
- declare
- pragma Unsuppress (Overflow_Check);
- begin
- Lemma_Mult_In_Range (Rest * Rest,
- Big (Result),
- Big (Left) ** Right);
- Lemma_Exp_In_Range (Big (Factor), Exp);
-
- Factor := Factor * Factor;
- end;
-
- pragma Assert (Big (Factor) ** Exp = Rest * Rest);
- end loop;
-
- pragma Assert (Big (Result) = Big (Left) ** Right);
+ end loop;
+ end if;
return Result;
-
- pragma Annotate (Gnatcheck, Exempt_Off, "Improper_Returns");
end Expon;
- ----------------------
- -- Lemma_Exp_Expand --
- ----------------------
-
- procedure Lemma_Exp_Expand (A : Big_Integer; Exp : Natural) is
-
- procedure Lemma_Exp_Distribution (Exp_1, Exp_2 : Natural) with
- Pre => A /= 0 and then Natural'Last - Exp_2 >= Exp_1,
- Post => A ** (Exp_1 + Exp_2) = A ** (Exp_1) * A ** (Exp_2);
-
- ----------------------------
- -- Lemma_Exp_Distribution --
- ----------------------------
-
- procedure Lemma_Exp_Distribution (Exp_1, Exp_2 : Natural) is null;
-
- begin
- if Exp rem 2 = 0 then
- pragma Assert (Exp = Exp / 2 + Exp / 2);
- else
- pragma Assert (Exp = Exp / 2 + Exp / 2 + 1);
- Lemma_Exp_Distribution (Exp / 2, Exp / 2 + 1);
- Lemma_Exp_Distribution (Exp / 2, 1);
- end if;
- end Lemma_Exp_Expand;
-
- ------------------------
- -- Lemma_Exp_In_Range --
- ------------------------
-
- procedure Lemma_Exp_In_Range (A : Big_Integer; Exp : Positive) is
- begin
- if A /= 0 and Exp /= 1 then
- pragma Assert (A ** Exp = A * A ** (Exp - 1));
- Lemma_Mult_In_Range
- (A * A, A ** (Exp - 1) * A ** (Exp - 1), A ** Exp * A ** Exp);
- end if;
- end Lemma_Exp_In_Range;
-
- ------------------------
- -- Lemma_Exp_Positive --
- ------------------------
-
- procedure Lemma_Exp_Positive (A : Big_Integer; Exp : Natural) is
- begin
- if Exp = 0 then
- pragma Assert (A ** Exp = 1);
- else
- pragma Assert (Exp = 2 * (Exp / 2));
- pragma Assert (A ** Exp = A ** (Exp / 2) * A ** (Exp / 2));
- pragma Assert (A ** Exp = (A ** (Exp / 2)) ** 2);
- Lemma_Exp_Not_Zero (A, Exp / 2);
- end if;
- end Lemma_Exp_Positive;
-
end System.Expont;
diff --git a/gcc/ada/libgnat/s-expont.ads b/gcc/ada/libgnat/s-expont.ads
index 880e054..2cf6dc0 100644
--- a/gcc/ada/libgnat/s-expont.ads
+++ b/gcc/ada/libgnat/s-expont.ads
@@ -32,44 +32,13 @@
-- This package provides functions for signed integer exponentiation. This
-- is the version of the package with checks enabled.
-with Ada.Numerics.Big_Numbers.Big_Integers_Ghost;
-
generic
-
type Int is range <>;
package System.Expont
with Pure, SPARK_Mode
is
- -- 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. Postconditions
- -- and contract cases should not be executed at runtime as well, in order
- -- not to slow down the execution of these functions.
-
- pragma Assertion_Policy (Pre => Ignore,
- Post => Ignore,
- Contract_Cases => Ignore,
- Ghost => Ignore);
-
- package BI_Ghost renames Ada.Numerics.Big_Numbers.Big_Integers_Ghost;
- subtype Big_Integer is BI_Ghost.Big_Integer with Ghost;
- use type BI_Ghost.Big_Integer;
-
- package Signed_Conversion is new BI_Ghost.Signed_Conversions (Int => Int);
-
- function Big (Arg : Int) return Big_Integer is
- (Signed_Conversion.To_Big_Integer (Arg))
- with Ghost;
-
- function In_Int_Range (Arg : Big_Integer) return Boolean is
- (BI_Ghost.In_Range (Arg, Big (Int'First), Big (Int'Last)))
- with Ghost;
-
- function Expon (Left : Int; Right : Natural) return Int
- with
- Pre => In_Int_Range (Big (Left) ** Right),
- Post => Expon'Result = Left ** Right;
+ function Expon (Left : Int; Right : Natural) return Int;
-- Calculate ``Left`` ** ``Right``. If ``Left`` is 0 then 0 is returned
-- and if ``Right`` is 0 then 1 is returned. In all other cases the result
-- is set to 1 and then computed in a loop as follows:
diff --git a/gcc/ada/libgnat/s-exponu.adb b/gcc/ada/libgnat/s-exponu.adb
index abb1930..0c52833 100644
--- a/gcc/ada/libgnat/s-exponu.adb
+++ b/gcc/ada/libgnat/s-exponu.adb
@@ -29,20 +29,7 @@
-- --
------------------------------------------------------------------------------
-function System.Exponu (Left : Int; Right : Natural) return Int
- with SPARK_Mode
-is
- -- Preconditions, postconditions, ghost code, loop invariants and
- -- assertions in this unit are meant for analysis only, not for run-time
- -- checking, as it would be too costly otherwise. This is enforced by
- -- setting the assertion policy to Ignore.
-
- pragma Assertion_Policy (Pre => Ignore,
- Post => Ignore,
- Ghost => Ignore,
- Loop_Invariant => Ignore,
- Assert => Ignore);
-
+function System.Exponu (Left : Int; Right : Natural) return Int is
-- Note that negative exponents get a constraint error because the
-- subtype of the Right argument (the exponent) is Natural.
@@ -61,16 +48,7 @@ begin
if Exp /= 0 then
loop
- pragma Loop_Invariant (Exp > 0);
- pragma Loop_Invariant (Result * Factor ** Exp = Left ** Right);
- pragma Loop_Variant (Decreases => Exp);
-
if Exp rem 2 /= 0 then
- pragma Assert
- (Result * (Factor * Factor ** (Exp - 1)) = Left ** Right);
- pragma Assert
- ((Result * Factor) * Factor ** (Exp - 1) = Left ** Right);
-
Result := Result * Factor;
end if;
diff --git a/gcc/ada/libgnat/s-exponu.ads b/gcc/ada/libgnat/s-exponu.ads
index cfa6d78..7cc2f9c 100644
--- a/gcc/ada/libgnat/s-exponu.ads
+++ b/gcc/ada/libgnat/s-exponu.ads
@@ -31,25 +31,10 @@
-- This function implements unsigned integer exponentiation
--- 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. Postconditions
--- and contract cases should not be executed at runtime as well, in order
--- not to slow down the execution of these functions.
-
-pragma Assertion_Policy (Pre => Ignore,
- Post => Ignore,
- Contract_Cases => Ignore,
- Ghost => Ignore);
-
generic
-
type Int is mod <>;
-function System.Exponu (Left : Int; Right : Natural) return Int
-with
- SPARK_Mode,
- Post => System.Exponu'Result = Left ** Right;
+function System.Exponu (Left : Int; Right : Natural) return Int;
-- Calculate ``Left`` ** ``Right``. If ``Left`` is 0 then 0 is returned
-- and if ``Right`` is 0 then 1 is returned. In all other cases the result
-- is set to 1 and then computed in a loop as follows:
diff --git a/gcc/ada/libgnat/s-expuns.ads b/gcc/ada/libgnat/s-expuns.ads
index 98ad607..d1dcc25 100644
--- a/gcc/ada/libgnat/s-expuns.ads
+++ b/gcc/ada/libgnat/s-expuns.ads
@@ -35,24 +35,12 @@
-- The result is always full width, the caller must do a masking operation
-- the modulus is less than 2 ** (Unsigned'Size).
--- 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. Postconditions
--- and contract cases should not be executed at runtime as well, in order
--- not to slow down the execution of these functions.
-
-pragma Assertion_Policy (Pre => Ignore,
- Post => Ignore,
- Contract_Cases => Ignore,
- Ghost => Ignore);
-
with System.Exponu;
with System.Unsigned_Types;
package System.Exp_Uns
with SPARK_Mode
is
-
subtype Unsigned is Unsigned_Types.Unsigned;
function Exp_Unsigned is new Exponu (Unsigned);
diff --git a/gcc/ada/libgnat/s-imaged.adb b/gcc/ada/libgnat/s-imaged.adb
index 34c15b0..638e37b 100644
--- a/gcc/ada/libgnat/s-imaged.adb
+++ b/gcc/ada/libgnat/s-imaged.adb
@@ -31,33 +31,10 @@
with System.Image_I;
with System.Img_Util; use System.Img_Util;
-with System.Value_I_Spec;
-with System.Value_U_Spec;
package body System.Image_D is
- -- Contracts, ghost code, loop invariants and assertions in this unit are
- -- meant for analysis only, not for run-time checking, as it would be too
- -- costly otherwise. This is enforced by setting the assertion policy to
- -- Ignore.
-
- pragma Assertion_Policy (Assert => Ignore,
- Assert_And_Cut => Ignore,
- Contract_Cases => Ignore,
- Ghost => Ignore,
- Loop_Invariant => Ignore,
- Pre => Ignore,
- Post => Ignore,
- Subprogram_Variant => Ignore);
-
- package Uns_Spec is new System.Value_U_Spec (Uns);
- package Int_Spec is new System.Value_I_Spec (Int, Uns, Uns_Spec);
-
- package Image_I is new System.Image_I
- (Int => Int,
- Uns => Uns,
- U_Spec => Uns_Spec,
- I_Spec => Int_Spec);
+ package Image_I is new System.Image_I (Int);
procedure Set_Image_Integer
(V : Int;
@@ -76,7 +53,6 @@ package body System.Image_D is
Scale : Integer)
is
pragma Assert (S'First = 1);
-
begin
-- Add space at start for non-negative numbers
diff --git a/gcc/ada/libgnat/s-imaged.ads b/gcc/ada/libgnat/s-imaged.ads
index 1b83a67..48d4b00 100644
--- a/gcc/ada/libgnat/s-imaged.ads
+++ b/gcc/ada/libgnat/s-imaged.ads
@@ -34,10 +34,7 @@
-- types.
generic
-
type Int is range <>;
- type Uns is mod <>;
-
package System.Image_D is
procedure Image_Decimal
diff --git a/gcc/ada/libgnat/s-imagef.adb b/gcc/ada/libgnat/s-imagef.adb
index 00b4ac5..c84f424 100644
--- a/gcc/ada/libgnat/s-imagef.adb
+++ b/gcc/ada/libgnat/s-imagef.adb
@@ -31,25 +31,9 @@
with System.Image_I;
with System.Img_Util; use System.Img_Util;
-with System.Value_I_Spec;
-with System.Value_U_Spec;
package body System.Image_F is
- -- Contracts, ghost code, loop invariants and assertions in this unit are
- -- meant for analysis only, not for run-time checking, as it would be too
- -- costly otherwise. This is enforced by setting the assertion policy to
- -- Ignore.
-
- pragma Assertion_Policy (Assert => Ignore,
- Assert_And_Cut => Ignore,
- Contract_Cases => Ignore,
- Ghost => Ignore,
- Loop_Invariant => Ignore,
- Pre => Ignore,
- Post => Ignore,
- Subprogram_Variant => Ignore);
-
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
@@ -70,14 +54,7 @@ package body System.Image_F is
-- if the small is larger than 1, and smaller than 2**(Int'Size - 1) / 10
-- if the small is smaller than 1.
- package Uns_Spec is new System.Value_U_Spec (Uns);
- package Int_Spec is new System.Value_I_Spec (Int, Uns, Uns_Spec);
-
- package Image_I is new System.Image_I
- (Int => Int,
- Uns => Uns,
- U_Spec => Uns_Spec,
- I_Spec => Int_Spec);
+ package Image_I is new System.Image_I (Int);
procedure Set_Image_Integer
(V : Int;
@@ -233,7 +210,6 @@ package body System.Image_F is
Aft0 : Natural)
is
pragma Assert (S'First = 1);
-
begin
-- Add space at start for non-negative numbers
diff --git a/gcc/ada/libgnat/s-imagef.ads b/gcc/ada/libgnat/s-imagef.ads
index fea63c6..f73eed8 100644
--- a/gcc/ada/libgnat/s-imagef.ads
+++ b/gcc/ada/libgnat/s-imagef.ads
@@ -34,9 +34,7 @@
-- point types whose Small is the ratio of two Int values.
generic
-
type Int is range <>;
- type Uns is mod <>;
with procedure Scaled_Divide
(X, Y, Z : Int;
diff --git a/gcc/ada/libgnat/s-imagei.adb b/gcc/ada/libgnat/s-imagei.adb
index e6aaf83..0f2211b 100644
--- a/gcc/ada/libgnat/s-imagei.adb
+++ b/gcc/ada/libgnat/s-imagei.adb
@@ -29,106 +29,18 @@
-- --
------------------------------------------------------------------------------
-with Ada.Numerics.Big_Numbers.Big_Integers_Ghost;
-use Ada.Numerics.Big_Numbers.Big_Integers_Ghost;
-
-with System.Val_Spec;
-
package body System.Image_I is
- -- Ghost code, loop invariants and assertions in this unit are meant for
- -- analysis only, not for run-time checking, as it would be too costly
- -- otherwise. This is enforced by setting the assertion policy to Ignore.
-
- pragma Assertion_Policy (Ghost => Ignore,
- Loop_Invariant => Ignore,
- Assert => Ignore,
- Assert_And_Cut => Ignore,
- Pre => Ignore,
- Post => Ignore,
- Subprogram_Variant => Ignore);
-
subtype Non_Positive is Int range Int'First .. 0;
- function Uns_Of_Non_Positive (T : Non_Positive) return Uns is
- (if T = Int'First then Uns (Int'Last) + 1 else Uns (-T));
-
procedure Set_Digits
(T : Non_Positive;
S : in out String;
- P : in out Natural)
- with
- Pre => P < Integer'Last
- and then S'Last < Integer'Last
- and then S'First <= P + 1
- and then S'First <= S'Last
- and then P <= S'Last - Unsigned_Width_Ghost + 1,
- Post => S (S'First .. P'Old) = S'Old (S'First .. P'Old)
- and then P in P'Old + 1 .. S'Last
- and then UP.Only_Decimal_Ghost (S, From => P'Old + 1, To => P)
- and then UP.Scan_Based_Number_Ghost (S, From => P'Old + 1, To => P)
- = UP.Wrap_Option (Uns_Of_Non_Positive (T));
+ P : in out Natural);
-- Set digits of absolute value of T, which is zero or negative. We work
-- with the negative of the value so that the largest negative number is
-- not a special case.
- package Unsigned_Conversion is new Unsigned_Conversions (Int => Uns);
-
- function Big (Arg : Uns) return Big_Integer renames
- Unsigned_Conversion.To_Big_Integer;
-
- function From_Big (Arg : Big_Integer) return Uns renames
- Unsigned_Conversion.From_Big_Integer;
-
- Big_10 : constant Big_Integer := Big (10) with Ghost;
-
- ------------------
- -- Local Lemmas --
- ------------------
-
- procedure Lemma_Non_Zero (X : Uns)
- with
- Ghost,
- Pre => X /= 0,
- Post => Big (X) /= 0;
-
- procedure Lemma_Div_Commutation (X, Y : Uns)
- with
- Ghost,
- Pre => Y /= 0,
- Post => Big (X) / Big (Y) = Big (X / Y);
-
- procedure Lemma_Div_Twice (X : Big_Natural; Y, Z : Big_Positive)
- with
- Ghost,
- Post => X / Y / Z = X / (Y * Z);
-
- ---------------------------
- -- Lemma_Div_Commutation --
- ---------------------------
-
- procedure Lemma_Non_Zero (X : Uns) is null;
- procedure Lemma_Div_Commutation (X, Y : Uns) is null;
-
- ---------------------
- -- Lemma_Div_Twice --
- ---------------------
-
- procedure Lemma_Div_Twice (X : Big_Natural; Y, Z : Big_Positive) is
- XY : constant Big_Natural := X / Y;
- YZ : constant Big_Natural := Y * Z;
- XYZ : constant Big_Natural := X / Y / Z;
- R : constant Big_Natural := (XY rem Z) * Y + (X rem Y);
- begin
- pragma Assert (X = XY * Y + (X rem Y));
- pragma Assert (XY = XY / Z * Z + (XY rem Z));
- pragma Assert (X = XYZ * YZ + R);
- pragma Assert ((XY rem Z) * Y <= (Z - 1) * Y);
- pragma Assert (R <= YZ - 1);
- pragma Assert (X / YZ = (XYZ * YZ + R) / YZ);
- pragma Assert (X / YZ = XYZ + R / YZ);
- end Lemma_Div_Twice;
-
-------------------
-- Image_Integer --
-------------------
@@ -139,44 +51,6 @@ package body System.Image_I is
P : out Natural)
is
pragma Assert (S'First = 1);
-
- procedure Prove_Value_Integer
- with
- Ghost,
- Pre => S'First = 1
- and then S'Last < Integer'Last
- and then P in 2 .. S'Last
- and then S (1) in ' ' | '-'
- and then (S (1) = '-') = (V < 0)
- and then UP.Only_Decimal_Ghost (S, From => 2, To => P)
- and then UP.Scan_Based_Number_Ghost (S, From => 2, To => P)
- = UP.Wrap_Option (IP.Abs_Uns_Of_Int (V)),
- Post => not System.Val_Spec.Only_Space_Ghost (S, 1, P)
- and then IP.Is_Integer_Ghost (S (1 .. P))
- and then IP.Is_Value_Integer_Ghost (S (1 .. P), V);
- -- Ghost lemma to prove the value of Value_Integer from the value of
- -- Scan_Based_Number_Ghost and the sign on a decimal string.
-
- -------------------------
- -- Prove_Value_Integer --
- -------------------------
-
- procedure Prove_Value_Integer is
- Str : constant String := S (1 .. P);
- begin
- pragma Assert (Str'First = 1);
- pragma Assert (Str (2) /= ' ');
- pragma Assert
- (UP.Only_Decimal_Ghost (Str, From => 2, To => P));
- UP.Prove_Scan_Based_Number_Ghost_Eq (S, Str, From => 2, To => P);
- pragma Assert
- (UP.Scan_Based_Number_Ghost (Str, From => 2, To => P)
- = UP.Wrap_Option (IP.Abs_Uns_Of_Int (V)));
- IP.Prove_Scan_Only_Decimal_Ghost (Str, V);
- end Prove_Value_Integer;
-
- -- Start of processing for Image_Integer
-
begin
if V >= 0 then
pragma Annotate (CodePeer, False_Positive, "test always false",
@@ -190,18 +64,7 @@ package body System.Image_I is
pragma Assert (P < S'Last - 1);
end if;
- declare
- P_Prev : constant Integer := P with Ghost;
- Offset : constant Positive := (if V >= 0 then 1 else 2) with Ghost;
- begin
- Set_Image_Integer (V, S, P);
-
- pragma Assert (P_Prev + Offset = 2);
- end;
- pragma Assert (if V >= 0 then S (1) = ' ');
- pragma Assert (S (1) in ' ' | '-');
-
- Prove_Value_Integer;
+ Set_Image_Integer (V, S, P);
end Image_Integer;
----------------
@@ -215,136 +78,6 @@ package body System.Image_I is
is
Nb_Digits : Natural := 0;
Value : Non_Positive := T;
-
- -- Local ghost variables
-
- Pow : Big_Positive := 1 with Ghost;
- S_Init : constant String := S with Ghost;
- Uns_T : constant Uns := Uns_Of_Non_Positive (T) with Ghost;
- Uns_Value : Uns := Uns_Of_Non_Positive (Value) with Ghost;
- Prev_Value : Uns with Ghost;
- Prev_S : String := S with Ghost;
-
- -- Local ghost lemmas
-
- procedure Prove_Character_Val (RU : Uns; RI : Non_Positive)
- with
- Ghost,
- Post => RU rem 10 in 0 .. 9
- and then -(RI rem 10) in 0 .. 9
- and then Character'Val (48 + RU rem 10) in '0' .. '9'
- and then Character'Val (48 - RI rem 10) in '0' .. '9';
- -- Ghost lemma to prove the value of a character corresponding to the
- -- next figure.
-
- procedure Prove_Euclidian (Val, Quot, Rest : Uns)
- with
- Ghost,
- Pre => Quot = Val / 10
- and then Rest = Val rem 10,
- Post => Uns'Last - Rest >= 10 * Quot and then Val = 10 * Quot + Rest;
- -- Ghost lemma to prove the relation between the quotient/remainder of
- -- division by 10 and the initial value.
-
- procedure Prove_Hexa_To_Unsigned_Ghost (RU : Uns; RI : Int)
- with
- Ghost,
- Pre => RU in 0 .. 9
- and then RI in 0 .. 9,
- Post => UP.Hexa_To_Unsigned_Ghost
- (Character'Val (48 + RU)) = RU
- and then UP.Hexa_To_Unsigned_Ghost
- (Character'Val (48 + RI)) = Uns (RI);
- -- Ghost lemma to prove that Hexa_To_Unsigned_Ghost returns the source
- -- figure when applied to the corresponding character.
-
- procedure Prove_Scan_Iter
- (S, Prev_S : String;
- V, Prev_V, Res : Uns;
- P, Max : Natural)
- with
- Ghost,
- Pre =>
- S'First = Prev_S'First and then S'Last = Prev_S'Last
- and then S'Last < Natural'Last and then
- Max in S'Range and then P in S'First .. Max and then
- (for all I in P + 1 .. Max => Prev_S (I) in '0' .. '9')
- and then (for all I in P + 1 .. Max => Prev_S (I) = S (I))
- and then S (P) in '0' .. '9'
- and then V <= Uns'Last / 10
- and then Uns'Last - UP.Hexa_To_Unsigned_Ghost (S (P))
- >= 10 * V
- and then Prev_V =
- V * 10 + UP.Hexa_To_Unsigned_Ghost (S (P))
- and then
- (if P = Max then Prev_V = Res
- else UP.Scan_Based_Number_Ghost
- (Str => Prev_S,
- From => P + 1,
- To => Max,
- Base => 10,
- Acc => Prev_V) = UP.Wrap_Option (Res)),
- Post =>
- (for all I in P .. Max => S (I) in '0' .. '9')
- and then UP.Scan_Based_Number_Ghost
- (Str => S,
- From => P,
- To => Max,
- Base => 10,
- Acc => V) = UP.Wrap_Option (Res);
- -- Ghost lemma to prove that Scan_Based_Number_Ghost is preserved
- -- through an iteration of the loop.
-
- procedure Prove_Uns_Of_Non_Positive_Value
- with
- Ghost,
- Pre => Uns_Value = Uns_Of_Non_Positive (Value),
- Post => Uns_Value / 10 = Uns_Of_Non_Positive (Value / 10)
- and then Uns_Value rem 10 = Uns_Of_Non_Positive (Value rem 10);
- -- Ghost lemma to prove that the relation between Value and its unsigned
- -- version is preserved.
-
- -----------------------------
- -- Local lemma null bodies --
- -----------------------------
-
- procedure Prove_Character_Val (RU : Uns; RI : Non_Positive) is null;
- procedure Prove_Euclidian (Val, Quot, Rest : Uns) is null;
- procedure Prove_Hexa_To_Unsigned_Ghost (RU : Uns; RI : Int) is null;
- procedure Prove_Uns_Of_Non_Positive_Value is null;
-
- ---------------------
- -- Prove_Scan_Iter --
- ---------------------
-
- procedure Prove_Scan_Iter
- (S, Prev_S : String;
- V, Prev_V, Res : Uns;
- P, Max : Natural)
- is
- pragma Unreferenced (Res);
- begin
- UP.Lemma_Scan_Based_Number_Ghost_Step
- (Str => S,
- From => P,
- To => Max,
- Base => 10,
- Acc => V);
- if P < Max then
- UP.Prove_Scan_Based_Number_Ghost_Eq
- (Prev_S, S, P + 1, Max, 10, Prev_V);
- else
- UP.Lemma_Scan_Based_Number_Ghost_Base
- (Str => S,
- From => P + 1,
- To => Max,
- Base => 10,
- Acc => Prev_V);
- end if;
- end Prove_Scan_Iter;
-
- -- Start of processing for Set_Digits
-
begin
pragma Assert (P >= S'First - 1 and P < S'Last);
-- No check is done since, as documented in the Set_Image_Integer
@@ -354,90 +87,20 @@ package body System.Image_I is
-- First we compute the number of characters needed for representing
-- the number.
loop
- Lemma_Div_Commutation (Uns_Of_Non_Positive (Value), 10);
- Lemma_Div_Twice (Big (Uns_Of_Non_Positive (T)),
- Big_10 ** Nb_Digits, Big_10);
- Prove_Uns_Of_Non_Positive_Value;
-
Value := Value / 10;
Nb_Digits := Nb_Digits + 1;
- Uns_Value := Uns_Value / 10;
- Pow := Pow * 10;
-
- pragma Loop_Invariant (Uns_Value = Uns_Of_Non_Positive (Value));
- pragma Loop_Invariant (Nb_Digits in 1 .. Unsigned_Width_Ghost - 1);
- pragma Loop_Invariant (Pow = Big_10 ** Nb_Digits);
- pragma Loop_Invariant (Big (Uns_Value) = Big (Uns_T) / Pow);
- pragma Loop_Variant (Increases => Value);
-
exit when Value = 0;
-
- Lemma_Non_Zero (Uns_Value);
- pragma Assert (Pow <= Big (Uns'Last));
end loop;
Value := T;
- Uns_Value := Uns_Of_Non_Positive (T);
- Pow := 1;
-
- pragma Assert (Uns_Value = From_Big (Big (Uns_T) / Big_10 ** 0));
-- We now populate digits from the end of the string to the beginning
for J in reverse 1 .. Nb_Digits loop
- Lemma_Div_Commutation (Uns_Value, 10);
- Lemma_Div_Twice (Big (Uns_T), Big_10 ** (Nb_Digits - J), Big_10);
- Prove_Character_Val (Uns_Value, Value);
- Prove_Hexa_To_Unsigned_Ghost (Uns_Value rem 10, -(Value rem 10));
- Prove_Uns_Of_Non_Positive_Value;
-
- Prev_Value := Uns_Value;
- Prev_S := S;
- Pow := Pow * 10;
- Uns_Value := Uns_Value / 10;
-
S (P + J) := Character'Val (48 - (Value rem 10));
Value := Value / 10;
-
- Prove_Euclidian
- (Val => Prev_Value,
- Quot => Uns_Value,
- Rest => UP.Hexa_To_Unsigned_Ghost (S (P + J)));
-
- Prove_Scan_Iter
- (S, Prev_S, Uns_Value, Prev_Value, Uns_T, P + J, P + Nb_Digits);
-
- pragma Loop_Invariant (Uns_Value = Uns_Of_Non_Positive (Value));
- pragma Loop_Invariant (Uns_Value <= Uns'Last / 10);
- pragma Loop_Invariant
- (for all K in S'First .. P => S (K) = S_Init (K));
- pragma Loop_Invariant
- (UP.Only_Decimal_Ghost (S, P + J, P + Nb_Digits));
- pragma Loop_Invariant
- (for all K in P + J .. P + Nb_Digits => S (K) in '0' .. '9');
- pragma Loop_Invariant (Pow = Big_10 ** (Nb_Digits - J + 1));
- pragma Loop_Invariant (Big (Uns_Value) = Big (Uns_T) / Pow);
- pragma Loop_Invariant
- (UP.Scan_Based_Number_Ghost
- (Str => S,
- From => P + J,
- To => P + Nb_Digits,
- Base => 10,
- Acc => Uns_Value)
- = UP.Wrap_Option (Uns_T));
end loop;
- pragma Assert (Big (Uns_Value) = Big (Uns_T) / Big_10 ** (Nb_Digits));
- pragma Assert (Uns_Value = 0);
- pragma Assert
- (UP.Scan_Based_Number_Ghost
- (Str => S,
- From => P + 1,
- To => P + Nb_Digits,
- Base => 10,
- Acc => Uns_Value)
- = UP.Wrap_Option (Uns_T));
-
P := P + Nb_Digits;
end Set_Digits;
@@ -448,12 +111,10 @@ package body System.Image_I is
procedure Set_Image_Integer
(V : Int;
S : in out String;
- P : in out Natural)
- is
+ P : in out Natural) is
begin
if V >= 0 then
Set_Digits (-V, S, P);
-
else
pragma Assert (P >= S'First - 1 and P < S'Last);
-- No check is done since, as documented in the specification,
diff --git a/gcc/ada/libgnat/s-imagei.ads b/gcc/ada/libgnat/s-imagei.ads
index e500f74..8d3b939 100644
--- a/gcc/ada/libgnat/s-imagei.ads
+++ b/gcc/ada/libgnat/s-imagei.ads
@@ -33,48 +33,14 @@
-- and ``Ada.Text_IO.Integer_IO`` conversions routines for signed integer
-- types.
--- 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. Postconditions and
--- contract cases should not be executed at runtime as well, in order not to
--- slow down the execution of these functions.
-
-pragma Assertion_Policy (Pre => Ignore,
- Post => Ignore,
- Contract_Cases => Ignore,
- Ghost => Ignore,
- Subprogram_Variant => Ignore);
-
-with System.Value_I_Spec;
-with System.Value_U_Spec;
-
generic
type Int is range <>;
- type Uns is mod <>;
-
- -- Additional parameters for ghost subprograms used inside contracts
-
- with package U_Spec is new System.Value_U_Spec (Uns => Uns) with Ghost;
- with package I_Spec is new System.Value_I_Spec
- (Int => Int, Uns => Uns, U_Spec => U_Spec) with Ghost;
-
package System.Image_I is
- package IP renames I_Spec;
- package UP renames U_Spec;
- use type UP.Uns_Option;
-
- Unsigned_Width_Ghost : constant Natural := U_Spec.Max_Log10 + 2 with Ghost;
procedure Image_Integer
(V : Int;
S : in out String;
- P : out Natural)
- with
- Pre => S'First = 1
- and then S'Last < Integer'Last
- and then S'Last >= Unsigned_Width_Ghost,
- Post => P in S'Range
- and then IP.Is_Value_Integer_Ghost (S (1 .. P), V);
+ P : out Natural);
-- Computes Int'Image (V) and stores the result in S (1 .. P)
-- setting the resulting value of P. The caller guarantees that S
-- is long enough to hold the result, and that S'First is 1.
@@ -82,31 +48,7 @@ package System.Image_I is
procedure Set_Image_Integer
(V : Int;
S : in out String;
- P : in out Natural)
- with
- Pre => P < Integer'Last
- and then S'Last < Integer'Last
- and then S'First <= P + 1
- and then S'First <= S'Last
- and then
- (if V >= 0 then
- P <= S'Last - Unsigned_Width_Ghost + 1
- else
- P <= S'Last - Unsigned_Width_Ghost),
- Post => S (S'First .. P'Old) = S'Old (S'First .. P'Old)
- and then
- (declare
- Minus : constant Boolean := S (P'Old + 1) = '-';
- Offset : constant Positive := (if V >= 0 then 1 else 2);
- Abs_V : constant Uns := IP.Abs_Uns_Of_Int (V);
- begin
- Minus = (V < 0)
- and then P in P'Old + Offset .. S'Last
- and then UP.Only_Decimal_Ghost
- (S, From => P'Old + Offset, To => P)
- and then UP.Scan_Based_Number_Ghost
- (S, From => P'Old + Offset, To => P)
- = UP.Wrap_Option (Abs_V));
+ P : in out Natural);
-- Stores the image of V in S starting at S (P + 1), P is updated to point
-- to the last character stored. The value stored is identical to the value
-- of Int'Image (V) except that no leading space is stored when V is
diff --git a/gcc/ada/libgnat/s-imageu.adb b/gcc/ada/libgnat/s-imageu.adb
index 820156b..a6cdfed 100644
--- a/gcc/ada/libgnat/s-imageu.adb
+++ b/gcc/ada/libgnat/s-imageu.adb
@@ -29,79 +29,8 @@
-- --
------------------------------------------------------------------------------
-with Ada.Numerics.Big_Numbers.Big_Integers_Ghost;
-use Ada.Numerics.Big_Numbers.Big_Integers_Ghost;
-with System.Val_Spec;
-
package body System.Image_U is
- -- Ghost code, loop invariants and assertions in this unit are meant for
- -- analysis only, not for run-time checking, as it would be too costly
- -- otherwise. This is enforced by setting the assertion policy to Ignore.
-
- pragma Assertion_Policy (Ghost => Ignore,
- Loop_Invariant => Ignore,
- Assert => Ignore,
- Assert_And_Cut => Ignore,
- Subprogram_Variant => Ignore);
-
- package Unsigned_Conversion is new Unsigned_Conversions (Int => Uns);
-
- function Big (Arg : Uns) return Big_Integer renames
- Unsigned_Conversion.To_Big_Integer;
-
- function From_Big (Arg : Big_Integer) return Uns renames
- Unsigned_Conversion.From_Big_Integer;
-
- Big_10 : constant Big_Integer := Big (10) with Ghost;
-
- ------------------
- -- Local Lemmas --
- ------------------
-
- procedure Lemma_Non_Zero (X : Uns)
- with
- Ghost,
- Pre => X /= 0,
- Post => Big (X) /= 0;
-
- procedure Lemma_Div_Commutation (X, Y : Uns)
- with
- Ghost,
- Pre => Y /= 0,
- Post => Big (X) / Big (Y) = Big (X / Y);
-
- procedure Lemma_Div_Twice (X : Big_Natural; Y, Z : Big_Positive)
- with
- Ghost,
- Post => X / Y / Z = X / (Y * Z);
-
- ---------------------------
- -- Lemma_Div_Commutation --
- ---------------------------
-
- procedure Lemma_Non_Zero (X : Uns) is null;
- procedure Lemma_Div_Commutation (X, Y : Uns) is null;
-
- ---------------------
- -- Lemma_Div_Twice --
- ---------------------
-
- procedure Lemma_Div_Twice (X : Big_Natural; Y, Z : Big_Positive) is
- XY : constant Big_Natural := X / Y;
- YZ : constant Big_Natural := Y * Z;
- XYZ : constant Big_Natural := X / Y / Z;
- R : constant Big_Natural := (XY rem Z) * Y + (X rem Y);
- begin
- pragma Assert (X = XY * Y + (X rem Y));
- pragma Assert (XY = XY / Z * Z + (XY rem Z));
- pragma Assert (X = XYZ * YZ + R);
- pragma Assert ((XY rem Z) * Y <= (Z - 1) * Y);
- pragma Assert (R <= YZ - 1);
- pragma Assert (X / YZ = (XYZ * YZ + R) / YZ);
- pragma Assert (X / YZ = XYZ + R / YZ);
- end Lemma_Div_Twice;
-
--------------------
-- Image_Unsigned --
--------------------
@@ -112,50 +41,10 @@ package body System.Image_U is
P : out Natural)
is
pragma Assert (S'First = 1);
-
- procedure Prove_Value_Unsigned
- with
- Ghost,
- Pre => S'First = 1
- and then S'Last < Integer'Last
- and then P in 2 .. S'Last
- and then S (1) = ' '
- and then U_Spec.Only_Decimal_Ghost (S, From => 2, To => P)
- and then U_Spec.Scan_Based_Number_Ghost (S, From => 2, To => P)
- = U_Spec.Wrap_Option (V),
- Post => not System.Val_Spec.Only_Space_Ghost (S, 1, P)
- and then U_Spec.Is_Unsigned_Ghost (S (1 .. P))
- and then U_Spec.Is_Value_Unsigned_Ghost (S (1 .. P), V);
- -- Ghost lemma to prove the value of Value_Unsigned from the value of
- -- Scan_Based_Number_Ghost on a decimal string.
-
- --------------------------
- -- Prove_Value_Unsigned --
- --------------------------
-
- procedure Prove_Value_Unsigned is
- Str : constant String := S (1 .. P);
- begin
- pragma Assert (Str'First = 1);
- pragma Assert (S (2) /= ' ');
- pragma Assert
- (U_Spec.Only_Decimal_Ghost (Str, From => 2, To => P));
- U_Spec.Prove_Scan_Based_Number_Ghost_Eq
- (S, Str, From => 2, To => P);
- pragma Assert
- (U_Spec.Scan_Based_Number_Ghost (Str, From => 2, To => P)
- = U_Spec.Wrap_Option (V));
- U_Spec.Prove_Scan_Only_Decimal_Ghost (Str, V);
- end Prove_Value_Unsigned;
-
- -- Start of processing for Image_Unsigned
-
begin
S (1) := ' ';
P := 1;
Set_Image_Unsigned (V, S, P);
-
- Prove_Value_Unsigned;
end Image_Unsigned;
------------------------
@@ -169,118 +58,6 @@ package body System.Image_U is
is
Nb_Digits : Natural := 0;
Value : Uns := V;
-
- -- Local ghost variables
-
- Pow : Big_Positive := 1 with Ghost;
- S_Init : constant String := S with Ghost;
- Prev_Value : Uns with Ghost;
- Prev_S : String := S with Ghost;
-
- -- Local ghost lemmas
-
- procedure Prove_Character_Val (R : Uns)
- with
- Ghost,
- Post => R rem 10 in 0 .. 9
- and then Character'Val (48 + R rem 10) in '0' .. '9';
- -- Ghost lemma to prove the value of a character corresponding to the
- -- next figure.
-
- procedure Prove_Euclidian (Val, Quot, Rest : Uns)
- with
- Ghost,
- Pre => Quot = Val / 10
- and then Rest = Val rem 10,
- Post => Uns'Last - Rest >= 10 * Quot and then Val = 10 * Quot + Rest;
- -- Ghost lemma to prove the relation between the quotient/remainder of
- -- division by 10 and the initial value.
-
- procedure Prove_Hexa_To_Unsigned_Ghost (R : Uns)
- with
- Ghost,
- Pre => R in 0 .. 9,
- Post => U_Spec.Hexa_To_Unsigned_Ghost (Character'Val (48 + R)) = R;
- -- Ghost lemma to prove that Hexa_To_Unsigned_Ghost returns the source
- -- figure when applied to the corresponding character.
-
- procedure Prove_Scan_Iter
- (S, Prev_S : String;
- V, Prev_V, Res : Uns;
- P, Max : Natural)
- with
- Ghost,
- Pre =>
- S'First = Prev_S'First and then S'Last = Prev_S'Last
- and then S'Last < Natural'Last and then
- Max in S'Range and then P in S'First .. Max and then
- (for all I in P + 1 .. Max => Prev_S (I) in '0' .. '9')
- and then (for all I in P + 1 .. Max => Prev_S (I) = S (I))
- and then S (P) in '0' .. '9'
- and then V <= Uns'Last / 10
- and then Uns'Last - U_Spec.Hexa_To_Unsigned_Ghost (S (P))
- >= 10 * V
- and then Prev_V =
- V * 10 + U_Spec.Hexa_To_Unsigned_Ghost (S (P))
- and then
- (if P = Max then Prev_V = Res
- else U_Spec.Scan_Based_Number_Ghost
- (Str => Prev_S,
- From => P + 1,
- To => Max,
- Base => 10,
- Acc => Prev_V) = U_Spec.Wrap_Option (Res)),
- Post =>
- (for all I in P .. Max => S (I) in '0' .. '9')
- and then U_Spec.Scan_Based_Number_Ghost
- (Str => S,
- From => P,
- To => Max,
- Base => 10,
- Acc => V) = U_Spec.Wrap_Option (Res);
- -- Ghost lemma to prove that Scan_Based_Number_Ghost is preserved
- -- through an iteration of the loop.
-
- -----------------------------
- -- Local lemma null bodies --
- -----------------------------
-
- procedure Prove_Character_Val (R : Uns) is null;
- procedure Prove_Euclidian (Val, Quot, Rest : Uns) is null;
- procedure Prove_Hexa_To_Unsigned_Ghost (R : Uns) is null;
-
- ---------------------
- -- Prove_Scan_Iter --
- ---------------------
-
- procedure Prove_Scan_Iter
- (S, Prev_S : String;
- V, Prev_V, Res : Uns;
- P, Max : Natural)
- is
- pragma Unreferenced (Res);
- begin
- U_Spec.Lemma_Scan_Based_Number_Ghost_Step
- (Str => S,
- From => P,
- To => Max,
- Base => 10,
- Acc => V);
- if P < Max then
- U_Spec.Prove_Scan_Based_Number_Ghost_Eq
- (Prev_S, S, P + 1, Max, 10, Prev_V);
- else
- U_Spec.Lemma_Scan_Based_Number_Ghost_Base
- (Str => S,
- From => P + 1,
- To => Max,
- Base => 10,
- Acc => Prev_V);
- end if;
- end Prove_Scan_Iter;
-
- -- Start of processing for Set_Image_Unsigned
-
begin
pragma Assert (P >= S'First - 1 and then P < S'Last and then
P < Natural'Last);
@@ -290,70 +67,19 @@ package body System.Image_U is
-- First we compute the number of characters needed for representing
-- the number.
loop
- Lemma_Div_Commutation (Value, 10);
- Lemma_Div_Twice (Big (V), Big_10 ** Nb_Digits, Big_10);
-
Value := Value / 10;
Nb_Digits := Nb_Digits + 1;
- Pow := Pow * 10;
-
- pragma Loop_Invariant (Nb_Digits in 1 .. Unsigned_Width_Ghost - 1);
- pragma Loop_Invariant (Pow = Big_10 ** Nb_Digits);
- pragma Loop_Invariant (Big (Value) = Big (V) / Pow);
- pragma Loop_Variant (Decreases => Value);
exit when Value = 0;
-
- Lemma_Non_Zero (Value);
- pragma Assert (Pow <= Big (Uns'Last));
end loop;
- pragma Assert (Big (V) / (Big_10 ** Nb_Digits) = 0);
Value := V;
- Pow := 1;
-
- pragma Assert (Value = From_Big (Big (V) / Big_10 ** 0));
-- We now populate digits from the end of the string to the beginning
for J in reverse 1 .. Nb_Digits loop
- Lemma_Div_Commutation (Value, 10);
- Lemma_Div_Twice (Big (V), Big_10 ** (Nb_Digits - J), Big_10);
- Prove_Character_Val (Value);
- Prove_Hexa_To_Unsigned_Ghost (Value rem 10);
-
- Prev_Value := Value;
- Prev_S := S;
- Pow := Pow * 10;
S (P + J) := Character'Val (48 + (Value rem 10));
Value := Value / 10;
-
- Prove_Euclidian
- (Val => Prev_Value,
- Quot => Value,
- Rest => U_Spec.Hexa_To_Unsigned_Ghost (S (P + J)));
-
- Prove_Scan_Iter
- (S, Prev_S, Value, Prev_Value, V, P + J, P + Nb_Digits);
-
- pragma Loop_Invariant (Value <= Uns'Last / 10);
- pragma Loop_Invariant
- (for all K in S'First .. P => S (K) = S_Init (K));
- pragma Loop_Invariant
- (U_Spec.Only_Decimal_Ghost
- (S, From => P + J, To => P + Nb_Digits));
- pragma Loop_Invariant (Pow = Big_10 ** (Nb_Digits - J + 1));
- pragma Loop_Invariant (Big (Value) = Big (V) / Pow);
- pragma Loop_Invariant
- (U_Spec.Scan_Based_Number_Ghost
- (Str => S,
- From => P + J,
- To => P + Nb_Digits,
- Base => 10,
- Acc => Value)
- = U_Spec.Wrap_Option (V));
end loop;
- pragma Assert (Big (Value) = Big (V) / (Big_10 ** Nb_Digits));
- pragma Assert (Value = 0);
P := P + Nb_Digits;
end Set_Image_Unsigned;
diff --git a/gcc/ada/libgnat/s-imageu.ads b/gcc/ada/libgnat/s-imageu.ads
index 720de40..8640a5b 100644
--- a/gcc/ada/libgnat/s-imageu.ads
+++ b/gcc/ada/libgnat/s-imageu.ads
@@ -33,44 +33,15 @@
-- and ``Ada.Text_IO.Modular_IO`` conversions routines for modular integer
-- types.
--- 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. Postconditions and
--- contract cases should not be executed at runtime as well, in order not to
--- slow down the execution of these functions.
-
-pragma Assertion_Policy (Pre => Ignore,
- Post => Ignore,
- Contract_Cases => Ignore,
- Ghost => Ignore,
- Subprogram_Variant => Ignore);
-
-with System.Value_U_Spec;
-
generic
-
type Uns is mod <>;
- -- Additional parameters for ghost subprograms used inside contracts
-
- with package U_Spec is new System.Value_U_Spec (Uns => Uns) with Ghost;
-
package System.Image_U is
- use all type U_Spec.Uns_Option;
-
- Unsigned_Width_Ghost : constant Natural := U_Spec.Max_Log10 + 2 with Ghost;
procedure Image_Unsigned
(V : Uns;
S : in out String;
- P : out Natural)
- with
- Pre => S'First = 1
- and then S'Last < Integer'Last
- and then S'Last >= Unsigned_Width_Ghost,
- Post => P in S'Range
- and then U_Spec.Is_Value_Unsigned_Ghost (S (1 .. P), V);
- pragma Inline (Image_Unsigned);
+ P : out Natural) with Inline;
-- Computes Uns'Image (V) and stores the result in S (1 .. P) setting
-- the resulting value of P. The caller guarantees that S is long enough to
-- hold the result, and that S'First is 1.
@@ -78,19 +49,7 @@ package System.Image_U is
procedure Set_Image_Unsigned
(V : Uns;
S : in out String;
- P : in out Natural)
- with
- Pre => P < Integer'Last
- and then S'Last < Integer'Last
- and then S'First <= P + 1
- and then S'First <= S'Last
- and then P <= S'Last - Unsigned_Width_Ghost + 1,
- Post => S (S'First .. P'Old) = S'Old (S'First .. P'Old)
- and then P in P'Old + 1 .. S'Last
- and then U_Spec.Only_Decimal_Ghost (S, From => P'Old + 1, To => P)
- and then U_Spec.Scan_Based_Number_Ghost
- (S, From => P'Old + 1, To => P)
- = U_Spec.Wrap_Option (V);
+ P : in out Natural);
-- Stores the image of V in S starting at S (P + 1), P is updated to point
-- to the last character stored. The value stored is identical to the value
-- of Uns'Image (V) except that no leading space is stored. The caller
diff --git a/gcc/ada/libgnat/s-imde128.ads b/gcc/ada/libgnat/s-imde128.ads
index f353f57..03485b9 100644
--- a/gcc/ada/libgnat/s-imde128.ads
+++ b/gcc/ada/libgnat/s-imde128.ads
@@ -39,9 +39,8 @@ with System.Image_D;
package System.Img_Decimal_128 is
subtype Int128 is Interfaces.Integer_128;
- subtype Uns128 is Interfaces.Unsigned_128;
- package Impl is new Image_D (Int128, Uns128);
+ package Impl is new Image_D (Int128);
procedure Image_Decimal128
(V : Int128;
diff --git a/gcc/ada/libgnat/s-imde32.ads b/gcc/ada/libgnat/s-imde32.ads
index 442f343..40fd5e9 100644
--- a/gcc/ada/libgnat/s-imde32.ads
+++ b/gcc/ada/libgnat/s-imde32.ads
@@ -39,9 +39,8 @@ with System.Image_D;
package System.Img_Decimal_32 is
subtype Int32 is Interfaces.Integer_32;
- subtype Uns32 is Interfaces.Unsigned_32;
- package Impl is new Image_D (Int32, Uns32);
+ package Impl is new Image_D (Int32);
procedure Image_Decimal32
(V : Int32;
diff --git a/gcc/ada/libgnat/s-imde64.ads b/gcc/ada/libgnat/s-imde64.ads
index a69e02f..5264c43 100644
--- a/gcc/ada/libgnat/s-imde64.ads
+++ b/gcc/ada/libgnat/s-imde64.ads
@@ -39,9 +39,8 @@ with System.Image_D;
package System.Img_Decimal_64 is
subtype Int64 is Interfaces.Integer_64;
- subtype Uns64 is Interfaces.Unsigned_64;
- package Impl is new Image_D (Int64, Uns64);
+ package Impl is new Image_D (Int64);
procedure Image_Decimal64
(V : Int64;
diff --git a/gcc/ada/libgnat/s-imfi128.ads b/gcc/ada/libgnat/s-imfi128.ads
index 9bb383a..23cd059 100644
--- a/gcc/ada/libgnat/s-imfi128.ads
+++ b/gcc/ada/libgnat/s-imfi128.ads
@@ -39,9 +39,8 @@ with System.Image_F;
package System.Img_Fixed_128 is
subtype Int128 is Interfaces.Integer_128;
- subtype Uns128 is Interfaces.Unsigned_128;
- package Impl is new Image_F (Int128, Uns128, Arith_128.Scaled_Divide128);
+ package Impl is new Image_F (Int128, Arith_128.Scaled_Divide128);
procedure Image_Fixed128
(V : Int128;
diff --git a/gcc/ada/libgnat/s-imfi32.ads b/gcc/ada/libgnat/s-imfi32.ads
index f66b0fa..ba46e8d 100644
--- a/gcc/ada/libgnat/s-imfi32.ads
+++ b/gcc/ada/libgnat/s-imfi32.ads
@@ -39,9 +39,8 @@ with System.Image_F;
package System.Img_Fixed_32 is
subtype Int32 is Interfaces.Integer_32;
- subtype Uns32 is Interfaces.Unsigned_32;
- package Impl is new Image_F (Int32, Uns32, Arith_32.Scaled_Divide32);
+ package Impl is new Image_F (Int32, Arith_32.Scaled_Divide32);
procedure Image_Fixed32
(V : Int32;
diff --git a/gcc/ada/libgnat/s-imfi64.ads b/gcc/ada/libgnat/s-imfi64.ads
index ecb70ad..c7f7aa1 100644
--- a/gcc/ada/libgnat/s-imfi64.ads
+++ b/gcc/ada/libgnat/s-imfi64.ads
@@ -39,9 +39,8 @@ with System.Image_F;
package System.Img_Fixed_64 is
subtype Int64 is Interfaces.Integer_64;
- subtype Uns64 is Interfaces.Unsigned_64;
- package Impl is new Image_F (Int64, Uns64, Arith_64.Scaled_Divide64);
+ package Impl is new Image_F (Int64, Arith_64.Scaled_Divide64);
procedure Image_Fixed64
(V : Int64;
diff --git a/gcc/ada/libgnat/s-imgboo.adb b/gcc/ada/libgnat/s-imgboo.adb
index 436818c..c4d85bf 100644
--- a/gcc/ada/libgnat/s-imgboo.adb
+++ b/gcc/ada/libgnat/s-imgboo.adb
@@ -29,32 +29,9 @@
-- --
------------------------------------------------------------------------------
--- Ghost code, loop invariants and assertions in this unit are meant for
--- analysis only, not for run-time checking, as it would be too costly
--- otherwise. This is enforced by setting the assertion policy to Ignore.
-
-pragma Assertion_Policy (Ghost => Ignore,
- Loop_Invariant => Ignore,
- Assert => Ignore);
-
package body System.Img_Bool
with SPARK_Mode
is
-
- -- Local lemmas
-
- procedure Lemma_Is_First_Non_Space_Ghost (S : String; R : Positive) with
- Ghost,
- Pre => R in S'Range and then S (R) /= ' '
- and then System.Val_Spec.Only_Space_Ghost (S, S'First, R - 1),
- Post => System.Val_Spec.First_Non_Space_Ghost (S, S'First, S'Last) = R;
-
- ------------------------------------
- -- Lemma_Is_First_Non_Space_Ghost --
- ------------------------------------
-
- procedure Lemma_Is_First_Non_Space_Ghost (S : String; R : Positive) is null;
-
-------------------
-- Image_Boolean --
-------------------
@@ -69,11 +46,9 @@ is
if V then
S (1 .. 4) := "TRUE";
P := 4;
- Lemma_Is_First_Non_Space_Ghost (S, 1);
else
S (1 .. 5) := "FALSE";
P := 5;
- Lemma_Is_First_Non_Space_Ghost (S, 1);
end if;
end Image_Boolean;
diff --git a/gcc/ada/libgnat/s-imgboo.ads b/gcc/ada/libgnat/s-imgboo.ads
index 9d8b1f7..af19c2e 100644
--- a/gcc/ada/libgnat/s-imgboo.ads
+++ b/gcc/ada/libgnat/s-imgboo.ads
@@ -34,32 +34,13 @@
-- This package provides support for ``Image`` attribute on ``Boolean``. The
-- compiler performs direct calls to this unit to implement the attribute.
--- 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. Postconditions and
--- contract cases should not be executed at runtime as well, in order not to
--- slow down the execution of these functions.
-
-pragma Assertion_Policy (Pre => Ignore,
- Post => Ignore,
- Contract_Cases => Ignore,
- Ghost => Ignore);
-
-with System.Val_Spec;
-
package System.Img_Bool
with SPARK_Mode, Preelaborate
is
-
procedure Image_Boolean
(V : Boolean;
S : in out String;
- P : out Natural)
- with
- Pre => S'First = 1
- and then (if V then S'Length >= 4 else S'Length >= 5),
- Post => (if V then P = 4 else P = 5)
- and then System.Val_Spec.Is_Boolean_Image_Ghost (S (1 .. P), V);
+ P : out Natural);
-- Computes Boolean'Image (``V``) and stores the result in
-- ``S`` (1 .. ``P``) setting the resulting value of ``P``. The caller
-- guarantees that ``S`` is long enough to hold the result, and that
diff --git a/gcc/ada/libgnat/s-imgint.ads b/gcc/ada/libgnat/s-imgint.ads
index 1ccf173..55df149 100644
--- a/gcc/ada/libgnat/s-imgint.ads
+++ b/gcc/ada/libgnat/s-imgint.ads
@@ -33,33 +33,12 @@
-- and ``Ada.Text_IO.Integer_IO`` conversions routines for signed integer
-- types up to Size ``Integer'Size``.
--- 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. Postconditions and
--- contract cases should not be executed at runtime as well, in order not to
--- slow down the execution of these functions.
-
-pragma Assertion_Policy (Pre => Ignore,
- Post => Ignore,
- Contract_Cases => Ignore,
- Ghost => Ignore,
- Subprogram_Variant => Ignore);
-
with System.Image_I;
-with System.Unsigned_Types;
-with System.Vs_Int;
-with System.Vs_Uns;
package System.Img_Int
with SPARK_Mode
is
- subtype Unsigned is Unsigned_Types.Unsigned;
-
- package Impl is new Image_I
- (Int => Integer,
- Uns => Unsigned,
- U_Spec => System.Vs_Uns.Spec,
- I_Spec => System.Vs_Int.Spec);
+ package Impl is new Image_I (Integer);
procedure Image_Integer
(V : Integer;
diff --git a/gcc/ada/libgnat/s-imglli.ads b/gcc/ada/libgnat/s-imglli.ads
index 32be4dc..28fd563 100644
--- a/gcc/ada/libgnat/s-imglli.ads
+++ b/gcc/ada/libgnat/s-imglli.ads
@@ -33,33 +33,12 @@
-- and ``Ada.Text_IO.Integer_IO`` conversions routines for signed integer
-- types larger than Size ``Integer'Size``.
--- 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. Postconditions and
--- contract cases should not be executed at runtime as well, in order not to
--- slow down the execution of these functions.
-
-pragma Assertion_Policy (Pre => Ignore,
- Post => Ignore,
- Contract_Cases => Ignore,
- Ghost => Ignore,
- Subprogram_Variant => Ignore);
-
with System.Image_I;
-with System.Unsigned_Types;
-with System.Vs_LLI;
-with System.Vs_LLU;
package System.Img_LLI
with SPARK_Mode
is
- subtype Long_Long_Unsigned is Unsigned_Types.Long_Long_Unsigned;
-
- package Impl is new Image_I
- (Int => Long_Long_Integer,
- Uns => Long_Long_Unsigned,
- U_Spec => System.Vs_LLU.Spec,
- I_Spec => System.Vs_LLI.Spec);
+ package Impl is new Image_I (Long_Long_Integer);
procedure Image_Long_Long_Integer
(V : Long_Long_Integer;
diff --git a/gcc/ada/libgnat/s-imgllli.ads b/gcc/ada/libgnat/s-imgllli.ads
index 47c75b0..cecbdff 100644
--- a/gcc/ada/libgnat/s-imgllli.ads
+++ b/gcc/ada/libgnat/s-imgllli.ads
@@ -33,33 +33,12 @@
-- signed integer types larger than Long_Long_Integer, and also for conversion
-- operations required in Text_IO.Integer_IO for such types.
--- 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. Postconditions and
--- contract cases should not be executed at runtime as well, in order not to
--- slow down the execution of these functions.
-
-pragma Assertion_Policy (Pre => Ignore,
- Post => Ignore,
- Contract_Cases => Ignore,
- Ghost => Ignore,
- Subprogram_Variant => Ignore);
-
with System.Image_I;
-with System.Unsigned_Types;
-with System.Vs_LLLI;
-with System.Vs_LLLU;
package System.Img_LLLI
with SPARK_Mode
is
- subtype Long_Long_Long_Unsigned is Unsigned_Types.Long_Long_Long_Unsigned;
-
- package Impl is new Image_I
- (Int => Long_Long_Long_Integer,
- Uns => Long_Long_Long_Unsigned,
- U_Spec => System.Vs_LLLU.Spec,
- I_Spec => System.Vs_LLLI.Spec);
+ package Impl is new Image_I (Long_Long_Long_Integer);
procedure Image_Long_Long_Long_Integer
(V : Long_Long_Long_Integer;
diff --git a/gcc/ada/libgnat/s-imglllu.ads b/gcc/ada/libgnat/s-imglllu.ads
index 0dbe1f21c..e581d37 100644
--- a/gcc/ada/libgnat/s-imglllu.ads
+++ b/gcc/ada/libgnat/s-imglllu.ads
@@ -33,30 +33,15 @@
-- modular integer types larger than Long_Long_Unsigned, and also for
-- conversion operations required in Text_IO.Modular_IO for such types.
--- 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. Postconditions and
--- contract cases should not be executed at runtime as well, in order not to
--- slow down the execution of these functions.
-
-pragma Assertion_Policy (Pre => Ignore,
- Post => Ignore,
- Contract_Cases => Ignore,
- Ghost => Ignore,
- Subprogram_Variant => Ignore);
-
with System.Image_U;
with System.Unsigned_Types;
-with System.Vs_LLLU;
package System.Img_LLLU
with SPARK_Mode
is
subtype Long_Long_Long_Unsigned is Unsigned_Types.Long_Long_Long_Unsigned;
- package Impl is new Image_U
- (Uns => Long_Long_Long_Unsigned,
- U_Spec => System.Vs_LLLU.Spec);
+ package Impl is new Image_U (Uns => Long_Long_Long_Unsigned);
procedure Image_Long_Long_Long_Unsigned
(V : Long_Long_Long_Unsigned;
diff --git a/gcc/ada/libgnat/s-imgllu.ads b/gcc/ada/libgnat/s-imgllu.ads
index 82d372d..729e6e8 100644
--- a/gcc/ada/libgnat/s-imgllu.ads
+++ b/gcc/ada/libgnat/s-imgllu.ads
@@ -33,30 +33,15 @@
-- and ``Ada.Text_IO.Modular_IO`` conversions routines for unsigned (modular)
-- integer types larger than Size ``Unsigned'Size``.
--- 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. Postconditions and
--- contract cases should not be executed at runtime as well, in order not to
--- slow down the execution of these functions.
-
-pragma Assertion_Policy (Pre => Ignore,
- Post => Ignore,
- Contract_Cases => Ignore,
- Ghost => Ignore,
- Subprogram_Variant => Ignore);
-
with System.Image_U;
with System.Unsigned_Types;
-with System.Vs_LLU;
package System.Img_LLU
with SPARK_Mode
is
subtype Long_Long_Unsigned is Unsigned_Types.Long_Long_Unsigned;
- package Impl is new Image_U
- (Uns => Long_Long_Unsigned,
- U_Spec => System.Vs_LLU.Spec);
+ package Impl is new Image_U (Uns => Long_Long_Unsigned);
procedure Image_Long_Long_Unsigned
(V : Long_Long_Unsigned;
diff --git a/gcc/ada/libgnat/s-imguns.ads b/gcc/ada/libgnat/s-imguns.ads
index 142591a..dbab67e 100644
--- a/gcc/ada/libgnat/s-imguns.ads
+++ b/gcc/ada/libgnat/s-imguns.ads
@@ -33,30 +33,15 @@
-- and ``Ada.Text_IO.Modular_IO`` conversions routines for modular integer
-- types up to size ``Unsigned'Size``.
--- 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. Postconditions and
--- contract cases should not be executed at runtime as well, in order not to
--- slow down the execution of these functions.
-
-pragma Assertion_Policy (Pre => Ignore,
- Post => Ignore,
- Contract_Cases => Ignore,
- Ghost => Ignore,
- Subprogram_Variant => Ignore);
-
with System.Image_U;
with System.Unsigned_Types;
-with System.Vs_Uns;
package System.Img_Uns
with SPARK_Mode
is
subtype Unsigned is Unsigned_Types.Unsigned;
- package Impl is new Image_U
- (Uns => Unsigned,
- U_Spec => System.Vs_Uns.Spec);
+ package Impl is new Image_U (Uns => Unsigned);
procedure Image_Unsigned
(V : Unsigned;
diff --git a/gcc/ada/libgnat/s-secsta.adb b/gcc/ada/libgnat/s-secsta.adb
index 2749658..9d78b86 100644
--- a/gcc/ada/libgnat/s-secsta.adb
+++ b/gcc/ada/libgnat/s-secsta.adb
@@ -633,6 +633,15 @@ package body System.Secondary_Stack is
if Over_Aligning then
Padding := Alignment;
+
+ -- Typically the padding would be
+ -- Alignment - (Addr mod Alignment)
+ -- however Addr in this case is not known yet. It depends on the
+ -- type of the secondary stack (Dynamic/Static). The allocation
+ -- routine for the respective type of stack requires to know the
+ -- allocation size before the address is known. To ensure a
+ -- sufficient allocation size to fit the padding, the padding is
+ -- calculated conservatively.
end if;
-- Round the requested size (plus the needed padding in case of
diff --git a/gcc/ada/libgnat/s-secsta__cheri.adb b/gcc/ada/libgnat/s-secsta__cheri.adb
index a24b50e..9a65ed28 100644
--- a/gcc/ada/libgnat/s-secsta__cheri.adb
+++ b/gcc/ada/libgnat/s-secsta__cheri.adb
@@ -662,6 +662,15 @@ package body System.Secondary_Stack is
if Over_Aligning then
Over_Align_Padding := Alignment;
+
+ -- Typically the padding would be
+ -- Alignment - (Addr mod Alignment)
+ -- however Addr in this case is not known yet. It depends on the
+ -- type of the secondary stack (Dynamic/Static). The allocation
+ -- routine for the respective type of stack requires to know the
+ -- allocation size before the address is known. To ensure a
+ -- sufficient allocation size to fit the padding, the padding is
+ -- calculated conservatively.
end if;
-- It should not be possible to request an allocation of negative
diff --git a/gcc/ada/libgnat/s-spark.ads b/gcc/ada/libgnat/s-spark.ads
deleted file mode 100644
index c46409f..0000000
--- a/gcc/ada/libgnat/s-spark.ads
+++ /dev/null
@@ -1,39 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- S Y S T E M . S P A R K --
--- --
--- S p e c --
--- --
--- Copyright (C) 2022-2025, Free Software Foundation, Inc. --
--- --
--- GNAT is 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 top level unit of the SPARK package. Its children
--- contain helper functions to aid proofs.
-
-package System.SPARK with
- SPARK_Mode,
- Pure
-is
-end System.SPARK;
diff --git a/gcc/ada/libgnat/s-spcuop.adb b/gcc/ada/libgnat/s-spcuop.adb
deleted file mode 100644
index 74422ea..0000000
--- a/gcc/ada/libgnat/s-spcuop.adb
+++ /dev/null
@@ -1,42 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- S Y S T E M . S P A R K . C U T _ O P E R A T I O N S --
--- --
--- B o d y --
--- --
--- Copyright (C) 2022-2025, Free Software Foundation, Inc. --
--- --
--- GNAT is 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.SPARK.Cut_Operations with
- SPARK_Mode => Off
-is
-
- function By (Consequence, Premise : Boolean) return Boolean is
- (Premise and then Consequence);
-
- function So (Premise, Consequence : Boolean) return Boolean is
- (Premise and then Consequence);
-
-end System.SPARK.Cut_Operations;
diff --git a/gcc/ada/libgnat/s-spcuop.ads b/gcc/ada/libgnat/s-spcuop.ads
deleted file mode 100644
index 04a94a5..0000000
--- a/gcc/ada/libgnat/s-spcuop.ads
+++ /dev/null
@@ -1,57 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- S Y S T E M . S P A R K . C U T _ O P E R A T I O N S --
--- --
--- S p e c --
--- --
--- Copyright (C) 2022-2025, Free Software Foundation, Inc. --
--- --
--- GNAT is 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 connectors used to manually help the proof of
--- assertions by introducing intermediate steps. They can only be used inside
--- pragmas Assert or Assert_And_Cut.
-
-package System.SPARK.Cut_Operations with
- SPARK_Mode,
- Pure,
- Always_Terminates
-is
-
- function By (Consequence, Premise : Boolean) return Boolean with
- Ghost,
- Global => null;
- -- If A and B are two boolean expressions, proving By (A, B) requires
- -- proving B, the premise, and then A assuming B, the side-condition. When
- -- By (A, B) is assumed on the other hand, we only assume A. B is used
- -- for the proof, but is not visible afterward.
-
- function So (Premise, Consequence : Boolean) return Boolean with
- Ghost,
- Global => null;
- -- If A and B are two boolean expressions, proving So (A, B) requires
- -- proving A, the premise, and then B assuming A, the side-condition. When
- -- So (A, B) is assumed both A and B are assumed to be true.
-
-end System.SPARK.Cut_Operations;
diff --git a/gcc/ada/libgnat/s-trasym__dwarf.adb b/gcc/ada/libgnat/s-trasym__dwarf.adb
index 45af884..1b4b807 100644
--- a/gcc/ada/libgnat/s-trasym__dwarf.adb
+++ b/gcc/ada/libgnat/s-trasym__dwarf.adb
@@ -41,6 +41,7 @@ with System.Soft_Links;
with System.CRTL;
with System.Dwarf_Lines;
with System.Exception_Traces;
+with System.OS_Lib;
with System.Standard_Library;
with System.Traceback_Entries;
with System.Strings;
@@ -413,6 +414,23 @@ package body System.Traceback.Symbolic is
return;
end if;
+ -- On some platforms, we use dladdr and the dli_fname field to get the
+ -- pathname, but that pathname might be relative and not point to the
+ -- right thing in our context. That happens when the executable is
+ -- dynamically linked and was started through execvp; dli_fname only
+ -- contains the executable name passed to execvp in that case.
+ --
+ -- Because of this, we might be about to open a file that's in fact not
+ -- a shared object but something completely unrelated. It's hard to
+ -- detect this in general, but we perform a sanity check that
+ -- Module_Name does not designate a directory; if it does, it's
+ -- definitely not a shared object.
+
+ if System.OS_Lib.Is_Directory (Module_Name) then
+ Success := False;
+ return;
+ end if;
+
Open (Module_Name, Module.C, Success);
-- If a module can't be opened just return now, we just cannot give more
diff --git a/gcc/ada/libgnat/s-vafi128.ads b/gcc/ada/libgnat/s-vafi128.ads
index 7518c6c..d75857a 100644
--- a/gcc/ada/libgnat/s-vafi128.ads
+++ b/gcc/ada/libgnat/s-vafi128.ads
@@ -29,9 +29,9 @@
-- --
------------------------------------------------------------------------------
--- 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.
+-- This package contains the routines for supporting the Value attribute for
+-- ordinary fixed point types up to 128-bit small and mantissa, and also for
+-- conversion operations required in Text_IO.Fixed_IO for such types.
with Interfaces;
with System.Arith_128;
diff --git a/gcc/ada/libgnat/s-vafi32.ads b/gcc/ada/libgnat/s-vafi32.ads
index e3ad5c2..7ed22c6 100644
--- a/gcc/ada/libgnat/s-vafi32.ads
+++ b/gcc/ada/libgnat/s-vafi32.ads
@@ -29,9 +29,9 @@
-- --
------------------------------------------------------------------------------
--- 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.
+-- This package contains the routines for supporting the Value attribute for
+-- ordinary fixed point types up to 32-bit small and mantissa, and also for
+-- conversion operations required in Text_IO.Fixed_IO for such types.
with Interfaces;
with System.Arith_32;
diff --git a/gcc/ada/libgnat/s-vafi64.ads b/gcc/ada/libgnat/s-vafi64.ads
index 4d86939..43197bb 100644
--- a/gcc/ada/libgnat/s-vafi64.ads
+++ b/gcc/ada/libgnat/s-vafi64.ads
@@ -29,9 +29,9 @@
-- --
------------------------------------------------------------------------------
--- 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.
+-- This package contains the routines for supporting the Value attribute for
+-- ordinary fixed point types up to 64-bit small and mantissa, and also for
+-- conversion operations required in Text_IO.Fixed_IO for such types.
with Interfaces;
with System.Arith_64;
diff --git a/gcc/ada/libgnat/s-vaispe.adb b/gcc/ada/libgnat/s-vaispe.adb
deleted file mode 100644
index 0b09f75..0000000
--- a/gcc/ada/libgnat/s-vaispe.adb
+++ /dev/null
@@ -1,87 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- S Y S T E M . V A L U E _ I _ S P E C --
--- --
--- B o d y --
--- --
--- Copyright (C) 2022-2025, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-pragma Assertion_Policy (Pre => Ignore,
- Post => Ignore,
- Contract_Cases => Ignore,
- Ghost => Ignore,
- Subprogram_Variant => Ignore);
-
-package body System.Value_I_Spec is
-
- -----------------------------------
- -- Prove_Scan_Only_Decimal_Ghost --
- -----------------------------------
-
- procedure Prove_Scan_Only_Decimal_Ghost (Str : String; Val : Int) is
- Non_Blank : constant Positive := First_Non_Space_Ghost
- (Str, Str'First, Str'Last);
- pragma Assert (Str (Str'First + 1) /= ' ');
- pragma Assert
- (if Val < 0 then Non_Blank = Str'First
- else
- Str (Str'First) = ' '
- and then Non_Blank = Str'First + 1);
- Minus : constant Boolean := Str (Non_Blank) = '-';
- Fst_Num : constant Positive :=
- (if Minus then Non_Blank + 1 else Non_Blank);
- pragma Assert (Fst_Num = Str'First + 1);
- Uval : constant Uns := Abs_Uns_Of_Int (Val);
-
- procedure Prove_Conversion_Is_Identity (Val : Int; Uval : Uns)
- with
- Pre => Minus = (Val < 0)
- and then Uval = Abs_Uns_Of_Int (Val),
- Post => Uns_Is_Valid_Int (Minus, Uval)
- and then Is_Int_Of_Uns (Minus, Uval, Val);
- -- Local proof of the unicity of the signed representation
-
- procedure Prove_Conversion_Is_Identity (Val : Int; Uval : Uns) is null;
-
- -- Start of processing for Prove_Scan_Only_Decimal_Ghost
-
- begin
- Prove_Conversion_Is_Identity (Val, Uval);
- pragma Assert
- (U_Spec.Is_Raw_Unsigned_Format_Ghost (Str (Fst_Num .. Str'Last)));
- pragma Assert
- (U_Spec.Scan_Split_No_Overflow_Ghost (Str, Fst_Num, Str'Last));
- U_Spec.Lemma_Exponent_Unsigned_Ghost_Base (Uval, 0, 10);
- pragma Assert
- (U_Spec.Raw_Unsigned_No_Overflow_Ghost (Str, Fst_Num, Str'Last));
- pragma Assert (Only_Space_Ghost
- (Str, U_Spec.Raw_Unsigned_Last_Ghost
- (Str, Fst_Num, Str'Last), Str'Last));
- pragma Assert (Is_Integer_Ghost (Str));
- pragma Assert (Is_Value_Integer_Ghost (Str, Val));
- end Prove_Scan_Only_Decimal_Ghost;
-
-end System.Value_I_Spec;
diff --git a/gcc/ada/libgnat/s-vaispe.ads b/gcc/ada/libgnat/s-vaispe.ads
deleted file mode 100644
index 2e729aa..0000000
--- a/gcc/ada/libgnat/s-vaispe.ads
+++ /dev/null
@@ -1,185 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- S Y S T E M . V A L U E _ I _ S P E C --
--- --
--- S p e c --
--- --
--- Copyright (C) 2022-2025, Free Software Foundation, Inc. --
--- --
--- GNAT is 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 is part of a set of Ghost code packages used to proof the
--- implementations of the Image and Value attributes. It provides the
--- specification entities using for the formal verification of the routines
--- for scanning signed integer values.
-
--- 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. Postconditions and
--- contract cases should not be executed at runtime as well, in order not to
--- slow down the execution of these functions.
-
-pragma Assertion_Policy (Pre => Ignore,
- Post => Ignore,
- Contract_Cases => Ignore,
- Ghost => Ignore,
- Subprogram_Variant => Ignore);
-
-with System.Value_U_Spec;
-with System.Val_Spec; use System.Val_Spec;
-
-generic
-
- type Int is range <>;
-
- type Uns is mod <>;
-
- -- Additional parameters for ghost subprograms used inside contracts
-
- with package U_Spec is new System.Value_U_Spec (Uns => Uns) with Ghost;
-
-package System.Value_I_Spec with
- Ghost,
- SPARK_Mode,
- Always_Terminates
-is
- pragma Preelaborate;
- use all type U_Spec.Uns_Option;
-
- function Uns_Is_Valid_Int (Minus : Boolean; Uval : Uns) return Boolean is
- (if Minus then Uval <= Uns (Int'Last) + 1
- else Uval <= Uns (Int'Last))
- with Post => True;
- -- Return True if Uval (or -Uval when Minus is True) is a valid number of
- -- type Int.
-
- function Is_Int_Of_Uns
- (Minus : Boolean;
- Uval : Uns;
- Val : Int)
- return Boolean
- is
- (if Minus and then Uval = Uns (Int'Last) + 1 then Val = Int'First
- elsif Minus then Val = -(Int (Uval))
- else Val = Int (Uval))
- with
- Pre => Uns_Is_Valid_Int (Minus, Uval),
- Post => True;
- -- Return True if Uval (or -Uval when Minus is True) is equal to Val
-
- function Abs_Uns_Of_Int (Val : Int) return Uns is
- (if Val = Int'First then Uns (Int'Last) + 1
- elsif Val < 0 then Uns (-Val)
- else Uns (Val));
- -- Return the unsigned absolute value of Val
-
- function Slide_To_1 (Str : String) return String
- with
- Post =>
- Only_Space_Ghost (Str, Str'First, Str'Last) =
- (for all J in Str'First .. Str'Last =>
- Slide_To_1'Result (J - Str'First + 1) = ' ');
- -- Slides Str so that it starts at 1
-
- function Slide_If_Necessary (Str : String) return String is
- (if Str'Last = Positive'Last then Slide_To_1 (Str) else Str);
- -- If Str'Last = Positive'Last then slides Str so that it starts at 1
-
- function Is_Integer_Ghost (Str : String) return Boolean is
- (declare
- Non_Blank : constant Positive := First_Non_Space_Ghost
- (Str, Str'First, Str'Last);
- Fst_Num : constant Positive :=
- (if Str (Non_Blank) in '+' | '-' then Non_Blank + 1 else Non_Blank);
- begin
- U_Spec.Is_Raw_Unsigned_Format_Ghost (Str (Fst_Num .. Str'Last))
- and then U_Spec.Raw_Unsigned_No_Overflow_Ghost
- (Str, Fst_Num, Str'Last)
- and then
- Uns_Is_Valid_Int
- (Minus => Str (Non_Blank) = '-',
- Uval => U_Spec.Scan_Raw_Unsigned_Ghost
- (Str, Fst_Num, Str'Last))
- and then Only_Space_Ghost
- (Str, U_Spec.Raw_Unsigned_Last_Ghost
- (Str, Fst_Num, Str'Last), Str'Last))
- with
- Pre => not Only_Space_Ghost (Str, Str'First, Str'Last)
- and then Str'Last /= Positive'Last,
- Post => True;
- -- Ghost function that determines if Str has the correct format for a
- -- signed number, consisting in some blank characters, an optional
- -- sign, a raw unsigned number which does not overflow and then some
- -- more blank characters.
-
- function Is_Value_Integer_Ghost (Str : String; Val : Int) return Boolean is
- (declare
- Non_Blank : constant Positive := First_Non_Space_Ghost
- (Str, Str'First, Str'Last);
- Fst_Num : constant Positive :=
- (if Str (Non_Blank) in '+' | '-' then Non_Blank + 1 else Non_Blank);
- Uval : constant Uns :=
- U_Spec.Scan_Raw_Unsigned_Ghost (Str, Fst_Num, Str'Last);
- begin
- Is_Int_Of_Uns (Minus => Str (Non_Blank) = '-',
- Uval => Uval,
- Val => Val))
- with
- Pre => not Only_Space_Ghost (Str, Str'First, Str'Last)
- and then Str'Last /= Positive'Last
- and then Is_Integer_Ghost (Str),
- Post => True;
- -- Ghost function that returns True if Val is the value corresponding to
- -- the signed number represented by Str.
-
- procedure Prove_Scan_Only_Decimal_Ghost (Str : String; Val : Int)
- with
- Ghost,
- Pre => Str'Last /= Positive'Last
- and then Str'Length >= 2
- and then Str (Str'First) in ' ' | '-'
- and then (Str (Str'First) = '-') = (Val < 0)
- and then U_Spec.Only_Decimal_Ghost (Str, Str'First + 1, Str'Last)
- and then U_Spec.Scan_Based_Number_Ghost
- (Str, Str'First + 1, Str'Last)
- = U_Spec.Wrap_Option (Abs_Uns_Of_Int (Val)),
- Post => Is_Integer_Ghost (Slide_If_Necessary (Str))
- and then Is_Value_Integer_Ghost (Str, Val);
- -- Ghost lemma used in the proof of 'Image implementation, to prove that
- -- the result of Value_Integer on a decimal string is the same as the
- -- signing the result of Scan_Based_Number_Ghost.
-
-private
-
- ----------------
- -- Slide_To_1 --
- ----------------
-
- function Slide_To_1 (Str : String) return String is
- (declare
- Res : constant String (1 .. Str'Length) := Str;
- begin
- Res);
-
-end System.Value_I_Spec;
diff --git a/gcc/ada/libgnat/s-valboo.adb b/gcc/ada/libgnat/s-valboo.adb
index 8db3316..93d6fb2 100644
--- a/gcc/ada/libgnat/s-valboo.adb
+++ b/gcc/ada/libgnat/s-valboo.adb
@@ -29,14 +29,6 @@
-- --
------------------------------------------------------------------------------
--- Ghost code, loop invariants and assertions in this unit are meant for
--- analysis only, not for run-time checking, as it would be too costly
--- otherwise. This is enforced by setting the assertion policy to Ignore.
-
-pragma Assertion_Policy (Ghost => Ignore,
- Loop_Invariant => Ignore,
- Assert => Ignore);
-
with System.Val_Util; use System.Val_Util;
package body System.Val_Bool
@@ -55,9 +47,6 @@ is
begin
Normalize_String (S, F, L, To_Upper_Case => True);
- pragma Assert (F = System.Val_Spec.First_Non_Space_Ghost
- (S, Str'First, Str'Last));
-
if S (F .. L) = "TRUE" then
return True;
diff --git a/gcc/ada/libgnat/s-valboo.ads b/gcc/ada/libgnat/s-valboo.ads
index fdd8a3f..b2fd558 100644
--- a/gcc/ada/libgnat/s-valboo.ads
+++ b/gcc/ada/libgnat/s-valboo.ads
@@ -29,32 +29,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. Postconditions and
--- contract cases should not be executed at runtime as well, in order not to
--- slow down the execution of these functions.
-
-pragma Assertion_Policy (Pre => Ignore,
- Post => Ignore,
- Contract_Cases => Ignore,
- Ghost => Ignore);
-
-with System.Val_Spec;
-
package System.Val_Bool
with SPARK_Mode
is
pragma Preelaborate;
- function Value_Boolean (Str : String) return Boolean
- with
- Pre => System.Val_Spec.Is_Boolean_Image_Ghost (Str, True)
- or else System.Val_Spec.Is_Boolean_Image_Ghost (Str, False),
- Post =>
- Value_Boolean'Result =
- (Str (System.Val_Spec.First_Non_Space_Ghost
- (Str, Str'First, Str'Last)) in 't' | 'T');
+ function Value_Boolean (Str : String) return Boolean;
-- Computes Boolean'Value (Str)
end System.Val_Bool;
diff --git a/gcc/ada/libgnat/s-valint.ads b/gcc/ada/libgnat/s-valint.ads
index 6045cd6..164bbfe 100644
--- a/gcc/ada/libgnat/s-valint.ads
+++ b/gcc/ada/libgnat/s-valint.ads
@@ -32,23 +32,9 @@
-- This package contains routines for scanning signed Integer values for use
-- in Text_IO.Integer_IO, and the Value attribute.
--- 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. Postconditions and
--- contract cases should not be executed at runtime as well, in order not to
--- slow down the execution of these functions.
-
-pragma Assertion_Policy (Pre => Ignore,
- Post => Ignore,
- Contract_Cases => Ignore,
- Ghost => Ignore,
- Subprogram_Variant => Ignore);
-
with System.Unsigned_Types;
with System.Val_Uns;
with System.Value_I;
-with System.Vs_Int;
-with System.Vs_Uns;
package System.Val_Int with SPARK_Mode is
pragma Preelaborate;
@@ -58,9 +44,7 @@ package System.Val_Int with SPARK_Mode is
package Impl is new Value_I
(Int => Integer,
Uns => Unsigned,
- Scan_Raw_Unsigned => Val_Uns.Scan_Raw_Unsigned,
- U_Spec => System.Vs_Uns.Spec,
- Spec => System.Vs_Int.Spec);
+ Scan_Raw_Unsigned => Val_Uns.Scan_Raw_Unsigned);
procedure Scan_Integer
(Str : String;
diff --git a/gcc/ada/libgnat/s-vallli.ads b/gcc/ada/libgnat/s-vallli.ads
index 7672cc5..a3b48e3 100644
--- a/gcc/ada/libgnat/s-vallli.ads
+++ b/gcc/ada/libgnat/s-vallli.ads
@@ -32,23 +32,9 @@
-- This package contains routines for scanning signed Long_Long_Integer
-- values for use in Text_IO.Integer_IO, and the Value attribute.
--- 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. Postconditions and
--- contract cases should not be executed at runtime as well, in order not to
--- slow down the execution of these functions.
-
-pragma Assertion_Policy (Pre => Ignore,
- Post => Ignore,
- Contract_Cases => Ignore,
- Ghost => Ignore,
- Subprogram_Variant => Ignore);
-
with System.Unsigned_Types;
with System.Val_LLU;
with System.Value_I;
-with System.Vs_LLI;
-with System.Vs_LLU;
package System.Val_LLI with SPARK_Mode is
pragma Preelaborate;
@@ -58,9 +44,7 @@ package System.Val_LLI with SPARK_Mode is
package Impl is new Value_I
(Int => Long_Long_Integer,
Uns => Long_Long_Unsigned,
- Scan_Raw_Unsigned => Val_LLU.Scan_Raw_Long_Long_Unsigned,
- U_Spec => System.Vs_LLU.Spec,
- Spec => System.Vs_LLI.Spec);
+ Scan_Raw_Unsigned => Val_LLU.Scan_Raw_Long_Long_Unsigned);
procedure Scan_Long_Long_Integer
(Str : String;
diff --git a/gcc/ada/libgnat/s-valllli.ads b/gcc/ada/libgnat/s-valllli.ads
index e2cae26..719d4f4 100644
--- a/gcc/ada/libgnat/s-valllli.ads
+++ b/gcc/ada/libgnat/s-valllli.ads
@@ -32,23 +32,9 @@
-- This package contains routines for scanning signed Long_Long_Long_Integer
-- values for use in Text_IO.Integer_IO, and the Value attribute.
--- 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. Postconditions and
--- contract cases should not be executed at runtime as well, in order not to
--- slow down the execution of these functions.
-
-pragma Assertion_Policy (Pre => Ignore,
- Post => Ignore,
- Contract_Cases => Ignore,
- Ghost => Ignore,
- Subprogram_Variant => Ignore);
-
with System.Unsigned_Types;
with System.Val_LLLU;
with System.Value_I;
-with System.Vs_LLLI;
-with System.Vs_LLLU;
package System.Val_LLLI with SPARK_Mode is
pragma Preelaborate;
@@ -58,9 +44,7 @@ package System.Val_LLLI with SPARK_Mode is
package Impl is new Value_I
(Int => Long_Long_Long_Integer,
Uns => Long_Long_Long_Unsigned,
- Scan_Raw_Unsigned => Val_LLLU.Scan_Raw_Long_Long_Long_Unsigned,
- U_Spec => System.Vs_LLLU.Spec,
- Spec => System.Vs_LLLI.Spec);
+ Scan_Raw_Unsigned => Val_LLLU.Scan_Raw_Long_Long_Long_Unsigned);
procedure Scan_Long_Long_Long_Integer
(Str : String;
diff --git a/gcc/ada/libgnat/s-vallllu.ads b/gcc/ada/libgnat/s-vallllu.ads
index 8e57e51..50a061b 100644
--- a/gcc/ada/libgnat/s-vallllu.ads
+++ b/gcc/ada/libgnat/s-vallllu.ads
@@ -32,28 +32,15 @@
-- This package contains routines for scanning modular Long_Long_Unsigned
-- values for use in Text_IO.Modular_IO, and the Value attribute.
--- 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. Postconditions and
--- contract cases should not be executed at runtime as well, in order not to
--- slow down the execution of these functions.
-
-pragma Assertion_Policy (Pre => Ignore,
- Post => Ignore,
- Contract_Cases => Ignore,
- Ghost => Ignore,
- Subprogram_Variant => Ignore);
-
with System.Unsigned_Types;
with System.Value_U;
-with System.Vs_LLLU;
package System.Val_LLLU with SPARK_Mode is
pragma Preelaborate;
subtype Long_Long_Long_Unsigned is Unsigned_Types.Long_Long_Long_Unsigned;
- package Impl is new Value_U (Long_Long_Long_Unsigned, System.Vs_LLLU.Spec);
+ package Impl is new Value_U (Long_Long_Long_Unsigned);
procedure Scan_Raw_Long_Long_Long_Unsigned
(Str : String;
diff --git a/gcc/ada/libgnat/s-valllu.ads b/gcc/ada/libgnat/s-valllu.ads
index a7e37fc..eeb9a25 100644
--- a/gcc/ada/libgnat/s-valllu.ads
+++ b/gcc/ada/libgnat/s-valllu.ads
@@ -32,28 +32,15 @@
-- This package contains routines for scanning modular Long_Long_Unsigned
-- values for use in Text_IO.Modular_IO, and the Value attribute.
--- 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. Postconditions and
--- contract cases should not be executed at runtime as well, in order not to
--- slow down the execution of these functions.
-
-pragma Assertion_Policy (Pre => Ignore,
- Post => Ignore,
- Contract_Cases => Ignore,
- Ghost => Ignore,
- Subprogram_Variant => Ignore);
-
with System.Unsigned_Types;
with System.Value_U;
-with System.Vs_LLU;
package System.Val_LLU with SPARK_Mode is
pragma Preelaborate;
subtype Long_Long_Unsigned is Unsigned_Types.Long_Long_Unsigned;
- package Impl is new Value_U (Long_Long_Unsigned, System.Vs_LLU.Spec);
+ package Impl is new Value_U (Long_Long_Unsigned);
procedure Scan_Raw_Long_Long_Unsigned
(Str : String;
diff --git a/gcc/ada/libgnat/s-valrea.adb b/gcc/ada/libgnat/s-valrea.adb
index aff694d..aaa82d4 100644
--- a/gcc/ada/libgnat/s-valrea.adb
+++ b/gcc/ada/libgnat/s-valrea.adb
@@ -49,7 +49,8 @@ package body System.Val_Real is
Precision_Limit : constant Uns := 2**Num'Machine_Mantissa - 1;
-- See below for the rationale
- package Impl is new Value_R (Uns, 2, Precision_Limit, Round => False);
+ package Impl is new Value_R (Uns, 2, Precision_Limit);
+ -- We do not use the Extra digits for floating-point types
subtype Base_T is Unsigned range 2 .. 16;
@@ -90,7 +91,7 @@ package body System.Val_Real is
when others => raise Program_Error);
-- Return the exponent of a power of 2
- function Integer_to_Real
+ function Integer_To_Real
(Str : String;
Val : Impl.Value_Array;
Base : Unsigned;
@@ -105,10 +106,10 @@ package body System.Val_Real is
-- Return Num'Scaling (5.0**Exp, -S) as a double number where Exp > Maxexp
---------------------
- -- Integer_to_Real --
+ -- Integer_To_Real --
---------------------
- function Integer_to_Real
+ function Integer_To_Real
(Str : String;
Val : Impl.Value_Array;
Base : Unsigned;
@@ -213,7 +214,7 @@ package body System.Val_Real is
-- Compute the final value by applying the scaling, if any
- if (Val (1) = 0 and then Val (2) = 0) or else S = 0 then
+ if Val (1) = 0 or else S = 0 then
R_Val := Double_Real.To_Single (D_Val);
else
@@ -313,7 +314,7 @@ package body System.Val_Real is
exception
when Constraint_Error => Bad_Value (Str);
- end Integer_to_Real;
+ end Integer_To_Real;
-------------------
-- Large_Powfive --
@@ -456,7 +457,7 @@ package body System.Val_Real is
begin
Val := Impl.Scan_Raw_Real (Str, Ptr, Max, Base, Scale, Extra, Minus);
- return Integer_to_Real (Str, Val, Base, Scale, Minus);
+ return Integer_To_Real (Str, Val, Base, Scale, Minus);
end Scan_Real;
----------------
@@ -473,7 +474,7 @@ package body System.Val_Real is
begin
Val := Impl.Value_Raw_Real (Str, Base, Scale, Extra, Minus);
- return Integer_to_Real (Str, Val, Base, Scale, Minus);
+ return Integer_To_Real (Str, Val, Base, Scale, Minus);
end Value_Real;
end System.Val_Real;
diff --git a/gcc/ada/libgnat/s-valspe.ads b/gcc/ada/libgnat/s-valspe.ads
deleted file mode 100644
index fbd3ba5..0000000
--- a/gcc/ada/libgnat/s-valspe.ads
+++ /dev/null
@@ -1,246 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- S Y S T E M . V A L _ S P E C --
--- --
--- S p e c --
--- --
--- Copyright (C) 2023-2025, Free Software Foundation, Inc. --
--- --
--- GNAT is 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 is part of a set of Ghost code packages used to proof the
--- implementations of the Image and Value attributes. It provides some common
--- specification functions used by the s-valxxx files.
-
--- 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. Postconditions and
--- contract cases should not be executed at runtime as well, in order not to
--- slow down the execution of these functions.
-
-pragma Assertion_Policy (Pre => Ignore,
- Post => Ignore,
- Contract_Cases => Ignore,
- Ghost => Ignore);
-
-package System.Val_Spec with
- SPARK_Mode,
- Pure,
- Ghost
-is
- function Only_Space_Ghost (S : String; From, To : Integer) return Boolean is
- (for all J in From .. To => S (J) = ' ')
- with
- Pre => From > To or else (From >= S'First and then To <= S'Last),
- Post => True;
- -- Ghost function that returns True if S has only space characters from
- -- index From to index To.
-
- function First_Non_Space_Ghost
- (S : String;
- From, To : Integer) return Positive
- with
- Pre => From in S'Range
- and then To in S'Range
- and then not Only_Space_Ghost (S, From, To),
- Post => First_Non_Space_Ghost'Result in From .. To
- and then S (First_Non_Space_Ghost'Result) /= ' '
- and then Only_Space_Ghost
- (S, From, First_Non_Space_Ghost'Result - 1);
- -- Ghost function that returns the index of the first non-space character
- -- in S, which necessarily exists given the precondition on S.
-
- function Is_Boolean_Image_Ghost
- (Str : String;
- Val : Boolean) return Boolean
- is
- (not Only_Space_Ghost (Str, Str'First, Str'Last)
- and then
- (declare
- F : constant Positive := First_Non_Space_Ghost
- (Str, Str'First, Str'Last);
- begin
- (Val
- and then F <= Str'Last - 3
- and then Str (F) in 't' | 'T'
- and then Str (F + 1) in 'r' | 'R'
- and then Str (F + 2) in 'u' | 'U'
- and then Str (F + 3) in 'e' | 'E'
- and then
- (if F + 3 < Str'Last then
- Only_Space_Ghost (Str, F + 4, Str'Last)))
- or else
- (not Val
- and then F <= Str'Last - 4
- and then Str (F) in 'f' | 'F'
- and then Str (F + 1) in 'a' | 'A'
- and then Str (F + 2) in 'l' | 'L'
- and then Str (F + 3) in 's' | 'S'
- and then Str (F + 4) in 'e' | 'E'
- and then
- (if F + 4 < Str'Last then
- Only_Space_Ghost (Str, F + 5, Str'Last)))))
- with
- Ghost;
- -- Ghost function that returns True iff Str is the image of boolean Val,
- -- that is "true" or "false" in any capitalization, possibly surounded by
- -- space characters.
-
- function Only_Number_Ghost (Str : String; From, To : Integer) return Boolean
- is
- (for all J in From .. To => Str (J) in '0' .. '9' | '_')
- with
- Pre => From > To or else (From >= Str'First and then To <= Str'Last);
- -- Ghost function that returns True if S has only number characters from
- -- index From to index To.
-
- function Last_Number_Ghost (Str : String) return Positive
- with
- Pre => Str /= "" and then Str (Str'First) in '0' .. '9',
- Post => Last_Number_Ghost'Result in Str'Range
- and then (if Last_Number_Ghost'Result < Str'Last then
- Str (Last_Number_Ghost'Result + 1) not in '0' .. '9' | '_')
- and then Only_Number_Ghost (Str, Str'First, Last_Number_Ghost'Result);
- -- Ghost function that returns the index of the last character in S that
- -- is either a figure or underscore, which necessarily exists given the
- -- precondition on Str.
-
- function Is_Natural_Format_Ghost (Str : String) return Boolean is
- (Str /= ""
- and then Str (Str'First) in '0' .. '9'
- and then
- (declare
- L : constant Positive := Last_Number_Ghost (Str);
- begin
- Str (L) in '0' .. '9'
- and then (for all J in Str'First .. L =>
- (if Str (J) = '_' then Str (J + 1) /= '_'))));
- -- Ghost function that determines if Str has the correct format for a
- -- natural number, consisting in a sequence of figures possibly separated
- -- by single underscores. It may be followed by other characters.
-
- function Starts_As_Exponent_Format_Ghost
- (Str : String;
- Real : Boolean := False) return Boolean
- is
- (Str'Length > 1
- and then Str (Str'First) in 'E' | 'e'
- and then
- (declare
- Plus_Sign : constant Boolean := Str (Str'First + 1) = '+';
- Minus_Sign : constant Boolean := Str (Str'First + 1) = '-';
- Sign : constant Boolean := Plus_Sign or Minus_Sign;
- begin
- (if Minus_Sign then Real)
- and then (if Sign then Str'Length > 2)
- and then
- (declare
- Start : constant Natural :=
- (if Sign then Str'First + 2 else Str'First + 1);
- begin
- Str (Start) in '0' .. '9')));
- -- Ghost function that determines if Str is recognized as something which
- -- might be an exponent, ie. it starts with an 'e', capitalized or not,
- -- followed by an optional sign which can only be '-' if we are working on
- -- real numbers (Real is True), and then a digit in decimal notation.
-
- function Is_Opt_Exponent_Format_Ghost
- (Str : String;
- Real : Boolean := False) return Boolean
- is
- (not Starts_As_Exponent_Format_Ghost (Str, Real)
- or else
- (declare
- Start : constant Natural :=
- (if Str (Str'First + 1) in '+' | '-' then Str'First + 2
- else Str'First + 1);
- begin Is_Natural_Format_Ghost (Str (Start .. Str'Last))));
- -- Ghost function that determines if Str has the correct format for an
- -- optional exponent, that is, either it does not start as an exponent, or
- -- it is in a correct format for a natural number.
-
- function Scan_Natural_Ghost
- (Str : String;
- P : Natural;
- Acc : Natural)
- return Natural
- with
- Subprogram_Variant => (Increases => P),
- Pre => Str /= "" and then Str (Str'First) in '0' .. '9'
- and then Str'Last < Natural'Last
- and then P in Str'First .. Last_Number_Ghost (Str) + 1;
- -- Ghost function that recursively computes the natural number in Str, up
- -- to the first number greater or equal to Natural'Last / 10, assuming Acc
- -- has been scanned already and scanning continues at index P.
-
- function Scan_Exponent_Ghost
- (Str : String;
- Real : Boolean := False)
- return Integer
- is
- (declare
- Plus_Sign : constant Boolean := Str (Str'First + 1) = '+';
- Minus_Sign : constant Boolean := Str (Str'First + 1) = '-';
- Sign : constant Boolean := Plus_Sign or Minus_Sign;
- Start : constant Natural :=
- (if Sign then Str'First + 2 else Str'First + 1);
- Value : constant Natural :=
- Scan_Natural_Ghost (Str (Start .. Str'Last), Start, 0);
- begin
- (if Minus_Sign then -Value else Value))
- with
- Pre => Str'Last < Natural'Last
- and then Starts_As_Exponent_Format_Ghost (Str, Real),
- Post => (if not Real then Scan_Exponent_Ghost'Result >= 0);
- -- Ghost function that scans an exponent
-
-private
-
- ------------------------
- -- Scan_Natural_Ghost --
- ------------------------
-
- function Scan_Natural_Ghost
- (Str : String;
- P : Natural;
- Acc : Natural)
- return Natural
- is
- (if P > Str'Last
- or else Str (P) not in '0' .. '9' | '_'
- or else Acc >= Integer'Last / 10
- then
- Acc
- elsif Str (P) = '_' then
- Scan_Natural_Ghost (Str, P + 1, Acc)
- else
- (declare
- Shift_Acc : constant Natural :=
- Acc * 10 +
- (Integer'(Character'Pos (Str (P))) -
- Integer'(Character'Pos ('0')));
- begin
- Scan_Natural_Ghost (Str, P + 1, Shift_Acc)));
-
-end System.Val_Spec;
diff --git a/gcc/ada/libgnat/s-valued.adb b/gcc/ada/libgnat/s-valued.adb
index dfef9a88..4f2e102 100644
--- a/gcc/ada/libgnat/s-valued.adb
+++ b/gcc/ada/libgnat/s-valued.adb
@@ -38,14 +38,16 @@ 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, 1, 2**(Int'Size - 1), Round => False);
- -- We do not use the Extra digit for decimal fixed-point types
+ package Impl is new Value_R (Uns, 1, 2**(Int'Size - 1));
+ -- We do not use the Extra digits for decimal fixed-point types, except to
+ -- effectively ensure that overflow is detected near the boundaries.
function Integer_to_Decimal
(Str : String;
Val : Uns;
Base : Unsigned;
ScaleB : Integer;
+ Extra2 : Unsigned;
Minus : Boolean;
Scale : Integer) return Int;
-- Convert the real value from integer to decimal representation
@@ -59,6 +61,7 @@ package body System.Value_D is
Val : Uns;
Base : Unsigned;
ScaleB : Integer;
+ Extra2 : Unsigned;
Minus : Boolean;
Scale : Integer) return Int
is
@@ -72,7 +75,7 @@ package body System.Value_D 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;
+ function To_Signed (Val : Uns) return Int;
-- Convert an integer value from unsigned to signed representation
-----------------
@@ -99,11 +102,11 @@ package body System.Value_D is
return Result;
end Safe_Expont;
- ------------------------
- -- Unsigned_To_Signed --
- ------------------------
+ ---------------
+ -- To_Signed --
+ ---------------
- function Unsigned_To_Signed (Val : Uns) return Int is
+ function To_Signed (Val : Uns) return Int is
begin
-- Deal with overflow cases, and also with largest negative number
@@ -124,34 +127,51 @@ package body System.Value_D is
else
return Int (Val);
end if;
- end Unsigned_To_Signed;
+ end To_Signed;
+
+ -- Local variables
+
+ V : Uns := Val;
+ S : Integer := ScaleB;
+ E : Unsigned := Extra2 / Base;
begin
+ -- The implementation of Value_R uses fully symmetric arithmetics
+ -- but here we cannot handle 2**(Int'Size - 1) if Minus is not set.
+
+ if V = 2**(Int'Size - 1) and then not Minus then
+ E := Unsigned (V rem Uns (Base));
+ V := V / Uns (Base);
+ S := S + 1;
+ end if;
+
-- 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;
-
+ if Base = 10 or else S = 0 then
begin
+ S := S + Scale;
+
while S < 0 loop
+ if V = 0 then
+ exit;
+ end if;
V := V / 10;
S := S + 1;
end loop;
while S > 0 loop
- if V <= Uns'Last / 10 then
- V := V * 10;
+ if V <= (Uns'Last - Uns (E)) / 10 then
+ V := V * 10 + Uns (E);
S := S - 1;
+ E := 0;
else
Bad_Value (Str);
end if;
end loop;
- return Unsigned_To_Signed (V);
+ return To_Signed (V);
end;
-- If the base of the value is not 10, use a scaled divide operation
@@ -159,10 +179,7 @@ package body System.Value_D is
else
declare
- B : constant Int := Int (Base);
- S : constant Integer := ScaleB;
-
- V : Uns := Val;
+ B : constant Int := Int (Base);
Y, Z, Q, R : Int;
@@ -178,7 +195,10 @@ package body System.Value_D is
Z := Safe_Expont (B, LS, 10 ** Integer'Max (0, -Scale));
for J in 1 .. LS loop
- V := V / Uns (B);
+ if V = 0 then
+ exit;
+ end if;
+ V := V / Uns (Base);
end loop;
end;
@@ -193,8 +213,9 @@ package body System.Value_D is
Z := 10 ** Integer'Max (0, -Scale);
for J in 1 .. LS loop
- if V <= Uns'Last / Uns (B) then
- V := V * Uns (B);
+ if V <= (Uns'Last - Uns (E)) / Uns (Base) then
+ V := V * Uns (Base) + Uns (E);
+ E := 0;
else
Bad_Value (Str);
end if;
@@ -207,9 +228,9 @@ package body System.Value_D is
raise Program_Error;
end if;
- -- Perform a scale divide operation with rounding to match 'Image
+ -- Perform a scaled divide operation with rounding to match 'Image
- Scaled_Divide (Unsigned_To_Signed (V), Y, Z, Q, R, Round => True);
+ Scaled_Divide (To_Signed (V), Y, Z, Q, R, Round => True);
return Q;
end;
@@ -229,16 +250,17 @@ package body System.Value_D is
Max : Integer;
Scale : Integer) return Int
is
- Base : Unsigned;
- Scl : Impl.Scale_Array;
- Extra : Unsigned;
- Minus : Boolean;
- Val : Impl.Value_Array;
+ Base : Unsigned;
+ Scl : Impl.Scale_Array;
+ Extra2 : Unsigned;
+ Minus : Boolean;
+ Val : Impl.Value_Array;
begin
- Val := Impl.Scan_Raw_Real (Str, Ptr, Max, Base, Scl, Extra, Minus);
+ Val := Impl.Scan_Raw_Real (Str, Ptr, Max, Base, Scl, Extra2, Minus);
- return Integer_to_Decimal (Str, Val (1), Base, Scl (1), Minus, Scale);
+ return
+ Integer_to_Decimal (Str, Val (1), Base, Scl (1), Extra2, Minus, Scale);
end Scan_Decimal;
-------------------
@@ -246,16 +268,17 @@ package body System.Value_D is
-------------------
function Value_Decimal (Str : String; Scale : Integer) return Int is
- Base : Unsigned;
- Scl : Impl.Scale_Array;
- Extra : Unsigned;
- Minus : Boolean;
- Val : Impl.Value_Array;
+ Base : Unsigned;
+ Scl : Impl.Scale_Array;
+ Extra2 : Unsigned;
+ Minus : Boolean;
+ Val : Impl.Value_Array;
begin
- Val := Impl.Value_Raw_Real (Str, Base, Scl, Extra, Minus);
+ Val := Impl.Value_Raw_Real (Str, Base, Scl, Extra2, Minus);
- return Integer_to_Decimal (Str, Val (1), Base, Scl (1), Minus, Scale);
+ return
+ Integer_to_Decimal (Str, Val (1), Base, Scl (1), Extra2, Minus, Scale);
end Value_Decimal;
end System.Value_D;
diff --git a/gcc/ada/libgnat/s-valuef.adb b/gcc/ada/libgnat/s-valuef.adb
index 9930740..1743749 100644
--- a/gcc/ada/libgnat/s-valuef.adb
+++ b/gcc/ada/libgnat/s-valuef.adb
@@ -46,15 +46,15 @@ package body System.Value_F 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, 1, 2**(Int'Size - 1), Round => True);
- -- We use the Extra digit for ordinary fixed-point types
+ package Impl is new Value_R (Uns, 1, 2**(Int'Size - 1));
+ -- We use the Extra digits for ordinary fixed-point types
function Integer_To_Fixed
(Str : String;
Val : Uns;
Base : Unsigned;
ScaleB : Integer;
- Extra : Unsigned;
+ Extra2 : Unsigned;
Minus : Boolean;
Num : Int;
Den : Int) return Int;
@@ -79,23 +79,25 @@ package body System.Value_F is
-- 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.
+ -- 1 extra decimal digit contains the information for the missing bits. But
+ -- in practice we need 2 extra decimal digits to avoid multiple roundings.
-- Therefore the actual computation to be performed is
- -- V = (Val * Base + Extra) * (Base ** (ScaleB - 1)) / (Num / Den)
+ -- V = (Val * Base ** 2 + Extra2) * (Base ** (ScaleB - 2)) / (Num / Den)
- -- using two steps of scaled divide if Extra is positive and ScaleB too
+ -- using two steps of scaled divide if Extra2 is positive and ScaleB too
- -- (1) Val * (Den * (Base ** ScaleB)) = Q1 * Num + R1
+ -- (1a) Val * (Den * (Base ** ScaleB)) = Q1 * Num + R1
- -- (2) Extra * (Den * (Base ** ScaleB)) = Q2 * -Base + R2
+ -- (2a) Extra2 * (Den * (Base ** ScaleB)) = Q2 * Base ** 2 + R2
- -- which yields after dividing (1) by Num and (2) by Num * Base and summing
+ -- which yields after dividing (1a) by Num and (2a) by Num * (Base ** 2)
+ -- and summing
- -- V = Q1 + (R1 - Q2) / Num + R2 / (Num * Base)
+ -- V = Q1 + (Q2 + R1) / Num + R2 / (Num * (Base ** 2))
- -- but we get rid of the third term by using a rounding divide for (2).
+ -- but we get rid of the third term by using a rounding divide for (2a).
-- 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
@@ -113,17 +115,17 @@ package body System.Value_F is
-- 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
+ -- On the other hand, if Extra2 is positive and ScaleB negative, the above
-- two steps are
-- (1b) Val * Den = Q1 * (Num * (Base ** -ScaleB)) + R1
- -- (2b) Extra * Den = Q2 * -Base + R2
+ -- (2b) Extra2 * Den = Q2 * Base ** 2 + R2
-- which yields after dividing (1b) by Num * (Base ** -ScaleB) and (2b) by
- -- Num * (Base ** (1 - ScaleB)) and summing
+ -- Num * (Base ** (2 - ScaleB)) and summing
- -- V = Q1 + (R1 - Q2) / (Num * (Base ** -ScaleB)) + R2 / ...
+ -- V = Q1 + (Q2 + R1) / (Num * (Base ** -ScaleB)) + R2 / (Num * (...))
-- but we get rid of the third term by using a rounding divide for (2b).
@@ -143,19 +145,22 @@ package body System.Value_F is
Val : Uns;
Base : Unsigned;
ScaleB : Integer;
- Extra : Unsigned;
+ Extra2 : 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 (Extra2 < Base ** 2);
+ -- Accept only two extra digits after those used for Val
pragma Assert (Num < 0 and then Den < 0);
-- Accept only negative numbers to allow -2**(Int'Size - 1)
+ pragma Unsuppress (Overflow_Check);
+ -- Use overflow check to catch bad values
+
function Safe_Expont
(Base : Int;
Exp : in out Natural;
@@ -166,7 +171,7 @@ package body System.Value_F 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;
+ function To_Signed (Val : Uns) return Int;
-- Convert an integer value from unsigned to signed representation
-----------------
@@ -193,11 +198,11 @@ package body System.Value_F is
return Result;
end Safe_Expont;
- ------------------------
- -- Unsigned_To_Signed --
- ------------------------
+ ---------------
+ -- To_Signed --
+ ---------------
- function Unsigned_To_Signed (Val : Uns) return Int is
+ function To_Signed (Val : Uns) return Int is
begin
-- Deal with overflow cases, and also with largest negative number
@@ -218,60 +223,74 @@ package body System.Value_F is
else
return Int (Val);
end if;
- end Unsigned_To_Signed;
+ end To_Signed;
-- Local variables
B : constant Int := Int (Base);
- V : Uns := Val;
- E : Uns := Uns (Extra);
+ V : Uns := Val;
+ S : Integer := ScaleB;
+ E : Unsigned := Extra2;
Y, Z, Q1, R1, Q2, R2 : Int;
begin
+ -- The implementation of Value_R uses fully symmetric arithmetics
+ -- but here we cannot handle 2**(Int'Size - 1) if Minus is not set.
+
+ if V = 2**(Int'Size - 1) and then not Minus then
+ E := Unsigned (V rem Uns (Base)) * Base + E / Base;
+ V := V / Uns (Base);
+ S := S + 1;
+ end if;
+
-- 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 S is too negative, then drop trailing digits, but preserve the
+ -- last two dropped digits, until V saturates to 0.
- if ScaleB < 0 then
+ if S < 0 then
declare
- LS : Integer := -ScaleB;
+ LS : Integer := -S;
begin
Y := Den;
Z := Safe_Expont (B, LS, Num);
for J in 1 .. LS loop
- E := V rem Uns (B);
- V := V / Uns (B);
+ if V = 0 then
+ E := 0;
+ exit;
+ end if;
+ E := Unsigned (V rem Uns (Base)) * Base + E / Base;
+ V := V / Uns (Base);
end loop;
end;
- -- If ScaleB is too positive, then scale V up, which may then overflow
+ -- If S is too positive, then scale V up, which may then overflow
- elsif ScaleB > 0 then
+ elsif S > 0 then
declare
- LS : Integer := ScaleB;
+ LS : Integer := S;
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;
+ if V <= (Uns'Last - Uns (E / Base)) / Uns (Base) then
+ V := V * Uns (Base) + Uns (E / Base);
+ E := (E rem Base) * Base;
else
Bad_Value (Str);
end if;
end loop;
end;
- -- If ScaleB is zero, then proceed directly
+ -- If S is zero, then proceed directly
else
Y := Den;
@@ -284,8 +303,8 @@ package body System.Value_F is
-- 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);
+ Scaled_Divide (To_Signed (V), Y, Z, Q1, R1, Round => False);
+ Scaled_Divide (To_Signed (Uns (E)), Y, -B**2, 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
@@ -312,7 +331,7 @@ package body System.Value_F is
return Q1 + Q2;
else
- Scaled_Divide (Unsigned_To_Signed (V), Y, Z, Q1, R1, Round => True);
+ Scaled_Divide (To_Signed (V), Y, Z, Q1, R1, Round => True);
return Q1;
end if;
@@ -332,17 +351,17 @@ package body System.Value_F is
Num : Int;
Den : Int) return Int
is
- Base : Unsigned;
- Scl : Impl.Scale_Array;
- Extra : Unsigned;
- Minus : Boolean;
- Val : Impl.Value_Array;
+ Bas : Unsigned;
+ Scl : Impl.Scale_Array;
+ Extra2 : Unsigned;
+ Minus : Boolean;
+ Val : Impl.Value_Array;
begin
- Val := Impl.Scan_Raw_Real (Str, Ptr, Max, Base, Scl, Extra, Minus);
+ Val := Impl.Scan_Raw_Real (Str, Ptr, Max, Bas, Scl, Extra2, Minus);
return
- Integer_To_Fixed (Str, Val (1), Base, Scl (1), Extra, Minus, Num, Den);
+ Integer_To_Fixed (Str, Val (1), Bas, Scl (1), Extra2, Minus, Num, Den);
end Scan_Fixed;
-----------------
@@ -354,17 +373,17 @@ package body System.Value_F is
Num : Int;
Den : Int) return Int
is
- Base : Unsigned;
- Scl : Impl.Scale_Array;
- Extra : Unsigned;
- Minus : Boolean;
- Val : Impl.Value_Array;
+ Bas : Unsigned;
+ Scl : Impl.Scale_Array;
+ Extra2 : Unsigned;
+ Minus : Boolean;
+ Val : Impl.Value_Array;
begin
- Val := Impl.Value_Raw_Real (Str, Base, Scl, Extra, Minus);
+ Val := Impl.Value_Raw_Real (Str, Bas, Scl, Extra2, Minus);
return
- Integer_To_Fixed (Str, Val (1), Base, Scl (1), Extra, Minus, Num, Den);
+ Integer_To_Fixed (Str, Val (1), Bas, Scl (1), Extra2, Minus, Num, Den);
end Value_Fixed;
end System.Value_F;
diff --git a/gcc/ada/libgnat/s-valuei.adb b/gcc/ada/libgnat/s-valuei.adb
index 2c4fe09..53790a0 100644
--- a/gcc/ada/libgnat/s-valuei.adb
+++ b/gcc/ada/libgnat/s-valuei.adb
@@ -33,16 +33,6 @@ with System.Val_Util; use System.Val_Util;
package body System.Value_I is
- -- Ghost code, loop invariants and assertions in this unit are meant for
- -- analysis only, not for run-time checking, as it would be too costly
- -- otherwise. This is enforced by setting the assertion policy to Ignore.
-
- pragma Assertion_Policy (Ghost => Ignore,
- Loop_Invariant => Ignore,
- Assert => Ignore,
- Assert_And_Cut => Ignore,
- Subprogram_Variant => Ignore);
-
------------------
-- Scan_Integer --
------------------
@@ -53,25 +43,6 @@ package body System.Value_I is
Max : Integer;
Res : out Int)
is
- procedure Prove_Is_Int_Of_Uns
- (Minus : Boolean;
- Uval : Uns;
- Val : Int)
- with Ghost,
- Pre => Spec.Uns_Is_Valid_Int (Minus, Uval)
- and then
- (if Minus and then Uval = Uns (Int'Last) + 1 then Val = Int'First
- elsif Minus then Val = -(Int (Uval))
- else Val = Int (Uval)),
- Post => Spec.Is_Int_Of_Uns (Minus, Uval, Val);
- -- Unfold the definition of Is_Int_Of_Uns
-
- procedure Prove_Is_Int_Of_Uns
- (Minus : Boolean;
- Uval : Uns;
- Val : Int)
- is null;
-
Uval : Uns;
-- Unsigned result
@@ -81,15 +52,6 @@ package body System.Value_I is
Unused_Start : Positive;
-- Saves location of first non-blank (not used in this case)
- Non_Blank : constant Positive :=
- First_Non_Space_Ghost (Str, Ptr.all, Max)
- with Ghost;
-
- Fst_Num : constant Positive :=
- (if Str (Non_Blank) in '+' | '-' then Non_Blank + 1
- else Non_Blank)
- with Ghost;
-
begin
Scan_Sign (Str, Ptr, Max, Minus, Unused_Start);
@@ -99,8 +61,6 @@ package body System.Value_I is
end if;
Scan_Raw_Unsigned (Str, Ptr, Max, Uval);
- pragma Assert
- (Uval = U_Spec.Scan_Raw_Unsigned_Ghost (Str, Fst_Num, Max));
-- Deal with overflow cases, and also with largest negative number
@@ -121,11 +81,6 @@ package body System.Value_I is
else
Res := Int (Uval);
end if;
-
- Prove_Is_Int_Of_Uns
- (Minus => Str (Non_Blank) = '-',
- Uval => Uval,
- Val => Res);
end Scan_Integer;
-------------------
@@ -141,15 +96,7 @@ package body System.Value_I is
if Str'Last = Positive'Last then
declare
subtype NT is String (1 .. Str'Length);
- procedure Prove_Is_Integer_Ghost with
- Ghost,
- Pre => Str'Length < Natural'Last
- and then not Only_Space_Ghost (Str, Str'First, Str'Last)
- and then Spec.Is_Integer_Ghost (Spec.Slide_To_1 (Str)),
- Post => Spec.Is_Integer_Ghost (NT (Str));
- procedure Prove_Is_Integer_Ghost is null;
begin
- Prove_Is_Integer_Ghost;
return Value_Integer (NT (Str));
end;
@@ -159,31 +106,14 @@ package body System.Value_I is
declare
V : Int;
P : aliased Integer := Str'First;
-
- Non_Blank : constant Positive := First_Non_Space_Ghost
- (Str, Str'First, Str'Last)
- with Ghost;
-
- Fst_Num : constant Positive :=
- (if Str (Non_Blank) in '+' | '-' then Non_Blank + 1
- else Non_Blank)
- with Ghost;
begin
-
declare
P_Acc : constant not null access Integer := P'Access;
begin
Scan_Integer (Str, P_Acc, Str'Last, V);
end;
- pragma Assert
- (P = U_Spec.Raw_Unsigned_Last_Ghost
- (Str, Fst_Num, Str'Last));
-
Scan_Trailing_Blanks (Str, P);
-
- pragma Assert
- (Spec.Is_Value_Integer_Ghost (Spec.Slide_If_Necessary (Str), V));
return V;
end;
end if;
diff --git a/gcc/ada/libgnat/s-valuei.ads b/gcc/ada/libgnat/s-valuei.ads
index 531eae1..08619c8 100644
--- a/gcc/ada/libgnat/s-valuei.ads
+++ b/gcc/ada/libgnat/s-valuei.ads
@@ -32,16 +32,6 @@
-- This package contains routines for scanning signed integer values for use
-- in Text_IO.Integer_IO, and the Value attribute.
-pragma Assertion_Policy (Pre => Ignore,
- Post => Ignore,
- Contract_Cases => Ignore,
- Ghost => Ignore,
- Subprogram_Variant => Ignore);
-
-with System.Val_Spec; use System.Val_Spec;
-with System.Value_I_Spec;
-with System.Value_U_Spec;
-
generic
type Int is range <>;
@@ -54,13 +44,6 @@ generic
Max : Integer;
Res : out Uns);
- -- Additional parameters for ghost subprograms used inside contracts
-
- with package U_Spec is new System.Value_U_Spec (Uns => Uns) with Ghost;
- with package Spec is new System.Value_I_Spec
- (Int => Int, Uns => Uns, U_Spec => U_Spec)
- with Ghost;
-
package System.Value_I is
pragma Preelaborate;
@@ -68,43 +51,7 @@ package System.Value_I is
(Str : String;
Ptr : not null access Integer;
Max : Integer;
- Res : out Int)
- with
- Pre => Str'Last /= Positive'Last
- -- Ptr.all .. Max is either an empty range, or a valid range in Str
- and then (Ptr.all > Max
- or else (Ptr.all >= Str'First and then Max <= Str'Last))
- and then not Only_Space_Ghost (Str, Ptr.all, Max)
- and then
- (declare
- Non_Blank : constant Positive := First_Non_Space_Ghost
- (Str, Ptr.all, Max);
- Fst_Num : constant Positive :=
- (if Str (Non_Blank) in '+' | '-' then Non_Blank + 1
- else Non_Blank);
- begin
- U_Spec.Is_Raw_Unsigned_Format_Ghost (Str (Fst_Num .. Max))
- and then U_Spec.Raw_Unsigned_No_Overflow_Ghost
- (Str, Fst_Num, Max)
- and then Spec.Uns_Is_Valid_Int
- (Minus => Str (Non_Blank) = '-',
- Uval => U_Spec.Scan_Raw_Unsigned_Ghost
- (Str, Fst_Num, Max))),
- Post =>
- (declare
- Non_Blank : constant Positive := First_Non_Space_Ghost
- (Str, Ptr.all'Old, Max);
- Fst_Num : constant Positive :=
- (if Str (Non_Blank) in '+' | '-' then Non_Blank + 1
- else Non_Blank);
- Uval : constant Uns :=
- U_Spec.Scan_Raw_Unsigned_Ghost (Str, Fst_Num, Max);
- begin
- Spec.Is_Int_Of_Uns (Minus => Str (Non_Blank) = '-',
- Uval => Uval,
- Val => Res)
- and then Ptr.all = U_Spec.Raw_Unsigned_Last_Ghost
- (Str, Fst_Num, Max));
+ Res : out Int);
-- This procedure scans the string starting at Str (Ptr.all) for a valid
-- integer 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
@@ -130,14 +77,7 @@ package System.Value_I 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_Integer (Str : String) return Int
- with
- Pre => not Only_Space_Ghost (Str, Str'First, Str'Last)
- and then Str'Length /= Positive'Last
- and then Spec.Is_Integer_Ghost (Spec.Slide_If_Necessary (Str)),
- Post => Spec.Is_Value_Integer_Ghost
- (Spec.Slide_If_Necessary (Str), Value_Integer'Result),
- Subprogram_Variant => (Decreases => Str'First);
+ function Value_Integer (Str : String) return Int;
-- Used in computing X'Value (Str) where X is a signed integer type whose
-- base range does not exceed the base range of Integer. Str is the string
-- argument of the attribute. Constraint_Error is raised if the string is
diff --git a/gcc/ada/libgnat/s-valuen.ads b/gcc/ada/libgnat/s-valuen.ads
index 047ded6..a57ee55 100644
--- a/gcc/ada/libgnat/s-valuen.ads
+++ b/gcc/ada/libgnat/s-valuen.ads
@@ -30,8 +30,8 @@
------------------------------------------------------------------------------
-- This package is used to compute the Value attribute for enumeration types
--- other than those in packages Standard and System. See unit Exp_Imgv for
--- details of the format of constructed image tables.
+-- other than those in package Standard. See unit Exp_Imgv for details of the
+-- format of constructed image tables.
generic
diff --git a/gcc/ada/libgnat/s-valuer.adb b/gcc/ada/libgnat/s-valuer.adb
index 6f557e9..961dda4 100644
--- a/gcc/ada/libgnat/s-valuer.adb
+++ b/gcc/ada/libgnat/s-valuer.adb
@@ -42,14 +42,6 @@ package body System.Value_R is
function As_Digit (C : Character) return Char_As_Digit;
-- Given a character return the digit it represents
- procedure Round_Extra
- (Digit : Char_As_Digit;
- Base : Unsigned;
- Value : in out Uns;
- Scale : in out Integer;
- Extra : in out Char_As_Digit);
- -- Round the triplet (Value, Scale, Extra) according to Digit in Base
-
procedure Scan_Decimal_Digits
(Str : String;
Index : in out Integer;
@@ -59,7 +51,7 @@ package body System.Value_R is
Value : in out Value_Array;
Scale : in out Scale_Array;
N : in out Positive;
- Extra : in out Char_As_Digit;
+ Extra2 : in out Unsigned;
Base_Violation : in out Boolean);
-- Scan the decimal part of a real (i.e. after decimal separator)
--
@@ -68,7 +60,8 @@ package body System.Value_R is
--
-- 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.
+ -- still parsed but ignored, except for the first two of them which are
+ -- stored in Extra2.
--
-- Base_Violation is set to True if a digit found is not part of the Base
--
@@ -83,7 +76,8 @@ package body System.Value_R is
Value : out Value_Array;
Scale : out Scale_Array;
N : out Positive;
- Extra : out Char_As_Digit;
+ Extra2 : out Unsigned;
+ Extra2_Filled : out Boolean;
Base_Violation : in out Boolean);
-- Scan the integral part of a real (i.e. before decimal separator)
--
@@ -93,7 +87,7 @@ package body System.Value_R is
-- 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.
+ -- two of them which are stored in Extra2 if Extra2_Filled is True.
--
-- Base_Violation is set to True if a digit found is not part of the Base
--
@@ -119,47 +113,6 @@ package body System.Value_R is
end case;
end As_Digit;
- -----------------
- -- Round_Extra --
- -----------------
-
- procedure Round_Extra
- (Digit : Char_As_Digit;
- Base : Unsigned;
- Value : in out Uns;
- Scale : in out Integer;
- Extra : in out Char_As_Digit)
- is
- pragma Assert (Base in 2 .. 16);
-
- 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, Base, Value, Scale, Extra);
-
- else
- Extra := 0;
- Value := Value + 1;
- end if;
-
- else
- Extra := Extra + 1;
- end if;
- end if;
- end Round_Extra;
-
-------------------------
-- Scan_Decimal_Digits --
-------------------------
@@ -173,7 +126,7 @@ package body System.Value_R is
Value : in out Value_Array;
Scale : in out Scale_Array;
N : in out Positive;
- Extra : in out Char_As_Digit;
+ Extra2 : in out Unsigned;
Base_Violation : in out Boolean)
is
@@ -192,8 +145,7 @@ package body System.Value_R is
-- 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.
+ -- Set to True if Precision_Limit_Reached was just set to True
Digit : Char_As_Digit;
-- The current digit
@@ -205,17 +157,16 @@ package body System.Value_R is
-- Number of trailing zeros at a given point
begin
- -- If initial Scale is not 0 then it means that Precision_Limit was
+ -- If initial Scale is not 0, then this means that Precision_Limit was
-- reached during scanning of the integral part.
if Scale (Data_Index'Last) > 0 then
Precision_Limit_Reached := True;
+ Precision_Limit_Just_Reached := True;
+
else
- Extra := 0;
+ Extra2 := 0;
Precision_Limit_Reached := False;
- end if;
-
- if Round then
Precision_Limit_Just_Reached := False;
end if;
@@ -229,28 +180,27 @@ package body System.Value_R is
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 the base is not explicitly specified, 'e' or 'E' marks the
+ -- beginning of the exponent part.
+
+ if not Base_Specified and then Digit = E_Digit then
+ return;
+ end if;
+
+ -- Check that Digit is a valid digit with respect to Base
if Digit >= Base then
- if Base_Specified then
- Base_Violation := True;
- elsif Digit = E_Digit then
- return;
- else
- Base_Violation := True;
- end if;
+ Base_Violation := True;
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.
+ -- first two digits in Extra2. 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, Base, Value (N), Scale (N), Extra);
+ if Precision_Limit_Just_Reached then
+ Extra2 := Extra2 + Digit;
Precision_Limit_Just_Reached := False;
end if;
@@ -273,11 +223,8 @@ package body System.Value_R is
Scale (N) := Scale (N - 1) - 1;
else
- Extra := 0;
+ Extra2 := (if J = Trailing_Zeros then Digit else 0);
Precision_Limit_Reached := True;
- if Round and then J = Trailing_Zeros then
- Round_Extra (Digit, Base, Value (N), Scale (N), Extra);
- end if;
exit;
end if;
@@ -316,11 +263,9 @@ package body System.Value_R is
Scale (N) := Scale (N - 1) - 1;
else
- Extra := Digit;
+ Extra2 := Digit * Base;
Precision_Limit_Reached := True;
- if Round then
- Precision_Limit_Just_Reached := True;
- end if;
+ Precision_Limit_Just_Reached := True;
end if;
end if;
end if;
@@ -339,10 +284,12 @@ package body System.Value_R is
-- Underscore is only allowed if followed by a digit
- if Digit = Underscore and Index + 1 <= Max then
+ if Digit = Underscore and then Index + 1 <= Max then
Digit := As_Digit (Str (Index + 1));
- if Digit in Valid_Digit then
+ if Digit in Valid_Digit and then
+ (Digit /= E_Digit or else Base > E_Digit)
+ then
Index := Index + 1;
else
return;
@@ -370,7 +317,8 @@ package body System.Value_R is
Value : out Value_Array;
Scale : out Scale_Array;
N : out Positive;
- Extra : out Char_As_Digit;
+ Extra2 : out Unsigned;
+ Extra2_Filled : out Boolean;
Base_Violation : in out Boolean)
is
pragma Assert (Base in 2 .. 16);
@@ -386,8 +334,7 @@ package body System.Value_R is
-- 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.
+ -- Set to True if Precision_Limit_Reached was just set to True
Digit : Char_As_Digit;
-- The current digit
@@ -396,18 +343,16 @@ package body System.Value_R is
-- Temporary
begin
- -- Initialize N, Value, Scale and Extra
+ -- Initialize N, Value, Scale, Extra2 and Extra2_Filled
N := 1;
Value := (others => 0);
Scale := (others => 0);
- Extra := 0;
+ Extra2 := 0;
+ Extra2_Filled := False;
Precision_Limit_Reached := False;
-
- if Round then
- Precision_Limit_Just_Reached := False;
- end if;
+ Precision_Limit_Just_Reached := False;
pragma Assert (Max <= Str'Last);
@@ -417,30 +362,30 @@ package body System.Value_R is
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 the base is not explicitly specified, 'e' or 'E' marks the
+ -- beginning of the exponent part.
+
+ if not Base_Specified and then Digit = E_Digit then
+ return;
+ end if;
+
+ -- Check that Digit is a valid digit with respect to Base
if Digit >= Base then
- if Base_Specified then
- Base_Violation := True;
- elsif Digit = E_Digit then
- return;
- else
- Base_Violation := True;
- end if;
+ Base_Violation := True;
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.
+ -- first two digits in Extra2. The scanning should continue only
+ -- to assess the validity of the string.
if Precision_Limit_Reached then
Scale (N) := Scale (N) + 1;
- if Round and then Precision_Limit_Just_Reached then
- Round_Extra (Digit, Base, Value (N), Scale (N), Extra);
+ if Precision_Limit_Just_Reached then
+ Extra2 := Extra2 + Digit;
+ Extra2_Filled := True;
Precision_Limit_Just_Reached := False;
end if;
@@ -465,11 +410,9 @@ package body System.Value_R is
Value (N) := Uns (Digit);
else
- Extra := Digit;
+ Extra2 := Digit * Base;
Precision_Limit_Reached := True;
- if Round then
- Precision_Limit_Just_Reached := True;
- end if;
+ Precision_Limit_Just_Reached := True;
Scale (N) := Scale (N) + 1;
end if;
end if;
@@ -494,9 +437,11 @@ package body System.Value_R is
-- 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
+ if Digit = Underscore and then Index + 1 <= Max then
Digit := As_Digit (Str (Index + 1));
- if Digit in Valid_Digit then
+ if Digit in Valid_Digit and then
+ (Digit /= E_Digit or else Base > E_Digit)
+ then
Index := Index + 1;
else
return;
@@ -513,13 +458,13 @@ package body System.Value_R is
-------------------
function Scan_Raw_Real
- (Str : String;
- Ptr : not null access Integer;
- Max : Integer;
- Base : out Unsigned;
- Scale : out Scale_Array;
- Extra : out Unsigned;
- Minus : out Boolean) return Value_Array
+ (Str : String;
+ Ptr : not null access Integer;
+ Max : Integer;
+ Base : out Unsigned;
+ Scale : out Scale_Array;
+ Extra2 : out Unsigned;
+ Minus : out Boolean) return Value_Array
is
pragma Assert (Max <= Str'Last);
@@ -534,6 +479,9 @@ package body System.Value_R is
-- If True some digits where not in the base. The real is still scanned
-- till the end even if an error will be raised.
+ Extra2_Filled : Boolean;
+ -- True if Extra2 has been filled
+
N : Positive;
-- Index number of the current part
@@ -578,12 +526,12 @@ package body System.Value_R is
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.
+ -- If this is a digit it can indicate either the integral part or the
+ -- base to use.
Scan_Integral_Digits
(Str, Index, Max, Base, False, Value, Scale, N,
- Char_As_Digit (Extra), Base_Violation);
+ Extra2, Extra2_Filled, Base_Violation);
-- A dot is allowed only if followed by a digit (RM 3.5(39.8))
@@ -596,13 +544,15 @@ package body System.Value_R is
N := 1;
Value := (others => 0);
Scale := (others => 0);
- Extra := 0;
+ Extra2 := 0;
+ Extra2_Filled := False;
else
Bad_Value (Str);
end if;
- -- Check if the first number encountered is a base
+ -- Check if the first number encountered is a base. ':' is allowed in
+ -- place of '#' in virtue of RM J.2 (3).
pragma Assert (Index >= Str'First);
@@ -611,7 +561,13 @@ package body System.Value_R is
then
Base_Char := Str (Index);
- if N = 1 and then Value (1) in 2 .. 16 then
+ -- Functionally, "(Parts = 1 or else N = 1)" in the condition of the
+ -- following if statement could replaced by the simpler "N = 1". The
+ -- reason we use a more complicated expression is to accommodate
+ -- machine-code-based coverage tools: the simple version makes it
+ -- impossible to fully cover generic instances of System.Value_R with
+ -- Parts = 1.
+ if (Parts = 1 or else N = 1) and then Value (1) in 2 .. 16 then
Base := Unsigned (Value (1));
else
Base_Violation := True;
@@ -630,16 +586,16 @@ package body System.Value_R is
end if;
end if;
- -- Scan the integral part if still necessary
+ -- Scan the integral part if there was a base and no point right after
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
+ if As_Digit (Str (Index)) not in Valid_Digit then
Bad_Value (Str);
end if;
Scan_Integral_Digits
(Str, Index, Max, Base, Base_Char /= ASCII.NUL, Value, Scale,
- N, Char_As_Digit (Extra), Base_Violation);
+ N, Extra2, Extra2_Filled, Base_Violation);
end if;
-- Do we have a dot?
@@ -664,9 +620,22 @@ package body System.Value_R is
if After_Point then
pragma Assert (Index <= Max);
- Scan_Decimal_Digits
- (Str, Index, Max, Base, Base_Char /= ASCII.NUL, Value, Scale,
- N, Char_As_Digit (Extra), Base_Violation);
+ -- If Extra2 has been filled, we are done with it
+
+ if Extra2_Filled then
+ declare
+ Dummy : Unsigned := 0;
+ begin
+ Scan_Decimal_Digits
+ (Str, Index, Max, Base, Base_Char /= ASCII.NUL, Value, Scale,
+ N, Dummy, Base_Violation);
+ end;
+
+ else
+ Scan_Decimal_Digits
+ (Str, Index, Max, Base, Base_Char /= ASCII.NUL, Value, Scale,
+ N, Extra2, Base_Violation);
+ end if;
end if;
-- If an explicit base was specified ensure that the delimiter is found
@@ -714,11 +683,11 @@ package body System.Value_R is
--------------------
function Value_Raw_Real
- (Str : String;
- Base : out Unsigned;
- Scale : out Scale_Array;
- Extra : out Unsigned;
- Minus : out Boolean) return Value_Array
+ (Str : String;
+ Base : out Unsigned;
+ Scale : out Scale_Array;
+ Extra2 : out Unsigned;
+ Minus : out Boolean) return Value_Array
is
P : aliased Integer;
V : Value_Array;
@@ -732,14 +701,14 @@ package body System.Value_R is
declare
subtype NT is String (1 .. Str'Length);
begin
- return Value_Raw_Real (NT (Str), Base, Scale, Extra, Minus);
+ return Value_Raw_Real (NT (Str), Base, Scale, Extra2, Minus);
end;
end if;
-- Normal case
P := Str'First;
- V := Scan_Raw_Real (Str, P'Access, Str'Last, Base, Scale, Extra, Minus);
+ V := Scan_Raw_Real (Str, P'Access, Str'Last, Base, Scale, Extra2, Minus);
Scan_Trailing_Blanks (Str, P);
return V;
diff --git a/gcc/ada/libgnat/s-valuer.ads b/gcc/ada/libgnat/s-valuer.ads
index 9f27998..e48241e 100644
--- a/gcc/ada/libgnat/s-valuer.ads
+++ b/gcc/ada/libgnat/s-valuer.ads
@@ -45,9 +45,6 @@ generic
Precision_Limit : Uns;
-- Precision limit for each part of the value
- Round : Boolean;
- -- If Parts = 1, True if the extra digit must be rounded
-
package System.Value_R is
pragma Preelaborate;
@@ -61,13 +58,13 @@ package System.Value_R is
-- The value split into parts
function Scan_Raw_Real
- (Str : String;
- Ptr : not null access Integer;
- Max : Integer;
- Base : out Unsigned;
- Scale : out Scale_Array;
- Extra : out Unsigned;
- Minus : out Boolean) return Value_Array;
+ (Str : String;
+ Ptr : not null access Integer;
+ Max : Integer;
+ Base : out Unsigned;
+ Scale : out Scale_Array;
+ Extra2 : out Unsigned;
+ Minus : out Boolean) return Value_Array;
-- 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
@@ -75,17 +72,18 @@ package System.Value_R is
--
-- 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
+ -- spaces are not scanned out) and the Base, Scale, Extra2 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 (1) * Base + Extra) * (Base ** (Scale (1) - 1))
+ -- (Val (1) * Base ** 2 + Extra2) * (Base ** (Scale (1) - 2))
--
-- when Parts = 1 and
--
-- Sum [Val (N) * (Base ** Scale (N)), N in 1 .. Parts]
--
- -- when Parts > 1, with the negative sign if Minus is true.
+ -- when Parts > 1, with the negative sign if Minus is true. Note that
+ -- Val (1) cannot be zero unless Val is entirely filled with zero.
--
-- 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
@@ -108,11 +106,11 @@ package System.Value_R is
-- case is not supported. Most such cases are eliminated by the caller.
function Value_Raw_Real
- (Str : String;
- Base : out Unsigned;
- Scale : out Scale_Array;
- Extra : out Unsigned;
- Minus : out Boolean) return Value_Array;
+ (Str : String;
+ Base : out Unsigned;
+ Scale : out Scale_Array;
+ Extra2 : out Unsigned;
+ Minus : out Boolean) return Value_Array;
-- 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.
diff --git a/gcc/ada/libgnat/s-valueu.adb b/gcc/ada/libgnat/s-valueu.adb
index e6f1d5e..a27e00f 100644
--- a/gcc/ada/libgnat/s-valueu.adb
+++ b/gcc/ada/libgnat/s-valueu.adb
@@ -29,78 +29,10 @@
-- --
------------------------------------------------------------------------------
-with System.SPARK.Cut_Operations; use System.SPARK.Cut_Operations;
with System.Val_Util; use System.Val_Util;
package body System.Value_U is
- -- Ghost code, loop invariants and assertions in this unit are meant for
- -- analysis only, not for run-time checking, as it would be too costly
- -- otherwise. This is enforced by setting the assertion policy to Ignore.
-
- pragma Assertion_Policy (Ghost => Ignore,
- Loop_Invariant => Ignore,
- Assert => Ignore,
- Assert_And_Cut => Ignore,
- Subprogram_Variant => Ignore);
-
- use type Spec.Uns_Option;
- use type Spec.Split_Value_Ghost;
-
- -- Local lemmas
-
- procedure Lemma_Digit_Not_Last
- (Str : String;
- P : Integer;
- From : Integer;
- To : Integer)
- with Ghost,
- Pre => Str'Last /= Positive'Last
- and then From in Str'Range
- and then To in From .. Str'Last
- and then Str (From) in '0' .. '9' | 'a' .. 'f' | 'A' .. 'F'
- and then P in From .. To
- and then P <= Spec.Last_Hexa_Ghost (Str (From .. To)) + 1
- and then Spec.Is_Based_Format_Ghost (Str (From .. To)),
- Post =>
- (if Str (P) in '0' .. '9' | 'a' .. 'f' | 'A' .. 'F'
- then P <= Spec.Last_Hexa_Ghost (Str (From .. To)));
-
- procedure Lemma_Underscore_Not_Last
- (Str : String;
- P : Integer;
- From : Integer;
- To : Integer)
- with Ghost,
- Pre => Str'Last /= Positive'Last
- and then From in Str'Range
- and then To in From .. Str'Last
- and then Str (From) in '0' .. '9' | 'a' .. 'f' | 'A' .. 'F'
- and then P in From .. To
- and then Str (P) = '_'
- and then P <= Spec.Last_Hexa_Ghost (Str (From .. To)) + 1
- and then Spec.Is_Based_Format_Ghost (Str (From .. To)),
- Post => P + 1 <= Spec.Last_Hexa_Ghost (Str (From .. To))
- and then Str (P + 1) in '0' .. '9' | 'a' .. 'f' | 'A' .. 'F';
-
- -----------------------------
- -- Local lemma null bodies --
- -----------------------------
-
- procedure Lemma_Digit_Not_Last
- (Str : String;
- P : Integer;
- From : Integer;
- To : Integer)
- is null;
-
- procedure Lemma_Underscore_Not_Last
- (Str : String;
- P : Integer;
- From : Integer;
- To : Integer)
- is null;
-
-----------------------
-- Scan_Raw_Unsigned --
-----------------------
@@ -132,36 +64,6 @@ package body System.Value_U is
Digit : Uns;
-- Digit value
- Ptr_Old : constant Integer := Ptr.all
- with Ghost;
- Last_Num_Init : constant Integer :=
- Last_Number_Ghost (Str (Ptr.all .. Max))
- with Ghost;
- Init_Val : constant Spec.Uns_Option :=
- Spec.Scan_Based_Number_Ghost (Str, Ptr.all, Last_Num_Init)
- with Ghost;
- Starts_As_Based : constant Boolean :=
- Spec.Raw_Unsigned_Starts_As_Based_Ghost (Str, Last_Num_Init, Max)
- with Ghost;
- Last_Num_Based : constant Integer :=
- (if Starts_As_Based
- then Spec.Last_Hexa_Ghost (Str (Last_Num_Init + 2 .. Max))
- else Last_Num_Init)
- with Ghost;
- Is_Based : constant Boolean :=
- Spec.Raw_Unsigned_Is_Based_Ghost
- (Str, Last_Num_Init, Last_Num_Based, Max)
- with Ghost;
- Based_Val : constant Spec.Uns_Option :=
- (if Starts_As_Based and then not Init_Val.Overflow
- then Spec.Scan_Based_Number_Ghost
- (Str, Last_Num_Init + 2, Last_Num_Based, Init_Val.Value)
- else Init_Val)
- with Ghost;
- First_Exp : constant Integer :=
- (if Is_Based then Last_Num_Based + 2 else Last_Num_Init + 1)
- with Ghost;
-
begin
-- We do not tolerate strings with Str'Last = Positive'Last
@@ -171,7 +73,15 @@ package body System.Value_U is
end if;
P := Ptr.all;
- Spec.Lemma_Scan_Based_Number_Ghost_Step (Str, P, Last_Num_Init);
+
+ -- Exit when the initial string to parse is empty
+
+ if Max < P then
+ raise Program_Error with
+ "Scan end Max=" & Max'Img &
+ " is smaller than scan end Ptr=" & P'Img;
+ end if;
+
Uval := Character'Pos (Str (P)) - Character'Pos ('0');
pragma Assert (Str (P) in '0' .. '9');
P := P + 1;
@@ -189,14 +99,6 @@ package body System.Value_U is
begin
-- Loop through decimal digits
loop
- pragma Loop_Invariant (P in P'Loop_Entry .. Last_Num_Init + 1);
- pragma Loop_Invariant
- (if Overflow then Init_Val.Overflow);
- pragma Loop_Invariant
- (if not Overflow
- then Init_Val = Spec.Scan_Based_Number_Ghost
- (Str, P, Last_Num_Init, Acc => Uval));
-
exit when P > Max;
Digit := Character'Pos (Str (P)) - Character'Pos ('0');
@@ -205,8 +107,6 @@ package body System.Value_U is
if Digit > 9 then
if Str (P) = '_' then
- Spec.Lemma_Scan_Based_Number_Ghost_Underscore
- (Str, P, Last_Num_Init, Acc => Uval);
Scan_Underscore (Str, P, Ptr, Max, False);
else
exit;
@@ -215,55 +115,23 @@ package body System.Value_U is
-- Accumulate result, checking for overflow
else
- pragma Assert
- (By
- (Str (P) in '0' .. '9',
- By
- (Character'Pos (Str (P)) >= Character'Pos ('0'),
- Uns '(Character'Pos (Str (P))) >=
- Character'Pos ('0'))));
- Spec.Lemma_Scan_Based_Number_Ghost_Step
- (Str, P, Last_Num_Init, Acc => Uval);
- Spec.Lemma_Scan_Based_Number_Ghost_Overflow
- (Str, P, Last_Num_Init, Acc => Uval);
-
if Uval <= Umax then
Uval := 10 * Uval + Digit;
- pragma Assert
- (if not Overflow
- then Init_Val = Spec.Scan_Based_Number_Ghost
- (Str, P + 1, Last_Num_Init, Acc => Uval));
-
elsif Uval > Umax10 then
Overflow := True;
-
else
Uval := 10 * Uval + Digit;
if Uval < Umax10 then
Overflow := True;
end if;
- pragma Assert
- (if not Overflow
- then Init_Val = Spec.Scan_Based_Number_Ghost
- (Str, P + 1, Last_Num_Init, Acc => Uval));
-
end if;
P := P + 1;
end if;
end loop;
- Spec.Lemma_Scan_Based_Number_Ghost_Base
- (Str, P, Last_Num_Init, Acc => Uval);
end;
- pragma Assert_And_Cut
- (By
- (P = Last_Num_Init + 1,
- P > Max or else Str (P) not in '_' | '0' .. '9')
- and then Overflow = Init_Val.Overflow
- and then (if not Overflow then Init_Val.Value = Uval));
-
Ptr.all := P;
-- Deal with based case. We recognize either the standard '#' or the
@@ -295,10 +163,6 @@ package body System.Value_U is
-- Numbers bigger than UmaxB overflow if multiplied by base
begin
- pragma Assert
- (if Str (P) in '0' .. '9' | 'A' .. 'F' | 'a' .. 'f'
- then Spec.Is_Based_Format_Ghost (Str (P .. Max)));
-
-- Loop to scan out based integer value
loop
@@ -321,49 +185,11 @@ package body System.Value_U is
-- already stored in Ptr.all.
else
- pragma Assert
- (By
- (Spec.Only_Hexa_Ghost (Str, P, Last_Num_Based),
- P > Last_Num_Init + 1
- and Spec.Only_Hexa_Ghost
- (Str, Last_Num_Init + 2, Last_Num_Based)));
- Spec.Lemma_Scan_Based_Number_Ghost_Base
- (Str, P, Last_Num_Based, Base, Uval);
Uval := Base;
Base := 10;
- pragma Assert (Ptr.all = Last_Num_Init + 1);
- pragma Assert
- (if Starts_As_Based
- then By
- (P = Last_Num_Based + 1,
- P <= Last_Num_Based + 1
- and Str (P) not in
- '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' | '_'));
- pragma Assert (not Is_Based);
- pragma Assert (if not Overflow then Uval = Init_Val.Value);
exit;
end if;
- pragma Loop_Invariant (P in P'Loop_Entry .. Last_Num_Based);
- pragma Loop_Invariant
- (Str (P) in '0' .. '9' | 'a' .. 'f' | 'A' .. 'F'
- and then Digit = Spec.Hexa_To_Unsigned_Ghost (Str (P)));
- pragma Loop_Invariant
- (if Overflow'Loop_Entry then Overflow);
- pragma Loop_Invariant
- (if Overflow then
- (Overflow'Loop_Entry or else Based_Val.Overflow));
- pragma Loop_Invariant
- (if not Overflow
- then Based_Val = Spec.Scan_Based_Number_Ghost
- (Str, P, Last_Num_Based, Base, Uval));
- pragma Loop_Invariant (Ptr.all = Last_Num_Init + 1);
-
- Spec.Lemma_Scan_Based_Number_Ghost_Step
- (Str, P, Last_Num_Based, Base, Uval);
- Spec.Lemma_Scan_Based_Number_Ghost_Overflow
- (Str, P, Last_Num_Based, Base, Uval);
-
-- If digit is too large, just signal overflow and continue.
-- The idea here is to keep scanning as long as the input is
-- syntactically valid, even if we have detected overflow
@@ -375,24 +201,14 @@ package body System.Value_U is
elsif Uval <= Umax then
Uval := Base * Uval + Digit;
- pragma Assert
- (if not Overflow
- then Based_Val = Spec.Scan_Based_Number_Ghost
- (Str, P + 1, Last_Num_Based, Base, Uval));
-
elsif Uval > UmaxB then
Overflow := True;
-
else
Uval := Base * Uval + Digit;
if Uval < UmaxB then
Overflow := True;
end if;
- pragma Assert
- (if not Overflow
- then Based_Val = Spec.Scan_Based_Number_Ghost
- (Str, P + 1, Last_Num_Based, Base, Uval));
end if;
-- If at end of string with no base char, not a based number
@@ -411,86 +227,22 @@ package body System.Value_U is
if Str (P) = Base_Char then
Ptr.all := P + 1;
- pragma Assert (P = Last_Num_Based + 1);
- pragma Assert (Ptr.all = Last_Num_Based + 2);
- pragma Assert
- (By
- (Is_Based,
- So
- (Starts_As_Based,
- So
- (Last_Num_Based < Max,
- Str (Last_Num_Based + 1) = Base_Char
- and Base_Char = Str (Last_Num_Init + 1)))));
- Spec.Lemma_Scan_Based_Number_Ghost_Base
- (Str, P, Last_Num_Based, Base, Uval);
exit;
-- Deal with underscore
elsif Str (P) = '_' then
- Lemma_Underscore_Not_Last (Str, P, Last_Num_Init + 2, Max);
- Spec.Lemma_Scan_Based_Number_Ghost_Underscore
- (Str, P, Last_Num_Based, Base, Uval);
Scan_Underscore (Str, P, Ptr, Max, True);
- pragma Assert
- (if not Overflow
- then Based_Val = Spec.Scan_Based_Number_Ghost
- (Str, P, Last_Num_Based, Base, Uval));
- pragma Assert (Str (P) not in '_' | Base_Char);
end if;
-
- Lemma_Digit_Not_Last (Str, P, Last_Num_Init + 2, Max);
- pragma Assert (Str (P) not in '_' | Base_Char);
end loop;
end;
- pragma Assert
- (if Starts_As_Based then P = Last_Num_Based + 1
- else P = Last_Num_Init + 2);
- pragma Assert
- (By
- (Overflow /= Spec.Scan_Split_No_Overflow_Ghost
- (Str, Ptr_Old, Max),
- So
- (Last_Num_Init < Max - 1
- and then Str (Last_Num_Init + 1) in '#' | ':',
- Overflow =
- (Init_Val.Overflow
- or else Init_Val.Value not in 2 .. 16
- or else (Starts_As_Based and Based_Val.Overflow)))));
end if;
- pragma Assert_And_Cut
- (Overflow /= Spec.Scan_Split_No_Overflow_Ghost (Str, Ptr_Old, Max)
- and then Ptr.all = First_Exp
- and then Base in 2 .. 16
- and then
- (if not Overflow then
- (if Is_Based then Base = Init_Val.Value else Base = 10))
- and then
- (if not Overflow then
- (if Is_Based then Uval = Based_Val.Value
- else Uval = Init_Val.Value)));
-
-- Come here with scanned unsigned value in Uval. The only remaining
-- required step is to deal with exponent if one is present.
Scan_Exponent (Str, Ptr, Max, Expon);
- pragma Assert
- (By
- (Ptr.all = Spec.Raw_Unsigned_Last_Ghost (Str, Ptr_Old, Max),
- Ptr.all =
- (if not Starts_As_Exponent_Format_Ghost (Str (First_Exp .. Max))
- then First_Exp
- elsif Str (First_Exp + 1) in '-' | '+' then
- Last_Number_Ghost (Str (First_Exp + 2 .. Max)) + 1
- else Last_Number_Ghost (Str (First_Exp + 1 .. Max)) + 1)));
- pragma Assert
- (if not Overflow
- then Spec.Scan_Split_Value_Ghost (Str, Ptr_Old, Max) =
- (Uval, Base, Expon));
-
if Expon /= 0 and then Uval /= 0 then
-- For non-zero value, scale by exponent value. No need to do this
@@ -500,66 +252,22 @@ package body System.Value_U is
declare
UmaxB : constant Uns := Uns'Last / Base;
-- Numbers bigger than UmaxB overflow if multiplied by base
-
- Res_Val : constant Spec.Uns_Option :=
- Spec.Exponent_Unsigned_Ghost (Uval, Expon, Base)
- with Ghost;
begin
for J in 1 .. Expon loop
- pragma Loop_Invariant
- (if Overflow'Loop_Entry then Overflow);
- pragma Loop_Invariant
- (if Overflow
- then Overflow'Loop_Entry or else Res_Val.Overflow);
- pragma Loop_Invariant (Uval /= 0);
- pragma Loop_Invariant
- (if not Overflow
- then Res_Val = Spec.Exponent_Unsigned_Ghost
- (Uval, Expon - J + 1, Base));
-
- pragma Assert
- ((Uval > UmaxB) = Spec.Scan_Overflows_Ghost (0, Base, Uval));
-
if Uval > UmaxB then
- Spec.Lemma_Exponent_Unsigned_Ghost_Overflow
- (Uval, Expon - J + 1, Base);
Overflow := True;
exit;
end if;
- Spec.Lemma_Exponent_Unsigned_Ghost_Step
- (Uval, Expon - J + 1, Base);
-
Uval := Uval * Base;
end loop;
- Spec.Lemma_Exponent_Unsigned_Ghost_Base (Uval, 0, Base);
-
- pragma Assert
- (Overflow /=
- Spec.Raw_Unsigned_No_Overflow_Ghost (Str, Ptr_Old, Max));
- pragma Assert (if not Overflow then Res_Val = (False, Uval));
end;
end if;
- Spec.Lemma_Exponent_Unsigned_Ghost_Base (Uval, Expon, Base);
- pragma Assert
- (if Expon = 0 or else Uval = 0 then
- Spec.Exponent_Unsigned_Ghost (Uval, Expon, Base) = (False, Uval));
- pragma Assert
- (Overflow /=
- Spec.Raw_Unsigned_No_Overflow_Ghost (Str, Ptr_Old, Max));
- pragma Assert
- (if not Overflow then
- Uval = Spec.Scan_Raw_Unsigned_Ghost (Str, Ptr_Old, Max));
-- Return result, dealing with overflow
if Overflow then
Bad_Value (Str);
- pragma Annotate
- (GNATprove, Intentional,
- "call to nonreturning subprogram might be executed",
- "it is expected that Constraint_Error is raised in case of"
- & " overflow");
else
Res := Uval;
end if;
@@ -608,15 +316,7 @@ package body System.Value_U is
if Str'Last = Positive'Last then
declare
subtype NT is String (1 .. Str'Length);
- procedure Prove_Is_Unsigned_Ghost with
- Ghost,
- Pre => Str'Length < Natural'Last
- and then not Only_Space_Ghost (Str, Str'First, Str'Last)
- and then Spec.Is_Unsigned_Ghost (Spec.Slide_To_1 (Str)),
- Post => Spec.Is_Unsigned_Ghost (NT (Str));
- procedure Prove_Is_Unsigned_Ghost is null;
begin
- Prove_Is_Unsigned_Ghost;
return Value_Unsigned (NT (Str));
end;
@@ -626,12 +326,6 @@ package body System.Value_U is
declare
V : Uns;
P : aliased Integer := Str'First;
- Non_Blank : constant Positive := First_Non_Space_Ghost
- (Str, Str'First, Str'Last)
- with Ghost;
- Fst_Num : constant Positive :=
- (if Str (Non_Blank) = '+' then Non_Blank + 1 else Non_Blank)
- with Ghost;
begin
declare
P_Acc : constant not null access Integer := P'Access;
@@ -639,16 +333,7 @@ package body System.Value_U is
Scan_Unsigned (Str, P_Acc, Str'Last, V);
end;
- pragma Assert
- (P = Spec.Raw_Unsigned_Last_Ghost (Str, Fst_Num, Str'Last));
- pragma Assert
- (V = Spec.Scan_Raw_Unsigned_Ghost (Str, Fst_Num, Str'Last));
-
Scan_Trailing_Blanks (Str, P);
-
- pragma Assert
- (Spec.Is_Value_Unsigned_Ghost
- (Spec.Slide_If_Necessary (Str), V));
return V;
end;
end if;
diff --git a/gcc/ada/libgnat/s-valueu.ads b/gcc/ada/libgnat/s-valueu.ads
index 92e3ffe..488c342 100644
--- a/gcc/ada/libgnat/s-valueu.ads
+++ b/gcc/ada/libgnat/s-valueu.ads
@@ -32,29 +32,8 @@
-- This package contains routines for scanning modular Unsigned
-- values for use in Text_IO.Modular_IO, and the Value attribute.
--- 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. Postconditions and
--- contract cases should not be executed at runtime as well, in order not to
--- slow down the execution of these functions.
-
-pragma Assertion_Policy (Pre => Ignore,
- Post => Ignore,
- Contract_Cases => Ignore,
- Ghost => Ignore,
- Subprogram_Variant => Ignore);
-
-with System.Value_U_Spec;
-with System.Val_Spec; use System.Val_Spec;
-
generic
-
type Uns is mod <>;
-
- -- Additional parameters for ghost subprograms used inside contracts
-
- with package Spec is new System.Value_U_Spec (Uns => Uns) with Ghost;
-
package System.Value_U is
pragma Preelaborate;
@@ -62,15 +41,7 @@ package System.Value_U is
(Str : String;
Ptr : not null access Integer;
Max : Integer;
- Res : out Uns)
- with Pre => Str'Last /= Positive'Last
- and then Ptr.all in Str'Range
- and then Max in Ptr.all .. Str'Last
- and then Spec.Is_Raw_Unsigned_Format_Ghost (Str (Ptr.all .. Max)),
- Post => Spec.Raw_Unsigned_No_Overflow_Ghost (Str, Ptr.all'Old, Max)
- and Res = Spec.Scan_Raw_Unsigned_Ghost (Str, Ptr.all'Old, Max)
- and Ptr.all = Spec.Raw_Unsigned_Last_Ghost (Str, Ptr.all'Old, Max);
-
+ Res : out Uns);
-- This function scans the string starting at Str (Ptr.all) for a valid
-- integer according to the syntax described in (RM 3.5(43)). The substring
-- scanned extends no further than Str (Max). Note: this does not scan
@@ -131,11 +102,9 @@ package System.Value_U is
-- This string results in a Constraint_Error with the pointer pointing
-- past the second 2.
--
- -- Note: if Str is empty, 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.
- -- ??? This is not the case. We will read Str (Ptr.all) without checking
- -- and increase Ptr.all by one.
+ -- Note: If Max is less than Ptr, then Ptr is left unchanged and
+ -- Program_Error is raised to indicate that a valid integer cannot
+ -- be parsed.
--
-- 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
@@ -145,45 +114,14 @@ package System.Value_U is
(Str : String;
Ptr : not null access Integer;
Max : Integer;
- Res : out Uns)
- with Pre => Str'Last /= Positive'Last
- and then Ptr.all in Str'Range
- and then Max in Ptr.all .. Str'Last
- and then not Only_Space_Ghost (Str, Ptr.all, Max)
- and then
- (declare
- Non_Blank : constant Positive :=
- First_Non_Space_Ghost (Str, Ptr.all, Max);
- Fst_Num : constant Positive :=
- (if Str (Non_Blank) = '+' then Non_Blank + 1 else Non_Blank);
- begin
- Spec.Is_Raw_Unsigned_Format_Ghost (Str (Fst_Num .. Max))),
- Post =>
- (declare
- Non_Blank : constant Positive :=
- First_Non_Space_Ghost (Str, Ptr.all'Old, Max);
- Fst_Num : constant Positive :=
- (if Str (Non_Blank) = '+' then Non_Blank + 1 else Non_Blank);
- begin
- Spec.Raw_Unsigned_No_Overflow_Ghost (Str, Fst_Num, Max)
- and then Res = Spec.Scan_Raw_Unsigned_Ghost (Str, Fst_Num, Max)
- and then Ptr.all = Spec.Raw_Unsigned_Last_Ghost (Str, Fst_Num, Max));
-
+ Res : out Uns);
-- Same as Scan_Raw_Unsigned, except scans optional leading
-- blanks, and an optional leading plus sign.
--
-- Note: if a minus sign is present, Constraint_Error will be raised.
-- Note: trailing blanks are not scanned.
- function Value_Unsigned
- (Str : String) return Uns
- with Pre => Str'Length /= Positive'Last
- and then not Only_Space_Ghost (Str, Str'First, Str'Last)
- and then Spec.Is_Unsigned_Ghost (Spec.Slide_If_Necessary (Str)),
- Post =>
- Spec.Is_Value_Unsigned_Ghost
- (Spec.Slide_If_Necessary (Str), Value_Unsigned'Result),
- Subprogram_Variant => (Decreases => Str'First);
+ function Value_Unsigned (Str : String) return Uns;
-- Used in computing X'Value (Str) where X is a modular integer type whose
-- modulus does not exceed the range of System.Unsigned_Types.Unsigned. Str
-- is the string argument of the attribute. Constraint_Error is raised if
diff --git a/gcc/ada/libgnat/s-valuns.ads b/gcc/ada/libgnat/s-valuns.ads
index 8bbb7fb..a015c12 100644
--- a/gcc/ada/libgnat/s-valuns.ads
+++ b/gcc/ada/libgnat/s-valuns.ads
@@ -32,28 +32,15 @@
-- This package contains routines for scanning modular Unsigned
-- values for use in Text_IO.Modular_IO, and the Value attribute.
--- 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. Postconditions and
--- contract cases should not be executed at runtime as well, in order not to
--- slow down the execution of these functions.
-
-pragma Assertion_Policy (Pre => Ignore,
- Post => Ignore,
- Contract_Cases => Ignore,
- Ghost => Ignore,
- Subprogram_Variant => Ignore);
-
with System.Unsigned_Types;
with System.Value_U;
-with System.Vs_Uns;
package System.Val_Uns with SPARK_Mode is
pragma Preelaborate;
subtype Unsigned is Unsigned_Types.Unsigned;
- package Impl is new Value_U (Unsigned, System.Vs_Uns.Spec);
+ package Impl is new Value_U (Unsigned);
procedure Scan_Raw_Unsigned
(Str : String;
diff --git a/gcc/ada/libgnat/s-valuti.adb b/gcc/ada/libgnat/s-valuti.adb
index a2b79f1..a97ab00 100644
--- a/gcc/ada/libgnat/s-valuti.adb
+++ b/gcc/ada/libgnat/s-valuti.adb
@@ -29,15 +29,7 @@
-- --
------------------------------------------------------------------------------
--- Ghost code, loop invariants and assertions in this unit are meant for
--- analysis only, not for run-time checking, as it would be too costly
--- otherwise. This is enforced by setting the assertion policy to Ignore.
-
-pragma Assertion_Policy (Ghost => Ignore,
- Loop_Invariant => Ignore,
- Assert => Ignore);
-
-with System.Case_Util; use System.Case_Util;
+with System.Case_Util_NSS; use System.Case_Util_NSS;
package body System.Val_Util
with SPARK_Mode
@@ -48,12 +40,11 @@ is
---------------
procedure Bad_Value (S : String) is
- pragma Annotate (GNATprove, Intentional, "exception might be raised",
- "Intentional exception from Bad_Value");
begin
-- Bad_Value might be called with very long strings allocated on the
-- heap. Limit the size of the message so that we avoid creating a
-- Storage_Error during error handling.
+
if S'Length > 127 then
raise Constraint_Error with "bad input for 'Value: """
& S (S'First .. S'First + 127) & "...""";
@@ -69,8 +60,7 @@ is
procedure Normalize_String
(S : in out String;
F, L : out Integer;
- To_Upper_Case : Boolean)
- is
+ To_Upper_Case : Boolean) is
begin
F := S'First;
L := S'Last;
@@ -84,9 +74,6 @@ is
-- Scan for leading spaces
while F < L and then S (F) = ' ' loop
- pragma Loop_Invariant (F in S'First .. L - 1);
- pragma Loop_Invariant (for all J in S'First .. F => S (J) = ' ');
- pragma Loop_Variant (Increases => F);
F := F + 1;
end loop;
@@ -101,9 +88,6 @@ is
-- Scan for trailing spaces
while S (L) = ' ' loop
- pragma Loop_Invariant (L in F + 1 .. S'Last);
- pragma Loop_Invariant (for all J in L .. S'Last => S (J) = ' ');
- pragma Loop_Variant (Decreases => L);
L := L - 1;
end loop;
@@ -112,8 +96,6 @@ is
if To_Upper_Case and then S (F) /= ''' then
for J in F .. L loop
S (J) := To_Upper (S (J));
- pragma Loop_Invariant
- (for all K in F .. J => S (K) = To_Upper (S'Loop_Entry (K)));
end loop;
end if;
end Normalize_String;
@@ -185,40 +167,23 @@ is
X := 0;
- declare
- Rest : constant String := Str (P .. Max) with Ghost;
- Last : constant Natural := Sp.Last_Number_Ghost (Rest) with Ghost;
-
- begin
- pragma Assert (Sp.Is_Natural_Format_Ghost (Rest));
-
- loop
- pragma Assert (Str (P) in '0' .. '9');
+ loop
+ pragma Assert (Str (P) in '0' .. '9');
- if X < (Integer'Last / 10) then
- X := X * 10 + (Character'Pos (Str (P)) - Character'Pos ('0'));
- end if;
-
- pragma Loop_Invariant (X >= 0);
- pragma Loop_Invariant (P in Rest'First .. Last);
- pragma Loop_Invariant (Str (P) in '0' .. '9');
- pragma Loop_Invariant
- (Sp.Scan_Natural_Ghost (Rest, Rest'First, 0)
- = Sp.Scan_Natural_Ghost (Rest, P + 1, X));
-
- P := P + 1;
+ if X < (Integer'Last / 10) then
+ X := X * 10 + (Character'Pos (Str (P)) - Character'Pos ('0'));
+ end if;
- exit when P > Max;
+ P := P + 1;
- if Str (P) = '_' then
- Scan_Underscore (Str, P, Ptr, Max, False);
- else
- exit when Str (P) not in '0' .. '9';
- end if;
- end loop;
+ exit when P > Max;
- pragma Assert (P = Last + 1);
- end;
+ if Str (P) = '_' then
+ Scan_Underscore (Str, P, Ptr, Max, False);
+ else
+ exit when Str (P) not in '0' .. '9';
+ end if;
+ end loop;
if M then
X := -X;
@@ -250,12 +215,6 @@ is
while Str (P) = ' ' loop
P := P + 1;
- pragma Loop_Invariant (Ptr.all = Ptr.all'Loop_Entry);
- pragma Loop_Invariant (P in Ptr.all .. Max);
- pragma Loop_Invariant (for some J in P .. Max => Str (J) /= ' ');
- pragma Loop_Invariant
- (for all J in Ptr.all .. P - 1 => Str (J) = ' ');
-
if P > Max then
Ptr.all := P;
Bad_Value (Str);
@@ -264,8 +223,6 @@ is
Start := P;
- pragma Assert (Start = Sp.First_Non_Space_Ghost (Str, Ptr.all, Max));
-
-- Skip past an initial plus sign
if Str (P) = '+' then
@@ -292,7 +249,6 @@ is
Start : out Positive)
is
P : Integer := Ptr.all;
-
begin
-- Deal with case of null string (all blanks). As per spec, we raise
-- constraint error, with Ptr unchanged, and thus > Max.
@@ -306,12 +262,6 @@ is
while Str (P) = ' ' loop
P := P + 1;
- pragma Loop_Invariant (Ptr.all = Ptr.all'Loop_Entry);
- pragma Loop_Invariant (P in Ptr.all .. Max);
- pragma Loop_Invariant (for some J in P .. Max => Str (J) /= ' ');
- pragma Loop_Invariant
- (for all J in Ptr.all .. P - 1 => Str (J) = ' ');
-
if P > Max then
Ptr.all := P;
Bad_Value (Str);
@@ -320,8 +270,6 @@ is
Start := P;
- pragma Assert (Start = Sp.First_Non_Space_Ghost (Str, Ptr.all, Max));
-
-- Remember an initial minus sign
if Str (P) = '-' then
@@ -361,8 +309,6 @@ is
if Str (J) /= ' ' then
Bad_Value (Str);
end if;
-
- pragma Loop_Invariant (for all K in P .. J => Str (K) = ' ');
end loop;
end Scan_Trailing_Blanks;
@@ -378,7 +324,6 @@ is
Ext : Boolean)
is
C : Character;
-
begin
P := P + 1;
diff --git a/gcc/ada/libgnat/s-valuti.ads b/gcc/ada/libgnat/s-valuti.ads
index 8720c41..4a299ca 100644
--- a/gcc/ada/libgnat/s-valuti.ads
+++ b/gcc/ada/libgnat/s-valuti.ads
@@ -31,59 +31,16 @@
-- This package provides some common utilities used by the s-valxxx files
--- 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. Postconditions and
--- contract cases should not be executed at runtime as well, in order not to
--- slow down the execution of these functions.
-
-pragma Assertion_Policy (Pre => Ignore,
- Post => Ignore,
- Contract_Cases => Ignore,
- Ghost => Ignore);
-
-with System.Case_Util;
-with System.Val_Spec;
-
package System.Val_Util
with SPARK_Mode, Pure
is
- pragma Unevaluated_Use_Of_Old (Allow);
-
- package Sp renames System.Val_Spec;
-
- procedure Bad_Value (S : String)
- with
- Always_Terminates,
- Depends => (null => S),
- Exceptional_Cases => (others => Standard.False);
- pragma No_Return (Bad_Value);
+ procedure Bad_Value (S : String) with No_Return;
-- Raises constraint error with message: bad input for 'Value: "xxx"
procedure Normalize_String
(S : in out String;
F, L : out Integer;
- To_Upper_Case : Boolean)
- with
- Post => (if Sp.Only_Space_Ghost (S'Old, S'First, S'Last) then
- F > L
- else
- F >= S'First
- and then L <= S'Last
- and then F <= L
- and then Sp.Only_Space_Ghost (S'Old, S'First, F - 1)
- and then S'Old (F) /= ' '
- and then S'Old (L) /= ' '
- and then
- (if L < S'Last then
- Sp.Only_Space_Ghost (S'Old, L + 1, S'Last))
- and then
- (if To_Upper_Case and then S'Old (F) /= ''' then
- (for all J in S'Range =>
- (if J in F .. L then
- S (J) = System.Case_Util.To_Upper (S'Old (J))
- else
- S (J) = S'Old (J)))));
+ To_Upper_Case : Boolean);
-- This procedure scans the string S setting F to be the index of the first
-- non-blank character of S and L to be the index of the last non-blank
-- character of S. If To_Upper_Case is True and S does not represent a
@@ -96,27 +53,7 @@ is
Ptr : not null access Integer;
Max : Integer;
Minus : out Boolean;
- Start : out Positive)
- with
- Pre =>
- -- Ptr.all .. Max is either an empty range, or a valid range in Str
- (Ptr.all > Max or else (Ptr.all >= Str'First and then Max <= Str'Last))
- and then not Sp.Only_Space_Ghost (Str, Ptr.all, Max)
- and then
- (declare
- F : constant Positive :=
- Sp.First_Non_Space_Ghost (Str, Ptr.all, Max);
- begin
- (if Str (F) in '+' | '-' then
- F <= Max - 1 and then Str (F + 1) /= ' ')),
- Post =>
- (declare
- F : constant Positive :=
- Sp.First_Non_Space_Ghost (Str, Ptr.all'Old, Max);
- begin
- Minus = (Str (F) = '-')
- and then Ptr.all = (if Str (F) in '+' | '-' then F + 1 else F)
- and then Start = F);
+ Start : out Positive);
-- The Str, Ptr, Max parameters are as for the scan routines (Str is the
-- string to be scanned starting at Ptr.all, and Max is the index of the
-- last character in the string). Scan_Sign first scans out any initial
@@ -140,26 +77,7 @@ is
(Str : String;
Ptr : not null access Integer;
Max : Integer;
- Start : out Positive)
- with
- Pre =>
- -- Ptr.all .. Max is either an empty range, or a valid range in Str
- (Ptr.all > Max or else (Ptr.all >= Str'First and then Max <= Str'Last))
- and then not Sp.Only_Space_Ghost (Str, Ptr.all, Max)
- and then
- (declare
- F : constant Positive :=
- Sp.First_Non_Space_Ghost (Str, Ptr.all, Max);
- begin
- (if Str (F) = '+' then
- F <= Max - 1 and then Str (F + 1) /= ' ')),
- Post =>
- (declare
- F : constant Positive :=
- Sp.First_Non_Space_Ghost (Str, Ptr.all'Old, Max);
- begin
- Ptr.all = (if Str (F) = '+' then F + 1 else F)
- and then Start = F);
+ Start : out Positive);
-- Same as Scan_Sign, but allows only plus, not minus. This is used for
-- modular types.
@@ -168,22 +86,7 @@ is
Ptr : not null access Integer;
Max : Integer;
Exp : out Integer;
- Real : Boolean := False)
- with
- Pre =>
- -- Ptr.all .. Max is either an empty range, or a valid range in Str
- (Ptr.all > Max or else (Ptr.all >= Str'First and then Max <= Str'Last))
- and then Max < Natural'Last
- and then Sp.Is_Opt_Exponent_Format_Ghost (Str (Ptr.all .. Max), Real),
- Post =>
- (if Sp.Starts_As_Exponent_Format_Ghost (Str (Ptr.all'Old .. Max), Real)
- then Exp = Sp.Scan_Exponent_Ghost (Str (Ptr.all'Old .. Max), Real)
- and then
- (if Str (Ptr.all'Old + 1) in '-' | '+' then
- Ptr.all = Sp.Last_Number_Ghost (Str (Ptr.all'Old + 2 .. Max)) + 1
- else
- Ptr.all = Sp.Last_Number_Ghost (Str (Ptr.all'Old + 1 .. Max)) + 1)
- else Exp = 0 and Ptr.all = Ptr.all'Old);
+ Real : Boolean := False);
-- Called to scan a possible exponent. Str, Ptr, Max are as described above
-- for Scan_Sign. If Ptr.all < Max and Str (Ptr.all) = 'E' or 'e', then an
-- exponent is scanned out, with the exponent value returned in Exp, and
@@ -198,35 +101,16 @@ is
-- This routine must not be called with Str'Last = Positive'Last. There is
-- no check for this case, the caller must ensure this condition is met.
- procedure Scan_Trailing_Blanks (Str : String; P : Positive)
- with
- Pre => P >= Str'First
- and then Sp.Only_Space_Ghost (Str, P, Str'Last);
+ procedure Scan_Trailing_Blanks (Str : String; P : Positive);
-- Checks that the remainder of the field Str (P .. Str'Last) is all
-- blanks. Raises Constraint_Error if a non-blank character is found.
- pragma Warnings
- (GNATprove, Off, """Ptr"" is not modified",
- Reason => "Ptr is actually modified when raising an exception");
procedure Scan_Underscore
(Str : String;
P : in out Natural;
Ptr : not null access Integer;
Max : Integer;
- Ext : Boolean)
- with
- Pre => P in Str'Range
- and then Str (P) = '_'
- and then Max in Str'Range
- and then P < Max
- and then
- (if Ext then
- Str (P + 1) in '0' .. '9' | 'A' .. 'F' | 'a' .. 'f'
- else
- Str (P + 1) in '0' .. '9'),
- Post =>
- P = P'Old + 1
- and then Ptr.all'Old = Ptr.all;
+ Ext : Boolean);
-- Called if an underscore is encountered while scanning digits. Str (P)
-- contains the underscore. Ptr is the pointer to be returned to the
-- ultimate caller of the scan routine, Max is the maximum subscript in
@@ -237,6 +121,5 @@ is
--
-- This routine must not be called with Str'Last = Positive'Last. There is
-- no check for this case, the caller must ensure this condition is met.
- pragma Warnings (GNATprove, On, """Ptr"" is not modified");
end System.Val_Util;
diff --git a/gcc/ada/libgnat/s-vauspe.adb b/gcc/ada/libgnat/s-vauspe.adb
deleted file mode 100644
index a350a56..0000000
--- a/gcc/ada/libgnat/s-vauspe.adb
+++ /dev/null
@@ -1,203 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- S Y S T E M . V A L U E _ U _ S P E C --
--- --
--- B o d y --
--- --
--- Copyright (C) 2022-2025, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-pragma Assertion_Policy (Pre => Ignore,
- Post => Ignore,
- Contract_Cases => Ignore,
- Ghost => Ignore,
- Subprogram_Variant => Ignore);
-
-package body System.Value_U_Spec with SPARK_Mode is
-
- -----------------------------
- -- Exponent_Unsigned_Ghost --
- -----------------------------
-
- function Exponent_Unsigned_Ghost
- (Value : Uns;
- Exp : Natural;
- Base : Uns := 10) return Uns_Option
- is
- (if Exp = 0 or Value = 0 then (Overflow => False, Value => Value)
- elsif Scan_Overflows_Ghost (0, Base, Value) then (Overflow => True)
- else Exponent_Unsigned_Ghost (Value * Base, Exp - 1, Base));
-
- ---------------------
- -- Last_Hexa_Ghost --
- ---------------------
-
- function Last_Hexa_Ghost (Str : String) return Positive is
- begin
- pragma Annotate (Gnatcheck, Exempt_On, "Improper_Returns",
- "occurs in ghost code, not executable");
-
- for J in Str'Range loop
- if Str (J) not in '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' | '_' then
- return J - 1;
- end if;
-
- pragma Loop_Invariant
- (for all K in Str'First .. J =>
- Str (K) in '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' | '_');
- end loop;
-
- return Str'Last;
-
- pragma Annotate (Gnatcheck, Exempt_Off, "Improper_Returns");
- end Last_Hexa_Ghost;
-
- -----------------------------
- -- Lemmas with null bodies --
- -----------------------------
-
- procedure Lemma_Scan_Based_Number_Ghost_Base
- (Str : String;
- From, To : Integer;
- Base : Uns := 10;
- Acc : Uns := 0)
- is null;
-
- procedure Lemma_Scan_Based_Number_Ghost_Underscore
- (Str : String;
- From, To : Integer;
- Base : Uns := 10;
- Acc : Uns := 0)
- is null;
-
- procedure Lemma_Scan_Based_Number_Ghost_Overflow
- (Str : String;
- From, To : Integer;
- Base : Uns := 10;
- Acc : Uns := 0)
- is null;
-
- procedure Lemma_Scan_Based_Number_Ghost_Step
- (Str : String;
- From, To : Integer;
- Base : Uns := 10;
- Acc : Uns := 0)
- is null;
-
- procedure Lemma_Exponent_Unsigned_Ghost_Base
- (Value : Uns;
- Exp : Natural;
- Base : Uns := 10)
- is null;
-
- procedure Lemma_Exponent_Unsigned_Ghost_Overflow
- (Value : Uns;
- Exp : Natural;
- Base : Uns := 10)
- is null;
-
- procedure Lemma_Exponent_Unsigned_Ghost_Step
- (Value : Uns;
- Exp : Natural;
- Base : Uns := 10)
- is null;
-
- --------------------------------------
- -- Prove_Scan_Based_Number_Ghost_Eq --
- --------------------------------------
-
- procedure Prove_Scan_Based_Number_Ghost_Eq
- (Str1, Str2 : String;
- From, To : Integer;
- Base : Uns := 10;
- Acc : Uns := 0)
- is
- begin
- if From > To then
- null;
- elsif Str1 (From) = '_' then
- Prove_Scan_Based_Number_Ghost_Eq
- (Str1, Str2, From + 1, To, Base, Acc);
- elsif Scan_Overflows_Ghost
- (Hexa_To_Unsigned_Ghost (Str1 (From)), Base, Acc)
- then
- null;
- else
- Prove_Scan_Based_Number_Ghost_Eq
- (Str1, Str2, From + 1, To, Base,
- Base * Acc + Hexa_To_Unsigned_Ghost (Str1 (From)));
- end if;
- end Prove_Scan_Based_Number_Ghost_Eq;
-
- -----------------------------------
- -- Prove_Scan_Only_Decimal_Ghost --
- -----------------------------------
-
- procedure Prove_Scan_Only_Decimal_Ghost
- (Str : String;
- Val : Uns)
- is
- pragma Assert (Str (Str'First + 1) /= ' ');
- Non_Blank : constant Positive := First_Non_Space_Ghost
- (Str, Str'First, Str'Last);
- pragma Assert (Non_Blank = Str'First + 1);
- Fst_Num : constant Positive :=
- (if Str (Non_Blank) = '+' then Non_Blank + 1 else Non_Blank);
- pragma Assert (Fst_Num = Str'First + 1);
- begin
- pragma Assert
- (Is_Raw_Unsigned_Format_Ghost (Str (Fst_Num .. Str'Last)));
- pragma Assert
- (Scan_Split_No_Overflow_Ghost (Str, Str'First + 1, Str'Last));
- pragma Assert
- ((Val, 10, 0) = Scan_Split_Value_Ghost (Str, Str'First + 1, Str'Last));
- pragma Assert
- (Raw_Unsigned_No_Overflow_Ghost (Str, Fst_Num, Str'Last));
- pragma Assert (Val = Exponent_Unsigned_Ghost (Val, 0, 10).Value);
- pragma Assert (Is_Unsigned_Ghost (Str));
- pragma Assert (Is_Value_Unsigned_Ghost (Str, Val));
- end Prove_Scan_Only_Decimal_Ghost;
-
- -----------------------------
- -- Scan_Based_Number_Ghost --
- -----------------------------
-
- function Scan_Based_Number_Ghost
- (Str : String;
- From, To : Integer;
- Base : Uns := 10;
- Acc : Uns := 0) return Uns_Option
- is
- (if From > To then (Overflow => False, Value => Acc)
- elsif Str (From) = '_'
- then Scan_Based_Number_Ghost (Str, From + 1, To, Base, Acc)
- elsif Scan_Overflows_Ghost
- (Hexa_To_Unsigned_Ghost (Str (From)), Base, Acc)
- then (Overflow => True)
- else Scan_Based_Number_Ghost
- (Str, From + 1, To, Base,
- Base * Acc + Hexa_To_Unsigned_Ghost (Str (From))));
-
-end System.Value_U_Spec;
diff --git a/gcc/ada/libgnat/s-vauspe.ads b/gcc/ada/libgnat/s-vauspe.ads
deleted file mode 100644
index 5dbb57d..0000000
--- a/gcc/ada/libgnat/s-vauspe.ads
+++ /dev/null
@@ -1,629 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- S Y S T E M . V A L U E _ U _ S P E C --
--- --
--- S p e c --
--- --
--- Copyright (C) 2022-2025, Free Software Foundation, Inc. --
--- --
--- GNAT is 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 is part of a set of Ghost code packages used to proof the
--- implementations of the Image and Value attributes. It provides the
--- specification entities using for the formal verification of the routines
--- for scanning modular unsigned integer values.
-
--- 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. Postconditions and
--- contract cases should not be executed at runtime as well, in order not to
--- slow down the execution of these functions.
-
-pragma Assertion_Policy (Pre => Ignore,
- Post => Ignore,
- Contract_Cases => Ignore,
- Ghost => Ignore,
- Subprogram_Variant => Ignore);
-
-with System.Val_Spec; use System.Val_Spec;
-
-generic
-
- type Uns is mod <>;
-
-package System.Value_U_Spec with
- Ghost,
- SPARK_Mode,
- Always_Terminates
-is
- pragma Preelaborate;
-
- -- Maximum value of exponent for 10 that fits in Uns'Base
- function Max_Log10 return Natural is
- (case Uns'Base'Size is
- when 8 => 2,
- when 16 => 4,
- when 32 => 9,
- when 64 => 19,
- when 128 => 38,
- when others => raise Program_Error)
- with Ghost;
-
- pragma Annotate (Gnatcheck, Exempt_On, "Discriminated_Records",
- "variant record only used in proof code");
- type Uns_Option (Overflow : Boolean := False) is record
- case Overflow is
- when True =>
- null;
- when False =>
- Value : Uns := 0;
- end case;
- end record;
- pragma Annotate (Gnatcheck, Exempt_Off, "Discriminated_Records");
-
- function Wrap_Option (Value : Uns) return Uns_Option is
- (Overflow => False, Value => Value);
-
- function Only_Decimal_Ghost
- (Str : String;
- From, To : Integer)
- return Boolean
- is
- (for all J in From .. To => Str (J) in '0' .. '9')
- with
- Pre => From > To or else (From >= Str'First and then To <= Str'Last);
- -- Ghost function that returns True if S has only decimal characters
- -- from index From to index To.
-
- function Only_Hexa_Ghost (Str : String; From, To : Integer) return Boolean
- is
- (for all J in From .. To =>
- Str (J) in '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' | '_')
- with
- Pre => From > To or else (From >= Str'First and then To <= Str'Last);
- -- Ghost function that returns True if S has only hexadecimal characters
- -- from index From to index To.
-
- function Last_Hexa_Ghost (Str : String) return Positive
- with
- Pre => Str /= ""
- and then Str (Str'First) in '0' .. '9' | 'a' .. 'f' | 'A' .. 'F',
- Post => Last_Hexa_Ghost'Result in Str'Range
- and then (if Last_Hexa_Ghost'Result < Str'Last then
- Str (Last_Hexa_Ghost'Result + 1) not in
- '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' | '_')
- and then Only_Hexa_Ghost (Str, Str'First, Last_Hexa_Ghost'Result);
- -- Ghost function that returns the index of the last character in S that
- -- is either an hexadecimal digit or an underscore, which necessarily
- -- exists given the precondition on Str.
-
- function Is_Based_Format_Ghost (Str : String) return Boolean
- is
- (Str /= ""
- and then Str (Str'First) in '0' .. '9' | 'a' .. 'f' | 'A' .. 'F'
- and then
- (declare
- L : constant Positive := Last_Hexa_Ghost (Str);
- begin
- Str (L) /= '_'
- and then (for all J in Str'First .. L =>
- (if Str (J) = '_' then Str (J + 1) /= '_'))));
- -- Ghost function that determines if Str has the correct format for a
- -- based number, consisting in a sequence of hexadecimal digits possibly
- -- separated by single underscores. It may be followed by other characters.
-
- function Hexa_To_Unsigned_Ghost (X : Character) return Uns is
- (case X is
- when '0' .. '9' => Character'Pos (X) - Character'Pos ('0'),
- when 'a' .. 'f' => Character'Pos (X) - Character'Pos ('a') + 10,
- when 'A' .. 'F' => Character'Pos (X) - Character'Pos ('A') + 10,
- when others => raise Program_Error)
- with
- Pre => X in '0' .. '9' | 'a' .. 'f' | 'A' .. 'F';
- -- Ghost function that computes the value corresponding to an hexadecimal
- -- digit.
-
- function Scan_Overflows_Ghost
- (Digit : Uns;
- Base : Uns;
- Acc : Uns) return Boolean
- is
- (Digit >= Base
- or else Acc > Uns'Last / Base
- or else Uns'Last - Digit < Base * Acc);
- -- Ghost function which returns True if Digit + Base * Acc overflows or
- -- Digit is greater than Base, as this is used by the algorithm for the
- -- test of overflow.
-
- function Scan_Based_Number_Ghost
- (Str : String;
- From, To : Integer;
- Base : Uns := 10;
- Acc : Uns := 0) return Uns_Option
- with
- Subprogram_Variant => (Increases => From),
- Pre => Str'Last /= Positive'Last
- and then
- (From > To or else (From >= Str'First and then To <= Str'Last))
- and then Only_Hexa_Ghost (Str, From, To);
- -- Ghost function that recursively computes the based number in Str,
- -- assuming Acc has been scanned already and scanning continues at index
- -- From.
-
- -- Lemmas unfolding the recursive definition of Scan_Based_Number_Ghost
-
- procedure Lemma_Scan_Based_Number_Ghost_Base
- (Str : String;
- From, To : Integer;
- Base : Uns := 10;
- Acc : Uns := 0)
- with
- Global => null,
- Pre => Str'Last /= Positive'Last
- and then
- (From > To or else (From >= Str'First and then To <= Str'Last))
- and then Only_Hexa_Ghost (Str, From, To),
- Post =>
- (if From > To
- then Scan_Based_Number_Ghost (Str, From, To, Base, Acc) =
- (Overflow => False, Value => Acc));
- -- Base case: Scan_Based_Number_Ghost returns Acc if From is bigger than To
-
- procedure Lemma_Scan_Based_Number_Ghost_Underscore
- (Str : String;
- From, To : Integer;
- Base : Uns := 10;
- Acc : Uns := 0)
- with
- Global => null,
- Pre => Str'Last /= Positive'Last
- and then
- (From > To or else (From >= Str'First and then To <= Str'Last))
- and then Only_Hexa_Ghost (Str, From, To),
- Post =>
- (if From <= To and then Str (From) = '_'
- then Scan_Based_Number_Ghost (Str, From, To, Base, Acc) =
- Scan_Based_Number_Ghost (Str, From + 1, To, Base, Acc));
- -- Underscore case: underscores are ignored while scanning
-
- procedure Lemma_Scan_Based_Number_Ghost_Overflow
- (Str : String;
- From, To : Integer;
- Base : Uns := 10;
- Acc : Uns := 0)
- with
- Global => null,
- Pre => Str'Last /= Positive'Last
- and then
- (From > To or else (From >= Str'First and then To <= Str'Last))
- and then Only_Hexa_Ghost (Str, From, To),
- Post =>
- (if From <= To
- and then Str (From) /= '_'
- and then Scan_Overflows_Ghost
- (Hexa_To_Unsigned_Ghost (Str (From)), Base, Acc)
- then Scan_Based_Number_Ghost (Str, From, To, Base, Acc) =
- (Overflow => True));
- -- Overflow case: scanning a digit which causes an overflow
-
- procedure Lemma_Scan_Based_Number_Ghost_Step
- (Str : String;
- From, To : Integer;
- Base : Uns := 10;
- Acc : Uns := 0)
- with
- Global => null,
- Pre => Str'Last /= Positive'Last
- and then
- (From > To or else (From >= Str'First and then To <= Str'Last))
- and then Only_Hexa_Ghost (Str, From, To),
- Post =>
- (if From <= To
- and then Str (From) /= '_'
- and then not Scan_Overflows_Ghost
- (Hexa_To_Unsigned_Ghost (Str (From)), Base, Acc)
- then Scan_Based_Number_Ghost (Str, From, To, Base, Acc) =
- Scan_Based_Number_Ghost
- (Str, From + 1, To, Base,
- Base * Acc + Hexa_To_Unsigned_Ghost (Str (From))));
- -- Normal case: scanning a digit without overflows
-
- function Exponent_Unsigned_Ghost
- (Value : Uns;
- Exp : Natural;
- Base : Uns := 10) return Uns_Option
- with
- Subprogram_Variant => (Decreases => Exp);
- -- Ghost function that recursively computes Value * Base ** Exp
-
- -- Lemmas unfolding the recursive definition of Exponent_Unsigned_Ghost
-
- procedure Lemma_Exponent_Unsigned_Ghost_Base
- (Value : Uns;
- Exp : Natural;
- Base : Uns := 10)
- with
- Post =>
- (if Exp = 0 or Value = 0
- then Exponent_Unsigned_Ghost (Value, Exp, Base) =
- (Overflow => False, Value => Value));
- -- Base case: Exponent_Unsigned_Ghost returns 0 if Value or Exp is 0
-
- procedure Lemma_Exponent_Unsigned_Ghost_Overflow
- (Value : Uns;
- Exp : Natural;
- Base : Uns := 10)
- with
- Post =>
- (if Exp /= 0
- and then Value /= 0
- and then Scan_Overflows_Ghost (0, Base, Value)
- then Exponent_Unsigned_Ghost (Value, Exp, Base) = (Overflow => True));
- -- Overflow case: the next multiplication overflows
-
- procedure Lemma_Exponent_Unsigned_Ghost_Step
- (Value : Uns;
- Exp : Natural;
- Base : Uns := 10)
- with
- Post =>
- (if Exp /= 0
- and then Value /= 0
- and then not Scan_Overflows_Ghost (0, Base, Value)
- then Exponent_Unsigned_Ghost (Value, Exp, Base) =
- Exponent_Unsigned_Ghost (Value * Base, Exp - 1, Base));
- -- Normal case: exponentiation without overflows
-
- function Raw_Unsigned_Starts_As_Based_Ghost
- (Str : String;
- Last_Num_Init, To : Integer)
- return Boolean
- is
- (Last_Num_Init < To - 1
- and then Str (Last_Num_Init + 1) in '#' | ':'
- and then Str (Last_Num_Init + 2) in
- '0' .. '9' | 'a' .. 'f' | 'A' .. 'F')
- with Ghost,
- Pre => Last_Num_Init in Str'Range
- and then To in Str'Range;
- -- Return True if Str starts as a based number
-
- function Raw_Unsigned_Is_Based_Ghost
- (Str : String;
- Last_Num_Init : Integer;
- Last_Num_Based : Integer;
- To : Integer)
- return Boolean
- is
- (Raw_Unsigned_Starts_As_Based_Ghost (Str, Last_Num_Init, To)
- and then Last_Num_Based < To
- and then Str (Last_Num_Based + 1) = Str (Last_Num_Init + 1))
- with Ghost,
- Pre => Last_Num_Init in Str'Range
- and then Last_Num_Based in Last_Num_Init .. Str'Last
- and then To in Str'Range;
- -- Return True if Str is a based number
-
- function Is_Raw_Unsigned_Format_Ghost (Str : String) return Boolean is
- (Is_Natural_Format_Ghost (Str)
- and then
- (declare
- Last_Num_Init : constant Integer := Last_Number_Ghost (Str);
- Starts_As_Based : constant Boolean :=
- Raw_Unsigned_Starts_As_Based_Ghost (Str, Last_Num_Init, Str'Last);
- Last_Num_Based : constant Integer :=
- (if Starts_As_Based
- then Last_Hexa_Ghost (Str (Last_Num_Init + 2 .. Str'Last))
- else Last_Num_Init);
- Is_Based : constant Boolean :=
- Raw_Unsigned_Is_Based_Ghost
- (Str, Last_Num_Init, Last_Num_Based, Str'Last);
- First_Exp : constant Integer :=
- (if Is_Based then Last_Num_Based + 2 else Last_Num_Init + 1);
- begin
- (if Starts_As_Based then
- Is_Based_Format_Ghost (Str (Last_Num_Init + 2 .. Str'Last))
- and then Last_Num_Based < Str'Last)
- and then Is_Opt_Exponent_Format_Ghost
- (Str (First_Exp .. Str'Last))))
- with
- Pre => Str'Last /= Positive'Last;
- -- Ghost function that determines if Str has the correct format for an
- -- unsigned number without a sign character.
- -- It is a natural number in base 10, optionally followed by a based
- -- number surrounded by delimiters # or :, optionally followed by an
- -- exponent part.
-
- type Split_Value_Ghost is record
- Value : Uns;
- Base : Uns;
- Expon : Natural;
- end record;
-
- function Scan_Split_No_Overflow_Ghost
- (Str : String;
- From, To : Integer)
- return Boolean
- is
- (declare
- Last_Num_Init : constant Integer :=
- Last_Number_Ghost (Str (From .. To));
- Init_Val : constant Uns_Option :=
- Scan_Based_Number_Ghost (Str, From, Last_Num_Init);
- Starts_As_Based : constant Boolean :=
- Raw_Unsigned_Starts_As_Based_Ghost (Str, Last_Num_Init, To);
- Last_Num_Based : constant Integer :=
- (if Starts_As_Based
- then Last_Hexa_Ghost (Str (Last_Num_Init + 2 .. To))
- else Last_Num_Init);
- Based_Val : constant Uns_Option :=
- (if Starts_As_Based and then not Init_Val.Overflow
- then Scan_Based_Number_Ghost
- (Str, Last_Num_Init + 2, Last_Num_Based, Init_Val.Value)
- else Init_Val);
- begin
- not Init_Val.Overflow
- and then
- (Last_Num_Init >= To - 1
- or else Str (Last_Num_Init + 1) not in '#' | ':'
- or else Init_Val.Value in 2 .. 16)
- and then
- (not Starts_As_Based
- or else not Based_Val.Overflow))
- with
- Pre => Str'Last /= Positive'Last
- and then From in Str'Range
- and then To in From .. Str'Last
- and then Str (From) in '0' .. '9';
- -- Ghost function that determines if an overflow might occur while scanning
- -- the representation of an unsigned number. The computation overflows if
- -- either:
- -- * The computation of the decimal part overflows,
- -- * The decimal part is followed by a valid delimiter for a based
- -- part, and the number corresponding to the base is not a valid base,
- -- or
- -- * The computation of the based part overflows.
-
- pragma Warnings (Off, "constant * is not referenced");
- function Scan_Split_Value_Ghost
- (Str : String;
- From, To : Integer)
- return Split_Value_Ghost
- is
- (declare
- Last_Num_Init : constant Integer :=
- Last_Number_Ghost (Str (From .. To));
- Init_Val : constant Uns_Option :=
- Scan_Based_Number_Ghost (Str, From, Last_Num_Init);
- Starts_As_Based : constant Boolean :=
- Raw_Unsigned_Starts_As_Based_Ghost (Str, Last_Num_Init, To);
- Last_Num_Based : constant Integer :=
- (if Starts_As_Based
- then Last_Hexa_Ghost (Str (Last_Num_Init + 2 .. To))
- else Last_Num_Init);
- Is_Based : constant Boolean :=
- Raw_Unsigned_Is_Based_Ghost (Str, Last_Num_Init, Last_Num_Based, To);
- Based_Val : constant Uns_Option :=
- (if Starts_As_Based and then not Init_Val.Overflow
- then Scan_Based_Number_Ghost
- (Str, Last_Num_Init + 2, Last_Num_Based, Init_Val.Value)
- else Init_Val);
- First_Exp : constant Integer :=
- (if Is_Based then Last_Num_Based + 2 else Last_Num_Init + 1);
- Expon : constant Natural :=
- (if Starts_As_Exponent_Format_Ghost (Str (First_Exp .. To))
- then Scan_Exponent_Ghost (Str (First_Exp .. To))
- else 0);
- Base : constant Uns :=
- (if Is_Based then Init_Val.Value else 10);
- Value : constant Uns :=
- (if Is_Based then Based_Val.Value else Init_Val.Value);
- begin
- (Value => Value, Base => Base, Expon => Expon))
- with
- Pre => Str'Last /= Positive'Last
- and then From in Str'Range
- and then To in From .. Str'Last
- and then Str (From) in '0' .. '9'
- and then Scan_Split_No_Overflow_Ghost (Str, From, To);
- -- Ghost function that scans an unsigned number without a sign character
- -- and return a record containing the values scanned for its value, its
- -- base, and its exponent.
- pragma Warnings (On, "constant * is not referenced");
-
- function Raw_Unsigned_No_Overflow_Ghost
- (Str : String;
- From, To : Integer)
- return Boolean
- is
- (Scan_Split_No_Overflow_Ghost (Str, From, To)
- and then
- (declare
- Val : constant Split_Value_Ghost := Scan_Split_Value_Ghost
- (Str, From, To);
- begin
- not Exponent_Unsigned_Ghost
- (Val.Value, Val.Expon, Val.Base).Overflow))
- with
- Pre => Str'Last /= Positive'Last
- and then From in Str'Range
- and then To in From .. Str'Last
- and then Str (From) in '0' .. '9';
- -- Ghost function that determines if the computation of the unsigned number
- -- represented by Str will overflow. The computation overflows if either:
- -- * The scan of the string overflows, or
- -- * The computation of the exponentiation overflows.
-
- function Scan_Raw_Unsigned_Ghost
- (Str : String;
- From, To : Integer)
- return Uns
- is
- (declare
- Val : constant Split_Value_Ghost := Scan_Split_Value_Ghost
- (Str, From, To);
- begin
- Exponent_Unsigned_Ghost (Val.Value, Val.Expon, Val.Base).Value)
- with
- Pre => Str'Last /= Positive'Last
- and then From in Str'Range
- and then To in From .. Str'Last
- and then Str (From) in '0' .. '9'
- and then Raw_Unsigned_No_Overflow_Ghost (Str, From, To);
- -- Ghost function that scans an unsigned number without a sign character
-
- function Raw_Unsigned_Last_Ghost
- (Str : String;
- From, To : Integer)
- return Positive
- is
- (declare
- Last_Num_Init : constant Integer :=
- Last_Number_Ghost (Str (From .. To));
- Starts_As_Based : constant Boolean :=
- Raw_Unsigned_Starts_As_Based_Ghost (Str, Last_Num_Init, To);
- Last_Num_Based : constant Integer :=
- (if Starts_As_Based
- then Last_Hexa_Ghost (Str (Last_Num_Init + 2 .. To))
- else Last_Num_Init);
- Is_Based : constant Boolean :=
- Raw_Unsigned_Is_Based_Ghost (Str, Last_Num_Init, Last_Num_Based, To);
- First_Exp : constant Integer :=
- (if Is_Based then Last_Num_Based + 2 else Last_Num_Init + 1);
- begin
- (if not Starts_As_Exponent_Format_Ghost (Str (First_Exp .. To))
- then First_Exp
- elsif Str (First_Exp + 1) in '-' | '+' then
- Last_Number_Ghost (Str (First_Exp + 2 .. To)) + 1
- else Last_Number_Ghost (Str (First_Exp + 1 .. To)) + 1))
- with
- Pre => Str'Last /= Positive'Last
- and then From in Str'Range
- and then To in From .. Str'Last
- and then Str (From) in '0' .. '9',
- Post => Raw_Unsigned_Last_Ghost'Result >= From;
- -- Ghost function that returns the position of the cursor once an unsigned
- -- number has been seen.
-
- function Slide_To_1 (Str : String) return String
- with
- Post =>
- Only_Space_Ghost (Str, Str'First, Str'Last) =
- (for all J in Str'First .. Str'Last =>
- Slide_To_1'Result (J - Str'First + 1) = ' ');
- -- Slides Str so that it starts at 1
-
- function Slide_If_Necessary (Str : String) return String is
- (if Str'Last = Positive'Last then Slide_To_1 (Str) else Str);
- -- If Str'Last = Positive'Last then slides Str so that it starts at 1
-
- function Is_Unsigned_Ghost (Str : String) return Boolean is
- (declare
- Non_Blank : constant Positive := First_Non_Space_Ghost
- (Str, Str'First, Str'Last);
- Fst_Num : constant Positive :=
- (if Str (Non_Blank) = '+' then Non_Blank + 1 else Non_Blank);
- begin
- Is_Raw_Unsigned_Format_Ghost (Str (Fst_Num .. Str'Last))
- and then Raw_Unsigned_No_Overflow_Ghost (Str, Fst_Num, Str'Last)
- and then Only_Space_Ghost
- (Str, Raw_Unsigned_Last_Ghost (Str, Fst_Num, Str'Last), Str'Last))
- with
- Pre => not Only_Space_Ghost (Str, Str'First, Str'Last)
- and then Str'Last /= Positive'Last;
- -- Ghost function that determines if Str has the correct format for an
- -- unsigned number, consisting in some blank characters, an optional
- -- + sign, a raw unsigned number which does not overflow and then some
- -- more blank characters.
-
- function Is_Value_Unsigned_Ghost (Str : String; Val : Uns) return Boolean is
- (declare
- Non_Blank : constant Positive := First_Non_Space_Ghost
- (Str, Str'First, Str'Last);
- Fst_Num : constant Positive :=
- (if Str (Non_Blank) = '+' then Non_Blank + 1 else Non_Blank);
- begin
- Val = Scan_Raw_Unsigned_Ghost (Str, Fst_Num, Str'Last))
- with
- Pre => not Only_Space_Ghost (Str, Str'First, Str'Last)
- and then Str'Last /= Positive'Last
- and then Is_Unsigned_Ghost (Str);
- -- Ghost function that returns True if Val is the value corresponding to
- -- the unsigned number represented by Str.
-
- procedure Prove_Scan_Based_Number_Ghost_Eq
- (Str1, Str2 : String;
- From, To : Integer;
- Base : Uns := 10;
- Acc : Uns := 0)
- with
- Subprogram_Variant => (Increases => From),
- Pre => Str1'Last /= Positive'Last
- and then Str2'Last /= Positive'Last
- and then
- (From > To or else (From >= Str1'First and then To <= Str1'Last))
- and then
- (From > To or else (From >= Str2'First and then To <= Str2'Last))
- and then Only_Hexa_Ghost (Str1, From, To)
- and then (for all J in From .. To => Str1 (J) = Str2 (J)),
- Post =>
- Scan_Based_Number_Ghost (Str1, From, To, Base, Acc)
- = Scan_Based_Number_Ghost (Str2, From, To, Base, Acc);
- -- Scan_Based_Number_Ghost returns the same value on two slices which are
- -- equal.
-
- procedure Prove_Scan_Only_Decimal_Ghost
- (Str : String;
- Val : Uns)
- with
- Pre => Str'Last /= Positive'Last
- and then Str'Length >= 2
- and then Str (Str'First) = ' '
- and then Only_Decimal_Ghost (Str, Str'First + 1, Str'Last)
- and then Scan_Based_Number_Ghost (Str, Str'First + 1, Str'Last)
- = Wrap_Option (Val),
- Post => Is_Unsigned_Ghost (Slide_If_Necessary (Str))
- and then
- Is_Value_Unsigned_Ghost (Slide_If_Necessary (Str), Val);
- -- Ghost lemma used in the proof of 'Image implementation, to prove that
- -- the result of Value_Unsigned on a decimal string is the same as the
- -- result of Scan_Based_Number_Ghost.
-
- -- Bundle Uns type with other types, constants and subprograms used in
- -- ghost code, so that this package can be instantiated once and used
- -- multiple times as generic formal for a given Int type.
-
-private
-
- ----------------
- -- Slide_To_1 --
- ----------------
-
- function Slide_To_1 (Str : String) return String is
- (declare
- Res : constant String (1 .. Str'Length) := Str;
- begin
- Res);
-
-end System.Value_U_Spec;
diff --git a/gcc/ada/libgnat/s-veboop.adb b/gcc/ada/libgnat/s-veboop.adb
index fb92f1c..edff485 100644
--- a/gcc/ada/libgnat/s-veboop.adb
+++ b/gcc/ada/libgnat/s-veboop.adb
@@ -29,14 +29,6 @@
-- --
------------------------------------------------------------------------------
--- Ghost code, loop invariants and assertions in this unit are meant for
--- analysis only, not for run-time checking, as it would be too costly
--- otherwise. This is enforced by setting the assertion policy to Ignore.
-
-pragma Assertion_Policy (Ghost => Ignore,
- Loop_Invariant => Ignore,
- Assert => Ignore);
-
package body System.Vectors.Boolean_Operations
with SPARK_Mode
is
@@ -86,26 +78,7 @@ is
-----------
function "not" (Item : Vectors.Vector) return Vectors.Vector is
-
- procedure Prove_Not (Result : Vectors.Vector)
- with
- Ghost,
- Pre => Valid (Item)
- and then Result = (Item xor True_Val),
- Post => Valid (Result)
- and then (for all J in 1 .. Vector_Boolean_Size =>
- Model (Result) (J) = not Model (Item) (J));
-
- procedure Prove_Not (Result : Vectors.Vector) is
- begin
- for J in 1 .. Vector_Boolean_Size loop
- pragma Assert
- (Element (Result, J) = 1 - Element (Item, J));
- end loop;
- end Prove_Not;
-
begin
- Prove_Not (Item xor True_Val);
return Item xor True_Val;
end "not";
@@ -119,32 +92,7 @@ is
end Nand;
function Nand (Left, Right : Vectors.Vector) return Vectors.Vector is
-
- procedure Prove_And (Result : Vectors.Vector)
- with
- Ghost,
- Pre => Valid (Left)
- and then Valid (Right)
- and then Result = (Left and Right),
- Post => Valid (Result)
- and then (for all J in 1 .. Vector_Boolean_Size =>
- Model (Result) (J) =
- (Model (Left) (J) and Model (Right) (J)));
-
- procedure Prove_And (Result : Vectors.Vector) is
- begin
- for J in 1 .. Vector_Boolean_Size loop
- pragma Assert
- (Element (Result, J) =
- (if Element (Left, J) = 1
- and Element (Right, J) = 1
- then 1
- else 0));
- end loop;
- end Prove_And;
-
begin
- Prove_And (Left and Right);
return not (Left and Right);
end Nand;
@@ -158,32 +106,7 @@ is
end Nor;
function Nor (Left, Right : Vectors.Vector) return Vectors.Vector is
-
- procedure Prove_Or (Result : Vectors.Vector)
- with
- Ghost,
- Pre => Valid (Left)
- and then Valid (Right)
- and then Result = (Left or Right),
- Post => Valid (Result)
- and then (for all J in 1 .. Vector_Boolean_Size =>
- Model (Result) (J) =
- (Model (Left) (J) or Model (Right) (J)));
-
- procedure Prove_Or (Result : Vectors.Vector) is
- begin
- for J in 1 .. Vector_Boolean_Size loop
- pragma Assert
- (Element (Result, J) =
- (if Element (Left, J) = 1
- or Element (Right, J) = 1
- then 1
- else 0));
- end loop;
- end Prove_Or;
-
begin
- Prove_Or (Left or Right);
return not (Left or Right);
end Nor;
@@ -197,32 +120,7 @@ is
end Nxor;
function Nxor (Left, Right : Vectors.Vector) return Vectors.Vector is
-
- procedure Prove_Xor (Result : Vectors.Vector)
- with
- Ghost,
- Pre => Valid (Left)
- and then Valid (Right)
- and then Result = (Left xor Right),
- Post => Valid (Result)
- and then (for all J in 1 .. Vector_Boolean_Size =>
- Model (Result) (J) =
- (Model (Left) (J) xor Model (Right) (J)));
-
- procedure Prove_Xor (Result : Vectors.Vector) is
- begin
- for J in 1 .. Vector_Boolean_Size loop
- pragma Assert
- (Element (Result, J) =
- (if Element (Left, J) = 1
- xor Element (Right, J) = 1
- then 1
- else 0));
- end loop;
- end Prove_Xor;
-
begin
- Prove_Xor (Left xor Right);
return not (Left xor Right);
end Nxor;
diff --git a/gcc/ada/libgnat/s-veboop.ads b/gcc/ada/libgnat/s-veboop.ads
index 6283d19..0b4f894 100644
--- a/gcc/ada/libgnat/s-veboop.ads
+++ b/gcc/ada/libgnat/s-veboop.ads
@@ -31,116 +31,21 @@
-- This package contains functions for runtime operations on boolean vectors
--- 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. Postconditions and
--- contract cases should not be executed at runtime as well, in order not to
--- slow down the execution of these functions.
-
-pragma Assertion_Policy (Pre => Ignore,
- Post => Ignore,
- Contract_Cases => Ignore,
- Ghost => Ignore);
-
package System.Vectors.Boolean_Operations
with Pure, SPARK_Mode
is
- pragma Warnings (Off, "aspect ""Pre"" not enforced on inlined subprogram",
- Reason => "Pre only used in proof");
- pragma Warnings (Off, "aspect ""Post"" not enforced on inlined subprogram",
- Reason => "Post only used in proof");
-
-- Type Vectors.Vector represents an array of Boolean, each of which
- -- takes 8 bits of the representation, with the 7 msb set to zero. Express
- -- in contracts the constraint on valid vectors and the model that they
- -- represent, and the relationship between input models and output model.
-
- Vector_Boolean_Size : constant Positive :=
- System.Word_Size / System.Storage_Unit
- with Ghost;
-
- type Vector_Element is mod 2 ** System.Storage_Unit with Ghost;
-
- type Vector_Boolean_Array is array (1 .. Vector_Boolean_Size) of Boolean
- with Ghost;
-
- function Shift_Right (V : Vectors.Vector; N : Natural) return Vectors.Vector
- with Ghost, Import, Convention => Intrinsic;
-
- function Element (V : Vectors.Vector; N : Positive) return Vector_Element is
- (Vector_Element (Shift_Right (V, (N - 1) * System.Storage_Unit)
- and (2 ** System.Storage_Unit - 1)))
- with
- Ghost,
- Pre => N <= Vector_Boolean_Size;
- -- Return the Nth element represented by the vector
-
- function Valid (V : Vectors.Vector) return Boolean is
- (for all J in 1 .. Vector_Boolean_Size =>
- Element (V, J) in 0 .. 1)
- with Ghost;
- -- A valid vector is one for which all elements are 0 (representing False)
- -- or 1 (representing True).
-
- function Model (V : Vectors.Vector) return Vector_Boolean_Array
- with
- Ghost,
- Pre => Valid (V);
-
- function Model (V : Vectors.Vector) return Vector_Boolean_Array is
- (for J in 1 .. Vector_Boolean_Size => Element (V, J) = 1);
- -- The model of a valid vector is the corresponding array of Boolean values
-
- -- Although in general the boolean operations on arrays of booleans are
- -- identical to operations on arrays of unsigned words of the same size,
- -- for the "not" operator this is not the case as False is typically
- -- represented by 0 and true by 1.
-
- function "not" (Item : Vectors.Vector) return Vectors.Vector
- with
- Pre => Valid (Item),
- Post => Valid ("not"'Result)
- and then (for all J in 1 .. Vector_Boolean_Size =>
- Model ("not"'Result) (J) = not Model (Item) (J));
-
- function Nand (Left, Right : Boolean) return Boolean
- with
- Post => Nand'Result = not (Left and Right);
-
- function Nor (Left, Right : Boolean) return Boolean
- with
- Post => Nor'Result = not (Left or Right);
-
- function Nxor (Left, Right : Boolean) return Boolean
- with
- Post => Nxor'Result = not (Left xor Right);
+ -- takes 8 bits of the representation, with the 7 msb set to zero.
- function Nand (Left, Right : Vectors.Vector) return Vectors.Vector
- with
- Pre => Valid (Left)
- and then Valid (Right),
- Post => Valid (Nand'Result)
- and then (for all J in 1 .. Vector_Boolean_Size =>
- Model (Nand'Result) (J) =
- Nand (Model (Left) (J), Model (Right) (J)));
+ function "not" (Item : Vectors.Vector) return Vectors.Vector;
- function Nor (Left, Right : Vectors.Vector) return Vectors.Vector
- with
- Pre => Valid (Left)
- and then Valid (Right),
- Post => Valid (Nor'Result)
- and then (for all J in 1 .. Vector_Boolean_Size =>
- Model (Nor'Result) (J) =
- Nor (Model (Left) (J), Model (Right) (J)));
+ function Nand (Left, Right : Boolean) return Boolean;
+ function Nor (Left, Right : Boolean) return Boolean;
+ function Nxor (Left, Right : Boolean) return Boolean;
- function Nxor (Left, Right : Vectors.Vector) return Vectors.Vector
- with
- Pre => Valid (Left)
- and then Valid (Right),
- Post => Valid (Nxor'Result)
- and then (for all J in 1 .. Vector_Boolean_Size =>
- Model (Nxor'Result) (J) =
- Nxor (Model (Left) (J), Model (Right) (J)));
+ function Nand (Left, Right : Vectors.Vector) return Vectors.Vector;
+ function Nor (Left, Right : Vectors.Vector) return Vectors.Vector;
+ function Nxor (Left, Right : Vectors.Vector) return Vectors.Vector;
-- The three boolean operations "nand", "nor" and "nxor" are needed
-- for cases where the compiler moves boolean array operations into
-- the body of the loop that iterates over the array elements.
diff --git a/gcc/ada/libgnat/s-vs_int.ads b/gcc/ada/libgnat/s-vs_int.ads
deleted file mode 100644
index a4cc0dc..0000000
--- a/gcc/ada/libgnat/s-vs_int.ads
+++ /dev/null
@@ -1,59 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- S Y S T E M . V S _ I N T --
--- --
--- S p e c --
--- --
--- Copyright (C) 2023-2025, Free Software Foundation, Inc. --
--- --
--- GNAT is 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 specification functions for scanning signed Integer
--- values for use in ``Text_IO.Integer_IO``, and the Value attribute.
-
--- 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. Postconditions and
--- contract cases should not be executed at runtime as well, in order not to
--- slow down the execution of these functions.
-
-pragma Assertion_Policy (Pre => Ignore,
- Post => Ignore,
- Contract_Cases => Ignore,
- Ghost => Ignore,
- Subprogram_Variant => Ignore);
-
-with System.Unsigned_Types;
-with System.Value_I_Spec;
-with System.Vs_Uns;
-
-package System.Vs_Int with SPARK_Mode, Ghost is
- pragma Preelaborate;
-
- subtype Unsigned is Unsigned_Types.Unsigned;
-
- package Spec is new System.Value_I_Spec
- (Integer, Unsigned, System.Vs_Uns.Spec);
-
-end System.Vs_Int;
diff --git a/gcc/ada/libgnat/s-vs_lli.ads b/gcc/ada/libgnat/s-vs_lli.ads
deleted file mode 100644
index 3a4a010..0000000
--- a/gcc/ada/libgnat/s-vs_lli.ads
+++ /dev/null
@@ -1,60 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- S Y S T E M . V S _ L L I --
--- --
--- S p e c --
--- --
--- Copyright (C) 2023-2025, Free Software Foundation, Inc. --
--- --
--- GNAT is 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 specification functions for scanning
--- Long_Long_Integer values for use in ``Text_IO.Integer_IO``, and the Value
--- attribute.
-
--- 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. Postconditions and
--- contract cases should not be executed at runtime as well, in order not to
--- slow down the execution of these functions.
-
-pragma Assertion_Policy (Pre => Ignore,
- Post => Ignore,
- Contract_Cases => Ignore,
- Ghost => Ignore,
- Subprogram_Variant => Ignore);
-
-with System.Unsigned_Types;
-with System.Value_I_Spec;
-with System.Vs_LLU;
-
-package System.Vs_LLI with SPARK_Mode, Ghost is
- pragma Preelaborate;
-
- subtype Long_Long_Unsigned is Unsigned_Types.Long_Long_Unsigned;
-
- package Spec is new System.Value_I_Spec
- (Long_Long_Integer, Long_Long_Unsigned, System.Vs_LLU.Spec);
-
-end System.Vs_LLI;
diff --git a/gcc/ada/libgnat/s-vs_llu.ads b/gcc/ada/libgnat/s-vs_llu.ads
deleted file mode 100644
index e1c0fec..0000000
--- a/gcc/ada/libgnat/s-vs_llu.ads
+++ /dev/null
@@ -1,58 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- S Y S T E M . V S _ L L U --
--- --
--- S p e c --
--- --
--- Copyright (C) 2023-2025, Free Software Foundation, Inc. --
--- --
--- GNAT is 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 specification functions for scanning
--- Long_Long_Unsigned values for use in ``Text_IO.Modular_IO``, and the Value
--- attribute.
-
--- 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. Postconditions and
--- contract cases should not be executed at runtime as well, in order not to
--- slow down the execution of these functions.
-
-pragma Assertion_Policy (Pre => Ignore,
- Post => Ignore,
- Contract_Cases => Ignore,
- Ghost => Ignore,
- Subprogram_Variant => Ignore);
-
-with System.Unsigned_Types;
-with System.Value_U_Spec;
-
-package System.Vs_LLU with SPARK_Mode, Ghost is
- pragma Preelaborate;
-
- subtype Long_Long_Unsigned is Unsigned_Types.Long_Long_Unsigned;
-
- package Spec is new System.Value_U_Spec (Long_Long_Unsigned);
-
-end System.Vs_LLU;
diff --git a/gcc/ada/libgnat/s-vs_uns.ads b/gcc/ada/libgnat/s-vs_uns.ads
deleted file mode 100644
index 7e5aac3..0000000
--- a/gcc/ada/libgnat/s-vs_uns.ads
+++ /dev/null
@@ -1,57 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- S Y S T E M . V S _ U N S --
--- --
--- S p e c --
--- --
--- Copyright (C) 2023-2025, Free Software Foundation, Inc. --
--- --
--- GNAT is 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 specification functions for scanning modular Unsigned
--- values for use in ``Text_IO.Modular_IO``, and the Value attribute.
-
--- 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. Postconditions and
--- contract cases should not be executed at runtime as well, in order not to
--- slow down the execution of these functions.
-
-pragma Assertion_Policy (Pre => Ignore,
- Post => Ignore,
- Contract_Cases => Ignore,
- Ghost => Ignore,
- Subprogram_Variant => Ignore);
-
-with System.Unsigned_Types;
-with System.Value_U_Spec;
-
-package System.Vs_Uns with SPARK_Mode, Ghost is
- pragma Preelaborate;
-
- subtype Unsigned is Unsigned_Types.Unsigned;
-
- package Spec is new System.Value_U_Spec (Unsigned);
-
-end System.Vs_Uns;
diff --git a/gcc/ada/libgnat/s-vsllli.ads b/gcc/ada/libgnat/s-vsllli.ads
deleted file mode 100644
index 5648060..0000000
--- a/gcc/ada/libgnat/s-vsllli.ads
+++ /dev/null
@@ -1,60 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- S Y S T E M . V S _ L L L I --
--- --
--- S p e c --
--- --
--- Copyright (C) 2023-2025, Free Software Foundation, Inc. --
--- --
--- GNAT is 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 specification functions for scanning
--- ``Long_Long_Long_Integer`` values for use in ``Text_IO.Integer_IO``, and
--- the Value attribute.
-
--- 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. Postconditions and
--- contract cases should not be executed at runtime as well, in order not to
--- slow down the execution of these functions.
-
-pragma Assertion_Policy (Pre => Ignore,
- Post => Ignore,
- Contract_Cases => Ignore,
- Ghost => Ignore,
- Subprogram_Variant => Ignore);
-
-with System.Unsigned_Types;
-with System.Value_I_Spec;
-with System.Vs_LLLU;
-
-package System.Vs_LLLI with SPARK_Mode, Ghost is
- pragma Preelaborate;
-
- subtype Long_Long_Long_Unsigned is Unsigned_Types.Long_Long_Long_Unsigned;
-
- package Spec is new System.Value_I_Spec
- (Long_Long_Long_Integer, Long_Long_Long_Unsigned, System.Vs_LLLU.Spec);
-
-end System.Vs_LLLI;
diff --git a/gcc/ada/libgnat/s-vslllu.ads b/gcc/ada/libgnat/s-vslllu.ads
deleted file mode 100644
index 7fe1235..0000000
--- a/gcc/ada/libgnat/s-vslllu.ads
+++ /dev/null
@@ -1,58 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- S Y S T E M . V S _ L L L U --
--- --
--- S p e c --
--- --
--- Copyright (C) 2023-2025, Free Software Foundation, Inc. --
--- --
--- GNAT is 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 specification functions for scanning
--- Long_Long_Long_Unsigned values for use in Text_IO.Modular_IO, and the Value
--- attribute.
-
--- 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. Postconditions and
--- contract cases should not be executed at runtime as well, in order not to
--- slow down the execution of these functions.
-
-pragma Assertion_Policy (Pre => Ignore,
- Post => Ignore,
- Contract_Cases => Ignore,
- Ghost => Ignore,
- Subprogram_Variant => Ignore);
-
-with System.Unsigned_Types;
-with System.Value_U_Spec;
-
-package System.Vs_LLLU with SPARK_Mode, Ghost is
- pragma Preelaborate;
-
- subtype Long_Long_Long_Unsigned is Unsigned_Types.Long_Long_Long_Unsigned;
-
- package Spec is new System.Value_U_Spec (Long_Long_Long_Unsigned);
-
-end System.Vs_LLLU;
diff --git a/gcc/ada/libgnat/s-widint.ads b/gcc/ada/libgnat/s-widint.ads
index 22e342c..8af8d91 100644
--- a/gcc/ada/libgnat/s-widint.ads
+++ b/gcc/ada/libgnat/s-widint.ads
@@ -31,24 +31,11 @@
-- Width attribute for signed integers up to Integer
--- 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. Postconditions and
--- contract cases should not be executed at runtime as well, in order not to
--- slow down the execution of these functions.
-
-pragma Assertion_Policy (Pre => Ignore,
- Post => Ignore,
- Contract_Cases => Ignore,
- Ghost => Ignore);
-
with System.Width_I;
package System.Wid_Int
with SPARK_Mode
is
-
function Width_Integer is new Width_I (Integer);
pragma Pure_Function (Width_Integer);
-
end System.Wid_Int;
diff --git a/gcc/ada/libgnat/s-widlli.ads b/gcc/ada/libgnat/s-widlli.ads
index 3490b3f..a977096 100644
--- a/gcc/ada/libgnat/s-widlli.ads
+++ b/gcc/ada/libgnat/s-widlli.ads
@@ -31,24 +31,11 @@
-- Width attribute for signed integers larger than Integer
--- 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. Postconditions and
--- contract cases should not be executed at runtime as well, in order not to
--- slow down the execution of these functions.
-
-pragma Assertion_Policy (Pre => Ignore,
- Post => Ignore,
- Contract_Cases => Ignore,
- Ghost => Ignore);
-
with System.Width_I;
package System.Wid_LLI
with SPARK_Mode
is
-
function Width_Long_Long_Integer is new Width_I (Long_Long_Integer);
pragma Pure_Function (Width_Long_Long_Integer);
-
end System.Wid_LLI;
diff --git a/gcc/ada/libgnat/s-widllli.ads b/gcc/ada/libgnat/s-widllli.ads
index ee8f7af..325e80f 100644
--- a/gcc/ada/libgnat/s-widllli.ads
+++ b/gcc/ada/libgnat/s-widllli.ads
@@ -31,25 +31,12 @@
-- Width attribute for signed integers larger than Long_Long_Integer
--- 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. Postconditions and
--- contract cases should not be executed at runtime as well, in order not to
--- slow down the execution of these functions.
-
-pragma Assertion_Policy (Pre => Ignore,
- Post => Ignore,
- Contract_Cases => Ignore,
- Ghost => Ignore);
-
with System.Width_I;
package System.Wid_LLLI
with SPARK_Mode
is
-
function Width_Long_Long_Long_Integer is
new Width_I (Long_Long_Long_Integer);
pragma Pure_Function (Width_Long_Long_Long_Integer);
-
end System.Wid_LLLI;
diff --git a/gcc/ada/libgnat/s-widlllu.ads b/gcc/ada/libgnat/s-widlllu.ads
index db5b9d1..8a5c04f 100644
--- a/gcc/ada/libgnat/s-widlllu.ads
+++ b/gcc/ada/libgnat/s-widlllu.ads
@@ -31,17 +31,6 @@
-- Width attribute for modular integers larger than Long_Long_Integer
--- 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. Postconditions and
--- contract cases should not be executed at runtime as well, in order not to
--- slow down the execution of these functions.
-
-pragma Assertion_Policy (Pre => Ignore,
- Post => Ignore,
- Contract_Cases => Ignore,
- Ghost => Ignore);
-
with System.Width_U;
with System.Unsigned_Types;
diff --git a/gcc/ada/libgnat/s-widllu.ads b/gcc/ada/libgnat/s-widllu.ads
index 0fd3135..f8c8284 100644
--- a/gcc/ada/libgnat/s-widllu.ads
+++ b/gcc/ada/libgnat/s-widllu.ads
@@ -31,17 +31,6 @@
-- Width attribute for modular integers larger than Integer
--- 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. Postconditions and
--- contract cases should not be executed at runtime as well, in order not to
--- slow down the execution of these functions.
-
-pragma Assertion_Policy (Pre => Ignore,
- Post => Ignore,
- Contract_Cases => Ignore,
- Ghost => Ignore);
-
with System.Width_U;
with System.Unsigned_Types;
diff --git a/gcc/ada/libgnat/s-widthi.adb b/gcc/ada/libgnat/s-widthi.adb
index 9595790..c66d662 100644
--- a/gcc/ada/libgnat/s-widthi.adb
+++ b/gcc/ada/libgnat/s-widthi.adb
@@ -29,109 +29,9 @@
-- --
------------------------------------------------------------------------------
-with Ada.Numerics.Big_Numbers.Big_Integers_Ghost;
-use Ada.Numerics.Big_Numbers.Big_Integers_Ghost;
-
function System.Width_I (Lo, Hi : Int) return Natural is
-
- -- Ghost code, loop invariants and assertions in this unit are meant for
- -- analysis only, not for run-time checking, as it would be too costly
- -- otherwise. This is enforced by setting the assertion policy to Ignore.
-
- pragma Assertion_Policy (Ghost => Ignore,
- Loop_Invariant => Ignore,
- Assert => Ignore);
-
- -----------------------
- -- Local Subprograms --
- -----------------------
-
- package Signed_Conversion is new Signed_Conversions (Int => Int);
-
- function Big (Arg : Int) return Big_Integer renames
- Signed_Conversion.To_Big_Integer;
-
- -- Maximum value of exponent for 10 that fits in Uns'Base
- function Max_Log10 return Natural is
- (case Int'Base'Size is
- when 8 => 2,
- when 16 => 4,
- when 32 => 9,
- when 64 => 19,
- when 128 => 38,
- when others => raise Program_Error)
- with Ghost;
-
- ------------------
- -- Local Lemmas --
- ------------------
-
- procedure Lemma_Lower_Mult (A, B, C : Big_Natural)
- with
- Ghost,
- Pre => A <= B,
- Post => A * C <= B * C;
-
- procedure Lemma_Div_Commutation (X, Y : Int)
- with
- Ghost,
- Pre => X >= 0 and Y > 0,
- Post => Big (X) / Big (Y) = Big (X / Y);
-
- procedure Lemma_Div_Twice (X : Big_Natural; Y, Z : Big_Positive)
- with
- Ghost,
- Post => X / Y / Z = X / (Y * Z);
-
- ----------------------
- -- Lemma_Lower_Mult --
- ----------------------
-
- procedure Lemma_Lower_Mult (A, B, C : Big_Natural) is null;
-
- ---------------------------
- -- Lemma_Div_Commutation --
- ---------------------------
-
- procedure Lemma_Div_Commutation (X, Y : Int) is null;
-
- ---------------------
- -- Lemma_Div_Twice --
- ---------------------
-
- procedure Lemma_Div_Twice (X : Big_Natural; Y, Z : Big_Positive) is
- XY : constant Big_Natural := X / Y;
- YZ : constant Big_Natural := Y * Z;
- XYZ : constant Big_Natural := X / Y / Z;
- R : constant Big_Natural := (XY rem Z) * Y + (X rem Y);
- begin
- pragma Assert (X = XY * Y + (X rem Y));
- pragma Assert (XY = XY / Z * Z + (XY rem Z));
- pragma Assert (X = XYZ * YZ + R);
- pragma Assert ((XY rem Z) * Y <= (Z - 1) * Y);
- pragma Assert (R <= YZ - 1);
- pragma Assert (X / YZ = (XYZ * YZ + R) / YZ);
- pragma Assert (X / YZ = XYZ + R / YZ);
- end Lemma_Div_Twice;
-
- -- Local variables
-
W : Natural;
T : Int;
-
- -- Local ghost variables
-
- Max_W : constant Natural := Max_Log10 with Ghost;
- Big_10 : constant Big_Integer := Big (10) with Ghost;
-
- Pow : Big_Integer := 1 with Ghost;
- T_Init : constant Int :=
- Int'Max (abs Int'Max (Lo, Int'First + 1),
- abs Int'Max (Hi, Int'First + 1))
- with Ghost;
-
--- Start of processing for System.Width_I
-
begin
if Lo > Hi then
return 0;
@@ -151,41 +51,10 @@ begin
-- Increase value if more digits required
while T >= 10 loop
- Lemma_Div_Commutation (T, 10);
- Lemma_Div_Twice (Big (T_Init), Big_10 ** (W - 2), Big_10);
-
T := T / 10;
W := W + 1;
- Pow := Pow * 10;
-
- pragma Loop_Invariant (T >= 0);
- pragma Loop_Invariant (W in 3 .. Max_W + 3);
- pragma Loop_Invariant (Pow = Big_10 ** (W - 2));
- pragma Loop_Invariant (Big (T) = Big (T_Init) / Pow);
- pragma Loop_Variant (Decreases => T);
end loop;
- declare
- F : constant Big_Positive := Big_10 ** (W - 2) with Ghost;
- Q : constant Big_Natural := Big (T_Init) / F with Ghost;
- R : constant Big_Natural := Big (T_Init) rem F with Ghost;
- begin
- pragma Assert (Q < Big_10);
- pragma Assert (Big (T_Init) = Q * F + R);
- Lemma_Lower_Mult (Q, Big (9), F);
- pragma Assert (Big (T_Init) <= Big (9) * F + F - 1);
- pragma Assert (Big (T_Init) < Big_10 * F);
- pragma Assert (Big_10 * F = Big_10 ** (W - 1));
- end;
-
- -- This is an expression of the functional postcondition for Width_I,
- -- which cannot be expressed readily as a postcondition as this would
- -- require making the instantiation Signed_Conversion and function Big
- -- available from the spec.
-
- pragma Assert (Big (Int'Max (Lo, Int'First + 1)) < Big_10 ** (W - 1));
- pragma Assert (Big (Int'Max (Hi, Int'First + 1)) < Big_10 ** (W - 1));
-
return W;
end if;
diff --git a/gcc/ada/libgnat/s-widthu.adb b/gcc/ada/libgnat/s-widthu.adb
index df27e50..fe51d61 100644
--- a/gcc/ada/libgnat/s-widthu.adb
+++ b/gcc/ada/libgnat/s-widthu.adb
@@ -31,110 +31,12 @@
package body System.Width_U is
- -- Ghost code, loop invariants and assertions in this unit are meant for
- -- analysis only, not for run-time checking, as it would be too costly
- -- otherwise. This is enforced by setting the assertion policy to Ignore.
-
- pragma Assertion_Policy (Ghost => Ignore,
- Loop_Invariant => Ignore,
- Assert => Ignore,
- Assert_And_Cut => Ignore,
- Subprogram_Variant => Ignore);
-
function Width (Lo, Hi : Uns) return Natural is
-
- -- Ghost code, loop invariants and assertions in this unit are meant for
- -- analysis only, not for run-time checking, as it would be too costly
- -- otherwise. This is enforced by setting the assertion policy to
- -- Ignore.
-
- pragma Assertion_Policy (Ghost => Ignore,
- Loop_Invariant => Ignore,
- Assert => Ignore);
-
- ------------------
- -- Local Lemmas --
- ------------------
-
- procedure Lemma_Lower_Mult (A, B, C : Big_Natural)
- with
- Ghost,
- Pre => A <= B,
- Post => A * C <= B * C;
-
- procedure Lemma_Div_Commutation (X, Y : Uns)
- with
- Ghost,
- Pre => Y /= 0,
- Post => Big (X) / Big (Y) = Big (X / Y);
-
- procedure Lemma_Div_Twice (X : Big_Natural; Y, Z : Big_Positive)
- with
- Ghost,
- Post => X / Y / Z = X / (Y * Z);
-
- procedure Lemma_Euclidian (V, Q, F, R : Big_Integer)
- with
- Ghost,
- Pre => F > 0 and then Q = V / F and then R = V rem F,
- Post => V = Q * F + R;
- -- Ghost lemma to prove the relation between the quotient/remainder of
- -- division by F and the value V.
-
- ----------------------
- -- Lemma_Lower_Mult --
- ----------------------
-
- procedure Lemma_Lower_Mult (A, B, C : Big_Natural) is null;
-
- ---------------------------
- -- Lemma_Div_Commutation --
- ---------------------------
-
- procedure Lemma_Div_Commutation (X, Y : Uns) is null;
-
- ---------------------
- -- Lemma_Div_Twice --
- ---------------------
-
- procedure Lemma_Div_Twice (X : Big_Natural; Y, Z : Big_Positive) is
- XY : constant Big_Natural := X / Y;
- YZ : constant Big_Natural := Y * Z;
- XYZ : constant Big_Natural := X / Y / Z;
- R : constant Big_Natural := (XY rem Z) * Y + (X rem Y);
- begin
- pragma Assert (X = XY * Y + (X rem Y));
- pragma Assert (XY = XY / Z * Z + (XY rem Z));
- pragma Assert (X = XYZ * YZ + R);
- pragma Assert ((XY rem Z) * Y <= (Z - 1) * Y);
- pragma Assert (R <= YZ - 1);
- pragma Assert (X / YZ = (XYZ * YZ + R) / YZ);
- pragma Assert (X / YZ = XYZ + R / YZ);
- end Lemma_Div_Twice;
-
- ---------------------
- -- Lemma_Euclidian --
- ---------------------
-
- procedure Lemma_Euclidian (V, Q, F, R : Big_Integer) is null;
-
- -- Local variables
-
W : Natural;
T : Uns;
-
- -- Local ghost variables
-
- Max_W : constant Natural := Max_Log10 with Ghost;
- Pow : Big_Integer := 1 with Ghost;
- T_Init : constant Uns := Uns'Max (Lo, Hi) with Ghost;
-
- -- Start of processing for System.Width_U
-
begin
if Lo > Hi then
return 0;
-
else
-- Minimum value is 2, one for space, one for digit
@@ -147,32 +49,10 @@ package body System.Width_U is
-- Increase value if more digits required
while T >= 10 loop
- Lemma_Div_Commutation (T, 10);
- Lemma_Div_Twice (Big (T_Init), Big_10 ** (W - 2), Big_10);
-
T := T / 10;
W := W + 1;
- Pow := Pow * 10;
-
- pragma Loop_Invariant (W in 3 .. Max_W + 2);
- pragma Loop_Invariant (Pow = Big_10 ** (W - 2));
- pragma Loop_Invariant (Big (T) = Big (T_Init) / Pow);
- pragma Loop_Variant (Decreases => T);
end loop;
- declare
- F : constant Big_Integer := Big_10 ** (W - 2) with Ghost;
- Q : constant Big_Integer := Big (T_Init) / F with Ghost;
- R : constant Big_Integer := Big (T_Init) rem F with Ghost;
- begin
- pragma Assert (Q < Big_10);
- Lemma_Euclidian (Big (T_Init), Q, F, R);
- Lemma_Lower_Mult (Q, Big (9), F);
- pragma Assert (Big (T_Init) <= Big (9) * F + F - 1);
- pragma Assert (Big (T_Init) < Big_10 * F);
- pragma Assert (Big_10 * F = Big_10 ** (W - 1));
- end;
-
return W;
end if;
end Width;
diff --git a/gcc/ada/libgnat/s-widthu.ads b/gcc/ada/libgnat/s-widthu.ads
index 56da0a2..076dace 100644
--- a/gcc/ada/libgnat/s-widthu.ads
+++ b/gcc/ada/libgnat/s-widthu.ads
@@ -29,65 +29,14 @@
-- --
------------------------------------------------------------------------------
--- 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. Postconditions and
--- contract cases should not be executed at runtime as well, in order not to
--- slow down the execution of these functions.
-
-pragma Assertion_Policy (Pre => Ignore,
- Post => Ignore,
- Contract_Cases => Ignore,
- Ghost => Ignore,
- Subprogram_Variant => Ignore);
-
-- Compute Width attribute for non-static type derived from a modular integer
-- type. The arguments Lo, Hi are the bounds of the type.
-with Ada.Numerics.Big_Numbers.Big_Integers_Ghost;
-
generic
-
type Uns is mod <>;
package System.Width_U
with Pure
is
- package BI_Ghost renames Ada.Numerics.Big_Numbers.Big_Integers_Ghost;
- subtype Big_Integer is BI_Ghost.Big_Integer with Ghost;
- subtype Big_Natural is BI_Ghost.Big_Natural with Ghost;
- subtype Big_Positive is BI_Ghost.Big_Positive with Ghost;
- use type BI_Ghost.Big_Integer;
-
- package Unsigned_Conversion is
- new BI_Ghost.Unsigned_Conversions (Int => Uns);
-
- function Big (Arg : Uns) return Big_Integer renames
- Unsigned_Conversion.To_Big_Integer;
-
- Big_10 : constant Big_Integer := Big (Uns'(10)) with Ghost;
-
- -- Maximum value of exponent for 10 that fits in Uns'Base
- function Max_Log10 return Natural is
- (case Uns'Base'Size is
- when 8 => 2,
- when 16 => 4,
- when 32 => 9,
- when 64 => 19,
- when 128 => 38,
- when others => raise Program_Error)
- with Ghost;
-
- function Width (Lo, Hi : Uns) return Natural
- with
- Post =>
- (declare
- W : constant Natural := System.Width_U.Width'Result;
- begin
- (if Lo > Hi then W = 0
- else W > 0
- and then W <= Max_Log10 + 2
- and then Big (Lo) < Big_10 ** (W - 1)
- and then Big (Hi) < Big_10 ** (W - 1)));
-
+ function Width (Lo, Hi : Uns) return Natural;
end System.Width_U;
diff --git a/gcc/ada/libgnat/s-widuns.ads b/gcc/ada/libgnat/s-widuns.ads
index d81b862..6ac2928 100644
--- a/gcc/ada/libgnat/s-widuns.ads
+++ b/gcc/ada/libgnat/s-widuns.ads
@@ -31,17 +31,6 @@
-- Width attribute for modular integers up to Integer
--- 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. Postconditions and
--- contract cases should not be executed at runtime as well, in order not to
--- slow down the execution of these functions.
-
-pragma Assertion_Policy (Pre => Ignore,
- Post => Ignore,
- Contract_Cases => Ignore,
- Ghost => Ignore);
-
with System.Width_U;
with System.Unsigned_Types;
diff --git a/gcc/ada/namet.adb b/gcc/ada/namet.adb
index e27669e..b7d3abd 100644
--- a/gcc/ada/namet.adb
+++ b/gcc/ada/namet.adb
@@ -1297,29 +1297,11 @@ package body Namet is
-- Present --
-------------
- function Present (Nam : File_Name_Type) return Boolean is
- begin
- return Nam /= No_File;
- end Present;
-
- -------------
- -- Present --
- -------------
-
function Present (Nam : Name_Id) return Boolean is
begin
return Nam /= No_Name;
end Present;
- -------------
- -- Present --
- -------------
-
- function Present (Nam : Unit_Name_Type) return Boolean is
- begin
- return Nam /= No_Unit_Name;
- end Present;
-
------------------
-- Reinitialize --
------------------
diff --git a/gcc/ada/namet.ads b/gcc/ada/namet.ads
index daa87d9..b05e4b5 100644
--- a/gcc/ada/namet.ads
+++ b/gcc/ada/namet.ads
@@ -504,10 +504,6 @@ package Namet is
-- Constant used to indicate no file is present (this is used for example
-- when a search for a file indicates that no file of the name exists).
- function Present (Nam : File_Name_Type) return Boolean;
- pragma Inline (Present);
- -- Determine whether file name Nam exists
-
Error_File_Name : constant File_Name_Type := File_Name_Type (Error_Name);
-- The special File_Name_Type value Error_File_Name is used to indicate
-- a unit name where some previous processing has found an error.
@@ -532,10 +528,6 @@ package Namet is
No_Unit_Name : constant Unit_Name_Type := Unit_Name_Type (No_Name);
-- Constant used to indicate no file name present
- function Present (Nam : Unit_Name_Type) return Boolean;
- pragma Inline (Present);
- -- Determine whether unit name Nam exists
-
Error_Unit_Name : constant Unit_Name_Type := Unit_Name_Type (Error_Name);
-- The special Unit_Name_Type value Error_Unit_Name is used to indicate
-- a unit name where some previous processing has found an error.
@@ -609,6 +601,7 @@ private
-- Int Value associated with this name
end record;
+ -- The aliased non-boolean components are required to match the C structure
for Name_Entry use record
Name_Chars_Index at 0 range 0 .. 31;
@@ -622,9 +615,10 @@ private
Hash_Link at 8 range 0 .. 31;
Int_Info at 12 range 0 .. 31;
end record;
+ -- This ensures a matching layout between Ada and C
for Name_Entry'Size use 16 * 8;
- -- This ensures that we did not leave out any fields
+ -- This ensures that record is reasonably small
-- This is the table that is referenced by Valid_Name_Id entries.
-- It contains one entry for each unique name in the table.
diff --git a/gcc/ada/nlists.adb b/gcc/ada/nlists.adb
index e5228f5..a018199 100644
--- a/gcc/ada/nlists.adb
+++ b/gcc/ada/nlists.adb
@@ -125,19 +125,10 @@ package body Nlists is
--------------------------
procedure Allocate_List_Tables (N : Node_Or_Entity_Id) is
- Old_Last : constant Node_Or_Entity_Id'Base := Next_Node.Last;
-
begin
- pragma Assert (N >= Old_Last);
+ pragma Assert (N >= Next_Node.Last);
Next_Node.Set_Last (N);
Prev_Node.Set_Last (N);
-
- -- Make sure we have no uninitialized junk in any new entries added.
-
- for J in Old_Last + 1 .. N loop
- Next_Node.Table (J) := Empty;
- Prev_Node.Table (J) := Empty;
- end loop;
end Allocate_List_Tables;
------------
diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads
index 687d1ed..e595b08 100644
--- a/gcc/ada/opt.ads
+++ b/gcc/ada/opt.ads
@@ -308,6 +308,10 @@ package Opt is
-- GNATMAKE
-- Set to True to check readonly files during the make process
+ Check_Semantics_Only_Mode : Boolean := False;
+ -- GNATMAKE
+ -- Set to True when -gnatc is present to only perform semantic checking.
+
Check_Source_Files : Boolean := True;
-- GNATBIND, GNATMAKE
-- Set to True to enable consistency checking for any source files that
@@ -939,6 +943,21 @@ package Opt is
-- WARNING: There is a matching C declaration of this variable in fe.h
+ List_Representation_Info_Extended : Boolean := False;
+ -- GNAT
+ -- Set true by -gnatRe switch. Causes extended information for record types
+ -- to be included in the representation output information.
+
+ List_Representation_Info_Holes : Boolean := False;
+ -- GNAT
+ -- Set true by -gnatRh switch. Causes information for holes between record
+ -- components to be included in the representation output information.
+
+ List_Representation_Info_Mechanisms : Boolean := False;
+ -- GNAT
+ -- Set true by -gnatRm switch. Causes information on mechanisms to be
+ -- included in the representation output information.
+
List_Representation_Info_To_File : Boolean := False;
-- GNAT
-- Set true by -gnatRs switch. Causes information from -gnatR[1-4]m to be
@@ -951,16 +970,6 @@ package Opt is
-- Set true by -gnatRj switch. Causes information from -gnatR[1-4]m to be
-- output in the JSON data interchange format.
- List_Representation_Info_Mechanisms : Boolean := False;
- -- GNAT
- -- Set true by -gnatRm switch. Causes information on mechanisms to be
- -- included in the representation output information.
-
- List_Representation_Info_Extended : Boolean := False;
- -- GNAT
- -- Set true by -gnatRe switch. Causes extended information for record types
- -- to be included in the representation output information.
-
List_Preprocessing_Symbols : Boolean := False;
-- GNAT, GNATPREP
-- Set to True if symbols for preprocessing a source are to be listed
@@ -1518,10 +1527,6 @@ package Opt is
-- used for inconsistency error messages. A value of System_Location is
-- used if the policy is set in package System.
- Tasking_Used : Boolean := False;
- -- Set True if any tasking construct is encountered. Used to activate the
- -- output of the Q, L and T lines in ALI files.
-
Time_Slice_Set : Boolean := False;
-- GNATBIND
-- Set True if a pragma Time_Slice is processed in the main unit, or
diff --git a/gcc/ada/osint.adb b/gcc/ada/osint.adb
index bf2affe..26b0dbb 100644
--- a/gcc/ada/osint.adb
+++ b/gcc/ada/osint.adb
@@ -64,6 +64,14 @@ package body Osint is
-- Used in Locate_File as a fake directory when Name is already an
-- absolute path.
+ procedure Get_Current_Dir
+ (Dir : System.Address; Length : System.Address);
+ pragma Import (C, Get_Current_Dir, "__gnat_get_current_dir");
+
+ Max_Path : Integer;
+ pragma Import (C, Max_Path, "__gnat_max_path_len");
+ -- Maximum length of a path name
+
-------------------------------------
-- Use of Name_Find and Name_Enter --
-------------------------------------
@@ -1426,6 +1434,24 @@ package body Osint is
Smart_Find_File (N, Source, Full_File, Attr.all);
end Full_Source_Name;
+ ---------------------
+ -- Get_Current_Dir --
+ ---------------------
+
+ function Get_Current_Dir return String is
+ Path_Len : Natural := Max_Path;
+ Buffer : String (1 .. 1 + Max_Path + 1);
+
+ begin
+ Get_Current_Dir (Buffer'Address, Path_Len'Address);
+
+ if Path_Len = 0 then
+ raise Program_Error;
+ end if;
+
+ return Buffer (1 .. Path_Len);
+ end Get_Current_Dir;
+
-------------------
-- Get_Directory --
-------------------
@@ -1517,15 +1543,6 @@ package body Osint is
(Search_Dir : String;
File_Type : Search_File_Type) return String_Ptr
is
- procedure Get_Current_Dir
- (Dir : System.Address;
- Length : System.Address);
- pragma Import (C, Get_Current_Dir, "__gnat_get_current_dir");
-
- Max_Path : Integer;
- pragma Import (C, Max_Path, "__gnat_max_path_len");
- -- Maximum length of a path name
-
Current_Dir : String_Ptr;
Default_Search_Dir : String_Access;
Default_Suffix_Dir : String_Access;
@@ -2732,6 +2749,84 @@ package body Osint is
end Read_Source_File;
-------------------
+ -- Relative_Path --
+ -------------------
+
+ function Relative_Path (Path : String; Ref : String) return String is
+ Norm_Path : constant String :=
+ Normalize_Pathname (Name => Path, Resolve_Links => False);
+ Norm_Ref : constant String :=
+ Normalize_Pathname (Name => Ref, Resolve_Links => False);
+ Rel_Path : Bounded_String;
+ Last : Natural := Norm_Ref'Last;
+ Old : Natural;
+ Depth : Natural := 0;
+
+ begin
+ pragma Assert (System.OS_Lib.Is_Absolute_Path (Norm_Path));
+ pragma Assert (System.OS_Lib.Is_Absolute_Path (Norm_Ref));
+ pragma Assert (System.OS_Lib.Is_Directory (Norm_Ref));
+
+ -- If the root drives are different on Windows then we cannot create a
+ -- relative path.
+
+ if Root (Norm_Path) /= Root (Norm_Ref) then
+ return Norm_Path;
+ end if;
+
+ if Norm_Path = Norm_Ref then
+ return ".";
+ end if;
+
+ loop
+ exit when Last - Norm_Ref'First + 1 <= Norm_Path'Length
+ and then
+ Norm_Path
+ (Norm_Path'First ..
+ Norm_Path'First + Last - Norm_Ref'First) =
+ Norm_Ref (Norm_Ref'First .. Last);
+
+ Old := Last;
+ for J in reverse Norm_Ref'First .. Last - 1 loop
+ if Is_Directory_Separator (Norm_Ref (J)) then
+ Depth := Depth + 1;
+ Last := J;
+ exit;
+ end if;
+ end loop;
+
+ if Old = Last then
+ -- No Dir_Separator in Ref... Let's return Path
+ return Norm_Path;
+ end if;
+ end loop;
+
+ -- Move up the directory chain to the common point
+
+ for I in 1 .. Depth loop
+ Append (Rel_Path, ".." & System.OS_Lib.Directory_Separator);
+ end loop;
+
+ -- Avoid starting the relative path with a directory separator
+
+ if Last < Norm_Path'Length
+ and then Is_Directory_Separator (Norm_Path (Norm_Path'First + Last))
+ then
+ Last := Last + 1;
+ end if;
+
+ -- Add the rest of the path from the common point
+
+ Append
+ (Rel_Path,
+ Norm_Path
+ (Norm_Path'First + Last - Norm_Ref'First + 1 ..
+ Norm_Path'Last));
+
+ return To_String (Rel_Path);
+ end Relative_Path;
+
+ -------------------
-- Relocate_Path --
-------------------
@@ -2788,6 +2883,25 @@ package body Osint is
return new String'(Path);
end Relocate_Path;
+ ----------
+ -- Root --
+ ----------
+
+ function Root (Path : String) return String is
+ Last : Natural := Path'First;
+ begin
+ pragma Assert (System.OS_Lib.Is_Absolute_Path (Path));
+
+ for I in Path'Range loop
+ if Is_Directory_Separator (Path (I)) then
+ Last := I;
+ exit;
+ end if;
+ end loop;
+
+ return Path (Path'First .. Last);
+ end Root;
+
-----------------
-- Set_Program --
-----------------
diff --git a/gcc/ada/osint.ads b/gcc/ada/osint.ads
index 041af41..77aaf04 100644
--- a/gcc/ada/osint.ads
+++ b/gcc/ada/osint.ads
@@ -166,6 +166,9 @@ package Osint is
function Is_Directory_Separator (C : Character) return Boolean;
-- Returns True if C is a directory separator
+ function Get_Current_Dir return String;
+ -- Returns the current working directory for the execution environment
+
function Get_Directory (Name : File_Name_Type) return File_Name_Type;
-- Get the prefix directory name (if any) from Name. The last separator
-- is preserved. Return the normalized current directory if there is no
@@ -230,6 +233,15 @@ package Osint is
(Canonical_File : String) return String_Access;
-- Convert a canonical syntax file specification to host syntax
+ function Relative_Path (Path : String; Ref : String) return String;
+ -- Given an absolute path Path calculate its relative path from a reference
+ -- directory Ref.
+ --
+ -- If the paths are the same it will return ".".
+ --
+ -- If the paths are on different drives on Windows based systems then it
+ -- will return the normalized version of Path.
+
function Relocate_Path
(Prefix : String;
Path : String) return String_Ptr;
@@ -243,6 +255,9 @@ package Osint is
-- If the above computation fails, return Path. This function assumes
-- Prefix'First = Path'First.
+ function Root (Path : String) return String;
+ -- Return the root of an absolute Path.
+
function Shared_Lib (Name : String) return String;
-- Returns the runtime shared library in the form -l<name>-<version> where
-- version is the GNAT runtime library option for the platform. For example
diff --git a/gcc/ada/par-ch13.adb b/gcc/ada/par-ch13.adb
index f52136c..dbb894f 100644
--- a/gcc/ada/par-ch13.adb
+++ b/gcc/ada/par-ch13.adb
@@ -503,6 +503,8 @@ package body Ch13 is
or else A_Id = Aspect_Refined_Depends
then
Inside_Depends := True;
+ elsif A_Id = Aspect_Abstract_State then
+ Inside_Abstract_State := True;
end if;
-- Note that we have seen an Import aspect specification.
@@ -529,9 +531,10 @@ package body Ch13 is
Set_Expression (Aspect, P_Expression);
end if;
- -- Unconditionally reset flag for Inside_Depends
+ -- Unconditionally reset flag for being inside aspects
- Inside_Depends := False;
+ Inside_Depends := False;
+ Inside_Abstract_State := False;
end if;
-- Add the aspect to the resulting list only when it was properly
diff --git a/gcc/ada/par-ch2.adb b/gcc/ada/par-ch2.adb
index 20640d55..11c9a83 100644
--- a/gcc/ada/par-ch2.adb
+++ b/gcc/ada/par-ch2.adb
@@ -385,6 +385,8 @@ package body Ch2 is
or else Chars (Ident_Node) = Name_Refined_Depends
then
Inside_Depends := True;
+ elsif Chars (Ident_Node) = Name_Abstract_State then
+ Inside_Abstract_State := True;
end if;
-- Scan arguments. We assume that arguments are present if there is
@@ -441,11 +443,11 @@ package body Ch2 is
Semicolon_Loc := Token_Ptr;
- -- Cancel indication of being within a pragma or in particular a Depends
- -- pragma.
+ -- Cancel indication of being within a pragma
- Inside_Depends := False;
- Inside_Pragma := False;
+ Inside_Depends := False;
+ Inside_Abstract_State := False;
+ Inside_Pragma := False;
-- Now we have two tasks left, we need to scan out the semicolon
-- following the pragma, and we have to call Par.Prag to process
@@ -472,8 +474,9 @@ package body Ch2 is
exception
when Error_Resync =>
Resync_Past_Semicolon;
- Inside_Depends := False;
- Inside_Pragma := False;
+ Inside_Depends := False;
+ Inside_Abstract_State := False;
+ Inside_Pragma := False;
return Error;
end P_Pragma;
diff --git a/gcc/ada/par-ch4.adb b/gcc/ada/par-ch4.adb
index ca02f1b..ebdc587 100644
--- a/gcc/ada/par-ch4.adb
+++ b/gcc/ada/par-ch4.adb
@@ -592,6 +592,20 @@ package body Ch4 is
Explicit_Actual_Parameter => Rnam));
exit;
+ -- 'Make is a special attribute that takes a variable
+ -- amount of parameters.
+
+ elsif All_Extensions_Allowed
+ and then Attr_Name = Name_Make
+ then
+ Scan;
+ Rnam := P_Expression;
+ Append_To (Expressions (Name_Node),
+ Make_Parameter_Association (Sloc (Rnam),
+ Selector_Name => Expr,
+ Explicit_Actual_Parameter => Rnam));
+ exit;
+
-- For all other cases named notation is illegal
else
@@ -654,13 +668,13 @@ package body Ch4 is
-- (discrete_range)
- -- This is a slice. This case is handled in LP_State_Init
+ -- This is a slice
-- (expression, expression, ..)
-- This is interpreted as an indexed component, i.e. as a
-- case of a name which can be extended in the normal manner.
- -- This case is handled by LP_State_Name or LP_State_Expr.
+ -- This case is handled by LP_State_Expr.
-- Note: if and case expressions (without an extra level of
-- parentheses) are permitted in this context).
@@ -921,129 +935,9 @@ package body Ch4 is
-- Error recovery: cannot raise Error_Resync
- function P_Function_Name return Node_Id is
- Designator_Node : Node_Id;
- Prefix_Node : Node_Id;
- Selector_Node : Node_Id;
- Dot_Sloc : Source_Ptr := No_Location;
-
- begin
- -- Prefix_Node is set to the gathered prefix so far, Empty means that
- -- no prefix has been scanned. This allows us to build up the result
- -- in the required right recursive manner.
-
- Prefix_Node := Empty;
-
- -- Loop through prefixes
-
- loop
- Designator_Node := Token_Node;
-
- if Token not in Token_Class_Desig then
- return P_Identifier; -- let P_Identifier issue the error message
-
- else -- Token in Token_Class_Desig
- Scan; -- past designator
- exit when Token /= Tok_Dot;
- end if;
-
- -- Here at a dot, with token just before it in Designator_Node
-
- if No (Prefix_Node) then
- Prefix_Node := Designator_Node;
- else
- Selector_Node := New_Node (N_Selected_Component, Dot_Sloc);
- Set_Prefix (Selector_Node, Prefix_Node);
- Set_Selector_Name (Selector_Node, Designator_Node);
- Prefix_Node := Selector_Node;
- end if;
-
- Dot_Sloc := Token_Ptr;
- Scan; -- past dot
- end loop;
-
- -- Fall out of the loop having just scanned a designator
-
- if No (Prefix_Node) then
- return Designator_Node;
- else
- Selector_Node := New_Node (N_Selected_Component, Dot_Sloc);
- Set_Prefix (Selector_Node, Prefix_Node);
- Set_Selector_Name (Selector_Node, Designator_Node);
- return Selector_Node;
- end if;
-
- exception
- when Error_Resync =>
- return Error;
- end P_Function_Name;
-
- -- This function parses a restricted form of Names which are either
- -- identifiers, or identifiers preceded by a sequence of prefixes
- -- that are direct names.
-
- -- Error recovery: cannot raise Error_Resync
-
function P_Qualified_Simple_Name return Node_Id is
- Designator_Node : Node_Id;
- Prefix_Node : Node_Id;
- Selector_Node : Node_Id;
- Dot_Sloc : Source_Ptr := No_Location;
-
begin
- -- Prefix node is set to the gathered prefix so far, Empty means that
- -- no prefix has been scanned. This allows us to build up the result
- -- in the required right recursive manner.
-
- Prefix_Node := Empty;
-
- -- Loop through prefixes
-
- loop
- Designator_Node := Token_Node;
-
- if Token = Tok_Identifier then
- Scan; -- past identifier
- exit when Token /= Tok_Dot;
-
- elsif Token not in Token_Class_Desig then
- return P_Identifier; -- let P_Identifier issue the error message
-
- else
- Scan; -- past designator
-
- if Token /= Tok_Dot then
- Error_Msg_SP ("identifier expected");
- return Error;
- end if;
- end if;
-
- -- Here at a dot, with token just before it in Designator_Node
-
- if No (Prefix_Node) then
- Prefix_Node := Designator_Node;
- else
- Selector_Node := New_Node (N_Selected_Component, Dot_Sloc);
- Set_Prefix (Selector_Node, Prefix_Node);
- Set_Selector_Name (Selector_Node, Designator_Node);
- Prefix_Node := Selector_Node;
- end if;
-
- Dot_Sloc := Token_Ptr;
- Scan; -- past dot
- end loop;
-
- -- Fall out of the loop having just scanned an identifier
-
- if No (Prefix_Node) then
- return Designator_Node;
- else
- Selector_Node := New_Node (N_Selected_Component, Dot_Sloc);
- Set_Prefix (Selector_Node, Prefix_Node);
- Set_Selector_Name (Selector_Node, Designator_Node);
- return Selector_Node;
- end if;
-
+ return P_Qualified_Simple_Name_Resync;
exception
when Error_Resync =>
return Error;
@@ -1062,6 +956,10 @@ package body Ch4 is
Dot_Sloc : Source_Ptr := No_Location;
begin
+ -- Prefix_Node is set to the gathered prefix so far, Empty means that
+ -- no prefix has been scanned. This allows us to build up the result
+ -- in the required right recursive manner.
+
Prefix_Node := Empty;
-- Loop through prefixes
@@ -1069,21 +967,13 @@ package body Ch4 is
loop
Designator_Node := Token_Node;
- if Token = Tok_Identifier then
- Scan; -- past identifier
- exit when Token /= Tok_Dot;
-
- elsif Token not in Token_Class_Desig then
+ if Token not in Token_Class_Desig then
Discard_Junk_Node (P_Identifier); -- to issue the error message
raise Error_Resync;
else
Scan; -- past designator
-
- if Token /= Tok_Dot then
- Error_Msg_SP ("identifier expected");
- raise Error_Resync;
- end if;
+ exit when Token /= Tok_Dot;
end if;
-- Here at a dot, with token just before it in Designator_Node
@@ -1098,7 +988,7 @@ package body Ch4 is
end if;
Dot_Sloc := Token_Ptr;
- Scan; -- past period
+ Scan; -- past dot
end loop;
-- Fall out of the loop having just scanned an identifier
@@ -1593,8 +1483,13 @@ package body Ch4 is
-- Improper use of WITH
elsif Token = Tok_With then
- Error_Msg_SC ("WITH must be preceded by single expression in " &
- "extension aggregate");
+ if Inside_Abstract_State then
+ Error_Msg_SC ("state name with options must be enclosed in " &
+ "parentheses");
+ else
+ Error_Msg_SC ("WITH must be preceded by single expression in " &
+ "extension aggregate");
+ end if;
raise Error_Resync;
-- Range attribute can only appear as part of a discrete choice list
@@ -3473,8 +3368,9 @@ package body Ch4 is
function P_Allocator return Node_Id is
Alloc_Node : Node_Id;
- Type_Node : Node_Id;
Null_Exclusion_Present : Boolean;
+ Scan_State : Saved_Scan_State;
+ Type_Node : Node_Id;
begin
Alloc_Node := New_Node (N_Allocator, Token_Ptr);
@@ -3496,6 +3392,31 @@ package body Ch4 is
Null_Exclusion_Present := P_Null_Exclusion;
Set_Null_Exclusion_Present (Alloc_Node, Null_Exclusion_Present);
+
+ -- Check for 'Make
+
+ if All_Extensions_Allowed
+ and then Token = Tok_Identifier
+ then
+ Save_Scan_State (Scan_State);
+ Type_Node := P_Qualified_Simple_Name_Resync;
+ if Token = Tok_Apostrophe then
+ Scan;
+ if Token_Name = Name_Make then
+ Restore_Scan_State (Scan_State);
+ Set_Expression
+ (Alloc_Node,
+ Make_Qualified_Expression (Token_Ptr,
+ Subtype_Mark => Check_Subtype_Mark (Type_Node),
+ Expression => P_Expression_Or_Range_Attribute));
+ return Alloc_Node;
+ end if;
+ end if;
+ Restore_Scan_State (Scan_State);
+ end if;
+
+ -- Otherwise continue parsing the subtype
+
Type_Node := P_Subtype_Mark_Resync;
if Token = Tok_Apostrophe then
diff --git a/gcc/ada/par-ch5.adb b/gcc/ada/par-ch5.adb
index a46fe44..cc0e6c1 100644
--- a/gcc/ada/par-ch5.adb
+++ b/gcc/ada/par-ch5.adb
@@ -32,6 +32,7 @@ package body Ch5 is
function P_Case_Statement return Node_Id;
function P_Case_Statement_Alternative return Node_Id;
+ function P_Continue_Statement return Node_Id;
function P_Exit_Statement return Node_Id;
function P_Goto_Statement return Node_Id;
function P_If_Statement return Node_Id;
@@ -76,6 +77,9 @@ package body Ch5 is
procedure Then_Scan;
-- Scan past THEN token, testing for illegal junk after it
+ procedure Parse_Loop_Flow_Statement (N : N_Loop_Flow_Statement_Id);
+ -- Common processing for Parse_Continue_Statement and Parse_Exit_Statement.
+
---------------------------------
-- 5.1 Sequence of Statements --
---------------------------------
@@ -511,6 +515,13 @@ package body Ch5 is
P_Assignment_Statement (Id_Node));
Statement_Required := False;
+ elsif Block_Label = Name_Continue
+ and then Token in Tok_Semicolon | Tok_When | Tok_Identifier
+ then
+ Restore_Scan_State (Scan_State_Label); -- to Id
+ Append_To (Statement_List, P_Continue_Statement);
+ Statement_Required := False;
+
-- Check common case of procedure call, another case that
-- we want to speed up as much as possible.
@@ -1899,11 +1910,11 @@ package body Ch5 is
(Block_Name : Node_Id := Empty)
return Node_Id
is
- Block_Node : Node_Id;
+ Block : Node_Id;
Created_Name : Node_Id;
begin
- Block_Node := New_Node (N_Block_Statement, Token_Ptr);
+ Block := New_Node (N_Block_Statement, Token_Ptr);
Push_Scope_Stack;
Scopes (Scope.Last).Etyp := E_Name;
@@ -1916,18 +1927,18 @@ package body Ch5 is
if No (Block_Name) then
Created_Name :=
- Make_Identifier (Sloc (Block_Node), Set_Loop_Block_Name ('B'));
+ Make_Identifier (Sloc (Block), Set_Loop_Block_Name ('B'));
Set_Comes_From_Source (Created_Name, False);
- Set_Has_Created_Identifier (Block_Node, True);
- Set_Identifier (Block_Node, Created_Name);
+ Set_Has_Created_Identifier (Block, True);
+ Set_Identifier (Block, Created_Name);
Scopes (Scope.Last).Labl := Created_Name;
else
- Set_Identifier (Block_Node, Block_Name);
+ Set_Identifier (Block, Block_Name);
end if;
- Append_Elmt (Block_Node, Label_List);
- Parse_Decls_Begin_End (Block_Node);
- return Block_Node;
+ Append_Elmt (Block, Label_List);
+ Parse_Decls_Begin_End (Block);
+ return Block;
end P_Declare_Statement;
-- P_Begin_Statement
@@ -1942,11 +1953,11 @@ package body Ch5 is
(Block_Name : Node_Id := Empty)
return Node_Id
is
- Block_Node : Node_Id;
+ Block : Node_Id;
Created_Name : Node_Id;
begin
- Block_Node := New_Node (N_Block_Statement, Token_Ptr);
+ Block := New_Node (N_Block_Statement, Token_Ptr);
Push_Scope_Stack;
Scopes (Scope.Last).Etyp := E_Name;
@@ -1957,24 +1968,24 @@ package body Ch5 is
if No (Block_Name) then
Created_Name :=
- Make_Identifier (Sloc (Block_Node), Set_Loop_Block_Name ('B'));
+ Make_Identifier (Sloc (Block), Set_Loop_Block_Name ('B'));
Set_Comes_From_Source (Created_Name, False);
- Set_Has_Created_Identifier (Block_Node, True);
- Set_Identifier (Block_Node, Created_Name);
+ Set_Has_Created_Identifier (Block, True);
+ Set_Identifier (Block, Created_Name);
Scopes (Scope.Last).Labl := Created_Name;
else
- Set_Identifier (Block_Node, Block_Name);
+ Set_Identifier (Block, Block_Name);
end if;
- Append_Elmt (Block_Node, Label_List);
+ Append_Elmt (Block, Label_List);
Scopes (Scope.Last).Ecol := Start_Column;
Scopes (Scope.Last).Sloc := Token_Ptr;
Scan; -- past BEGIN
Set_Handled_Statement_Sequence
- (Block_Node, P_Handled_Sequence_Of_Statements);
- End_Statements (Handled_Statement_Sequence (Block_Node));
- return Block_Node;
+ (Block, P_Handled_Sequence_Of_Statements);
+ End_Statements (Handled_Statement_Sequence (Block));
+ return Block;
end P_Begin_Statement;
-------------------------
@@ -1995,46 +2006,24 @@ package body Ch5 is
begin
Exit_Node := New_Node (N_Exit_Statement, Token_Ptr);
- Scan; -- past EXIT
-
- if Token = Tok_Identifier then
- Set_Name (Exit_Node, P_Qualified_Simple_Name);
-
- elsif Style_Check then
- -- This EXIT has no name, so check that
- -- the innermost loop is unnamed too.
-
- Check_No_Exit_Name :
- for J in reverse 1 .. Scope.Last loop
- if Scopes (J).Etyp = E_Loop then
- if Present (Scopes (J).Labl)
- and then Comes_From_Source (Scopes (J).Labl)
- then
- -- Innermost loop in fact had a name, style check fails
-
- Style.No_Exit_Name (Scopes (J).Labl);
- end if;
- exit Check_No_Exit_Name;
- end if;
- end loop Check_No_Exit_Name;
- end if;
+ Parse_Loop_Flow_Statement (Exit_Node);
- if Token = Tok_When and then not Missing_Semicolon_On_When then
- Scan; -- past WHEN
- Set_Condition (Exit_Node, P_Condition);
+ return Exit_Node;
+ end P_Exit_Statement;
- -- Allow IF instead of WHEN, giving error message
+ --------------------------------------
+ -- GNAT-specific Continue Statement --
+ --------------------------------------
- elsif Token = Tok_If then
- T_When;
- Scan; -- past IF used in place of WHEN
- Set_Condition (Exit_Node, P_Expression_No_Right_Paren);
- end if;
+ function P_Continue_Statement return Node_Id is
+ Continue_Node : constant Node_Id :=
+ New_Node (N_Continue_Statement, Token_Ptr);
+ begin
+ Parse_Loop_Flow_Statement (Continue_Node);
- TF_Semicolon;
- return Exit_Node;
- end P_Exit_Statement;
+ return Continue_Node;
+ end P_Continue_Statement;
-------------------------
-- 5.8 Goto Statement --
@@ -2395,4 +2384,48 @@ package body Ch5 is
end if;
end Then_Scan;
+ -------------------------------
+ -- Parse_Loop_Flow_Statement --
+ -------------------------------
+
+ procedure Parse_Loop_Flow_Statement (N : N_Loop_Flow_Statement_Id) is
+ begin
+ Scan; -- past EXIT or CONTINUE
+
+ if Token = Tok_Identifier then
+ Set_Name (N, P_Qualified_Simple_Name);
+ elsif Style_Check and then Nkind (N) = N_Exit_Statement then
+ -- This statement has no name, so check that
+ -- the innermost loop is unnamed too.
+
+ Check_No_Exit_Name :
+ for J in reverse 1 .. Scope.Last loop
+ if Scopes (J).Etyp = E_Loop then
+ if Present (Scopes (J).Labl)
+ and then Comes_From_Source (Scopes (J).Labl)
+ then
+ -- Innermost loop in fact had a name, style check fails
+
+ Style.No_Exit_Name (Scopes (J).Labl);
+ end if;
+
+ exit Check_No_Exit_Name;
+ end if;
+ end loop Check_No_Exit_Name;
+ end if;
+
+ if Token = Tok_When and then not Missing_Semicolon_On_When then
+ Scan; -- past WHEN
+ Set_Condition (N, P_Condition);
+
+ -- Allow IF instead of WHEN, giving error message
+
+ elsif Token = Tok_If then
+ T_When;
+ Scan; -- past IF used in place of WHEN
+ Set_Condition (N, P_Expression_No_Right_Paren);
+ end if;
+
+ TF_Semicolon;
+ end Parse_Loop_Flow_Statement;
end Ch5;
diff --git a/gcc/ada/par-ch6.adb b/gcc/ada/par-ch6.adb
index 55591fd..0f7765b 100644
--- a/gcc/ada/par-ch6.adb
+++ b/gcc/ada/par-ch6.adb
@@ -362,12 +362,11 @@ package body Ch6 is
if Func then
Inst_Node := New_Node (N_Function_Instantiation, Fproc_Sloc);
- Set_Name (Inst_Node, P_Function_Name);
else
Inst_Node := New_Node (N_Procedure_Instantiation, Fproc_Sloc);
- Set_Name (Inst_Node, P_Qualified_Simple_Name);
end if;
+ Set_Name (Inst_Node, P_Qualified_Simple_Name);
Set_Defining_Unit_Name (Inst_Node, Name_Node);
Set_Generic_Associations (Inst_Node, P_Generic_Actual_Part_Opt);
P_Aspect_Specifications (Inst_Node, Semicolon => True);
diff --git a/gcc/ada/par-endh.adb b/gcc/ada/par-endh.adb
index ac78b60..12baed4 100644
--- a/gcc/ada/par-endh.adb
+++ b/gcc/ada/par-endh.adb
@@ -23,12 +23,12 @@
-- --
------------------------------------------------------------------------------
+with Errid; use Errid;
with Namet.Sp; use Namet.Sp;
with Stringt; use Stringt;
with Uintp; use Uintp;
with GNAT.Spelling_Checker; use GNAT.Spelling_Checker;
-with Diagnostics.Constructors; use Diagnostics.Constructors;
separate (Par)
package body Endh is
@@ -899,6 +899,8 @@ package body Endh is
Wrong_End_Start : Source_Ptr;
Wrong_End_Finish : Source_Ptr;
+
+ Wrong_End_Span : Source_Span;
begin
-- Suppress message if this was a potentially junk entry (e.g. a record
-- entry where no record keyword was present).
@@ -936,31 +938,38 @@ package body Endh is
elsif End_Type = E_Loop then
if Error_Msg_Node_1 = Empty then
- if Debug_Flag_Underscore_DD then
-
- -- TODO: This is a quick hack to get the location of the
- -- END LOOP for the demonstration.
-
- Wrong_End_Start := Token_Ptr;
-
- while Token /= Tok_Semicolon loop
- Scan; -- past semicolon
- end loop;
-
- Wrong_End_Finish := Token_Ptr;
+ Wrong_End_Start := Token_Ptr;
- Restore_Scan_State (Scan_State);
-
- Record_End_Loop_Expected_Error
- (End_Loc => To_Span (First => Wrong_End_Start,
- Ptr => Wrong_End_Start,
- Last => Wrong_End_Finish),
- Start_Loc => Error_Msg_Sloc);
+ while Token /= Tok_Semicolon loop
+ Scan; -- past semicolon
+ end loop;
- else
- Error_Msg_SC -- CODEFIX
- ("`END LOOP;` expected@ for LOOP#!");
- end if;
+ Wrong_End_Finish := Token_Ptr;
+
+ Wrong_End_Span :=
+ To_Span
+ (First => Wrong_End_Start,
+ Ptr => Wrong_End_Start,
+ Last => Wrong_End_Finish);
+
+ Restore_Scan_State (Scan_State);
+
+ Error_Msg -- CODEFIX
+ (Msg => "`END LOOP;` expected@ for LOOP#!",
+ Flag_Span => Wrong_End_Span,
+ N => Empty,
+ Error_Code => GNAT0004,
+ Spans =>
+ (1 => Secondary_Labeled_Span (To_Span (Error_Msg_Sloc))),
+ Fixes =>
+ (1 =>
+ Fix
+ (Description => "Replace with 'end loop;'",
+ Edits =>
+ (1 =>
+ Edit
+ (Text => "end loop;",
+ Span => Wrong_End_Span)))));
else
Error_Msg_SC -- CODEFIX
("`END LOOP &;` expected@!");
diff --git a/gcc/ada/par-prag.adb b/gcc/ada/par-prag.adb
index 6efb16d..4d0ffe6 100644
--- a/gcc/ada/par-prag.adb
+++ b/gcc/ada/par-prag.adb
@@ -1548,6 +1548,7 @@ begin
| Pragma_Priority_Specific_Dispatching
| Pragma_Profile
| Pragma_Profile_Warnings
+ | Pragma_Program_Exit
| Pragma_Propagate_Exceptions
| Pragma_Provide_Shift_Operators
| Pragma_Psect_Object
diff --git a/gcc/ada/par-util.adb b/gcc/ada/par-util.adb
index 53b57e4..78a76b3 100644
--- a/gcc/ada/par-util.adb
+++ b/gcc/ada/par-util.adb
@@ -176,14 +176,17 @@ package body Util is
procedure Check_Future_Keyword is
begin
-- Ada 2005 (AI-284): Compiling in Ada 95 mode we warn that INTERFACE,
- -- OVERRIDING, and SYNCHRONIZED are new reserved words.
+ -- OVERRIDING, and SYNCHRONIZED are new reserved words. We make an
+ -- exception if INTERFACE is used in the context of the GNAT-specific
+ -- pragma Interface, since we accept that pragma regardless of the Ada
+ -- version.
if Ada_Version = Ada_95
and then Warn_On_Ada_2005_Compatibility
then
- if Token_Name in Name_Overriding | Name_Synchronized
- or else (Token_Name = Name_Interface
- and then Prev_Token /= Tok_Pragma)
+ if Token_Name in Ada_2005_Reserved_Words
+ and then not (Token_Name = Name_Interface
+ and then Prev_Token = Tok_Pragma)
then
Error_Msg_N ("& is a reserved word in Ada 2005?y?", Token_Node);
end if;
@@ -194,13 +197,13 @@ package body Util is
if Ada_Version in Ada_95 .. Ada_2005
and then Warn_On_Ada_2012_Compatibility
then
- if Token_Name = Name_Some then
+ if Token_Name in Ada_2012_Reserved_Words then
Error_Msg_N ("& is a reserved word in Ada 2012?y?", Token_Node);
end if;
end if;
if Ada_Version < Ada_With_All_Extensions then
- if Token_Name = Name_Finally then
+ if Token_Name in GNAT_Extensions_Reserved_Words then
Error_Msg_N
("& is a reserved word with all extensions enabled?",
Token_Node);
diff --git a/gcc/ada/par.adb b/gcc/ada/par.adb
index 5d61fac..e11ec7e 100644
--- a/gcc/ada/par.adb
+++ b/gcc/ada/par.adb
@@ -80,6 +80,11 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is
-- True within a delta aggregate (but only after the "delta" token has
-- been scanned). Used to distinguish syntax errors from syntactically
-- correct "deep" delta aggregates (enabled via -gnatX0).
+
+ Inside_Abstract_State : Boolean := False;
+ -- True within an Abstract_State contract. Used to distinguish syntax error
+ -- about extended aggregates and about a malformed contract.
+
Save_Style_Checks : Style_Check_Options;
Save_Style_Check : Boolean;
-- Variables for storing the original state of whether style checks should
@@ -825,7 +830,6 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is
function P_Aggregate return Node_Id;
function P_Expression return Node_Id;
function P_Expression_Or_Range_Attribute return Node_Id;
- function P_Function_Name return Node_Id;
function P_Name return Node_Id;
function P_Qualified_Simple_Name return Node_Id;
function P_Qualified_Simple_Name_Resync return Node_Id;
diff --git a/gcc/ada/prepcomp.adb b/gcc/ada/prepcomp.adb
index ea7760a..35dd4cb 100644
--- a/gcc/ada/prepcomp.adb
+++ b/gcc/ada/prepcomp.adb
@@ -545,7 +545,7 @@ package body Prepcomp is
if Total_Errors_Detected > T then
Errout.Finalize (Last_Call => True);
- Errout.Output_Messages;
+ Errout.Output_Messages (E_Fatal);
Fail ("errors found in preprocessing data file """
& Get_Name_String (N) & """");
end if;
@@ -668,7 +668,7 @@ package body Prepcomp is
if T /= Total_Errors_Detected then
Errout.Finalize (Last_Call => True);
- Errout.Output_Messages;
+ Errout.Output_Messages (E_Fatal);
Fail ("errors found in definition file """
& Get_Name_String (N)
& """");
diff --git a/gcc/ada/repinfo.adb b/gcc/ada/repinfo.adb
index cd4b664..1d616db 100644
--- a/gcc/ada/repinfo.adb
+++ b/gcc/ada/repinfo.adb
@@ -30,6 +30,7 @@ with Debug; use Debug;
with Einfo; use Einfo;
with Einfo.Entities; use Einfo.Entities;
with Einfo.Utils; use Einfo.Utils;
+with GNAT.Heap_Sort_G;
with Lib; use Lib;
with Namet; use Namet;
with Nlists; use Nlists;
@@ -77,20 +78,6 @@ package body Repinfo is
Op3 : Node_Ref_Or_Val;
end record;
- -- The following representation clause ensures that the above record
- -- has no holes. We do this so that when instances of this record are
- -- written, we do not write uninitialized values to the file.
-
- for Exp_Node use record
- Expr at 0 range 0 .. 31;
- Op1 at 4 range 0 .. 31;
- Op2 at 8 range 0 .. 31;
- Op3 at 12 range 0 .. 31;
- end record;
-
- for Exp_Node'Size use 16 * 8;
- -- This ensures that we did not leave out any fields
-
package Rep_Table is new Table.Table (
Table_Component_Type => Exp_Node,
Table_Index_Type => Nat,
@@ -427,9 +414,9 @@ package body Repinfo is
Write_Line (";");
end if;
- -- Alignment is not always set for task, protected, and class-wide
- -- types, or when doing semantic analysis only. Representation aspects
- -- are not computed for types in a generic unit.
+ -- Alignment is not always set for concurrent types, class-wide types,
+ -- cloned subtypes, or when doing semantic analysis only. Representation
+ -- aspects are not computed for types declared in a generic unit.
else
-- Add unknown alignment entry in JSON format to ensure the format is
@@ -440,11 +427,13 @@ package body Repinfo is
Write_Unknown_Val;
end if;
- pragma Assert
- (not Expander_Active or else
- Is_Concurrent_Type (Ent) or else
- Is_Class_Wide_Type (Ent) or else
- Sem_Util.In_Generic_Scope (Ent));
+ pragma Assert (not Expander_Active
+ or else Is_Concurrent_Type (Ent)
+ or else Is_Class_Wide_Type (Ent)
+ or else (Ekind (Ent) = E_Record_Subtype
+ and then Present (Cloned_Subtype (Ent))
+ and then Has_Delayed_Freeze (Cloned_Subtype (Ent)))
+ or else Sem_Util.In_Generic_Scope (Ent));
end if;
end List_Common_Type_Info;
@@ -544,11 +533,13 @@ package body Repinfo is
List_Type_Info (E);
end if;
- -- Note that formals are not annotated so we skip them here
+ -- Formals and renamings are not annotated, so we skip them
+ -- here.
elsif Ekind (E) in E_Constant
| E_Loop_Parameter
| E_Variable
+ and then Nkind (Parent (E)) /= N_Object_Renaming_Declaration
then
if List_Representation_Info >= 2 then
List_Object_Info (E);
@@ -870,8 +861,7 @@ package body Repinfo is
-- generic unit, or if the back end is not being run), don't try to
-- print them.
- pragma Assert (Known_Esize (Ent) = Known_Alignment (Ent));
- if not Known_Alignment (Ent) then
+ if not Known_Esize (Ent) or else not Known_Alignment (Ent) then
return;
end if;
@@ -896,6 +886,7 @@ package body Repinfo is
Write_Eol;
Write_Line ("}");
+
else
Write_Str ("for ");
List_Name (Ent);
@@ -1237,11 +1228,135 @@ package body Repinfo is
Starting_First_Bit : Uint := Uint_0;
Prefix : String := "")
is
- Comp : Entity_Id;
- First : Boolean := True;
+ function First_Comp_Or_Discr (Ent : Entity_Id) return Entity_Id;
+ -- Like First_Component_Or_Discriminant, but reorder the components
+ -- according to their bit offset if need be.
+
+ -------------------------
+ -- First_Comp_Or_Discr --
+ -------------------------
+
+ function First_Comp_Or_Discr (Ent : Entity_Id) return Entity_Id is
+
+ function Is_Placed_Before (C1, C2 : Entity_Id) return Boolean;
+ -- Return True if component C1 is placed before component C2
+
+ ----------------------
+ -- Is_Placed_Before --
+ ----------------------
+
+ function Is_Placed_Before (C1, C2 : Entity_Id) return Boolean is
+ begin
+ return Known_Static_Component_Bit_Offset (C1)
+ and then Known_Static_Component_Bit_Offset (C2)
+ and then
+ Component_Bit_Offset (C1) < Component_Bit_Offset (C2);
+ end Is_Placed_Before;
+
+ -- Local variables
+
+ Comp : Entity_Id;
+ N_Comp : Natural := 0;
+ Prev : Entity_Id;
+ Reorder : Boolean := False;
+
+ -- Start of processing for First_Comp_Or_Discr
+
+ begin
+ -- Reordering is needed only for -gnatRh
+
+ if not List_Representation_Info_Holes then
+ return First_Component_Or_Discriminant (Ent);
+ end if;
+
+ -- Count the number of components and whether reordering is needed
+
+ Comp := First_Component_Or_Discriminant (Ent);
+ Prev := Comp;
+
+ while Present (Comp) loop
+ N_Comp := N_Comp + 1;
+
+ if not Reorder then
+ Reorder := Is_Placed_Before (Comp, Prev);
+ end if;
+
+ Prev := Comp;
+ Next_Component_Or_Discriminant (Comp);
+ end loop;
+
+ -- Reorder the components, if need be, by directly reshuffling the
+ -- list of entities between First_Entity and Last_Entity, which is
+ -- safe because we are invoked after compilation is finished.
+
+ if Reorder then
+ declare
+ Comps : array (Natural range 0 .. N_Comp) of Entity_Id;
+ -- Support array for the heapsort
+
+ function Lt (Op1, Op2 : Natural) return Boolean is
+ (Is_Placed_Before (Comps (Op1), Comps (Op2)));
+ -- Compare function for the heapsort
+
+ procedure Move (From : Natural; To : Natural);
+ pragma Inline (Move);
+ -- Move procedure for the heapsort
+
+ ----------
+ -- Move --
+ ----------
+
+ procedure Move (From : Natural; To : Natural) is
+ begin
+ Comps (To) := Comps (From);
+ end Move;
+
+ package HS is new GNAT.Heap_Sort_G (Lt => Lt, Move => Move);
+ -- The heapsort for record components
+
+ begin
+ -- Pack the components into the array
+
+ N_Comp := 0;
+ Comp := First_Component_Or_Discriminant (Ent);
+
+ while Present (Comp) loop
+ N_Comp := N_Comp + 1;
+ Comps (N_Comp) := Comp;
+
+ Next_Component_Or_Discriminant (Comp);
+ end loop;
+
+ -- Sort the array
+
+ HS.Sort (N_Comp);
+
+ -- Unpack the component into the list of entities
+
+ Set_First_Entity (Ent, Comps (1));
+ Set_Prev_Entity (Comps (1), Empty);
+ for J in 1 .. N_Comp - 1 loop
+ Set_Next_Entity (Comps (J), Comps (J + 1));
+ Set_Prev_Entity (Comps (J + 1), Comps (J));
+ end loop;
+ Set_Next_Entity (Comps (N_Comp), Empty);
+ Set_Last_Entity (Ent, Comps (N_Comp));
+ end;
+ end if;
+
+ return First_Component_Or_Discriminant (Ent);
+ end First_Comp_Or_Discr;
+
+ -- Local variables
+
+ Bit_Offset : Uint := Uint_0;
+ Comp : Entity_Id;
+ First : Boolean := True;
+
+ -- Start of processing for List_Record_Layout
begin
- Comp := First_Component_Or_Discriminant (Ent);
+ Comp := First_Comp_Or_Discr (Ent);
while Present (Comp) loop
-- Skip a completely hidden discriminant or a discriminant in an
@@ -1251,69 +1366,98 @@ package body Repinfo is
and then (Is_Completely_Hidden (Comp)
or else Is_Unchecked_Union (Ent))
then
- goto Continue;
- end if;
+ null;
-- Skip _Parent component in extension (to avoid overlap)
- if Chars (Comp) = Name_uParent then
- goto Continue;
- end if;
+ elsif Chars (Comp) = Name_uParent then
+ null;
-- All other cases
- declare
- Ctyp : constant Entity_Id := Underlying_Type (Etype (Comp));
- Npos : constant Uint := Normalized_Position (Comp);
- Fbit : constant Uint := Normalized_First_Bit (Comp);
- Spos : Uint;
- Sbit : Uint;
+ else
+ declare
+ C : constant Entity_Id :=
+ (if Known_Normalized_Position (Comp)
+ then Comp
+ else Original_Record_Component (Comp));
+ -- The Parent_Subtype in an extension is not back-annotated
+ -- but its layout is the same as that of the parent type.
- begin
- Get_Decoded_Name_String (Chars (Comp));
- Set_Casing (Unit_Casing);
+ Ctyp : constant Entity_Id := Underlying_Type (Etype (C));
- -- If extended information is requested, recurse fully into
- -- record components, i.e. skip the outer level.
+ begin
+ Get_Decoded_Name_String (Chars (C));
+ Set_Casing (Unit_Casing);
- if List_Representation_Info_Extended
- and then Is_Record_Type (Ctyp)
- and then Known_Static_Normalized_Position (Comp)
- and then Known_Static_Normalized_First_Bit (Comp)
- then
- Spos := Starting_Position + Npos;
- Sbit := Starting_First_Bit + Fbit;
+ -- If extended information is requested, recurse fully into
+ -- record components, i.e. skip the outer level.
- if Sbit >= SSU then
- Spos := Spos + 1;
- Sbit := Sbit - SSU;
- end if;
+ if List_Representation_Info_Extended
+ and then Is_Record_Type (Ctyp)
+ and then Known_Static_Normalized_Position (C)
+ and then Known_Static_Normalized_First_Bit (C)
+ then
+ declare
+ Npos : constant Uint := Normalized_Position (C);
+ Fbit : constant Uint := Normalized_First_Bit (C);
+ Pref : constant String :=
+ Prefix & Name_Buffer (1 .. Name_Len) & ".";
- List_Record_Layout (Ctyp,
- Spos, Sbit, Prefix & Name_Buffer (1 .. Name_Len) & ".");
+ Spos : Uint;
+ Sbit : Uint;
- goto Continue;
- end if;
+ begin
+ Spos := Starting_Position + Npos;
+ Sbit := Starting_First_Bit + Fbit;
+
+ if Sbit >= SSU then
+ Spos := Spos + 1;
+ Sbit := Sbit - SSU;
+ end if;
+
+ List_Record_Layout (Ctyp, Spos, Sbit, Pref);
+ end;
- if List_Representation_Info_To_JSON then
- if First then
- Write_Eol;
- First := False;
else
- Write_Line (",");
- end if;
- end if;
+ if List_Representation_Info_To_JSON then
+ if First then
+ Write_Eol;
+ First := False;
+ else
+ Write_Line (",");
+ end if;
+ end if;
- -- The Parent_Subtype in an extension is not back-annotated
+ -- If information about holes is requested, update the
+ -- current bit offset and report any (static) gap.
- List_Component_Layout (
- (if Known_Normalized_Position (Comp)
- then Comp
- else Original_Record_Component (Comp)),
- Starting_Position, Starting_First_Bit, Prefix);
- end;
+ if List_Representation_Info_Holes
+ and then Known_Static_Component_Bit_Offset (C)
+ then
+ declare
+ Gap : constant Uint :=
+ Component_Bit_Offset (C) - Bit_Offset;
+ begin
+ if Gap > Uint_0 then
+ Write_Str (" -- ");
+ UI_Write (Gap, Decimal);
+ Write_Line (" bits unused --");
+ end if;
+
+ if Known_Static_Esize (C) then
+ Bit_Offset :=
+ Component_Bit_Offset (C) + Esize (C);
+ end if;
+ end;
+ end if;
+
+ List_Component_Layout
+ (C, Starting_Position, Starting_First_Bit, Prefix);
+ end if;
+ end;
+ end if;
- <<Continue>>
Next_Component_Or_Discriminant (Comp);
end loop;
end List_Record_Layout;
@@ -1624,6 +1768,17 @@ package body Repinfo is
end loop;
end List_Structural_Record_Layout;
+ -- Use the original record type giving the layout of components
+ -- to avoid repeated reordering when -gnatRh is specified.
+
+ Rec : constant Entity_Id :=
+ (if Ekind (Ent) = E_Record_Subtype
+ and then Present (Cloned_Subtype (Ent))
+ then (if Is_Private_Type (Cloned_Subtype (Ent))
+ then Full_View (Cloned_Subtype (Ent))
+ else Cloned_Subtype (Ent))
+ else Ent);
+
-- Start of processing for List_Record_Info
begin
@@ -1638,7 +1793,7 @@ package body Repinfo is
-- First find out max line length and max starting position
-- length, for the purpose of lining things up nicely.
- Compute_Max_Length (Ent);
+ Compute_Max_Length (Rec);
-- Then do actual output based on those values
@@ -1650,21 +1805,21 @@ package body Repinfo is
-- declared in the extended main source unit for the time being,
-- because otherwise declarations might not be processed at all.
- if Is_Base_Type (Ent) then
+ if Is_Base_Type (Rec) then
begin
- List_Structural_Record_Layout (Ent, Ent);
+ List_Structural_Record_Layout (Rec, Rec);
exception
when Incomplete_Layout
| Not_In_Extended_Main
=>
- List_Record_Layout (Ent);
+ List_Record_Layout (Rec);
when others =>
raise Program_Error;
end;
else
- List_Record_Layout (Ent);
+ List_Record_Layout (Rec);
end if;
Write_Eol;
@@ -1674,7 +1829,7 @@ package body Repinfo is
List_Name (Ent);
Write_Line (" use record");
- List_Record_Layout (Ent);
+ List_Record_Layout (Rec);
Write_Line ("end record;");
end if;
diff --git a/gcc/ada/rtsfind.adb b/gcc/ada/rtsfind.adb
index 70a6f12..86713ff 100644
--- a/gcc/ada/rtsfind.adb
+++ b/gcc/ada/rtsfind.adb
@@ -566,11 +566,11 @@ package body Rtsfind is
subtype Ada_Numerics_Descendant is Ada_Descendant
range Ada_Numerics_Big_Numbers ..
- Ada_Numerics_Big_Numbers_Big_Integers_Ghost;
+ Ada_Numerics_Big_Numbers_Big_Integers;
subtype Ada_Numerics_Big_Numbers_Descendant is Ada_Descendant
range Ada_Numerics_Big_Numbers_Big_Integers ..
- Ada_Numerics_Big_Numbers_Big_Integers_Ghost;
+ Ada_Numerics_Big_Numbers_Big_Integers;
subtype Ada_Real_Time_Descendant is Ada_Descendant
range Ada_Real_Time_Delays .. Ada_Real_Time_Timing_Events;
diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads
index d57d4fa..37ed22b1 100644
--- a/gcc/ada/rtsfind.ads
+++ b/gcc/ada/rtsfind.ads
@@ -121,7 +121,6 @@ package Rtsfind is
-- Children of Ada.Numerics.Big_Numbers
Ada_Numerics_Big_Numbers_Big_Integers,
- Ada_Numerics_Big_Numbers_Big_Integers_Ghost,
-- Children of Ada.Real_Time
@@ -582,7 +581,6 @@ package Rtsfind is
RE_Reference, -- Ada.Interrupts
RE_Big_Integer, -- Ada.Numerics.Big_Numbers.Big_Integers
- RO_GH_Big_Integer, -- Ada.Numerics.Big_Numbers.Big_Integers_Ghost
RO_SP_Big_Integer, -- SPARK.Big_Integers
RE_Names, -- Ada.Interrupts.Names
@@ -2231,7 +2229,6 @@ package Rtsfind is
RE_Reference => Ada_Interrupts,
RE_Big_Integer => Ada_Numerics_Big_Numbers_Big_Integers,
- RO_GH_Big_Integer => Ada_Numerics_Big_Numbers_Big_Integers_Ghost,
RO_SP_Big_Integer => SPARK_Big_Integers,
RE_Names => Ada_Interrupts_Names,
diff --git a/gcc/ada/scos.ads b/gcc/ada/scos.ads
index a2ade8a..b5f39c9 100644
--- a/gcc/ada/scos.ads
+++ b/gcc/ada/scos.ads
@@ -28,9 +28,6 @@
-- the ALI file, and by Get_SCO/Put_SCO to read and write the text form that
-- is used in the ALI file.
--- WARNING: There is a C version of this package. Any changes to this
--- source file must be properly reflected in the C header file scos.h
-
with Namet; use Namet;
with Table;
with Types; use Types;
diff --git a/gcc/ada/scos.h b/gcc/ada/scos.h
deleted file mode 100644
index 3d800bf..0000000
--- a/gcc/ada/scos.h
+++ /dev/null
@@ -1,89 +0,0 @@
-/****************************************************************************
- * *
- * GNAT COMPILER COMPONENTS *
- * *
- * S C O S *
- * *
- * C Header File *
- * *
- * Copyright (C) 2014-2025, Free Software Foundation, Inc. *
- * *
- * GNAT is 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 C header that corresponds to the Ada package specification for
- Scos. It was created manually from scos.ads and must be kept synchronized
- with changes in this file. */
-
-#ifdef __cplusplus
-extern "C" {
-#endif
-
-
-/* Unit table: */
-
-typedef Int SCO_Unit_Index;
-
-struct SCO_Unit_Table_Entry
- {
- String_Pointer File_Name;
- Int File_Index;
- Nat Dep_Num;
- Nat From, To;
- };
-
-typedef struct SCO_Unit_Table_Entry *SCO_Unit_Table_Type;
-
-extern SCO_Unit_Table_Type scos__sco_unit_table__table;
-#define SCO_Unit_Table scos__sco_unit_table__table
-
-extern Int scos__sco_unit_table__min;
-#define SCO_Unit_Table_Min scos__sco_unit_table__min
-
-extern Int scos__sco_unit_table__last_val;
-#define SCO_Unit_Table_Last_Val scos__sco_unit_table__last_val
-
-
-/* SCOs table: */
-
-struct Source_Location
- {
- Line_Number_Type Line;
- Column_Number_Type Col;
- };
-
-struct SCO_Table_Entry
- {
- struct Source_Location From, To;
- char C1, C2;
- bool Last;
- Source_Ptr Pragma_Sloc;
- Name_Id Pragma_Aspect_Name;
- };
-
-typedef struct SCO_Table_Entry *SCO_Table_Type;
-
-extern SCO_Table_Type scos__sco_table__table;
-#define SCO_Table scos__sco_table__table
-
-extern Int scos__sco_table__min;
-#define SCO_Table_Min scos__sco_table__min
-
-extern Int scos__sco_table__last_val;
-#define SCO_Table_Last_Val scos__sco_table__last_val
-
-#ifdef __cplusplus
-}
-#endif
diff --git a/gcc/ada/sem.adb b/gcc/ada/sem.adb
index 06df00e..dcff62e 100644
--- a/gcc/ada/sem.adb
+++ b/gcc/ada/sem.adb
@@ -192,6 +192,9 @@ package body Sem is
when N_Conditional_Entry_Call =>
Analyze_Conditional_Entry_Call (N);
+ when N_Continue_Statement =>
+ Analyze_Continue_Statement (N);
+
when N_Delay_Alternative =>
Analyze_Delay_Alternative (N);
@@ -765,12 +768,11 @@ package body Sem is
E : constant Entity_Id := Defining_Entity_Or_Empty (N);
begin
if Present (E) then
- if Ekind (E) = E_Void
- and then Nkind (N) = N_Component_Declaration
+ if Nkind (N) = N_Component_Declaration
and then Present (Scope (E))
and then Ekind (Scope (E)) = E_Record_Type
then
- null; -- Set it later, in Analyze_Component_Declaration
+ null; -- Set it later, in Record_Type_Definition
elsif not Is_Not_Self_Hidden (E) then
Set_Is_Not_Self_Hidden (E);
end if;
diff --git a/gcc/ada/sem.ads b/gcc/ada/sem.ads
index f8a67a9..6113097 100644
--- a/gcc/ada/sem.ads
+++ b/gcc/ada/sem.ads
@@ -109,7 +109,7 @@
-- pragmas that appear with subprogram specifications rather than in the body.
-- Collectively we call these Spec_Expressions. The routine that performs the
--- special analysis is called Preanalyze_Spec_Expression.
+-- special analysis is called Preanalyze_And_Resolve_Spec_Expression.
-- Expansion has to be deferred since you can't generate code for expressions
-- that reference types that have not been frozen yet. As an example, consider
@@ -198,11 +198,11 @@
-- strict preanalysis of other expressions is that we do carry out freezing
-- in the former (for static scalar expressions) but not in the latter. The
-- routine that performs preanalysis of default expressions is called
--- Preanalyze_Spec_Expression and is in Sem_Ch3. The routine that performs
--- strict preanalysis and corresponding resolution is in Sem_Res and it is
--- called Preanalyze_And_Resolve. Preanalyze_Spec_Expression relaxes the
--- strictness of Preanalyze_And_Resolve setting to True the global boolean
--- variable In_Spec_Expression before calling Preanalyze_And_Resolve.
+-- Preanalyze_And_Resolve_Spec_Expression and is in Sem_Ch3. The routine that
+-- performs strict preanalysis and corresponding resolution is in Sem_Res and
+-- it is called Preanalyze_And_Resolve. Preanalyze_And_Resolve_Spec_Expression
+-- relaxes the strictness of Preanalyze_And_Resolve setting to True the global
+-- boolean variable In_Spec_Expression before calling Preanalyze_And_Resolve.
with Alloc;
with Einfo.Entities; use Einfo.Entities;
diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb
index a7ec772..58460b8 100644
--- a/gcc/ada/sem_aggr.adb
+++ b/gcc/ada/sem_aggr.adb
@@ -26,11 +26,10 @@
with Aspects; use Aspects;
with Atree; use Atree;
with Checks; use Checks;
-with Debug; use Debug;
-with Diagnostics.Constructors; use Diagnostics.Constructors;
with Einfo; use Einfo;
with Einfo.Utils; use Einfo.Utils;
with Elists; use Elists;
+with Errid; use Errid;
with Errout; use Errout;
with Expander; use Expander;
with Exp_Tss; use Exp_Tss;
@@ -4038,22 +4037,25 @@ package body Sem_Aggr is
if Present (First (Expressions (N)))
and then Present (First (Component_Associations (N)))
then
- if Debug_Flag_Underscore_DD then
- Record_Mixed_Container_Aggregate_Error
- (Aggr => N,
- Pos_Elem => First (Expressions (N)),
- Named_Elem => First (Component_Associations (N)));
- else
- Error_Msg_N
- ("container aggregate cannot be both positional and named", N);
- end if;
+ Error_Msg_N
+ (Msg =>
+ "container aggregate cannot be both positional and named",
+ N => N,
+ Error_Code => GNAT0006,
+ Spans =>
+ (1 =>
+ Secondary_Labeled_Span
+ (First (Expressions (N)), "positional element "),
+ 2 =>
+ Secondary_Labeled_Span
+ (First (Component_Associations (N)), "named element")));
return;
end if;
if Present (Add_Unnamed_Subp)
and then No (New_Indexed_Subp)
- and then Present (Etype (Add_Unnamed_Subp))
- and then Etype (Add_Unnamed_Subp) /= Any_Type
+ and then Present (Entity (Add_Unnamed_Subp))
+ and then Entity (Add_Unnamed_Subp) /= Any_Id
then
declare
Elmt_Type : constant Entity_Id :=
@@ -4099,7 +4101,8 @@ package body Sem_Aggr is
end;
elsif Present (Add_Named_Subp)
- and then Etype (Add_Named_Subp) /= Any_Type
+ and then Present (Entity (Add_Named_Subp))
+ and then Entity (Add_Named_Subp) /= Any_Id
then
declare
-- Retrieves types of container, key, and element from the
@@ -4153,7 +4156,8 @@ package body Sem_Aggr is
end;
elsif Present (Assign_Indexed_Subp)
- and then Etype (Assign_Indexed_Subp) /= Any_Type
+ and then Present (Entity (Assign_Indexed_Subp))
+ and then Entity (Assign_Indexed_Subp) /= Any_Id
then
-- Indexed Aggregate. Positional or indexed component
-- can be present, but not both. Choices must be static
@@ -6351,7 +6355,12 @@ package body Sem_Aggr is
& "has unknown discriminants", N, Typ);
end if;
- if Has_Unknown_Discriminants (Typ)
+ -- Mutably tagged class-wide types do not have discriminants;
+ -- however, all class-wide types are considered to have unknown
+ -- discriminants.
+
+ if not Is_Mutably_Tagged_Type (Typ)
+ and then Has_Unknown_Discriminants (Typ)
and then Present (Underlying_Record_View (Typ))
then
Discrim := First_Discriminant (Underlying_Record_View (Typ));
@@ -6423,7 +6432,13 @@ package body Sem_Aggr is
-- STEP 4: Set the Etype of the record aggregate
if Has_Discriminants (Typ)
- or else (Has_Unknown_Discriminants (Typ)
+
+ -- Handle types with unknown discriminants, excluding mutably tagged
+ -- class-wide types because, although they do not have discriminants,
+ -- all class-wide types are considered to have unknown discriminants.
+
+ or else (not Is_Mutably_Tagged_Type (Typ)
+ and then Has_Unknown_Discriminants (Typ)
and then Present (Underlying_Record_View (Typ)))
then
Build_Constrained_Itype (N, Typ, New_Assoc_List);
@@ -6594,7 +6609,13 @@ package body Sem_Aggr is
if Null_Present (Record_Def) then
null;
- elsif not Has_Unknown_Discriminants (Typ) then
+ -- Explicitly add here mutably class-wide types because they do
+ -- not have discriminants; however, all class-wide types are
+ -- considered to have unknown discriminants.
+
+ elsif not Has_Unknown_Discriminants (Typ)
+ or else Is_Mutably_Tagged_Type (Typ)
+ then
Gather_Components
(Base_Type (Typ),
Component_List (Record_Def),
@@ -6780,6 +6801,11 @@ package body Sem_Aggr is
Set_Has_Self_Reference (N);
elsif Needs_Simple_Initialization (Ctyp)
+
+ -- Mutably tagged class-wide type components are initialized
+ -- by the expander calling their IP subprogram.
+
+ or else Is_Mutably_Tagged_CW_Equivalent_Type (Ctyp)
or else Has_Non_Null_Base_Init_Proc (Ctyp)
or else not Expander_Active
then
@@ -6984,6 +7010,30 @@ package body Sem_Aggr is
-- Check the dimensions of the components in the record aggregate
Analyze_Dimension_Extension_Or_Record_Aggregate (N);
+
+ -- Do a pass for constructors which rely on things being fully expanded
+
+ declare
+ function Resolve_Make_Expr (N : Node_Id) return Traverse_Result;
+ -- Recurse in the aggregate and resolve references to 'Make
+
+ function Resolve_Make_Expr (N : Node_Id) return Traverse_Result is
+ begin
+ if Nkind (N) = N_Attribute_Reference
+ and then Attribute_Name (N) = Name_Make
+ then
+ Set_Analyzed (N, False);
+ Resolve (N);
+ end if;
+
+ return OK;
+ end Resolve_Make_Expr;
+
+ procedure Search_And_Resolve_Make_Expr is new
+ Traverse_Proc (Resolve_Make_Expr);
+ begin
+ Search_And_Resolve_Make_Expr (N);
+ end;
end Resolve_Record_Aggregate;
-----------------------------
diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb
index af08fdb..4f5047f 100644
--- a/gcc/ada/sem_attr.adb
+++ b/gcc/ada/sem_attr.adb
@@ -1462,6 +1462,13 @@ package body Sem_Attr is
then
null;
+ -- Attribute 'Old is allowed to appear in Program_Exit
+
+ elsif Prag_Nam = Name_Program_Exit
+ and then Aname = Name_Old
+ then
+ null;
+
elsif Prag_Nam = Name_Test_Case then
Check_Placement_In_Test_Case (Prag);
@@ -3317,7 +3324,7 @@ package body Sem_Attr is
E1 := Empty;
E2 := Empty;
- else
+ elsif Aname /= Name_Make then
E1 := First (Exprs);
-- Skip analysis for case of Restriction_Set, we do not expect
@@ -5164,6 +5171,36 @@ package body Sem_Attr is
Check_Not_Incomplete_Type;
Set_Etype (N, Universal_Integer);
+ ----------
+ -- Make --
+ ----------
+
+ when Attribute_Make => declare
+ Expr : Entity_Id;
+ begin
+ -- Should this be assert? Parsing should fail if it hits 'Make
+ -- and all extensions aren't enabled ???
+
+ if not All_Extensions_Allowed then
+ return;
+ end if;
+
+ Set_Etype (N, Etype (P));
+
+ if Present (Expressions (N)) then
+ Expr := First (Expressions (N));
+ while Present (Expr) loop
+ if Nkind (Expr) = N_Parameter_Association then
+ Analyze (Explicit_Actual_Parameter (Expr));
+ else
+ Analyze (Expr);
+ end if;
+
+ Next (Expr);
+ end loop;
+ end if;
+ end;
+
--------------
-- Mantissa --
--------------
@@ -5656,19 +5693,15 @@ package body Sem_Attr is
when Attribute_Partition_ID =>
Check_E0;
- if P_Type /= Any_Type then
- if not Is_Library_Level_Entity (Entity (P)) then
- Error_Attr_P
- ("prefix of % attribute must be library-level entity");
+ if not Is_Library_Level_Entity (Entity (P)) then
+ Error_Attr_P
+ ("prefix of % attribute must be library-level entity");
- -- The defining entity of prefix should not be declared inside a
- -- Pure unit. RM E.1(8). Is_Pure was set during declaration.
+ -- The defining entity of prefix should not be declared inside a
+ -- Pure unit. RM E.1(8). Is_Pure was set during declaration.
- elsif Is_Entity_Name (P)
- and then Is_Pure (Entity (P))
- then
- Error_Attr_P ("prefix of% attribute must not be declared pure");
- end if;
+ elsif Is_Entity_Name (P) and then Is_Pure (Entity (P)) then
+ Error_Attr_P ("prefix of% attribute must not be declared pure");
end if;
Set_Etype (N, Universal_Integer);
@@ -7511,13 +7544,14 @@ package body Sem_Attr is
Set_Etype (N, Standard_Boolean);
Validate_Non_Static_Attribute_Function_Call;
- if P_Type in Standard_Boolean
+ if Root_Type (P_Type) in Standard_Boolean
| Standard_Character
| Standard_Wide_Character
| Standard_Wide_Wide_Character
then
Error_Attr_P
- ("prefix of % attribute must not be a type in Standard");
+ ("prefix of % attribute must not be a type originating from " &
+ "Standard");
end if;
if Discard_Names (First_Subtype (P_Type)) then
@@ -8712,6 +8746,13 @@ package body Sem_Attr is
Set_Etype (N, C_Type);
return;
+ -- Handle 'Make constructor calls
+
+ elsif All_Extensions_Allowed
+ and then Id = Attribute_Make
+ then
+ P_Type := P_Entity;
+
-- No other cases are foldable (they certainly aren't static, and at
-- the moment we don't try to fold any cases other than the ones above).
@@ -8723,9 +8764,10 @@ package body Sem_Attr is
-- If either attribute or the prefix is Any_Type, then propagate
-- Any_Type to the result and don't do anything else at all.
- if P_Type = Any_Type
+ if Id /= Attribute_Make
+ and then (P_Type = Any_Type
or else (Present (E1) and then Etype (E1) = Any_Type)
- or else (Present (E2) and then Etype (E2) = Any_Type)
+ or else (Present (E2) and then Etype (E2) = Any_Type))
then
Set_Etype (N, Any_Type);
return;
@@ -8838,7 +8880,9 @@ package body Sem_Attr is
Static := False;
Set_Is_Static_Expression (N, False);
- elsif Id /= Attribute_Max_Alignment_For_Allocation then
+ elsif Id not in Attribute_Max_Alignment_For_Allocation
+ | Attribute_Make
+ then
if not Is_Constrained (P_Type)
or else (Id /= Attribute_First and then
Id /= Attribute_Last and then
@@ -8914,53 +8958,55 @@ package body Sem_Attr is
-- of the expressions to be scalar in order for the attribute to be
-- considered to be static.
- declare
- E : Node_Id;
+ if Id /= Attribute_Make then
+ declare
+ E : Node_Id;
- begin
- E := E1;
+ begin
+ E := E1;
- while Present (E) loop
+ while Present (E) loop
- -- If expression is not static, then the attribute reference
- -- result certainly cannot be static.
+ -- If expression is not static, then the attribute reference
+ -- result certainly cannot be static.
- if not Is_Static_Expression (E) then
- Static := False;
- Set_Is_Static_Expression (N, False);
- end if;
+ if not Is_Static_Expression (E) then
+ Static := False;
+ Set_Is_Static_Expression (N, False);
+ end if;
- if Raises_Constraint_Error (E) then
- Set_Raises_Constraint_Error (N);
- end if;
+ if Raises_Constraint_Error (E) then
+ Set_Raises_Constraint_Error (N);
+ end if;
- -- If the result is not known at compile time, or is not of
- -- a scalar type, then the result is definitely not static,
- -- so we can quit now.
+ -- If the result is not known at compile time, or is not of
+ -- a scalar type, then the result is definitely not static,
+ -- so we can quit now.
- if not Compile_Time_Known_Value (E)
- or else not Is_Scalar_Type (Etype (E))
- then
- Check_Expressions;
- return;
+ if not Compile_Time_Known_Value (E)
+ or else not Is_Scalar_Type (Etype (E))
+ then
+ Check_Expressions;
+ return;
- -- If the expression raises a constraint error, then so does
- -- the attribute reference. We keep going in this case because
- -- we are still interested in whether the attribute reference
- -- is static even if it is not static.
+ -- If the expression raises a constraint error, then so does
+ -- the attribute reference. We keep going in this case because
+ -- we are still interested in whether the attribute reference
+ -- is static even if it is not static.
- elsif Raises_Constraint_Error (E) then
- Set_Raises_Constraint_Error (N);
- end if;
+ elsif Raises_Constraint_Error (E) then
+ Set_Raises_Constraint_Error (N);
+ end if;
- Next (E);
- end loop;
+ Next (E);
+ end loop;
- if Raises_Constraint_Error (Prefix (N)) then
- Set_Is_Static_Expression (N, False);
- return;
- end if;
- end;
+ if Raises_Constraint_Error (Prefix (N)) then
+ Set_Is_Static_Expression (N, False);
+ return;
+ end if;
+ end;
+ end if;
-- Deal with the case of a static attribute reference that raises
-- constraint error. The Raises_Constraint_Error flag will already
@@ -9778,6 +9824,13 @@ package body Sem_Attr is
end if;
end Machine_Size;
+ ----------
+ -- Make --
+ ----------
+
+ when Attribute_Make =>
+ Set_Etype (N, Etype (Prefix (N)));
+
--------------
-- Mantissa --
--------------
@@ -11095,7 +11148,9 @@ package body Sem_Attr is
-- If this is still an attribute reference, then it has not been folded
-- and that means that its expressions are in a non-static context.
- elsif Nkind (N) = N_Attribute_Reference then
+ elsif Nkind (N) = N_Attribute_Reference
+ and then Attribute_Name (N) /= Name_Make
+ then
Check_Expressions;
-- Note: the else case not covered here are odd cases where the
@@ -12959,7 +13014,7 @@ package body Sem_Attr is
-- their Entity attribute to reference their discriminal.
if Expander_Active
- and then Present (Expressions (N))
+ and then Attr_Id /= Attribute_Make
then
declare
Expr : Node_Id := First (Expressions (N));
diff --git a/gcc/ada/sem_attr.ads b/gcc/ada/sem_attr.ads
index 8208048..1c54370 100644
--- a/gcc/ada/sem_attr.ads
+++ b/gcc/ada/sem_attr.ads
@@ -319,6 +319,12 @@ package Sem_Attr is
-- This attribute is identical to the Object_Size attribute. It is
-- provided for compatibility with the DEC attribute of this name.
+ ----------
+ -- Make --
+ ----------
+
+ Attribute_Make => True,
+
----------------------
-- Max_Integer_Size --
----------------------
diff --git a/gcc/ada/sem_case.adb b/gcc/ada/sem_case.adb
index 3399a41..c81b563 100644
--- a/gcc/ada/sem_case.adb
+++ b/gcc/ada/sem_case.adb
@@ -3684,13 +3684,15 @@ package body Sem_Case is
-- Use of nonstatic predicate is an error
if not Is_Discrete_Type (E)
- or else not Has_Static_Predicate (E)
+ or else (not Has_Static_Predicate (E)
+ and then
+ not Has_Static_Predicate_Aspect (E))
or else Has_Dynamic_Predicate_Aspect (E)
or else Has_Ghost_Predicate_Aspect (E)
then
Bad_Predicated_Subtype_Use
- ("cannot use subtype& with non-static "
- & "predicate as case alternative",
+ ("cannot use subtype& with nonstatic "
+ & "predicate as choice in case alternative",
Choice, E, Suggest_Static => True);
-- Static predicate case. The bounds are those of
diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb
index de5a8c8..45aabad 100644
--- a/gcc/ada/sem_ch10.adb
+++ b/gcc/ada/sem_ch10.adb
@@ -123,15 +123,6 @@ package body Sem_Ch10 is
-- Verify that a stub is declared immediately within a compilation unit,
-- and not in an inner frame.
- procedure Expand_With_Clause (Item : Node_Id; Nam : Node_Id; N : Node_Id);
- -- When a child unit appears in a context clause, the implicit withs on
- -- parents are made explicit, and with clauses are inserted in the context
- -- clause before the one for the child. If a parent in the with_clause
- -- is a renaming, the implicit with_clause is on the renaming whose name
- -- is mentioned in the with_clause, and not on the package it renames.
- -- N is the compilation unit whose list of context items receives the
- -- implicit with_clauses.
-
procedure Generate_Parent_References (N : Node_Id; P_Id : Entity_Id);
-- Generate cross-reference information for the parents of child units
-- and of subunits. N is a defining_program_unit_name, and P_Id is the
@@ -1234,9 +1225,15 @@ package body Sem_Ch10 is
if Expander_Active and then Tagged_Type_Expansion then
case Nkind (Unit_Node) is
- when N_Package_Declaration | N_Package_Body =>
+ when N_Package_Declaration =>
Build_Static_Dispatch_Tables (Unit_Node);
+ when N_Package_Body =>
+ if Ekind (Corresponding_Spec (Unit_Node)) /= E_Generic_Package
+ then
+ Build_Static_Dispatch_Tables (Unit_Node);
+ end if;
+
when N_Package_Instantiation =>
Build_Static_Dispatch_Tables (Instance_Spec (Unit_Node));
@@ -2955,6 +2952,7 @@ package body Sem_Ch10 is
if Ada_Version >= Ada_95
and then In_Predefined_Renaming (U)
+ and then Comes_From_Source (N)
then
if Restriction_Check_Required (No_Obsolescent_Features) then
Check_Restriction (No_Obsolescent_Features, N);
@@ -4932,6 +4930,8 @@ package body Sem_Ch10 is
if Entity (Name (Clause)) = Id
or else
(Nkind (Name (Clause)) = N_Expanded_Name
+ and then
+ Is_Entity_Name (Prefix (Name (Clause)))
and then Entity (Prefix (Name (Clause))) = Id)
then
return True;
diff --git a/gcc/ada/sem_ch10.ads b/gcc/ada/sem_ch10.ads
index c80c412..9585785 100644
--- a/gcc/ada/sem_ch10.ads
+++ b/gcc/ada/sem_ch10.ads
@@ -45,6 +45,15 @@ package Sem_Ch10 is
-- set when Ent is a tagged type and its class-wide type needs to appear
-- in the tree.
+ procedure Expand_With_Clause (Item : Node_Id; Nam : Node_Id; N : Node_Id);
+ -- When a child unit appears in a context clause, the implicit withs on
+ -- parents are made explicit, and with clauses are inserted in the context
+ -- clause before the one for the child. If a parent in the with_clause
+ -- is a renaming, the implicit with_clause is on the renaming whose name
+ -- is mentioned in the with_clause, and not on the package it renames.
+ -- N is the compilation unit whose list of context items receives the
+ -- implicit with_clauses.
+
procedure Install_Context (N : Node_Id; Chain : Boolean := True);
-- Installs the entities from the context clause of the given compilation
-- unit into the visibility chains. This is done before analyzing a unit.
diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb
index 5768e28e..f492b23 100644
--- a/gcc/ada/sem_ch12.adb
+++ b/gcc/ada/sem_ch12.adb
@@ -276,6 +276,7 @@ package body Sem_Ch12 is
-- Pre
-- Pre_Class
-- Precondition
+ -- Program_Exit
-- Refined_Depends
-- Refined_Global
-- Refined_Post
@@ -478,18 +479,19 @@ package body Sem_Ch12 is
-- Create a new access type with the given designated type
function Analyze_Associations
- (I_Node : Node_Id;
+ (N : Node_Id;
Formals : List_Id;
F_Copy : List_Id) return List_Id;
-- At instantiation time, build the list of associations between formals
-- and actuals. Each association becomes a renaming declaration for the
- -- formal entity. F_Copy is the analyzed list of formals in the generic
- -- copy. It is used to apply legality checks to the actuals. I_Node is the
- -- instantiation node.
+ -- formal entity. N is the instantiation node. Formals is the list of
+ -- unanalyzed formals. F_Copy is the analyzed list of formals in the
+ -- generic copy.
procedure Analyze_Subprogram_Instantiation
(N : Node_Id;
K : Entity_Kind);
+ -- Analyze subprogram instantiation N, either a function or a procedure
procedure Build_Instance_Compilation_Unit_Nodes
(N : Node_Id;
@@ -608,12 +610,12 @@ package body Sem_Ch12 is
(Inner : Entity_Id;
Outer : Entity_Id;
N : Node_Id) return Boolean;
- -- Inner is instantiated within the generic Outer. Check whether Inner
- -- directly or indirectly contains an instance of Outer or of one of its
- -- parents, in the case of a subunit. Each generic unit holds a list of
- -- the entities instantiated within (at any depth). This procedure
- -- determines whether the set of such lists contains a cycle, i.e. an
- -- illegal circular instantiation.
+ -- Inner is being instantiated within Outer. If Outer is also a generic
+ -- unit, check whether Inner directly or indirectly contains an instance
+ -- of Outer or of one of its parents (case of subunit). Each generic unit
+ -- holds a list of the entities instantiated within (at any depth). This
+ -- procedure determines whether the set of such lists contains a cycle,
+ -- i.e. an illegal circular instantiation.
function Denotes_Formal_Package
(Pack : Entity_Id;
@@ -1008,8 +1010,8 @@ package body Sem_Ch12 is
procedure Set_Next_Assoc (E : Assoc_Ptr; Next : Assoc_Ptr);
function Next_Assoc (E : Assoc_Ptr) return Assoc_Ptr;
- function Get_Gen_Id (E : Assoc_Ptr) return Entity_Id;
- function Hash (F : Entity_Id) return HTable_Range;
+ function Get_Gen_Id (E : Assoc_Ptr) return Entity_Id;
+ function Hash (F : Entity_Id) return HTable_Range;
package Generic_Renamings_HTable is new GNAT.HTable.Static_HTable (
Header_Num => HTable_Range,
@@ -1157,19 +1159,29 @@ package body Sem_Ch12 is
-- kinds for N_Box_Subp_Default, N_Box_Actual, N_Null_Default, and
-- N_Exp_Func_Default.
- type Generic_Actual_Rec (Kind : Actual_Kind := None) is record
- -- Representation of one generic actual parameter
+ type Actual_Rec (Kind : Actual_Kind := None) is record
case Kind is
- when None | None_Use_Clause | Box_Subp_Default | Box_Actual |
- Null_Default | Dummy_Assoc =>
+ when None
+ | None_Use_Clause
+ | Box_Subp_Default
+ | Box_Actual
+ | Null_Default
+ | Dummy_Assoc
+ =>
null;
- when Name_Exp | Exp_Func_Default =>
+ when Name_Exp
+ | Exp_Func_Default
+ =>
Name_Exp : Node_Id;
end case;
end record;
+ -- Representation of one generic actual parameter
type Actual_Origin_Enum is
- (None, From_Explicit_Actual, From_Default, From_Inference,
+ (None,
+ From_Explicit_Actual,
+ From_Default,
+ From_Inference,
From_Others_Box);
-- Indication of where the Actual came from -- explicitly in the
-- instantiation, inferred from some other type, or defaulted.
@@ -1178,16 +1190,16 @@ package body Sem_Ch12 is
-- Reason an actual type corresponding to a formal type was (or could
-- be) inferred from the actual type corresponding to another formal
-- type.
- (Designated_Type, -- designated type from formal access
- Index_Type, -- index type from formal array
- Component_Type, -- component type from formal array
+ (Designated_Type, -- designated type from formal access
+ Index_Type, -- index type from formal array
+ Component_Type, -- component type from formal array
Discriminant_Type); -- discriminant type from formal discriminated
function Image (Reason : Inference_Reason) return String is
(case Reason is
- when Designated_Type => "designated type",
- when Index_Type => "index type",
- when Component_Type => "component type",
+ when Designated_Type => "designated type",
+ when Index_Type => "index type",
+ when Component_Type => "component type",
when Discriminant_Type => "discriminant type");
type Assoc_Index is new Pos;
@@ -1209,7 +1221,7 @@ package body Sem_Ch12 is
Explicit_Assoc : Opt_N_Generic_Association_Id;
-- Explicit association, if any, from the source or generated.
- Actual : Generic_Actual_Rec;
+ Actual : Actual_Rec;
-- Generic actual parameter corresponding to Un_Formal/An_Formal,
-- possibly from defaults or others/boxes.
@@ -1223,7 +1235,7 @@ package body Sem_Ch12 is
-- inferred.
Inferred_From : Assoc_Index;
- -- Index of a later Assoc_Rec in the same Gen_Assocs_Rec from which
+ -- Index of a later Assoc_Rec in the same Match_Rec from which
-- this one was inferred, or could be inferred.
-- Valid only if Info_Inferred_Actual is present.
@@ -1236,10 +1248,10 @@ package body Sem_Ch12 is
-- One element for each formal and (if legal) for each corresponding
-- actual.
- type Gen_Assocs_Rec (Num_Assocs : Assoc_Count) is record
- -- Representation of formal/actual matching. Num_Assocs
- -- is the number of formals and (if legal) the number
- -- of actuals.
+ type Match_Rec (Num_Assocs : Assoc_Count) is record
+ -- Representation of formal/actual matching. Num_Assocs is the
+ -- number of formals and (if legal) the number of actuals.
+
Gen_Unit : Entity_Id;
-- the generic unit being instantiated
Others_Present : Boolean;
@@ -1250,25 +1262,26 @@ package body Sem_Ch12 is
end record;
function Match_Assocs
- (I_Node : Node_Id; Formals : List_Id; F_Copy : List_Id)
- return Gen_Assocs_Rec;
- -- I_Node is the instantiation node. Formals is the list of unanalyzed
+ (N : Node_Id;
+ Formals : List_Id;
+ F_Copy : List_Id) return Match_Rec;
+ -- N is the instantiation node. Formals is the list of unanalyzed
-- formals. F_Copy is the analyzed list of formals in the generic copy.
- -- Return a Gen_Assocs_Rec with formals, explicit actuals, and default
+ -- Return a Match_Rec with formals, explicit actuals, and default
-- actuals filled in. Check legality rules related to formal/actual
-- matching.
procedure Note_Potential_Inference
- (I_Node : Node_Id; Gen_Assocs : Gen_Assocs_Rec);
+ (N : Node_Id;
+ Match : Match_Rec);
-- If -gnatd_I, print "info:" messages about type inference that could
-- have been done.
end Associations;
procedure Analyze_One_Association
- (I_Node : Node_Id; -- instantiation node
- Assoc : Associations.Assoc_Rec;
- -- Logical 'in out' parameters:
+ (N : Node_Id;
+ Assoc : Associations.Assoc_Rec;
Result_Renamings : List_Id;
Default_Actuals : List_Id;
Actuals_To_Freeze : Elist_Id);
@@ -1278,12 +1291,12 @@ package body Sem_Ch12 is
-- appended onto Actuals_To_Freeze.
procedure Check_Fixed_Point_Warning
- (Gen_Assocs : Associations.Gen_Assocs_Rec;
+ (Match : Associations.Match_Rec;
Renamings : List_Id);
-- Warn if any actual is a fixed-point type that has user-defined
-- arithmetic operators, but there is no corresponding formal in the
-- generic, in which case the predefined operators will be used. This
- -- merits a warning because of the special semantics of fixed point
+ -- deserves a warning because of the special semantics of fixed point
-- operators. However, do not warn if the formal is private, because there
-- can be no arithmetic operators in the generic so there no danger of
-- confusion.
@@ -1314,27 +1327,29 @@ package body Sem_Ch12 is
-- analyzed formals in cases where there are multiple ones
-- corresponding to a particular unanalyzed one.
- function Num_An_Formals (F_Copy : List_Id) return Assoc_Count;
+ function Num_An_Formals (F_Copy : List_Id) return Assoc_Count;
-- Number of analyzed formals that correspond directly to unanalyzed
-- formals. There are all sorts of other things in F_Copy, which
-- are not counted.
- procedure Check_Box (I_Node, Actual : Node_Id);
+ procedure Check_Box (N, Actual : Node_Id);
-- Check for errors in "others => <>" and "Name => <>"
- function Default (Un_Formal : Node_Id) return Generic_Actual_Rec;
+ function Default (Un_Formal : Node_Id) return Actual_Rec;
-- Return the default for a given formal, which can be a name,
-- expression, box, etc.
procedure Match_Positional
- (Src_Assoc : in out Node_Id; Assoc : in out Assoc_Rec);
+ (Src_Assoc : in out Node_Id;
+ Assoc : in out Assoc_Rec);
-- Called by Match_Assocs to match one positional parameter association.
-- If the current formal (in Assoc) is not a use clause, then there is a
-- match, and we set Assoc.Actual and move Src_Assoc to the next one.
procedure Match_Named
- (Src_Assoc : Node_Id; Assoc : in out Assoc_Rec;
- Found : in out Boolean);
+ (Src_Assoc : Node_Id;
+ Assoc : in out Assoc_Rec;
+ Found : in out Boolean);
-- Called by Match_Assocs to match one named parameter association.
-- If the current formal (in Assoc) is not a use clause, and the
-- selector name matches the formal name, then there is a match,
@@ -1342,48 +1357,50 @@ package body Sem_Ch12 is
-- the matched formal, and set Found to True.
procedure Inference_Msg
- (Gen_Unit : Entity_Id;
- Inferred_To, Inferred_From : Assoc_Rec;
- Was_Inferred : Boolean);
+ (Gen_Unit : Entity_Id;
+ Inferred_To : Assoc_Rec;
+ Inferred_From : Assoc_Rec;
+ Was_Inferred : Boolean);
-- If Was_Inferred is True, this prints out an "info:" message
-- showing the inference.
-- If Was_Inferred is False, the message says that it could have
-- been inferred.
function Find_Assoc
- (Gen_Assocs : Gen_Assocs_Rec; F : Entity_Id) return Assoc_Index;
- -- Return the index of F in Gen_Assocs.Assocs, which must be
- -- present.
+ (Match : Match_Rec;
+ F : Entity_Id) return Assoc_Index;
+ -- Return the index of F in Match.Assocs, which must be present
procedure Maybe_Infer_One
- (Gen_Assocs : in out Gen_Assocs_Rec;
- FF, AA : N_Entity_Id; Inferred_From : Assoc_Index;
- Reason : Inference_Reason);
+ (Match : in out Match_Rec;
+ FF, AA : N_Entity_Id;
+ Inferred_From : Assoc_Index;
+ Reason : Inference_Reason);
-- If it makes sense to infer that formal FF is associated with
-- actual AA, then do so.
procedure Infer_From_Access
- (Gen_Assocs : in out Gen_Assocs_Rec;
- Index : Assoc_Index;
- F : Node_Id;
+ (Match : in out Match_Rec;
+ Index : Assoc_Index;
+ F : Node_Id;
A_Full : Entity_Id);
-- Try to infer the designated type
procedure Infer_From_Array
- (Gen_Assocs : in out Gen_Assocs_Rec;
- Index : Assoc_Index;
- F : Node_Id;
+ (Match : in out Match_Rec;
+ Index : Assoc_Index;
+ F : Node_Id;
A_Full : Entity_Id);
-- Try to infer the index and component types
procedure Infer_From_Discriminated
- (Gen_Assocs : in out Gen_Assocs_Rec;
- Index : Assoc_Index;
- F : Node_Id;
+ (Match : in out Match_Rec;
+ Index : Assoc_Index;
+ F : Node_Id;
A_Full : Entity_Id);
-- Try to infer the types of discriminants
- procedure Infer_Actuals (Gen_Assocs : in out Gen_Assocs_Rec);
+ procedure Infer_Actuals (Match : in out Match_Rec);
-- Called by Match_Assocs after processing explicit and defaulted
-- parameters to infer any that are still missing.
@@ -1541,13 +1558,13 @@ package body Sem_Ch12 is
-- Check_Box --
---------------
- procedure Check_Box (I_Node, Actual : Node_Id) is
+ procedure Check_Box (N, Actual : Node_Id) is
begin
-- "... => <>" is allowed only in formal packages, not old-fashioned
-- instantiations.
- if Nkind (I_Node) /= N_Formal_Package_Declaration
- and then Comes_From_Source (I_Node)
+ if Nkind (N) /= N_Formal_Package_Declaration
+ and then Comes_From_Source (N)
then
if Actual in N_Others_Choice_Id then
Error_Msg_N
@@ -1572,9 +1589,9 @@ package body Sem_Ch12 is
-- Default --
-------------
- function Default (Un_Formal : Node_Id) return Generic_Actual_Rec is
+ function Default (Un_Formal : Node_Id) return Actual_Rec is
begin
- return Result : Generic_Actual_Rec do
+ return Result : Actual_Rec do
case Nkind (Un_Formal) is
when N_Formal_Object_Declaration =>
if Present (Default_Expression (Un_Formal)) then
@@ -1726,22 +1743,24 @@ package body Sem_Ch12 is
------------------
function Match_Assocs
- (I_Node : Node_Id; Formals : List_Id; F_Copy : List_Id)
- return Gen_Assocs_Rec
+ (N : Node_Id;
+ Formals : List_Id;
+ F_Copy : List_Id) return Match_Rec
is
- Src_Assocs : constant List_Id := Generic_Associations (I_Node);
- Gen_Unit : constant Entity_Id := Defining_Entity (Parent (F_Copy));
+ Src_Assocs : constant List_Id := Generic_Associations (N);
+ Gen_Unit : constant Entity_Id := Defining_Entity (Parent (F_Copy));
+
begin
pragma Assert
(Num_An_Formals (F_Copy) = Num_Formals (Formals)
or else Serious_Errors_Detected > 0);
- return Result : Gen_Assocs_Rec (Num_Assocs => Num_Formals (Formals))
+ return Result : Match_Rec (Num_Assocs => Num_Formals (Formals))
do
Result.Gen_Unit := Gen_Unit;
Result.Others_Present := False;
- -- Loop through the unanalyzed formals:
+ -- Loop through the unanalyzed formals
declare
procedure Set_Formal (F : Node_Id; Index : Assoc_Index);
@@ -1778,7 +1797,7 @@ package body Sem_Ch12 is
Iter (Formals);
end;
- -- Loop through the analyzed copy of the formals:
+ -- Loop through the analyzed copy of the formals
declare
procedure Set_An_Formal (F : Node_Id; Index : Assoc_Index);
@@ -1835,7 +1854,7 @@ package body Sem_Ch12 is
Iter (F_Copy);
end;
- -- Loop through actual source associations:
+ -- Loop through actual source associations
declare
Src_Assoc : Node_Id := First (Src_Assocs);
@@ -1863,7 +1882,7 @@ package body Sem_Ch12 is
-- Loop through named actuals and "others => <>":
while Present (Src_Assoc) loop
- Check_Box (I_Node, Src_Assoc);
+ Check_Box (N, Src_Assoc);
if Src_Assoc in N_Others_Choice_Id then
Result.Others_Present := True;
exit;
@@ -1941,8 +1960,8 @@ package body Sem_Ch12 is
end;
end loop;
- if Nkind (I_Node) /= N_Formal_Package_Declaration then
- Infer_Actuals (Gen_Assocs => Result);
+ if Nkind (N) /= N_Formal_Package_Declaration then
+ Infer_Actuals (Result);
end if;
-- Check for missing actuals
@@ -1968,9 +1987,10 @@ package body Sem_Ch12 is
-------------------
procedure Inference_Msg
- (Gen_Unit : Entity_Id;
- Inferred_To, Inferred_From : Assoc_Rec;
- Was_Inferred : Boolean)
+ (Gen_Unit : Entity_Id;
+ Inferred_To : Assoc_Rec;
+ Inferred_From : Assoc_Rec;
+ Was_Inferred : Boolean)
is
pragma Assert (Debug_Flag_Underscore_II); -- This is only for -gnatd_I
@@ -2008,7 +2028,8 @@ package body Sem_Ch12 is
------------------------------
procedure Note_Potential_Inference
- (I_Node : Node_Id; Gen_Assocs : Gen_Assocs_Rec)
+ (N : Node_Id;
+ Match : Match_Rec)
is
begin
if not Debug_Flag_Underscore_II or else Serious_Errors_Detected > 0
@@ -2016,20 +2037,21 @@ package body Sem_Ch12 is
return;
end if;
- for Index in Gen_Assocs.Assocs'Range loop
+ for Index in Match.Assocs'Range loop
declare
- Assoc : Assoc_Rec renames Gen_Assocs.Assocs (Index);
+ Assoc : Assoc_Rec renames Match.Assocs (Index);
+
begin
if Assoc.Actual_Origin = From_Explicit_Actual
and then Present (Assoc.Info_Inferred_Actual)
- and then In_Extended_Main_Source_Unit (I_Node)
- and then not In_Internal_Unit (I_Node)
+ and then In_Extended_Main_Source_Unit (N)
+ and then not In_Internal_Unit (N)
then
Inference_Msg
- (Gen_Assocs.Gen_Unit,
- Inferred_To => Assoc,
- Inferred_From => Gen_Assocs.Assocs (Assoc.Inferred_From),
- Was_Inferred => False);
+ (Match.Gen_Unit,
+ Inferred_To => Assoc,
+ Inferred_From => Match.Assocs (Assoc.Inferred_From),
+ Was_Inferred => False);
end if;
end;
end loop;
@@ -2040,11 +2062,12 @@ package body Sem_Ch12 is
--------------
function Find_Assoc
- (Gen_Assocs : Gen_Assocs_Rec; F : Entity_Id) return Assoc_Index
+ (Match : Match_Rec;
+ F : Entity_Id) return Assoc_Index
is
begin
- for Index in Gen_Assocs.Assocs'Range loop
- if Defining_Entity (Gen_Assocs.Assocs (Index).An_Formal) = F then
+ for Index in Match.Assocs'Range loop
+ if Defining_Entity (Match.Assocs (Index).An_Formal) = F then
return Index;
end if;
end loop;
@@ -2057,13 +2080,14 @@ package body Sem_Ch12 is
---------------------
procedure Maybe_Infer_One
- (Gen_Assocs : in out Gen_Assocs_Rec;
- FF, AA : N_Entity_Id; Inferred_From : Assoc_Index;
- Reason : Inference_Reason)
+ (Match : in out Match_Rec;
+ FF, AA : N_Entity_Id;
+ Inferred_From : Assoc_Index;
+ Reason : Inference_Reason)
is
begin
if not (Is_Generic_Type (FF)
- and then Scope (FF) = Gen_Assocs.Gen_Unit)
+ and then Scope (FF) = Match.Gen_Unit)
then
return; -- no inference if not a formal type of this generic
end if;
@@ -2073,12 +2097,12 @@ package body Sem_Ch12 is
end if;
declare
- Index : constant Assoc_Index := Find_Assoc (Gen_Assocs, FF);
- Assoc : Assoc_Rec renames Gen_Assocs.Assocs (Index);
+ Index : constant Assoc_Index := Find_Assoc (Match, FF);
+ Assoc : Assoc_Rec renames Match.Assocs (Index);
pragma Assert (Defining_Entity (Assoc.An_Formal) = FF);
From_Actual : constant Node_Id :=
- Gen_Assocs.Assocs (Inferred_From).Actual.Name_Exp;
+ Match.Assocs (Inferred_From).Actual.Name_Exp;
begin
Assoc.Info_Inferred_Actual := AA;
@@ -2096,23 +2120,23 @@ package body Sem_Ch12 is
if Debug_Flag_Underscore_II then
Inference_Msg
- (Gen_Assocs.Gen_Unit,
- Inferred_To => Assoc,
- Inferred_From => Gen_Assocs.Assocs (Assoc.Inferred_From),
- Was_Inferred => True);
+ (Match.Gen_Unit,
+ Inferred_To => Assoc,
+ Inferred_From => Match.Assocs (Assoc.Inferred_From),
+ Was_Inferred => True);
end if;
end if;
end;
end Maybe_Infer_One;
- -------------------
- -- Infer_Actuals --
- -------------------
+ -----------------------
+ -- Infer_From_Access --
+ -----------------------
procedure Infer_From_Access
- (Gen_Assocs : in out Gen_Assocs_Rec;
- Index : Assoc_Index;
- F : Node_Id;
+ (Match : in out Match_Rec;
+ Index : Assoc_Index;
+ F : Node_Id;
A_Full : Entity_Id)
is
begin
@@ -2123,7 +2147,7 @@ package body Sem_Ch12 is
AA : constant Entity_Id := Designated_Type (A_Full);
begin
Maybe_Infer_One
- (Gen_Assocs,
+ (Match,
FF,
AA,
Inferred_From => Index,
@@ -2132,10 +2156,14 @@ package body Sem_Ch12 is
end if;
end Infer_From_Access;
+ ----------------------
+ -- Infer_From_Array --
+ ----------------------
+
procedure Infer_From_Array
- (Gen_Assocs : in out Gen_Assocs_Rec;
- Index : Assoc_Index;
- F : Node_Id;
+ (Match : in out Match_Rec;
+ Index : Assoc_Index;
+ F : Node_Id;
A_Full : Entity_Id)
is
begin
@@ -2149,7 +2177,7 @@ package body Sem_Ch12 is
while Present (F_Index_Type) and then Present (A_Index_Type)
loop
Maybe_Infer_One
- (Gen_Assocs,
+ (Match,
Etype (F_Index_Type),
Etype (A_Index_Type),
Inferred_From => Index,
@@ -2167,7 +2195,7 @@ package body Sem_Ch12 is
Component_Type (A_Full);
begin
Maybe_Infer_One
- (Gen_Assocs,
+ (Match,
F_Comp_Type,
A_Comp_Type,
Inferred_From => Index,
@@ -2176,10 +2204,14 @@ package body Sem_Ch12 is
end if;
end Infer_From_Array;
+ ------------------------------
+ -- Infer_From_Discriminated --
+ ------------------------------
+
procedure Infer_From_Discriminated
- (Gen_Assocs : in out Gen_Assocs_Rec;
- Index : Assoc_Index;
- F : Node_Id;
+ (Match : in out Match_Rec;
+ Index : Assoc_Index;
+ F : Node_Id;
A_Full : Entity_Id)
is
begin
@@ -2195,7 +2227,7 @@ package body Sem_Ch12 is
begin
while Present (F_Discrim) loop
Maybe_Infer_One
- (Gen_Assocs,
+ (Match,
Etype (F_Discrim),
Etype (A_Discrim),
Inferred_From => Index,
@@ -2209,23 +2241,27 @@ package body Sem_Ch12 is
end if;
end Infer_From_Discriminated;
- procedure Infer_Actuals (Gen_Assocs : in out Gen_Assocs_Rec) is
- -- Note that we can infer FROM defaults, but we cannot infer TO a
- -- parameter that has a default. We can also infer from inferred
- -- types.
+ -------------------
+ -- Infer_Actuals --
+ -------------------
+
+ -- Note that we can infer FROM defaults, but we cannot infer TO a
+ -- parameter that has a default. We can also infer from inferred
+ -- types.
- -- We don't need to check that multiple inferences get the same
- -- answer; the second one will get a type mismatch or nonstatically
- -- matching error.
+ -- We don't need to check that multiple inferences get the same
+ -- answer; the second one will get a type mismatch or nonstatically
+ -- matching error.
- -- This code needs to be robust, in the sense of tolerating illegal
- -- code, because we have not yet checked all legality rules. For
- -- example, if a formal type F has a discriminant whose type is
- -- another formal type, then we want to infer the type of the
- -- discriminant from the actual for F. That actual must have
- -- discriminants, but we have not checked that rule yet, so we
- -- need to tolerate an actual for F that has no discriminants.
+ -- This code needs to be robust, in the sense of tolerating illegal
+ -- code, because we have not yet checked all legality rules. For
+ -- example, if a formal type F has a discriminant whose type is
+ -- another formal type, then we want to infer the type of the
+ -- discriminant from the actual for F. That actual must have
+ -- discriminants, but we have not checked that rule yet, so we
+ -- need to tolerate an actual for F that has no discriminants.
+ procedure Infer_Actuals (Match : in out Match_Rec) is
begin
-- For each parameter, check whether we can infer FROM that one TO
-- other ones.
@@ -2239,12 +2275,12 @@ package body Sem_Ch12 is
-- designated type. The reverse loop implies that we will see the
-- array type, then the access type, then the designated type.
- for Index in reverse Gen_Assocs.Assocs'Range loop -- NB: "reverse"
- if Gen_Assocs.Assocs (Index).Actual.Kind = Name_Exp then
+ for Index in reverse Match.Assocs'Range loop -- NB: "reverse"
+ if Match.Assocs (Index).Actual.Kind = Name_Exp then
declare
- F : constant Node_Id := Gen_Assocs.Assocs (Index).An_Formal;
+ F : constant Node_Id := Match.Assocs (Index).An_Formal;
A_E : constant Node_Id :=
- Gen_Assocs.Assocs (Index).Actual.Name_Exp;
+ Match.Assocs (Index).Actual.Name_Exp;
A_Full : Entity_Id := Empty;
begin
if Nkind (A_E) in N_Has_Entity then
@@ -2263,7 +2299,7 @@ package body Sem_Ch12 is
then
case Ekind (Defining_Entity (F)) is
when E_Access_Type | E_General_Access_Type =>
- Infer_From_Access (Gen_Assocs, Index, F, A_Full);
+ Infer_From_Access (Match, Index, F, A_Full);
when E_Access_Subtype
| E_Access_Attribute_Type
@@ -2273,7 +2309,7 @@ package body Sem_Ch12 is
raise Program_Error;
when E_Array_Type | E_Array_Subtype =>
- Infer_From_Array (Gen_Assocs, Index, F, A_Full);
+ Infer_From_Array (Match, Index, F, A_Full);
when E_String_Literal_Subtype =>
raise Program_Error;
@@ -2282,13 +2318,12 @@ package body Sem_Ch12 is
null;
end case;
- Infer_From_Discriminated (Gen_Assocs, Index, F, A_Full);
+ Infer_From_Discriminated (Match, Index, F, A_Full);
end if;
end;
end if;
end loop;
end Infer_Actuals;
-
end Associations;
---------------------------
@@ -2315,46 +2350,49 @@ package body Sem_Ch12 is
--------------------------
function Analyze_Associations
- (I_Node : Node_Id;
+ (N : Node_Id;
Formals : List_Id;
F_Copy : List_Id) return List_Id
is
use Associations;
- Result_Renamings : constant List_Id := New_List;
+ Actuals_To_Freeze : constant Elist_Id := New_Elmt_List;
+ Default_Actuals : constant List_Id := New_List;
+ Result_Renamings : constant List_Id := New_List;
-- To be returned. Includes "renamings" broadly interpreted
-- (e.g. subtypes are used for types).
- Actuals_To_Freeze : constant Elist_Id := New_Elmt_List;
- Default_Actuals : constant List_Id := New_List;
-
- Gen_Assocs : constant Gen_Assocs_Rec :=
- Match_Assocs (I_Node, Formals, F_Copy);
+ Match : constant Match_Rec := Match_Assocs (N, Formals, F_Copy);
begin
- for Matching_Actual_Index in Gen_Assocs.Assocs'Range loop
+ for Index in Match.Assocs'Range loop
declare
- Assoc : Assoc_Rec renames
- Gen_Assocs.Assocs (Matching_Actual_Index);
+ Assoc : Assoc_Rec renames Match.Assocs (Index);
+
begin
if Nkind (Assoc.Un_Formal) = N_Formal_Package_Declaration
and then Error_Posted (Assoc.An_Formal)
then
-- Restrict this to N_Formal_Package_Declaration,
-- because otherwise we miss errors.
+
Abandon_Instantiation (Instantiation_Node);
end if;
- if Nkind (Assoc.Un_Formal) in
- N_Use_Package_Clause | N_Use_Type_Clause
+ if Nkind (Assoc.Un_Formal) in N_Use_Package_Clause
+ | N_Use_Type_Clause
then
- -- Copy the use clause to where it belongs:
+ -- Copy the use clause to where it belongs
+
Append (New_Copy_Tree (Assoc.Un_Formal), Result_Renamings);
else
Analyze_One_Association
- (I_Node, Assoc,
- Result_Renamings, Default_Actuals, Actuals_To_Freeze);
+ (N,
+ Assoc,
+ Result_Renamings,
+ Default_Actuals,
+ Actuals_To_Freeze);
end if;
end;
end loop;
@@ -2365,9 +2403,10 @@ package body Sem_Ch12 is
declare
Elmt : Elmt_Id := First_Elmt (Actuals_To_Freeze);
+
begin
while Present (Elmt) loop
- Freeze_Before (I_Node, Node (Elmt));
+ Freeze_Before (N, Node (Elmt));
Next_Elmt (Elmt);
end loop;
end;
@@ -2387,17 +2426,17 @@ package body Sem_Ch12 is
Next (Default);
end loop;
- if No (Generic_Associations (I_Node)) then
- Set_Generic_Associations (I_Node, Default_Actuals);
+ if No (Generic_Associations (N)) then
+ Set_Generic_Associations (N, Default_Actuals);
else
- Append_List_To (Generic_Associations (I_Node), Default_Actuals);
+ Append_List_To (Generic_Associations (N), Default_Actuals);
end if;
end;
end if;
- Note_Potential_Inference (I_Node, Gen_Assocs);
+ Note_Potential_Inference (N, Match);
- Check_Fixed_Point_Warning (Gen_Assocs, Result_Renamings);
+ Check_Fixed_Point_Warning (Match, Result_Renamings);
return Result_Renamings;
end Analyze_Associations;
@@ -2407,9 +2446,8 @@ package body Sem_Ch12 is
-----------------------------
procedure Analyze_One_Association
- (I_Node : Node_Id;
- Assoc : Associations.Assoc_Rec;
- -- Logical 'in out' parameters:
+ (N : Node_Id;
+ Assoc : Associations.Assoc_Rec;
Result_Renamings : List_Id;
Default_Actuals : List_Id;
Actuals_To_Freeze : Elist_Id)
@@ -2481,11 +2519,11 @@ package body Sem_Ch12 is
if No (Match) and then not Inside_A_Generic then
Append_To (Default_Actuals,
- Make_Generic_Association (Sloc (I_Node),
+ Make_Generic_Association (Sloc (N),
Selector_Name =>
New_Occurrence_Of
(Defining_Identifier
- (Assoc.Un_Formal), Sloc (I_Node)),
+ (Assoc.Un_Formal), Sloc (N)),
Explicit_Generic_Actual_Parameter =>
New_Copy_Tree (Default_Expression (Assoc.Un_Formal))));
end if;
@@ -2606,7 +2644,7 @@ package body Sem_Ch12 is
-- unless this is a rewritten formal package, or the
-- formal is an Ada 2012 formal incomplete type.
- if Nkind (I_Node) = N_Formal_Package_Declaration
+ if Nkind (N) = N_Formal_Package_Declaration
or else
(Ada_Version >= Ada_2012
and then
@@ -2692,7 +2730,7 @@ package body Sem_Ch12 is
-- An instantiation is a freeze point for the actuals,
-- unless this is a rewritten formal package.
- if Nkind (I_Node) /= N_Formal_Package_Declaration
+ if Nkind (N) /= N_Formal_Package_Declaration
and then Nkind (Match) = N_Identifier
and then Is_Subprogram (Entity (Match))
@@ -2710,7 +2748,7 @@ package body Sem_Ch12 is
-- subprograms defined in Standard which are used
-- as generic actuals.
- and then In_Same_Code_Unit (Entity (Match), I_Node)
+ and then In_Same_Code_Unit (Entity (Match), N)
and then Has_Fully_Defined_Profile (Entity (Match))
then
-- Mark the subprogram as having a delayed freeze
@@ -2733,11 +2771,11 @@ package body Sem_Ch12 is
begin
Append_To (Default_Actuals,
- Make_Generic_Association (Sloc (I_Node),
+ Make_Generic_Association (Sloc (N),
Selector_Name =>
- New_Occurrence_Of (Subp, Sloc (I_Node)),
+ New_Occurrence_Of (Subp, Sloc (N)),
Explicit_Generic_Actual_Parameter =>
- New_Occurrence_Of (Subp, Sloc (I_Node))));
+ New_Occurrence_Of (Subp, Sloc (N))));
end;
end if;
@@ -2850,13 +2888,13 @@ package body Sem_Ch12 is
if not Expander_Active
or else not Has_Completion (Actual)
- or else not In_Same_Source_Unit (I_Node, Actual)
+ or else not In_Same_Source_Unit (N, Actual)
or else Is_Frozen (Actual)
or else
(Present (Renamed_Entity (Actual))
and then
not In_Same_Source_Unit
- (I_Node, (Renamed_Entity (Actual))))
+ (N, (Renamed_Entity (Actual))))
then
null;
@@ -2868,7 +2906,7 @@ package body Sem_Ch12 is
Needs_Freezing := True;
- P := Parent (I_Node);
+ P := Parent (N);
while Nkind (P) /= N_Compilation_Unit loop
if Nkind (P) = N_Handled_Sequence_Of_Statements
then
@@ -3371,7 +3409,7 @@ package body Sem_Ch12 is
end if;
if Present (E) then
- Preanalyze_Spec_Expression (E, T);
+ Preanalyze_And_Resolve_Spec_Expression (E, T);
-- The default for a ghost generic formal IN parameter of
-- access-to-variable type should be a ghost object (SPARK
@@ -3585,7 +3623,7 @@ package body Sem_Ch12 is
Decls :=
Analyze_Associations
- (I_Node => Original_Node (N),
+ (N => Original_Node (N),
Formals => Generic_Formal_Declarations (Act_Tree),
F_Copy => Generic_Formal_Declarations (Gen_Decl));
@@ -3601,9 +3639,8 @@ package body Sem_Ch12 is
if No (Visible_Declarations (Specification (Pack_Decl))) then
Set_Visible_Declarations (Specification (Pack_Decl), Decls);
else
- Insert_List_Before
- (First (Visible_Declarations (Specification (Pack_Decl))),
- Decls);
+ Prepend_List_To
+ (Visible_Declarations (Specification (Pack_Decl)), Decls);
end if;
return Pack_Decl;
@@ -4195,7 +4232,7 @@ package body Sem_Ch12 is
elsif Present (Expr) then
Push_Scope (Nam);
Install_Formals (Nam);
- Preanalyze_Spec_Expression (Expr, Etype (Nam));
+ Preanalyze_And_Resolve_Spec_Expression (Expr, Etype (Nam));
End_Scope;
end if;
@@ -4859,11 +4896,10 @@ package body Sem_Ch12 is
-- Local declarations
- Gen_Id : constant Node_Id := Name (N);
- Inst_Id : constant Entity_Id := Defining_Entity (N);
- Is_Actual_Pack : constant Boolean := Is_Internal (Inst_Id);
- Loc : constant Source_Ptr := Sloc (N);
-
+ Gen_Id : constant Node_Id := Name (N);
+ Loc : constant Source_Ptr := Sloc (N);
+ Is_Abbrev : constant Boolean :=
+ Is_Abbreviated_Instance (Defining_Entity (N));
Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
Saved_ISMP : constant Boolean :=
@@ -4876,7 +4912,6 @@ package body Sem_Ch12 is
-- Save style check mode for restore on exit
Act_Decl : Node_Id;
- Act_Decl_Name : Node_Id;
Act_Decl_Id : Entity_Id;
Act_Spec : Node_Id;
Act_Tree : Node_Id;
@@ -4917,29 +4952,7 @@ package body Sem_Ch12 is
Instantiation_Node := N;
- -- Case of instantiation of a generic package
-
- if Nkind (N) = N_Package_Instantiation then
- Act_Decl_Id := New_Copy (Defining_Entity (N));
-
- if Nkind (Defining_Unit_Name (N)) = N_Defining_Program_Unit_Name then
- Act_Decl_Name :=
- Make_Defining_Program_Unit_Name (Loc,
- Name =>
- New_Copy_Tree (Name (Defining_Unit_Name (N))),
- Defining_Identifier => Act_Decl_Id);
- else
- Act_Decl_Name := Act_Decl_Id;
- end if;
-
- -- Case of instantiation of a formal package
-
- else
- Act_Decl_Id := Defining_Identifier (N);
- Act_Decl_Name := Act_Decl_Id;
- end if;
-
- Generate_Definition (Act_Decl_Id);
+ Act_Decl_Id := New_Copy (Defining_Entity (N));
Mutate_Ekind (Act_Decl_Id, E_Package);
Set_Is_Not_Self_Hidden (Act_Decl_Id);
@@ -4971,7 +4984,7 @@ package body Sem_Ch12 is
-- Except for an abbreviated instance created to check a formal package,
-- install the parent if this is a generic child unit.
- if not Is_Abbreviated_Instance (Inst_Id) then
+ if not Is_Abbrev then
Check_Generic_Child_Unit (Gen_Id, Parent_Installed);
end if;
@@ -5074,9 +5087,6 @@ package body Sem_Ch12 is
goto Leave;
else
- Mutate_Ekind (Inst_Id, E_Package);
- Set_Scope (Inst_Id, Current_Scope);
-
-- If the context of the instance is subject to SPARK_Mode "off" or
-- the annotation is altogether missing, set the global flag which
-- signals Analyze_Pragma to ignore all SPARK_Mode pragmas within
@@ -5114,22 +5124,38 @@ package body Sem_Ch12 is
-- If this is the instance created to validate an actual package,
-- only the formals matter, do not examine the package spec itself.
- if Is_Actual_Pack then
+ if Is_Abbrev then
Set_Visible_Declarations (Act_Spec, New_List);
Set_Private_Declarations (Act_Spec, New_List);
end if;
Renamings :=
Analyze_Associations
- (I_Node => N,
+ (N => N,
Formals => Generic_Formal_Declarations (Act_Tree),
F_Copy => Generic_Formal_Declarations (Gen_Decl));
Vis_Prims_List := Check_Hidden_Primitives (Renamings);
+ -- Set minimal decoration on the original entity
+
+ Mutate_Ekind (Defining_Entity (N), E_Package);
+ Set_Scope (Defining_Entity (N), Current_Scope);
+
Set_Instance_Env (Gen_Unit, Act_Decl_Id);
- Set_Defining_Unit_Name (Act_Spec, Act_Decl_Name);
Set_Is_Generic_Instance (Act_Decl_Id);
+ Generate_Definition (Act_Decl_Id);
+
+ if Nkind (Defining_Unit_Name (N)) = N_Defining_Program_Unit_Name then
+ Set_Defining_Unit_Name (Act_Spec,
+ Make_Defining_Program_Unit_Name (Loc,
+ Name =>
+ New_Copy_Tree (Name (Defining_Unit_Name (N))),
+ Defining_Identifier => Act_Decl_Id));
+ else
+ Set_Defining_Unit_Name (Act_Spec, Act_Decl_Id);
+ end if;
+
Set_Generic_Parent (Act_Spec, Gen_Unit);
-- References to the generic in its own declaration or its body are
@@ -5273,7 +5299,7 @@ package body Sem_Ch12 is
and then (not Is_Child_Unit (Gen_Unit)
or else not Is_Generic_Unit (Scope (Gen_Unit)))
and then Might_Inline_Subp (Gen_Unit)
- and then not Is_Actual_Pack
+ and then not Is_Abbrev
then
if not Back_End_Inlining
and then (Front_End_Inlining or else Has_Inline_Always)
@@ -5318,7 +5344,7 @@ package body Sem_Ch12 is
or else Enclosing_Body_Present
or else Present (Corresponding_Body (Gen_Decl)))
and then Needs_Body_Instantiated (Gen_Unit)
- and then not Is_Actual_Pack
+ and then not Is_Abbrev
and then not Inline_Now
and then (Operating_Mode = Generate_Code
or else (Operating_Mode = Check_Semantics
@@ -6031,6 +6057,10 @@ package body Sem_Ch12 is
if (Is_In_Main_Unit (N) or else Is_Inlined_Or_Child_Of_Inlined (Subp))
+ -- No need to instantiate bodies in generic units
+
+ and then not Is_Generic_Unit (Cunit_Entity (Main_Unit))
+
-- Must be generating code or analyzing code in GNATprove mode
and then (Operating_Mode = Generate_Code
@@ -6450,7 +6480,7 @@ package body Sem_Ch12 is
Renamings :=
Analyze_Associations
- (I_Node => N,
+ (N => N,
Formals => Generic_Formal_Declarations (Act_Tree),
F_Copy => Generic_Formal_Declarations (Gen_Decl));
@@ -6674,6 +6704,7 @@ package body Sem_Ch12 is
elsif Nkind (Parent (N)) = N_Compilation_Unit then
Rewrite (N, Unit (Parent (N)));
+ Move_Aspects (From => Original_Node (N), To => N);
Set_Unit (Parent (N), N);
end if;
@@ -6682,6 +6713,7 @@ package body Sem_Ch12 is
elsif Nkind (Parent (N)) = N_Compilation_Unit then
Rewrite (N, Unit (Parent (N)));
+ Move_Aspects (From => Original_Node (N), To => N);
Set_Unit (Parent (N), N);
end if;
@@ -7558,14 +7590,15 @@ package body Sem_Ch12 is
-------------------------------
procedure Check_Fixed_Point_Warning
- (Gen_Assocs : Associations.Gen_Assocs_Rec;
+ (Match : Associations.Match_Rec;
Renamings : List_Id)
is
use Associations;
+
begin
- for Type_Index in Gen_Assocs.Assocs'Range loop
+ for Type_Index in Match.Assocs'Range loop
declare
- Assoc : Assoc_Rec renames Gen_Assocs.Assocs (Type_Index);
+ Assoc : Assoc_Rec renames Match.Assocs (Type_Index);
begin
if Nkind (Assoc.An_Formal) = N_Formal_Type_Declaration
and then Is_Fixed_Point_Type (Defining_Entity (Assoc.An_Formal))
@@ -7594,9 +7627,9 @@ package body Sem_Ch12 is
Op := Alias (Node (Elem));
for Op_Index in Type_Index + 1 ..
- Gen_Assocs.Assocs'Last
+ Match.Assocs'Last
loop
- Formal := Gen_Assocs.Assocs (Op_Index).Un_Formal;
+ Formal := Match.Assocs (Op_Index).Un_Formal;
if Nkind (Formal) =
N_Formal_Concrete_Subprogram_Declaration
@@ -9340,9 +9373,6 @@ package body Sem_Ch12 is
and then Nkind (Ancestor_Type (N)) in N_Entity
then
declare
- Root_Typ : constant Entity_Id :=
- Root_Type (Ancestor_Type (N));
-
Typ : Entity_Id := Ancestor_Type (N);
begin
@@ -9351,7 +9381,7 @@ package body Sem_Ch12 is
Switch_View (Typ);
end if;
- exit when Typ = Root_Typ;
+ exit when Etype (Typ) = Typ;
Typ := Etype (Typ);
end loop;
@@ -10056,13 +10086,12 @@ package body Sem_Ch12 is
-- the freeze node for Inst must be inserted after that of
-- Parent_Inst. This relation is established by comparing
-- the Slocs of Parent_Inst freeze node and Inst.
- -- We examine the parents of the enclosing lists to handle
+ -- We examine the parents (of the enclosing lists) to handle
-- the case where the parent instance is in the visible part
-- of a package declaration, and the inner instance is in
-- the corresponding private part.
- if Parent (List_Containing (Freeze_Node (Par_Id)))
- = Parent (List_Containing (N))
+ if Parent (Freeze_Node (Par_Id)) = Parent (N)
and then Sloc (Freeze_Node (Par_Id)) <= Sloc (N)
then
Insert_Freeze_Node_For_Instance (N, F_Node);
@@ -10381,7 +10410,8 @@ package body Sem_Ch12 is
-- investigated, and would allow this function to be significantly
-- simplified. ???
- Inst := Package_Instantiation (A);
+ Inst :=
+ (if Ekind (A) = E_Package then Package_Instantiation (A) else Empty);
if Present (Inst) then
if Nkind (Inst) = N_Package_Instantiation then
@@ -10428,10 +10458,11 @@ package body Sem_Ch12 is
else
Inst := Next (Decl);
- while Nkind (Inst) not in N_Formal_Package_Declaration
- | N_Function_Instantiation
- | N_Package_Instantiation
- | N_Procedure_Instantiation
+ while Present (Inst)
+ and then Nkind (Inst) not in N_Formal_Package_Declaration
+ | N_Function_Instantiation
+ | N_Package_Instantiation
+ | N_Procedure_Instantiation
loop
Next (Inst);
end loop;
@@ -13034,10 +13065,6 @@ package body Sem_Ch12 is
Make_Defining_Identifier (Sloc (Act_Decl_Id), Chars (Act_Decl_Id));
Preserve_Comes_From_Source (Act_Body_Id, Act_Decl_Id);
- -- Some attributes of spec entity are not inherited by body entity
-
- Set_Handler_Records (Act_Body_Id, No_List);
-
if Nkind (Defining_Unit_Name (Act_Spec)) =
N_Defining_Program_Unit_Name
then
@@ -14132,6 +14159,16 @@ package body Sem_Ch12 is
T2 := Etype (I2);
end if;
+ -- In the case of a fixed-lower-bound subtype, we want to check
+ -- against the index type's range rather than the range of the
+ -- subtype (which will be seen as unconstrained, and whose bounds
+ -- won't generally match those of the formal unconstrained array
+ -- type's corresponding index type).
+
+ if Is_Fixed_Lower_Bound_Index_Subtype (T2) then
+ T2 := Etype (Scalar_Range (T2));
+ end if;
+
if not Subtypes_Match
(Find_Actual_Type (Etype (I1), A_Gen_T), T2)
then
diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb
index 072ec66..dcca3fc 100644
--- a/gcc/ada/sem_ch13.adb
+++ b/gcc/ada/sem_ch13.adb
@@ -29,11 +29,11 @@ with Atree; use Atree;
with Checks; use Checks;
with Contracts; use Contracts;
with Debug; use Debug;
-with Diagnostics.Constructors; use Diagnostics.Constructors;
with Einfo; use Einfo;
with Einfo.Entities; use Einfo.Entities;
with Einfo.Utils; use Einfo.Utils;
with Elists; use Elists;
+with Errid; use Errid;
with Errout; use Errout;
with Exp_Ch3; use Exp_Ch3;
with Exp_Disp; use Exp_Disp;
@@ -54,6 +54,7 @@ with Restrict; use Restrict;
with Rident; use Rident;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
+with Sem_Aggr; use Sem_Aggr;
with Sem_Aux; use Sem_Aux;
with Sem_Case; use Sem_Case;
with Sem_Cat; use Sem_Cat;
@@ -1620,6 +1621,7 @@ package body Sem_Ch13 is
-- Part_Of
-- Post
-- Pre
+ -- Program_Exit
-- Refined_Depends
-- Refined_Global
-- Refined_Post
@@ -1872,11 +1874,11 @@ package body Sem_Ch13 is
-- analyzed right now.
-- Note that there is a special handling for Pre, Post, Test_Case,
- -- Contract_Cases, Always_Terminates, Exit_Cases, Exceptional_Cases and
- -- Subprogram_Variant aspects. In these cases, we do not have to worry
- -- about delay issues, since the pragmas themselves deal with delay of
- -- visibility for the expression analysis. Thus, we just insert the
- -- pragma after the node N.
+ -- Contract_Cases, Always_Terminates, Exit_Cases, Exceptional_Cases,
+ -- Program_Exit and Subprogram_Variant aspects. In these cases, we do
+ -- not have to worry about delay issues, since the pragmas themselves
+ -- deal with delay of visibility for the expression analysis. Thus, we
+ -- just insert the pragma after the node N.
if No (L) then
return;
@@ -3873,6 +3875,89 @@ package body Sem_Ch13 is
goto Continue;
end Initial_Condition;
+ -- Initialize
+
+ when Aspect_Initialize => Initialize : declare
+ Aspect_Comp : Node_Id;
+ Type_Comp : Node_Id;
+ Typ : Entity_Id;
+ Dummy_Aggr : Node_Id;
+ begin
+ -- Error checking
+
+ if not All_Extensions_Allowed then
+ goto Continue;
+ end if;
+
+ if Ekind (E) /= E_Procedure then
+ Error_Msg_N ("Initialize must apply to a constructor", N);
+ end if;
+
+ if Present (Expressions (Expression (Aspect))) then
+ Error_Msg_N ("only component associations allowed", N);
+ end if;
+
+ -- Install the others for the aggregate if necessary
+
+ Typ := Etype (First_Entity (E));
+
+ if No (First_Entity (Typ)) then
+ Error_Msg_N
+ ("Initialize can only apply to contructors"
+ & " whose type has one or more components", N);
+ end if;
+
+ Aspect_Comp :=
+ First (Component_Associations (Expression (Aspect)));
+ Type_Comp := First_Entity (Typ);
+ while Present (Type_Comp) loop
+ if No (Aspect_Comp) then
+ Append_To
+ (Component_Associations (Expression (Aspect)),
+ Make_Component_Association (Loc,
+ Choices =>
+ New_List (Make_Others_Choice (Loc)),
+ Box_Present => True));
+ exit;
+ elsif Nkind (First (Choices (Aspect_Comp)))
+ = N_Others_Choice
+ then
+ exit;
+ end if;
+
+ Next (Aspect_Comp);
+ Next_Entity (Type_Comp);
+ end loop;
+
+ -- Push the scope and formals for analysis
+
+ Push_Scope (E);
+ Install_Formals (Defining_Unit_Name (Specification (N)));
+
+ -- Analyze the components
+
+ Aspect_Comp :=
+ First (Component_Associations (Expression (Aspect)));
+ while Present (Aspect_Comp) loop
+ if Present (Expression (Aspect_Comp)) then
+ Analyze (Expression (Aspect_Comp));
+ end if;
+
+ Next (Aspect_Comp);
+ end loop;
+
+ -- Do a psuedo pass over the aggregate to ensure it is valid
+
+ Expander_Active := False;
+ Dummy_Aggr := New_Copy_Tree (Expression (Aspect));
+ Resolve_Aggregate (Dummy_Aggr, Typ);
+ Expander_Active := True;
+
+ -- Return the scope
+
+ End_Scope;
+ end Initialize;
+
-- Initializes
-- Aspect Initializes is never delayed because it is equivalent
@@ -4346,6 +4431,10 @@ package body Sem_Ch13 is
Analyze_Aspect_Implicit_Dereference;
goto Continue;
+ when Aspect_Constructor =>
+ Set_Constructor_Name (E, Expr);
+ Set_Needs_Construction (E);
+
-- Dimension
when Aspect_Dimension =>
@@ -4366,8 +4455,9 @@ package body Sem_Ch13 is
-- Case 4: Aspects requiring special handling
-- Pre/Post/Test_Case/Contract_Cases/Always_Terminates/
- -- Exceptional_Cases/Exit_Cases and Subprogram_Variant whose
- -- corresponding pragmas take care of the delay.
+ -- Exceptional_Cases/Exit_Cases/Program_Exit and
+ -- Subprogram_Variant whose corresponding pragmas take care of
+ -- the delay.
-- Pre/Post
@@ -4573,6 +4663,19 @@ package body Sem_Ch13 is
Insert_Pragma (Aitem);
goto Continue;
+ -- Program_Exit
+
+ when Aspect_Program_Exit =>
+ Aitem := Make_Aitem_Pragma
+ (Pragma_Argument_Associations => New_List (
+ Make_Pragma_Argument_Association (Loc,
+ Expression => Relocate_Node (Expr))),
+ Pragma_Name => Name_Program_Exit);
+
+ Decorate (Aspect, Aitem);
+ Insert_Pragma (Aitem);
+ goto Continue;
+
-- Subprogram_Variant
when Aspect_Subprogram_Variant =>
@@ -6105,6 +6208,7 @@ package body Sem_Ch13 is
declare
Expr : constant Node_Id := Expression (N);
O_Ent : Entity_Id;
+ O_Typ : Entity_Id;
Off : Boolean;
begin
@@ -6117,7 +6221,7 @@ package body Sem_Ch13 is
return;
end if;
- Find_Overlaid_Entity (N, O_Ent, Off);
+ Find_Overlaid_Entity (N, O_Ent, O_Typ, Off);
if Present (O_Ent) then
@@ -6170,10 +6274,10 @@ package body Sem_Ch13 is
if (Is_Record_Type (Etype (U_Ent))
or else Is_Array_Type (Etype (U_Ent)))
- and then (Is_Record_Type (Etype (O_Ent))
- or else Is_Array_Type (Etype (O_Ent)))
+ and then (Is_Record_Type (O_Typ)
+ or else Is_Array_Type (O_Typ))
and then Reverse_Storage_Order (Etype (U_Ent)) /=
- Reverse_Storage_Order (Etype (O_Ent))
+ Reverse_Storage_Order (O_Typ)
then
Error_Msg_N
("??overlay changes scalar storage order", Expr);
@@ -6278,11 +6382,6 @@ package body Sem_Ch13 is
then
Set_Check_Address_Alignment (N);
end if;
-
- -- Kill the size check code, since we are not allocating
- -- the variable, it is somewhere else.
-
- Kill_Size_Check_Code (U_Ent);
end;
-- Not a valid entity for an address clause
@@ -6502,7 +6601,8 @@ package body Sem_Ch13 is
-- and restored before and after analysis.
Push_Type (U_Ent);
- Preanalyze_Spec_Expression (Expr, RTE (RE_CPU_Range));
+ Preanalyze_And_Resolve_Spec_Expression
+ (Expr, RTE (RE_CPU_Range));
Pop_Type (U_Ent);
-- AI12-0117-1, "Restriction No_Tasks_Unassigned_To_CPU":
@@ -6592,10 +6692,8 @@ package body Sem_Ch13 is
-- The visibility to the components must be restored
Push_Type (U_Ent);
-
- Preanalyze_Spec_Expression
+ Preanalyze_And_Resolve_Spec_Expression
(Expr, RTE (RE_Dispatching_Domain));
-
Pop_Type (U_Ent);
end if;
@@ -6674,10 +6772,8 @@ package body Sem_Ch13 is
-- The visibility to the components must be restored
Push_Type (U_Ent);
-
- Preanalyze_Spec_Expression
+ Preanalyze_And_Resolve_Spec_Expression
(Expr, RTE (RE_Interrupt_Priority));
-
Pop_Type (U_Ent);
-- Check the No_Task_At_Interrupt_Priority restriction
@@ -6843,7 +6939,8 @@ package body Sem_Ch13 is
-- The visibility to the components must be restored
Push_Type (U_Ent);
- Preanalyze_Spec_Expression (Expr, Standard_Integer);
+ Preanalyze_And_Resolve_Spec_Expression
+ (Expr, Standard_Integer);
Pop_Type (U_Ent);
if not Is_OK_Static_Expression (Expr) then
@@ -7154,7 +7251,7 @@ package body Sem_Ch13 is
else
Small := Expr_Value_R (Expr);
- if Small <= Ureal_0 then
+ if not UR_Is_Positive (Small) then
Error_Msg_N ("small value must be greater than zero", Expr);
return;
end if;
@@ -9889,6 +9986,12 @@ package body Sem_Ch13 is
-- Includes a call to the predicate function for type T in Expr if
-- Predicate_Function (T) is non-empty.
+ function Has_Source_Predicate (T : Entity_Id) return Boolean;
+ -- Return True if one of the 3 predicate aspects is specified
+ -- explicitly (either via a pragma or an aspect specification, but
+ -- not implicitly via propagation from some other type/subtype via
+ -- RM 3.2.4(5)) for the type/subtype T.
+
procedure Replace_Current_Instance_References
(N : Node_Id; Typ, New_Entity : Entity_Id);
-- Replace all references to Typ in the tree rooted at N with
@@ -10039,8 +10142,8 @@ package body Sem_Ch13 is
-- If the predicate pragma comes from an aspect, replace the
-- saved expression because we need the subtype references
- -- replaced for the calls to Preanalyze_Spec_Expression in
- -- Check_Aspect_At_xxx routines.
+ -- replaced for the calls to Preanalyze_And_Resolve_Spec_
+ -- Expression in Check_Aspect_At_xxx routines.
if Present (Asp) then
Set_Expression_Copy (Asp, New_Copy_Tree (Arg2_Copy));
@@ -10105,6 +10208,41 @@ package body Sem_Ch13 is
end loop;
end Add_Predicates;
+ --------------------------
+ -- Has_Source_Predicate --
+ --------------------------
+
+ function Has_Source_Predicate (T : Entity_Id) return Boolean is
+ Rep_Item : Node_Id := First_Rep_Item (T);
+ begin
+ while Present (Rep_Item) loop
+ case Nkind (Rep_Item) is
+ when N_Pragma =>
+ if Get_Pragma_Id (Rep_Item) = Pragma_Predicate
+ and then T = Entity (Expression
+ (First (Pragma_Argument_Associations (Rep_Item))))
+ then
+ return True;
+ end if;
+
+ when N_Aspect_Specification =>
+ if Get_Aspect_Id (Rep_Item) in
+ Aspect_Static_Predicate
+ | Aspect_Dynamic_Predicate | Aspect_Predicate
+ and then Entity (Rep_Item) = T
+ then
+ return True;
+ end if;
+
+ when others =>
+ null;
+ end case;
+
+ Next_Rep_Item (Rep_Item);
+ end loop;
+ return False;
+ end Has_Source_Predicate;
+
-----------------------------------------
-- Replace_Current_Instance_References --
-----------------------------------------
@@ -10148,6 +10286,21 @@ package body Sem_Ch13 is
-- context where expansion and tests are enabled.
SId := Predicate_Function (Typ);
+
+ -- When declaring a subtype S whose "predecessor" subtype PS (that is,
+ -- the subtype denoted by the subtype_mark in the declaration of S)
+ -- already has a predicate function, do not confuse that existing
+ -- function for PS with the function we need to build for S if
+ -- Has_Source_Predicate returns True for S.
+
+ if Present (SId)
+ and then Nkind (Parent (Typ)) = N_Subtype_Declaration
+ and then Etype (First_Entity (SId)) /= Typ
+ and then Has_Source_Predicate (Typ)
+ then
+ SId := Empty;
+ end if;
+
if not Has_Predicates (Typ)
or else (Present (SId) and then Has_Completion (SId))
or else
@@ -10806,7 +10959,8 @@ 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 in Aspect_Input
+ elsif A_Id in Aspect_Constructor
+ | Aspect_Input
| Aspect_Output
| Aspect_Read
| Aspect_Write
@@ -10853,12 +11007,14 @@ package body Sem_Ch13 is
| Aspect_Static_Predicate
then
Push_Type (Ent);
- Preanalyze_Spec_Expression (Freeze_Expr, Standard_Boolean);
+ Preanalyze_And_Resolve_Spec_Expression
+ (Freeze_Expr, Standard_Boolean);
Pop_Type (Ent);
elsif A_Id = Aspect_Priority then
Push_Type (Ent);
- Preanalyze_Spec_Expression (Freeze_Expr, Any_Integer);
+ Preanalyze_And_Resolve_Spec_Expression
+ (Freeze_Expr, Any_Integer);
Pop_Type (Ent);
else
@@ -10908,7 +11064,8 @@ package body Sem_Ch13 is
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));
+ Preanalyze_And_Resolve_Spec_Expression
+ (End_Decl_Expr, Full_View (T));
-- The following aspect expressions may contain references to
-- components and discriminants of the type.
@@ -10922,14 +11079,15 @@ package body Sem_Ch13 is
| Aspect_Static_Predicate
then
Push_Type (Ent);
- Preanalyze_Spec_Expression (End_Decl_Expr, T);
+ Preanalyze_And_Resolve_Spec_Expression (End_Decl_Expr, T);
Pop_Type (Ent);
elsif A_Id = Aspect_Predicate_Failure then
- Preanalyze_Spec_Expression (End_Decl_Expr, Standard_String);
+ Preanalyze_And_Resolve_Spec_Expression
+ (End_Decl_Expr, Standard_String);
elsif Present (End_Decl_Expr) then
- Preanalyze_Spec_Expression (End_Decl_Expr, T);
+ Preanalyze_And_Resolve_Spec_Expression (End_Decl_Expr, T);
end if;
Err :=
@@ -11112,7 +11270,8 @@ package body Sem_Ch13 is
-- Special case, the expression of these aspects is just an entity
-- that does not need any resolution, so just analyze.
- when Aspect_Input
+ when Aspect_Constructor
+ | Aspect_Input
| Aspect_Output
| Aspect_Put_Image
| Aspect_Read
@@ -11324,6 +11483,7 @@ package body Sem_Ch13 is
| Aspect_GNAT_Annotate
| Aspect_Implicit_Dereference
| Aspect_Initial_Condition
+ | Aspect_Initialize
| Aspect_Initializes
| Aspect_Max_Entry_Queue_Length
| Aspect_Max_Queue_Length
@@ -11333,6 +11493,7 @@ package body Sem_Ch13 is
| Aspect_Postcondition
| Aspect_Pre
| Aspect_Precondition
+ | Aspect_Program_Exit
| Aspect_Refined_Depends
| Aspect_Refined_Global
| Aspect_Refined_Post
@@ -11359,7 +11520,7 @@ package body Sem_Ch13 is
-- the aspect_specification cause freezing (RM 13.14(7.2/5)).
if Present (Expression (ASN)) then
- Preanalyze_Spec_Expression (Expression (ASN), T);
+ Preanalyze_And_Resolve_Spec_Expression (Expression (ASN), T);
end if;
end Check_Aspect_At_Freeze_Point;
@@ -12082,18 +12243,15 @@ package body Sem_Ch13 is
if not Check_Primitive_Function (Subp, Typ) then
if Present (Ref_Node) then
- if Debug_Flag_Underscore_DD then
- Record_Default_Iterator_Not_Primitive_Error
- (Ref_Node, Subp);
- else
- Error_Msg_N ("improper function for default iterator!",
- Ref_Node);
- Error_Msg_Sloc := Sloc (Subp);
- Error_Msg_NE
- ("\\default iterator defined # "
- & "must be a local primitive or class-wide function",
- Ref_Node, Subp);
- end if;
+ Error_Msg_N
+ ("improper function for default iterator!",
+ Ref_Node,
+ GNAT0001);
+ Error_Msg_Sloc := Sloc (Subp);
+ Error_Msg_NE
+ ("\\default iterator defined # "
+ & "must be a local primitive or class-wide function",
+ Ref_Node, Subp);
end if;
return False;
@@ -13928,7 +14086,7 @@ package body Sem_Ch13 is
Next (First (Pragma_Argument_Associations (Ritem)));
begin
Push_Type (E);
- Preanalyze_Spec_Expression
+ Preanalyze_And_Resolve_Spec_Expression
(Expression (Arg), Standard_Boolean);
Pop_Type (E);
end;
@@ -15786,27 +15944,36 @@ package body Sem_Ch13 is
-- anyway, no reason to be too strict about this.
if not Relaxed_RM_Semantics then
- if Debug_Flag_Underscore_DD then
-
- S := First_Subtype (T);
- if Present (Freeze_Node (S)) then
- Record_Representation_Too_Late_Error
- (Rep => N,
- Freeze => Freeze_Node (S),
- Def => S);
- else
- Error_Msg_N ("|representation item appears too late!", N);
- end if;
-
+ S := First_Subtype (T);
+ if Present (Freeze_Node (S)) then
+ Error_Msg_N
+ (Msg =>
+ "record representation cannot be specified" &
+ " after the type is frozen",
+ N => N,
+ Error_Code => GNAT0005,
+ Label =>
+ "record representation clause specified here",
+ Spans =>
+ (1 =>
+ Secondary_Labeled_Span
+ (N => Freeze_Node (S),
+ Label =>
+ "Type " & To_Name (S) &
+ " is frozen here"),
+ 2 =>
+ Secondary_Labeled_Span
+ (N => S,
+ Label =>
+ "Type " & To_Name (S) &
+ " is declared here")));
+ Error_Msg_Sloc := Sloc (Freeze_Node (S));
+ Error_Msg_N
+ ("\\move the record representation clause" &
+ " before the freeze point #",
+ N);
else
Error_Msg_N ("|representation item appears too late!", N);
-
- S := First_Subtype (T);
- if Present (Freeze_Node (S)) then
- Error_Msg_NE
- ("??no more representation items for }",
- Freeze_Node (S), S);
- end if;
end if;
end if;
end Too_Late;
@@ -16345,6 +16512,9 @@ package body Sem_Ch13 is
=>
null;
+ when Aspect_Constructor =>
+ null;
+
when Aspect_Dynamic_Predicate
| Aspect_Ghost_Predicate
| Aspect_Predicate
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index 74eac9c..45b28bf 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -41,7 +41,6 @@ with Exp_Disp; use Exp_Disp;
with Exp_Dist; use Exp_Dist;
with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
-with Expander; use Expander;
with Fmap;
with Freeze; use Freeze;
with Ghost; use Ghost;
@@ -291,6 +290,15 @@ package body Sem_Ch3 is
-- Check that the expression represented by E is suitable for use as a
-- digits expression, i.e. it is of integer type, positive and static.
+ procedure Check_Discriminant_Conformance
+ (N : Node_Id;
+ Prev : Entity_Id;
+ Prev_Loc : Node_Id);
+ -- Check that the discriminants of a full type N fully conform to the
+ -- discriminants of the corresponding partial view Prev. Prev_Loc indicates
+ -- the source location of the partial view, which may be different than
+ -- Prev in the case of private types.
+
procedure Check_Initialization (T : Entity_Id; Exp : Node_Id);
-- Validate the initialization of an object declaration. T is the required
-- type, and Exp is the initialization expression.
@@ -383,7 +391,7 @@ package body Sem_Ch3 is
-- created in the procedure and attached to Related_Nod.
procedure Constrain_Array
- (Def_Id : in out Entity_Id;
+ (Def_Id : Entity_Id;
SI : Node_Id;
Related_Nod : Node_Id;
Related_Id : Entity_Id;
@@ -623,9 +631,11 @@ package body Sem_Ch3 is
-- Create a new ordinary fixed point type, and apply the constraint to
-- obtain subtype of it.
- procedure Preanalyze_Default_Expression (N : Node_Id; T : Entity_Id);
- -- Wrapper on Preanalyze_Spec_Expression for default expressions, so that
- -- In_Default_Expr can be properly adjusted.
+ procedure Preanalyze_And_Resolve_Default_Expression
+ (N : Node_Id;
+ T : Entity_Id);
+ -- Wrapper on Preanalyze_And_Resolve_Spec_Expression for default
+ -- expressions, so that In_Default_Expr can be properly adjusted.
procedure Prepare_Private_Subtype_Completion
(Id : Entity_Id;
@@ -1307,14 +1317,6 @@ package body Sem_Ch3 is
Reinit_Size_Align (T_Name);
Set_Directly_Designated_Type (T_Name, Desig_Type);
- -- If the access_to_subprogram is not declared at the library level,
- -- it can only point to subprograms that are at the same or deeper
- -- accessibility level. The corresponding subprogram type might
- -- require an activation record when compiling for C.
-
- Set_Needs_Activation_Record (Desig_Type,
- not Is_Library_Level_Entity (T_Name));
-
Generate_Reference_To_Formals (T_Name);
-- Ada 2005 (AI-231): Propagate the null-excluding attribute
@@ -1421,7 +1423,9 @@ package body Sem_Ch3 is
end if;
else
- Setup_Access_Type (Desig_Typ => Process_Subtype (S, P, T, 'P'));
+ Setup_Access_Type
+ (Desig_Typ =>
+ Process_Subtype (S, P, T, 'P', Incomplete_Type_OK => True));
end if;
if not Error_Posted (T) then
@@ -1958,7 +1962,7 @@ package body Sem_Ch3 is
procedure Analyze_Component_Declaration (N : Node_Id) is
Id : constant Entity_Id := Defining_Identifier (N);
E : constant Node_Id := Expression (N);
- Typ : constant Node_Id :=
+ Ind : constant Node_Id :=
Subtype_Indication (Component_Definition (N));
T : Entity_Id;
P : Entity_Id;
@@ -2053,10 +2057,11 @@ package body Sem_Ch3 is
-- Start of processing for Analyze_Component_Declaration
begin
+ Mutate_Ekind (Id, E_Component);
Generate_Definition (Id);
Enter_Name (Id);
- if Present (Typ) then
+ if Present (Ind) then
T := Find_Type_Of_Object
(Subtype_Indication (Component_Definition (N)), N);
@@ -2110,7 +2115,7 @@ package body Sem_Ch3 is
-- package Sem).
if Present (E) then
- Preanalyze_Default_Expression (E, T);
+ Preanalyze_And_Resolve_Default_Expression (E, T);
Check_Initialization (T, E);
if Ada_Version >= Ada_2005
@@ -2507,7 +2512,8 @@ package body Sem_Ch3 is
(First (Pragma_Argument_Associations (ASN))));
Set_Parent (Exp, ASN);
- Preanalyze_Assert_Expression (Exp, Standard_Boolean);
+ Preanalyze_And_Resolve_Assert_Expression
+ (Exp, Standard_Boolean);
end if;
ASN := Next_Pragma (ASN);
@@ -3200,7 +3206,7 @@ package body Sem_Ch3 is
and then Present (Full_View (Prev))
then
T := Full_View (Prev);
- Set_Incomplete_View (N, Prev);
+ Set_Incomplete_View (T, Prev);
else
T := Prev;
end if;
@@ -3551,6 +3557,13 @@ package body Sem_Ch3 is
end;
end if;
end if;
+
+ if Ekind (T) = E_Record_Type
+ and then Is_Large_Unconstrained_Definite (T)
+ and then not Is_Limited_Type (T)
+ then
+ Error_Msg_N ("??creation of & object may raise Storage_Error!", T);
+ end if;
end Analyze_Full_Type_Declaration;
----------------------------------
@@ -3700,8 +3713,8 @@ package body Sem_Ch3 is
Set_Is_Static_Expression (E, True);
Set_Etype (E, Universal_Integer);
- Set_Etype (Id, Universal_Integer);
Mutate_Ekind (Id, E_Named_Integer);
+ Set_Etype (Id, Universal_Integer);
Set_Is_Frozen (Id, True);
Set_Debug_Info_Needed (Id);
@@ -3761,8 +3774,8 @@ package body Sem_Ch3 is
if Is_Integer_Type (T) then
Resolve (E, T);
- Set_Etype (Id, Universal_Integer);
Mutate_Ekind (Id, E_Named_Integer);
+ Set_Etype (Id, Universal_Integer);
elsif Is_Real_Type (T) then
@@ -3793,15 +3806,15 @@ package body Sem_Ch3 is
end if;
Resolve (E, T);
- Set_Etype (Id, Universal_Real);
Mutate_Ekind (Id, E_Named_Real);
+ Set_Etype (Id, Universal_Real);
else
Wrong_Type (E, Any_Numeric);
Resolve (E, T);
- Set_Etype (Id, T);
Mutate_Ekind (Id, E_Constant);
+ Set_Etype (Id, T);
Set_Never_Set_In_Source (Id, True);
Set_Is_True_Constant (Id, True);
return;
@@ -3950,7 +3963,7 @@ package body Sem_Ch3 is
Data_Path_String : constant String :=
Absolute_Dir
& System.OS_Lib.Directory_Separator
- & Stringt.To_String (Strval (Def));
+ & S;
begin
Data_Path := Name_Find (Data_Path_String);
@@ -4363,6 +4376,12 @@ package body Sem_Ch3 is
-- Start of processing for Analyze_Object_Declaration
begin
+ if Constant_Present (N) then
+ Mutate_Ekind (Id, E_Constant);
+ else
+ Mutate_Ekind (Id, E_Variable);
+ end if;
+
-- There are three kinds of implicit types generated by an
-- object declaration:
@@ -4442,7 +4461,6 @@ package body Sem_Ch3 is
T := Find_Type_Of_Object (Object_Definition (N), N);
Set_Etype (Id, T);
- Mutate_Ekind (Id, E_Variable);
goto Leave;
end if;
@@ -4468,7 +4486,6 @@ package body Sem_Ch3 is
if Error_Posted (Id) then
Set_Etype (Id, T);
- Mutate_Ekind (Id, E_Variable);
goto Leave;
end if;
end if;
@@ -4551,7 +4568,6 @@ package body Sem_Ch3 is
Error_Msg_N
("\declaration requires an initialization expression",
N);
- Set_Constant_Present (N, False);
-- In Ada 83, deferred constant must be of private type
@@ -4658,9 +4674,7 @@ package body Sem_Ch3 is
Set_Has_Completion (Id);
end if;
- -- Set type and resolve (type may be overridden later on). Note:
- -- Ekind (Id) must still be E_Void at this point so that incorrect
- -- early usage within E is properly diagnosed.
+ -- Set type and resolve (type may be overridden later on)
Set_Etype (Id, T);
@@ -4760,7 +4774,6 @@ package body Sem_Ch3 is
and then In_Subrange_Of (Etype (Entity (E)), T)
then
Set_Is_Known_Valid (Id);
- Mutate_Ekind (Id, E_Constant);
Set_Actual_Subtype (Id, Etype (Entity (E)));
end if;
@@ -4991,7 +5004,7 @@ package body Sem_Ch3 is
if Is_Array_Type (T)
and then No_Initialization (N)
- and then Nkind (Original_Node (E)) = N_Aggregate
+ and then Nkind (Unqualify (Original_Node (E))) = N_Aggregate
then
Act_T := Etype (E);
@@ -5009,12 +5022,6 @@ package body Sem_Ch3 is
-- for discriminants and are thus not indefinite.
elsif Is_Unchecked_Union (T) then
- if Constant_Present (N) or else Nkind (E) = N_Function_Call then
- Mutate_Ekind (Id, E_Constant);
- else
- Mutate_Ekind (Id, E_Variable);
- end if;
-
-- If the expression is an aggregate it contains the required
-- discriminant values but it has not been resolved yet, so do
-- it now, and treat it as the initial expression of an object
@@ -5075,10 +5082,8 @@ package body Sem_Ch3 is
-- "X : Integer := X;".
if Constant_Present (N) then
- Mutate_Ekind (Id, E_Constant);
Set_Is_True_Constant (Id);
else
- Mutate_Ekind (Id, E_Variable);
if Present (E) then
Set_Has_Initial_Value (Id);
end if;
@@ -5137,10 +5142,7 @@ package body Sem_Ch3 is
elsif Is_Array_Type (T)
and then No_Initialization (N)
- and then (Nkind (Original_Node (E)) = N_Aggregate
- or else (Nkind (Original_Node (E)) = N_Qualified_Expression
- and then Nkind (Original_Node (Expression
- (Original_Node (E)))) = N_Aggregate))
+ and then Nkind (Unqualify (Original_Node (E))) = N_Aggregate
then
if not Is_Entity_Name (Object_Definition (N)) then
Act_T := Etype (E);
@@ -5223,12 +5225,9 @@ package body Sem_Ch3 is
end if;
if Constant_Present (N) then
- Mutate_Ekind (Id, E_Constant);
Set_Is_True_Constant (Id);
else
- Mutate_Ekind (Id, E_Variable);
-
-- A variable is set as shared passive if it appears in a shared
-- passive package, and is at the outer level. This is not done for
-- entities generated during expansion, because those are always
@@ -5329,17 +5328,14 @@ package body Sem_Ch3 is
else
Validate_Controlled_Object (Id);
end if;
+ end if;
- -- If the type of a constrained array has an unconstrained first
- -- subtype, its Finalize_Address primitive expects the address of
- -- an object with a dope vector (see Make_Finalize_Address_Stmts).
+ -- If the type of a constrained array has an unconstrained first
+ -- subtype, its Finalize_Address primitive expects the address of
+ -- an object with a dope vector (see Make_Finalize_Address_Stmts).
- if Is_Array_Type (Etype (Id))
- and then Is_Constrained (Etype (Id))
- and then not Is_Constrained (First_Subtype (Etype (Id)))
- then
- Set_Is_Constr_Array_Subt_With_Bounds (Etype (Id));
- end if;
+ if Is_Constr_Array_Subt_Of_Unc_With_Controlled (Etype (Id)) then
+ Set_Is_Constr_Array_Subt_With_Bounds (Etype (Id));
end if;
if Has_Task (Etype (Id)) then
@@ -5738,6 +5734,25 @@ package body Sem_Ch3 is
Id : constant Entity_Id := Defining_Identifier (N);
T : Entity_Id;
+ procedure Copy_Parent_Attributes;
+ -- Copy fields that don't depend on the type kind from the subtype
+ -- denoted by the subtype mark.
+
+ ----------------------------
+ -- Copy_Parent_Attributes --
+ ----------------------------
+
+ procedure Copy_Parent_Attributes is
+ begin
+ Set_Etype (Id, Base_Type (T));
+ Set_Is_Volatile (Id, Is_Volatile (T));
+ Set_Treat_As_Volatile (Id, Treat_As_Volatile (T));
+ Set_Is_Generic_Type (Id, Is_Generic_Type (Base_Type (T)));
+ Set_Convention (Id, Convention (T));
+ end Copy_Parent_Attributes;
+
+ -- Start of processing for Analyze_Subtype_Declaration
+
begin
Generate_Definition (Id);
Set_Is_Pure (Id, Is_Pure (Current_Scope));
@@ -5781,7 +5796,15 @@ package body Sem_Ch3 is
Enter_Name (Id);
end if;
- T := Process_Subtype (Subtype_Indication (N), N, Id, 'P');
+ T :=
+ Process_Subtype
+ (Subtype_Indication (N),
+ N,
+ Id,
+ 'P',
+ Excludes_Null => Null_Exclusion_Present (N),
+ Incomplete_Type_OK =>
+ Ada_Version >= Ada_2005 or else Is_Itype (Id));
-- Class-wide equivalent types of records with unknown discriminants
-- involve the generation of an itype which serves as the private view
@@ -5796,13 +5819,6 @@ package body Sem_Ch3 is
T := Full_View (T);
end if;
- -- Inherit common attributes
-
- Set_Is_Volatile (Id, Is_Volatile (T));
- Set_Treat_As_Volatile (Id, Treat_As_Volatile (T));
- Set_Is_Generic_Type (Id, Is_Generic_Type (Base_Type (T)));
- Set_Convention (Id, Convention (T));
-
-- If ancestor has predicates then so does the subtype, and in addition
-- we must delay the freeze to properly arrange predicate inheritance.
@@ -5842,16 +5858,16 @@ package body Sem_Ch3 is
-- semantic attributes must be established here.
if Nkind (Subtype_Indication (N)) /= N_Subtype_Indication then
- Set_Etype (Id, Base_Type (T));
-
case Ekind (T) is
when Array_Kind =>
Mutate_Ekind (Id, E_Array_Subtype);
+ Copy_Parent_Attributes;
Copy_Array_Subtype_Attributes (Id, T);
Set_Packed_Array_Impl_Type (Id, Packed_Array_Impl_Type (T));
when Decimal_Fixed_Point_Kind =>
Mutate_Ekind (Id, E_Decimal_Fixed_Point_Subtype);
+ Copy_Parent_Attributes;
Set_Digits_Value (Id, Digits_Value (T));
Set_Delta_Value (Id, Delta_Value (T));
Set_Scale_Value (Id, Scale_Value (T));
@@ -5864,6 +5880,7 @@ package body Sem_Ch3 is
when Enumeration_Kind =>
Mutate_Ekind (Id, E_Enumeration_Subtype);
+ Copy_Parent_Attributes;
Set_First_Literal (Id, First_Literal (Base_Type (T)));
Set_Scalar_Range (Id, Scalar_Range (T));
Set_Is_Character_Type (Id, Is_Character_Type (T));
@@ -5873,6 +5890,7 @@ package body Sem_Ch3 is
when Ordinary_Fixed_Point_Kind =>
Mutate_Ekind (Id, E_Ordinary_Fixed_Point_Subtype);
+ Copy_Parent_Attributes;
Set_Scalar_Range (Id, Scalar_Range (T));
Set_Small_Value (Id, Small_Value (T));
Set_Delta_Value (Id, Delta_Value (T));
@@ -5882,6 +5900,7 @@ package body Sem_Ch3 is
when Float_Kind =>
Mutate_Ekind (Id, E_Floating_Point_Subtype);
+ Copy_Parent_Attributes;
Set_Scalar_Range (Id, Scalar_Range (T));
Set_Digits_Value (Id, Digits_Value (T));
Set_Is_Constrained (Id, Is_Constrained (T));
@@ -5891,6 +5910,7 @@ package body Sem_Ch3 is
when Signed_Integer_Kind =>
Mutate_Ekind (Id, E_Signed_Integer_Subtype);
+ Copy_Parent_Attributes;
Set_Scalar_Range (Id, Scalar_Range (T));
Set_Is_Constrained (Id, Is_Constrained (T));
Set_Is_Known_Valid (Id, Is_Known_Valid (T));
@@ -5898,6 +5918,7 @@ package body Sem_Ch3 is
when Modular_Integer_Kind =>
Mutate_Ekind (Id, E_Modular_Integer_Subtype);
+ Copy_Parent_Attributes;
Set_Scalar_Range (Id, Scalar_Range (T));
Set_Is_Constrained (Id, Is_Constrained (T));
Set_Is_Known_Valid (Id, Is_Known_Valid (T));
@@ -5905,6 +5926,7 @@ package body Sem_Ch3 is
when Class_Wide_Kind =>
Mutate_Ekind (Id, E_Class_Wide_Subtype);
+ Copy_Parent_Attributes;
Set_Class_Wide_Type (Id, Class_Wide_Type (T));
Set_Cloned_Subtype (Id, T);
Set_Is_Tagged_Type (Id, True);
@@ -5922,6 +5944,7 @@ package body Sem_Ch3 is
| E_Record_Type
=>
Mutate_Ekind (Id, E_Record_Subtype);
+ Copy_Parent_Attributes;
-- Subtype declarations introduced for formal type parameters
-- in generic instantiations should inherit the Size value of
@@ -5973,6 +5996,7 @@ package body Sem_Ch3 is
when Private_Kind =>
Mutate_Ekind (Id, Subtype_Kind (Ekind (T)));
+ Copy_Parent_Attributes;
Set_Has_Discriminants (Id, Has_Discriminants (T));
Set_Is_Constrained (Id, Is_Constrained (T));
Set_First_Entity (Id, First_Entity (T));
@@ -6036,6 +6060,7 @@ package body Sem_Ch3 is
when Access_Kind =>
Mutate_Ekind (Id, E_Access_Subtype);
+ Copy_Parent_Attributes;
Set_Is_Constrained (Id, Is_Constrained (T));
Set_Is_Access_Constant
(Id, Is_Access_Constant (T));
@@ -6059,6 +6084,7 @@ package body Sem_Ch3 is
when Concurrent_Kind =>
Mutate_Ekind (Id, Subtype_Kind (Ekind (T)));
+ Copy_Parent_Attributes;
Set_Corresponding_Record_Type (Id,
Corresponding_Record_Type (T));
Set_First_Entity (Id, First_Entity (T));
@@ -6087,6 +6113,7 @@ package body Sem_Ch3 is
-- subtypes for Ada 2012 extended use of incomplete types.
Mutate_Ekind (Id, E_Incomplete_Subtype);
+ Copy_Parent_Attributes;
Set_Is_Tagged_Type (Id, Is_Tagged_Type (T));
Set_Private_Dependents (Id, New_Elmt_List);
@@ -6127,6 +6154,8 @@ package body Sem_Ch3 is
-- declared entity inherits predicates from the parent.
Inherit_Predicate_Flags (Id, T);
+ else
+ Copy_Parent_Attributes;
end if;
if Etype (Id) = Any_Type then
@@ -6461,12 +6490,15 @@ package body Sem_Ch3 is
Priv : Entity_Id;
Related_Id : Entity_Id;
Has_FLB_Index : Boolean := False;
+ K : Entity_Kind;
begin
if Nkind (Def) = N_Constrained_Array_Definition then
Index := First (Discrete_Subtype_Definitions (Def));
+ K := E_Array_Subtype;
else
Index := First (Subtype_Marks (Def));
+ K := E_Array_Type;
end if;
-- Find proper names for the implicit types which may be public. In case
@@ -6598,7 +6630,13 @@ package body Sem_Ch3 is
-- Process subtype indication if one is present
if Present (Component_Typ) then
- Element_Type := Process_Subtype (Component_Typ, P, Related_Id, 'C');
+ Element_Type :=
+ Process_Subtype
+ (Component_Typ,
+ P,
+ Related_Id,
+ 'C',
+ Excludes_Null => Null_Exclusion_Present (Component_Def));
Set_Etype (Component_Typ, Element_Type);
-- Ada 2005 (AI-230): Access Definition case
@@ -6633,17 +6671,17 @@ package body Sem_Ch3 is
end;
end if;
- -- Constrained array case
-
if No (T) then
-- We might be creating more than one itype with the same Related_Id,
-- e.g. for an array object definition and its initial value. Give
-- them unique suffixes, because GNATprove require distinct types to
-- have different names.
- T := Create_Itype (E_Void, P, Related_Id, 'T', Suffix_Index => -1);
+ T := Create_Itype (K, P, Related_Id, 'T', Suffix_Index => -1);
end if;
+ -- Constrained array case
+
if Nkind (Def) = N_Constrained_Array_Definition then
Index := First (Discrete_Subtype_Definitions (Def));
@@ -7214,7 +7252,11 @@ package body Sem_Ch3 is
Set_Directly_Designated_Type
(Derived_Type, Designated_Type (Parent_Type));
- Subt := Process_Subtype (S, N);
+ Subt :=
+ Process_Subtype
+ (S,
+ N,
+ Excludes_Null => Null_Exclusion_Present (Type_Definition (N)));
if Nkind (S) /= N_Subtype_Indication
and then Subt /= Base_Type (Subt)
@@ -8116,9 +8158,6 @@ package body Sem_Ch3 is
Set_Non_Binary_Modulus
(Implicit_Base, Non_Binary_Modulus (Parent_Base));
- Set_Is_Known_Valid
- (Implicit_Base, Is_Known_Valid (Parent_Base));
-
elsif Is_Floating_Point_Type (Parent_Type) then
-- Digits of base type is always copied from the digits value of
@@ -8491,11 +8530,19 @@ package body Sem_Ch3 is
Analyze (Decl);
- pragma Assert (Has_Discriminants (Full_Der)
- and then not Has_Unknown_Discriminants (Full_Der));
+ pragma
+ Assert
+ ((Has_Discriminants (Full_Der)
+ and then not Has_Unknown_Discriminants (Full_Der))
+ or else Serious_Errors_Detected > 0);
Uninstall_Declarations (Par_Scope);
+ if Etype (Full_Der) = Any_Type then
+ pragma Assert (Serious_Errors_Detected > 0);
+ return;
+ end if;
+
-- Freeze the underlying record view, to prevent generation of
-- useless dispatching information, which is simply shared with
-- the real derived type.
@@ -9460,8 +9507,8 @@ package body Sem_Ch3 is
if Constraint_Present then
if not Has_Discriminants (Parent_Base)
or else
- (Has_Unknown_Discriminants (Parent_Base)
- and then Is_Private_Type (Parent_Base))
+ (Has_Unknown_Discriminants (Parent_Type)
+ and then Is_Private_Type (Parent_Type))
then
Error_Msg_N
("invalid constraint: type has no discriminant",
@@ -11985,7 +12032,7 @@ package body Sem_Ch3 is
Insert_Before (Typ_Decl, Decl);
Analyze (Decl);
Set_Full_View (Inc_T, Typ);
- Set_Incomplete_View (Typ_Decl, Inc_T);
+ Set_Incomplete_View (Typ, Inc_T);
-- If the type is tagged, create a common class-wide type for
-- both views, and set the Etype of the class-wide type to the
@@ -12670,6 +12717,249 @@ package body Sem_Ch3 is
end Check_Digits_Expression;
+ ------------------------------------
+ -- Check_Discriminant_Conformance --
+ ------------------------------------
+
+ procedure Check_Discriminant_Conformance
+ (N : Node_Id;
+ Prev : Entity_Id;
+ Prev_Loc : Node_Id)
+ is
+ Old_Discr : Entity_Id := First_Discriminant (Prev);
+ New_Discr : Node_Id := First (Discriminant_Specifications (N));
+ New_Discr_Id : Entity_Id;
+ New_Discr_Type : Entity_Id;
+
+ procedure Conformance_Error (Msg : String; N : Node_Id);
+ -- Post error message for conformance error on given node. Two messages
+ -- are output. The first points to the previous declaration with a
+ -- general "no conformance" message. The second is the detailed reason,
+ -- supplied as Msg. The parameter N provide information for a possible
+ -- & insertion in the message.
+
+ -----------------------
+ -- Conformance_Error --
+ -----------------------
+
+ procedure Conformance_Error (Msg : String; N : Node_Id) is
+ begin
+ Error_Msg_Sloc := Sloc (Prev_Loc);
+ Error_Msg_N -- CODEFIX
+ ("not fully conformant with declaration#!", N);
+ Error_Msg_NE (Msg, N, N);
+ end Conformance_Error;
+
+ -- Start of processing for Check_Discriminant_Conformance
+
+ begin
+ while Present (Old_Discr) and then Present (New_Discr) loop
+ New_Discr_Id := Defining_Identifier (New_Discr);
+
+ -- The subtype mark of the discriminant on the full type has not
+ -- been analyzed so we do it here. For an access discriminant a new
+ -- type is created.
+
+ if Nkind (Discriminant_Type (New_Discr)) = N_Access_Definition then
+ New_Discr_Type :=
+ Access_Definition (N, Discriminant_Type (New_Discr));
+
+ else
+ Find_Type (Discriminant_Type (New_Discr));
+ New_Discr_Type := Etype (Discriminant_Type (New_Discr));
+
+ -- Ada 2005: if the discriminant definition carries a null
+ -- exclusion, create an itype to check properly for consistency
+ -- with partial declaration.
+
+ if Is_Access_Type (New_Discr_Type)
+ and then Null_Exclusion_Present (New_Discr)
+ then
+ New_Discr_Type :=
+ Create_Null_Excluding_Itype
+ (T => New_Discr_Type,
+ Related_Nod => New_Discr,
+ Scope_Id => Current_Scope);
+ end if;
+ end if;
+
+ if not Conforming_Types
+ (Etype (Old_Discr), New_Discr_Type, Fully_Conformant)
+ then
+ Conformance_Error ("type of & does not match!", New_Discr_Id);
+ return;
+ else
+ -- Treat the new discriminant as an occurrence of the old one,
+ -- for navigation purposes, and fill in some semantic
+ -- information, for completeness.
+
+ Generate_Reference (Old_Discr, New_Discr_Id, 'r');
+ Set_Etype (New_Discr_Id, Etype (Old_Discr));
+ Set_Scope (New_Discr_Id, Scope (Old_Discr));
+ end if;
+
+ -- Names must match
+
+ if Chars (Old_Discr) /= Chars (Defining_Identifier (New_Discr)) then
+ Conformance_Error ("name & does not match!", New_Discr_Id);
+ return;
+ end if;
+
+ -- Default expressions must match
+
+ declare
+ NewD : constant Boolean :=
+ Present (Expression (New_Discr));
+ OldD : constant Boolean :=
+ Present (Expression (Parent (Old_Discr)));
+
+ function Has_Tagged_Limited_Partial_View
+ (Typ : Entity_Id) return Boolean;
+ -- Returns True iff Typ has a tagged limited partial view.
+
+ function Is_Derived_From_Immutably_Limited_Type
+ (Typ : Entity_Id) return Boolean;
+ -- Returns True iff Typ is a derived type (tagged or not)
+ -- whose ancestor type is immutably limited. The unusual
+ -- ("unusual" is one word for it) thing about this function
+ -- is that it handles the case where the ancestor name's Entity
+ -- attribute has not been set yet.
+
+ -------------------------------------
+ -- Has_Tagged_Limited_Partial_View --
+ -------------------------------------
+
+ function Has_Tagged_Limited_Partial_View
+ (Typ : Entity_Id) return Boolean
+ is
+ Priv : constant Entity_Id := Incomplete_Or_Partial_View (Typ);
+ begin
+ return Present (Priv)
+ and then not Is_Incomplete_Type (Priv)
+ and then Is_Tagged_Type (Priv)
+ and then Limited_Present (Parent (Priv));
+ end Has_Tagged_Limited_Partial_View;
+
+ --------------------------------------------
+ -- Is_Derived_From_Immutably_Limited_Type --
+ --------------------------------------------
+
+ function Is_Derived_From_Immutably_Limited_Type
+ (Typ : Entity_Id) return Boolean
+ is
+ Type_Def : constant Node_Id := Type_Definition (Parent (Typ));
+ Parent_Name : Node_Id;
+ begin
+ if Nkind (Type_Def) /= N_Derived_Type_Definition then
+ return False;
+ end if;
+ Parent_Name := Subtype_Indication (Type_Def);
+ if Nkind (Parent_Name) = N_Subtype_Indication then
+ Parent_Name := Subtype_Mark (Parent_Name);
+ end if;
+ if Parent_Name not in N_Has_Entity_Id
+ or else No (Entity (Parent_Name))
+ then
+ Find_Type (Parent_Name);
+ end if;
+ return Is_Immutably_Limited_Type (Entity (Parent_Name));
+ end Is_Derived_From_Immutably_Limited_Type;
+
+ begin
+ if NewD or OldD then
+
+ -- The old default value has been analyzed and expanded,
+ -- because the current full declaration will have frozen
+ -- everything before. The new default values have not been
+ -- expanded, so expand now to check conformance.
+
+ if NewD then
+ Preanalyze_And_Resolve_Spec_Expression
+ (Expression (New_Discr), New_Discr_Type);
+ end if;
+
+ if not (NewD and OldD)
+ or else not Fully_Conformant_Expressions
+ (Expression (Parent (Old_Discr)),
+ Expression (New_Discr))
+
+ then
+ Conformance_Error
+ ("default expression for & does not match!",
+ New_Discr_Id);
+ return;
+ end if;
+
+ if NewD
+ and then Ada_Version >= Ada_2005
+ and then Nkind (Discriminant_Type (New_Discr)) =
+ N_Access_Definition
+ and then not Is_Immutably_Limited_Type
+ (Defining_Identifier (N))
+
+ -- Check for a case that would be awkward to handle in
+ -- Is_Immutably_Limited_Type (because sem_aux can't
+ -- "with" sem_util).
+
+ and then not Has_Tagged_Limited_Partial_View
+ (Defining_Identifier (N))
+
+ -- Check for another case that would be awkward to handle
+ -- in Is_Immutably_Limited_Type
+
+ and then not Is_Derived_From_Immutably_Limited_Type
+ (Defining_Identifier (N))
+ then
+ Error_Msg_N
+ ("(Ada 2005) default value for access discriminant "
+ & "requires immutably limited type",
+ Expression (New_Discr));
+ return;
+ end if;
+ end if;
+ end;
+
+ -- In Ada 83 case, grouping must match: (A,B : X) /= (A : X; B : X)
+
+ if Ada_Version = Ada_83 then
+ declare
+ Old_Disc : constant Node_Id := Declaration_Node (Old_Discr);
+
+ begin
+ -- Grouping (use of comma in param lists) must be the same
+ -- This is where we catch a misconformance like:
+
+ -- A, B : Integer
+ -- A : Integer; B : Integer
+
+ -- which are represented identically in the tree except
+ -- for the setting of the flags More_Ids and Prev_Ids.
+
+ if More_Ids (Old_Disc) /= More_Ids (New_Discr)
+ or else Prev_Ids (Old_Disc) /= Prev_Ids (New_Discr)
+ then
+ Conformance_Error
+ ("grouping of & does not match!", New_Discr_Id);
+ return;
+ end if;
+ end;
+ end if;
+
+ Next_Discriminant (Old_Discr);
+ Next (New_Discr);
+ end loop;
+
+ if Present (Old_Discr) then
+ Conformance_Error ("too few discriminants!", Defining_Identifier (N));
+ return;
+
+ elsif Present (New_Discr) then
+ Conformance_Error
+ ("too many discriminants!", Defining_Identifier (New_Discr));
+ return;
+ end if;
+ end Check_Discriminant_Conformance;
+
--------------------------
-- Check_Initialization --
--------------------------
@@ -13972,7 +14262,7 @@ package body Sem_Ch3 is
---------------------
procedure Constrain_Array
- (Def_Id : in out Entity_Id;
+ (Def_Id : Entity_Id;
SI : Node_Id;
Related_Nod : Node_Id;
Related_Id : Entity_Id;
@@ -14072,14 +14362,7 @@ package body Sem_Ch3 is
end if;
end if;
- if No (Def_Id) then
- Def_Id :=
- Create_Itype (E_Array_Subtype, Related_Nod, Related_Id, Suffix);
- Set_Parent (Def_Id, Related_Nod);
-
- else
- Mutate_Ekind (Def_Id, E_Array_Subtype);
- end if;
+ Mutate_Ekind (Def_Id, E_Array_Subtype);
Set_Size_Info (Def_Id, (T));
Set_First_Rep_Item (Def_Id, First_Rep_Item (T));
@@ -14599,6 +14882,7 @@ package body Sem_Ch3 is
Set_Etype (T_Sub, Corr_Rec);
Set_Has_Discriminants (T_Sub, Has_Discriminants (Prot_Subt));
Set_Is_Tagged_Type (T_Sub, Is_Tagged_Type (Corr_Rec));
+ Set_Class_Wide_Type (T_Sub, Class_Wide_Type (Corr_Rec));
Set_Is_Constrained (T_Sub, True);
Set_First_Entity (T_Sub, First_Entity (Corr_Rec));
Set_Last_Entity (T_Sub, Last_Entity (Corr_Rec));
@@ -14965,17 +15249,24 @@ package body Sem_Ch3 is
R : Node_Id := Empty;
T : constant Entity_Id := Etype (Index);
Is_FLB_Index : Boolean := False;
+ Is_Range : constant Boolean :=
+ Nkind (S) = N_Range
+ or else (Nkind (S) = N_Attribute_Reference
+ and then Attribute_Name (S) = Name_Range);
+ Is_Indic : constant Boolean := Nkind (S) = N_Subtype_Indication;
+ K : constant Entity_Kind :=
+ (if Is_Modular_Integer_Type (T) then E_Modular_Integer_Subtype
+ elsif Is_Integer_Type (T) then E_Signed_Integer_Subtype
+ else E_Enumeration_Subtype);
begin
- Def_Id :=
- Create_Itype (E_Void, Related_Nod, Related_Id, Suffix, Suffix_Index);
- Set_Etype (Def_Id, Base_Type (T));
+ if Is_Range or else Is_Indic then
+ Def_Id :=
+ Create_Itype (K, Related_Nod, Related_Id, Suffix, Suffix_Index);
+ Set_Etype (Def_Id, Base_Type (T));
+ end if;
- if Nkind (S) = N_Range
- or else
- (Nkind (S) = N_Attribute_Reference
- and then Attribute_Name (S) = Name_Range)
- then
+ if Is_Range then
-- A Range attribute will be transformed into N_Range by Resolve
-- If a range has an Empty upper bound, then remember that for later
@@ -15010,7 +15301,7 @@ package body Sem_Ch3 is
end if;
end if;
- elsif Nkind (S) = N_Subtype_Indication then
+ elsif Is_Indic then
-- The parser has verified that this is a discrete indication
@@ -15065,27 +15356,19 @@ package body Sem_Ch3 is
S, Entity (S));
end if;
- return;
-
else
Error_Msg_N ("invalid index constraint", S);
Rewrite (S, New_Occurrence_Of (T, Sloc (S)));
- return;
end if;
+
+ return;
end if;
-- Complete construction of the Itype
- if Is_Modular_Integer_Type (T) then
- Mutate_Ekind (Def_Id, E_Modular_Integer_Subtype);
-
- elsif Is_Integer_Type (T) then
- Mutate_Ekind (Def_Id, E_Signed_Integer_Subtype);
-
- else
- Mutate_Ekind (Def_Id, E_Enumeration_Subtype);
+ if K = E_Enumeration_Subtype then
Set_Is_Character_Type (Def_Id, Is_Character_Type (T));
- Set_First_Literal (Def_Id, First_Literal (T));
+ Set_First_Literal (Def_Id, First_Literal (T));
end if;
Set_Size_Info (Def_Id, (T));
@@ -15095,7 +15378,8 @@ package body Sem_Ch3 is
-- If this is a range for a fixed-lower-bound subtype, then set the
-- index itype's low bound to the FLB and the index itype's upper bound
-- to the high bound of the parent array type's index subtype. Also,
- -- mark the itype as an FLB index subtype.
+ -- set the Etype of the new scalar range and mark the itype as an FLB
+ -- index subtype.
if Nkind (S) = N_Range and then Is_FLB_Index then
Set_Scalar_Range
@@ -15103,6 +15387,7 @@ package body Sem_Ch3 is
Make_Range (Sloc (S),
Low_Bound => Low_Bound (S),
High_Bound => Type_High_Bound (T)));
+ Set_Etype (Scalar_Range (Def_Id), Etype (Index));
Set_Is_Fixed_Lower_Bound_Index_Subtype (Def_Id);
else
@@ -18835,10 +19120,15 @@ package body Sem_Ch3 is
or else Nkind (P) /= N_Object_Declaration
or else Is_Library_Level_Entity (Defining_Identifier (P)));
- -- Otherwise, the object definition is just a subtype_mark
+ -- Otherwise, either the object definition is just a subtype_mark or we
+ -- are analyzing a component declaration.
else
- T := Process_Subtype (Obj_Def, Related_Nod);
+ T :=
+ Process_Subtype
+ (Obj_Def,
+ Related_Nod,
+ Excludes_Null => Null_Exclusion_Present (Parent (Obj_Def)));
end if;
return T;
@@ -19846,7 +20136,9 @@ package body Sem_Ch3 is
-- Start of processing for Is_Visible_Component
begin
- if Ekind (C) in E_Component | E_Discriminant then
+ if Ekind (C) in E_Component | E_Discriminant
+ and then Is_Not_Self_Hidden (C)
+ then
Original_Comp := Original_Record_Component (C);
end if;
@@ -20341,17 +20633,17 @@ package body Sem_Ch3 is
if No (Def_Id) then
Def_Id :=
- Create_Itype (E_Void, Related_Nod, Related_Id, 'D', Suffix_Index);
+ Create_Itype
+ ((if Is_Signed_Integer_Type (T) then E_Signed_Integer_Subtype
+ elsif Is_Modular_Integer_Type (T) then E_Modular_Integer_Subtype
+ else E_Enumeration_Subtype),
+ Related_Nod,
+ Related_Id,
+ 'D',
+ Suffix_Index);
Set_Etype (Def_Id, Base_Type (T));
- if Is_Signed_Integer_Type (T) then
- Mutate_Ekind (Def_Id, E_Signed_Integer_Subtype);
-
- elsif Is_Modular_Integer_Type (T) then
- Mutate_Ekind (Def_Id, E_Modular_Integer_Subtype);
-
- else
- Mutate_Ekind (Def_Id, E_Enumeration_Subtype);
+ if Ekind (Def_Id) = E_Enumeration_Subtype then
Set_Is_Character_Type (Def_Id, Is_Character_Type (T));
Set_First_Literal (Def_Id, First_Literal (T));
end if;
@@ -20857,67 +21149,71 @@ package body Sem_Ch3 is
Set_Is_Constrained (T);
end Ordinary_Fixed_Point_Type_Declaration;
- ----------------------------------
- -- Preanalyze_Assert_Expression --
- ----------------------------------
+ ----------------------------------------------
+ -- Preanalyze_And_Resolve_Assert_Expression --
+ ----------------------------------------------
- procedure Preanalyze_Assert_Expression (N : Node_Id; T : Entity_Id) is
+ procedure Preanalyze_And_Resolve_Assert_Expression
+ (N : Node_Id;
+ T : Entity_Id) is
begin
In_Assertion_Expr := In_Assertion_Expr + 1;
- Preanalyze_Spec_Expression (N, T);
+ Preanalyze_And_Resolve_Spec_Expression (N, T);
In_Assertion_Expr := In_Assertion_Expr - 1;
- end Preanalyze_Assert_Expression;
-
- -- ??? The variant below explicitly saves and restores all the flags,
- -- because it is impossible to compose the existing variety of
- -- Analyze/Resolve (and their wrappers, e.g. Preanalyze_Spec_Expression)
- -- to achieve the desired semantics.
+ end Preanalyze_And_Resolve_Assert_Expression;
- procedure Preanalyze_Assert_Expression (N : Node_Id) is
- Save_In_Spec_Expression : constant Boolean := In_Spec_Expression;
- Save_Full_Analysis : constant Boolean := Full_Analysis;
+ ----------------------------------------------
+ -- Preanalyze_And_Resolve_Assert_Expression --
+ ----------------------------------------------
+ procedure Preanalyze_And_Resolve_Assert_Expression (N : Node_Id) is
begin
In_Assertion_Expr := In_Assertion_Expr + 1;
- In_Spec_Expression := True;
- Full_Analysis := False;
- Expander_Mode_Save_And_Set (False);
-
- if GNATprove_Mode then
- Analyze_And_Resolve (N);
- else
- Analyze_And_Resolve (N, Suppress => All_Checks);
- end if;
-
- Expander_Mode_Restore;
- Full_Analysis := Save_Full_Analysis;
- In_Spec_Expression := Save_In_Spec_Expression;
+ Preanalyze_And_Resolve_Spec_Expression (N);
In_Assertion_Expr := In_Assertion_Expr - 1;
- end Preanalyze_Assert_Expression;
+ end Preanalyze_And_Resolve_Assert_Expression;
- -----------------------------------
- -- Preanalyze_Default_Expression --
- -----------------------------------
+ -----------------------------------------------
+ -- Preanalyze_And_Resolve_Default_Expression --
+ -----------------------------------------------
- procedure Preanalyze_Default_Expression (N : Node_Id; T : Entity_Id) is
+ procedure Preanalyze_And_Resolve_Default_Expression
+ (N : Node_Id;
+ T : Entity_Id)
+ is
Save_In_Default_Expr : constant Boolean := In_Default_Expr;
begin
In_Default_Expr := True;
- Preanalyze_Spec_Expression (N, T);
+ Preanalyze_And_Resolve_Spec_Expression (N, T);
In_Default_Expr := Save_In_Default_Expr;
- end Preanalyze_Default_Expression;
+ end Preanalyze_And_Resolve_Default_Expression;
- --------------------------------
- -- Preanalyze_Spec_Expression --
- --------------------------------
+ --------------------------------------------
+ -- Preanalyze_And_Resolve_Spec_Expression --
+ --------------------------------------------
- procedure Preanalyze_Spec_Expression (N : Node_Id; T : Entity_Id) is
+ procedure Preanalyze_And_Resolve_Spec_Expression
+ (N : Node_Id;
+ T : Entity_Id)
+ is
Save_In_Spec_Expression : constant Boolean := In_Spec_Expression;
begin
In_Spec_Expression := True;
Preanalyze_And_Resolve (N, T);
In_Spec_Expression := Save_In_Spec_Expression;
- end Preanalyze_Spec_Expression;
+ end Preanalyze_And_Resolve_Spec_Expression;
+
+ --------------------------------------------
+ -- Preanalyze_And_Resolve_Spec_Expression --
+ --------------------------------------------
+
+ procedure Preanalyze_And_Resolve_Spec_Expression (N : Node_Id) is
+ Save_In_Spec_Expression : constant Boolean := In_Spec_Expression;
+ begin
+ In_Spec_Expression := True;
+ Preanalyze_And_Resolve (N);
+ In_Spec_Expression := Save_In_Spec_Expression;
+ end Preanalyze_And_Resolve_Spec_Expression;
----------------------------------------
-- Prepare_Private_Subtype_Completion --
@@ -20981,6 +21277,12 @@ package body Sem_Ch3 is
Discr := First (Discriminant_Specifications (N));
while Present (Discr) loop
+ if Ekind (Defining_Identifier (Discr)) = E_In_Parameter then
+ Reinit_Field_To_Zero
+ (Defining_Identifier (Discr), F_Discriminal_Link);
+ end if;
+
+ Mutate_Ekind (Defining_Identifier (Discr), E_Discriminant);
Enter_Name (Defining_Identifier (Discr));
-- For navigation purposes we add a reference to the discriminant
@@ -21076,7 +21378,8 @@ package body Sem_Ch3 is
-- Per-Object Expressions" in spec of package Sem).
if Present (Expression (Discr)) then
- Preanalyze_Default_Expression (Expression (Discr), Discr_Type);
+ Preanalyze_And_Resolve_Default_Expression
+ (Expression (Discr), Discr_Type);
-- Legaity checks
@@ -21255,11 +21558,6 @@ package body Sem_Ch3 is
while Present (Discr) loop
Id := Defining_Identifier (Discr);
- if Ekind (Id) = E_In_Parameter then
- Reinit_Field_To_Zero (Id, F_Discriminal_Link);
- end if;
-
- Mutate_Ekind (Id, E_Discriminant);
Set_Is_Not_Self_Hidden (Id);
Reinit_Component_Location (Id);
Reinit_Esize (Id);
@@ -22506,10 +22804,12 @@ package body Sem_Ch3 is
---------------------
function Process_Subtype
- (S : Node_Id;
- Related_Nod : Node_Id;
- Related_Id : Entity_Id := Empty;
- Suffix : Character := ' ') return Entity_Id
+ (S : Node_Id;
+ Related_Nod : Node_Id;
+ Related_Id : Entity_Id := Empty;
+ Suffix : Character := ' ';
+ Excludes_Null : Boolean := False;
+ Incomplete_Type_OK : Boolean := False) return Entity_Id
is
procedure Check_Incomplete (T : Node_Id);
-- Called to verify that an incomplete type is not used prematurely
@@ -22523,13 +22823,7 @@ package body Sem_Ch3 is
-- Ada 2005 (AI-412): Incomplete subtypes are legal
if Ekind (Root_Type (Entity (T))) = E_Incomplete_Type
- and then
- not (Ada_Version >= Ada_2005
- and then
- (Nkind (Parent (T)) = N_Subtype_Declaration
- or else (Nkind (Parent (T)) = N_Subtype_Indication
- and then Nkind (Parent (Parent (T))) =
- N_Subtype_Declaration)))
+ and then not Incomplete_Type_OK
then
Error_Msg_N ("invalid use of type before its full declaration", T);
end if;
@@ -22537,126 +22831,91 @@ package body Sem_Ch3 is
-- Local variables
- P : Node_Id;
+ P : constant Node_Id := Parent (S);
+ Mark : Node_Id;
Def_Id : Entity_Id;
Error_Node : Node_Id;
Full_View_Id : Entity_Id;
Subtype_Mark_Id : Entity_Id;
- May_Have_Null_Exclusion : Boolean;
-
-- Start of processing for Process_Subtype
begin
- -- Case of no constraints present
-
- if Nkind (S) /= N_Subtype_Indication then
- Find_Type (S);
-
- -- No way to proceed if the subtype indication is malformed. This
- -- will happen for example when the subtype indication in an object
- -- declaration is missing altogether and the expression is analyzed
- -- as if it were that indication.
-
- if not Is_Entity_Name (S) then
- return Any_Type;
- end if;
+ if Nkind (S) = N_Subtype_Indication then
+ Mark := Subtype_Mark (S);
+ else
+ Mark := S;
+ end if;
- Check_Incomplete (S);
- P := Parent (S);
+ Find_Type (Mark);
- -- The following mirroring of assertion in Null_Exclusion_Present is
- -- ugly, can't we have a range, a static predicate or even a flag???
+ -- No way to proceed if the subtype indication is malformed. This will
+ -- happen for example when the subtype indication in an object
+ -- declaration is missing altogether and the expression is analyzed as
+ -- if it were that indication.
- May_Have_Null_Exclusion :=
- Present (P)
- and then
- Nkind (P) in N_Access_Definition
- | N_Access_Function_Definition
- | N_Access_Procedure_Definition
- | N_Access_To_Object_Definition
- | N_Allocator
- | N_Component_Definition
- | N_Derived_Type_Definition
- | N_Discriminant_Specification
- | N_Formal_Object_Declaration
- | N_Function_Specification
- | N_Object_Declaration
- | N_Object_Renaming_Declaration
- | N_Parameter_Specification
- | N_Subtype_Declaration;
-
- -- Ada 2005 (AI-231): Static check
+ if not Is_Entity_Name (Mark) then
+ return Any_Type;
+ end if;
- if Ada_Version >= Ada_2005
- and then May_Have_Null_Exclusion
- and then Null_Exclusion_Present (P)
- and then Nkind (P) /= N_Access_To_Object_Definition
- and then not Is_Access_Type (Entity (S))
- then
- Error_Msg_N ("`NOT NULL` only allowed for an access type", S);
- end if;
+ Check_Incomplete (Mark);
- -- Create an Itype that is a duplicate of Entity (S) but with the
- -- null-exclusion attribute.
+ -- Case of no constraints present
- if May_Have_Null_Exclusion
- and then Is_Access_Type (Entity (S))
- and then Null_Exclusion_Present (P)
+ if Nkind (S) /= N_Subtype_Indication then
+ if Excludes_Null then
+ -- Create an Itype that is a duplicate of Entity (S) but with the
+ -- null-exclusion attribute.
+ if Is_Access_Type (Entity (S)) then
+ if Can_Never_Be_Null (Entity (S)) then
+ case Nkind (Related_Nod) is
+ when N_Full_Type_Declaration =>
+ if Nkind (Type_Definition (Related_Nod))
+ in N_Array_Type_Definition
+ then
+ Error_Node :=
+ Subtype_Indication
+ (Component_Definition
+ (Type_Definition (Related_Nod)));
+ else
+ Error_Node :=
+ Subtype_Indication
+ (Type_Definition (Related_Nod));
+ end if;
- -- No need to check the case of an access to object definition.
- -- It is correct to define double not-null pointers.
+ when N_Subtype_Declaration =>
+ Error_Node := Subtype_Indication (Related_Nod);
- -- Example:
- -- type Not_Null_Int_Ptr is not null access Integer;
- -- type Acc is not null access Not_Null_Int_Ptr;
+ when N_Object_Declaration =>
+ Error_Node := Object_Definition (Related_Nod);
- and then Nkind (P) /= N_Access_To_Object_Definition
- then
- if Can_Never_Be_Null (Entity (S)) then
- case Nkind (Related_Nod) is
- when N_Full_Type_Declaration =>
- if Nkind (Type_Definition (Related_Nod))
- in N_Array_Type_Definition
- then
+ when N_Component_Declaration =>
Error_Node :=
Subtype_Indication
- (Component_Definition
- (Type_Definition (Related_Nod)));
- else
- Error_Node :=
- Subtype_Indication (Type_Definition (Related_Nod));
- end if;
+ (Component_Definition (Related_Nod));
- when N_Subtype_Declaration =>
- Error_Node := Subtype_Indication (Related_Nod);
+ when N_Allocator =>
+ Error_Node := Expression (Related_Nod);
- when N_Object_Declaration =>
- Error_Node := Object_Definition (Related_Nod);
+ when others =>
+ pragma Assert (False);
+ Error_Node := Related_Nod;
+ end case;
- when N_Component_Declaration =>
- Error_Node :=
- Subtype_Indication (Component_Definition (Related_Nod));
-
- when N_Allocator =>
- Error_Node := Expression (Related_Nod);
-
- when others =>
- pragma Assert (False);
- Error_Node := Related_Nod;
- end case;
+ Error_Msg_NE
+ ("`NOT NULL` not allowed (& already excludes null)",
+ Error_Node,
+ Entity (S));
+ end if;
- Error_Msg_NE
- ("`NOT NULL` not allowed (& already excludes null)",
- Error_Node,
- Entity (S));
+ Set_Etype
+ (S,
+ Create_Null_Excluding_Itype
+ (T => Entity (S), Related_Nod => P));
+ Set_Entity (S, Etype (S));
+ elsif Ada_Version >= Ada_2005 then
+ Error_Msg_N ("`NOT NULL` only allowed for an access type", S);
end if;
-
- Set_Etype (S,
- Create_Null_Excluding_Itype
- (T => Entity (S),
- Related_Nod => P));
- Set_Entity (S, Etype (S));
end if;
return Entity (S);
@@ -22665,18 +22924,7 @@ package body Sem_Ch3 is
-- node (this node is created only if constraints are present).
else
- Find_Type (Subtype_Mark (S));
-
- if Nkind (Parent (S)) /= N_Access_To_Object_Definition
- and then not
- (Nkind (Parent (S)) = N_Subtype_Declaration
- and then Is_Itype (Defining_Identifier (Parent (S))))
- then
- Check_Incomplete (Subtype_Mark (S));
- end if;
-
- P := Parent (S);
- Subtype_Mark_Id := Entity (Subtype_Mark (S));
+ Subtype_Mark_Id := Entity (Mark);
-- Explicit subtype declaration case
@@ -22696,8 +22944,7 @@ package body Sem_Ch3 is
-- has not yet been called to create Def_Id.
else
- if Is_Array_Type (Subtype_Mark_Id)
- or else Is_Concurrent_Type (Subtype_Mark_Id)
+ if Is_Concurrent_Type (Subtype_Mark_Id)
or else Is_Access_Type (Subtype_Mark_Id)
then
Def_Id := Empty;
@@ -22730,7 +22977,14 @@ package body Sem_Ch3 is
-- Make recursive call, having got rid of the bogus constraint
- return Process_Subtype (S, Related_Nod, Related_Id, Suffix);
+ return
+ Process_Subtype
+ (S,
+ Related_Nod,
+ Related_Id,
+ Suffix,
+ Excludes_Null,
+ Incomplete_Type_OK);
end if;
-- Remaining processing depends on type. Select on Base_Type kind to
@@ -22750,6 +23004,8 @@ package body Sem_Ch3 is
Error_Msg_N
("constraint on class-wide type ignored??",
Constraint (S));
+ else
+ pragma Assert (False);
end if;
if Nkind (P) = N_Subtype_Declaration then
@@ -22878,8 +23134,8 @@ package body Sem_Ch3 is
-- Size, Alignment, Representation aspects and Convention are always
-- inherited from the base type.
- Set_Size_Info (Def_Id, (Subtype_Mark_Id));
- Set_Rep_Info (Def_Id, (Subtype_Mark_Id));
+ Set_Size_Info (Def_Id, Subtype_Mark_Id);
+ Set_Rep_Info (Def_Id, Subtype_Mark_Id);
Set_Convention (Def_Id, Convention (Subtype_Mark_Id));
-- The anonymous subtype created for the subtype indication
@@ -23131,16 +23387,22 @@ package body Sem_Ch3 is
Component := First_Entity (Current_Scope);
while Present (Component) loop
- if Ekind (Component) = E_Void
- and then not Is_Itype (Component)
+ if Ekind (Component) = E_Component and then not Is_Itype (Component)
then
- Mutate_Ekind (Component, E_Component);
Reinit_Component_Location (Component);
Set_Is_Not_Self_Hidden (Component);
end if;
Propagate_Concurrent_Flags (T, Etype (Component));
+ -- Propagate information about constructor dependence
+
+ if Ekind (Etype (Component)) /= E_Void
+ and then Needs_Construction (Etype (Component))
+ then
+ Set_Needs_Construction (T);
+ end if;
+
if Ekind (Component) /= E_Component then
null;
diff --git a/gcc/ada/sem_ch3.ads b/gcc/ada/sem_ch3.ads
index 3d9aa0a..a97393d 100644
--- a/gcc/ada/sem_ch3.ads
+++ b/gcc/ada/sem_ch3.ads
@@ -236,19 +236,23 @@ package Sem_Ch3 is
-- Always False in Ada 95 mode. Equivalent to OK_For_Limited_Init_In_05 in
-- Ada 2005 mode.
- procedure Preanalyze_Assert_Expression (N : Node_Id; T : Entity_Id);
- -- Wrapper on Preanalyze_Spec_Expression for assertion expressions, so that
- -- In_Assertion_Expr can be properly adjusted.
+ procedure Preanalyze_And_Resolve_Assert_Expression
+ (N : Node_Id;
+ T : Entity_Id);
+ -- Wrapper on Preanalyze_And_Resolve_Spec_Expression for assertion
+ -- expressions, so that In_Assertion_Expr can be properly adjusted.
--
-- This routine must not be called when N is the root of a subtree that is
-- not in its final place since it freezes static expression entities,
-- which would be misplaced in the tree. Preanalyze_And_Resolve must be
-- used in such a case to avoid reporting spurious errors.
- procedure Preanalyze_Assert_Expression (N : Node_Id);
+ procedure Preanalyze_And_Resolve_Assert_Expression (N : Node_Id);
-- Similar to the above, but without forcing N to be of a particular type
- procedure Preanalyze_Spec_Expression (N : Node_Id; T : Entity_Id);
+ procedure Preanalyze_And_Resolve_Spec_Expression
+ (N : Node_Id;
+ T : Entity_Id);
-- Default and per object expressions do not freeze their components, and
-- must be analyzed and resolved accordingly. The analysis is done by
-- calling the Preanalyze_And_Resolve routine and setting the global
@@ -263,6 +267,9 @@ package Sem_Ch3 is
-- which would be misplaced in the tree. Preanalyze_And_Resolve must be
-- used in such a case to avoid reporting spurious errors.
+ procedure Preanalyze_And_Resolve_Spec_Expression (N : Node_Id);
+ -- Similar to the above, but without forcing N to be of a particular type
+
procedure Process_Full_View (N : Node_Id; Full_T, Priv_T : Entity_Id);
-- Process some semantic actions when the full view of a private type is
-- encountered and analyzed. The first action is to create the full views
@@ -294,10 +301,12 @@ package Sem_Ch3 is
-- in this case the bounds are captured if necessary using this name.
function Process_Subtype
- (S : Node_Id;
- Related_Nod : Node_Id;
- Related_Id : Entity_Id := Empty;
- Suffix : Character := ' ') return Entity_Id;
+ (S : Node_Id;
+ Related_Nod : Node_Id;
+ Related_Id : Entity_Id := Empty;
+ Suffix : Character := ' ';
+ Excludes_Null : Boolean := False;
+ Incomplete_Type_OK : Boolean := False) return Entity_Id;
-- Process a subtype indication S and return corresponding entity.
-- Related_Nod is the node where the potential generated implicit types
-- will be inserted. The Related_Id and Suffix parameters are used to
diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb
index 4069839..dc81467 100644
--- a/gcc/ada/sem_ch4.adb
+++ b/gcc/ada/sem_ch4.adb
@@ -27,11 +27,11 @@ with Accessibility; use Accessibility;
with Aspects; use Aspects;
with Atree; use Atree;
with Debug; use Debug;
-with Diagnostics.Constructors; use Diagnostics.Constructors;
with Einfo; use Einfo;
with Einfo.Entities; use Einfo.Entities;
with Einfo.Utils; use Einfo.Utils;
with Elists; use Elists;
+with Errid; use Errid;
with Errout; use Errout;
with Exp_Util; use Exp_Util;
with Itypes; use Itypes;
@@ -308,8 +308,12 @@ package body Sem_Ch4 is
(N : Node_Id;
Prefix : Node_Id;
Exprs : List_Id) return Boolean;
- -- AI05-0139: Generalized indexing to support iterators over containers
- -- ??? Need to provide a more detailed spec of what this function does
+ -- AI05-0139: Generalized indexing to support iterators over containers.
+ -- Given the N_Indexed_Component node N, with the given prefix and
+ -- expressions list, check if the generalized indexing is applicable;
+ -- if applicable then build its indexing function, link it to N through
+ -- attribute Generalized_Indexing, and return True; otherwise return
+ -- False.
function Try_Indexed_Call
(N : Node_Id;
@@ -590,8 +594,6 @@ package body Sem_Ch4 is
-- part of the allocator. It is fully analyzed and resolved when
-- the allocator is resolved with the context type.
- Set_Etype (E, Type_Id);
-
-- Case where allocator has a subtype indication
else
@@ -724,7 +726,8 @@ package body Sem_Ch4 is
end;
end if;
- Type_Id := Process_Subtype (E, N);
+ Type_Id :=
+ Process_Subtype (E, N, Excludes_Null => Null_Exclusion_Present (N));
Acc_Type := Create_Itype (E_Allocator_Type, N);
Set_Etype (Acc_Type, Acc_Type);
Set_Directly_Designated_Type (Acc_Type, Type_Id);
@@ -831,6 +834,14 @@ package body Sem_Ch4 is
Error_Msg_N ("cannot allocate abstract object", E);
end if;
+ -- If the type of a constrained array has an unconstrained first
+ -- subtype, its Finalize_Address primitive expects the address of
+ -- an object with a dope vector (see Make_Finalize_Address_Stmts).
+
+ if Is_Constr_Array_Subt_Of_Unc_With_Controlled (Type_Id) then
+ Set_Is_Constr_Array_Subt_With_Bounds (Type_Id);
+ end if;
+
Set_Etype (N, Acc_Type);
-- If this is an allocator for the return stack, then no restriction may
@@ -6040,9 +6051,10 @@ package body Sem_Ch4 is
Error_Msg_NE ("invalid prefix in selected component&", N, Sel);
end if;
- -- If N still has no type, the component is not defined in the prefix
+ -- If the selector is not labelled with an entity at this point, the
+ -- component is not defined in the prefix.
- if Etype (N) = Any_Type then
+ if No (Entity (Sel)) then
if Is_Single_Concurrent_Object then
Error_Msg_Node_2 := Entity (Pref);
@@ -7642,35 +7654,14 @@ package body Sem_Ch4 is
begin
if not Is_Overloaded (R) then
if Is_Numeric_Type (Etype (R)) then
-
- -- In an instance a generic actual may be a numeric type even if
- -- the formal in the generic unit was not. In that case, the
- -- predefined operator was not a possible interpretation in the
- -- generic, and cannot be one in the instance, unless the operator
- -- is an actual of an instance.
-
- if In_Instance
- and then
- not Is_Numeric_Type (Corresponding_Generic_Type (Etype (R)))
- then
- null;
- else
- Add_One_Interp (N, Op_Id, Base_Type (Etype (R)));
- end if;
+ Add_One_Interp (N, Op_Id, Base_Type (Etype (R)));
end if;
else
Get_First_Interp (R, Index, It);
while Present (It.Typ) loop
if Is_Numeric_Type (It.Typ) then
- if In_Instance
- and then
- not Is_Numeric_Type
- (Corresponding_Generic_Type (Etype (It.Typ)))
- then
- null;
-
- elsif Is_Effectively_Visible_Operator (N, Base_Type (It.Typ))
+ if Is_Effectively_Visible_Operator (N, Base_Type (It.Typ))
then
Add_One_Interp (N, Op_Id, Base_Type (It.Typ));
end if;
@@ -8533,21 +8524,29 @@ package body Sem_Ch4 is
Prefix : Node_Id;
Exprs : List_Id) return Boolean
is
- Pref_Typ : Entity_Id := Etype (Prefix);
+ Heuristic : Boolean := False;
+ Pref_Typ : Entity_Id := Etype (Prefix);
function Constant_Indexing_OK return Boolean;
- -- Constant_Indexing is legal if there is no Variable_Indexing defined
- -- for the type, or else node not a target of assignment, or an actual
- -- for an IN OUT or OUT formal (RM 4.1.6 (11)).
-
- function Expr_Matches_In_Formal
- (Subp : Entity_Id;
- Par : Node_Id) return Boolean;
- -- Find formal corresponding to given indexed component that is an
- -- actual in a call. Note that the enclosing subprogram call has not
- -- been analyzed yet, and the parameter list is not normalized, so
- -- that if the argument is a parameter association we must match it
- -- by name and not by position.
+ -- Determines whether the Constant_Indexing aspect has been specified
+ -- for the type of the prefix and can be interpreted as constant
+ -- indexing; that is, there is no Variable_Indexing defined for the
+ -- type, or else the node is not a target of an assignment, or an
+ -- actual for an IN OUT or OUT formal, or the name in an object
+ -- renaming (RM 4.1.6 (12/3..15/3)).
+ --
+ -- Given that prefix notation calls have not yet been resolved, if the
+ -- type of the prefix has both aspects present (Constant_Indexing and
+ -- Variable_Indexing), and context analysis performed by this routine
+ -- identifies a potential prefix notation call (i.e., an N_Selected_
+ -- Component node), this function may rely on heuristics to decide
+ -- between constant or variable indexing. In such cases, if the
+ -- decision is later found to be incorrect, Try_Container_Indexing
+ -- will retry using the alternative indexing aspect.
+
+ -- When heuristics are used to compute the result of this function
+ -- the behavior of Try_Container_Indexing might not be strictly
+ -- following the rules of the RM.
function Indexing_Interpretations
(T : Entity_Id;
@@ -8555,59 +8554,429 @@ package body Sem_Ch4 is
-- Return a set of interpretations reflecting all of the functions
-- associated with an indexing aspect of type T of the given kind.
+ function Try_Indexing_Function
+ (Func_Name : Node_Id;
+ Assoc : List_Id) return Entity_Id;
+ -- Build a call to the given indexing function name with the given
+ -- parameter associations; if there are several indexing functions
+ -- the call is analyzed for each of the interpretation; if there are
+ -- several successfull candidates, resolution is handled by result.
+ -- Return the Etype of the built function call.
+
--------------------------
-- Constant_Indexing_OK --
--------------------------
function Constant_Indexing_OK return Boolean is
- Par : Node_Id;
+
+ function Expr_Matches_In_Formal
+ (Subp : Entity_Id;
+ Subp_Call : Node_Id;
+ Param : Node_Id;
+ Skip_Controlling_Formal : Boolean := False) return Boolean;
+ -- Find formal corresponding to given indexed component that is an
+ -- actual in a call. Note that the enclosing subprogram call has not
+ -- been analyzed yet, and the parameter list is not normalized, so
+ -- that if the argument is a parameter association we must match it
+ -- by name and not by position. In the traversal up the tree done by
+ -- Constant_Indexing_OK, the previous node in the traversal (that is,
+ -- the actual parameter used to ascend to the subprogram call node),
+ -- is passed to this function in formal Param, and it is used to
+ -- determine wether the argument is passed by name or by position.
+ -- Skip_Controlling_Formal is set to True to skip the first formal
+ -- of Subp.
+
+ procedure Handle_Selected_Component
+ (Current_Node : Node_Id;
+ Sel_Comp : Node_Id;
+ Candidate : out Entity_Id;
+ Is_Constant_Idx : out Boolean);
+ -- Current_Node is the current node climbing up the tree. Determine
+ -- if Sel_Comp is a candidate for a prefixed call using constant
+ -- indexing; if no candidate is found Candidate is returned Empty
+ -- and Is_Constant_Idx is returned False.
+
+ function Has_IN_Mode (Formal : Node_Id) return Boolean is
+ (Ekind (Formal) = E_In_Parameter);
+ -- Return True if the given formal has mode IN
+
+ ----------------------------
+ -- Expr_Matches_In_Formal --
+ ----------------------------
+
+ function Expr_Matches_In_Formal
+ (Subp : Entity_Id;
+ Subp_Call : Node_Id;
+ Param : Node_Id;
+ Skip_Controlling_Formal : Boolean := False) return Boolean
+ is
+ pragma Assert (Nkind (Subp_Call) in N_Subprogram_Call);
+
+ Actual : Node_Id := First (Parameter_Associations (Subp_Call));
+ Formal : Node_Id := First_Formal (Subp);
+
+ begin
+ if Skip_Controlling_Formal then
+ Next_Formal (Formal);
+ end if;
+
+ -- Match by position
+
+ if Nkind (Param) /= N_Parameter_Association then
+ while Present (Actual) and then Present (Formal) loop
+ exit when Actual = Param;
+ Next (Actual);
+
+ if Present (Formal) then
+ Next_Formal (Formal);
+
+ -- Otherwise this is a parameter mismatch, the error is
+ -- reported elsewhere, or else variable indexing is implied.
+
+ else
+ return False;
+ end if;
+ end loop;
+
+ -- Match by name
+
+ else
+ while Present (Formal) loop
+ exit when Chars (Formal) = Chars (Selector_Name (Param));
+ Next_Formal (Formal);
+
+ if No (Formal) then
+ return False;
+ end if;
+ end loop;
+ end if;
+
+ return Present (Formal) and then Has_IN_Mode (Formal);
+ end Expr_Matches_In_Formal;
+
+ -------------------------------
+ -- Handle_Selected_Component --
+ -------------------------------
+
+ procedure Handle_Selected_Component
+ (Current_Node : Node_Id;
+ Sel_Comp : Node_Id;
+ Candidate : out Entity_Id;
+ Is_Constant_Idx : out Boolean)
+ is
+ procedure Search_Constant_Interpretation
+ (Call : Node_Id;
+ Target_Name : Node_Id;
+ Candidate : out Entity_Id;
+ Is_Unique : out Boolean;
+ Unique_Mode : out Boolean);
+ -- Given a subprogram call, search in the homonyms chain for
+ -- visible (or potentially visible) dispatching primitives that
+ -- have at least one formal. Candidate is the entity of the first
+ -- found candidate; Is_Unique is returned True when the mode of
+ -- the first formal of all the candidates match. If no candidate
+ -- is found the out parameter Candidate is returned Empty, and
+ -- Is_Unique is returned False.
+
+ procedure Search_Enclosing_Call
+ (Call_Node : out Node_Id;
+ Prev_Node : out Node_Id);
+ -- Climb up to the tree looking for an enclosing subprogram call
+ -- of a prefixed notation call. If found then the Call_Node and
+ -- its Prev_Node in such traversal are returned; otherwise
+ -- Call_Node and Prev_Node are returned Empty.
+
+ ------------------------------------
+ -- Search_Constant_Interpretation --
+ ------------------------------------
+
+ procedure Search_Constant_Interpretation
+ (Call : Node_Id;
+ Target_Name : Node_Id;
+ Candidate : out Entity_Id;
+ Is_Unique : out Boolean;
+ Unique_Mode : out Boolean)
+ is
+ Constant_Idx : Boolean;
+ In_Proc_Call : constant Boolean :=
+ Present (Call)
+ and then
+ Nkind (Call) = N_Procedure_Call_Statement;
+ Kind : constant Entity_Kind :=
+ (if In_Proc_Call then E_Procedure
+ else E_Function);
+ Target_Subp : constant Entity_Id :=
+ Current_Entity (Target_Name);
+ begin
+ Candidate := Empty;
+ Is_Unique := False;
+ Unique_Mode := False;
+
+ if Present (Target_Subp) then
+ declare
+ Hom : Entity_Id := Target_Subp;
+
+ begin
+ while Present (Hom) loop
+ if Is_Overloadable (Hom)
+ and then Is_Dispatching_Operation (Hom)
+ and then
+ (Is_Immediately_Visible (Scope (Hom))
+ or else
+ Is_Potentially_Use_Visible (Scope (Hom)))
+ and then Ekind (Hom) = Kind
+ and then Present (First_Formal (Hom))
+ then
+ if No (Candidate) then
+ Candidate := Hom;
+ Is_Unique := True;
+ Unique_Mode := True;
+ Constant_Idx :=
+ Has_IN_Mode (First_Formal (Candidate));
+
+ else
+ Is_Unique := False;
+
+ if Ekind (First_Formal (Hom))
+ /= Ekind (First_Formal (Candidate))
+ or else Has_IN_Mode (First_Formal (Hom))
+ /= Constant_Idx
+ then
+ Unique_Mode := False;
+ exit;
+ end if;
+ end if;
+ end if;
+
+ Hom := Homonym (Hom);
+ end loop;
+ end;
+ end if;
+ end Search_Constant_Interpretation;
+
+ ---------------------------
+ -- Search_Enclosing_Call --
+ ---------------------------
+
+ procedure Search_Enclosing_Call
+ (Call_Node : out Node_Id;
+ Prev_Node : out Node_Id)
+ is
+ Prev : Node_Id := Current_Node;
+ Par : Node_Id := Parent (N);
+
+ begin
+ while Present (Par)
+ and then Nkind (Par) not in N_Subprogram_Call
+ | N_Handled_Sequence_Of_Statements
+ | N_Assignment_Statement
+ | N_Iterator_Specification
+ | N_Object_Declaration
+ | N_Case_Statement
+ | N_Declaration
+ | N_Elsif_Part
+ | N_If_Statement
+ | N_Simple_Return_Statement
+ loop
+ Prev := Par;
+ Par := Parent (Par);
+ end loop;
+
+ if Present (Par)
+ and then Nkind (Par) in N_Subprogram_Call
+ and then Nkind (Name (Par)) = N_Selected_Component
+ then
+ Call_Node := Par;
+ Prev_Node := Prev;
+ else
+ Call_Node := Empty;
+ Prev_Node := Empty;
+ end if;
+ end Search_Enclosing_Call;
+
+ -- Local variables
+
+ Is_Unique : Boolean;
+ Unique_Mode : Boolean;
+ Call_Node : Node_Id;
+ Prev_Node : Node_Id;
+
+ -- Start of processing for Handle_Selected_Component
+
+ begin
+ pragma Assert (Nkind (Sel_Comp) = N_Selected_Component);
+
+ -- Climb up the tree starting from Current_Node searching for the
+ -- enclosing subprogram call of a prefixed notation call.
+
+ Search_Enclosing_Call (Call_Node, Prev_Node);
+
+ -- Search for a candidate visible (or potentially visible)
+ -- dispatching primitive that has at least one formal, and may
+ -- be called using the prefix notation. This must be done even
+ -- if we did not found an enclosing call since the prefix notation
+ -- call has not been transformed yet into a subprogram call. The
+ -- found Call_Node (if any) is passed now to help identifying if
+ -- the prefix notation call corresponds with a procedure call or
+ -- a function call.
+
+ Search_Constant_Interpretation
+ (Call => Call_Node,
+ Target_Name => Selector_Name (Sel_Comp),
+ Candidate => Candidate,
+ Is_Unique => Is_Unique,
+ Unique_Mode => Unique_Mode);
+
+ -- If there is no candidate to interpret this node as a prefixed
+ -- call to a subprogram we return no candidate, and the caller
+ -- will continue ascending in the tree.
+
+ if No (Candidate) then
+ Is_Constant_Idx := False;
+
+ -- If we found an unique candidate and also found the enclosing
+ -- call node, we differentiate two cases: either we climbed up
+ -- the tree through the first actual parameter of the call (that
+ -- is, the name of the selected component), or we climbed up the
+ -- tree though another actual parameter of the prefixed call and
+ -- we must skip the controlling formal of the call.
+
+ elsif Is_Unique
+ and then Present (Call_Node)
+ then
+ -- First actual parameter
+
+ if Name (Call_Node) = Prev_Node
+ and then Nkind (Prev_Node) = N_Selected_Component
+ and then Nkind (Selector_Name (Prev_Node)) in N_Has_Chars
+ and then Chars (Selector_Name (Prev_Node)) = Chars (Candidate)
+ then
+ Is_Constant_Idx := Has_IN_Mode (First_Formal (Candidate));
+
+ -- Any other actual parameter
+
+ else
+ Is_Constant_Idx :=
+ Expr_Matches_In_Formal (Candidate,
+ Subp_Call => Call_Node,
+ Param => Prev_Node,
+ Skip_Controlling_Formal => True);
+ end if;
+
+ -- The mode of the first formal of all the candidates match but,
+ -- given that we have several candidates, we cannot check if
+ -- indexing is used in the first actual parameter of the call
+ -- or in another actual parameter. Heuristically assume here
+ -- that indexing is used in the prefix of a call.
+
+ elsif Unique_Mode then
+ Heuristic := True;
+ Is_Constant_Idx := Has_IN_Mode (First_Formal (Candidate));
+
+ -- The target candidate subprogram has several possible
+ -- interpretations; we don't know what to do with an
+ -- N_Selected_Component node for a prefixed notation call
+ -- to AA.BB that has several candidate targets and it has
+ -- not yet been resolved. For now we maintain the
+ -- behavior that we have had so far; to be improved???
+
+ else
+ Heuristic := True;
+
+ if Nkind (Call_Node) = N_Procedure_Call_Statement then
+ Is_Constant_Idx := False;
+
+ -- For function calls we rely on the mode of the
+ -- first formal of the first found candidate???
+
+ else
+ Is_Constant_Idx := Has_IN_Mode (First_Formal (Candidate));
+ end if;
+ end if;
+ end Handle_Selected_Component;
+
+ -- Local variables
+
+ Asp_Constant : constant Node_Id :=
+ Find_Value_Of_Aspect (Pref_Typ,
+ Aspect_Constant_Indexing);
+ Asp_Variable : constant Node_Id :=
+ Find_Value_Of_Aspect (Pref_Typ,
+ Aspect_Variable_Indexing);
+ Par : Node_Id;
+
+ -- Start of processing for Constant_Indexing_OK
begin
- if No (Find_Value_Of_Aspect (Pref_Typ, Aspect_Variable_Indexing)) then
+ if No (Asp_Constant) then
+ return False;
+
+ -- It is interpreted as constant indexing when the prefix has the
+ -- Constant_Indexing aspect and the Variable_Indexing aspect is not
+ -- specified for the type of the prefix.
+
+ elsif No (Asp_Variable) then
return True;
+ -- It is interpreted as constant indexing when the prefix denotes
+ -- a constant.
+
elsif not Is_Variable (Prefix) then
return True;
end if;
+ -- Both aspects are present
+
+ pragma Assert (Present (Asp_Constant) and Present (Asp_Variable));
+
+ -- The prefix must be interpreted as a constant indexing when it
+ -- is used within a primary where a name denoting a constant is
+ -- permitted.
+
Par := N;
while Present (Par) loop
- if Nkind (Parent (Par)) = N_Assignment_Statement
- and then Par = Name (Parent (Par))
+
+ -- Avoid climbing more than needed
+
+ exit when Nkind (Parent (Par)) in N_Iterator_Specification
+ | N_Handled_Sequence_Of_Statements;
+
+ if Nkind (Parent (Par)) in N_Case_Statement
+ | N_Declaration
+ | N_Elsif_Part
+ | N_If_Statement
+ | N_Simple_Return_Statement
then
- return False;
+ return True;
+
+ -- It is not interpreted as constant indexing for the variable
+ -- name in the LHS of an assignment.
+
+ elsif Nkind (Parent (Par)) = N_Assignment_Statement then
+ return Par /= Name (Parent (Par));
-- The call may be overloaded, in which case we assume that its
-- resolution does not depend on the type of the parameter that
- -- includes the indexing operation.
+ -- includes the indexing operation because we cannot invoke
+ -- Preanalyze_And_Resolve (since it would cause a never-ending
+ -- loop).
elsif Nkind (Parent (Par)) in N_Subprogram_Call then
- if not Is_Entity_Name (Name (Parent (Par))) then
+ -- Regular subprogram call
- -- ??? We don't know what to do with an N_Selected_Component
- -- node for a prefixed-notation call to AA.BB where AA's
- -- type is known, but BB has not yet been resolved. In that
- -- case, the preceding Is_Entity_Name call returns False.
- -- Incorrectly returning False here will usually work
- -- better than incorrectly returning True, so that's what
- -- we do for now.
+ -- It is not interpreted as constant indexing for the name
+ -- used for an OUT or IN OUT parameter.
- return False;
- end if;
-
- declare
- Proc : Entity_Id;
-
- begin
- -- We should look for an interpretation with the proper
- -- number of formals, and determine whether it is an
- -- In_Parameter, but for now we examine the formal that
- -- corresponds to the indexing, and assume that variable
- -- indexing is required if some interpretation has an
- -- assignable formal at that position. Still does not
- -- cover the most complex cases ???
+ -- We should look for an interpretation with the proper
+ -- number of formals, and determine whether it is an
+ -- In_Parameter, but for now we examine the formal that
+ -- corresponds to the indexing, and assume that variable
+ -- indexing is required if some interpretation has an
+ -- assignable formal at that position. Still does not
+ -- cover the most complex cases ???
+ if Is_Entity_Name (Name (Parent (Par))) then
if Is_Overloaded (Name (Parent (Par))) then
declare
Proc : constant Node_Id := Name (Parent (Par));
@@ -8617,57 +8986,103 @@ package body Sem_Ch4 is
begin
Get_First_Interp (Proc, I, It);
while Present (It.Nam) loop
- if not Expr_Matches_In_Formal (It.Nam, Par) then
+ if not Expr_Matches_In_Formal
+ (Subp => It.Nam,
+ Subp_Call => Parent (Par),
+ Param => Par)
+ then
return False;
end if;
Get_Next_Interp (I, It);
end loop;
- end;
- -- All interpretations have a matching in-mode formal
+ -- All interpretations have a matching in-mode formal
- return True;
+ return True;
+ end;
else
- Proc := Entity (Name (Parent (Par)));
+ declare
+ Proc : Entity_Id := Entity (Name (Parent (Par)));
- -- If this is an indirect call, get formals from
- -- designated type.
+ begin
+ -- If this is an indirect call, get formals from
+ -- designated type.
- if Is_Access_Subprogram_Type (Etype (Proc)) then
- Proc := Designated_Type (Etype (Proc));
- end if;
+ if Is_Access_Subprogram_Type (Etype (Proc)) then
+ Proc := Designated_Type (Etype (Proc));
+ end if;
+
+ return Expr_Matches_In_Formal
+ (Subp => Proc,
+ Subp_Call => Parent (Par),
+ Param => Par);
+ end;
end if;
- return Expr_Matches_In_Formal (Proc, Par);
- end;
+ -- Continue climbing
+
+ elsif Nkind (Name (Parent (Par))) = N_Explicit_Dereference then
+ null;
+
+ -- Not a regular call; we know that we are in a subprogram
+ -- call, we also know that the name of the call may be a
+ -- prefixed call, and we know the name of the target
+ -- subprogram. Search for an unique target candidate in the
+ -- homonym chain.
+
+ elsif Nkind (Name (Parent (Par))) = N_Selected_Component then
+ declare
+ Candidate : Entity_Id;
+ Is_Constant_Idx : Boolean;
+
+ begin
+ Handle_Selected_Component
+ (Current_Node => Par,
+ Sel_Comp => Name (Parent (Par)),
+ Candidate => Candidate,
+ Is_Constant_Idx => Is_Constant_Idx);
+
+ if Present (Candidate) then
+ return Is_Constant_Idx;
+
+ -- Continue climbing
+
+ else
+ null;
+ end if;
+ end;
+ end if;
+
+ -- It is not interpreted as constant indexing for the name in
+ -- an object renaming.
elsif Nkind (Parent (Par)) = N_Object_Renaming_Declaration then
return False;
- -- If the indexed component is a prefix it may be the first actual
- -- of a prefixed call. Retrieve the called entity, if any, and
- -- check its first formal. Determine if the context is a procedure
- -- or function call.
+ -- If the indexed component is a prefix it may be an actual of
+ -- of a prefixed call.
elsif Nkind (Parent (Par)) = N_Selected_Component then
declare
- Sel : constant Node_Id := Selector_Name (Parent (Par));
- Nam : constant Entity_Id := Current_Entity (Sel);
+ Candidate : Entity_Id;
+ Is_Constant_Idx : Boolean;
begin
- if Present (Nam) and then Is_Overloadable (Nam) then
- if Nkind (Parent (Parent (Par))) =
- N_Procedure_Call_Statement
- then
- return False;
+ Handle_Selected_Component
+ (Current_Node => Par,
+ Sel_Comp => Parent (Par),
+ Candidate => Candidate,
+ Is_Constant_Idx => Is_Constant_Idx);
- elsif Ekind (Nam) = E_Function
- and then Present (First_Formal (Nam))
- then
- return Ekind (First_Formal (Nam)) = E_In_Parameter;
- end if;
+ if Present (Candidate) then
+ return Is_Constant_Idx;
+
+ -- Continue climbing
+
+ else
+ null;
end if;
end;
@@ -8678,61 +9093,12 @@ package body Sem_Ch4 is
Par := Parent (Par);
end loop;
- -- In all other cases, constant indexing is legal
+ -- It is not interpreted as constant indexing when both aspects
+ -- are present (RM 4.1.6(13/3)).
- return True;
+ return False;
end Constant_Indexing_OK;
- ----------------------------
- -- Expr_Matches_In_Formal --
- ----------------------------
-
- function Expr_Matches_In_Formal
- (Subp : Entity_Id;
- Par : Node_Id) return Boolean
- is
- Actual : Node_Id;
- Formal : Node_Id;
-
- begin
- Formal := First_Formal (Subp);
- Actual := First (Parameter_Associations ((Parent (Par))));
-
- if Nkind (Par) /= N_Parameter_Association then
-
- -- Match by position
-
- while Present (Actual) and then Present (Formal) loop
- exit when Actual = Par;
- Next (Actual);
-
- if Present (Formal) then
- Next_Formal (Formal);
-
- -- Otherwise this is a parameter mismatch, the error is
- -- reported elsewhere, or else variable indexing is implied.
-
- else
- return False;
- end if;
- end loop;
-
- else
- -- Match by name
-
- while Present (Formal) loop
- exit when Chars (Formal) = Chars (Selector_Name (Par));
- Next_Formal (Formal);
-
- if No (Formal) then
- return False;
- end if;
- end loop;
- end if;
-
- return Present (Formal) and then Ekind (Formal) = E_In_Parameter;
- end Expr_Matches_In_Formal;
-
------------------------------
-- Indexing_Interpretations --
------------------------------
@@ -8782,14 +9148,127 @@ package body Sem_Ch4 is
return Indexing_Func;
end Indexing_Interpretations;
+ ---------------------------
+ -- Try_Indexing_Function --
+ ---------------------------
+
+ function Try_Indexing_Function
+ (Func_Name : Node_Id;
+ Assoc : List_Id) return Entity_Id
+ is
+ Loc : constant Source_Ptr := Sloc (N);
+ Func : Entity_Id;
+ Indexing : Node_Id;
+
+ begin
+ if not Is_Overloaded (Func_Name) then
+ Func := Entity (Func_Name);
+
+ Indexing :=
+ Make_Function_Call (Loc,
+ Name => New_Occurrence_Of (Func, Loc),
+ Parameter_Associations => Assoc);
+
+ Set_Parent (Indexing, Parent (N));
+ Set_Generalized_Indexing (N, Indexing);
+ Analyze (Indexing);
+ Set_Etype (N, Etype (Indexing));
+
+ -- If the return type of the indexing function is a reference
+ -- type, add the dereference as a possible interpretation. Note
+ -- that the indexing aspect may be a function that returns the
+ -- element type with no intervening implicit dereference, and
+ -- that the reference discriminant is not the first discriminant.
+
+ if Has_Discriminants (Etype (Func)) then
+ Check_Implicit_Dereference (N, Etype (Func));
+ end if;
+
+ else
+ -- If there are multiple indexing functions, build a function
+ -- call and analyze it for each of the possible interpretations.
+
+ Indexing :=
+ Make_Function_Call (Loc,
+ Name =>
+ Make_Identifier (Loc, Chars (Func_Name)),
+ Parameter_Associations => Assoc);
+ Set_Parent (Indexing, Parent (N));
+ Set_Generalized_Indexing (N, Indexing);
+ Set_Etype (N, Any_Type);
+ Set_Etype (Name (Indexing), Any_Type);
+
+ declare
+ I : Interp_Index;
+ It : Interp;
+ Success : Boolean;
+
+ begin
+ Get_First_Interp (Func_Name, I, It);
+ Set_Etype (Indexing, Any_Type);
+
+ -- Analyze each candidate function with the given actuals
+
+ while Present (It.Nam) loop
+ Analyze_One_Call (Indexing, It.Nam, False, Success);
+ Get_Next_Interp (I, It);
+ end loop;
+
+ -- If there are several successful candidates, resolution will
+ -- be by result. Mark the interpretations of the function name
+ -- itself.
+
+ if Is_Overloaded (Indexing) then
+ Get_First_Interp (Indexing, I, It);
+
+ while Present (It.Nam) loop
+ Add_One_Interp (Name (Indexing), It.Nam, It.Typ);
+ Get_Next_Interp (I, It);
+ end loop;
+
+ else
+ Set_Etype (Name (Indexing), Etype (Indexing));
+ end if;
+
+ -- Now add the candidate interpretations to the indexing node
+ -- itself, to be replaced later by the function call.
+
+ if Is_Overloaded (Name (Indexing)) then
+ Get_First_Interp (Name (Indexing), I, It);
+
+ while Present (It.Nam) loop
+ Add_One_Interp (N, It.Nam, It.Typ);
+
+ -- Add dereference interpretation if the result type has
+ -- implicit reference discriminants.
+
+ if Has_Discriminants (Etype (It.Nam)) then
+ Check_Implicit_Dereference (N, Etype (It.Nam));
+ end if;
+
+ Get_Next_Interp (I, It);
+ end loop;
+
+ else
+ Set_Etype (N, Etype (Name (Indexing)));
+
+ if Has_Discriminants (Etype (N)) then
+ Check_Implicit_Dereference (N, Etype (N));
+ end if;
+ end if;
+ end;
+ end if;
+
+ return Etype (Indexing);
+ end Try_Indexing_Function;
+
-- Local variables
Loc : constant Source_Ptr := Sloc (N);
Assoc : List_Id;
C_Type : Entity_Id;
- Func : Entity_Id;
Func_Name : Node_Id;
- Indexing : Node_Id;
+ Idx_Type : Entity_Id;
-- Start of processing for Try_Container_Indexing
@@ -8799,6 +9278,13 @@ package body Sem_Ch4 is
if Present (Generalized_Indexing (N)) then
return True;
+
+ -- Old language version or unknown type require no action
+
+ elsif Ada_Version < Ada_2012
+ or else Pref_Typ = Any_Type
+ then
+ return False;
end if;
-- An explicit dereference needs to be created in the case of a prefix
@@ -8833,8 +9319,8 @@ package body Sem_Ch4 is
Func_Name := Empty;
- -- The context is suitable for constant indexing, so obtain the name of
- -- the indexing functions from aspect Constant_Indexing.
+ -- The context is suitable for constant indexing, so obtain the name
+ -- of the indexing functions from aspect Constant_Indexing.
if Constant_Indexing_OK then
Func_Name :=
@@ -8867,6 +9353,11 @@ package body Sem_Ch4 is
else
return False;
end if;
+
+ -- Handle cascaded errors
+
+ elsif No (Entity (Func_Name)) then
+ return False;
end if;
Assoc := New_List (Relocate_Node (Prefix));
@@ -8907,110 +9398,54 @@ package body Sem_Ch4 is
end loop;
end;
- if not Is_Overloaded (Func_Name) then
- Func := Entity (Func_Name);
-
- -- Can happen in case of e.g. cascaded errors
-
- if No (Func) then
- return False;
- end if;
-
- Indexing :=
- Make_Function_Call (Loc,
- Name => New_Occurrence_Of (Func, Loc),
- Parameter_Associations => Assoc);
-
- Set_Parent (Indexing, Parent (N));
- Set_Generalized_Indexing (N, Indexing);
- Analyze (Indexing);
- Set_Etype (N, Etype (Indexing));
-
- -- If the return type of the indexing function is a reference type,
- -- add the dereference as a possible interpretation. Note that the
- -- indexing aspect may be a function that returns the element type
- -- with no intervening implicit dereference, and that the reference
- -- discriminant is not the first discriminant.
-
- if Has_Discriminants (Etype (Func)) then
- Check_Implicit_Dereference (N, Etype (Func));
- end if;
-
- else
- -- If there are multiple indexing functions, build a function call
- -- and analyze it for each of the possible interpretations.
-
- Indexing :=
- Make_Function_Call (Loc,
- Name =>
- Make_Identifier (Loc, Chars (Func_Name)),
- Parameter_Associations => Assoc);
- Set_Parent (Indexing, Parent (N));
- Set_Generalized_Indexing (N, Indexing);
- Set_Etype (N, Any_Type);
- Set_Etype (Name (Indexing), Any_Type);
-
+ Idx_Type := Try_Indexing_Function (Func_Name, Assoc);
+
+ -- Last chance handling for heuristics: Given that prefix notation
+ -- calls have not yet been resolved, when the type of the prefix has
+ -- both operational aspects present (Constant_Indexing and Variable_
+ -- Indexing), and the analysis of the context identified a potential
+ -- prefix notation call (i.e. an N_Selected_Component node), the
+ -- evaluation of Constant_Indexing_OK is based on heuristics; in such
+ -- case, if the chosen indexing approach is noticed now to be wrong
+ -- we retry with the other alternative before leaving.
+
+ -- Retrying means that the heuristic decision taken when analyzing
+ -- the context failed in this case, and therefore we should adjust
+ -- the code of Handle_Selected_Component to improve identification
+ -- of prefix notation calls. This last chance handling handler is
+ -- left here for the purpose of improving such routine because it
+ -- proved to be usefull for identified such cases when the function
+ -- Handle_Selected_Component was added.
+
+ if Idx_Type = Any_Type and then Heuristic then
declare
- I : Interp_Index;
- It : Interp;
- Success : Boolean;
+ Tried_Func_Name : constant Node_Id := Func_Name;
begin
- Get_First_Interp (Func_Name, I, It);
- Set_Etype (Indexing, Any_Type);
-
- -- Analyze each candidate function with the given actuals
-
- while Present (It.Nam) loop
- Analyze_One_Call (Indexing, It.Nam, False, Success);
- Get_Next_Interp (I, It);
- end loop;
-
- -- If there are several successful candidates, resolution will
- -- be by result. Mark the interpretations of the function name
- -- itself.
-
- if Is_Overloaded (Indexing) then
- Get_First_Interp (Indexing, I, It);
+ Func_Name :=
+ Indexing_Interpretations (C_Type,
+ Aspect_Constant_Indexing);
- while Present (It.Nam) loop
- Add_One_Interp (Name (Indexing), It.Nam, It.Typ);
- Get_Next_Interp (I, It);
- end loop;
+ if Present (Func_Name)
+ and then Func_Name /= Tried_Func_Name
+ then
+ Idx_Type := Try_Indexing_Function (Func_Name, Assoc);
else
- Set_Etype (Name (Indexing), Etype (Indexing));
- end if;
-
- -- Now add the candidate interpretations to the indexing node
- -- itself, to be replaced later by the function call.
-
- if Is_Overloaded (Name (Indexing)) then
- Get_First_Interp (Name (Indexing), I, It);
-
- while Present (It.Nam) loop
- Add_One_Interp (N, It.Nam, It.Typ);
-
- -- Add dereference interpretation if the result type has
- -- implicit reference discriminants.
+ Func_Name :=
+ Indexing_Interpretations (C_Type,
+ Aspect_Variable_Indexing);
- if Has_Discriminants (Etype (It.Nam)) then
- Check_Implicit_Dereference (N, Etype (It.Nam));
- end if;
-
- Get_Next_Interp (I, It);
- end loop;
-
- else
- Set_Etype (N, Etype (Name (Indexing)));
- if Has_Discriminants (Etype (N)) then
- Check_Implicit_Dereference (N, Etype (N));
+ if Present (Func_Name)
+ and then Func_Name /= Tried_Func_Name
+ then
+ Idx_Type := Try_Indexing_Function (Func_Name, Assoc);
end if;
end if;
end;
end if;
- if Etype (Indexing) = Any_Type then
+ if Idx_Type = Any_Type then
Error_Msg_NE
("container cannot be indexed with&", N, Etype (First (Exprs)));
Rewrite (N, New_Occurrence_Of (Any_Id, Loc));
@@ -10480,6 +10915,10 @@ package body Sem_Ch4 is
-- Start of processing for Try_Object_Operation
begin
+ if Is_Class_Wide_Equivalent_Type (Obj_Type) then
+ Obj_Type := Corresponding_Mutably_Tagged_Type (Obj_Type);
+ end if;
+
Analyze_Expression (Obj);
-- Analyze the actuals if node is known to be a subprogram call
@@ -10667,86 +11106,46 @@ package body Sem_Ch4 is
end loop;
if No (Op_Id) then
- if Debug_Flag_Underscore_DD then
- if Nkind (N) /= N_Op_Concat then
- if Nkind (N) in N_Op_Multiply | N_Op_Divide
- and then Is_Fixed_Point_Type (Etype (L))
- and then Is_Integer_Type (Etype (R))
- then
- Record_Invalid_Operand_Types_For_Operator_R_Int_Error
- (Op => N,
- L => L,
- L_Type => Etype (L),
- R => R,
- R_Type => Etype (R));
-
- elsif Nkind (N) = N_Op_Multiply
- and then Is_Fixed_Point_Type (Etype (R))
- and then Is_Integer_Type (Etype (L))
- then
- Record_Invalid_Operand_Types_For_Operator_L_Int_Error
- (Op => N,
- L => L,
- L_Type => Etype (L),
- R => R,
- R_Type => Etype (R));
- else
- Record_Invalid_Operand_Types_For_Operator_Error
- (Op => N,
- L => L,
- L_Type => Etype (L),
- R => R,
- R_Type => Etype (R));
- end if;
- elsif Is_Access_Type (Etype (L)) then
- Record_Invalid_Operand_Types_For_Operator_L_Acc_Error
- (Op => N,
- L => L);
-
- elsif Is_Access_Type (Etype (R)) then
- Record_Invalid_Operand_Types_For_Operator_R_Acc_Error
- (Op => N,
- R => R);
- else
- Record_Invalid_Operand_Types_For_Operator_General_Error
- (N);
- end if;
- else
- Error_Msg_N ("invalid operand types for operator&", N);
+ Error_Msg_N
+ ("invalid operand types for operator&", N,
+ GNAT0002);
- if Nkind (N) /= N_Op_Concat then
- Error_Msg_NE ("\left operand has}!", N, Etype (L));
- Error_Msg_NE ("\right operand has}!", N, Etype (R));
+ if Nkind (N) /= N_Op_Concat then
+ Error_Msg_NE
+ ("\left operand has}!", N, Etype (L));
+ Error_Msg_NE
+ ("\right operand has}!", N, Etype (R));
- -- For multiplication and division operators with
- -- a fixed-point operand and an integer operand,
- -- indicate that the integer operand should be of
- -- type Integer.
+ -- For multiplication and division operators with
+ -- a fixed-point operand and an integer operand,
+ -- indicate that the integer operand should be of
+ -- type Integer.
- if Nkind (N) in N_Op_Multiply | N_Op_Divide
- and then Is_Fixed_Point_Type (Etype (L))
- and then Is_Integer_Type (Etype (R))
- then
- Error_Msg_N ("\convert right operand to `Integer`", N);
+ if Nkind (N) in N_Op_Multiply | N_Op_Divide
+ and then Is_Fixed_Point_Type (Etype (L))
+ and then Is_Integer_Type (Etype (R))
+ then
+ Error_Msg_N
+ ("\convert right operand to `Integer`", N);
- elsif Nkind (N) = N_Op_Multiply
- and then Is_Fixed_Point_Type (Etype (R))
- and then Is_Integer_Type (Etype (L))
- then
- Error_Msg_N ("\convert left operand to `Integer`", N);
- end if;
+ elsif Nkind (N) = N_Op_Multiply
+ and then Is_Fixed_Point_Type (Etype (R))
+ and then Is_Integer_Type (Etype (L))
+ then
+ Error_Msg_N
+ ("\convert left operand to `Integer`", N);
+ end if;
-- For concatenation operators it is more difficult to
-- determine which is the wrong operand. It is worth
-- flagging explicitly an access type, for those who
-- might think that a dereference happens here.
- elsif Is_Access_Type (Etype (L)) then
- Error_Msg_N ("\left operand is access type", N);
+ elsif Is_Access_Type (Etype (L)) then
+ Error_Msg_N ("\left operand is access type", N);
- elsif Is_Access_Type (Etype (R)) then
- Error_Msg_N ("\right operand is access type", N);
- end if;
+ elsif Is_Access_Type (Etype (R)) then
+ Error_Msg_N ("\right operand is access type", N);
end if;
end if;
end if;
diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb
index 12d6426..e1d6be4 100644
--- a/gcc/ada/sem_ch5.adb
+++ b/gcc/ada/sem_ch5.adb
@@ -90,6 +90,12 @@ package body Sem_Ch5 is
-- messages. This variable is recursively saved on entry to processing the
-- construct, and restored on exit.
+ function Analyze_Loop_Flow_Statement
+ (N : N_Loop_Flow_Statement_Id) return Opt_E_Loop_Id;
+ -- Perform analysis that is common to continue statements and exit
+ -- statements. On success, the return value is the entity of the loop
+ -- referenced by the statement.
+
function Has_Sec_Stack_Call (N : Node_Id) return Boolean;
-- N is the node for an arbitrary construct. This function searches the
-- construct N to see if it contains a function call that returns on the
@@ -534,7 +540,11 @@ package body Sem_Ch5 is
if In_Inlined_Body then
null;
- elsif not Is_Variable (Lhs) then
+ elsif not Is_Variable (Lhs)
+ and then not (not Comes_From_Source (Lhs)
+ and then Nkind (Lhs) in N_Has_Etype
+ and then Needs_Construction (Etype (Lhs)))
+ then
-- Ada 2005 (AI-327): Check assignment to the attribute Priority of a
-- protected object.
@@ -1659,6 +1669,112 @@ package body Sem_Ch5 is
end if;
end Analyze_Case_Statement;
+ --------------------------------
+ -- Analyze_Continue_Statement --
+ --------------------------------
+
+ procedure Analyze_Continue_Statement (N : Node_Id) is
+ Ignore_Errors_On_Entry : constant Boolean := Get_Ignore_Errors;
+
+ Loc : constant Source_Ptr := Sloc (N);
+
+ Nam : constant Node_Id := Name (N);
+ Cond : constant Node_Id := Condition (N);
+
+ function Make_Call return N_Procedure_Call_Statement_Id;
+ -- Build a node that corresponds to the procedure call interpretation of
+ -- N.
+
+ function Make_Stmt return N_Continue_Statement_Id;
+ -- Build a node that corresponds to the continue statement
+ -- interpretation of N.
+
+ function Make_Call return N_Procedure_Call_Statement_Id is
+ begin
+ return
+ Make_Procedure_Call_Statement
+ (Loc, Make_Identifier (Loc, Name_Continue));
+ end Make_Call;
+
+ function Make_Stmt return N_Continue_Statement_Id is
+ begin
+ return Make_Continue_Statement (Loc, Nam, Cond);
+ end Make_Stmt;
+
+ Continue_Is_Available : constant Boolean :=
+ Ada_Version = Ada_With_All_Extensions;
+
+ Maybe_Procedure_Call : constant Boolean :=
+ No (Name (N)) and then No (Condition (N));
+ begin
+ if Maybe_Procedure_Call and then Continue_Is_Available then
+ -- This is the tricky case. The idea is to do a kind of overload
+ -- resolution of a procedure call, but with "continue statement" as
+ -- an additional possible interpretation. To achieve this, we
+ -- temporarily replace N with a procedure call statement and analyze
+ -- it in "ignore errors" mode.
+ Replace (N, Make_Call);
+ Set_Ignore_Errors (True);
+ Analyze (N);
+ Set_Ignore_Errors (Ignore_Errors_On_Entry);
+
+ declare
+ C : constant N_Procedure_Call_Statement_Id := New_Copy (N);
+ -- C is the result of our procedure call interpretation analysis
+ begin
+ -- We restore N to a continue statement
+ Replace (N, Make_Stmt);
+
+ if Is_Overloaded (Name (C)) then
+ -- There are multiple valid procedure call interpretations; we
+ -- don't mention the possible interpretation as a continue
+ -- statement for now. It might be possible to add this in the
+ -- future.
+
+ Set_Call_Or_Target_Loop (N, Make_Call);
+ elsif Etype (C) = Any_Type then
+ -- There is no valid procedure call interpretation. We go for
+ -- the continue statement interpretation. It might not be valid
+ -- either, but we make the assumption that the user meant to
+ -- write a continue statement and not a procedure call and emit
+ -- error messages accordingly.
+
+ Set_Call_Or_Target_Loop (N, Analyze_Loop_Flow_Statement (N));
+ else
+ -- There is a unique valid procedure call interpretation. We
+ -- test whether the interpretation as a continue statement is
+ -- valid.
+
+ declare
+ L : Opt_E_Loop_Id;
+ begin
+ Set_Ignore_Errors (True);
+ L := Analyze_Loop_Flow_Statement (N);
+ Set_Ignore_Errors (Ignore_Errors_On_Entry);
+
+ if Present (L) then
+ -- If the continue statement interpretation makes sense,
+ -- we post an ad hoc ambiguity error.
+ Error_Msg_N
+ ("ambiguity between continue statement and call", N);
+ else
+ Set_Call_Or_Target_Loop (N, Make_Call);
+ end if;
+ end;
+ end if;
+ end;
+ elsif Maybe_Procedure_Call then
+ Set_Call_Or_Target_Loop (N, Make_Call);
+ elsif Continue_Is_Available then
+ Set_Call_Or_Target_Loop (N, Analyze_Loop_Flow_Statement (N));
+ else
+ Error_Msg_GNAT_Extension
+ (Extension => "continue",
+ Loc => Sloc (N),
+ Is_Core_Extension => False);
+ end if;
+ end Analyze_Continue_Statement;
+
----------------------------
-- Analyze_Exit_Statement --
----------------------------
@@ -1678,99 +1794,16 @@ package body Sem_Ch5 is
-- in a loop. The exit must be the last statement in the if-statement.
procedure Analyze_Exit_Statement (N : Node_Id) is
- Target : constant Node_Id := Name (N);
- Cond : constant Node_Id := Condition (N);
- Scope_Id : Entity_Id := Empty; -- initialize to prevent warning
- U_Name : Entity_Id;
- Kind : Entity_Kind;
-
+ L : constant Opt_E_Loop_Id := Analyze_Loop_Flow_Statement (N);
begin
- if No (Cond) then
- Check_Unreachable_Code (N);
- end if;
-
- if Present (Target) then
- Analyze (Target);
- U_Name := Entity (Target);
-
- if not In_Open_Scopes (U_Name) or else Ekind (U_Name) /= E_Loop then
- Error_Msg_N ("invalid loop name in exit statement", N);
- return;
+ if Present (L) then
+ Set_Has_Exit (L);
- else
- Set_Has_Exit (U_Name);
- end if;
+ -- Chain exit statement to associated loop entity
- else
- U_Name := Empty;
+ Set_Next_Exit_Statement (N, First_Exit_Statement (L));
+ Set_First_Exit_Statement (L, N);
end if;
-
- for J in reverse 0 .. Scope_Stack.Last loop
- Scope_Id := Scope_Stack.Table (J).Entity;
- Kind := Ekind (Scope_Id);
-
- if Kind = E_Loop and then (No (Target) or else Scope_Id = U_Name) then
- Set_Has_Exit (Scope_Id);
- exit;
-
- elsif Kind = E_Block
- or else Kind = E_Loop
- or else Kind = E_Return_Statement
- then
- null;
-
- else
- Error_Msg_N
- ("cannot exit from program unit or accept statement", N);
- return;
- end if;
- end loop;
-
- Finally_Legality_Check : declare
- -- The following value can actually be a block statement due to
- -- expansion, but we call it Target_Loop_Statement because it was
- -- originally a loop statement.
- Target_Loop_Statement : constant Node_Id :=
- (if Present (U_Name) then Label_Construct ((Parent (U_Name)))
- else Empty);
-
- X : Node_Id := N;
- begin
- while Present (X) loop
- if Nkind (X) = N_Loop_Statement
- and then (No (Target_Loop_Statement)
- or else X = Target_Loop_Statement)
- then
- exit;
- elsif Nkind (Parent (X)) = N_Handled_Sequence_Of_Statements
- and then Is_List_Member (X)
- and then List_Containing (X) = Finally_Statements (Parent (X))
- then
- Error_Msg_N ("cannot exit out of finally part", N);
- exit;
- end if;
- X := Parent (X);
- end loop;
- end Finally_Legality_Check;
-
- -- Verify that if present the condition is a Boolean expression
-
- if Present (Cond) then
- Analyze_And_Resolve (Cond, Any_Boolean);
- Check_Unset_Reference (Cond);
- end if;
-
- -- Chain exit statement to associated loop entity
-
- Set_Next_Exit_Statement (N, First_Exit_Statement (Scope_Id));
- Set_First_Exit_Statement (Scope_Id, N);
-
- -- Since the exit may take us out of a loop, any previous assignment
- -- statement is not useless, so clear last assignment indications. It
- -- is OK to keep other current values, since if the exit statement
- -- does not exit, then the current values are still valid.
-
- Kill_Current_Values (Last_Assignment_Only => True);
end Analyze_Exit_Statement;
----------------------------
@@ -3145,6 +3178,7 @@ package body Sem_Ch5 is
-- Start of processing for Analyze_Loop_Parameter_Specification
begin
+ Mutate_Ekind (Id, E_Loop_Parameter);
Enter_Name (Id);
-- We always consider the loop variable to be referenced, since the loop
@@ -3250,7 +3284,6 @@ package body Sem_Ch5 is
-- subsequent analysis of the condition in a quantified
-- expression.
- Mutate_Ekind (Id, E_Loop_Parameter);
return;
end;
@@ -3313,7 +3346,6 @@ package body Sem_Ch5 is
Make_Index (DS, N);
end if;
- Mutate_Ekind (Id, E_Loop_Parameter);
Set_Etype (Id, Etype (DS));
Set_Is_Not_Self_Hidden (Id);
@@ -3557,10 +3589,6 @@ package body Sem_Ch5 is
----------------------------
procedure Analyze_Loop_Statement (N : Node_Id) is
-
- -- The following exception is raised by routine Prepare_Loop_Statement
- -- to avoid further analysis of a transformed loop.
-
procedure Prepare_Loop_Statement
(Iter : Node_Id;
Stop_Processing : out Boolean);
@@ -3998,6 +4026,18 @@ package body Sem_Ch5 is
Set_Has_Created_Identifier (N);
end if;
+ if No (Continue_Mark (Ent)) then
+ -- If Continue_Mark wasn't set on the loop entity, we know that N
+ -- does not come from the expansion of iterators that append
+ -- statements to advance the loop, so right after the last statement
+ -- in the list is where continue statements must jump to.
+ Set_Continue_Mark (Ent, Last (Statements (N)));
+ else
+ -- Otherwise, N somehow derives from another loop statement, the
+ -- analysis of which set Continue_Mark adequately already.
+ null;
+ end if;
+
-- Determine whether the loop statement must be transformed prior to
-- analysis, and if so, perform it. This early modification is needed
-- when:
@@ -4207,6 +4247,105 @@ package body Sem_Ch5 is
end if;
end Analyze_Loop_Statement;
+ ---------------------------------
+ -- Analyze_Loop_Flow_Statement --
+ ---------------------------------
+
+ function Analyze_Loop_Flow_Statement
+ (N : N_Loop_Flow_Statement_Id) return Opt_E_Loop_Id
+ is
+ Target : constant Node_Id := Name (N);
+ Cond : constant Node_Id := Condition (N);
+ Scope_Id : Entity_Id := Empty;
+ U_Name : Entity_Id;
+ Kind : Entity_Kind;
+
+ S : constant String := Loop_Flow_Keyword (N);
+ begin
+ if No (Cond) then
+ Check_Unreachable_Code (N);
+ end if;
+
+ if Present (Target) then
+ Analyze (Target);
+ U_Name := Entity (Target);
+
+ if not In_Open_Scopes (U_Name) or else Ekind (U_Name) /= E_Loop then
+ Error_Msg_N ("invalid loop name in " & S & " statement", N);
+ return Empty;
+ end if;
+
+ else
+ U_Name := Empty;
+ end if;
+
+ for J in reverse 0 .. Scope_Stack.Last loop
+ Scope_Id := Scope_Stack.Table (J).Entity;
+ Kind := Ekind (Scope_Id);
+
+ if Kind = E_Loop and then (No (Target) or else Scope_Id = U_Name) then
+ exit;
+
+ elsif Kind = E_Block
+ or else Kind = E_Loop
+ or else Kind = E_Return_Statement
+ then
+ null;
+
+ else
+ Error_Msg_N
+ ("cannot " & S & " from program unit or accept statement", N);
+ return Empty;
+ end if;
+ end loop;
+
+ Finally_Legality_Check :
+ declare
+ -- The following value can actually be a block statement due to
+ -- expansion, but we call it Target_Loop_Statement because it was
+ -- originally a loop statement.
+ Target_Loop_Statement : constant Node_Id :=
+ (if Present (U_Name)
+ then Label_Construct ((Parent (U_Name)))
+ else Empty);
+
+ X : Node_Id := N;
+ begin
+ while Present (X) loop
+ if Nkind (X) = N_Loop_Statement
+ and then (No (Target_Loop_Statement)
+ or else X = Target_Loop_Statement)
+ then
+ exit;
+ elsif Nkind (Parent (X)) = N_Handled_Sequence_Of_Statements
+ and then Is_List_Member (X)
+ and then List_Containing (X) = Finally_Statements (Parent (X))
+ then
+ Error_Msg_N ("cannot " & S & " out of finally part", N);
+ exit;
+ end if;
+ X := Parent (X);
+ end loop;
+ end Finally_Legality_Check;
+
+ -- Verify that if present the condition is a Boolean expression
+
+ if Present (Cond) then
+ Analyze_And_Resolve (Cond, Any_Boolean);
+ Check_Unset_Reference (Cond);
+ end if;
+
+ -- Since the statement may take us out of the current iteration of the
+ -- loop, any previous assignment statement is not useless, so clear last
+ -- assignment indications. It is OK to keep other current values, since
+ -- if the statement does not stop the current iteration, then the
+ -- current values are still valid.
+
+ Kill_Current_Values (Last_Assignment_Only => True);
+
+ return Scope_Id;
+ end Analyze_Loop_Flow_Statement;
+
----------------------------
-- Analyze_Null_Statement --
----------------------------
diff --git a/gcc/ada/sem_ch5.ads b/gcc/ada/sem_ch5.ads
index 03bfc01..3a6c90e 100644
--- a/gcc/ada/sem_ch5.ads
+++ b/gcc/ada/sem_ch5.ads
@@ -31,6 +31,7 @@ package Sem_Ch5 is
procedure Analyze_Block_Statement (N : Node_Id);
procedure Analyze_Case_Statement (N : Node_Id);
procedure Analyze_Compound_Statement (N : Node_Id);
+ procedure Analyze_Continue_Statement (N : Node_Id);
procedure Analyze_Exit_Statement (N : Node_Id);
procedure Analyze_Goto_Statement (N : Node_Id);
procedure Analyze_Goto_When_Statement (N : Node_Id);
diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index 05bbeed..7bce7fb 100644
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -225,7 +225,10 @@ package body Sem_Ch6 is
-- Create the declaration for an inequality operator that is implicitly
-- created by a user-defined equality operator that yields a boolean.
- procedure Set_Formal_Mode (Formal_Id : Entity_Id);
+ procedure Set_Formal_Mode
+ (Formal_Id : Entity_Id;
+ Spec : N_Parameter_Specification_Id;
+ Subp_Id : Entity_Id);
-- Set proper Ekind to reflect formal mode (in, out, in out), and set
-- miscellaneous other attributes.
@@ -581,16 +584,21 @@ package body Sem_Ch6 is
Set_Has_Completion (Def_Id, not Is_Ignored_Ghost_Entity (Def_Id));
Push_Scope (Def_Id);
Install_Formals (Def_Id);
- Preanalyze_Spec_Expression (Expr, Typ);
+ Preanalyze_And_Resolve_Spec_Expression (Expr, Typ);
End_Scope;
else
Push_Scope (Def_Id);
Install_Formals (Def_Id);
- Preanalyze_Spec_Expression (Expr, Typ);
+ Preanalyze_And_Resolve_Spec_Expression (Expr, Typ);
Check_Limited_Return (Orig_N, Expr, Typ);
End_Scope;
end if;
+ if Is_Incomplete_Type (Typ) then
+ Error_Msg_NE
+ ("premature usage of incomplete}", Expr, First_Subtype (Typ));
+ end if;
+
-- In the case of an expression function marked with the aspect
-- Static, we need to check the requirement that the function's
-- expression is a potentially static expression. This is done
@@ -617,7 +625,7 @@ package body Sem_Ch6 is
begin
Set_Checking_Potentially_Static_Expression (True);
- Preanalyze_Spec_Expression (Exp_Copy, Typ);
+ Preanalyze_And_Resolve_Spec_Expression (Exp_Copy, Typ);
if not Is_Static_Expression (Exp_Copy) then
Error_Msg_N
@@ -2270,6 +2278,23 @@ package body Sem_Ch6 is
end if;
Formal := First_Formal (Spec_Id);
+
+ -- The first parameter of a borrowing traversal function might be an IN
+ -- or an IN OUT parameter.
+
+ if Present (Formal)
+ and then Ekind (Etype (Spec_Id)) = E_Anonymous_Access_Type
+ and then not Is_Access_Constant (Etype (Spec_Id))
+ then
+ if Ekind (Formal) = E_Out_Parameter then
+ Error_Msg_Code := GEC_Out_Parameter_In_Function;
+ Error_Msg_N
+ ("first parameter of traversal function cannot have mode `OUT` "
+ & "in SPARK '[[]']", Formal);
+ end if;
+ Next_Formal (Formal);
+ end if;
+
while Present (Formal) loop
if Ekind (Spec_Id) in E_Function | E_Generic_Function
and then not Is_Function_With_Side_Effects (Spec_Id)
@@ -4581,7 +4606,7 @@ package body Sem_Ch6 is
Analyze_SPARK_Subprogram_Specification (Specification (N));
-- A function with side effects shall not be an expression function
- -- (SPARK RM 6.1.11(6)).
+ -- (SPARK RM 6.1.12(6)).
if Present (Spec_Id)
and then (Is_Expression_Function (Spec_Id)
@@ -4644,10 +4669,8 @@ package body Sem_Ch6 is
-- an incomplete tagged type declaration, get the class-wide
-- type of the incomplete tagged type to match Find_Type_Name.
- if Nkind (Parent (Etyp)) = N_Full_Type_Declaration
- and then Present (Incomplete_View (Parent (Etyp)))
- then
- Etyp := Class_Wide_Type (Incomplete_View (Parent (Etyp)));
+ if Present (Incomplete_View (Etype (Etyp))) then
+ Etyp := Class_Wide_Type (Incomplete_View (Etype (Etyp)));
end if;
Set_Directly_Designated_Type (Etype (Spec_Id), Etyp);
@@ -5379,6 +5402,89 @@ package body Sem_Ch6 is
End_Scope;
+ -- Register the subprogram in a Constructor_List when it is a valid
+ -- constructor.
+
+ if All_Extensions_Allowed
+ and then Present (First_Formal (Designator))
+ then
+
+ declare
+ First_Form_Type : constant Entity_Id :=
+ Etype (First_Formal (Designator));
+
+ Construct : Elmt_Id;
+ begin
+ -- Valid constructors have a "controlling" formal of a type
+ -- with the Constructor aspect specified. Additionally, the
+ -- subprogram name must match value described by the aspect.
+
+ -- Additionally, constructor declarations must exist within the
+ -- same scope as the type declaration and before the type is
+ -- frozen.
+
+ -- For example:
+ --
+ -- type Foo is null record with Constructor => Bar;
+ --
+ -- procedure Bar (Self : in out Foo);
+ --
+
+ if Present (Constructor_Name (First_Form_Type))
+ and then Current_Scope = Scope (First_Form_Type)
+ and then Chars (Constructor_Name (First_Form_Type))
+ = Chars (Designator)
+ and then Ekind (Designator) = E_Procedure
+ and then Nkind (Parent (N)) = N_Subprogram_Declaration
+ then
+ -- If the constructor list is empty than we don't have to
+ -- look for duplicates - we simply create the list and
+ -- add it.
+
+ if No (Constructor_List (First_Form_Type)) then
+ Set_Constructor_List
+ (First_Form_Type, New_Elmt_List (Designator));
+
+ -- Otherwise, we need to check the constructor hasen't
+ -- already been added (e.g. a specification and body) and
+ -- that there isn't a constructor with the same number of
+ -- type of formals.
+
+ -- NOTE: The Constructor_List is sorted by the number of
+ -- parameters.
+
+ else
+ Construct := First_Elmt
+ (Constructor_List (First_Form_Type));
+
+ -- Skip over constructors with less than the number of
+ -- parameters than Designator ???
+
+ -- Loop through the constructors looking for ones which
+ -- "match."
+
+ Outter : loop
+
+ -- When we are at the end of the constructor list we
+ -- know there are no matches, so it is safe to add.
+
+ if No (Construct) then
+ Append_Elmt
+ (Designator,
+ Constructor_List (First_Form_Type));
+ exit Outter;
+ end if;
+
+ -- Loop through the formals and check the formals
+ -- match on type ???
+
+ Next_Elmt (Construct);
+ end loop Outter;
+ end if;
+ end if;
+ end;
+ end if;
+
-- The subprogram scope is pushed and popped around the processing of
-- the return type for consistency with call above to Process_Formals
-- (which itself can call Analyze_Return_Type), and to ensure that any
@@ -6094,7 +6200,7 @@ package body Sem_Ch6 is
if NewD then
Push_Scope (New_Id);
- Preanalyze_Spec_Expression
+ Preanalyze_And_Resolve_Spec_Expression
(Default_Value (New_Formal), Etype (New_Formal));
End_Scope;
end if;
@@ -6319,12 +6425,6 @@ package body Sem_Ch6 is
elsif Has_Delayed_Freeze (T) and then not Is_Frozen (T) then
Set_Has_Delayed_Freeze (Designator);
-
- elsif Is_Access_Type (T)
- and then Has_Delayed_Freeze (Designated_Type (T))
- and then not Is_Frozen (Designated_Type (T))
- then
- Set_Has_Delayed_Freeze (Designator);
end if;
end Possible_Freeze;
@@ -6351,6 +6451,13 @@ package body Sem_Ch6 is
Next_Formal (F);
end loop;
+ -- RM 13.14 (15.1/6): the primitive subprograms of a tagged type are
+ -- frozen at the place where the type is frozen.
+
+ if Is_Dispatching_Operation (Designator) then
+ Set_Has_Delayed_Freeze (Designator);
+ end if;
+
-- Mark functions that return by reference. Note that it cannot be done
-- for delayed_freeze subprograms because the underlying returned type
-- may not be known yet (for private types).
@@ -6360,249 +6467,6 @@ package body Sem_Ch6 is
end if;
end Check_Delayed_Subprogram;
- ------------------------------------
- -- Check_Discriminant_Conformance --
- ------------------------------------
-
- procedure Check_Discriminant_Conformance
- (N : Node_Id;
- Prev : Entity_Id;
- Prev_Loc : Node_Id)
- is
- Old_Discr : Entity_Id := First_Discriminant (Prev);
- New_Discr : Node_Id := First (Discriminant_Specifications (N));
- New_Discr_Id : Entity_Id;
- New_Discr_Type : Entity_Id;
-
- procedure Conformance_Error (Msg : String; N : Node_Id);
- -- Post error message for conformance error on given node. Two messages
- -- are output. The first points to the previous declaration with a
- -- general "no conformance" message. The second is the detailed reason,
- -- supplied as Msg. The parameter N provide information for a possible
- -- & insertion in the message.
-
- -----------------------
- -- Conformance_Error --
- -----------------------
-
- procedure Conformance_Error (Msg : String; N : Node_Id) is
- begin
- Error_Msg_Sloc := Sloc (Prev_Loc);
- Error_Msg_N -- CODEFIX
- ("not fully conformant with declaration#!", N);
- Error_Msg_NE (Msg, N, N);
- end Conformance_Error;
-
- -- Start of processing for Check_Discriminant_Conformance
-
- begin
- while Present (Old_Discr) and then Present (New_Discr) loop
- New_Discr_Id := Defining_Identifier (New_Discr);
-
- -- The subtype mark of the discriminant on the full type has not
- -- been analyzed so we do it here. For an access discriminant a new
- -- type is created.
-
- if Nkind (Discriminant_Type (New_Discr)) = N_Access_Definition then
- New_Discr_Type :=
- Access_Definition (N, Discriminant_Type (New_Discr));
-
- else
- Find_Type (Discriminant_Type (New_Discr));
- New_Discr_Type := Etype (Discriminant_Type (New_Discr));
-
- -- Ada 2005: if the discriminant definition carries a null
- -- exclusion, create an itype to check properly for consistency
- -- with partial declaration.
-
- if Is_Access_Type (New_Discr_Type)
- and then Null_Exclusion_Present (New_Discr)
- then
- New_Discr_Type :=
- Create_Null_Excluding_Itype
- (T => New_Discr_Type,
- Related_Nod => New_Discr,
- Scope_Id => Current_Scope);
- end if;
- end if;
-
- if not Conforming_Types
- (Etype (Old_Discr), New_Discr_Type, Fully_Conformant)
- then
- Conformance_Error ("type of & does not match!", New_Discr_Id);
- return;
- else
- -- Treat the new discriminant as an occurrence of the old one,
- -- for navigation purposes, and fill in some semantic
- -- information, for completeness.
-
- Generate_Reference (Old_Discr, New_Discr_Id, 'r');
- Set_Etype (New_Discr_Id, Etype (Old_Discr));
- Set_Scope (New_Discr_Id, Scope (Old_Discr));
- end if;
-
- -- Names must match
-
- if Chars (Old_Discr) /= Chars (Defining_Identifier (New_Discr)) then
- Conformance_Error ("name & does not match!", New_Discr_Id);
- return;
- end if;
-
- -- Default expressions must match
-
- declare
- NewD : constant Boolean :=
- Present (Expression (New_Discr));
- OldD : constant Boolean :=
- Present (Expression (Parent (Old_Discr)));
-
- function Has_Tagged_Limited_Partial_View
- (Typ : Entity_Id) return Boolean;
- -- Returns True iff Typ has a tagged limited partial view.
-
- function Is_Derived_From_Immutably_Limited_Type
- (Typ : Entity_Id) return Boolean;
- -- Returns True iff Typ is a derived type (tagged or not)
- -- whose ancestor type is immutably limited. The unusual
- -- ("unusual" is one word for it) thing about this function
- -- is that it handles the case where the ancestor name's Entity
- -- attribute has not been set yet.
-
- -------------------------------------
- -- Has_Tagged_Limited_Partial_View --
- -------------------------------------
-
- function Has_Tagged_Limited_Partial_View
- (Typ : Entity_Id) return Boolean
- is
- Priv : constant Entity_Id := Incomplete_Or_Partial_View (Typ);
- begin
- return Present (Priv)
- and then not Is_Incomplete_Type (Priv)
- and then Is_Tagged_Type (Priv)
- and then Limited_Present (Parent (Priv));
- end Has_Tagged_Limited_Partial_View;
-
- --------------------------------------------
- -- Is_Derived_From_Immutably_Limited_Type --
- --------------------------------------------
-
- function Is_Derived_From_Immutably_Limited_Type
- (Typ : Entity_Id) return Boolean
- is
- Type_Def : constant Node_Id := Type_Definition (Parent (Typ));
- Parent_Name : Node_Id;
- begin
- if Nkind (Type_Def) /= N_Derived_Type_Definition then
- return False;
- end if;
- Parent_Name := Subtype_Indication (Type_Def);
- if Nkind (Parent_Name) = N_Subtype_Indication then
- Parent_Name := Subtype_Mark (Parent_Name);
- end if;
- if Parent_Name not in N_Has_Entity_Id
- or else No (Entity (Parent_Name))
- then
- Find_Type (Parent_Name);
- end if;
- return Is_Immutably_Limited_Type (Entity (Parent_Name));
- end Is_Derived_From_Immutably_Limited_Type;
-
- begin
- if NewD or OldD then
-
- -- The old default value has been analyzed and expanded,
- -- because the current full declaration will have frozen
- -- everything before. The new default values have not been
- -- expanded, so expand now to check conformance.
-
- if NewD then
- Preanalyze_Spec_Expression
- (Expression (New_Discr), New_Discr_Type);
- end if;
-
- if not (NewD and OldD)
- or else not Fully_Conformant_Expressions
- (Expression (Parent (Old_Discr)),
- Expression (New_Discr))
-
- then
- Conformance_Error
- ("default expression for & does not match!",
- New_Discr_Id);
- return;
- end if;
-
- if NewD
- and then Ada_Version >= Ada_2005
- and then Nkind (Discriminant_Type (New_Discr)) =
- N_Access_Definition
- and then not Is_Immutably_Limited_Type
- (Defining_Identifier (N))
-
- -- Check for a case that would be awkward to handle in
- -- Is_Immutably_Limited_Type (because sem_aux can't
- -- "with" sem_util).
-
- and then not Has_Tagged_Limited_Partial_View
- (Defining_Identifier (N))
-
- -- Check for another case that would be awkward to handle
- -- in Is_Immutably_Limited_Type
-
- and then not Is_Derived_From_Immutably_Limited_Type
- (Defining_Identifier (N))
- then
- Error_Msg_N
- ("(Ada 2005) default value for access discriminant "
- & "requires immutably limited type",
- Expression (New_Discr));
- return;
- end if;
- end if;
- end;
-
- -- In Ada 83 case, grouping must match: (A,B : X) /= (A : X; B : X)
-
- if Ada_Version = Ada_83 then
- declare
- Old_Disc : constant Node_Id := Declaration_Node (Old_Discr);
-
- begin
- -- Grouping (use of comma in param lists) must be the same
- -- This is where we catch a misconformance like:
-
- -- A, B : Integer
- -- A : Integer; B : Integer
-
- -- which are represented identically in the tree except
- -- for the setting of the flags More_Ids and Prev_Ids.
-
- if More_Ids (Old_Disc) /= More_Ids (New_Discr)
- or else Prev_Ids (Old_Disc) /= Prev_Ids (New_Discr)
- then
- Conformance_Error
- ("grouping of & does not match!", New_Discr_Id);
- return;
- end if;
- end;
- end if;
-
- Next_Discriminant (Old_Discr);
- Next (New_Discr);
- end loop;
-
- if Present (Old_Discr) then
- Conformance_Error ("too few discriminants!", Defining_Identifier (N));
- return;
-
- elsif Present (New_Discr) then
- Conformance_Error
- ("too many discriminants!", Defining_Identifier (New_Discr));
- return;
- end if;
- end Check_Discriminant_Conformance;
-
-----------------------------------------
-- Check_Formal_Subprogram_Conformance --
-----------------------------------------
@@ -12963,13 +12827,10 @@ package body Sem_Ch6 is
-- Start of processing for Process_Formals
begin
- -- In order to prevent premature use of the formals in the same formal
- -- part, the Ekind is left undefined until all default expressions are
- -- analyzed. The Ekind is established in a separate loop at the end.
-
Param_Spec := First (T);
while Present (Param_Spec) loop
Formal := Defining_Identifier (Param_Spec);
+ Set_Formal_Mode (Formal, Param_Spec, Current_Scope);
Set_Never_Set_In_Source (Formal, True);
Enter_Name (Formal);
@@ -13207,7 +13068,7 @@ package body Sem_Ch6 is
-- Do the special preanalysis of the expression (see section on
-- "Handling of Default Expressions" in the spec of package Sem).
- Preanalyze_Spec_Expression (Default, Formal_Type);
+ Preanalyze_And_Resolve_Spec_Expression (Default, Formal_Type);
-- An access to constant cannot be the default for
-- an access parameter that is an access to variable.
@@ -13287,12 +13148,48 @@ package body Sem_Ch6 is
Analyze_Return_Type (Related_Nod);
end if;
- -- Now set the kind (mode) of each formal
-
Param_Spec := First (T);
while Present (Param_Spec) loop
Formal := Defining_Identifier (Param_Spec);
- Set_Formal_Mode (Formal);
+ Set_Is_Not_Self_Hidden (Formal);
+
+ -- Set Is_Known_Non_Null for access parameters since the language
+ -- guarantees that access parameters are always non-null. We also set
+ -- Can_Never_Be_Null, since there is no way to change the value.
+
+ if Nkind (Parameter_Type (Param_Spec)) = N_Access_Definition then
+
+ -- Ada 2005 (AI-231): In Ada 95, access parameters are always non-
+ -- null; In Ada 2005, only if then null_exclusion is explicit.
+
+ if Ada_Version < Ada_2005
+ or else Can_Never_Be_Null (Etype (Formal))
+ then
+ Set_Is_Known_Non_Null (Formal);
+ Set_Can_Never_Be_Null (Formal);
+ end if;
+
+ -- Ada 2005 (AI-231): Null-exclusion access subtype
+
+ elsif Is_Access_Type (Etype (Formal))
+ and then Can_Never_Be_Null (Etype (Formal))
+ then
+ Set_Is_Known_Non_Null (Formal);
+
+ -- We can also set Can_Never_Be_Null (thus preventing some junk
+ -- access checks) for the case of an IN parameter, which cannot
+ -- be changed, or for an IN OUT parameter, which can be changed
+ -- but not to a null value. But for an OUT parameter, the initial
+ -- value passed in can be null, so we can't set this flag in that
+ -- case.
+
+ if Ekind (Formal) /= E_Out_Parameter then
+ Set_Can_Never_Be_Null (Formal);
+ end if;
+ end if;
+
+ Set_Mechanism (Formal, Default_Mechanism);
+ Set_Formal_Validity (Formal);
if Ekind (Formal) = E_In_Parameter then
Default := Expression (Param_Spec);
@@ -13563,23 +13460,23 @@ package body Sem_Ch6 is
-- Set_Formal_Mode --
---------------------
- procedure Set_Formal_Mode (Formal_Id : Entity_Id) is
- Spec : constant Node_Id := Parent (Formal_Id);
- Id : constant Entity_Id := Scope (Formal_Id);
-
+ procedure Set_Formal_Mode
+ (Formal_Id : Entity_Id;
+ Spec : N_Parameter_Specification_Id;
+ Subp_Id : Entity_Id) is
begin
-- Note: we set Is_Known_Valid for IN parameters and IN OUT parameters
-- since we ensure that corresponding actuals are always valid at the
-- point of the call.
if Out_Present (Spec) then
- if Is_Entry (Id)
- or else Is_Subprogram_Or_Generic_Subprogram (Id)
+ if Is_Entry (Subp_Id)
+ or else Is_Subprogram_Or_Generic_Subprogram (Subp_Id)
then
- Set_Has_Out_Or_In_Out_Parameter (Id, True);
+ Set_Has_Out_Or_In_Out_Parameter (Subp_Id, True);
end if;
- if Ekind (Id) in E_Function | E_Generic_Function then
+ if Ekind (Subp_Id) in E_Function | E_Generic_Function then
-- [IN] OUT parameters allowed for functions in Ada 2012
@@ -13616,45 +13513,6 @@ package body Sem_Ch6 is
else
Mutate_Ekind (Formal_Id, E_In_Parameter);
end if;
-
- Set_Is_Not_Self_Hidden (Formal_Id);
-
- -- Set Is_Known_Non_Null for access parameters since the language
- -- guarantees that access parameters are always non-null. We also set
- -- Can_Never_Be_Null, since there is no way to change the value.
-
- if Nkind (Parameter_Type (Spec)) = N_Access_Definition then
-
- -- Ada 2005 (AI-231): In Ada 95, access parameters are always non-
- -- null; In Ada 2005, only if then null_exclusion is explicit.
-
- if Ada_Version < Ada_2005
- or else Can_Never_Be_Null (Etype (Formal_Id))
- then
- Set_Is_Known_Non_Null (Formal_Id);
- Set_Can_Never_Be_Null (Formal_Id);
- end if;
-
- -- Ada 2005 (AI-231): Null-exclusion access subtype
-
- elsif Is_Access_Type (Etype (Formal_Id))
- and then Can_Never_Be_Null (Etype (Formal_Id))
- then
- Set_Is_Known_Non_Null (Formal_Id);
-
- -- We can also set Can_Never_Be_Null (thus preventing some junk
- -- access checks) for the case of an IN parameter, which cannot
- -- be changed, or for an IN OUT parameter, which can be changed but
- -- not to a null value. But for an OUT parameter, the initial value
- -- passed in can be null, so we can't set this flag in that case.
-
- if Ekind (Formal_Id) /= E_Out_Parameter then
- Set_Can_Never_Be_Null (Formal_Id);
- end if;
- end if;
-
- Set_Mechanism (Formal_Id, Default_Mechanism);
- Set_Formal_Validity (Formal_Id);
end Set_Formal_Mode;
-------------------------
diff --git a/gcc/ada/sem_ch6.ads b/gcc/ada/sem_ch6.ads
index bd4b730..7ebbcaa 100644
--- a/gcc/ada/sem_ch6.ads
+++ b/gcc/ada/sem_ch6.ads
@@ -64,18 +64,8 @@ package Sem_Ch6 is
-- respective counterparts.
procedure Check_Delayed_Subprogram (Designator : Entity_Id);
- -- Designator can be a E_Subprogram_Type, E_Procedure or E_Function. If a
- -- type in its profile depends on a private type without a full
- -- declaration, indicate that the subprogram or type is delayed.
-
- procedure Check_Discriminant_Conformance
- (N : Node_Id;
- Prev : Entity_Id;
- Prev_Loc : Node_Id);
- -- Check that the discriminants of a full type N fully conform to the
- -- discriminants of the corresponding partial view Prev. Prev_Loc indicates
- -- the source location of the partial view, which may be different than
- -- Prev in the case of private types.
+ -- Designator can be a E_Subprogram_Type, E_Procedure or E_Function. Set
+ -- Has_Delayed_Freeze on Designator if its freezing needs to be delayed.
procedure Check_Formal_Subprogram_Conformance
(New_Id : Entity_Id;
diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb
index 0a9ef41..db892d0 100644
--- a/gcc/ada/sem_ch8.adb
+++ b/gcc/ada/sem_ch8.adb
@@ -77,6 +77,7 @@ with Style;
with Table;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
+with Uname; use Uname;
with Warnsw; use Warnsw;
package body Sem_Ch8 is
@@ -4300,6 +4301,44 @@ package body Sem_Ch8 is
begin
pragma Assert (Nkind (Clause) = N_Use_Package_Clause);
+
+ -- Perform "use implies with" expansion (when extensions are enabled)
+ -- by inserting an extra with clause since redundant clauses don't
+ -- really matter.
+
+ if All_Extensions_Allowed and then Is_In_Context_Clause (Clause) then
+ declare
+ Unum : Unit_Number_Type;
+ With_Clause : constant Node_Id :=
+ Make_With_Clause (Sloc (Clause),
+ Name => New_Copy_Tree (Pack));
+ begin
+ -- Attempt to load the unit mentioned in the use clause
+
+ Unum := Load_Unit
+ (Load_Name => Get_Unit_Name (With_Clause),
+ Required => False,
+ Subunit => False,
+ Error_Node => Clause,
+ With_Node => With_Clause);
+
+ -- Either we can't file the unit or the use clause is a
+ -- reference to a nested package - in that case just handle
+ -- the use clause normally.
+
+ if Unum /= No_Unit then
+
+ Set_Library_Unit (With_Clause, Cunit (Unum));
+ Set_Is_Implicit_With (With_Clause);
+
+ Analyze (With_Clause);
+ Expand_With_Clause
+ (With_Clause, Name (With_Clause),
+ Enclosing_Comp_Unit_Node (Clause));
+ end if;
+ end;
+ end if;
+
Analyze (Pack);
-- Verify that the package standard is not directly named in a
@@ -8365,7 +8404,8 @@ package body Sem_Ch8 is
if Is_Overloaded (P) then
- -- The prefix must resolve to a unique enclosing construct
+ -- The prefix must resolve to a unique enclosing construct, per
+ -- the last sentence of RM 4.1.3 (13).
declare
Found : Boolean := False;
@@ -8379,6 +8419,7 @@ package body Sem_Ch8 is
if Found then
Error_Msg_N (
"prefix must be unique enclosing scope", N);
+ Change_Selected_Component_To_Expanded_Name (N);
Set_Entity (N, Any_Id);
Set_Etype (N, Any_Type);
return;
@@ -9504,6 +9545,11 @@ package body Sem_Ch8 is
and then Present (Scope (Entity (E)))
then
Mark_Use_Package (Scope (Entity (E)));
+
+ -- Additionally mark the types of the formals and the return
+ -- types as used when dealing with an overloaded operator.
+
+ Mark_Parameters (Entity (E));
end if;
Curr := Current_Use_Clause (Base);
@@ -9878,28 +9924,8 @@ package body Sem_Ch8 is
procedure Premature_Usage (N : Node_Id) is
Kind : constant Node_Kind := Nkind (Parent (Entity (N)));
- E : Entity_Id := Entity (N);
begin
- -- Within an instance, the analysis of the actual for a formal object
- -- does not see the name of the object itself. This is significant only
- -- if the object is an aggregate, where its analysis does not do any
- -- name resolution on component associations. (see 4717-008). In such a
- -- case, look for the visible homonym on the chain.
-
- if In_Instance and then Present (Homonym (E)) then
- E := Homonym (E);
- while Present (E) and then not In_Open_Scopes (Scope (E)) loop
- E := Homonym (E);
- end loop;
-
- if Present (E) then
- Set_Entity (N, E);
- Set_Etype (N, Etype (E));
- return;
- end if;
- end if;
-
case Kind is
when N_Component_Declaration =>
Error_Msg_N
diff --git a/gcc/ada/sem_ch8.ads b/gcc/ada/sem_ch8.ads
index 70fbcf2..f915f2c 100644
--- a/gcc/ada/sem_ch8.ads
+++ b/gcc/ada/sem_ch8.ads
@@ -100,11 +100,6 @@ package Sem_Ch8 is
-- entries in the current scope, and that will give all homonyms that are
-- declared before the point of call in the current scope. This is useful
-- for example in the processing for pragma Inline.
- --
- -- Flag Errors_OK should be set when error diagnostics are desired. Flag
- -- Marker_OK should be set when a N_Variable_Reference_Marker needs to be
- -- generated for a SPARK object in order to detect elaboration issues. Flag
- -- Reference_OK should be set when N must generate a cross reference.
procedure Find_Selected_Component (N : Node_Id);
-- Resolve various cases of selected components, recognize expanded names
diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb
index 71394aa..e32612e 100644
--- a/gcc/ada/sem_ch9.adb
+++ b/gcc/ada/sem_ch9.adb
@@ -28,11 +28,10 @@ with Aspects; use Aspects;
with Atree; use Atree;
with Checks; use Checks;
with Contracts; use Contracts;
-with Debug; use Debug;
-with Diagnostics.Constructors; use Diagnostics.Constructors;
with Einfo; use Einfo;
with Einfo.Entities; use Einfo.Entities;
with Einfo.Utils; use Einfo.Utils;
+with Errid; use Errid;
with Errout; use Errout;
with Exp_Ch9; use Exp_Ch9;
with Elists; use Elists;
@@ -753,8 +752,6 @@ package body Sem_Ch9 is
T_Name : Node_Id;
begin
- Tasking_Used := True;
-
T_Name := First (Names (N));
while Present (T_Name) loop
Analyze (T_Name);
@@ -790,8 +787,6 @@ package body Sem_Ch9 is
procedure Analyze_Accept_Alternative (N : Node_Id) is
begin
- Tasking_Used := True;
-
if Present (Pragmas_Before (N)) then
Analyze_List (Pragmas_Before (N));
end if;
@@ -823,8 +818,6 @@ package body Sem_Ch9 is
Task_Nam : Entity_Id := Empty; -- initialize to prevent warning
begin
- Tasking_Used := True;
-
-- Entry name is initialized to Any_Id. It should get reset to the
-- matching entry entity. An error is signalled if it is not reset.
@@ -1064,7 +1057,6 @@ package body Sem_Ch9 is
Trigger : Node_Id;
begin
- Tasking_Used := True;
Check_Restriction (Max_Asynchronous_Select_Nesting, N);
Check_Restriction (No_Select_Statements, N);
@@ -1109,7 +1101,6 @@ package body Sem_Ch9 is
Is_Disp_Select : Boolean := False;
begin
- Tasking_Used := True;
Check_Restriction (No_Select_Statements, N);
-- Ada 2005 (AI-345): The trigger may be a dispatching call
@@ -1154,7 +1145,6 @@ package body Sem_Ch9 is
Typ : Entity_Id;
begin
- Tasking_Used := True;
Check_Restriction (No_Delay, N);
if Present (Pragmas_Before (N)) then
@@ -1206,7 +1196,6 @@ package body Sem_Ch9 is
E : constant Node_Id := Expression (N);
begin
- Tasking_Used := True;
Check_Restriction (No_Relative_Delay, N);
Check_Restriction (No_Delay, N);
Check_Potentially_Blocking_Operation (N);
@@ -1231,7 +1220,6 @@ package body Sem_Ch9 is
Typ : Entity_Id;
begin
- Tasking_Used := True;
Check_Restriction (No_Delay, N);
Check_Potentially_Blocking_Operation (N);
Analyze_And_Resolve (E);
@@ -1266,8 +1254,6 @@ package body Sem_Ch9 is
Freeze_Previous_Contracts (N);
- Tasking_Used := True;
-
-- Entry_Name is initialized to Any_Id. It should get reset to the
-- matching entry entity. An error is signalled if it is not reset.
@@ -1518,8 +1504,6 @@ package body Sem_Ch9 is
Formals : constant List_Id := Parameter_Specifications (N);
begin
- Tasking_Used := True;
-
if Present (Index) then
Analyze (Index);
@@ -1545,8 +1529,6 @@ package body Sem_Ch9 is
Call : constant Node_Id := Entry_Call_Statement (N);
begin
- Tasking_Used := True;
-
if Present (Pragmas_Before (N)) then
Analyze_List (Pragmas_Before (N));
end if;
@@ -1589,8 +1571,6 @@ package body Sem_Ch9 is
begin
Generate_Definition (Def_Id);
- Tasking_Used := True;
-
-- Case of no discrete subtype definition
if No (D_Sdef) then
@@ -1751,7 +1731,6 @@ package body Sem_Ch9 is
Loop_Id : constant Entity_Id := Make_Temporary (Sloc (N), 'L');
begin
- Tasking_Used := True;
Analyze (Def);
-- There is no elaboration of the entry index specification. Therefore,
@@ -1848,7 +1827,6 @@ package body Sem_Ch9 is
Freeze_Previous_Contracts (N);
- Tasking_Used := True;
Mutate_Ekind (Body_Id, E_Protected_Body);
Set_Etype (Body_Id, Standard_Void_Type);
Spec_Id := Find_Concurrent_Spec (Body_Id);
@@ -1991,7 +1969,6 @@ package body Sem_Ch9 is
-- Start of processing for Analyze_Protected_Definition
begin
- Tasking_Used := True;
Analyze_Declarations (Visible_Declarations (N));
if not Is_Empty_List (Private_Declarations (N)) then
@@ -2047,7 +2024,6 @@ package body Sem_Ch9 is
return;
end if;
- Tasking_Used := True;
Check_Restriction (No_Protected_Types, N);
T := Find_Type_Name (N);
@@ -2223,18 +2199,21 @@ package body Sem_Ch9 is
-- Pragma case
else
- if Debug_Flag_Underscore_DD then
- Record_Pragma_No_Effect_With_Lock_Free_Warning
- (Pragma_Node => Prio_Item,
- Pragma_Name => Pragma_Name (Prio_Item),
- Lock_Free_Node => Id,
- Lock_Free_Range => Parent (Id));
- else
- Error_Msg_Name_1 := Pragma_Name (Prio_Item);
- Error_Msg_NE
- ("pragma% for & has no effect when Lock_Free given??",
- Prio_Item, Id);
- end if;
+ Error_Msg_Name_1 := Pragma_Name (Prio_Item);
+ Error_Msg_NE
+ (Msg =>
+ "pragma% for & has no effect when Lock_Free given??",
+ N => Prio_Item,
+ E => Id,
+ Error_Code => GNAT0003,
+ Label => "No effect",
+ Spans =>
+ (1 =>
+ Labeled_Span
+ (Span => To_Full_Span (Parent (Id)),
+ Label => "Lock_Free in effect here",
+ Is_Primary => False,
+ Is_Region => True)));
end if;
end if;
end;
@@ -2422,7 +2401,6 @@ package body Sem_Ch9 is
Modes => True,
Warnings => True);
- Tasking_Used := True;
Check_Restriction (No_Requeue_Statements, N);
Check_Unreachable_Code (N);
@@ -2754,7 +2732,6 @@ package body Sem_Ch9 is
Alt_Count : Uint := Uint_0;
begin
- Tasking_Used := True;
Check_Restriction (No_Select_Statements, N);
-- Loop to analyze alternatives
@@ -2871,7 +2848,6 @@ package body Sem_Ch9 is
begin
Generate_Definition (Obj_Id);
- Tasking_Used := True;
-- A single protected declaration is transformed into a pair of an
-- anonymous protected type and an object of that type. Generate:
@@ -2959,7 +2935,6 @@ package body Sem_Ch9 is
begin
Generate_Definition (Obj_Id);
- Tasking_Used := True;
-- A single task declaration is transformed into a pair of an anonymous
-- task type and an object of that type. Generate:
@@ -3074,7 +3049,6 @@ package body Sem_Ch9 is
Freeze_Previous_Contracts (N);
- Tasking_Used := True;
Set_Scope (Body_Id, Current_Scope);
Mutate_Ekind (Body_Id, E_Task_Body);
Set_Etype (Body_Id, Standard_Void_Type);
@@ -3219,8 +3193,6 @@ package body Sem_Ch9 is
L : Entity_Id;
begin
- Tasking_Used := True;
-
if Present (Visible_Declarations (N)) then
Analyze_Declarations (Visible_Declarations (N));
end if;
@@ -3265,8 +3237,6 @@ package body Sem_Ch9 is
-- Proceed ahead with analysis of task type declaration
- Tasking_Used := True;
-
-- The sequential partition elaboration policy is supported only in the
-- restricted profile.
@@ -3448,8 +3418,6 @@ package body Sem_Ch9 is
procedure Analyze_Terminate_Alternative (N : Node_Id) is
begin
- Tasking_Used := True;
-
if Present (Pragmas_Before (N)) then
Analyze_List (Pragmas_Before (N));
end if;
@@ -3469,7 +3437,6 @@ package body Sem_Ch9 is
Is_Disp_Select : Boolean := False;
begin
- Tasking_Used := True;
Check_Restriction (No_Select_Statements, N);
-- Ada 2005 (AI-345): The trigger may be a dispatching call
@@ -3504,8 +3471,6 @@ package body Sem_Ch9 is
Trigger : constant Node_Id := Triggering_Statement (N);
begin
- Tasking_Used := True;
-
if Present (Pragmas_Before (N)) then
Analyze_List (Pragmas_Before (N));
end if;
diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb
index 4881d6f..d133676 100644
--- a/gcc/ada/sem_disp.adb
+++ b/gcc/ada/sem_disp.adb
@@ -80,7 +80,7 @@ package body Sem_Disp is
-- parameter); otherwise returns empty.
function Find_Hidden_Overridden_Primitive (S : Entity_Id) return Entity_Id;
- -- [Ada 2012:AI-0125] Find an inherited hidden primitive of the dispatching
+ -- [AI05-0125] Find an inherited hidden primitive of the dispatching
-- type of S that has the same name of S, a type-conformant profile, an
-- original corresponding operation O that is a primitive of a visible
-- ancestor of the dispatching type of S and O is visible at the point of
@@ -91,7 +91,8 @@ package body Sem_Disp is
-- This routine does not search for non-hidden primitives since they are
-- covered by the normal Ada 2005 rules. Its name was motivated by an
-- intermediate version of AI05-0125 where this term was proposed to
- -- name these entities in the RM.
+ -- name these entities in the RM. FWIW, note that AI05-0125 was
+ -- not approved; it was voted "No Action".
function Is_Inherited_Public_Operation (Op : Entity_Id) return Boolean;
-- Check whether a primitive operation is inherited from an operation
@@ -1710,9 +1711,8 @@ package body Sem_Disp is
Ovr_Subp := Old_Subp;
- -- [Ada 2012:AI-0125]: Search for inherited hidden primitive that may be
- -- overridden by Subp. This only applies to source subprograms, and
- -- their declaration must carry an explicit overriding indicator.
+ -- Search for inherited hidden primitive that may be
+ -- overridden by Subp. This only applies to source subprograms.
if No (Ovr_Subp)
and then Ada_Version >= Ada_2012
@@ -1721,16 +1721,6 @@ package body Sem_Disp is
Nkind (Unit_Declaration_Node (Subp)) = N_Subprogram_Declaration
then
Ovr_Subp := Find_Hidden_Overridden_Primitive (Subp);
-
- -- Warn if the proper overriding indicator has not been supplied.
-
- if Present (Ovr_Subp)
- and then
- not Must_Override (Specification (Unit_Declaration_Node (Subp)))
- and then not In_Instance
- then
- Error_Msg_NE ("missing overriding indicator for&??", Subp, Subp);
- end if;
end if;
-- Now it should be a correct primitive operation, put it in the list
diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb
index b7dfe01..2d64d84 100644
--- a/gcc/ada/sem_eval.adb
+++ b/gcc/ada/sem_eval.adb
@@ -144,7 +144,7 @@ package body Sem_Eval is
Checking_For_Potentially_Static_Expression : Boolean := False;
-- Global flag that is set True during Analyze_Static_Expression_Function
-- in order to verify that the result expression of a static expression
- -- function is a potentially static function (see RM2022 6.8(5.3)).
+ -- function is a potentially static function (see RM 2022 6.8(5.3)).
-----------------------
-- Local Subprograms --
@@ -574,13 +574,11 @@ package body Sem_Eval is
Rewrite (N, New_Copy (N));
- if not Is_Floating_Point_Type (T) then
- Set_Realval
- (N, Corresponding_Integer_Value (N) * Small_Value (T));
-
- elsif not UR_Is_Zero (Realval (N)) then
+ if Is_Floating_Point_Type (T) then
Set_Realval (N, Machine_Number (Base_Type (T), Realval (N), N));
Set_Is_Machine_Number (N);
+ else
+ Set_Realval (N, Corresponding_Integer_Value (N) * Small_Value (T));
end if;
end if;
@@ -4989,27 +4987,41 @@ package body Sem_Eval is
end if;
end Check_Elab_Call;
- Modulus, Val : Uint;
-
begin
- if Compile_Time_Known_Value (Left)
- and then Compile_Time_Known_Value (Right)
+ if not (Compile_Time_Known_Value (Left)
+ and then Compile_Time_Known_Value (Right))
then
- pragma Assert (not Non_Binary_Modulus (Typ));
+ return;
+ end if;
+
+ pragma Assert (not Non_Binary_Modulus (Typ));
+ pragma Assert (Expr_Value (Right) >= Uint_0); -- Amount is always Natural
+
+ -- Shift by zero bits is a no-op
+
+ if Expr_Value (Right) = Uint_0 then
+ Fold_Uint (N, Expr_Value (Left), Static => Static);
+ return;
+ end if;
+ declare
+ Modulus : constant Uint :=
+ (if Is_Modular_Integer_Type (Typ) then Einfo.Entities.Modulus (Typ)
+ else Uint_2 ** RM_Size (Typ));
+ Amount : constant Uint := UI_Min (Expr_Value (Right), RM_Size (Typ));
+ -- Shift by an Amount greater than the size is all-zeros or all-ones.
+ -- Without this "min", we could use huge amounts of time and memory
+ -- below (e.g. 2**Amount, if Amount were a billion).
+
+ Val : Uint;
+ begin
if Op = N_Op_Shift_Left then
Check_Elab_Call;
- if Is_Modular_Integer_Type (Typ) then
- Modulus := Einfo.Entities.Modulus (Typ);
- else
- Modulus := Uint_2 ** RM_Size (Typ);
- end if;
-
-- Fold Shift_Left (X, Y) by computing
-- (X * 2**Y) rem modulus [- Modulus]
- Val := (Expr_Value (Left) * (Uint_2 ** Expr_Value (Right)))
+ Val := (Expr_Value (Left) * (Uint_2 ** Amount))
rem Modulus;
if Is_Modular_Integer_Type (Typ)
@@ -5023,49 +5035,32 @@ package body Sem_Eval is
elsif Op = N_Op_Shift_Right then
Check_Elab_Call;
- -- X >> 0 is a no-op
+ -- 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.
- 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.Entities.Modulus (Typ);
+ declare
+ M : Unat;
+ begin
+ if Expr_Value (Left) >= Uint_0 then
+ M := Uint_0;
else
- Modulus := Uint_2 ** RM_Size (Typ);
+ M := Modulus;
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.
-
- declare
- M : Unat;
- begin
- if Expr_Value (Left) >= Uint_0 then
- M := Uint_0;
- else
- M := Modulus;
- end if;
+ Fold_Uint
+ (N,
+ (Expr_Value (Left) + M) / (Uint_2 ** Amount),
+ Static => Static);
+ end;
- Fold_Uint
- (N,
- (Expr_Value (Left) + M) / (Uint_2 ** Expr_Value (Right)),
- Static => Static);
- end;
- end if;
elsif Op = N_Op_Shift_Right_Arithmetic then
Check_Elab_Call;
declare
- Two_Y : constant Uint := Uint_2 ** Expr_Value (Right);
+ Two_Y : constant Uint := Uint_2 ** Amount;
begin
- if Is_Modular_Integer_Type (Typ) then
- Modulus := Einfo.Entities.Modulus (Typ);
- else
- Modulus := Uint_2 ** RM_Size (Typ);
- end if;
-
-- X / 2**Y if X if positive or a small enough modular integer
if (Is_Modular_Integer_Type (Typ)
@@ -5096,7 +5091,7 @@ package body Sem_Eval is
(N,
(Expr_Value (Left)) / Two_Y
+ (Two_Y - Uint_1)
- * Uint_2 ** (RM_Size (Typ) - Expr_Value (Right)),
+ * Uint_2 ** (RM_Size (Typ) - Amount),
Static => Static);
-- Negative signed integer, compute via multiple/divide the
@@ -5108,13 +5103,15 @@ package body Sem_Eval is
(N,
(Modulus + Expr_Value (Left)) / Two_Y
+ (Two_Y - Uint_1)
- * Uint_2 ** (RM_Size (Typ) - Expr_Value (Right))
+ * Uint_2 ** (RM_Size (Typ) - Amount)
- Modulus,
Static => Static);
end if;
end;
+ else
+ raise Program_Error;
end if;
- end if;
+ end;
end Fold_Shift;
--------------
@@ -5290,9 +5287,16 @@ package body Sem_Eval is
begin
if Nkind (N) in N_String_Literal | N_Character_Literal then
return N;
- else
- pragma Assert (Is_Entity_Name (N));
+ elsif Is_Entity_Name (N) then
return Get_String_Val (Constant_Value (Entity (N)));
+ elsif Nkind (N) = N_Integer_Literal then
+ pragma Assert (Serious_Errors_Detected /= 0);
+ return
+ Make_Character_Literal (Sloc (N),
+ Chars => Error_Name,
+ Char_Literal_Value => Intval (N));
+ else
+ raise Program_Error;
end if;
end Get_String_Val;
diff --git a/gcc/ada/sem_eval.ads b/gcc/ada/sem_eval.ads
index 138278f..b6f44ef 100644
--- a/gcc/ada/sem_eval.ads
+++ b/gcc/ada/sem_eval.ads
@@ -301,34 +301,34 @@ package Sem_Eval is
-- is static or its value is known at compile time. This version is used
-- for string types and returns the corresponding N_String_Literal node.
- procedure Eval_Actual (N : Node_Id);
- procedure Eval_Allocator (N : Node_Id);
- procedure Eval_Arithmetic_Op (N : Node_Id);
- procedure Eval_Call (N : Node_Id);
- procedure Eval_Case_Expression (N : Node_Id);
- procedure Eval_Character_Literal (N : Node_Id);
- procedure Eval_Concatenation (N : Node_Id);
- procedure Eval_Entity_Name (N : Node_Id);
- procedure Eval_If_Expression (N : Node_Id);
- procedure Eval_Indexed_Component (N : Node_Id);
- procedure Eval_Integer_Literal (N : Node_Id);
- procedure Eval_Logical_Op (N : Node_Id);
- procedure Eval_Membership_Op (N : Node_Id);
- procedure Eval_Named_Integer (N : Node_Id);
- procedure Eval_Named_Real (N : Node_Id);
- procedure Eval_Op_Expon (N : Node_Id);
- 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);
- procedure Eval_String_Literal (N : Node_Id);
- procedure Eval_Qualified_Expression (N : Node_Id);
- procedure Eval_Type_Conversion (N : Node_Id);
- procedure Eval_Unary_Op (N : Node_Id);
- procedure Eval_Unchecked_Conversion (N : Node_Id);
+ procedure Eval_Actual (N : Node_Id);
+ procedure Eval_Allocator (N : Node_Id);
+ procedure Eval_Arithmetic_Op (N : Node_Id);
+ procedure Eval_Call (N : Node_Id);
+ procedure Eval_Case_Expression (N : Node_Id);
+ procedure Eval_Character_Literal (N : Node_Id);
+ procedure Eval_Concatenation (N : Node_Id);
+ procedure Eval_Entity_Name (N : Node_Id);
+ procedure Eval_If_Expression (N : Node_Id);
+ procedure Eval_Indexed_Component (N : Node_Id);
+ procedure Eval_Integer_Literal (N : Node_Id);
+ procedure Eval_Logical_Op (N : Node_Id);
+ procedure Eval_Membership_Op (N : Node_Id);
+ procedure Eval_Named_Integer (N : Node_Id);
+ procedure Eval_Named_Real (N : Node_Id);
+ procedure Eval_Op_Expon (N : Node_Id);
+ 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);
+ procedure Eval_String_Literal (N : Node_Id);
+ procedure Eval_Qualified_Expression (N : Node_Id);
+ procedure Eval_Type_Conversion (N : Node_Id);
+ procedure Eval_Unary_Op (N : Node_Id);
+ procedure Eval_Unchecked_Conversion (N : Node_Id);
procedure Flag_Non_Static_Expr (Msg : String; Expr : Node_Id);
-- This procedure is called after it has been determined that Expr is not
@@ -342,41 +342,12 @@ package Sem_Eval is
-- set of messages is all posted.
procedure Fold_Str (N : Node_Id; Val : String_Id; Static : Boolean);
- -- Rewrite N with a new N_String_Literal node as the result of the compile
- -- time evaluation of the node N. Val is the resulting string value from
- -- the folding operation. The Is_Static_Expression flag is set in the
- -- result node. The result is fully analyzed and resolved. Static indicates
- -- whether the result should be considered static or not (True = consider
- -- static). The point here is that normally all string literals are static,
- -- but if this was the result of some sequence of evaluation where values
- -- were known at compile time but not static, then the result is not
- -- static. 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_Uint (N : Node_Id; Val : Uint; Static : Boolean);
- -- Rewrite N with a (N_Integer_Literal, N_Identifier, N_Character_Literal)
- -- node as the result of the compile time evaluation of the node N. Val is
- -- the result in the integer case and is the position of the literal in the
- -- literals list for the enumeration case. Is_Static_Expression is set True
- -- in the result node. The result is fully analyzed/resolved. Static
- -- indicates whether the result should be considered static or not (True =
- -- consider static). The point here is that normally all integer literals
- -- are static, but if this was the result of some sequence of evaluation
- -- where values were known at compile time but not static, then the result
- -- is not static. 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_Ureal (N : Node_Id; Val : Ureal; Static : Boolean);
- -- Rewrite N with a new N_Real_Literal node as the result of the compile
- -- time evaluation of the node N. Val is the resulting real value from the
- -- folding operation. The Is_Static_Expression flag is set in the result
- -- node. The result is fully analyzed and result. Static indicates whether
- -- the result should be considered static or not (True = consider static).
- -- The point here is that normally all string literals are static, but if
- -- this was the result of some sequence of evaluation where values were
- -- known at compile time but not static, then the result is not static.
- -- The call has no effect if Raises_Constraint_Error (N) is True, since
- -- there is no point in folding if we have an error.
+ -- Rewrite N with a new literal node with compile-time-known value Val.
+ -- Is_Static_Expression is set to Static. This 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
diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
index 621edc7..2717c38 100644
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -216,10 +216,10 @@ package body Sem_Prag is
(Prag : Node_Id;
Spec_Id : Entity_Id);
-- Subsidiary to the analysis of pragmas Contract_Cases, Postcondition,
- -- Precondition, Refined_Post, Subprogram_Variant, and Test_Case. Emit a
- -- warning when pragma Prag is associated with subprogram Spec_Id subject
- -- to Inline_Always, assertions are enabled and inling is done in the
- -- frontend.
+ -- Precondition, Program_Exit, Refined_Post, Subprogram_Variant, and
+ -- Test_Case. Emit a warning when pragma Prag is associated with subprogram
+ -- Spec_Id subject to Inline_Always, assertions are enabled and inling is
+ -- done in the frontend.
procedure Check_State_And_Constituent_Use
(States : Elist_Id;
@@ -234,9 +234,10 @@ package body Sem_Prag is
(Contract_Id : Entity_Id;
Freeze_Id : Entity_Id);
-- Subsidiary to the analysis of pragmas Contract_Cases, Exceptional_Cases,
- -- Part_Of, Post, Pre and Subprogram_Variant. Emit a freezing-related error
- -- message where Freeze_Id is the entity of a body which caused contract
- -- freezing and Contract_Id denotes the entity of the affected contstruct.
+ -- Part_Of, Post, Pre, Program_Exit and Subprogram_Variant. Emit a
+ -- freezing-related error message where Freeze_Id is the entity of a body
+ -- which caused contract freezing and Contract_Id denotes the entity of the
+ -- affected contstruct.
procedure Duplication_Error (Prag : Node_Id; Prev : Node_Id);
-- Subsidiary to all Find_Related_xxx routines. Emit an error on pragma
@@ -474,7 +475,8 @@ package body Sem_Prag is
end if;
Errors := Serious_Errors_Detected;
- Preanalyze_Assert_Expression (Expression (Arg1), Standard_Boolean);
+ Preanalyze_And_Resolve_Assert_Expression
+ (Expression (Arg1), Standard_Boolean);
-- Emit a clarification message when the expression contains at least
-- one undefined reference, possibly due to contract freezing.
@@ -564,7 +566,8 @@ package body Sem_Prag is
if Nkind (Case_Guard) /= N_Others_Choice then
Errors := Serious_Errors_Detected;
- Preanalyze_Assert_Expression (Case_Guard, Standard_Boolean);
+ Preanalyze_And_Resolve_Assert_Expression
+ (Case_Guard, Standard_Boolean);
-- Emit a clarification message when the case guard contains
-- at least one undefined reference, possibly due to contract
@@ -579,7 +582,8 @@ package body Sem_Prag is
end if;
Errors := Serious_Errors_Detected;
- Preanalyze_Assert_Expression (Conseq, Standard_Boolean);
+ Preanalyze_And_Resolve_Assert_Expression
+ (Conseq, Standard_Boolean);
-- Emit a clarification message when the consequence contains
-- at least one undefined reference, possibly due to contract
@@ -2391,9 +2395,10 @@ package body Sem_Prag is
Errors := Serious_Errors_Detected;
- -- Preanalyze_Assert_Expression enforcing the expression type
+ -- Preanalyze_And_Resolve_Assert_Expression enforcing the expression
+ -- type.
- Preanalyze_Assert_Expression (Consequence, Any_Boolean);
+ Preanalyze_And_Resolve_Assert_Expression (Consequence, Any_Boolean);
Check_Params (Consequence);
@@ -2621,7 +2626,8 @@ package body Sem_Prag is
if Nkind (Case_Guard) /= N_Others_Choice then
Errors := Serious_Errors_Detected;
- Preanalyze_Assert_Expression (Case_Guard, Standard_Boolean);
+ Preanalyze_And_Resolve_Assert_Expression
+ (Case_Guard, Standard_Boolean);
-- Emit a clarification message when the case guard contains
-- at least one undefined reference, possibly due to contract
@@ -2636,14 +2642,16 @@ package body Sem_Prag is
end if;
-- Check the exit kind. It shall be either an exception or the
- -- identifiers Normal_Return or Any_Exception.
+ -- identifiers Normal_Return, Exception_Raised, or Program_Exit.
if Nkind (Exit_Kind) = N_Identifier then
if Chars (Exit_Kind) not in Name_Normal_Return
| Name_Exception_Raised
+ | Name_Program_Exit
then
Error_Msg_N
- ("exit kind should be Normal_Return or Exception_Raised",
+ ("exit kind should be Normal_Return, Exception_Raised, " &
+ "or Program_Exit",
Exit_Kind);
end if;
@@ -5112,10 +5120,6 @@ package body Sem_Prag is
-- Determines if the placement of the current pragma is appropriate
-- for a configuration pragma.
- function Is_In_Context_Clause return Boolean;
- -- Returns True if pragma appears within the context clause of a unit,
- -- and False for any other placement (does not generate any messages).
-
function Is_Static_String_Expression (Arg : Node_Id) return Boolean;
-- Analyzes the argument, and determines if it is a static string
-- expression, returns True if so, False if non-static or not String.
@@ -5585,7 +5589,7 @@ package body Sem_Prag is
if Present (Arg2) then
Check_Optional_Identifier (Arg2, Name_Message);
- Preanalyze_Assert_Expression
+ Preanalyze_And_Resolve_Assert_Expression
(Get_Pragma_Arg (Arg2), Standard_String);
end if;
end if;
@@ -6009,7 +6013,7 @@ package body Sem_Prag is
-- Check case of appearing within context clause
- if not Is_Unused and then Is_In_Context_Clause then
+ if not Is_Unused and then Is_In_Context_Clause (N) then
-- The arguments must all be units mentioned in a with clause in
-- the same context clause. Note that Par.Prag already checked
@@ -8083,10 +8087,26 @@ package body Sem_Prag is
-- the test below also permits use in a configuration pragma file.
function Is_Configuration_Pragma return Boolean is
+ function Is_Pragma_Node (Prg : Node_Id) return Boolean is
+ (Nkind (Prg) = N_Pragma
+ or else
+ (Present (Original_Node (Prg))
+ and then Nkind (Original_Node (Prg)) = N_Pragma));
+ -- Returns true whether the node is a pragma or was originally a
+ -- pragma.
+ --
+ -- Note that some pragmas like Assertion_Policy are rewritten as
+ -- Null_Statment nodes but we still need to make sure here that the
+ -- original node was a pragma node.
+
+ -- Local variables
+
Lis : List_Id;
Par : constant Node_Id := Parent (N);
Prg : Node_Id;
+ -- Start of processing for Is_Configuration_Pragma
+
begin
-- Don't evaluate List_Containing (N) if Parent (N) could be
-- an N_Aspect_Specification node.
@@ -8115,7 +8135,7 @@ package body Sem_Prag is
loop
if Prg = N then
return True;
- elsif Nkind (Prg) /= N_Pragma then
+ elsif not Is_Pragma_Node (Prg) then
return False;
end if;
@@ -8127,27 +8147,6 @@ package body Sem_Prag is
end if;
end Is_Configuration_Pragma;
- --------------------------
- -- Is_In_Context_Clause --
- --------------------------
-
- function Is_In_Context_Clause return Boolean is
- Plist : List_Id;
- Parent_Node : Node_Id;
-
- begin
- if Is_List_Member (N) then
- Plist := List_Containing (N);
- Parent_Node := Parent (Plist);
-
- return Present (Parent_Node)
- and then Nkind (Parent_Node) = N_Compilation_Unit
- and then Context_Items (Parent_Node) = Plist;
- end if;
-
- return False;
- end Is_In_Context_Clause;
-
---------------------------------
-- Is_Static_String_Expression --
---------------------------------
@@ -10049,7 +10048,6 @@ package body Sem_Prag is
end if;
Def_Id := Entity (Def_Id);
- Kill_Size_Check_Code (Def_Id);
if Ekind (Def_Id) /= E_Constant then
Note_Possible_Modification
(Get_Pragma_Arg (Arg1), Sure => False);
@@ -10062,7 +10060,6 @@ package body Sem_Prag is
-- purposes of legality checks and removal of ignored Ghost code.
Mark_Ghost_Pragma (N, Def_Id);
- Kill_Size_Check_Code (Def_Id);
if Ekind (Def_Id) /= E_Constant then
Note_Possible_Modification
(Get_Pragma_Arg (Arg2), Sure => False);
@@ -14065,7 +14062,7 @@ package body Sem_Prag is
-- Perform preanalysis to deal with embedded Loop_Entry
-- attributes.
- Preanalyze_Assert_Expression (Expr, Any_Boolean);
+ Preanalyze_And_Resolve_Assert_Expression (Expr, Any_Boolean);
end if;
-- Implement Assert[_And_Cut]/Assume/Loop_Invariant by generating
@@ -14696,19 +14693,18 @@ package body Sem_Prag is
D := Declaration_Node (E);
- if (Nkind (D) = N_Full_Type_Declaration and then Is_Array_Type (E))
+ if (Nkind (D) in N_Full_Type_Declaration
+ | N_Formal_Type_Declaration
+ and then Is_Array_Type (E))
or else
(Nkind (D) = N_Object_Declaration
and then Ekind (E) in E_Constant | E_Variable
and then Nkind (Object_Definition (D)) =
N_Constrained_Array_Definition)
- or else
- (Ada_Version >= Ada_2022
- and then Nkind (D) = N_Formal_Type_Declaration)
then
-- The flag is set on the base type, or on the object
- if Nkind (D) = N_Full_Type_Declaration then
+ if Is_Array_Type (E) then
E := Base_Type (E);
end if;
@@ -16166,7 +16162,8 @@ package body Sem_Prag is
-- described in "Handling of Default and Per-Object
-- Expressions" in sem.ads.
- Preanalyze_Spec_Expression (Arg, RTE (RE_CPU_Range));
+ Preanalyze_And_Resolve_Spec_Expression
+ (Arg, RTE (RE_CPU_Range));
-- See comment in Sem_Ch13 about the following restrictions
@@ -16212,7 +16209,7 @@ package body Sem_Prag is
-- The expression must be analyzed in the special manner described
-- in "Handling of Default and Per-Object Expressions" in sem.ads.
- Preanalyze_Spec_Expression (Arg, RTE (RE_Time_Span));
+ Preanalyze_And_Resolve_Spec_Expression (Arg, RTE (RE_Time_Span));
-- Only protected types allowed
@@ -16841,7 +16838,8 @@ package body Sem_Prag is
-- described in "Handling of Default and Per-Object
-- Expressions" in sem.ads.
- Preanalyze_Spec_Expression (Arg, RTE (RE_Dispatching_Domain));
+ Preanalyze_And_Resolve_Spec_Expression
+ (Arg, RTE (RE_Dispatching_Domain));
-- Check duplicate pragma before we chain the pragma in the Rep
-- Item chain of Ent.
@@ -16869,7 +16867,7 @@ package body Sem_Prag is
begin
-- Pragma must be in context items list of a compilation unit
- if not Is_In_Context_Clause then
+ if not Is_In_Context_Clause (N) then
Pragma_Misplaced;
end if;
@@ -16965,7 +16963,7 @@ package body Sem_Prag is
-- Pragma must be in context items list of a compilation unit
- if not Is_In_Context_Clause then
+ if not Is_In_Context_Clause (N) then
Pragma_Misplaced;
end if;
@@ -17457,6 +17455,7 @@ package body Sem_Prag is
--
-- EXIT_KIND ::=
-- Normal_Return
+ -- | Program_Exit
-- | Exception_Raised
-- | (Exception_Raised => exception_name)
--
@@ -19964,7 +19963,6 @@ package body Sem_Prag is
-- object to be imported.
if Ekind (Def_Id) = E_Variable then
- Kill_Size_Check_Code (Def_Id);
Note_Possible_Modification (Id, Sure => False);
-- Initialization is not allowed for imported variable
@@ -20074,7 +20072,8 @@ package body Sem_Prag is
-- described in "Handling of Default and Per-Object
-- Expressions" in sem.ads.
- Preanalyze_Spec_Expression (Arg, RTE (RE_Interrupt_Priority));
+ Preanalyze_And_Resolve_Spec_Expression
+ (Arg, RTE (RE_Interrupt_Priority));
end if;
if Nkind (P) not in N_Task_Definition | N_Protected_Definition then
@@ -20979,10 +20978,10 @@ package body Sem_Prag is
("Structural variant shall be the only variant", Variant);
end if;
- -- Preanalyze_Assert_Expression, but without enforcing any of
- -- the two acceptable types.
+ -- Preanalyze_And_Resolve_Assert_Expression, but without
+ -- enforcing any of the two acceptable types.
- Preanalyze_Assert_Expression (Expression (Variant));
+ Preanalyze_And_Resolve_Assert_Expression (Expression (Variant));
-- Expression of a discrete type is allowed. Nothing to
-- check for structural variants.
@@ -20992,7 +20991,7 @@ package body Sem_Prag is
then
null;
- -- Expression of a Big_Integer type (or its ghost variant) is
+ -- Expression of a Big_Integer type (or its SPARK variant) is
-- only allowed in Decreases clause.
elsif
@@ -21000,9 +20999,6 @@ package body Sem_Prag is
RE_Big_Integer)
or else
Is_RTE (Base_Type (Etype (Expression (Variant))),
- RO_GH_Big_Integer)
- or else
- Is_RTE (Base_Type (Etype (Expression (Variant))),
RO_SP_Big_Integer)
then
if Chars (Variant) = Name_Increases then
@@ -21374,8 +21370,8 @@ package body Sem_Prag is
-- pragma No_Component_Reordering [([Entity =>] type_LOCAL_NAME)];
when Pragma_No_Component_Reordering => No_Comp_Reordering : declare
- E : Entity_Id;
- E_Id : Node_Id;
+ Typ : Entity_Id;
+ Type_Id : Node_Id;
begin
GNAT_Pragma;
@@ -21388,19 +21384,20 @@ package body Sem_Prag is
else
Check_Optional_Identifier (Arg2, Name_Entity);
Check_Arg_Is_Local_Name (Arg1);
- E_Id := Get_Pragma_Arg (Arg1);
+ Type_Id := Get_Pragma_Arg (Arg1);
- if Etype (E_Id) = Any_Type then
+ Find_Type (Type_Id);
+ Typ := Entity (Type_Id);
+
+ if Typ = Any_Type then
return;
end if;
- E := Entity (E_Id);
-
- if not Is_Record_Type (E) then
+ if not Is_Record_Type (Typ) then
Error_Pragma_Arg ("pragma% requires record type", Arg1);
end if;
- Set_No_Reordering (Base_Type (E));
+ Set_No_Reordering (Base_Type (Typ));
end if;
end No_Comp_Reordering;
@@ -23410,7 +23407,8 @@ package body Sem_Prag is
-- described in "Handling of Default and Per-Object
-- Expressions" in sem.ads.
- Preanalyze_Spec_Expression (Arg, RTE (RE_Any_Priority));
+ Preanalyze_And_Resolve_Spec_Expression
+ (Arg, RTE (RE_Any_Priority));
if not Is_OK_Static_Expression (Arg) then
Check_Restriction (Static_Priorities, Arg);
@@ -23615,6 +23613,132 @@ package body Sem_Prag is
end if;
end;
+ ------------------
+ -- Program_Exit --
+ ------------------
+
+ -- pragma Program_Exit (Boolean_EXPRESSION);
+
+ -- Characteristics:
+
+ -- * Analysis - The annotation undergoes initial checks to verify
+ -- the legal placement and context. Secondary checks preanalyze the
+ -- expression in:
+
+ -- Analyze_Program_Exit_In_Decl_Part
+
+ -- * Expansion - The annotation is expanded during the expansion of
+ -- the related subprogram [body] contract as performed in:
+
+ -- Expand_Subprogram_Contract
+
+ -- * Template - The annotation utilizes the generic template of the
+ -- related subprogram [body] when it is:
+
+ -- aspect on subprogram declaration
+ -- aspect on stand-alone subprogram body
+ -- pragma on stand-alone subprogram body
+
+ -- The annotation must prepare its own template when it is:
+
+ -- pragma on subprogram declaration
+
+ -- * Globals - Capture of global references must occur after full
+ -- analysis.
+
+ -- * Instance - The annotation is instantiated automatically when
+ -- the related generic subprogram [body] is instantiated except for
+ -- the "pragma on subprogram declaration" case. In that scenario
+ -- the annotation must instantiate itself.
+
+ when Pragma_Program_Exit => Program_Exit : declare
+ Spec_Id : Entity_Id;
+ Subp_Decl : Node_Id;
+ Subp_Spec : Node_Id;
+
+ begin
+ GNAT_Pragma;
+ Check_No_Identifiers;
+ Check_At_Most_N_Arguments (1);
+
+ -- Ensure the proper placement of the pragma. Program_Exit must be
+ -- associated with a subprogram declaration or a body that acts as
+ -- a spec.
+
+ Subp_Decl :=
+ Find_Related_Declaration_Or_Body (N, Do_Checks => True);
+
+ -- Generic subprogram
+
+ if Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
+ null;
+
+ -- Body acts as spec
+
+ elsif Nkind (Subp_Decl) = N_Subprogram_Body
+ and then No (Corresponding_Spec (Subp_Decl))
+ then
+ null;
+
+ -- Body stub acts as spec
+
+ elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
+ and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
+ then
+ null;
+
+ -- Subprogram
+
+ elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
+ Subp_Spec := Specification (Subp_Decl);
+
+ -- Pragma Program_Exit is forbidden on null procedures, as this
+ -- may lead to potential ambiguities in behavior when interface
+ -- null procedures are involved. Also, it just wouldn't make
+ -- sense, because null procedure always exits.
+
+ if Nkind (Subp_Spec) = N_Procedure_Specification
+ and then Null_Present (Subp_Spec)
+ then
+ Error_Msg_N (Fix_Error
+ ("pragma % cannot apply to null procedure"), N);
+ return;
+ end if;
+
+ else
+ Pragma_Misplaced;
+ end if;
+
+ Spec_Id := Unique_Defining_Entity (Subp_Decl);
+
+ -- A pragma that applies to a Ghost entity becomes Ghost for the
+ -- purposes of legality checks and removal of ignored Ghost code.
+
+ Mark_Ghost_Pragma (N, Spec_Id);
+
+ -- Chain the pragma on the contract for further processing by
+ -- Analyze_Program_Exit.
+
+ Add_Contract_Item (N, Defining_Entity (Subp_Decl));
+
+ -- Fully analyze the pragma when it appears inside a subprogram
+ -- body because it cannot benefit from forward references.
+
+ if Nkind (Subp_Decl) in N_Subprogram_Body
+ | N_Subprogram_Body_Stub
+ then
+ -- The legality checks of pragma Program_Exit are affected by
+ -- the SPARK mode in effect and the volatility of the context.
+ -- Analyze all pragmas in a specific order.
+
+ Analyze_If_Present (Pragma_SPARK_Mode);
+ Analyze_If_Present (Pragma_Volatile_Function);
+ Analyze_If_Present (Pragma_Global);
+ Analyze_If_Present (Pragma_Depends);
+ Analyze_Program_Exit_In_Decl_Part (N);
+ end if;
+ end Program_Exit;
+
----------------------
-- Profile_Warnings --
----------------------
@@ -23982,7 +24106,7 @@ package body Sem_Prag is
Analyze_If_Present (Pragma_Side_Effects);
-- A function with side effects shall not have a Pure_Function
- -- aspect or pragma (SPARK RM 6.1.11(5)).
+ -- aspect or pragma (SPARK RM 6.1.12(5)).
if Is_Function_With_Side_Effects (E) then
Error_Pragma
@@ -24397,7 +24521,7 @@ package body Sem_Prag is
-- The expression must be analyzed in the special manner described
-- in "Handling of Default and Per-Object Expressions" in sem.ads.
- Preanalyze_Spec_Expression (Arg, RTE (RE_Time_Span));
+ Preanalyze_And_Resolve_Spec_Expression (Arg, RTE (RE_Time_Span));
-- Subprogram case
@@ -24657,7 +24781,7 @@ package body Sem_Prag is
-- The expression must be analyzed in the special manner
-- described in "Handling of Default Expressions" in sem.ads.
- Preanalyze_Spec_Expression (Arg, Any_Integer);
+ Preanalyze_And_Resolve_Spec_Expression (Arg, Any_Integer);
-- The pragma cannot appear if the No_Secondary_Stack
-- restriction is in effect.
@@ -25815,7 +25939,7 @@ package body Sem_Prag is
-- in "Handling of Default Expressions" in sem.ads.
Arg := Get_Pragma_Arg (Arg1);
- Preanalyze_Spec_Expression (Arg, Any_Integer);
+ Preanalyze_And_Resolve_Spec_Expression (Arg, Any_Integer);
if not Is_OK_Static_Expression (Arg) then
Check_Restriction (Static_Storage_Size, Arg);
@@ -26845,7 +26969,7 @@ package body Sem_Prag is
Opt.Time_Slice_Set := True;
Val := Expr_Value_R (Get_Pragma_Arg (Arg1));
- if Val <= Ureal_0 then
+ if not UR_Is_Positive (Val) then
Opt.Time_Slice_Value := 0;
elsif Val > UR_From_Uint (UI_From_Int (1000)) then
@@ -28241,7 +28365,7 @@ package body Sem_Prag is
end if;
Errors := Serious_Errors_Detected;
- Preanalyze_Assert_Expression (Expr, Standard_Boolean);
+ Preanalyze_And_Resolve_Assert_Expression (Expr, Standard_Boolean);
-- Emit a clarification message when the expression contains at least
-- one undefined reference, possibly due to contract freezing.
@@ -28296,6 +28420,153 @@ package body Sem_Prag is
Restore_Ghost_Region (Saved_GM, Saved_IGR);
end Analyze_Pre_Post_Condition_In_Decl_Part;
+ ---------------------------------------
+ -- Analyze_Program_Exit_In_Decl_Part --
+ ---------------------------------------
+
+ -- WARNING: This routine manages Ghost regions. Return statements must be
+ -- replaced by gotos which jump to the end of the routine and restore the
+ -- Ghost mode.
+
+ procedure Analyze_Program_Exit_In_Decl_Part
+ (N : Node_Id;
+ Freeze_Id : Entity_Id := Empty)
+ is
+ Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
+ Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
+ Arg1 : constant Node_Id :=
+ First (Pragma_Argument_Associations (N));
+
+ Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
+ Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
+ -- Save the Ghost-related attributes to restore on exit
+
+ Errors : Nat;
+ Restore_Scope : Boolean := False;
+ Unused : Boolean;
+
+ Subp_Inputs, Subp_Outputs : Elist_Id := No_Elist;
+ -- Inputs and outputs of the subprogram
+
+ function Check_Reference (N : Node_Id) return Traverse_Result;
+ -- Check references to objects within the Program_Exit expression
+
+ ---------------------
+ -- Check_Reference --
+ ---------------------
+
+ function Check_Reference (N : Node_Id) return Traverse_Result is
+ begin
+ -- If an output of a subprogram with side effects is mentioned
+ -- in the boolean expression of its aspect Program_Exit, then it
+ -- shall either occur inside the prefix of a reference to the Old
+ -- attribute or be a stand-alone object.
+
+ if Is_Attribute_Old (N) then
+ return Skip;
+ end if;
+
+ if Is_Entity_Name (N) then
+ declare
+ E : constant Entity_Id := Entity (N);
+ begin
+ if Appears_In (Subp_Outputs, E)
+ and then Ekind (E) not in E_Constant | E_Variable
+ then
+ Error_Msg_NE
+ ("reference to subprogram output & in Program_Exit", N, E);
+ end if;
+ end;
+ end if;
+
+ return OK;
+ end Check_Reference;
+
+ procedure Check_Exit_References is new Traverse_Proc (Check_Reference);
+
+ -- Start of processing for Analyze_Pre_Post_Condition_In_Decl_Part
+
+ begin
+ -- Do not analyze the pragma multiple times
+
+ if Is_Analyzed_Pragma (N) then
+ return;
+ end if;
+
+ if Ekind (Spec_Id) in E_Function | E_Generic_Function
+ and then not Is_Function_With_Side_Effects (Spec_Id)
+ then
+ Error_Msg_N
+ ("aspect Program_Exit is only allowed " &
+ "for subprograms with side effects", N);
+ end if;
+
+ if Present (Arg1) then
+
+ -- Set the Ghost mode in effect from the pragma. Due to the delayed
+ -- analysis of the pragma, the Ghost mode at point of declaration and
+ -- point of analysis may not necessarily be the same. Use the mode in
+ -- effect at the point of declaration.
+
+ Set_Ghost_Mode (N);
+
+ -- Ensure that the subprogram and its formals are visible when
+ -- analyzing the expression of the pragma.
+
+ if not In_Open_Scopes (Spec_Id) then
+ Restore_Scope := True;
+
+ if Is_Generic_Subprogram (Spec_Id) then
+ Push_Scope (Spec_Id);
+ Install_Generic_Formals (Spec_Id);
+ else
+ Push_Scope (Spec_Id);
+ Install_Formals (Spec_Id);
+ end if;
+ end if;
+
+ Errors := Serious_Errors_Detected;
+
+ -- Preanalyze_And_Resolve_Assert_Expression enforcing the expression
+ -- type.
+
+ Preanalyze_And_Resolve_Assert_Expression
+ (Expression (Arg1), Any_Boolean);
+
+ Collect_Subprogram_Inputs_Outputs
+ (Spec_Id,
+ Synthesize => True,
+ Subp_Inputs => Subp_Inputs,
+ Subp_Outputs => Subp_Outputs,
+ Global_Seen => Unused);
+
+ Check_Exit_References (Expression (Arg1));
+
+ -- Emit a clarification message when the expression contains at least
+ -- one undefined reference, possibly due to contract freezing.
+
+ if Errors /= Serious_Errors_Detected
+ and then Present (Freeze_Id)
+ and then Has_Undefined_Reference (Expression (Arg1))
+ then
+ Contract_Freeze_Error (Spec_Id, Freeze_Id);
+ end if;
+
+ if Restore_Scope then
+ End_Scope;
+ end if;
+
+ -- Currently it is not possible to inline pre/postconditions on a
+ -- subprogram subject to pragma Inline_Always.
+
+ Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
+
+ Restore_Ghost_Region (Saved_GM, Saved_IGR);
+ end if;
+
+ Set_Is_Analyzed_Pragma (N);
+ end Analyze_Program_Exit_In_Decl_Part;
+
------------------------------------------
-- Analyze_Refined_Depends_In_Decl_Part --
------------------------------------------
@@ -30956,34 +31227,67 @@ package body Sem_Prag is
-- end Pack;
if Constit_Id = Any_Id then
- SPARK_Msg_NE ("& is undefined", Constit, Constit_Id);
+ -- A "Foo is undefined" message has already been
+ -- generated for this constituent. Emit an additional
+ -- message in the special case where the named
+ -- would-be constituent was declared too late in the
+ -- declaration list (as opposed to, for example, not
+ -- being declared at all).
+
+ -- Look for named constituent after freezing point
+ if Present (Freeze_Id) then
+ declare
+ Decl : Node_Id;
+ begin
+ Decl := Enclosing_Declaration (Freeze_Id);
- -- Emit a specialized info message when the contract of
- -- the related package body was "frozen" by another body.
- -- Note that it is not possible to precisely identify why
- -- the constituent is undefined because it is not visible
- -- when pragma Refined_State is analyzed. This message is
- -- a reasonable approximation.
+ while Present (Decl) loop
+ if Nkind (Decl) = N_Object_Declaration
+ and then Same_Name (Defining_Identifier (Decl),
+ Constit)
+ and then not Constant_Present (Decl)
+ then
+ Error_Msg_Node_1 := Constit;
+ Error_Msg_Sloc :=
+ Sloc (Defining_Identifier (Decl));
- if Present (Freeze_Id) and then not Freeze_Posted then
- Freeze_Posted := True;
+ SPARK_Msg_NE
+ ("abstract state constituent & declared"
+ & " too late #!", Constit, Constit);
- Error_Msg_Name_1 := Chars (Body_Id);
- Error_Msg_Sloc := Sloc (Freeze_Id);
- SPARK_Msg_NE
- ("body & declared # freezes the contract of %",
- N, Freeze_Id);
- SPARK_Msg_N
- ("\all constituents must be declared before body #",
- N);
+ exit;
+ end if;
+ Next (Decl);
+ end loop;
+ end;
+
+ -- Emit a specialized info message when the contract
+ -- of the related package body was "frozen" by
+ -- another body. If a "declared too late" message
+ -- is generated, this will clarify what is meant by
+ -- "too late".
+
+ if not Freeze_Posted then
+ Freeze_Posted := True;
- -- A misplaced constituent is a critical error because
- -- pragma Refined_Depends or Refined_Global depends on
- -- the proper link between a state and a constituent.
- -- Stop the compilation, as this leads to a multitude
- -- of misleading cascaded errors.
+ Error_Msg_Name_1 := Chars (Body_Id);
+ Error_Msg_Sloc := Sloc (Freeze_Id);
+ SPARK_Msg_NE
+ ("body & declared # freezes the contract of %",
+ N, Freeze_Id);
+ SPARK_Msg_N
+ ("\all constituents must be declared" &
+ " before body #", N);
- raise Unrecoverable_Error;
+ -- A misplaced constituent is a critical error
+ -- because pragma Refined_Depends or
+ -- Refined_Global depends on the proper link
+ -- between a state and a constituent. Stop the
+ -- compilation, as this leads to a multitude of
+ -- misleading cascaded errors.
+
+ raise Unrecoverable_Error;
+ end if;
end if;
-- The constituent is a valid state or object
@@ -31452,10 +31756,10 @@ package body Sem_Prag is
Errors := Serious_Errors_Detected;
- -- Preanalyze_Assert_Expression, but without enforcing any of the
- -- acceptable types.
+ -- Preanalyze_And_Resolve_Assert_Expression, but without enforcing
+ -- any of the acceptable types.
- Preanalyze_Assert_Expression (Expr);
+ Preanalyze_And_Resolve_Assert_Expression (Expr);
-- Expression of a discrete type is allowed. Nothing more to check
-- for structural variants.
@@ -31468,12 +31772,8 @@ package body Sem_Prag is
-- Expression of a Big_Integer type (or its ghost variant) is only
-- allowed in Decreases clause.
- elsif
- Is_RTE (Base_Type (Etype (Expr)), RE_Big_Integer)
- or else
- Is_RTE (Base_Type (Etype (Expr)), RO_GH_Big_Integer)
- or else
- Is_RTE (Base_Type (Etype (Expr)), RO_SP_Big_Integer)
+ elsif Is_RTE (Base_Type (Etype (Expr)), RE_Big_Integer)
+ or else Is_RTE (Base_Type (Etype (Expr)), RO_SP_Big_Integer)
then
if Chars (Direction) = Name_Increases then
Error_Msg_N
@@ -31633,7 +31933,7 @@ package body Sem_Prag is
From_Aspect => True);
if Present (Arg) then
- Preanalyze_Assert_Expression
+ Preanalyze_And_Resolve_Assert_Expression
(Expression (Arg), Standard_Boolean);
end if;
end if;
@@ -31641,7 +31941,8 @@ package body Sem_Prag is
Arg := Test_Case_Arg (N, Arg_Nam);
if Present (Arg) then
- Preanalyze_Assert_Expression (Expression (Arg), Standard_Boolean);
+ Preanalyze_And_Resolve_Assert_Expression
+ (Expression (Arg), Standard_Boolean);
end if;
end Preanalyze_Test_Case_Arg;
@@ -33640,6 +33941,7 @@ package body Sem_Prag is
Pragma_Profile => 0,
Pragma_Profile_Warnings => 0,
Pragma_Propagate_Exceptions => 0,
+ Pragma_Program_Exit => -1,
Pragma_Provide_Shift_Operators => 0,
Pragma_Psect_Object => 0,
Pragma_Pure => 0,
diff --git a/gcc/ada/sem_prag.ads b/gcc/ada/sem_prag.ads
index 7c19d85..9228a87 100644
--- a/gcc/ada/sem_prag.ads
+++ b/gcc/ada/sem_prag.ads
@@ -97,6 +97,7 @@ package Sem_Prag is
Pragma_Preelaborable_Initialization => True,
Pragma_Preelaborate => True,
Pragma_Priority => True,
+ Pragma_Program_Exit => True,
Pragma_Pure => True,
Pragma_Pure_Function => True,
Pragma_Refined_Depends => True,
@@ -156,6 +157,7 @@ package Sem_Prag is
Pragma_Pre_Class => True,
Pragma_Precondition => True,
Pragma_Predicate => True,
+ Pragma_Program_Exit => True,
Pragma_Refined_Post => True,
Pragma_Subprogram_Variant => True,
Pragma_Test_Case => True,
@@ -229,6 +231,7 @@ package Sem_Prag is
Pragma_Pre => True,
Pragma_Pre_Class => True,
Pragma_Precondition => True,
+ Pragma_Program_Exit => True,
Pragma_Pure => True,
Pragma_Pure_Function => True,
Pragma_Refined_Depends => True,
@@ -326,6 +329,13 @@ package Sem_Prag is
-- subprogram body which caused "freezing" of the related contract where
-- the pragma resides.
+ procedure Analyze_Program_Exit_In_Decl_Part
+ (N : Node_Id;
+ Freeze_Id : Entity_Id := Empty);
+ -- Perform full analysis of delayed pragma Program_Exit. Freeze_Id is the
+ -- entity of [generic] package body or [generic] subprogram body which
+ -- caused "freezing" of the related contract where the pragma resides.
+
procedure Analyze_Refined_Depends_In_Decl_Part (N : Node_Id);
-- Preform full analysis of delayed pragma Refined_Depends. This routine
-- uses Analyze_Depends_In_Decl_Part as a starting point, then performs
@@ -494,6 +504,7 @@ package Sem_Prag is
-- Pre
-- Pre_Class
-- Precondition
+ -- Program_Exit
-- Refined_Depends
-- Refined_Global
-- Refined_Post
diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index b73b947..96e8da6 100644
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -757,14 +757,6 @@ package body Sem_Res is
goto No_Danger;
end if;
- -- If the enclosing type is limited, we allocate only the
- -- default value, not the maximum, and there is no need for
- -- a warning.
-
- if Is_Limited_Type (Scope (Disc)) then
- goto No_Danger;
- end if;
-
-- Check that it is the high bound
if N /= High_Bound (PN)
@@ -811,11 +803,9 @@ package body Sem_Res is
goto No_Danger;
end if;
- -- Warn about the danger
-
- Error_Msg_N
- ("??creation of & object may raise Storage_Error!",
- Scope (Disc));
+ if Ekind (Scope (Disc)) = E_Record_Type then
+ Set_Is_Large_Unconstrained_Definite (Scope (Disc));
+ end if;
<<No_Danger>>
null;
@@ -2106,8 +2096,6 @@ package body Sem_Res is
Full_Analysis := False;
Expander_Mode_Save_And_Set (False);
- -- See also Preanalyze_And_Resolve in sem.adb for similar handling
-
-- Normally, we suppress all checks for this preanalysis. There is no
-- point in processing them now, since they will be applied properly
-- and in the proper location when the default expressions reanalyzed
@@ -2150,8 +2138,13 @@ package body Sem_Res is
Full_Analysis := False;
Expander_Mode_Save_And_Set (False);
- Analyze (N);
- Resolve (N, Etype (N), Suppress => All_Checks);
+ -- See previous version of Preanalyze_And_Resolve for similar handling
+
+ if GNATprove_Mode then
+ Analyze_And_Resolve (N);
+ else
+ Analyze_And_Resolve (N, Suppress => All_Checks);
+ end if;
Expander_Mode_Restore;
Full_Analysis := Save_Full_Analysis;
@@ -4849,6 +4842,7 @@ package body Sem_Res is
if not Is_OK_Variable_For_Out_Formal (A)
and then not Is_Init_Proc (Nam)
+ and then not Is_Expanded_Constructor_Call (N)
then
Error_Msg_NE ("actual for& must be a variable", A, F);
@@ -6101,6 +6095,8 @@ package body Sem_Res is
elsif Is_Fixed_Point_Type (It.Typ) then
if Analyzed (N) then
Error_Msg_N ("ambiguous operand in fixed operation", N);
+ elsif It.Typ = Any_Fixed then
+ Resolve (N, B_Typ);
else
Resolve (N, It.Typ);
end if;
@@ -7801,6 +7797,7 @@ package body Sem_Res is
then
Set_Entity (N, Local);
Set_Etype (N, Etype (Local));
+ Generate_Reference (Local, N);
end if;
return OK;
@@ -8150,6 +8147,7 @@ package body Sem_Res is
and then not Preanalysis_Active
and then not Is_Imported (E)
and then Nkind (Parent (E)) /= N_Object_Renaming_Declaration
+ and then not Needs_Construction (Etype (E))
then
if No_Initialization (Parent (E))
or else (Present (Full_View (E))
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 0e1505b..4e3c625 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -333,7 +333,7 @@ package body Sem_Util is
-- Add_Global_Declaration --
----------------------------
- procedure Add_Global_Declaration (N : Node_Id) is
+ procedure Add_Global_Declaration (Decl : Node_Id) is
Aux_Node : constant Node_Id := Aux_Decls_Node (Cunit (Current_Sem_Unit));
begin
@@ -341,8 +341,8 @@ package body Sem_Util is
Set_Declarations (Aux_Node, New_List);
end if;
- Append_To (Declarations (Aux_Node), N);
- Analyze (N);
+ Append_To (Declarations (Aux_Node), Decl);
+ Analyze (Decl);
end Add_Global_Declaration;
--------------------------------
@@ -2176,6 +2176,7 @@ package body Sem_Util is
Def_Id : Entity_Id;
Btyp : Entity_Id := Base_Type (Typ);
+ Predicated_Parent_Used : Boolean := False;
begin
-- The Related_Node better be here or else we won't be able to
-- attach new itypes to a node in the tree.
@@ -2190,6 +2191,25 @@ package body Sem_Util is
and then Present (Underlying_Type (Btyp))
then
Btyp := Underlying_Type (Btyp);
+
+ -- If a predicate has been specified for an unconstrained
+ -- ancestor subtype, then that ancestor subtype needs to also
+ -- be an ancestor subtype for the subtype we are building so that
+ -- we don't lose the predicate. It is somewhat ugly here to have
+ -- to replicate the precondition for Predicated_Parent.
+
+ elsif Typ in E_Array_Subtype_Id
+ | E_Record_Subtype_Id
+ | E_Record_Subtype_With_Private_Id
+ and then Present (Predicated_Parent (Typ))
+ then
+ -- Assert that the following assignment is only changing the
+ -- subtype, not the type.
+
+ pragma Assert (Base_Type (Predicated_Parent (Typ)) = Btyp);
+
+ Btyp := Predicated_Parent (Typ);
+ Predicated_Parent_Used := True;
end if;
Indic :=
@@ -2211,7 +2231,10 @@ package body Sem_Util is
Analyze (Subtyp_Decl, Suppress => All_Checks);
- if Is_Itype (Def_Id) and then Has_Predicates (Typ) then
+ if Is_Itype (Def_Id)
+ and then Has_Predicates (Typ)
+ and then not Predicated_Parent_Used
+ then
Inherit_Predicate_Flags (Def_Id, Typ);
-- Indicate where the predicate function may be found
@@ -2686,6 +2709,15 @@ package body Sem_Util is
Append_Unique_Elmt (N, Identifiers_List);
end if;
+
+ -- Skip attribute references created by the compiler, typically
+ -- 'Constrained applied to one of the writable actuals, to avoid
+ -- spurious errors.
+
+ elsif Nkind (N) = N_Attribute_Reference
+ and then not Comes_From_Source (N)
+ then
+ return Skip;
end if;
return OK;
@@ -3025,7 +3057,7 @@ package body Sem_Util is
-- For an array aggregate, a discrete_choice_list that has
-- a nonstatic range is considered as two or more separate
- -- occurrences of the expression (RM 6.4.1(20/3)).
+ -- occurrences of the expression (RM 6.4.1(6.20/3)).
elsif Is_Array_Type (Etype (N))
and then Nkind (N) = N_Aggregate
@@ -3110,48 +3142,105 @@ package body Sem_Util is
end loop;
end if;
- -- Handle discrete associations
+ -- Handle named associations
if Present (Component_Associations (N)) then
Assoc := First (Component_Associations (N));
while Present (Assoc) loop
- if not Box_Present (Assoc) then
- Choice := First (Choices (Assoc));
- while Present (Choice) loop
+ Handle_Association : declare
- -- For now we skip discriminants since it requires
- -- performing the analysis in two phases: first one
- -- analyzing discriminants and second one analyzing
- -- the rest of components since discriminants are
- -- evaluated prior to components: too much extra
- -- work to detect a corner case???
+ procedure Collect_Expression_Ids (Expr : Node_Id);
+ -- Collect identifiers in association expression Expr
- if Nkind (Choice) in N_Has_Entity
- and then Present (Entity (Choice))
- and then Ekind (Entity (Choice)) = E_Discriminant
- then
- null;
+ procedure Handle_Association_Choices
+ (Choices : List_Id; Expr : Node_Id);
+ -- Collect identifiers in an association expression
+ -- Expr for each choice in Choices.
+
+ ----------------------------
+ -- Collect_Expression_Ids --
+ ----------------------------
- elsif Box_Present (Assoc) then
- null;
+ procedure Collect_Expression_Ids (Expr : Node_Id) is
+ Comp_Expr : Node_Id;
+ begin
+ if not Analyzed (Expr) then
+ Comp_Expr := New_Copy_Tree (Expr);
+ Set_Parent (Comp_Expr, Parent (N));
+ Preanalyze_Without_Errors (Comp_Expr);
else
- if not Analyzed (Expression (Assoc)) then
- Comp_Expr :=
- New_Copy_Tree (Expression (Assoc));
- Set_Parent (Comp_Expr, Parent (N));
- Preanalyze_Without_Errors (Comp_Expr);
+ Comp_Expr := Expr;
+ end if;
+
+ Collect_Identifiers (Comp_Expr);
+ end Collect_Expression_Ids;
+
+ --------------------------------
+ -- Handle_Association_Choices --
+ --------------------------------
+
+ procedure Handle_Association_Choices
+ (Choices : List_Id; Expr : Node_Id)
+ is
+ Choice : Node_Id := First (Choices);
+
+ begin
+ while Present (Choice) loop
+
+ -- For now skip discriminants since it requires
+ -- performing analysis in two phases: first one
+ -- analyzing discriminants and second analyzing
+ -- the rest of components since discriminants
+ -- are evaluated prior to components: too much
+ -- extra work to detect a corner case???
+
+ if Nkind (Choice) in N_Has_Entity
+ and then Present (Entity (Choice))
+ and then
+ Ekind (Entity (Choice)) = E_Discriminant
+ then
+ null;
+
else
- Comp_Expr := Expression (Assoc);
+ Collect_Expression_Ids (Expr);
end if;
- Collect_Identifiers (Comp_Expr);
- end if;
+ Next (Choice);
+ end loop;
+ end Handle_Association_Choices;
- Next (Choice);
- end loop;
- end if;
+ begin
+ if not Box_Present (Assoc) then
+ if Nkind (Assoc) = N_Component_Association then
+ Handle_Association_Choices
+ (Choices (Assoc), Expression (Assoc));
+
+ elsif
+ Nkind (Assoc) = N_Iterated_Component_Association
+ and then Present (Defining_Identifier (Assoc))
+ then
+ Handle_Association_Choices
+ (Discrete_Choices (Assoc), Expression (Assoc));
+
+ -- Nkind (Assoc) = N_Iterated_Component_Association
+ -- with iterator_specification, or
+ -- Nkind (Assoc) = N_Iterated_Element_Association
+ -- with loop_parameter_specification
+ -- or iterator_specification
+ --
+ -- It seems that we might also need to deal with
+ -- iterable/iterator_names and iterator_filters
+ -- within iterator_specifications, and range bounds
+ -- within loop_parameter_specifications, but the
+ -- utility of doing that seems very low. ???
+
+ else
+ Collect_Expression_Ids (Expression (Assoc));
+ end if;
+ end if;
+ end Handle_Association;
Next (Assoc);
end loop;
@@ -5619,10 +5708,8 @@ package body Sem_Util is
-- to start scanning from the incomplete view, which is earlier on
-- the entity chain.
- elsif Nkind (Parent (B_Type)) = N_Full_Type_Declaration
- and then Present (Incomplete_View (Parent (B_Type)))
- then
- Id := Incomplete_View (Parent (B_Type));
+ elsif Present (Incomplete_View (B_Type)) then
+ Id := Incomplete_View (B_Type);
-- If T is a derived from a type with an incomplete view declared
-- elsewhere, that incomplete view is irrelevant, we want the
@@ -5662,6 +5749,7 @@ package body Sem_Util is
or else Is_Primitive (Id))
and then Parent_Kind (Parent (Id))
not in N_Formal_Subprogram_Declaration
+ and then not Is_Child_Unit (Id)
then
Is_Prim := False;
@@ -6578,6 +6666,30 @@ package body Sem_Util is
return Is_Class_Wide_Type (Typ) or else Needs_Finalization (Typ);
end CW_Or_Needs_Finalization;
+ -------------------------
+ -- Default_Constructor --
+ -------------------------
+
+ function Default_Constructor (Typ : Entity_Id) return Entity_Id is
+ Construct : Elmt_Id;
+ begin
+ pragma Assert (Is_Type (Typ));
+ if No (Constructor_Name (Typ)) or else No (Constructor_List (Typ)) then
+ return Empty;
+ end if;
+
+ Construct := First_Elmt (Constructor_List (Typ));
+ while Present (Construct) loop
+ if Parameter_Count (Elists.Node (Construct)) = 1 then
+ return Elists.Node (Construct);
+ end if;
+
+ Next_Elmt (Construct);
+ end loop;
+
+ return Empty;
+ end Default_Constructor;
+
---------------------
-- Defining_Entity --
---------------------
@@ -7946,6 +8058,7 @@ package body Sem_Util is
-- but the error should be posted on it, not on the component.
elsif Ekind (E) = E_Discriminant
+ and then Is_Not_Self_Hidden (E)
and then Present (Scope (Def_Id))
and then Scope (Def_Id) /= Current_Scope
then
@@ -7971,7 +8084,10 @@ package body Sem_Util is
-- Avoid cascaded messages with duplicate components in
-- derived types.
- if Ekind (E) in E_Component | E_Discriminant then
+ if Ekind (E) = E_Component
+ or else (Ekind (E) = E_Discriminant
+ and then Is_Not_Self_Hidden (E))
+ then
return;
end if;
end if;
@@ -8002,20 +8118,7 @@ package body Sem_Util is
-- If we fall through, declaration is OK, at least OK enough to continue
- -- If Def_Id is a discriminant or a record component we are in the midst
- -- of inheriting components in a derived record definition. Preserve
- -- their Ekind and Etype.
-
- if Ekind (Def_Id) in E_Discriminant | E_Component then
- null;
-
- -- If a type is already set, leave it alone (happens when a type
- -- declaration is reanalyzed following a call to the optimizer).
-
- elsif Present (Etype (Def_Id)) then
- null;
-
- else
+ if No (Etype (Def_Id)) then
Set_Etype (Def_Id, Any_Type); -- avoid cascaded errors
end if;
@@ -8063,12 +8166,20 @@ package body Sem_Util is
loop
Ren := Renamed_Object (Id);
+ -- The reference renames a function result. Check the original
+ -- node in case expansion relocates the function call.
+
+ -- Ren : ... renames Func_Call;
+
+ if Nkind (Original_Node (Ren)) = N_Function_Call then
+ exit;
+
-- The reference renames an abstract state or a whole object
-- Obj : ...;
-- Ren : ... renames Obj;
- if Is_Entity_Name (Ren) then
+ elsif Is_Entity_Name (Ren) then
-- Do not follow a renaming that goes through a generic formal,
-- because these entities are hidden and must not be referenced
@@ -8081,14 +8192,6 @@ package body Sem_Util is
Id := Entity (Ren);
end if;
- -- The reference renames a function result. Check the original
- -- node in case expansion relocates the function call.
-
- -- Ren : ... renames Func_Call;
-
- elsif Nkind (Original_Node (Ren)) = N_Function_Call then
- exit;
-
-- Otherwise the reference renames something which does not yield
-- an abstract state or a whole object. Treat the reference as not
-- having a proper entity for SPARK legality purposes.
@@ -8843,9 +8946,10 @@ package body Sem_Util is
--------------------------
procedure Find_Overlaid_Entity
- (N : Node_Id;
- Ent : out Entity_Id;
- Off : out Boolean)
+ (N : Node_Id;
+ Ent : out Entity_Id;
+ Ovrl_Typ : out Entity_Id;
+ Off : out Boolean)
is
pragma Assert
(Nkind (N) = N_Attribute_Definition_Clause
@@ -8867,8 +8971,9 @@ package body Sem_Util is
-- In the second case, the expr is either Y'Address, or recursively a
-- constant that eventually references Y'Address.
- Ent := Empty;
- Off := False;
+ Ent := Empty;
+ Ovrl_Typ := Empty;
+ Off := False;
Expr := Expression (N);
@@ -8898,6 +9003,8 @@ package body Sem_Util is
end if;
end loop;
+ Ovrl_Typ := Etype (Expr);
+
-- This loop checks the form of the prefix for an entity, using
-- recursion to deal with intermediate components.
@@ -8916,8 +9023,10 @@ package body Sem_Util is
pragma Assert
(not Expander_Active
and then Is_Concurrent_Type (Scope (Ent)));
- Ent := Empty;
+ Ent := Empty;
+ Ovrl_Typ := Empty;
end if;
+
return;
-- Check for components
@@ -10152,63 +10261,69 @@ package body Sem_Util is
Strval => String_From_Name_Buffer);
end Get_Default_External_Name;
- --------------------------
- -- Get_Enclosing_Object --
- --------------------------
+ --------------------------------
+ -- Get_Enclosing_Ghost_Entity --
+ --------------------------------
- function Get_Enclosing_Object (N : Node_Id) return Entity_Id is
+ function Get_Enclosing_Ghost_Entity (N : Node_Id) return Entity_Id is
begin
if Is_Entity_Name (N) then
return Entity (N);
else
case Nkind (N) is
- when N_Indexed_Component
+ when N_Attribute_Reference
+ | N_Explicit_Dereference
+ | N_Indexed_Component
| N_Selected_Component
| N_Slice
=>
- -- If not generating code, a dereference may be left implicit.
- -- In thoses cases, return Empty.
+ return Get_Enclosing_Ghost_Entity (Prefix (N));
- if Is_Access_Type (Etype (Prefix (N))) then
- return Empty;
- else
- return Get_Enclosing_Object (Prefix (N));
- end if;
+ when N_Function_Call =>
+ return Get_Called_Entity (N);
- when N_Type_Conversion =>
- return Get_Enclosing_Object (Expression (N));
+ -- We are interested in the target type, because if it is ghost,
+ -- then the object is ghost as well and if it is non-ghost, then
+ -- its expression can't be ghost.
+
+ when N_Qualified_Expression
+ | N_Type_Conversion
+ | N_Unchecked_Type_Conversion
+ =>
+ return Entity (Subtype_Mark (N));
when others =>
return Empty;
end case;
end if;
- end Get_Enclosing_Object;
+ end Get_Enclosing_Ghost_Entity;
- -------------------------------
- -- Get_Enclosing_Deep_Object --
- -------------------------------
+ --------------------------
+ -- Get_Enclosing_Object --
+ --------------------------
- function Get_Enclosing_Deep_Object (N : Node_Id) return Entity_Id is
+ function Get_Enclosing_Object (N : Node_Id) return Entity_Id is
begin
if Is_Entity_Name (N) then
return Entity (N);
else
case Nkind (N) is
- when N_Explicit_Dereference
- | N_Indexed_Component
+ when N_Indexed_Component
| N_Selected_Component
| N_Slice
=>
- return Get_Enclosing_Deep_Object (Prefix (N));
+ return Get_Enclosing_Object (Prefix (N));
- when N_Type_Conversion =>
- return Get_Enclosing_Deep_Object (Expression (N));
+ when N_Type_Conversion
+ | N_Unchecked_Type_Conversion
+ =>
+ return Get_Enclosing_Object (Expression (N));
when others =>
return Empty;
end case;
end if;
- end Get_Enclosing_Deep_Object;
+ end Get_Enclosing_Object;
---------------------------
-- Get_Enum_Lit_From_Pos --
@@ -12368,9 +12483,14 @@ package body Sem_Util is
while Present (Node) loop
case Nkind (Node) is
- when N_Null_Statement | N_Call_Marker | N_Raise_xxx_Error =>
+ when N_Null_Statement | N_Call_Marker =>
null;
+ when N_Raise_xxx_Error =>
+ if Comes_From_Source (Node) then
+ return False;
+ end if;
+
when N_Object_Declaration =>
if Present (Expression (Node))
and then not Side_Effect_Free (Expression (Node))
@@ -17815,6 +17935,27 @@ package body Sem_Util is
return Nkind (Spec_Decl) in N_Generic_Declaration;
end Is_Generic_Declaration_Or_Body;
+ --------------------------
+ -- Is_In_Context_Clause --
+ --------------------------
+
+ function Is_In_Context_Clause (N : Node_Id) return Boolean is
+ Plist : List_Id;
+ Parent_Node : Node_Id;
+
+ begin
+ if Is_List_Member (N) then
+ Plist := List_Containing (N);
+ Parent_Node := Parent (Plist);
+
+ return Present (Parent_Node)
+ and then Nkind (Parent_Node) = N_Compilation_Unit
+ and then Context_Items (Parent_Node) = Plist;
+ end if;
+
+ return False;
+ end Is_In_Context_Clause;
+
---------------------------
-- Is_Independent_Object --
---------------------------
@@ -18276,6 +18417,7 @@ package body Sem_Util is
case Nkind (N) is
when N_Indexed_Component
+ | N_Selected_Component
| N_Slice
=>
return
@@ -18287,13 +18429,6 @@ package body Sem_Util is
when N_Attribute_Reference =>
return Attribute_Name (N) in Name_Input | Name_Old | Name_Result;
- when N_Selected_Component =>
- return
- Is_Name_Reference (Selector_Name (N))
- and then
- (Is_Name_Reference (Prefix (N))
- or else Is_Access_Type (Etype (Prefix (N))));
-
when N_Explicit_Dereference =>
return True;
@@ -20863,6 +20998,7 @@ package body Sem_Util is
or else Nam = Name_Pre
or else Nam = Name_Pre_Class
or else Nam = Name_Precondition
+ or else Nam = Name_Program_Exit
or else Nam = Name_Refined_Depends
or else Nam = Name_Refined_Global
or else Nam = Name_Refined_Post
@@ -21800,7 +21936,7 @@ package body Sem_Util is
Set_Last_Assignment (Ent, Empty);
end if;
- if Is_Object (Ent) then
+ if Is_Object (Ent) and then Ekind (Ent) not in Record_Field_Kind then
if not Last_Assignment_Only then
Kill_Checks (Ent);
Set_Current_Value (Ent, Empty);
@@ -21876,20 +22012,6 @@ package body Sem_Util is
end loop Scope_Loop;
end Kill_Current_Values;
- --------------------------
- -- Kill_Size_Check_Code --
- --------------------------
-
- procedure Kill_Size_Check_Code (E : Entity_Id) is
- begin
- if (Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
- and then Present (Size_Check_Code (E))
- then
- Remove (Size_Check_Code (E));
- Set_Size_Check_Code (E, Empty);
- end if;
- end Kill_Size_Check_Code;
-
--------------------
-- Known_Non_Null --
--------------------
@@ -23078,11 +23200,6 @@ package body Sem_Util is
then
return True;
- -- Mutably tagged types require default initialization
-
- elsif Is_Mutably_Tagged_CW_Equivalent_Type (Typ) then
- return True;
-
-- If Initialize/Normalize_Scalars is in effect, string objects also
-- need initialization, unless they are created in the course of
-- expanding an aggregate (since in the latter case they will be
@@ -24902,7 +25019,7 @@ package body Sem_Util is
-- In case of a call rewritten in GNATprove mode while "inlining
-- for proof" go to the original call.
- elsif Nkind (Par) = N_Null_Statement then
+ elsif Nkind (Par) in N_Null_Statement | N_Block_Statement then
pragma Assert
(GNATprove_Mode
and then
@@ -25336,6 +25453,8 @@ package body Sem_Util is
end if;
if Nkind (P) = N_Selected_Component
+ -- and then Ekind (Entity (Selector_Name (P)))
+ -- in Record_Field_Kind
and then Present (Entry_Formal (Entity (Selector_Name (P))))
then
-- Case of a reference to an entry formal
@@ -25498,16 +25617,18 @@ package body Sem_Util is
if Sure
and then Modification_Comes_From_Source
+ and then Ekind (Ent) in E_Constant | E_Variable
and then Overlays_Constant (Ent)
and then Address_Clause_Overlay_Warnings
then
declare
Addr : constant Node_Id := Address_Clause (Ent);
O_Ent : Entity_Id;
+ O_Typ : Entity_Id;
Off : Boolean;
begin
- Find_Overlaid_Entity (Addr, O_Ent, Off);
+ Find_Overlaid_Entity (Addr, O_Ent, O_Typ, Off);
Error_Msg_Sloc := Sloc (Addr);
Error_Msg_NE
@@ -26066,6 +26187,24 @@ package body Sem_Util is
return Empty;
end Param_Entity;
+ ---------------------
+ -- Parameter_Count --
+ ---------------------
+
+ function Parameter_Count (Subp : Entity_Id) return Nat is
+ Result : Nat := 0;
+ Param : Entity_Id;
+ begin
+ Param := First_Entity (Subp);
+ while Present (Param) loop
+ Result := Result + 1;
+
+ Param := Next_Entity (Param);
+ end loop;
+
+ return Result;
+ end Parameter_Count;
+
----------------------
-- Policy_In_Effect --
----------------------
@@ -28409,12 +28548,6 @@ package body Sem_Util is
return False;
end if;
- if Ekind (Entity (Selector_Name (N))) not in
- E_Component | E_Discriminant
- then
- return False;
- end if;
-
declare
Comp : constant Entity_Id :=
Original_Record_Component (Entity (Selector_Name (N)));
@@ -28937,9 +29070,10 @@ package body Sem_Util is
------------------------------
function Ultimate_Overlaid_Entity (E : Entity_Id) return Entity_Id is
- Address : Node_Id;
- Alias : Entity_Id := E;
- Offset : Boolean;
+ Address : Node_Id;
+ Alias : Entity_Id := E;
+ Offset : Boolean;
+ Ovrl_Typ : Entity_Id;
begin
-- Currently this routine is only called for stand-alone objects that
@@ -28951,7 +29085,7 @@ package body Sem_Util is
loop
Address := Address_Clause (Alias);
if Present (Address) then
- Find_Overlaid_Entity (Address, Alias, Offset);
+ Find_Overlaid_Entity (Address, Alias, Ovrl_Typ, Offset);
if Present (Alias) then
null;
else
diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads
index fd749c4..e9c1263 100644
--- a/gcc/ada/sem_util.ads
+++ b/gcc/ada/sem_util.ads
@@ -54,12 +54,12 @@ package Sem_Util is
-- Add A to the list of access types to process when expanding the
-- freeze node of E.
- procedure Add_Global_Declaration (N : Node_Id);
- -- These procedures adds a declaration N at the library level, to be
+ procedure Add_Global_Declaration (Decl : Node_Id);
+ -- This procedure adds a declaration Decl at the library level, to be
-- elaborated before any other code in the unit. It is used for example
-- for the entity that marks whether a unit has been elaborated. The
-- declaration is added to the Declarations list of the Aux_Decls_Node
- -- for the current unit. The declarations are added in the current scope,
+ -- for the current unit. The declared entity is added to current scope,
-- so the caller should push a new scope as required before the call.
function Add_Suffix (E : Entity_Id; Suffix : Character) return Name_Id;
@@ -619,7 +619,21 @@ package Sem_Util is
-- Find whether there is a previous definition for name or identifier N in
-- the current scope. Because declarations for a scope are not necessarily
-- contiguous (e.g. for packages) the first entry on the visibility chain
- -- for N is not necessarily in the current scope.
+ -- for N is not necessarily in the current scope. Take, for example:
+ --
+ -- package P is
+ -- X : constant := 13;
+ --
+ -- package Q is
+ -- X : constant := 67;
+ -- end Q;
+ --
+ -- Y : constant := X;
+ -- end P;
+ --
+ -- When the declaration of Y is analyzed, the first entry on the visibility
+ -- chain is the X equal to 67, but Current_Entity_In_Scope returns the X
+ -- equal to 13.
function Current_Scope return Entity_Id;
-- Get entity representing current scope
@@ -647,6 +661,10 @@ package Sem_Util is
-- as Needs_Finalization except with pragma Restrictions (No_Finalization),
-- in which case we know that class-wide objects do not need finalization.
+ function Default_Constructor (Typ : Entity_Id) return Entity_Id;
+ -- Determine the default constructor (e.g. the constructor with only one
+ -- formal parameter) for a given type Typ.
+
function Defining_Entity (N : Node_Id) return Entity_Id;
-- Given a declaration N, returns the associated defining entity. If the
-- declaration has a specification, the entity is obtained from the
@@ -880,14 +898,18 @@ package Sem_Util is
-- loop are nested within the block.
procedure Find_Overlaid_Entity
- (N : Node_Id;
- Ent : out Entity_Id;
- Off : out Boolean);
+ (N : Node_Id;
+ Ent : out Entity_Id;
+ Ovrl_Typ : out Entity_Id;
+ Off : out Boolean);
-- The node N should be an address representation clause. Determines if the
-- target expression is the address of an entity with an optional offset.
-- If so, set Ent to the entity and, if there is an offset, set Off to
-- True, otherwise to False. If it is not possible to determine that the
-- address is of this form, then set Ent to Empty.
+ -- Ovrl_Typ is set to the type being overlaid and can be different than the
+ -- type of Ent, for example when the address clause is applied to a record
+ -- component or to an element of an array.
function Find_Parameter_Type (Param : Node_Id) return Entity_Id;
-- Return the type of formal parameter Param as determined by its
@@ -1117,15 +1139,27 @@ package Sem_Util is
-- identifier provided as the external name. Letters in the name are
-- according to the setting of Opt.External_Name_Default_Casing.
+ function Get_Enclosing_Ghost_Entity (N : Node_Id) return Entity_Id;
+ -- If expression N references a name of either an object or of a
+ -- subprogram, then return its outermost entity that determines
+ -- whether this name denotes a ghost object.
+
function Get_Enclosing_Object (N : Node_Id) return Entity_Id;
-- If expression N references a part of an object, return this object.
-- Otherwise return Empty. Expression N should have been resolved already.
- function Get_Enclosing_Deep_Object (N : Node_Id) return Entity_Id;
- -- If expression N references a reachable part of an object (as defined in
- -- SPARK RM 6.9), return this object. Otherwise return Empty. It is similar
- -- to Get_Enclosing_Object, but treats pointer dereference like component
- -- selection. Expression N should have been resolved already.
+ function Get_Enum_Lit_From_Pos
+ (T : Entity_Id;
+ Pos : Uint;
+ Loc : Source_Ptr) return Node_Id;
+ -- This function returns an identifier denoting the E_Enumeration_Literal
+ -- entity for the specified value from the enumeration type or subtype T.
+ -- The second argument is the Pos value. Constraint_Error is raised if
+ -- argument Pos is not in range. The third argument supplies a source
+ -- location for constructed nodes returned by this function. If No_Location
+ -- is supplied as source location, the location of the returned node is
+ -- copied from the original source location for the enumeration literal,
+ -- when available.
function Get_Generic_Entity (N : Node_Id) return Entity_Id;
-- Returns the true generic entity in an instantiation. If the name in the
@@ -1192,19 +1226,6 @@ package Sem_Util is
-- When flag Do_Checks is set, this routine will flag duplicate uses of
-- aspects.
- function Get_Enum_Lit_From_Pos
- (T : Entity_Id;
- Pos : Uint;
- Loc : Source_Ptr) return Node_Id;
- -- This function returns an identifier denoting the E_Enumeration_Literal
- -- entity for the specified value from the enumeration type or subtype T.
- -- The second argument is the Pos value. Constraint_Error is raised if
- -- argument Pos is not in range. The third argument supplies a source
- -- location for constructed nodes returned by this function. If No_Location
- -- is supplied as source location, the location of the returned node is
- -- copied from the original source location for the enumeration literal,
- -- when available.
-
function Get_Iterable_Type_Primitive
(Typ : Entity_Id;
Nam : Name_Id) return Entity_Id;
@@ -2095,6 +2116,10 @@ package Sem_Util is
-- Determine whether arbitrary declaration Decl denotes a generic package,
-- a generic subprogram or a generic body.
+ function Is_In_Context_Clause (N : Node_Id) return Boolean;
+ -- Returns True if N appears within the context clause of a unit, and False
+ -- for any other placement.
+
function Is_Independent_Object (N : Node_Id) return Boolean;
-- Determine whether arbitrary node N denotes a reference to an independent
-- object as per RM C.6(8).
@@ -2377,6 +2402,7 @@ package Sem_Util is
-- Pre
-- Pre_Class
-- Precondition
+ -- Program_Exit
-- Refined_Depends
-- Refined_Global
-- Refined_Post
@@ -2417,15 +2443,15 @@ package Sem_Util is
-- Determine whether an arbitrary entity denotes an instance of function
-- Ada.Unchecked_Conversion.
- function Is_Universal_Numeric_Type (T : Entity_Id) return Boolean;
- pragma Inline (Is_Universal_Numeric_Type);
- -- True if T is Universal_Integer or Universal_Real
-
function Is_Unconstrained_Or_Tagged_Item (Item : Entity_Id) return Boolean;
-- Subsidiary to Collect_Subprogram_Inputs_Outputs and the analysis of
-- pragma Depends. Determine whether the type of dependency item Item is
-- tagged, unconstrained array or unconstrained record.
+ function Is_Universal_Numeric_Type (T : Entity_Id) return Boolean;
+ pragma Inline (Is_Universal_Numeric_Type);
+ -- True if T is Universal_Integer or Universal_Real
+
function Is_User_Defined_Equality (Id : Entity_Id) return Boolean;
-- Determine whether an entity denotes a user-defined equality
@@ -2536,12 +2562,6 @@ package Sem_Util is
-- if the entity Ent is not for an object. Last_Assignment_Only has the
-- same meaning as for the call with no Ent.
- procedure Kill_Size_Check_Code (E : Entity_Id);
- -- Called when an address clause or pragma Import is applied to an entity.
- -- If the entity is a variable or a constant, and size check code is
- -- present, this size check code is killed, since the object will not be
- -- allocated by the program.
-
function Known_Non_Null (N : Node_Id) return Boolean;
-- Given a node N for a subexpression of an access type, determines if
-- this subexpression yields a value that is known at compile time to
@@ -2862,6 +2882,9 @@ package Sem_Util is
-- WARNING: this routine should be used in debugging scenarios such as
-- tracking down undefined symbols as it is fairly low level.
+ function Parameter_Count (Subp : Entity_Id) return Nat;
+ -- Return the number of parameters for a given subprogram Subp.
+
function Param_Entity (N : Node_Id) return Entity_Id;
-- Given an expression N, determines if the expression is a reference
-- to a formal (of a subprogram or entry), and if so returns the Id
diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb
index 35ef616..156afc9 100644
--- a/gcc/ada/sem_warn.adb
+++ b/gcc/ada/sem_warn.adb
@@ -1712,17 +1712,11 @@ package body Sem_Warn is
and then Ekind (E1) /= E_Class_Wide_Type
- -- Objects other than parameters of task types are allowed to
- -- be non-referenced, since they start up tasks.
+ -- Objects that are not parameters and whose types have tasks
+ -- are allowed to be non-referenced since they start up tasks.
- and then ((Ekind (E1) /= E_Variable
- and then Ekind (E1) /= E_Constant
- and then Ekind (E1) /= E_Component)
-
- -- Check that E1T is not a task or a composite type
- -- with a task component.
-
- or else not Has_Task (E1T))
+ and then not (Ekind (E1) in E_Variable | E_Constant | E_Component
+ and then Has_Task (E1T))
-- For subunits, only place warnings on the main unit itself,
-- since parent units are not completely compiled.
@@ -3470,6 +3464,24 @@ package body Sem_Warn is
end if;
end Warn_On_Constant_Valid_Condition;
+ ---------------------------------------
+ -- Warn_On_Ignored_Equality_Operator --
+ ---------------------------------------
+
+ procedure Warn_On_Ignored_Equality_Operator
+ (Typ : Entity_Id;
+ Comp_Typ : Entity_Id;
+ Loc : Source_Ptr) is
+ begin
+ if Warn_On_Ignored_Equality then
+ Error_Msg_Node_2 := Comp_Typ;
+ Error_Msg_N ("?_q?""="" for type & uses predefined ""="" for }", Typ);
+
+ Error_Msg_Sloc := Loc;
+ Error_Msg_N ("\?_q?""="" # is ignored here", Typ);
+ end if;
+ end Warn_On_Ignored_Equality_Operator;
+
-----------------------------
-- Warn_On_Known_Condition --
-----------------------------
@@ -4670,9 +4682,11 @@ package body Sem_Warn is
if Nkind (Parent (LA)) in N_Procedure_Call_Statement
| N_Parameter_Association
then
- Error_Msg_NE
- ("?m?& modified by call, but value overwritten #!",
- LA, Ent);
+ if Warn_On_All_Unread_Out_Parameters then
+ Error_Msg_NE
+ ("?m?& modified by call, but value overwritten #!",
+ LA, Ent);
+ end if;
else
Error_Msg_NE -- CODEFIX
("?m?useless assignment to&, value overwritten #!",
@@ -4747,7 +4761,7 @@ package body Sem_Warn is
Ent : Entity_Id;
begin
- if Warn_On_Modified_Unread
+ if (Warn_On_Modified_Unread or Warn_On_All_Unread_Out_Parameters)
and then In_Extended_Main_Source_Unit (E)
then
Ent := First_Entity (E);
diff --git a/gcc/ada/sem_warn.ads b/gcc/ada/sem_warn.ads
index edb872f..3a347ef 100644
--- a/gcc/ada/sem_warn.ads
+++ b/gcc/ada/sem_warn.ads
@@ -173,6 +173,15 @@ package Sem_Warn is
-- Op assuming that its scalar operands are valid. Emit a warning when the
-- result of the evaluation is True or False.
+ procedure Warn_On_Ignored_Equality_Operator
+ (Typ : Entity_Id;
+ Comp_Typ : Entity_Id;
+ Loc : Source_Ptr);
+ -- Typ is a composite type and Comp_Typ is the type of one of its
+ -- components. Output a warning notifying that the predefined "="
+ -- for Comp_Typ takes precedence over the user-defined equality
+ -- defined at the given location.
+
procedure Warn_On_Known_Condition (C : Node_Id);
-- C is a node for a boolean expression resulting from a relational
-- or membership operation. If the expression has a compile time known
diff --git a/gcc/ada/set_targ.ads b/gcc/ada/set_targ.ads
index b2e598f..e465c3f 100644
--- a/gcc/ada/set_targ.ads
+++ b/gcc/ada/set_targ.ads
@@ -93,7 +93,7 @@ package Set_Targ is
type FPT_Mode_Entry is record
NAME : String_Ptr; -- Name of mode (no null character at end)
- DIGS : Natural; -- Digits for floating-point type
+ DIGS : Positive; -- Digits for floating-point type
FLOAT_REP : Float_Rep_Kind; -- Float representation
PRECISION : Natural; -- Precision in bits
SIZE : Natural; -- Size in bits
diff --git a/gcc/ada/sinfo-utils.adb b/gcc/ada/sinfo-utils.adb
index 184bb08..d2e78a3 100644
--- a/gcc/ada/sinfo-utils.adb
+++ b/gcc/ada/sinfo-utils.adb
@@ -347,6 +347,19 @@ package body Sinfo.Utils is
end if;
end Get_Pragma_Arg;
+ -----------------------
+ -- Loop_Flow_Keyword --
+ -----------------------
+
+ function Loop_Flow_Keyword (N : N_Loop_Flow_Statement_Id) return String is
+ begin
+ case Nkind (N) is
+ when N_Continue_Statement => return "continue";
+ when N_Exit_Statement => return "exit";
+ when others => pragma Assert (False);
+ end case;
+ end Loop_Flow_Keyword;
+
procedure Destroy_Element (Elem : in out Union_Id);
-- Does not do anything but is used to instantiate
-- GNAT.Lists.Doubly_Linked_Lists.
diff --git a/gcc/ada/sinfo-utils.ads b/gcc/ada/sinfo-utils.ads
index 0e7399e..3ef85e6 100644
--- a/gcc/ada/sinfo-utils.ads
+++ b/gcc/ada/sinfo-utils.ads
@@ -137,6 +137,10 @@ package Sinfo.Utils is
-- for the argument. This is Arg itself, or, in the case where Arg is a
-- pragma argument association node, the expression from this node.
+ function Loop_Flow_Keyword (N : N_Loop_Flow_Statement_Id) return String;
+ -- Returns the keyword corresponding to N as a string, for use in
+ -- diagnostics.
+
function Lowest_Common_Ancestor (N1, N2 : Node_Id) return Union_Id;
-- Returns the list or node that is the lowest common ancestor of N1 and
-- N2 in the syntax tree.
diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads
index d22f103..c63a97d 100644
--- a/gcc/ada/sinfo.ads
+++ b/gcc/ada/sinfo.ads
@@ -737,14 +737,6 @@ package Sinfo is
-- section describes the usage of the semantic fields, which are used to
-- contain additional information determined during semantic analysis.
- -- Accept_Handler_Records
- -- This field is present only in an N_Accept_Alternative node. It is used
- -- to temporarily hold the exception handler records from an accept
- -- statement in a selective accept. These exception handlers will
- -- eventually be placed in the Handler_Records list of the procedure
- -- built for this accept (see Expand_N_Selective_Accept procedure in
- -- Exp_Ch9 for further details).
-
-- Access_Types_To_Process
-- Present in N_Freeze_Entity nodes for Incomplete or private types.
-- Contains the list of access types which may require specific treatment
@@ -1515,11 +1507,6 @@ package Sinfo is
-- range is given by the programmer, even if that range is identical to
-- the range for Float.
- -- Incomplete_View
- -- Present in full type declarations that are completions of incomplete
- -- type declarations. Denotes the corresponding incomplete view declared
- -- by the incomplete declaration.
-
-- Inherited_Discriminant
-- This flag is present in N_Component_Association nodes. It indicates
-- that a given component association in an extension aggregate is the
@@ -1701,6 +1688,7 @@ package Sinfo is
-- Pre
-- Pre_Class
-- Precondition
+ -- Program_Exit
-- Refined_Depends
-- Refined_Global
-- Refined_Post
@@ -2324,6 +2312,15 @@ package Sinfo is
-- entity of the original entity, operator, or subprogram being invoked,
-- or the original variable being read or written.
+ -- Call_Or_Target_Loop
+ -- Present in continue statements. Set by Analyze_Continue_Statement and
+ -- used by Expand_Continue_Statement. If Analyze_Continue_Statement
+ -- concluded that its input node was in fact a call to a procedure named
+ -- "Continue", it contains the corresponding N_Procedure_Call_Statement
+ -- node. Otherwise it contains the E_Loop_Id of the loop the continue
+ -- statement applies to. Finally, if Analyze_Continue_Statement detects
+ -- an error, this field is set to Empty.
+
-- Target_Type
-- Used in an N_Validate_Unchecked_Conversion node to point to the target
-- type entity for the unchecked conversion instantiation which gigi must
@@ -5219,6 +5216,23 @@ package Sinfo is
-- Condition (set to Empty if no WHEN part present)
-- Next_Exit_Statement : Next exit on chain
+ ------------------------
+ -- Continue Statement --
+ ------------------------
+
+ -- This is a GNAT extension
+
+ -- CONTINUE_STATEMENT ::= continue [loop_NAME] [when CONDITION];
+
+ -- Gigi restriction: The expander ensures that the type of the Condition
+ -- field is always Standard.Boolean, even if the type in the source is
+ -- some non-standard boolean type.
+
+ -- N_Continue_Statement
+ -- Sloc points to CONTINUE
+ -- Name (set to Empty if no loop name present)
+ -- Condition (set to Empty if no WHEN part present)
+
-------------------------
-- 5.9 Goto Statement --
-------------------------
@@ -6381,7 +6395,6 @@ package Sinfo is
-- Condition from the guard (set to Empty if no guard present)
-- Statements (set to Empty_List if no statements)
-- Pragmas_Before pragmas before alt (set to No_List if none)
- -- Accept_Handler_Records
------------------------------
-- 9.7.1 Delay Alternative --
@@ -7966,8 +7979,9 @@ package Sinfo is
-- operation) are also in this list.
-- Contract_Test_Cases contains a collection of pragmas that correspond
- -- to aspects/pragmas Contract_Cases, Exceptional_Cases, Test_Case and
- -- Subprogram_Variant. The ordering in the list is in LIFO fashion.
+ -- to aspects/pragmas Contract_Cases, Exceptional_Cases, Program_Exit,
+ -- Test_Case and Subprogram_Variant. The ordering in the list is in LIFO
+ -- fashion.
-- Classifications contains pragmas that either declare, categorize, or
-- establish dependencies between subprogram or package inputs and
@@ -8184,7 +8198,7 @@ package Sinfo is
-- An implicit label declaration is created for every occurrence of a
-- label on a statement or a label on a block or loop. It is chained
-- in the declarations of the innermost enclosing block as specified
- -- in RM section 5.1 (3).
+ -- in RM section 5.1 (12).
-- The Defining_Identifier is the actual identifier for the statement
-- identifier. Note that the occurrence of the label is a reference, NOT
diff --git a/gcc/ada/sinput.ads b/gcc/ada/sinput.ads
index 0a9602f..49423f0 100644
--- a/gcc/ada/sinput.ads
+++ b/gcc/ada/sinput.ads
@@ -793,8 +793,9 @@ private
Full_Ref_Name : File_Name_Type;
Instance : Instance_Id;
Num_SRef_Pragmas : Nat;
- First_Mapped_Line : Logical_Line_Number;
Source_Text : Source_Buffer_Ptr;
+ Inlined_Call : Source_Ptr;
+ First_Mapped_Line : Logical_Line_Number;
Source_First : Source_Ptr;
Source_Last : Source_Ptr;
Source_Checksum : Word;
@@ -803,7 +804,6 @@ private
Unit : Unit_Number_Type;
Time_Stamp : Time_Stamp_Type;
File_Type : Type_Of_File;
- Inlined_Call : Source_Ptr;
Inlined_Body : Boolean;
Inherited_Pragma : Boolean;
License : License_Type;
@@ -839,52 +839,6 @@ private
Index : Source_File_Index := 123456789; -- for debugging
end record;
- -- The following representation clause ensures that the above record
- -- has no holes. We do this so that when instances of this record are
- -- written by Tree_Gen, we do not write uninitialized values to the file.
-
- AS : constant Pos := Standard'Address_Size;
-
- for Source_File_Record use record
- File_Name at 0 range 0 .. 31;
- Reference_Name at 4 range 0 .. 31;
- Debug_Source_Name at 8 range 0 .. 31;
- Full_Debug_Name at 12 range 0 .. 31;
- Full_File_Name at 16 range 0 .. 31;
- Full_Ref_Name at 20 range 0 .. 31;
- Instance at 48 range 0 .. 31;
- Num_SRef_Pragmas at 24 range 0 .. 31;
- First_Mapped_Line at 28 range 0 .. 31;
- Source_First at 32 range 0 .. 31;
- Source_Last at 36 range 0 .. 31;
- Source_Checksum at 40 range 0 .. 31;
- Last_Source_Line at 44 range 0 .. 31;
- Template at 52 range 0 .. 31;
- Unit at 56 range 0 .. 31;
- Time_Stamp at 60 range 0 .. 8 * Time_Stamp_Length - 1;
- File_Type at 74 range 0 .. 7;
- Inlined_Call at 88 range 0 .. 31;
- Inlined_Body at 75 range 0 .. 0;
- Inherited_Pragma at 75 range 1 .. 1;
- License at 76 range 0 .. 7;
- Keyword_Casing at 77 range 0 .. 7;
- Identifier_Casing at 78 range 0 .. 15;
- Sloc_Adjust at 80 range 0 .. 31;
- Lines_Table_Max at 84 range 0 .. 31;
- Index at 92 range 0 .. 31;
-
- -- The following fields are pointers, so we have to specialize their
- -- lengths using pointer size, obtained above as Standard'Address_Size.
- -- Note that Source_Text is a fat pointer, so it has size = AS*2.
-
- Source_Text at 96 range 0 .. AS * 2 - 1;
- Lines_Table at 96 range AS * 2 .. AS * 3 - 1;
- Logical_Lines_Table at 96 range AS * 3 .. AS * 4 - 1;
- end record; -- Source_File_Record
-
- for Source_File_Record'Size use 96 * 8 + AS * 4;
- -- This ensures that we did not leave out any fields
-
package Source_File is new Table.Table
(Table_Component_Type => Source_File_Record,
Table_Index_Type => Source_File_Index,
diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl
index 95ece32..84bee72 100644
--- a/gcc/ada/snames.ads-tmpl
+++ b/gcc/ada/snames.ads-tmpl
@@ -147,6 +147,7 @@ package Snames is
-- Names of aspects for which there are no matching pragmas or attributes
-- so that they need to be included for aspect specification use.
+ Name_Constructor : constant Name_Id := N + $;
Name_Default_Value : constant Name_Id := N + $;
Name_Default_Component_Value : constant Name_Id := N + $;
Name_Designated_Storage_Model : constant Name_Id := N + $;
@@ -659,6 +660,7 @@ package Snames is
-- correctly recognize and process Priority. Priority is a standard Ada 95
-- pragma.
+ Name_Program_Exit : constant Name_Id := N + $; -- GNAT
Name_Provide_Shift_Operators : constant Name_Id := N + $; -- GNAT
Name_Psect_Object : constant Name_Id := N + $; -- GNAT
Name_Pure : constant Name_Id := N + $;
@@ -1080,6 +1082,7 @@ package Snames is
Name_Img : constant Name_Id := N + $; -- GNAT
Name_Input : constant Name_Id := N + $;
Name_Machine : constant Name_Id := N + $;
+ Name_Make : constant Name_Id := N + $; -- GNAT
Name_Max : constant Name_Id := N + $;
Name_Min : constant Name_Id := N + $;
Name_Model : constant Name_Id := N + $;
@@ -1388,6 +1391,7 @@ package Snames is
-- e.g. Name_UP_RESULT maps to "RESULT".
Name_Synchronous_Task_Control : constant Name_Id := N + $;
+ Name_Continue : constant Name_Id := N + $;
-- Names used to implement iterators over predefined containers
@@ -1614,6 +1618,7 @@ package Snames is
Attribute_Img,
Attribute_Input,
Attribute_Machine,
+ Attribute_Make,
Attribute_Max,
Attribute_Min,
Attribute_Model,
@@ -1952,6 +1957,7 @@ package Snames is
Pragma_Predicate_Failure,
Pragma_Preelaborate,
Pragma_Pre_Class,
+ Pragma_Program_Exit,
Pragma_Provide_Shift_Operators,
Pragma_Psect_Object,
Pragma_Pure,
diff --git a/gcc/ada/socket.c b/gcc/ada/socket.c
index 77bdde4..a22ed99 100644
--- a/gcc/ada/socket.c
+++ b/gcc/ada/socket.c
@@ -280,10 +280,10 @@ __gnat_gethostbyname (const char *name,
return -1;
}
ret->h_name = name;
- ret->h_aliases = &vxw_h_aliases;
+ ret->h_aliases = vxw_h_aliases;
ret->h_addrtype = AF_INET;
ret->h_length = 4;
- ret->h_addr_list = &vxw_h_addr_list;
+ ret->h_addr_list = vxw_h_addr_list;
return 0;
}
@@ -302,18 +302,18 @@ __gnat_gethostbyaddr (const char *addr, int len, int type,
return -1;
}
- if (hostGetByAddr (*(int*)addr, &vxw_h_name) != OK) {
+ if (hostGetByAddr (*(int*)addr, vxw_h_name) != OK) {
*h_errnop = __gnat_get_h_errno ();
return -1;
}
vxw_h_addr = (long) addr;
- ret->h_name = &vxw_h_name;
- ret->h_aliases = &vxw_h_aliases;
+ ret->h_name = vxw_h_name;
+ ret->h_aliases = vxw_h_aliases;
ret->h_addrtype = AF_INET;
ret->h_length = 4;
- ret->h_addr_list = &vxw_h_addr_list;
+ ret->h_addr_list = vxw_h_addr_list;
return 0;
}
diff --git a/gcc/ada/sprint.adb b/gcc/ada/sprint.adb
index 938d2b2..7a97492 100644
--- a/gcc/ada/sprint.adb
+++ b/gcc/ada/sprint.adb
@@ -1772,8 +1772,8 @@ package body Sprint is
Sprint_Node (Name (Node));
Write_Char (';');
- when N_Exit_Statement =>
- Write_Indent_Str_Sloc ("exit");
+ when N_Loop_Flow_Statement =>
+ Write_Indent_Str_Sloc (Loop_Flow_Keyword (Node));
Sprint_Opt_Node (Name (Node));
if Present (Condition (Node)) then
@@ -4634,7 +4634,7 @@ package body Sprint is
Param : Entity_Id;
begin
- Param := First_Entity (Typ);
+ Param := First_Formal (Typ);
loop
Write_Id (Param);
Write_Str (" : ");
@@ -4646,7 +4646,7 @@ package body Sprint is
end if;
Write_Id (Etype (Param));
- Next_Entity (Param);
+ Next_Formal (Param);
exit when No (Param);
Write_Str (", ");
end loop;
diff --git a/gcc/ada/switch-c.adb b/gcc/ada/switch-c.adb
index 6344a0b..efad12c 100644
--- a/gcc/ada/switch-c.adb
+++ b/gcc/ada/switch-c.adb
@@ -335,6 +335,7 @@ package body Switch.C is
end if;
Ptr := Ptr + 1;
+ Check_Semantics_Only_Mode := True;
Operating_Mode := Check_Semantics;
-- -gnatC (Generate CodePeer information)
@@ -1219,17 +1220,20 @@ package body Switch.C is
List_Representation_Info :=
Character'Pos (C) - Character'Pos ('0');
- when 's' =>
- List_Representation_Info_To_File := True;
+ when 'e' =>
+ List_Representation_Info_Extended := True;
- when 'j' =>
- List_Representation_Info_To_JSON := True;
+ when 'h' =>
+ List_Representation_Info_Holes := True;
when 'm' =>
List_Representation_Info_Mechanisms := True;
- when 'e' =>
- List_Representation_Info_Extended := True;
+ when 'j' =>
+ List_Representation_Info_To_JSON := True;
+
+ when 's' =>
+ List_Representation_Info_To_File := True;
when others =>
Bad_Switch ("-gnatR" & Switch_Chars (Ptr .. Max));
@@ -1244,6 +1248,12 @@ package body Switch.C is
Osint.Fail ("-gnatRe is incompatible with -gnatRj");
end if;
+ if List_Representation_Info_To_JSON
+ and then List_Representation_Info_Holes
+ then
+ Osint.Fail ("-gnatRh is incompatible with -gnatRj");
+ end if;
+
-- -gnats (syntax check only)
when 's' =>
diff --git a/gcc/ada/switch.adb b/gcc/ada/switch.adb
index b1abe1e..691abc0 100644
--- a/gcc/ada/switch.adb
+++ b/gcc/ada/switch.adb
@@ -93,7 +93,7 @@ package body Switch is
Set_Standard_Output;
Usage;
Write_Eol;
- Write_Line ("Report bugs to report@adacore.com");
+ Write_Line ("Report bugs to support@adacore.com");
Exit_Program (E_Success);
end if;
end Check_Version_And_Help_G;
diff --git a/gcc/ada/sysdep.c b/gcc/ada/sysdep.c
index 04ca270..3dc76f9 100644
--- a/gcc/ada/sysdep.c
+++ b/gcc/ada/sysdep.c
@@ -331,7 +331,7 @@ __gnat_ttyname (int filedes ATTRIBUTE_UNUSED)
#endif /* defined (__vxworks) */
}
#endif
-
+
#if defined (__linux__) || defined (__sun__) \
|| defined (WINNT) \
|| defined (__MACHTEN__) || defined (__hpux__) || defined (_AIX) \
@@ -1070,6 +1070,11 @@ _getpagesize (void)
{
return getpagesize ();
}
+
+int
+__gnat_has_cap_sys_nice () {
+ return 0;
+}
#endif
int
diff --git a/gcc/ada/treepr.adb b/gcc/ada/treepr.adb
index b1a2c34..d58f3ce 100644
--- a/gcc/ada/treepr.adb
+++ b/gcc/ada/treepr.adb
@@ -87,7 +87,7 @@ package body Treepr is
procedure Destroy (Value : in out Nat) is null;
pragma Annotate (CodePeer, False_Positive, "unassigned parameter",
"in out parameter is required to instantiate generic");
- -- Dummy routine for destroing hashed values
+ -- Dummy routine for destroying hashed values
package Serial_Numbers is new Dynamic_Hash_Tables
(Key_Type => Int,
@@ -412,6 +412,34 @@ package body Treepr is
procedure pe (N : Union_Id) renames pn;
+ ---------
+ -- pec --
+ ---------
+
+ procedure pec (From : Entity_Id) is
+ begin
+ Push_Output;
+ Set_Standard_Output;
+
+ Print_Entity_Chain (From);
+
+ Pop_Output;
+ end pec;
+
+ ----------
+ -- rpec --
+ ----------
+
+ procedure rpec (From : Entity_Id) is
+ begin
+ Push_Output;
+ Set_Standard_Output;
+
+ Print_Entity_Chain (From, Rev => True);
+
+ Pop_Output;
+ end rpec;
+
--------
-- pl --
--------
@@ -589,6 +617,36 @@ package body Treepr is
end if;
end Print_End_Span;
+ ------------------------
+ -- Print_Entity_Chain --
+ ------------------------
+
+ procedure Print_Entity_Chain (From : Entity_Id; Rev : Boolean := False) is
+ Ent : Entity_Id := From;
+ begin
+ Printing_Descendants := False;
+ Phase := Printing;
+
+ loop
+ declare
+ Next_Ent : constant Entity_Id :=
+ (if Rev then Prev_Entity (Ent) else Next_Entity (Ent));
+
+ Prefix_Char : constant Character :=
+ (if Present (Next_Ent) then '|' else ' ');
+ begin
+ Print_Node (Ent, "", Prefix_Char);
+
+ exit when No (Next_Ent);
+
+ Ent := Next_Ent;
+
+ Print_Char ('|');
+ Print_Eol;
+ end;
+ end loop;
+ end Print_Entity_Chain;
+
-----------------------
-- Print_Entity_Info --
-----------------------
@@ -1144,8 +1202,8 @@ package body Treepr is
end if;
if not Is_List_Member (N) then
- Print_Str (Prefix_Str);
- Print_Str (" Parent = ");
+ Print_Str (Prefix);
+ Print_Str ("Parent = ");
Print_Node_Ref (Parent (N));
Print_Eol;
end if;
diff --git a/gcc/ada/treepr.ads b/gcc/ada/treepr.ads
index f8a17fb..43e5187 100644
--- a/gcc/ada/treepr.ads
+++ b/gcc/ada/treepr.ads
@@ -60,6 +60,12 @@ package Treepr is
-- Prints the subtree consisting of the given element list and all its
-- referenced descendants.
+ procedure Print_Entity_Chain (From : Entity_Id; Rev : Boolean := False);
+ -- Prints the entity chain From is on, starting from From. In other words,
+ -- prints From and then recursively follow the Next_Entity field. If Rev is
+ -- True, prints the chain backwards, i.e. follow the Last_Entity field
+ -- instead of Next_Entity.
+
-- The following debugging procedures are intended to be called from gdb.
-- Note that in several cases there are synonyms which represent historical
-- development, and we keep them because some people are used to them!
@@ -103,4 +109,12 @@ package Treepr is
-- on the left and add a minus sign. This just saves some typing in the
-- debugger.
+ procedure pec (From : Entity_Id);
+ pragma Export (Ada, pec);
+ -- Print From and the entities that follow it on its entity chain
+
+ procedure rpec (From : Entity_Id);
+ pragma Export (Ada, rpec);
+ -- Like pec, but walk the entity chain backwards. The 'r' stands for
+ -- "reverse".
end Treepr;
diff --git a/gcc/ada/types.ads b/gcc/ada/types.ads
index 21701de..8869d01 100644
--- a/gcc/ada/types.ads
+++ b/gcc/ada/types.ads
@@ -947,7 +947,8 @@ package Types is
SE_Object_Too_Large, -- 35
PE_Stream_Operation_Not_Allowed, -- 36
PE_Build_In_Place_Mismatch, -- 37
- PE_Raise_Check_Failed); -- 38
+ PE_Raise_Check_Failed, -- 38
+ PE_Abstract_Type_Component); -- 39
pragma Convention (C, RT_Exception_Code);
Last_Reason_Code : constant :=
@@ -973,6 +974,7 @@ package Types is
CE_Range_Check_Failed => CE_Reason,
CE_Tag_Check_Failed => CE_Reason,
+ PE_Abstract_Type_Component => PE_Reason,
PE_Access_Before_Elaboration => PE_Reason,
PE_Accessibility_Check_Failed => PE_Reason,
PE_Address_Of_Intrinsic => PE_Reason,
diff --git a/gcc/ada/types.h b/gcc/ada/types.h
index 007dc24..d0a1a04 100644
--- a/gcc/ada/types.h
+++ b/gcc/ada/types.h
@@ -431,7 +431,8 @@ enum RT_Exception_Code
SE_Object_Too_Large = 35,
PE_Stream_Operation_Not_Allowed = 36,
PE_Build_In_Place_Mismatch = 37,
- PE_Raise_Check_Failed = 38
+ PE_Raise_Check_Failed = 38,
+ PE_Abstract_Type_Component = 39
};
-#define LAST_REASON_CODE 38
+#define LAST_REASON_CODE 39
diff --git a/gcc/ada/urealp.adb b/gcc/ada/urealp.adb
index cad1e66..d5fb4f5 100644
--- a/gcc/ada/urealp.adb
+++ b/gcc/ada/urealp.adb
@@ -34,7 +34,7 @@ package body Urealp is
-- add 1 to No_Ureal, since "+" means something different for Ureals).
type Ureal_Entry is record
- Num : Uint;
+ Num : Uint;
-- Numerator (always non-negative)
Den : Uint;
@@ -48,20 +48,6 @@ package body Urealp is
-- Flag set if value is negative
end record;
- -- The following representation clause ensures that the above record
- -- has no holes. We do this so that when instances of this record are
- -- written, we do not write uninitialized values to the file.
-
- for Ureal_Entry use record
- Num at 0 range 0 .. 31;
- Den at 4 range 0 .. 31;
- Rbase at 8 range 0 .. 31;
- Negative at 12 range 0 .. 31;
- end record;
-
- for Ureal_Entry'Size use 16 * 8;
- -- This ensures that we did not leave out any fields
-
package Ureals is new Table.Table (
Table_Component_Type => Ureal_Entry,
Table_Index_Type => Ureal'Base,
@@ -832,7 +818,7 @@ package body Urealp is
return Store_Ureal
((Num => Uint_1,
Den => -N,
- Rbase => UI_To_Int (UR_Trunc (Bas)),
+ Rbase => UI_To_Int (IBas),
Negative => Neg));
-- If the exponent is negative then we raise the numerator and the
@@ -1251,12 +1237,13 @@ package body Urealp is
---------------
function UR_Negate (Real : Ureal) return Ureal is
+ Val : constant Ureal_Entry := Ureals.Table (Real);
begin
return Store_Ureal
- ((Num => Ureals.Table (Real).Num,
- Den => Ureals.Table (Real).Den,
- Rbase => Ureals.Table (Real).Rbase,
- Negative => not Ureals.Table (Real).Negative));
+ ((Num => Val.Num,
+ Den => Val.Den,
+ Rbase => Val.Rbase,
+ Negative => not Val.Negative));
end UR_Negate;
------------
diff --git a/gcc/ada/urealp.ads b/gcc/ada/urealp.ads
index 323efc8..c7725bf 100644
--- a/gcc/ada/urealp.ads
+++ b/gcc/ada/urealp.ads
@@ -233,7 +233,7 @@ package Urealp is
function UR_Sub (Left : Ureal; Right : Uint) return Ureal;
-- Returns real difference of operands
- function UR_Exponentiate (Real : Ureal; N : Uint) return Ureal;
+ function UR_Exponentiate (Real : Ureal; N : Uint) return Ureal;
-- Returns result of raising Ureal to Uint power.
-- Fatal error if Left is 0 and Right is negative.
@@ -317,7 +317,7 @@ package Urealp is
function "-" (Left : Uint; Right : Ureal) return Ureal renames UR_Sub;
function "-" (Left : Ureal; Right : Uint) return Ureal renames UR_Sub;
- function "**" (Real : Ureal; N : Uint) return Ureal
+ function "**" (Real : Ureal; N : Uint) return Ureal
renames UR_Exponentiate;
function "abs" (Real : Ureal) return Ureal renames UR_Abs;
diff --git a/gcc/ada/usage.adb b/gcc/ada/usage.adb
index efa38b5..5b87bb5 100644
--- a/gcc/ada/usage.adb
+++ b/gcc/ada/usage.adb
@@ -92,17 +92,17 @@ begin
-- Common switches available everywhere
- Write_Switch_Char ("g ", "");
+ Write_Switch_Char ("g ", "");
Write_Line ("Generate debugging information");
- Write_Switch_Char ("Idir ", "");
+ Write_Switch_Char ("Idir ", "");
Write_Line ("Specify source files search path");
- Write_Switch_Char ("I- ", "");
+ Write_Switch_Char ("I- ", "");
Write_Line ("Do not look for sources in current directory");
- Write_Switch_Char ("O[0123] ", "");
- Write_Line ("Control the optimization level");
+ Write_Switch_Char ("O[?] ", "");
+ Write_Line ("Control the optimization level (?=0/1/2/3/s/z/g)");
Write_Eol;
@@ -402,7 +402,7 @@ begin
Write_Switch_Char ("R?");
Write_Line
- ("List rep info (?=0/1/2/3/4/e/m for none/types/all/sym/cg/ext/mech)");
+ ("List rep info (?=1/2/3/4/e/h/m for types/all/sym/cg/ext/holes/mech)");
Write_Switch_Char ("R?j");
Write_Line ("List rep info in the JSON data interchange format");
Write_Switch_Char ("R?s");
diff --git a/gcc/ada/vast.adb b/gcc/ada/vast.adb
index 302a89b..59470fd 100644
--- a/gcc/ada/vast.adb
+++ b/gcc/ada/vast.adb
@@ -23,18 +23,598 @@
-- --
------------------------------------------------------------------------------
--- Dummy implementation
+pragma Unsuppress (All_Checks);
+pragma Assertion_Policy (Check);
+-- Enable checking. This isn't really necessary, but it might come in handy if
+-- we want to run VAST with a compiler built without checks. Anyway, it's
+-- harmless, because VAST is not run by default.
+
+with Ada.Unchecked_Deallocation;
+
+with System.Case_Util;
+
+with Atree; use Atree;
+with Debug;
+with Einfo.Entities; use Einfo.Entities;
+with Lib; use Lib;
+with Namet; use Namet;
+with Nlists; use Nlists;
+with Opt; use Opt;
+with Output;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinput;
+with Table;
+with Types; use Types;
package body VAST is
+ -- ???Basic tree properties not yet checked:
+ -- - No dangling trees. Every node that is reachable at all is reachable
+ -- by some syntactic path.
+ -- - Basic properties of Nlists/Elists (next/prev pointers make sense,
+ -- for example).
+
+ Force_Enable_VAST : constant Boolean := False;
+ -- Normally, VAST is enabled by the the -gnatd_V switch.
+ -- To force it to be enabled independent of any switches,
+ -- set this to True.
+
+ type Check_Enum is
+ (Check_Other,
+ Check_Sloc,
+ Check_Analyzed,
+ Check_Error_Nodes,
+ Check_Sharing,
+ Check_Parent_Present,
+ Check_Parent_Correct);
+
+ type Check_Status is
+ -- Action in case of check failure:
+ (Disabled, -- Do nothing
+ Enabled, -- Print messages, and raise an exception
+ Print_And_Continue); -- Print a message
+
+ pragma Warnings (Off, "Status*could be declared constant");
+ Status : array (Check_Enum) of Check_Status :=
+ (Check_Other => Enabled,
+ Check_Sloc => Disabled,
+ Check_Analyzed => Disabled,
+ Check_Error_Nodes => Print_And_Continue,
+ Check_Sharing => Disabled,
+ Check_Parent_Present => Print_And_Continue,
+ Check_Parent_Correct => Disabled);
+-- others => Print_And_Continue);
+-- others => Enabled);
+-- others => Disabled);
+ -- Passing checks are Check_Other, which should always be Enabled.
+ -- Currently-failing checks are different enumerals in Check_Enum,
+ -- which can be disabled individually until we fix the bugs, or enabled
+ -- when debugging particular bugs. Pass a nondefault Check_Enum to
+ -- Assert in order to deal with bugs we have not yet fixed,
+ -- and play around with the value of Status above for
+ -- testing and debugging.
+ --
+ -- Note: Once a bug is fixed, and the check passes reliably, we may choose
+ -- to remove that check from Check_Enum and use Check_Other instead.
+
+ type Node_Stack_Index is new Pos;
+ subtype Node_Stack_Count is
+ Node_Stack_Index'Base range 0 .. Node_Stack_Index'Last;
+
+ package Node_Stack is new Table.Table
+ (Table_Component_Type => Node_Id,
+ Table_Index_Type => Node_Stack_Index'Base,
+ Table_Low_Bound => 1,
+ Table_Initial => 1,
+ Table_Increment => 100,
+ Table_Name => "Node_Stack");
+
+ procedure Assert
+ (Condition : Boolean;
+ Check : Check_Enum := Check_Other;
+ Detail : String := "");
+ -- Check that the Condition is True. Status determines action on failure.
+
+ function To_Mixed (A : String) return String;
+ -- Copied from System.Case_Util; old versions of that package do not have
+ -- this function, so this is needed for bootstrapping.
+
+ function Image (Kind : Node_Kind) return String is (To_Mixed (Kind'Img));
+ function Image (Kind : Entity_Kind) return String is (To_Mixed (Kind'Img));
+
+ procedure Put (S : String);
+ procedure Put_Line (S : String);
+ procedure Put_Node (N : Node_Id);
+ procedure Put_Node_Stack;
+ -- Output routines; print only if -gnatd_W (VAST in verbose mode) is
+ -- enabled.
+
+ procedure Put_Indentation;
+ -- Print spaces to indicate nesting depth of Node_Stack
+
+ procedure Enter_Node (N : Node_Id);
+ procedure Leave_Node (N : Node_Id);
+ -- Called for each node while walking the tree.
+ -- Push/pop N to/from Node_Stack.
+ -- Print enter/leave debugging messages.
+ -- ???Possible improvements to messages:
+ -- Walk subtrees in a better order.
+ -- Print field names.
+ -- Don't print boring fields (such as N_Empty nodes).
+ -- Print more info (value of literals, "A.B.C" for expanded names, etc.).
+ -- Share some code with Treepr.
+
+ procedure Do_Tree (N : Node_Id);
+ -- Do VAST checking on a tree of nodes
+
+ function Has_Subtrees (N : Node_Id) return Boolean;
+ -- True if N has one or more syntactic fields
+
+ procedure Do_Subtrees (N : Node_Id);
+ -- Call Do_Tree on all the subtrees (i.e. syntactic fields) of N
+
+ procedure Do_List (L : List_Id);
+ -- Call Do_Tree on the list elements
+
+ procedure Do_Unit (U : Unit_Number_Type);
+ -- Call Do_Tree on the root node of a compilation unit
+
+ function Ancestor_Node (Count : Node_Stack_Count) return Node_Id;
+ -- Nth ancestor on the Node_Stack. Ancestor_Node(0) is the current node,
+ -- Ancestor_Node(1) is its parent, Ancestor_Node(2) is its grandparent,
+ -- and so on.
+
+ function Top_Node return Node_Id is (Ancestor_Node (0));
+
+ type Node_Set is array (Node_Id range <>) of Boolean;
+ pragma Pack (Node_Set);
+ type Node_Set_Ptr is access all Node_Set;
+ procedure Free is new Ada.Unchecked_Deallocation (Node_Set, Node_Set_Ptr);
+
+ Visited : Node_Set_Ptr;
+ -- Giant array of Booleans; Visited (N) is True if and only if we have
+ -- visited N in the tree walk. Used to detect incorrect sharing of subtrees
+ -- or (worse) cycles. We don't allocate the set on the stack, for fear of
+ -- Storage_Error.
+
+ function Get_Node_Field_Union is new
+ Atree.Atree_Private_Part.Get_32_Bit_Field (Union_Id) with Inline;
+
+ --------------
+ -- To_Mixed --
+ --------------
+
+ function To_Mixed (A : String) return String is
+ Result : String := A;
+ begin
+ System.Case_Util.To_Mixed (Result);
+ return Result;
+ end To_Mixed;
+
+ ---------
+ -- Put --
+ ---------
+
+ procedure Put (S : String) is
+ begin
+ if Debug.Debug_Flag_Underscore_WW then
+ Output.Write_Str (S);
+ end if;
+ end Put;
+
+ --------------
+ -- Put_Line --
+ --------------
+
+ procedure Put_Line (S : String) is
+ begin
+ if Debug.Debug_Flag_Underscore_WW then
+ Output.Write_Line (S);
+ end if;
+ end Put_Line;
+
+ --------------
+ -- Put_Node --
+ --------------
+
+ procedure Put_Node (N : Node_Id) is
+ begin
+ if Debug.Debug_Flag_Underscore_WW then
+ if Nkind (N) in N_Entity then
+ Put (Image (Ekind (N)));
+ else
+ Put (Image (Nkind (N)));
+ end if;
+
+ Put (N'Img & " ");
+ Sinput.Write_Location (Sloc (N));
+
+ if Comes_From_Source (N) then
+ Put (" (s)");
+ end if;
+
+ case Nkind (N) is
+ when N_Has_Chars =>
+ Put (" ");
+ Write_Name_For_Debug (Chars (N), Quote => """");
+ when others => null;
+ end case;
+
+ end if;
+ end Put_Node;
+
+ ---------------------
+ -- Put_Indentation --
+ ---------------------
+
+ procedure Put_Indentation is
+ begin
+ Put (String'(Natural (Node_Stack.First) ..
+ Natural (Node_Stack.Last) * 2 => ' '));
+ end Put_Indentation;
+
+ ----------------
+ -- Enter_Node --
+ ----------------
+
+ procedure Enter_Node (N : Node_Id) is
+ begin
+ Node_Stack.Append (N); -- push
+
+ if Has_Subtrees (N) then
+ Put ("-->");
+ else
+ -- If no subtrees, just print one line for enter/leave
+ Put (" ");
+ end if;
+ Put_Indentation;
+ Put_Node (N);
+ Put_Line ("");
+ end Enter_Node;
+
----------------
- -- Check_Tree --
+ -- Leave_Node --
----------------
- procedure Check_Tree (GNAT_Root : Node_Id) is
- pragma Unreferenced (GNAT_Root);
+ procedure Leave_Node (N : Node_Id) is
+ begin
+ if Has_Subtrees (N) then
+ Put ("<--");
+ Put_Indentation;
+ Put_Node (N);
+ Put_Line ("");
+ end if;
+
+ Node_Stack.Decrement_Last; -- pop
+ end Leave_Node;
+
+ --------------------
+ -- Put_Node_Stack --
+ --------------------
+
+ procedure Put_Node_Stack is
+ begin
+ for J in reverse Node_Stack.First .. Node_Stack.Last loop
+ Put_Node (Node_Stack.Table (J));
+ Put_Line ("");
+ end loop;
+ end Put_Node_Stack;
+
+ -------------------
+ -- Ancestor_Node --
+ -------------------
+
+ function Ancestor_Node (Count : Node_Stack_Count) return Node_Id is
+ begin
+ return Node_Stack.Table (Node_Stack.Last - Count);
+ end Ancestor_Node;
+
+ ------------
+ -- Assert --
+ ------------
+
+ VAST_Failure : exception;
+
+ procedure Assert
+ (Condition : Boolean;
+ Check : Check_Enum := Check_Other;
+ Detail : String := "")
+ is
begin
- null;
- end Check_Tree;
+ if not Condition then
+ declare
+ Part1 : constant String := "VAST fail";
+ Part2 : constant String :=
+ (if Check = Check_Other then ""
+ else ": " & To_Mixed (Check'Img));
+ Part3 : constant String :=
+ (if Detail = "" then "" else " -- " & Detail);
+ Message : constant String := Part1 & Part2 & Part3;
+ Save : constant Boolean := Debug.Debug_Flag_Underscore_WW;
+ begin
+ case Status (Check) is
+ when Disabled => null;
+ when Enabled | Print_And_Continue =>
+ Debug.Debug_Flag_Underscore_WW := True;
+ -- ???We should probably avoid changing the debug flag here
+ Put (Message & ": ");
+ Put_Node (Top_Node);
+ Put_Line ("");
+
+ if Status (Check) = Enabled then
+ Put_Node_Stack;
+ raise VAST_Failure with Message;
+ end if;
+
+ Debug.Debug_Flag_Underscore_WW := Save;
+ end case;
+ end;
+ end if;
+ end Assert;
+
+ -------------
+ -- Do_Tree --
+ -------------
+
+ procedure Do_Tree (N : Node_Id) is
+ begin
+ Enter_Node (N);
+
+ -- Skip the rest if empty. Check Sloc:
+
+ case Nkind (N) is
+ when N_Empty =>
+ Assert (No (Sloc (N)));
+ goto Done; -- -------------->
+ -- Don't do any further checks on Empty
+
+ -- ???Some nodes, including exception handlers, have no Sloc;
+ -- it's unclear why.
+
+ when N_Exception_Handler =>
+ Assert (if Comes_From_Source (N) then Present (Sloc (N)));
+ when others =>
+ Assert (Present (Sloc (N)), Check_Sloc);
+ end case;
+
+ -- All reachable nodes should have been analyzed by the time we get
+ -- here:
+
+ Assert (Analyzed (N), Check_Analyzed);
+
+ -- If we visit the same node more than once, then there are shared
+ -- nodes; the "tree" is not a tree:
+
+ Assert (not Visited (N), Check_Sharing);
+ Visited (N) := True;
+
+ -- Misc checks based on node/entity kind:
+
+ case Nkind (N) is
+ when N_Unused_At_Start | N_Unused_At_End =>
+ Assert (False);
+
+ when N_Error =>
+ -- VAST doesn't do anything when Serious_Errors_Detected > 0 (at
+ -- least for now), so we shouldn't encounter any N_Error nodes.
+ Assert (False, Check_Error_Nodes);
+
+ when N_Entity =>
+ case Ekind (N) is
+ when others =>
+ null; -- more to be done here
+ end case;
+
+ when others =>
+ null; -- more to be done here
+ end case;
+
+ -- Check that N has a Parent, except in certain cases:
+
+ case Nkind (N) is
+ when N_Empty =>
+ raise Program_Error; -- can't get here
+
+ when N_Error =>
+ Assert (False, Check_Error_Nodes);
+ -- The error node has no parent, but we shouldn't even be seeing
+ -- error nodes in VAST at all. See earlier "when N_Error".
+
+ when N_Compilation_Unit =>
+ Assert (No (Parent (N)));
+ -- The parent of the root of each unit is empty.
+
+ when N_Entity =>
+ if not Is_Itype (N) then
+ -- An Itype might or might not have a parent
+
+ Assert
+ (Present (Parent (N)), Detail => "missing parent of entity");
+ Assert (Parent (N) = Ancestor_Node (1), Check_Parent_Correct);
+ end if;
+
+ when others =>
+ Assert (Present (Parent (N)), Check_Parent_Present);
+ -- All other nodes should have a parent
+ if Status (Check_Parent_Present) = Enabled then
+ Assert (Parent (N) = Ancestor_Node (1), Check_Parent_Correct);
+ end if;
+ end case;
+
+ Do_Subtrees (N);
+
+ <<Done>>
+ Leave_Node (N);
+ end Do_Tree;
+
+ -----------------
+ -- Has_Subtrees --
+ -----------------
+
+ function Has_Subtrees (N : Node_Id) return Boolean is
+ Offsets : Traversed_Offset_Array renames
+ Traversed_Fields (Nkind (N));
+ begin
+ -- True if sentinel comes first
+ return Offsets (Offsets'First) /= No_Field_Offset;
+ end Has_Subtrees;
+
+ -----------------
+ -- Do_Subtrees --
+ -----------------
+
+ procedure Do_Subtrees (N : Node_Id) is
+ -- ???Do we need tail recursion elimination here,
+ -- as in Atree.Traverse_Func?
+ Offsets : Traversed_Offset_Array renames
+ Traversed_Fields (Nkind (N));
+ begin
+ for Cur_Field in Offset_Array_Index loop
+ exit when Offsets (Cur_Field) = No_Field_Offset;
+
+ declare
+ F : constant Union_Id :=
+ Get_Node_Field_Union (N, Offsets (Cur_Field));
+ begin
+ if F in Node_Range then
+ Do_Tree (Node_Id (F));
+ elsif F in List_Range then
+ Do_List (List_Id (F));
+ else
+ raise Program_Error;
+ end if;
+ end;
+ end loop;
+ end Do_Subtrees;
+
+ -------------
+ -- Do_List --
+ -------------
+
+ procedure Do_List (L : List_Id) is
+ Elmt : Node_Id := First (L);
+ Len : constant String := List_Length (L)'Img;
+ begin
+ if Is_Non_Empty_List (L) then
+ Put ("-->");
+ Put_Indentation;
+ Put_Line ("list len=" & Len);
+
+ while Present (Elmt) loop
+ Do_Tree (Elmt);
+ Next (Elmt);
+ end loop;
+
+ Put ("<--");
+ Put_Indentation;
+ Put_Line ("list len=" & Len);
+ end if;
+ end Do_List;
+
+ -------------
+ -- Do_Unit --
+ -------------
+
+ procedure Do_Unit (U : Unit_Number_Type) is
+ U_Name : constant Unit_Name_Type := Unit_Name (U);
+ U_Name_S : constant String :=
+ (if U_Name = No_Unit_Name then "<No_Unit_Name>"
+ else Get_Name_String (U_Name));
+ Predef : constant String :=
+ (if Is_Predefined_Unit (U) then " (predef)"
+ elsif Is_Internal_Unit (U) then " (gnat)"
+ else "");
+ Is_Main : constant String :=
+ (if U = Main_Unit then " (main unit)" else "");
+ Msg : constant String :=
+ "VAST for unit" & U'Img & " " & U_Name_S & Predef & Is_Main;
+
+ Is_Preprocessing_Dependency : constant Boolean :=
+ U_Name = No_Unit_Name;
+ -- True if this is a bogus unit added by Add_Preprocessing_Dependency.
+ -- ???Not sure what that's about, but these units have no name and
+ -- no associated tree, so we had better not try to walk those trees.
+
+ Root : constant Node_Id := Cunit (U);
+ begin
+ pragma Assert (Node_Stack.Last = 0);
+ Assert (No (Root) = Is_Preprocessing_Dependency);
+ -- All compilation units except these bogus ones should have a Cunit.
+
+ Put_Line (Msg);
+
+ if Is_Preprocessing_Dependency then
+ Put_Line ("Skipping preprocessing dependency");
+ return;
+ end if;
+
+ Assert (Present (Root));
+ Do_Tree (Root);
+ Put_Line (Msg & " (done)");
+ pragma Assert (Node_Stack.Last = 0);
+ end Do_Unit;
+
+ ----------
+ -- VAST --
+ ----------
+
+ procedure VAST is
+ pragma Assert (Expander_Active = (Operating_Mode = Generate_Code));
+ -- ???So why do we need both Operating_Mode and Expander_Active?
+ use Debug;
+ begin
+ -- Do nothing if we're not calling the back end; the main point of VAST
+ -- is to protect against code-generation bugs. This includes the
+ -- case where legality errors were detected; the tree is known to be
+ -- malformed in some error cases.
+
+ if Operating_Mode /= Generate_Code then
+ return;
+ end if;
+
+ -- If -gnatd_W (VAST in verbose mode) is enabled, then that should imply
+ -- -gnatd_V (enable VAST).
+
+ if Debug_Flag_Underscore_WW then
+ Debug_Flag_Underscore_VV := True;
+ end if;
+
+ -- Do nothing if VAST is disabled
+
+ if not (Debug_Flag_Underscore_VV or Force_Enable_VAST) then
+ return;
+ end if;
+
+ -- Turn off output unless verbose mode is enabled
+
+ Put_Line ("VAST");
+
+ -- Operating_Mode = Generate_Code implies there are no legality errors:
+
+ Assert (Serious_Errors_Detected = 0);
+
+ Put_Line ("VAST checking" & Last_Unit'Img & " units");
+
+ declare
+ use Atree_Private_Part;
+ Last_Node : constant Node_Id := Node_Offsets.Last;
+ begin
+ pragma Assert (Visited = null);
+ Visited := new Node_Set'(Node_Id'First .. Last_Node => False);
+
+ for U in Main_Unit .. Last_Unit loop
+ -- Main_Unit is the one passed to the back end, but here we are
+ -- walking all the units.
+ Do_Unit (U);
+ end loop;
+
+ -- We shouldn't have allocated any new nodes during VAST:
+
+ pragma Assert (Node_Offsets.Last = Last_Node);
+ Free (Visited);
+ end;
+
+ Put_Line ("VAST done.");
+ end VAST;
end VAST;
diff --git a/gcc/ada/vast.ads b/gcc/ada/vast.ads
index 031ea21..faecd9a 100644
--- a/gcc/ada/vast.ads
+++ b/gcc/ada/vast.ads
@@ -24,13 +24,10 @@
------------------------------------------------------------------------------
-- This package is the entry point for VAST: Verifier for the Ada Semantic
--- Tree.
-
-with Types; use Types;
+-- Tree. It walks the expanded trees, and verifies their validity.
package VAST is
- procedure Check_Tree (GNAT_Root : Node_Id);
- -- Check the validity of the given Root tree
+ procedure VAST;
end VAST;