aboutsummaryrefslogtreecommitdiff
path: root/gcc/ada
diff options
context:
space:
mode:
authorMartin Liska <mliska@suse.cz>2022-09-12 10:43:19 +0200
committerMartin Liska <mliska@suse.cz>2022-09-12 10:43:19 +0200
commitfdb97cd0b7d15efa39ba79dca44be93debb0ef12 (patch)
tree65a6d95503fb9897bda29c72a629e57bb773d1c1 /gcc/ada
parent918bc838c2803f08e4d7ccd179396d48cb8ec804 (diff)
parent643ae816f17745a77b62188b6bf169211609a59b (diff)
downloadgcc-fdb97cd0b7d15efa39ba79dca44be93debb0ef12.zip
gcc-fdb97cd0b7d15efa39ba79dca44be93debb0ef12.tar.gz
gcc-fdb97cd0b7d15efa39ba79dca44be93debb0ef12.tar.bz2
Merge branch 'master' into devel/sphinx
Diffstat (limited to 'gcc/ada')
-rw-r--r--gcc/ada/ChangeLog432
-rw-r--r--gcc/ada/Makefile.rtl17
-rw-r--r--gcc/ada/bindgen.adb67
-rw-r--r--gcc/ada/checks.adb30
-rw-r--r--gcc/ada/contracts.adb1114
-rw-r--r--gcc/ada/contracts.ads36
-rw-r--r--gcc/ada/debug.adb11
-rw-r--r--gcc/ada/doc/gnat_rm/implementation_defined_aspects.rst16
-rw-r--r--gcc/ada/doc/gnat_rm/implementation_defined_attributes.rst7
-rw-r--r--gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst12
-rw-r--r--gcc/ada/doc/gnat_rm/the_gnat_library.rst219
-rw-r--r--gcc/ada/doc/gnat_ugn/building_executable_programs_with_gnat.rst81
-rw-r--r--gcc/ada/einfo.ads14
-rw-r--r--gcc/ada/erroutc.adb30
-rw-r--r--gcc/ada/exp_attr.adb117
-rw-r--r--gcc/ada/exp_ch11.adb3
-rw-r--r--gcc/ada/exp_ch4.adb5
-rw-r--r--gcc/ada/exp_ch6.adb178
-rw-r--r--gcc/ada/exp_ch7.adb772
-rw-r--r--gcc/ada/exp_ch9.adb390
-rw-r--r--gcc/ada/exp_prag.adb18
-rw-r--r--gcc/ada/exp_unst.adb13
-rw-r--r--gcc/ada/exp_util.adb3
-rw-r--r--gcc/ada/fe.h2
-rw-r--r--gcc/ada/freeze.adb32
-rw-r--r--gcc/ada/gcc-interface/decl.cc7
-rw-r--r--gcc/ada/gcc-interface/trans.cc261
-rw-r--r--gcc/ada/gcc-interface/utils.cc28
-rw-r--r--gcc/ada/gen_il-fields.ads5
-rw-r--r--gcc/ada/gen_il-gen-gen_entities.adb12
-rw-r--r--gcc/ada/gen_il-gen-gen_nodes.adb13
-rw-r--r--gcc/ada/ghost.adb10
-rw-r--r--gcc/ada/gnat_rm.texi1236
-rw-r--r--gcc/ada/gnat_ugn.texi81
-rw-r--r--gcc/ada/impunit.adb12
-rw-r--r--gcc/ada/inline.adb22
-rw-r--r--gcc/ada/lib-xref.adb9
-rw-r--r--gcc/ada/lib.adb9
-rw-r--r--gcc/ada/lib.ads6
-rw-r--r--gcc/ada/libgnarl/s-tpoben.ads11
-rw-r--r--gcc/ada/libgnat/a-cfdlli.adb1905
-rw-r--r--gcc/ada/libgnat/a-cfdlli.ads1641
-rw-r--r--gcc/ada/libgnat/a-cfhama.adb976
-rw-r--r--gcc/ada/libgnat/a-cfhama.ads883
-rw-r--r--gcc/ada/libgnat/a-cfhase.adb1559
-rw-r--r--gcc/ada/libgnat/a-cfhase.ads1473
-rw-r--r--gcc/ada/libgnat/a-cfidll.adb2054
-rw-r--r--gcc/ada/libgnat/a-cfidll.ads1640
-rw-r--r--gcc/ada/libgnat/a-cfinse.adb304
-rw-r--r--gcc/ada/libgnat/a-cfinse.ads350
-rw-r--r--gcc/ada/libgnat/a-cfinve.adb1452
-rw-r--r--gcc/ada/libgnat/a-cfinve.ads957
-rw-r--r--gcc/ada/libgnat/a-cforma.adb1239
-rw-r--r--gcc/ada/libgnat/a-cforma.ads1122
-rw-r--r--gcc/ada/libgnat/a-cforse.adb1939
-rw-r--r--gcc/ada/libgnat/a-cforse.ads1783
-rw-r--r--gcc/ada/libgnat/a-cofove.adb1311
-rw-r--r--gcc/ada/libgnat/a-cofove.ads952
-rw-r--r--gcc/ada/libgnat/a-cofuba.adb432
-rw-r--r--gcc/ada/libgnat/a-cofuba.ads198
-rw-r--r--gcc/ada/libgnat/a-cofuma.adb306
-rw-r--r--gcc/ada/libgnat/a-cofuma.ads366
-rw-r--r--gcc/ada/libgnat/a-cofuse.adb184
-rw-r--r--gcc/ada/libgnat/a-cofuse.ads306
-rw-r--r--gcc/ada/libgnat/a-cofuve.adb262
-rw-r--r--gcc/ada/libgnat/a-cofuve.ads381
-rw-r--r--gcc/ada/libgnat/a-coorse.ads6
-rw-r--r--gcc/ada/libgnat/a-strsup.adb15
-rw-r--r--gcc/ada/libgnat/a-stwisu.adb8
-rw-r--r--gcc/ada/libgnat/a-stzsup.adb14
-rw-r--r--gcc/ada/libgnat/s-imagei.adb2
-rw-r--r--gcc/ada/libgnat/s-maccod.ads4
-rw-r--r--gcc/ada/libgnat/s-powflt.ads30
-rw-r--r--gcc/ada/libgnat/s-powlfl.ads63
-rw-r--r--gcc/ada/libgnat/s-powllf.ads73
-rw-r--r--gcc/ada/libgnat/s-valflt.ads5
-rw-r--r--gcc/ada/libgnat/s-vallfl.ads5
-rw-r--r--gcc/ada/libgnat/s-valllf.ads5
-rw-r--r--gcc/ada/libgnat/s-valrea.adb345
-rw-r--r--gcc/ada/libgnat/s-valrea.ads8
-rw-r--r--gcc/ada/libgnat/s-valued.adb30
-rw-r--r--gcc/ada/libgnat/s-valuef.adb32
-rw-r--r--gcc/ada/libgnat/s-valuer.adb192
-rw-r--r--gcc/ada/libgnat/s-valuer.ads31
-rw-r--r--gcc/ada/libgnat/system-qnx-arm.ads2
-rw-r--r--gcc/ada/libgnat/system-vxworks7-aarch64-rtp-smp.ads2
-rw-r--r--gcc/ada/libgnat/system-vxworks7-aarch64.ads2
-rw-r--r--gcc/ada/libgnat/system-vxworks7-arm-rtp-smp.ads2
-rw-r--r--gcc/ada/libgnat/system-vxworks7-arm.ads2
-rw-r--r--gcc/ada/libgnat/system-vxworks7-x86-kernel.ads2
-rw-r--r--gcc/ada/libgnat/system-vxworks7-x86-rtp-smp.ads2
-rw-r--r--gcc/ada/libgnat/system-vxworks7-x86_64-kernel.ads2
-rw-r--r--gcc/ada/libgnat/system-vxworks7-x86_64-rtp-smp.ads2
-rw-r--r--gcc/ada/opt.ads7
-rw-r--r--gcc/ada/par-ch10.adb29
-rw-r--r--gcc/ada/par-ch12.adb5
-rw-r--r--gcc/ada/par-ch13.adb8
-rw-r--r--gcc/ada/par-ch3.adb71
-rw-r--r--gcc/ada/par-ch4.adb824
-rw-r--r--gcc/ada/par-ch5.adb86
-rw-r--r--gcc/ada/par-ch6.adb58
-rw-r--r--gcc/ada/par-ch7.adb15
-rw-r--r--gcc/ada/par-ch8.adb2
-rw-r--r--gcc/ada/par-ch9.adb11
-rw-r--r--gcc/ada/par-endh.adb24
-rw-r--r--gcc/ada/par-sync.adb22
-rw-r--r--gcc/ada/par-tchk.adb35
-rw-r--r--gcc/ada/par-util.adb34
-rw-r--r--gcc/ada/par.adb61
-rw-r--r--gcc/ada/prep.adb43
-rw-r--r--gcc/ada/prepcomp.adb4
-rw-r--r--gcc/ada/scng.adb12
-rw-r--r--gcc/ada/sem.ads37
-rw-r--r--gcc/ada/sem_aggr.adb5
-rw-r--r--gcc/ada/sem_attr.adb97
-rw-r--r--gcc/ada/sem_case.adb27
-rw-r--r--gcc/ada/sem_ch11.adb9
-rw-r--r--gcc/ada/sem_ch13.adb73
-rw-r--r--gcc/ada/sem_ch4.adb98
-rw-r--r--gcc/ada/sem_ch6.adb107
-rw-r--r--gcc/ada/sem_ch9.adb393
-rw-r--r--gcc/ada/sem_elab.adb49
-rw-r--r--gcc/ada/sem_prag.adb64
-rw-r--r--gcc/ada/sem_prag.ads29
-rw-r--r--gcc/ada/sem_res.adb15
-rw-r--r--gcc/ada/sem_util.adb191
-rw-r--r--gcc/ada/sem_util.ads5
-rw-r--r--gcc/ada/sinfo-utils.ads6
-rw-r--r--gcc/ada/sinfo.ads33
-rw-r--r--gcc/ada/snames.adb-tmpl3
-rw-r--r--gcc/ada/snames.ads-tmpl22
-rw-r--r--gcc/ada/sprint.adb33
-rw-r--r--gcc/ada/switch-b.adb9
-rw-r--r--gcc/ada/uintp.adb4
134 files changed, 4324 insertions, 30538 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 80e856d..b1fbd1e 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,435 @@
+2022-09-06 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/decl.cc (gnat_to_gnu_param): Set DECL_ARTIFICIAL.
+
+2022-09-06 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/trans.cc (At_End_Proc_to_gnu): Use the End_Label of
+ the child Handled_Statement_Sequence for body nodes.
+ (set_end_locus_from_node): Minor tweaks.
+
+2022-09-06 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/trans.cc (Full_View_Of_Private_Constant): New
+ function returning the Full_View of a private constant, after
+ looking through a chain of renamings, if any.
+ (Identifier_to_gnu): Call it on the entity. Small cleanup.
+
+2022-09-06 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/utils.cc (gnat_pushdecl): Preserve named
+ TYPE_DECLs consistently for all kind of pointer types.
+
+2022-09-06 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/trans.cc (gnat_to_gnu) <N_Op_Divide>: Report a
+ violation of No_Dependence on System.GCC if the result type is
+ larger than a word.
+ <N_Op_Shift>: Likewise.
+ <N_Op_Mod>: Likewise.
+ <N_Op_Rem>: Likewise.
+ (convert_with_check): Report a violation of No_Dependence on
+ System.GCC for a conversion between an integer type larger than
+ a word and a floating-point type.
+
+2022-09-06 Steve Baird <baird@adacore.com>
+
+ * sem_ch9.adb
+ (Allows_Lock_Free_Implementation): Return False if
+ Support_Atomic_Primitives is False.
+
+2022-09-06 Steve Baird <baird@adacore.com>
+
+ * debug.adb: Remove comment regarding the -gnatd9 switch.
+ * doc/gnat_rm/implementation_defined_attributes.rst: Remove all
+ mention of the Lock_Free attribute.
+ * gnat_rm.texi, gnat_ugn.texi: Regenerate.
+ * exp_attr.adb, sem_attr.adb: Remove all mention of the former
+ Attribute_Lock_Free enumeration element of the Attribute_Id type.
+ * sem_ch9.adb
+ (Allows_Lock_Free_Implementation): Remove the Debug_Flag_9 test.
+ Return False in the case of a protected function whose result type
+ requires use of the secondary stack.
+ (Satisfies_Lock_Free_Requirements): This functions checks for
+ certain constructs and returns False if one is found. In the case
+ of a protected function, there is no need to check to see if the
+ protected object is being modified. So it is ok to omit *some*
+ checks in the case of a protected function. But other checks which
+ are required (e.g., the test for a reference to a variable that is
+ not part of the protected object) were being incorrectly omitted.
+ This could result in accepting "Lock_Free => True" aspect
+ specifications that should be rejected.
+ * snames.adb-tmpl: Name_Lock_Free no longer requires special
+ treatment in Get_Pragma_Id or Is_Pragma_Name (because it is no
+ longer an attribute name).
+ * snames.ads-tmpl: Move the declaration of Name_Lock_Free to
+ reflect the fact that it is no longer the name of an attribute.
+ Delete Attribute_Lock_Free from the Attribute_Id enumeration type.
+
+2022-09-06 Steve Baird <baird@adacore.com>
+
+ * libgnat/a-coorse.ads: Restore Aggregate aspect specification for
+ type Set.
+
+2022-09-06 Marc Poulhiès <poulhies@adacore.com>
+
+ * exp_util.adb (Build_Allocate_Deallocate_Proc): Add
+ Alignment_Param in the formal list for calls to SS_Allocate.
+
+2022-09-06 Piotr Trojanek <trojanek@adacore.com>
+
+ * inline.adb (Process_Formals): Preserve Has_Private_View flag while
+ rewriting formal into actual parameters.
+
+2022-09-06 Javier Miranda <miranda@adacore.com>
+
+ * debug.adb
+ (Debug_Flag_Underscore_X): Switch added temporarily to allow
+ disabling extra formal checks.
+ * exp_attr.adb
+ (Expand_N_Attribute_Reference [access types]): Add extra formals
+ to the subprogram referenced in the prefix of 'Unchecked_Access,
+ 'Unrestricted_Access or 'Access; required to check that its extra
+ formals match the extra formals of the corresponding subprogram
+ type.
+ * exp_ch3.adb
+ (Stream_Operation_OK): Declaration moved to the public part of the
+ package.
+ (Validate_Tagged_Type_Extra_Formals): New subprogram.
+ (Expand_Freeze_Record_Type): Improve the code that takes care of
+ adding the extra formals of dispatching primitives; extended to
+ add also the extra formals to renamings of dispatching primitives.
+ * exp_ch3.ads
+ (Stream_Operation_OK): Declaration moved from the package body.
+ * exp_ch6.adb
+ (Has_BIP_Extra_Formal): Subprogram declaration moved to the public
+ part of the package. In addition, a parameter has been added to
+ disable an assertion that requires its use with frozen entities.
+ (Expand_Call_Helper): Enforce assertion checking extra formals on
+ thunks.
+ (Is_Build_In_Place_Function): Return False for entities with
+ foreign convention.
+ (Make_Build_In_Place_Call_In_Object_Declaration): Occurrences of
+ Is_Return_Object replaced by the local variable
+ Is_OK_Return_Object that evaluates to False for scopes with
+ foreign convention.
+ (Might_Have_Tasks): Fix check of class-wide limited record types.
+ (Needs_BIP_Task_Actuals): Remove assertion to allow calling this
+ function in more contexts; in addition it returns False for
+ functions returning objects with foreign convention.
+ (Needs_BIP_Finalization_Master): Likewise.
+ (Needs_BIP_Alloc_Form): Likewise.
+ * exp_ch6.ads
+ (Stream_Operation_OK): Declaration moved from the package body. In
+ addition, a parameter has been added to disable assertion that
+ requires its use with frozen entities.
+ * freeze.adb
+ (Check_Itype): Add extra formals to anonymous access subprogram
+ itypes.
+ (Freeze_Expression): Improve code that disables the addition of
+ extra formals to functions with foreign convention.
+ (Check_Extra_Formals): Moved to package Sem_Ch6 as
+ Extra_Formals_OK.
+ (Freeze_Subprogram): Add extra formals to non-dispatching
+ subprograms.
+ * sem_ch3.adb
+ (Access_Subprogram_Declaration): Defer the addition of extra
+ formals to the freezing point so that we know the convention.
+ (Check_Anonymous_Access_Component): Likewise.
+ (Derive_Subprogram): Fix documentation.
+ * sem_ch6.adb
+ (Check_Anonymous_Return): Fix check of access to class-wide
+ limited record types.
+ (Check_Untagged_Equality): Placed in alphabetical order.
+ (Extra_Formals_OK): Subprogram moved from freeze.adb.
+ (Extra_Formals_Match_OK): New subprogram.
+ (Has_BIP_Formals): New subprogram.
+ (Has_Extra_Formals): New subprograms.
+ (Needs_Accessibility_Check_Extra): New subprogram.
+ (Needs_Constrained_Extra): New subprogram.
+ (Parent_Subprogram): New subprogram.
+ (Add_Extra_Formal): Minor code cleanup.
+ (Create_Extra_Formals): Enforce matching extra formals on
+ overridden and aliased entities.
+ (Has_Reliable_Extra_Formals): New subprogram.
+ * sem_ch6.ads
+ (Extra_Formals_OK): Subprogram moved from freeze.adb.
+ (Extra_Formals_Match_OK): New subprogram.
+ * sem_eval.adb
+ (Compile_Time_Known_Value): Improve predicate to avoid assertion
+ failure; found working on this ticket; this change does not affect
+ the behavior of the compiler because this subprogram has an
+ exception handler that returns False when the assertion fails.
+ * sem_util.adb
+ (Needs_Result_Accessibility_Level): Do not return False for
+ dispatching operations compiled with Ada_Version < 2012 since they
+ they may be overridden by primitives compiled with Ada_Version >=
+ Ada_2012.
+
+2022-09-06 Arnaud Charlet <charlet@adacore.com>
+
+ * exp_ch4.adb (Expand_N_If_Expression): Disable optimization
+ for LLVM.
+
+2022-09-06 Javier Miranda <miranda@adacore.com>
+
+ * sem_prag.adb
+ (Analyze_Pre_Post_Condition_In_Decl_Part): Improve check to report
+ an error in non-legal class-wide conditions.
+
+2022-09-06 Steve Baird <baird@adacore.com>
+
+ * libgnat/a-strsup.adb, libgnat/a-stwisu.adb, libgnat/a-stzsup.adb
+ (Super_Slice function and procedure): fix slice length computation.
+
+2022-09-06 Steve Baird <baird@adacore.com>
+
+ * doc/gnat_ugn/building_executable_programs_with_gnat.rst:
+ Improve -gnatVa, -gnatVc, -gnatVd, -gnatVe, -gnatVf, -gnatVo,
+ -gnatVp, -gnatVr, and -gnatVs switch descriptions.
+ * gnat_ugn.texi: Regenerate.
+
+2022-09-06 Justin Squirek <squirek@adacore.com>
+
+ * exp_unst.adb
+ (Visit_Node): Add N_Block_Statement to the enclosing construct
+ case since they can now have "At end" procedures. Also, recognize
+ calls from "At end" procedures when recording subprograms.
+
+2022-09-06 Piotr Trojanek <trojanek@adacore.com>
+
+ * inline.adb (Replace_Formal): Fix name of the referenced routine.
+
+2022-09-06 Piotr Trojanek <trojanek@adacore.com>
+
+ * exp_attr.adb (Expand_N_Attribute_Reference [Attribute_Old]):
+ Remove unnecessary local constant that was shadowing another
+ constant with the same initial value.
+
+2022-09-06 Julien Bortolussi <bortolussi@adacore.com>
+
+ * libgnat/a-cforse.ads (Replace): Fix the postcondition.
+
+2022-09-06 Steve Baird <baird@adacore.com>
+
+ * exp_attr.adb
+ (Attribute_Valid): Ensure that PBtyp is initialized to a value for
+ which Is_Scalar_Type is True.
+ * checks.adb
+ (Determine_Range): Call Implemention_Base_Type instead of
+ Base_Type in order to ensure that result is suitable for passing
+ to Enum_Pos_To_Rep.
+
+2022-09-06 Bob Duff <duff@adacore.com>
+ Eric Botcazou <ebotcazou@adacore.com>
+
+ * gen_il-fields.ads
+ (First_Real_Statement): Remove this field.
+ * gen_il-gen-gen_nodes.adb: Remove the First_Real_Statement field.
+ Add the At_End_Proc field to nodes that have both Declarations and
+ HSS.
+ * sinfo.ads
+ (At_End_Proc): Document new semantics.
+ (First_Real_Statement): Remove comment.
+ * exp_ch11.adb
+ (Expand_N_Handled_Sequence_Of_Statements): Remove
+ First_Real_Statement.
+ * exp_ch7.adb
+ (Build_Cleanup_Statements): Remove "Historical note"; it doesn't
+ seem useful, and we have revision history.
+ (Create_Finalizer): Insert the finalizer later, typically in the
+ statement list, in some cases.
+ (Build_Finalizer_Call): Attach the "at end" handler to the parent
+ of the HSS node in most cases, so it applies to declarations.
+ (Expand_Cleanup_Actions): Remove Wrap_HSS_In_Block and the call to
+ it. Remove the code that moves declarations. Remove some redundant
+ code.
+ * exp_ch9.adb
+ (Build_Protected_Entry): Copy the At_End_Proc.
+ (Build_Protected_Subprogram_Body): Reverse the sense of Exc_Safe,
+ to avoid double negatives. Remove "Historical note" as in
+ exp_ch7.adb.
+ (Build_Unprotected_Subprogram_Body): Copy the At_End_Proc from the
+ protected version.
+ (Expand_N_Conditional_Entry_Call): Use First (Statements(...))
+ instead of First_Real_Statement(...).
+ (Expand_N_Task_Body): Put the Abort_Undefer call at the beginning
+ of the declarations, rather than in the HSS. Use First
+ (Statements(...)) instead of First_Real_Statement(...). Copy the
+ At_End_Proc.
+ * inline.adb
+ (Has_Initialized_Type): Return False if the declaration does not
+ come from source.
+ * libgnarl/s-tpoben.ads
+ (Lock_Entries, Lock_Entries_With_Status): Document when these
+ things raise Program_Error. It's not clear that
+ Lock_Entries_With_Status ought to be raising exceptions, but at
+ least it's documented now.
+ * sem.ads: Minor comment fixes.
+ * sem_ch6.adb
+ (Analyze_Subprogram_Body_Helper): Use First (Statements(...))
+ instead of First_Real_Statement(...).
+ (Analyze_Null_Procedure): Minor comment fix.
+ * sem_util.adb
+ (Might_Raise): Return True for N_Raise_Expression. Adjust the part
+ about exceptions generated by the back end to match the reality of
+ what the back end generates.
+ (Update_First_Real_Statement): Remove.
+ * sem_util.ads: Remove First_Real_Statement from comment.
+ * sinfo-utils.ads
+ (First_Real_Statement): New function that always returns Empty.
+ This should be removed once gnat-llvm and codepeer have been
+ updated to not refer to First_Real_Statement.
+ * sprint.adb
+ (Sprint_At_End_Proc): Deal with printing At_End_Proc.
+ * sem_prag.adb: Minor comment fixes.
+ * gcc-interface/trans.cc (At_End_Proc_to_gnu): New function.
+ (Subprogram_Body_to_gnu): Call it to handle an At_End_Proc.
+ (Handled_Sequence_Of_Statements_to_gnu): Likewise. Remove the
+ support for First_Real_Statement and clean up the rest.
+ (Exception_Handler_to_gnu): Do not push binding levels.
+ (Compilation_Unit_to_gnu): Adjust call to process_decls.
+ (gnat_to_gnu) <N_Package_Specification>: Likewise. <N_Entry_Body>:
+ Likewise. <N_Freeze_Entity>: Likewise. <N_Block_Statement>:
+ Likewise and call At_End_Proc_to_gnu to handle an At_End_Proc.
+ <N_Package_Body>: Likewise.
+ (process_decls): Remove GNAT_END_LIST parameter and adjust
+ recursive calls.
+
+2022-09-06 Steve Baird <baird@adacore.com>
+
+ * doc/gnat_rm/implementation_defined_pragmas.rst: Document new
+ temporary rule that a "when others =>" case choice must be given
+ when casing on a composite selector.
+ * gnat_rm.texi: Regenerate.
+
+2022-09-06 Steve Baird <baird@adacore.com>
+
+ * sem_case.adb: Define a new Boolean constant,
+ Simplified_Composite_Coverage_Rules, initialized to True. Setting
+ this constant to True has two effects: 1- Representative value
+ sets are not fully initialized - this is done to avoid capacity
+ problems, as well as for performance. 2- In
+ Check_Case_Pattern_Choices, the only legality check performed is a
+ check that a "when others =>" choice is present.
+
+2022-09-06 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_ch13.adb (Analyze_Aspect_Relaxed_Initialization): Fix error
+ template.
+
+2022-09-06 Steve Baird <baird@adacore.com>
+
+ * exp_attr.adb
+ (Make_Range_Test): In determining which subtype's First and Last
+ attributes are to be queried as part of a range test, call
+ Validated_View in order to get a scalar (as opposed to private)
+ subtype.
+ (Attribute_Valid): In determining whether to perform a signed or
+ unsigned comparison for a range test, call Validated_View in order
+ to get a scalar (as opposed to private) type. Also correct a typo
+ which, by itself, is the source of the problem reported for this
+ ticket.
+
+2022-09-06 Steve Baird <baird@adacore.com>
+
+ * sem_ch4.adb
+ (Analyze_Selected_Component): Define new Boolean-valued function,
+ Constraint_Has_Unprefixed_Discriminant_Reference, which takes a
+ subtype that is subject to a discriminant-dependent constraint and
+ returns True if any of the constraint values are unprefixed
+ discriminant names. Usually, the Etype of a selected component
+ node is set to Etype of the component. However, in the case of an
+ access-to-array component for which this predicate returns True,
+ we instead use the base type of the Etype of the component.
+ Normally such problematic discriminant references are addressed by
+ calling Build_Actual_Subtype_Of_Component, but that doesn't work
+ if Full_Analyze is False.
+
+2022-09-06 Piotr Trojanek <trojanek@adacore.com>
+
+ * Makefile.rtl (GNATRTL_NONTASKING_OBJS): Include
+ System.Value_U_Spec and System.Value_I_Spec units.
+
+2022-09-06 Eric Botcazou <ebotcazou@adacore.com>
+
+ * libgnat/s-powflt.ads (Powfive): New constant array.
+ * libgnat/s-powlfl.ads (Powfive): Likewise.
+ (Powfive_100): New constant.
+ (Powfive_200): Likewise.
+ (Powfive_300): Likewise.
+ * libgnat/s-powllf.ads (Powfive): New constant array.
+ (Powfive_100): New constant.
+ (Powfive_200): Likewise.
+ (Powfive_300): Likewise.
+ * libgnat/s-valflt.ads (Impl): Replace Powten with Powfive and pass
+ Null_Address for the address of large constants.
+ * libgnat/s-vallfl.ads (Impl): Replace Powten with Powfive and pass
+ the address of large constants.
+ * libgnat/s-valllf.ads (Impl): Likewise.
+ * libgnat/s-valrea.ads (System.Val_Real): Replace Powten_Address
+ with Powfive_Address and add Powfive_{1,2,3}00_Address parameters.
+ * libgnat/s-valrea.adb (Is_Large_Type): New boolean constant.
+ (Is_Very_Large_Type): Likewise.
+ (Maxexp32): Change value of 10 to that of 5.
+ (Maxexp64): Likewise.
+ (Maxexp80): Likewise.
+ (Integer_to_Real): Use a combination of tables of powers of 5 and
+ scaling if the base is 10.
+ (Large_Powten): Rename into...
+ (Large_Powfive): ...this. Add support for large constants.
+ (Large_Powfive): New overloaded function for very large exponents.
+
+2022-09-06 Piotr Trojanek <trojanek@adacore.com>
+
+ * doc/gnat_rm/implementation_defined_aspects.rst
+ (Aspect Iterable): Include Last and Previous primitives in
+ syntactic and semantic description.
+ * exp_attr.adb
+ (Expand_N_Attribute_Reference): Don't expect attributes like
+ Iterable that can only appear in attribute definition clauses.
+ * sem_ch13.adb
+ (Analyze_Attribute_Definition_Clause): Prevent crash on
+ non-aggregate Iterable attribute; improve basic diagnosis of
+ attribute values.
+ (Resolve_Iterable_Operation): Improve checks for illegal
+ primitives in aspect Iterable, e.g. with wrong number of formal
+ parameters.
+ (Validate_Iterable_Aspect): Prevent crashes on syntactically
+ illegal aspect expression.
+ * sem_util.adb
+ (Get_Cursor_Type): Fix style.
+ * gnat_ugn.texi, gnat_rm.texi: Regenerate.
+
+2022-09-06 Eric Botcazou <ebotcazou@adacore.com>
+
+ * libgnat/s-valuer.ads (System.Value_R): Add Parts formal parameter
+ as well as Data_Index, Scale_Array and Value_Array types.
+ (Scan_Raw_Real): Change type of Scale and return type.
+ (Value_Raw_Real): Likewise.
+ * libgnat/s-valuer.adb (Round_Extra): Reorder parameters and adjust
+ recursive call.
+ (Scan_Decimal_Digits): Reorder parameters, add N parameter and deal
+ with multi-part scale and value.
+ (Scan_Integral_Digits): Likewise.
+ (Scan_Raw_Real): Change type of Scale and return type and deal with
+ multi-part scale and value.
+ (Value_Raw_Real): Change type of Scale and return type and tidy up.
+ * libgnat/s-valued.adb (Impl): Pass 1 as Parts actual parameter.
+ (Scan_Decimal): Adjust to type changes.
+ (Value_Decimal): Likewise.
+ * libgnat/s-valuef.adb (Impl): Pass 1 as Parts actual parameter.
+ (Scan_Fixed): Adjust to type changes.
+ (Value_Fixed): Likewise.
+ * libgnat/s-valrea.adb (Need_Extra): Delete.
+ (Precision_Limit): Always use the precision of the mantissa.
+ (Impl): Pass 2 as Parts actual parameter.
+ (Exact_Log2): New expression function.
+ (Integer_to_Real): Change type of Scale and Val and deal with a
+ 2-part integer mantissa.
+ (Scan_Real): Adjust to type changes.
+ (Value_Real): Likewise.
+
2022-09-05 Martin Liska <mliska@suse.cz>
* sigtramp-vxworks-target.h: Rename DBX_REGISTER_NUMBER to
diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl
index 00137f2..96306f8 100644
--- a/gcc/ada/Makefile.rtl
+++ b/gcc/ada/Makefile.rtl
@@ -110,14 +110,6 @@ GNATRTL_NONTASKING_OBJS= \
a-cbprqu$(objext) \
a-cbsyqu$(objext) \
a-cdlili$(objext) \
- a-cfdlli$(objext) \
- a-cfhama$(objext) \
- a-cfhase$(objext) \
- a-cfidll$(objext) \
- a-cfinve$(objext) \
- a-cfinse$(objext) \
- a-cforma$(objext) \
- a-cforse$(objext) \
a-cgaaso$(objext) \
a-cgarso$(objext) \
a-cgcaso$(objext) \
@@ -144,14 +136,7 @@ GNATRTL_NONTASKING_OBJS= \
a-clrefi$(objext) \
a-coboho$(objext) \
a-cobove$(objext) \
- a-cofove$(objext) \
- a-cofuba$(objext) \
- a-cofuma$(objext) \
- a-cofuse$(objext) \
- a-cofuve$(objext) \
a-cogeso$(objext) \
- a-cohama$(objext) \
- a-cohase$(objext) \
a-cohata$(objext) \
a-coinho$(objext) \
a-coinve$(objext) \
@@ -778,6 +763,7 @@ GNATRTL_NONTASKING_OBJS= \
s-vaenu8$(objext) \
s-vafi32$(objext) \
s-vafi64$(objext) \
+ s-vaispe$(objext) \
s-valboo$(objext) \
s-valcha$(objext) \
s-valflt$(objext) \
@@ -796,6 +782,7 @@ GNATRTL_NONTASKING_OBJS= \
s-valuns$(objext) \
s-valuti$(objext) \
s-valwch$(objext) \
+ s-vauspe$(objext) \
s-veboop$(objext) \
s-vector$(objext) \
s-vercon$(objext) \
diff --git a/gcc/ada/bindgen.adb b/gcc/ada/bindgen.adb
index d5877c6..b2fa44d 100644
--- a/gcc/ada/bindgen.adb
+++ b/gcc/ada/bindgen.adb
@@ -114,6 +114,29 @@ package body Bindgen is
-- For CodePeer, introduce a wrapper subprogram which calls the
-- user-defined main subprogram.
+ -- Names and link_names for CUDA device adainit/adafinal procs.
+
+ Device_Subp_Name_Prefix : constant String := "imported_device_";
+ Device_Link_Name_Prefix : constant String := "__device_";
+
+ function Device_Ada_Final_Link_Name return String is
+ (Device_Link_Name_Prefix & Ada_Final_Name.all);
+
+ function Device_Ada_Final_Subp_Name return String is
+ (Device_Subp_Name_Prefix & Ada_Final_Name.all);
+
+ function Device_Ada_Init_Link_Name return String is
+ (Device_Link_Name_Prefix & Ada_Init_Name.all);
+
+ function Device_Ada_Init_Subp_Name return String is
+ (Device_Subp_Name_Prefix & Ada_Init_Name.all);
+
+ -- Text for aspect specifications (if any) given as part of the
+ -- Adainit and Adafinal spec declarations.
+
+ function Aspect_Text return String is
+ (if Enable_CUDA_Device_Expansion then " with CUDA_Global" else "");
+
----------------------------------
-- Interface_State Pragma Table --
----------------------------------
@@ -501,6 +524,12 @@ package body Bindgen is
WBI (" System.Standard_Library.Adafinal;");
end if;
+ -- perform device (as opposed to host) finalization
+ if Enable_CUDA_Expansion then
+ WBI (" pragma CUDA_Execute (" &
+ Device_Ada_Final_Subp_Name & ", 1, 1);");
+ end if;
+
WBI (" end " & Ada_Final_Name.all & ";");
WBI ("");
end Gen_Adafinal;
@@ -512,7 +541,6 @@ package body Bindgen is
procedure Gen_Adainit (Elab_Order : Unit_Id_Array) is
Main_Priority : Int renames ALIs.Table (ALIs.First).Main_Priority;
Main_CPU : Int renames ALIs.Table (ALIs.First).Main_CPU;
-
begin
-- Declare the access-to-subprogram type used for initialization of
-- of __gnat_finalize_library_objects. This is declared at library
@@ -1334,6 +1362,13 @@ package body Bindgen is
end;
end loop;
+ WBI (" procedure " & Device_Ada_Init_Subp_Name & ";");
+ WBI (" pragma Import (C, " & Device_Ada_Init_Subp_Name &
+ ", Link_Name => """ & Device_Ada_Init_Link_Name & """);");
+ WBI (" procedure " & Device_Ada_Final_Subp_Name & ";");
+ WBI (" pragma Import (C, " & Device_Ada_Final_Subp_Name &
+ ", Link_Name => """ & Device_Ada_Final_Link_Name & """);");
+
WBI ("");
end Gen_CUDA_Defs;
@@ -1393,6 +1428,10 @@ package body Bindgen is
end loop;
WBI (" CUDA_Register_Fat_Binary_End (Fat_Binary_Handle);");
+
+ -- perform device (as opposed to host) elaboration
+ WBI (" pragma CUDA_Execute (" &
+ Device_Ada_Init_Subp_Name & ", 1, 1);");
end Gen_CUDA_Init;
--------------------------
@@ -2513,6 +2552,9 @@ package body Bindgen is
if Enable_CUDA_Expansion then
WBI ("with Interfaces.C;");
WBI ("with Interfaces.C.Strings;");
+
+ -- with of CUDA.Internal needed for CUDA_Execute pragma expansion
+ WBI ("with CUDA.Internal;");
end if;
Resolve_Binder_Options (Elab_Order);
@@ -2602,9 +2644,14 @@ package body Bindgen is
end if;
WBI ("");
- WBI (" procedure " & Ada_Init_Name.all & ";");
- WBI (" pragma Export (C, " & Ada_Init_Name.all & ", """ &
- Ada_Init_Name.all & """);");
+ WBI (" procedure " & Ada_Init_Name.all & Aspect_Text & ";");
+ if Enable_CUDA_Device_Expansion then
+ WBI (" pragma Export (C, " & Ada_Init_Name.all &
+ ", Link_Name => """ & Device_Ada_Init_Link_Name & """);");
+ else
+ WBI (" pragma Export (C, " & Ada_Init_Name.all & ", """ &
+ Ada_Init_Name.all & """);");
+ end if;
-- If -a has been specified use pragma Linker_Constructor for the init
-- procedure and pragma Linker_Destructor for the final procedure.
@@ -2615,9 +2662,15 @@ package body Bindgen is
if not Cumulative_Restrictions.Set (No_Finalization) then
WBI ("");
- WBI (" procedure " & Ada_Final_Name.all & ";");
- WBI (" pragma Export (C, " & Ada_Final_Name.all & ", """ &
- Ada_Final_Name.all & """);");
+ WBI (" procedure " & Ada_Final_Name.all & Aspect_Text & ";");
+
+ if Enable_CUDA_Device_Expansion then
+ WBI (" pragma Export (C, " & Ada_Final_Name.all &
+ ", Link_Name => """ & Device_Ada_Final_Link_Name & """);");
+ else
+ WBI (" pragma Export (C, " & Ada_Final_Name.all & ", """ &
+ Ada_Final_Name.all & """);");
+ end if;
if Use_Pragma_Linker_Constructor then
WBI (" pragma Linker_Destructor (" & Ada_Final_Name.all & ");");
diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb
index 22577c8..8fa16b8 100644
--- a/gcc/ada/checks.adb
+++ b/gcc/ada/checks.adb
@@ -5094,7 +5094,8 @@ package body Checks is
-- Don't deal with enumerated types with non-standard representation
or else (Is_Enumeration_Type (Typ)
- and then Present (Enum_Pos_To_Rep (Base_Type (Typ))))
+ and then Present (Enum_Pos_To_Rep
+ (Implementation_Base_Type (Typ))))
-- Ignore type for which an error has been posted, since range in
-- this case may well be a bogosity deriving from the error. Also
@@ -9950,8 +9951,8 @@ package body Checks is
-- Typ'Length /= Exp'Length
function Length_Mismatch_Info_Message
- (Left_Element_Count : Uint;
- Right_Element_Count : Uint) return String;
+ (Left_Element_Count : Unat;
+ Right_Element_Count : Unat) return String;
-- Returns a message indicating how many elements were expected
-- (Left_Element_Count) and how many were found (Right_Element_Count).
@@ -10149,14 +10150,14 @@ package body Checks is
----------------------------------
function Length_Mismatch_Info_Message
- (Left_Element_Count : Uint;
- Right_Element_Count : Uint) return String
+ (Left_Element_Count : Unat;
+ Right_Element_Count : Unat) return String
is
- function Plural_Vs_Singular_Ending (Count : Uint) return String;
+ function Plural_Vs_Singular_Ending (Count : Unat) return String;
-- Returns an empty string if Count is 1; otherwise returns "s"
- function Plural_Vs_Singular_Ending (Count : Uint) return String is
+ function Plural_Vs_Singular_Ending (Count : Unat) return String is
begin
if Count = 1 then
return "";
@@ -10166,12 +10167,19 @@ package body Checks is
end Plural_Vs_Singular_Ending;
begin
- return "expected " & UI_Image (Left_Element_Count)
+ return "expected "
+ & UI_Image (Left_Element_Count, Format => Decimal)
& " element"
& Plural_Vs_Singular_Ending (Left_Element_Count)
- & "; found " & UI_Image (Right_Element_Count)
+ & "; found "
+ & UI_Image (Right_Element_Count, Format => Decimal)
& " element"
& Plural_Vs_Singular_Ending (Right_Element_Count);
+ -- "Format => Decimal" above is needed because otherwise UI_Image
+ -- can sometimes return a hexadecimal number 16#...#, but "#" means
+ -- something special to Errout. A previous version used the default
+ -- Auto, which was essentially the same bug as documented here:
+ -- https://xkcd.com/327/ .
end Length_Mismatch_Info_Message;
-----------------
@@ -10370,14 +10378,14 @@ package body Checks is
if L_Length > R_Length then
Add_Check
(Compile_Time_Constraint_Error
- (Wnode, "too few elements for}??", T_Typ,
+ (Wnode, "too few elements for}!!??", T_Typ,
Extra_Msg => Length_Mismatch_Info_Message
(L_Length, R_Length)));
elsif L_Length < R_Length then
Add_Check
(Compile_Time_Constraint_Error
- (Wnode, "too many elements for}??", T_Typ,
+ (Wnode, "too many elements for}!!??", T_Typ,
Extra_Msg => Length_Mismatch_Info_Message
(L_Length, R_Length)));
end if;
diff --git a/gcc/ada/contracts.adb b/gcc/ada/contracts.adb
index 1081b98..34db67a 100644
--- a/gcc/ada/contracts.adb
+++ b/gcc/ada/contracts.adb
@@ -68,6 +68,19 @@ package body Contracts is
--
-- Part_Of
+ procedure Build_Subprogram_Contract_Wrapper
+ (Body_Id : Entity_Id;
+ Stmts : List_Id;
+ Decls : List_Id;
+ Result : Entity_Id);
+ -- Generate a wrapper for a given subprogram body when the expansion of
+ -- postconditions require it by moving its declarations and statements
+ -- into a locally declared subprogram _Wrapped_Statements.
+
+ -- Postcondition and precondition checks then get inserted in place of
+ -- the original statements and declarations along with a call to
+ -- _Wrapped_Statements.
+
procedure Check_Class_Condition
(Cond : Node_Id;
Subp : Entity_Id;
@@ -78,6 +91,10 @@ package body Contracts is
-- In SPARK_Mode, an inherited operation that is not overridden but has
-- inherited modified conditions pre/postconditions is illegal.
+ function Is_Prologue_Renaming (Decl : Node_Id) return Boolean;
+ -- Determine whether arbitrary declaration Decl denotes a renaming of
+ -- a discriminant or protection field _object.
+
procedure Check_Type_Or_Object_External_Properties
(Type_Or_Obj_Id : Entity_Id);
-- Perform checking of external properties pragmas that is common to both
@@ -488,6 +505,45 @@ package body Contracts is
end loop;
end Analyze_Contracts;
+ -------------------------------------
+ -- Analyze_Pragmas_In_Declarations --
+ -------------------------------------
+
+ procedure Analyze_Pragmas_In_Declarations (Body_Id : Entity_Id) is
+ Curr_Decl : Node_Id;
+
+ begin
+ -- Move through the body's declarations analyzing all pragmas which
+ -- appear at the top of the declarations.
+
+ Curr_Decl := First (Declarations (Unit_Declaration_Node (Body_Id)));
+ while Present (Curr_Decl) loop
+
+ if Nkind (Curr_Decl) = N_Pragma then
+
+ if Pragma_Significant_To_Subprograms
+ (Get_Pragma_Id (Curr_Decl))
+ then
+ Analyze (Curr_Decl);
+ end if;
+
+ -- Skip the renamings of discriminants and protection fields
+
+ elsif Is_Prologue_Renaming (Curr_Decl) then
+ null;
+
+ -- We have reached something which is not a pragma so we can be sure
+ -- there are no more contracts or pragmas which need to be taken into
+ -- account.
+
+ else
+ exit;
+ end if;
+
+ Next (Curr_Decl);
+ end loop;
+ end Analyze_Pragmas_In_Declarations;
+
-----------------------------------------------
-- Analyze_Entry_Or_Subprogram_Body_Contract --
-----------------------------------------------
@@ -644,7 +700,7 @@ package body Contracts is
else
declare
- Bod : Node_Id;
+ Bod : Node_Id := Empty;
Freeze_Types : Boolean := False;
begin
@@ -1263,6 +1319,18 @@ package body Contracts is
if Present (Items) then
if Analyzed (Items) then
return;
+
+ -- Do not analyze the contract of the internal package
+ -- created to check conformance of an actual package.
+ -- Such an internal package is removed from the tree after
+ -- legality checks are completed, and it does not contain
+ -- the declarations of all local entities of the generic.
+
+ elsif Is_Internal (Pack_Id)
+ and then Is_Generic_Instance (Pack_Id)
+ then
+ return;
+
else
Set_Analyzed (Items);
end if;
@@ -1499,6 +1567,491 @@ package body Contracts is
(Type_Or_Obj_Id => Type_Id);
end Analyze_Type_Contract;
+ ---------------------------------------
+ -- Build_Subprogram_Contract_Wrapper --
+ ---------------------------------------
+
+ procedure Build_Subprogram_Contract_Wrapper
+ (Body_Id : Entity_Id;
+ Stmts : List_Id;
+ Decls : List_Id;
+ Result : Entity_Id)
+ is
+ Body_Decl : constant Entity_Id := Unit_Declaration_Node (Body_Id);
+ Loc : constant Source_Ptr := Sloc (Body_Decl);
+ Spec_Id : constant Entity_Id := Corresponding_Spec (Body_Decl);
+ Subp_Id : Entity_Id;
+ Ret_Type : Entity_Id;
+
+ Wrapper_Id : Entity_Id;
+ Wrapper_Body : Node_Id;
+ Wrapper_Spec : Node_Id;
+
+ begin
+ -- When there are no postcondition statements we do not need to
+ -- generate a wrapper.
+
+ if No (Stmts) then
+ return;
+ end if;
+
+ -- Obtain the related subprogram id from the body id.
+
+ if Present (Spec_Id) then
+ Subp_Id := Spec_Id;
+ else
+ Subp_Id := Body_Id;
+ end if;
+ Ret_Type := Etype (Subp_Id);
+
+ -- Generate the contracts wrapper by moving the original declarations
+ -- and statements within a local subprogram, calling it and possibly
+ -- preserving the result for the purpose of evaluating postconditions,
+ -- contracts, type invariants, etc.
+
+ -- In the case of a function, generate:
+ --
+ -- function Original_Func (X : in out Integer) return Typ is
+ -- <prologue renamings>
+ -- <preconditions>
+ --
+ -- function _Wrapped_Statements return Typ is
+ -- <original declarations>
+ -- begin
+ -- <original statements>
+ -- end;
+ --
+ -- begin
+ -- declare
+ -- type Axx is access all Typ;
+ -- Rxx : constant Axx := _Wrapped_Statements'reference;
+ -- Result_Obj : Typ renames Rxx.all;
+ --
+ -- begin
+ -- <postconditions statments>
+ -- return Rxx.all;
+ -- end;
+ -- end;
+ --
+ -- This sequence is recognized by Expand_Simple_Function_Return as a
+ -- tail call, in other words equivalent to "return _Wrapped_Statements;"
+ -- and thus the copy to the anonymous return object is elided, including
+ -- a pair of calls to Adjust/Finalize for types requiring finalization.
+
+ -- Note that an extended return statement does not yield the same result
+ -- because the copy of the return object is not elided by GNAT for now.
+
+ -- Or, in the case of a procedure:
+ --
+ -- procedure Original_Proc (X : in out Integer) is
+ -- <prologue renamings>
+ -- <preconditions>
+ --
+ -- procedure _Wrapped_Statements is
+ -- <original declarations>
+ -- begin
+ -- <original statements>
+ -- end;
+ --
+ -- begin
+ -- _Wrapped_Statements;
+ -- <postconditions statments>
+ -- end;
+ --
+
+ -- Create Identifier
+
+ Wrapper_Id := Make_Defining_Identifier (Loc, Name_uWrapped_Statements);
+ Set_Debug_Info_Needed (Wrapper_Id);
+ Set_Wrapped_Statements (Subp_Id, Wrapper_Id);
+
+ -- Create specification and declaration for the wrapper
+
+ if No (Ret_Type) or else Ret_Type = Standard_Void_Type then
+ Wrapper_Spec :=
+ Make_Procedure_Specification (Loc,
+ Defining_Unit_Name => Wrapper_Id);
+ else
+ Wrapper_Spec :=
+ Make_Function_Specification (Loc,
+ Defining_Unit_Name => Wrapper_Id,
+ Result_Definition => New_Occurrence_Of (Ret_Type, Loc));
+ end if;
+
+ -- Create the wrapper body using Body_Id's statements and declarations
+
+ Wrapper_Body :=
+ Make_Subprogram_Body (Loc,
+ Specification => Wrapper_Spec,
+ Declarations => Declarations (Body_Decl),
+ Handled_Statement_Sequence =>
+ Relocate_Node (Handled_Statement_Sequence (Body_Decl)));
+
+ Append_To (Decls, Wrapper_Body);
+ Set_Declarations (Body_Decl, Decls);
+ Set_Handled_Statement_Sequence (Body_Decl,
+ Make_Handled_Sequence_Of_Statements (Loc,
+ End_Label => Make_Identifier (Loc, Chars (Wrapper_Id))));
+
+ -- Move certain flags which are relevant to the body
+
+ -- Wouldn't a better way be to perform some sort of copy of Body_Decl
+ -- for Wrapper_Body be less error-prone ???
+
+ if Was_Expression_Function (Body_Decl) then
+ Set_Was_Expression_Function (Body_Decl, False);
+ Set_Was_Expression_Function (Wrapper_Body);
+ end if;
+
+ Set_Has_Pragma_Inline (Wrapper_Id, Has_Pragma_Inline (Subp_Id));
+ Set_Has_Pragma_Inline_Always
+ (Wrapper_Id, Has_Pragma_Inline_Always (Subp_Id));
+
+ -- Prepend a call to the wrapper when the subprogram is a procedure
+
+ if No (Ret_Type) or else Ret_Type = Standard_Void_Type then
+ Prepend_To (Stmts,
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Occurrence_Of (Wrapper_Id, Loc)));
+ Set_Statements
+ (Handled_Statement_Sequence (Body_Decl), Stmts);
+
+ -- Declare a renaming of the result of the call to the wrapper and
+ -- append a return of the result of the call when the subprogram is
+ -- a function, after manually removing the side effects. Note that
+ -- we cannot call Remove_Side_Effects here because nothing has been
+ -- analyzed yet and we cannot return the renaming itself because
+ -- Expand_Simple_Function_Return expects an explicit dereference.
+
+ else
+ declare
+ A_Id : constant Node_Id := Make_Temporary (Loc, 'A');
+ R_Id : constant Node_Id := Make_Temporary (Loc, 'R');
+
+ begin
+ Set_Statements (Handled_Statement_Sequence (Body_Decl), New_List (
+ Make_Block_Statement (Loc,
+
+ Declarations => New_List (
+ Make_Full_Type_Declaration (Loc,
+ Defining_Identifier => A_Id,
+ Type_Definition =>
+ Make_Access_To_Object_Definition (Loc,
+ All_Present => True,
+ Null_Exclusion_Present => True,
+ Subtype_Indication =>
+ New_Occurrence_Of (Ret_Type, Loc))),
+
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => R_Id,
+ Object_Definition => New_Occurrence_Of (A_Id, Loc),
+ Constant_Present => True,
+ Expression =>
+ Make_Reference (Loc,
+ Make_Function_Call (Loc,
+ Name => New_Occurrence_Of (Wrapper_Id, Loc)))),
+
+ Make_Object_Renaming_Declaration (Loc,
+ Defining_Identifier => Result,
+ Subtype_Mark => New_Occurrence_Of (Ret_Type, Loc),
+ Name =>
+ Make_Explicit_Dereference (Loc,
+ New_Occurrence_Of (R_Id, Loc)))),
+
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => Stmts))));
+
+ Append_To (Stmts,
+ Make_Simple_Return_Statement (Loc,
+ Expression =>
+ Make_Explicit_Dereference (Loc,
+ New_Occurrence_Of (R_Id, Loc))));
+
+ -- It is required for Is_Related_To_Func_Return to return True
+ -- that the temporary Rxx be related to the expression of the
+ -- simple return statement built just above.
+
+ Set_Related_Expression (R_Id, Expression (Last (Stmts)));
+ end;
+ end if;
+ end Build_Subprogram_Contract_Wrapper;
+
+ ----------------------------------
+ -- Build_Entry_Contract_Wrapper --
+ ----------------------------------
+
+ procedure Build_Entry_Contract_Wrapper (E : Entity_Id; Decl : Node_Id) is
+ Conc_Typ : constant Entity_Id := Scope (E);
+ Loc : constant Source_Ptr := Sloc (E);
+
+ procedure Add_Discriminant_Renamings
+ (Obj_Id : Entity_Id;
+ Decls : List_Id);
+ -- Add renaming declarations for all discriminants of concurrent type
+ -- Conc_Typ. Obj_Id is the entity of the wrapper formal parameter which
+ -- represents the concurrent object.
+
+ procedure Add_Matching_Formals
+ (Formals : List_Id;
+ Actuals : in out List_Id);
+ -- Add formal parameters that match those of entry E to list Formals.
+ -- The routine also adds matching actuals for the new formals to list
+ -- Actuals.
+
+ procedure Transfer_Pragma (Prag : Node_Id; To : in out List_Id);
+ -- Relocate pragma Prag to list To. The routine creates a new list if
+ -- To does not exist.
+
+ --------------------------------
+ -- Add_Discriminant_Renamings --
+ --------------------------------
+
+ procedure Add_Discriminant_Renamings
+ (Obj_Id : Entity_Id;
+ Decls : List_Id)
+ is
+ Discr : Entity_Id;
+ Renaming_Decl : Node_Id;
+
+ begin
+ -- Inspect the discriminants of the concurrent type and generate a
+ -- renaming for each one.
+
+ if Has_Discriminants (Conc_Typ) then
+ Discr := First_Discriminant (Conc_Typ);
+ while Present (Discr) loop
+ Renaming_Decl :=
+ Make_Object_Renaming_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Chars (Discr)),
+ Subtype_Mark =>
+ New_Occurrence_Of (Etype (Discr), Loc),
+ Name =>
+ Make_Selected_Component (Loc,
+ Prefix => New_Occurrence_Of (Obj_Id, Loc),
+ Selector_Name =>
+ Make_Identifier (Loc, Chars (Discr))));
+
+ Prepend_To (Decls, Renaming_Decl);
+
+ Next_Discriminant (Discr);
+ end loop;
+ end if;
+ end Add_Discriminant_Renamings;
+
+ --------------------------
+ -- Add_Matching_Formals --
+ --------------------------
+
+ procedure Add_Matching_Formals
+ (Formals : List_Id;
+ Actuals : in out List_Id)
+ is
+ Formal : Entity_Id;
+ New_Formal : Entity_Id;
+
+ begin
+ -- Inspect the formal parameters of the entry and generate a new
+ -- matching formal with the same name for the wrapper. A reference
+ -- to the new formal becomes an actual in the entry call.
+
+ Formal := First_Formal (E);
+ while Present (Formal) loop
+ New_Formal := Make_Defining_Identifier (Loc, Chars (Formal));
+ Append_To (Formals,
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier => New_Formal,
+ In_Present => In_Present (Parent (Formal)),
+ Out_Present => Out_Present (Parent (Formal)),
+ Parameter_Type =>
+ New_Occurrence_Of (Etype (Formal), Loc)));
+
+ if No (Actuals) then
+ Actuals := New_List;
+ end if;
+
+ Append_To (Actuals, New_Occurrence_Of (New_Formal, Loc));
+ Next_Formal (Formal);
+ end loop;
+ end Add_Matching_Formals;
+
+ ---------------------
+ -- Transfer_Pragma --
+ ---------------------
+
+ procedure Transfer_Pragma (Prag : Node_Id; To : in out List_Id) is
+ New_Prag : Node_Id;
+
+ begin
+ if No (To) then
+ To := New_List;
+ end if;
+
+ New_Prag := Relocate_Node (Prag);
+
+ Set_Analyzed (New_Prag, False);
+ Append (New_Prag, To);
+ end Transfer_Pragma;
+
+ -- Local variables
+
+ Items : constant Node_Id := Contract (E);
+ Actuals : List_Id := No_List;
+ Call : Node_Id;
+ Call_Nam : Node_Id;
+ Decls : List_Id := No_List;
+ Formals : List_Id;
+ Has_Pragma : Boolean := False;
+ Index_Id : Entity_Id;
+ Obj_Id : Entity_Id;
+ Prag : Node_Id;
+ Wrapper_Id : Entity_Id;
+
+ -- Start of processing for Build_Entry_Contract_Wrapper
+
+ begin
+ -- This routine generates a specialized wrapper for a protected or task
+ -- entry [family] which implements precondition/postcondition semantics.
+ -- Preconditions and case guards of contract cases are checked before
+ -- the protected action or rendezvous takes place.
+
+ -- procedure Wrapper
+ -- (Obj_Id : Conc_Typ; -- concurrent object
+ -- [Index : Index_Typ;] -- index of entry family
+ -- [Formal_1 : ...; -- parameters of original entry
+ -- Formal_N : ...])
+ -- is
+ -- [Discr_1 : ... renames Obj_Id.Discr_1; -- discriminant
+ -- Discr_N : ... renames Obj_Id.Discr_N;] -- renamings
+
+ -- <contracts pragmas>
+ -- <case guard checks>
+
+ -- begin
+ -- Entry_Call (Obj_Id, [Index,] [Formal_1, Formal_N]);
+ -- end Wrapper;
+
+ -- Create the wrapper only when the entry has at least one executable
+ -- contract item such as contract cases, precondition or postcondition.
+
+ if Present (Items) then
+
+ -- Inspect the list of pre/postconditions and transfer all available
+ -- pragmas to the declarative list of the wrapper.
+
+ Prag := Pre_Post_Conditions (Items);
+ while Present (Prag) loop
+ if Pragma_Name_Unmapped (Prag) in Name_Postcondition
+ | Name_Precondition
+ and then Is_Checked (Prag)
+ then
+ Has_Pragma := True;
+ Transfer_Pragma (Prag, To => Decls);
+ end if;
+
+ Prag := Next_Pragma (Prag);
+ end loop;
+
+ -- Inspect the list of test/contract cases and transfer only contract
+ -- cases pragmas to the declarative part of the wrapper.
+
+ Prag := Contract_Test_Cases (Items);
+ while Present (Prag) loop
+ if Pragma_Name (Prag) = Name_Contract_Cases
+ and then Is_Checked (Prag)
+ then
+ Has_Pragma := True;
+ Transfer_Pragma (Prag, To => Decls);
+ end if;
+
+ Prag := Next_Pragma (Prag);
+ end loop;
+ end if;
+
+ -- The entry lacks executable contract items and a wrapper is not needed
+
+ if not Has_Pragma then
+ return;
+ end if;
+
+ -- Create the profile of the wrapper. The first formal parameter is the
+ -- concurrent object.
+
+ Obj_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Chars (Conc_Typ), 'A'));
+
+ Formals := New_List (
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier => Obj_Id,
+ Out_Present => True,
+ In_Present => True,
+ Parameter_Type => New_Occurrence_Of (Conc_Typ, Loc)));
+
+ -- Construct the call to the original entry. The call will be gradually
+ -- augmented with an optional entry index and extra parameters.
+
+ Call_Nam :=
+ Make_Selected_Component (Loc,
+ Prefix => New_Occurrence_Of (Obj_Id, Loc),
+ Selector_Name => New_Occurrence_Of (E, Loc));
+
+ -- When creating a wrapper for an entry family, the second formal is the
+ -- entry index.
+
+ if Ekind (E) = E_Entry_Family then
+ Index_Id := Make_Defining_Identifier (Loc, Name_I);
+
+ Append_To (Formals,
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier => Index_Id,
+ Parameter_Type =>
+ New_Occurrence_Of (Entry_Index_Type (E), Loc)));
+
+ -- The call to the original entry becomes an indexed component to
+ -- accommodate the entry index.
+
+ Call_Nam :=
+ Make_Indexed_Component (Loc,
+ Prefix => Call_Nam,
+ Expressions => New_List (New_Occurrence_Of (Index_Id, Loc)));
+ end if;
+
+ -- Add formal parameters to match those of the entry and build actuals
+ -- for the entry call.
+
+ Add_Matching_Formals (Formals, Actuals);
+
+ Call :=
+ Make_Procedure_Call_Statement (Loc,
+ Name => Call_Nam,
+ Parameter_Associations => Actuals);
+
+ -- Add renaming declarations for the discriminants of the enclosing type
+ -- as the various contract items may reference them.
+
+ Add_Discriminant_Renamings (Obj_Id, Decls);
+
+ Wrapper_Id :=
+ Make_Defining_Identifier (Loc, New_External_Name (Chars (E), 'E'));
+ Set_Contract_Wrapper (E, Wrapper_Id);
+ Set_Is_Entry_Wrapper (Wrapper_Id);
+
+ -- The wrapper body is analyzed when the enclosing type is frozen
+
+ Append_Freeze_Action (Defining_Entity (Decl),
+ Make_Subprogram_Body (Loc,
+ Specification =>
+ Make_Procedure_Specification (Loc,
+ Defining_Unit_Name => Wrapper_Id,
+ Parameter_Specifications => Formals),
+ Declarations => Decls,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (Call))));
+ end Build_Entry_Contract_Wrapper;
+
---------------------------
-- Check_Class_Condition --
---------------------------
@@ -1804,16 +2357,9 @@ package body Contracts is
-- the item denotes a pragma, it is added to the list only when it is
-- enabled.
- procedure Build_Postconditions_Procedure
- (Subp_Id : Entity_Id;
- Stmts : List_Id;
- Result : Entity_Id);
- -- Create the body of procedure _Postconditions which handles various
- -- assertion actions on exit from subprogram Subp_Id. Stmts is the list
- -- of statements to be checked on exit. Parameter Result is the entity
- -- of parameter _Result when Subp_Id denotes a function.
-
- procedure Process_Contract_Cases (Stmts : in out List_Id);
+ procedure Process_Contract_Cases
+ (Stmts : in out List_Id;
+ Decls : List_Id);
-- Process pragma Contract_Cases. This routine prepends items to the
-- body declarations and appends items to list Stmts.
@@ -1821,7 +2367,7 @@ package body Contracts is
-- Collect all [inherited] spec and body postconditions and accumulate
-- their pragma Check equivalents in list Stmts.
- procedure Process_Preconditions;
+ procedure Process_Preconditions (Decls : in out List_Id);
-- Collect all [inherited] spec and body preconditions and prepend their
-- pragma Check equivalents to the declarations of the body.
@@ -2309,260 +2855,14 @@ package body Contracts is
end if;
end Append_Enabled_Item;
- ------------------------------------
- -- Build_Postconditions_Procedure --
- ------------------------------------
-
- procedure Build_Postconditions_Procedure
- (Subp_Id : Entity_Id;
- Stmts : List_Id;
- Result : Entity_Id)
- is
- Loc : constant Source_Ptr := Sloc (Body_Decl);
- Last_Decl : Node_Id;
- Params : List_Id := No_List;
- Proc_Bod : Node_Id;
- Proc_Decl : Node_Id;
- Proc_Id : Entity_Id;
- Proc_Spec : Node_Id;
-
- -- Extra declarations needed to handle interactions between
- -- postconditions and finalization.
-
- Postcond_Enabled_Decl : Node_Id;
- Return_Success_Decl : Node_Id;
- Result_Obj_Decl : Node_Id;
- Result_Obj_Type_Decl : Node_Id;
- Result_Obj_Type : Entity_Id;
-
- -- Start of processing for Build_Postconditions_Procedure
-
- begin
- -- Nothing to do if there are no actions to check on exit
-
- if No (Stmts) then
- return;
- end if;
-
- -- Otherwise, we generate the postcondition procedure and add
- -- associated objects and conditions used to coordinate postcondition
- -- evaluation with finalization.
-
- -- Generate:
- --
- -- procedure _postconditions (Return_Exp : Result_Typ);
- --
- -- -- Result_Obj_Type created when Result_Type is non-elementary
- -- [type Result_Obj_Type is access all Result_Typ;]
- --
- -- Result_Obj : Result_Obj_Type;
- --
- -- Postcond_Enabled : Boolean := True;
- -- Return_Success_For_Postcond : Boolean := False;
- --
- -- procedure _postconditions (Return_Exp : Result_Typ) is
- -- begin
- -- if Postcond_Enabled and then Return_Success_For_Postcond then
- -- [stmts];
- -- end if;
- -- end;
-
- Proc_Id := Make_Defining_Identifier (Loc, Name_uPostconditions);
- Set_Debug_Info_Needed (Proc_Id);
- Set_Postconditions_Proc (Subp_Id, Proc_Id);
-
- -- Mark it inlined to speed up the call
-
- Set_Is_Inlined (Proc_Id);
-
- -- Force the front-end inlining of _Postconditions when generating C
- -- code, since its body may have references to itypes defined in the
- -- enclosing subprogram, which would cause problems for unnesting
- -- routines in the absence of inlining.
-
- if Modify_Tree_For_C then
- Set_Has_Pragma_Inline (Proc_Id);
- Set_Has_Pragma_Inline_Always (Proc_Id);
- end if;
-
- -- The related subprogram is a function: create the specification of
- -- parameter _Result.
-
- if Present (Result) then
- Params := New_List (
- Make_Parameter_Specification (Loc,
- Defining_Identifier => Result,
- Parameter_Type =>
- New_Occurrence_Of (Etype (Result), Loc)));
- end if;
-
- Proc_Spec :=
- Make_Procedure_Specification (Loc,
- Defining_Unit_Name => Proc_Id,
- Parameter_Specifications => Params);
-
- Proc_Decl := Make_Subprogram_Declaration (Loc, Proc_Spec);
-
- -- Insert _Postconditions before the first source declaration of the
- -- body. This ensures that the body will not cause any premature
- -- freezing, as it may mention types:
-
- -- Generate:
- --
- -- procedure Proc (Obj : Array_Typ) is
- -- procedure _postconditions is
- -- begin
- -- ... Obj ...
- -- end _postconditions;
- --
- -- subtype T is Array_Typ (Obj'First (1) .. Obj'Last (1));
- -- begin
-
- -- In the example above, Obj is of type T but the incorrect placement
- -- of _Postconditions will cause a crash in gigi due to an out-of-
- -- order reference. The body of _Postconditions must be placed after
- -- the declaration of Temp to preserve correct visibility.
-
- Insert_Before_First_Source_Declaration
- (Proc_Decl, Declarations (Body_Decl));
- Analyze (Proc_Decl);
- Last_Decl := Proc_Decl;
-
- -- When Result is present (e.g. the postcondition checks apply to a
- -- function) we make a local object to capture the result, so, if
- -- needed, we can call the generated postconditions procedure during
- -- finalization instead of at the point of return.
-
- -- Note: The placement of the following declarations before the
- -- declaration of the body of the postconditions, but after the
- -- declaration of the postconditions spec is deliberate and required
- -- since other code within the expander expects them to be located
- -- here. Perhaps when more space is available in the tree this will
- -- no longer be necessary ???
-
- if Present (Result) then
- -- Elementary result types mean a copy is cheap and preferred over
- -- using pointers.
-
- if Is_Elementary_Type (Etype (Result)) then
- Result_Obj_Type := Etype (Result);
-
- -- Otherwise, we create a named access type to capture the result
-
- -- Generate:
- --
- -- type Result_Obj_Type is access all [Result_Type];
-
- else
- Result_Obj_Type := Make_Temporary (Loc, 'R');
-
- Result_Obj_Type_Decl :=
- Make_Full_Type_Declaration (Loc,
- Defining_Identifier => Result_Obj_Type,
- Type_Definition =>
- Make_Access_To_Object_Definition (Loc,
- All_Present => True,
- Subtype_Indication => New_Occurrence_Of
- (Etype (Result), Loc)));
- Insert_After_And_Analyze (Proc_Decl, Result_Obj_Type_Decl);
- Last_Decl := Result_Obj_Type_Decl;
- end if;
-
- -- Create the result obj declaration
-
- -- Generate:
- --
- -- Result_Object_For_Postcond : Result_Obj_Type;
-
- Result_Obj_Decl :=
- Make_Object_Declaration (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier
- (Loc, Name_uResult_Object_For_Postcond),
- Object_Definition =>
- New_Occurrence_Of
- (Result_Obj_Type, Loc));
- Set_No_Initialization (Result_Obj_Decl);
- Insert_After_And_Analyze (Last_Decl, Result_Obj_Decl);
- Last_Decl := Result_Obj_Decl;
- end if;
-
- -- Build the Postcond_Enabled flag used to delay evaluation of
- -- postconditions until finalization has been performed when cleanup
- -- actions are present.
-
- -- NOTE: This flag could be made into a predicate since we should be
- -- able at compile time to recognize when finalization and cleanup
- -- actions occur, but in practice this is not possible ???
-
- -- Generate:
- --
- -- Postcond_Enabled : Boolean := True;
-
- Postcond_Enabled_Decl :=
- Make_Object_Declaration (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier
- (Loc, Name_uPostcond_Enabled),
- Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
- Expression => New_Occurrence_Of (Standard_True, Loc));
- Insert_After_And_Analyze (Last_Decl, Postcond_Enabled_Decl);
- Last_Decl := Postcond_Enabled_Decl;
-
- -- Create a flag to indicate that return has been reached
-
- -- This is necessary for deciding whether to execute _postconditions
- -- during finalization.
-
- -- Generate:
- --
- -- Return_Success_For_Postcond : Boolean := False;
-
- Return_Success_Decl :=
- Make_Object_Declaration (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier
- (Loc, Name_uReturn_Success_For_Postcond),
- Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
- Expression => New_Occurrence_Of (Standard_False, Loc));
- Insert_After_And_Analyze (Last_Decl, Return_Success_Decl);
- Last_Decl := Return_Success_Decl;
-
- -- Set an explicit End_Label to override the sloc of the implicit
- -- RETURN statement, and prevent it from inheriting the sloc of one
- -- the postconditions: this would cause confusing debug info to be
- -- produced, interfering with coverage-analysis tools.
-
- -- NOTE: Coverage-analysis and static-analysis tools rely on the
- -- postconditions procedure being free of internally generated code
- -- since some of these tools, like CodePeer, treat _postconditions
- -- as original source.
-
- -- Generate:
- --
- -- procedure _postconditions is
- -- begin
- -- [Stmts];
- -- end;
-
- Proc_Bod :=
- Make_Subprogram_Body (Loc,
- Specification =>
- Copy_Subprogram_Spec (Proc_Spec),
- Declarations => Empty_List,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- End_Label => Make_Identifier (Loc, Chars (Proc_Id)),
- Statements => Stmts));
- Insert_After_And_Analyze (Last_Decl, Proc_Bod);
-
- end Build_Postconditions_Procedure;
-
----------------------------
-- Process_Contract_Cases --
----------------------------
- procedure Process_Contract_Cases (Stmts : in out List_Id) is
+ procedure Process_Contract_Cases
+ (Stmts : in out List_Id;
+ Decls : List_Id)
+ is
procedure Process_Contract_Cases_For (Subp_Id : Entity_Id);
-- Process pragma Contract_Cases for subprogram Subp_Id
@@ -2583,14 +2883,14 @@ package body Contracts is
Expand_Pragma_Contract_Cases
(CCs => Prag,
Subp_Id => Subp_Id,
- Decls => Declarations (Body_Decl),
+ Decls => Decls,
Stmts => Stmts);
elsif Pragma_Name (Prag) = Name_Subprogram_Variant then
Expand_Pragma_Subprogram_Variant
(Prag => Prag,
Subp_Id => Subp_Id,
- Body_Decls => Declarations (Body_Decl));
+ Body_Decls => Decls);
end if;
end if;
@@ -2599,11 +2899,6 @@ package body Contracts is
end if;
end Process_Contract_Cases_For;
- pragma Unmodified (Stmts);
- -- Stmts is passed as IN OUT to signal that the list can be updated,
- -- even if the corresponding integer value representing the list does
- -- not change.
-
-- Start of processing for Process_Contract_Cases
begin
@@ -2829,15 +3124,11 @@ package body Contracts is
-- Process_Preconditions --
---------------------------
- procedure Process_Preconditions is
+ procedure Process_Preconditions (Decls : in out List_Id) is
Insert_Node : Node_Id := Empty;
-- The insertion node after which all pragma Check equivalents are
-- inserted.
- function Is_Prologue_Renaming (Decl : Node_Id) return Boolean;
- -- Determine whether arbitrary declaration Decl denotes a renaming of
- -- a discriminant or protection field _object.
-
procedure Prepend_To_Decls (Item : Node_Id);
-- Prepend a single item to the declarations of the subprogram body
@@ -2849,64 +3140,12 @@ package body Contracts is
-- Collect all preconditions of subprogram Subp_Id and prepend their
-- pragma Check equivalents to the declarations of the body.
- --------------------------
- -- Is_Prologue_Renaming --
- --------------------------
-
- function Is_Prologue_Renaming (Decl : Node_Id) return Boolean is
- Nam : Node_Id;
- Obj : Entity_Id;
- Pref : Node_Id;
- Sel : Node_Id;
-
- begin
- if Nkind (Decl) = N_Object_Renaming_Declaration then
- Obj := Defining_Entity (Decl);
- Nam := Name (Decl);
-
- if Nkind (Nam) = N_Selected_Component then
- Pref := Prefix (Nam);
- Sel := Selector_Name (Nam);
-
- -- A discriminant renaming appears as
- -- Discr : constant ... := Prefix.Discr;
-
- if Ekind (Obj) = E_Constant
- and then Is_Entity_Name (Sel)
- and then Present (Entity (Sel))
- and then Ekind (Entity (Sel)) = E_Discriminant
- then
- return True;
-
- -- A protection field renaming appears as
- -- Prot : ... := _object._object;
-
- -- A renamed private component is just a component of
- -- _object, with an arbitrary name.
-
- elsif Ekind (Obj) in E_Variable | E_Constant
- and then Nkind (Pref) = N_Identifier
- and then Chars (Pref) = Name_uObject
- and then Nkind (Sel) = N_Identifier
- then
- return True;
- end if;
- end if;
- end if;
-
- return False;
- end Is_Prologue_Renaming;
-
----------------------
-- Prepend_To_Decls --
----------------------
procedure Prepend_To_Decls (Item : Node_Id) is
- Decls : List_Id;
-
begin
- Decls := Declarations (Body_Decl);
-
-- Ensure that the body has a declarative list
if No (Decls) then
@@ -2937,14 +3176,8 @@ package body Contracts is
else
Check_Prag := Build_Pragma_Check_Equivalent (Prag);
+ Prepend_To_Decls (Check_Prag);
- if Present (Insert_Node) then
- Insert_After (Insert_Node, Check_Prag);
- else
- Prepend_To_Decls (Check_Prag);
- end if;
-
- Analyze (Check_Prag);
end if;
end Prepend_Pragma_To_Decls;
@@ -3037,16 +3270,17 @@ package body Contracts is
-- Local variables
- Decls : constant List_Id := Declarations (Body_Decl);
- Decl : Node_Id;
+ Body_Decls : constant List_Id := Declarations (Body_Decl);
+ Decl : Node_Id;
+ Next_Decl : Node_Id;
-- Start of processing for Process_Preconditions
begin
-- Find the proper insertion point for all pragma Check equivalents
- if Present (Decls) then
- Decl := First (Decls);
+ if Present (Body_Decls) then
+ Decl := First (Body_Decls);
while Present (Decl) loop
-- First source declaration terminates the search, because all
@@ -3091,6 +3325,19 @@ package body Contracts is
-- <preconditions from body>
Process_Preconditions_For (Body_Id);
+
+ -- Move the generated entry-call prologue renamings into the
+ -- outer declarations for use in the preconditions.
+
+ Decl := First (Body_Decls);
+ while Present (Decl) and then Present (Insert_Node) loop
+ Next_Decl := Next (Decl);
+ Remove (Decl);
+ Prepend_To_Decls (Decl);
+
+ exit when Decl = Insert_Node;
+ Decl := Next_Decl;
+ end loop;
end if;
if Present (Spec_Id) then
@@ -3103,6 +3350,7 @@ package body Contracts is
Restore_Scope : Boolean := False;
Result : Entity_Id;
Stmts : List_Id := No_List;
+ Decls : List_Id := New_List;
Subp_Id : Entity_Id;
-- Start of processing for Expand_Subprogram_Contract
@@ -3181,8 +3429,22 @@ package body Contracts is
-- pragmas to verify the contract assertions of the spec and body in a
-- particular order. The order is as follows:
- -- function Example (...) return ... is
- -- procedure _Postconditions (...) is
+ -- function Original_Code (...) return ... is
+ -- <prologue renamings>
+ -- <inherited preconditions>
+ -- <preconditions from spec>
+ -- <preconditions from body>
+ -- <contract case conditions>
+
+ -- function _Wrapped_Statements (...) return ... is
+ -- <source declarations>
+ -- begin
+ -- <source statements>
+ -- end _Wrapped_Statements;
+
+ -- begin
+ -- declare
+ -- Result : ... renames _Wrapped_Statements;
-- begin
-- <refined postconditions from body>
-- <postconditions from body>
@@ -3190,24 +3452,10 @@ package body Contracts is
-- <inherited postconditions>
-- <contract case consequences>
-- <invariant check of function result>
- -- <invariant and predicate checks of parameters>
- -- end _Postconditions;
-
- -- <inherited preconditions>
- -- <preconditions from spec>
- -- <preconditions from body>
- -- <contract case conditions>
-
- -- <source declarations>
- -- begin
- -- <source statements>
-
- -- _Preconditions (Result);
- -- return Result;
- -- end Example;
-
- -- Routine _Postconditions holds all contract assertions that must be
- -- verified on exit from the related subprogram.
+ -- <invariant and predicate checks of parameters
+ -- return Result;
+ -- end;
+ -- end Original_Code;
-- Step 1: augment contracts list with postconditions associated with
-- Stable_Properties and Stable_Properties'Class aspects. This must
@@ -3222,7 +3470,7 @@ package body Contracts is
-- processing of pragma Contract_Cases because the pragma prepends items
-- to the body declarations.
- Process_Preconditions;
+ Process_Preconditions (Decls);
-- Step 3: Handle all postconditions. This action must come before the
-- processing of pragma Contract_Cases because the pragma appends items
@@ -3234,16 +3482,26 @@ package body Contracts is
-- the processing of invariants and predicates because those append
-- items to list Stmts.
- Process_Contract_Cases (Stmts);
+ Process_Contract_Cases (Stmts, Decls);
-- Step 5: Apply invariant and predicate checks on a function result and
-- all formals. The resulting checks are accumulated in list Stmts.
Add_Invariant_And_Predicate_Checks (Subp_Id, Stmts, Result);
- -- Step 6: Construct procedure _Postconditions
+ -- Step 6: Construct subprogram _wrapped_statements
+
+ -- When no statements are present we still need to insert contract
+ -- related declarations.
+
+ if No (Stmts) then
+ Prepend_List_To (Declarations (Body_Decl), Decls);
- Build_Postconditions_Procedure (Subp_Id, Stmts, Result);
+ -- Otherwise, we need a wrapper
+
+ else
+ Build_Subprogram_Contract_Wrapper (Body_Id, Stmts, Decls, Result);
+ end if;
if Restore_Scope then
End_Scope;
@@ -3448,81 +3706,6 @@ package body Contracts is
Freeze_Contracts;
end Freeze_Previous_Contracts;
- --------------------------
- -- Get_Postcond_Enabled --
- --------------------------
-
- function Get_Postcond_Enabled (Subp : Entity_Id) return Entity_Id is
- Decl : Node_Id;
- begin
- Decl :=
- Next (Unit_Declaration_Node (Postconditions_Proc (Subp)));
- while Present (Decl) loop
-
- if Nkind (Decl) = N_Object_Declaration
- and then Chars (Defining_Identifier (Decl))
- = Name_uPostcond_Enabled
- then
- return Defining_Identifier (Decl);
- end if;
-
- Next (Decl);
- end loop;
-
- return Empty;
- end Get_Postcond_Enabled;
-
- ------------------------------------
- -- Get_Result_Object_For_Postcond --
- ------------------------------------
-
- function Get_Result_Object_For_Postcond
- (Subp : Entity_Id) return Entity_Id
- is
- Decl : Node_Id;
- begin
- Decl :=
- Next (Unit_Declaration_Node (Postconditions_Proc (Subp)));
- while Present (Decl) loop
-
- if Nkind (Decl) = N_Object_Declaration
- and then Chars (Defining_Identifier (Decl))
- = Name_uResult_Object_For_Postcond
- then
- return Defining_Identifier (Decl);
- end if;
-
- Next (Decl);
- end loop;
-
- return Empty;
- end Get_Result_Object_For_Postcond;
-
- -------------------------------------
- -- Get_Return_Success_For_Postcond --
- -------------------------------------
-
- function Get_Return_Success_For_Postcond (Subp : Entity_Id) return Entity_Id
- is
- Decl : Node_Id;
- begin
- Decl :=
- Next (Unit_Declaration_Node (Postconditions_Proc (Subp)));
- while Present (Decl) loop
-
- if Nkind (Decl) = N_Object_Declaration
- and then Chars (Defining_Identifier (Decl))
- = Name_uReturn_Success_For_Postcond
- then
- return Defining_Identifier (Decl);
- end if;
-
- Next (Decl);
- end loop;
-
- return Empty;
- end Get_Return_Success_For_Postcond;
-
---------------------------------
-- Inherit_Subprogram_Contract --
---------------------------------
@@ -3617,6 +3800,65 @@ package body Contracts is
end if;
end Instantiate_Subprogram_Contract;
+ --------------------------
+ -- Is_Prologue_Renaming --
+ --------------------------
+
+ -- This should be turned into a flag and set during the expansion of
+ -- task and protected types when the renamings get generated ???
+
+ function Is_Prologue_Renaming (Decl : Node_Id) return Boolean is
+ Nam : Node_Id;
+ Obj : Entity_Id;
+ Pref : Node_Id;
+ Sel : Node_Id;
+
+ begin
+ if Nkind (Decl) = N_Object_Renaming_Declaration
+ and then not Comes_From_Source (Decl)
+ then
+ Obj := Defining_Entity (Decl);
+ Nam := Name (Decl);
+
+ if Nkind (Nam) = N_Selected_Component then
+ -- Analyze the renaming declaration so we can further examine it
+
+ if not Analyzed (Decl) then
+ Analyze (Decl);
+ end if;
+
+ Pref := Prefix (Nam);
+ Sel := Selector_Name (Nam);
+
+ -- A discriminant renaming appears as
+ -- Discr : constant ... := Prefix.Discr;
+
+ if Ekind (Obj) = E_Constant
+ and then Is_Entity_Name (Sel)
+ and then Present (Entity (Sel))
+ and then Ekind (Entity (Sel)) = E_Discriminant
+ then
+ return True;
+
+ -- A protection field renaming appears as
+ -- Prot : ... := _object._object;
+
+ -- A renamed private component is just a component of
+ -- _object, with an arbitrary name.
+
+ elsif Ekind (Obj) in E_Variable | E_Constant
+ and then Nkind (Pref) = N_Identifier
+ and then Chars (Pref) = Name_uObject
+ and then Nkind (Sel) = N_Identifier
+ then
+ return True;
+ end if;
+ end if;
+ end if;
+
+ return False;
+ end Is_Prologue_Renaming;
+
-----------------------------------
-- Make_Class_Precondition_Subps --
-----------------------------------
diff --git a/gcc/ada/contracts.ads b/gcc/ada/contracts.ads
index 5178373..bde32ff 100644
--- a/gcc/ada/contracts.ads
+++ b/gcc/ada/contracts.ads
@@ -64,6 +64,16 @@ package Contracts is
procedure Analyze_Contracts (L : List_Id);
-- Analyze the contracts of all eligible constructs found in list L
+ procedure Analyze_Pragmas_In_Declarations (Body_Id : Entity_Id);
+ -- Perform early analysis of pragmas at the top of a given subprogram's
+ -- declarations.
+ --
+ -- The purpose of this is to analyze contract-related pragmas for later
+ -- processing, but also to handle other such pragmas before these
+ -- declarations get moved to an internal wrapper as part of contract
+ -- expansion. For example, pragmas Inline, Ghost, Volatile all need to
+ -- apply directly to the subprogram and not be moved to a wrapper.
+
procedure Analyze_Entry_Or_Subprogram_Body_Contract (Body_Id : Entity_Id);
-- Analyze all delayed pragmas chained on the contract of entry or
-- subprogram body Body_Id as if they appeared at the end of a declarative
@@ -177,6 +187,17 @@ package Contracts is
-- Depends
-- Global
+ procedure Build_Entry_Contract_Wrapper (E : Entity_Id; Decl : Node_Id);
+ -- Build the body of a wrapper procedure for an entry or entry family that
+ -- has contract cases, preconditions, or postconditions, and add it to the
+ -- freeze actions of the related synchronized type.
+ --
+ -- The body first verifies the preconditions and case guards of the
+ -- contract cases, then invokes the entry [family], and finally verifies
+ -- the postconditions and the consequences of the contract cases. E denotes
+ -- the entry family. Decl denotes the declaration of the enclosing
+ -- synchronized type.
+
procedure Create_Generic_Contract (Unit : Node_Id);
-- Create a contract node for a generic package, generic subprogram, or a
-- generic body denoted by Unit by collecting all source contract-related
@@ -188,21 +209,6 @@ package Contracts is
-- denoted by Body_Decl. In addition, freeze the contract of the nearest
-- enclosing package body.
- function Get_Postcond_Enabled (Subp : Entity_Id) return Entity_Id;
- -- Get the defining identifier for a subprogram's Postcond_Enabled
- -- object created during the expansion of the subprogram's postconditions.
-
- function Get_Result_Object_For_Postcond (Subp : Entity_Id) return Entity_Id;
- -- Get the defining identifier for a subprogram's
- -- Result_Object_For_Postcond object created during the expansion of the
- -- subprogram's postconditions.
-
- function Get_Return_Success_For_Postcond
- (Subp : Entity_Id) return Entity_Id;
- -- Get the defining identifier for a subprogram's
- -- Return_Success_For_Postcond object created during the expansion of the
- -- subprogram's postconditions.
-
procedure Inherit_Subprogram_Contract
(Subp : Entity_Id;
From_Subp : Entity_Id);
diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb
index d0bcdb0..94e729e 100644
--- a/gcc/ada/debug.adb
+++ b/gcc/ada/debug.adb
@@ -142,7 +142,7 @@ package body Debug is
-- d_a Stop elaboration checks on accept or select statement
-- d_b Use designated type model under No_Dynamic_Accessibility_Checks
-- d_c CUDA compilation : compile for the host
- -- d_d
+ -- d_d CUDA compilation : compile for the device
-- d_e Ignore entry calls and requeue statements for elaboration
-- d_f Issue info messages related to GNATprove usage
-- d_g Disable large static aggregates
@@ -201,7 +201,7 @@ package body Debug is
-- d6 Default access unconstrained to thin pointers
-- d7 Suppress version/source stamp/compilation time for -gnatv/-gnatl
-- d8 Force opposite endianness in packed stuff
- -- d9 Allow lock free implementation
+ -- d9
-- d.1 Enable unnesting of nested procedures
-- d.2 Allow statements in declarative part
@@ -345,8 +345,8 @@ package body Debug is
-- d_a Ignore the effects of pragma Elaborate_All
-- d_b Ignore the effects of pragma Elaborate_Body
- -- d_c
- -- d_d
+ -- d_c CUDA compilation : compile/bind for the host
+ -- d_d CUDA compilation : compile/bind for the device
-- d_e Ignore the effects of pragma Elaborate
-- d_f
-- d_g
@@ -1089,9 +1089,6 @@ package body Debug is
-- opposite endianness from the actual correct value. Useful in
-- testing out code generation from the packed routines.
- -- d9 This allows lock free implementation for protected objects
- -- (see Exp_Ch9).
-
-- d.1 Sets Opt.Unnest_Subprogram_Mode to enable unnesting of subprograms.
-- This special pass does not actually unnest things, but it ensures
-- that a nested procedure does not contain any uplevel references.
diff --git a/gcc/ada/doc/gnat_rm/implementation_defined_aspects.rst b/gcc/ada/doc/gnat_rm/implementation_defined_aspects.rst
index 6ef00c2..4541f2b 100644
--- a/gcc/ada/doc/gnat_rm/implementation_defined_aspects.rst
+++ b/gcc/ada/doc/gnat_rm/implementation_defined_aspects.rst
@@ -317,23 +317,27 @@ The following is a typical example of use:
type List is private with
Iterable => (First => First_Cursor,
Next => Advance,
- Has_Element => Cursor_Has_Element,
- [Element => Get_Element]);
+ Has_Element => Cursor_Has_Element
+ [,Element => Get_Element]
+ [,Last => Last_Cursor]
+ [,Previous => Retreat]);
-* The value denoted by ``First`` must denote a primitive operation of the
- container type that returns a ``Cursor``, which must a be a type declared in
+* The values of ``First`` and ``Last`` are primitive operations of the
+ container type that return a ``Cursor``, which must be a type declared in
the container package or visible from it. For example:
.. code-block:: ada
function First_Cursor (Cont : Container) return Cursor;
+ function Last_Cursor (Cont : Container) return Cursor;
-* The value of ``Next`` is a primitive operation of the container type that takes
- both a container and a cursor and yields a cursor. For example:
+* The values of ``Next`` and ``Previous`` are primitive operations of the container type that take
+ both a container and a cursor and yield a cursor. For example:
.. code-block:: ada
function Advance (Cont : Container; Position : Cursor) return Cursor;
+ function Retreat (Cont : Container; Position : Cursor) return Cursor;
* The value of ``Has_Element`` is a primitive operation of the container type
that takes both a container and a cursor and yields a boolean. For example:
diff --git a/gcc/ada/doc/gnat_rm/implementation_defined_attributes.rst b/gcc/ada/doc/gnat_rm/implementation_defined_attributes.rst
index 1b4f4fe..c25e3d4 100644
--- a/gcc/ada/doc/gnat_rm/implementation_defined_attributes.rst
+++ b/gcc/ada/doc/gnat_rm/implementation_defined_attributes.rst
@@ -606,13 +606,6 @@ in this example:
end Gen;
-Attribute Lock_Free
-===================
-.. index:: Lock_Free
-
-``P'Lock_Free``, where P is a protected object, returns True if a
-pragma ``Lock_Free`` applies to P.
-
Attribute Loop_Entry
====================
.. index:: Loop_Entry
diff --git a/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst b/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst
index 4318a34..53836c9 100644
--- a/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst
+++ b/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst
@@ -2262,7 +2262,8 @@ of GNAT specific extensions are recognized as follows:
will not be executed if the earlier alternative "matches"). All possible
values of the composite type shall be covered. The composite type of the
selector shall be an array or record type that is neither limited
- class-wide.
+ class-wide. Currently, a "when others =>" case choice is required; it is
+ intended that this requirement will be relaxed at some point.
If a subcomponent's subtype does not meet certain restrictions, then
the only value that can be specified for that subcomponent in a case
@@ -3751,7 +3752,12 @@ In addition, each protected subprogram body must satisfy:
* May not dereferenced access values
* Function calls and attribute references must be static
-
+If the Lock_Free aspect is specified to be True for a protected unit
+and the Ceiling_Locking locking policy is in effect, then the run-time
+actions associated with the Ceiling_Locking locking policy (described in
+Ada RM D.3) are not performed when a protected operation of the protected
+unit is executed.
+
Pragma Loop_Invariant
=====================
@@ -7119,7 +7125,7 @@ be.
For the variable case, warnings are never given for unreferenced variables
whose name contains one of the substrings
-``DISCARD, DUMMY, IGNORE, JUNK, UNUSED`` in any casing. Such names
+``DISCARD, DUMMY, IGNORE, JUNK, UNUSE, TMP, TEMP`` in any casing. Such names
are typically to be used in cases where such warnings are expected.
Thus it is never necessary to use ``pragma Unmodified`` for such
variables, though it is harmless to do so.
diff --git a/gcc/ada/doc/gnat_rm/the_gnat_library.rst b/gcc/ada/doc/gnat_rm/the_gnat_library.rst
index 524e3e0..d791f81 100644
--- a/gcc/ada/doc/gnat_rm/the_gnat_library.rst
+++ b/gcc/ada/doc/gnat_rm/the_gnat_library.rst
@@ -120,225 +120,6 @@ instead of ``Character``. The provision of such a package
is specifically authorized by the Ada Reference Manual
(RM A.3.3(27)).
-.. _`Ada.Containers.Formal_Doubly_Linked_Lists_(a-cfdlli.ads)`:
-
-``Ada.Containers.Formal_Doubly_Linked_Lists`` (:file:`a-cfdlli.ads`)
-====================================================================
-
-.. index:: Ada.Containers.Formal_Doubly_Linked_Lists (a-cfdlli.ads)
-
-.. index:: Formal container for doubly linked lists
-
-This child of ``Ada.Containers`` defines a modified version of the
-Ada 2005 container for doubly linked lists, meant to facilitate formal
-verification of code using such containers. The specification of this
-unit is compatible with SPARK 2014.
-
-Note that although this container was designed with formal verification
-in mind, it may well be generally useful in that it is a simplified more
-efficient version than the one defined in the standard. In particular it
-does not have the complex overhead required to detect cursor tampering.
-
-.. _`Ada.Containers.Formal_Hashed_Maps_(a-cfhama.ads)`:
-
-``Ada.Containers.Formal_Hashed_Maps`` (:file:`a-cfhama.ads`)
-============================================================
-
-.. index:: Ada.Containers.Formal_Hashed_Maps (a-cfhama.ads)
-
-.. index:: Formal container for hashed maps
-
-This child of ``Ada.Containers`` defines a modified version of the
-Ada 2005 container for hashed maps, meant to facilitate formal
-verification of code using such containers. The specification of this
-unit is compatible with SPARK 2014.
-
-Note that although this container was designed with formal verification
-in mind, it may well be generally useful in that it is a simplified more
-efficient version than the one defined in the standard. In particular it
-does not have the complex overhead required to detect cursor tampering.
-
-.. _`Ada.Containers.Formal_Hashed_Sets_(a-cfhase.ads)`:
-
-``Ada.Containers.Formal_Hashed_Sets`` (:file:`a-cfhase.ads`)
-============================================================
-
-.. index:: Ada.Containers.Formal_Hashed_Sets (a-cfhase.ads)
-
-.. index:: Formal container for hashed sets
-
-This child of ``Ada.Containers`` defines a modified version of the
-Ada 2005 container for hashed sets, meant to facilitate formal
-verification of code using such containers. The specification of this
-unit is compatible with SPARK 2014.
-
-Note that although this container was designed with formal verification
-in mind, it may well be generally useful in that it is a simplified more
-efficient version than the one defined in the standard. In particular it
-does not have the complex overhead required to detect cursor tampering.
-
-.. _`Ada.Containers.Formal_Ordered_Maps_(a-cforma.ads)`:
-
-``Ada.Containers.Formal_Ordered_Maps`` (:file:`a-cforma.ads`)
-=============================================================
-
-.. index:: Ada.Containers.Formal_Ordered_Maps (a-cforma.ads)
-
-.. index:: Formal container for ordered maps
-
-This child of ``Ada.Containers`` defines a modified version of the
-Ada 2005 container for ordered maps, meant to facilitate formal
-verification of code using such containers. The specification of this
-unit is compatible with SPARK 2014.
-
-Note that although this container was designed with formal verification
-in mind, it may well be generally useful in that it is a simplified more
-efficient version than the one defined in the standard. In particular it
-does not have the complex overhead required to detect cursor tampering.
-
-.. _`Ada.Containers.Formal_Ordered_Sets_(a-cforse.ads)`:
-
-``Ada.Containers.Formal_Ordered_Sets`` (:file:`a-cforse.ads`)
-=============================================================
-
-.. index:: Ada.Containers.Formal_Ordered_Sets (a-cforse.ads)
-
-.. index:: Formal container for ordered sets
-
-This child of ``Ada.Containers`` defines a modified version of the
-Ada 2005 container for ordered sets, meant to facilitate formal
-verification of code using such containers. The specification of this
-unit is compatible with SPARK 2014.
-
-Note that although this container was designed with formal verification
-in mind, it may well be generally useful in that it is a simplified more
-efficient version than the one defined in the standard. In particular it
-does not have the complex overhead required to detect cursor tampering.
-
-.. _`Ada.Containers.Formal_Vectors_(a-cofove.ads)`:
-
-``Ada.Containers.Formal_Vectors`` (:file:`a-cofove.ads`)
-========================================================
-
-.. index:: Ada.Containers.Formal_Vectors (a-cofove.ads)
-
-.. index:: Formal container for vectors
-
-This child of ``Ada.Containers`` defines a modified version of the
-Ada 2005 container for vectors, meant to facilitate formal
-verification of code using such containers. The specification of this
-unit is compatible with SPARK 2014.
-
-Note that although this container was designed with formal verification
-in mind, it may well be generally useful in that it is a simplified more
-efficient version than the one defined in the standard. In particular it
-does not have the complex overhead required to detect cursor tampering.
-
-.. _`Ada.Containers.Formal_Indefinite_Vectors_(a-cfinve.ads)`:
-
-``Ada.Containers.Formal_Indefinite_Vectors`` (:file:`a-cfinve.ads`)
-===================================================================
-
-.. index:: Ada.Containers.Formal_Indefinite_Vectors (a-cfinve.ads)
-
-.. index:: Formal container for vectors
-
-This child of ``Ada.Containers`` defines a modified version of the
-Ada 2005 container for vectors of indefinite elements, meant to
-facilitate formal verification of code using such containers. The
-specification of this unit is compatible with SPARK 2014.
-
-Note that although this container was designed with formal verification
-in mind, it may well be generally useful in that it is a simplified more
-efficient version than the one defined in the standard. In particular it
-does not have the complex overhead required to detect cursor tampering.
-
-.. _`Ada.Containers.Functional_Infinite_Sequences_(a-cfinse.ads)`:
-
-``Ada.Containers.Functional_Infinite_Sequences`` (:file:`a-cfinse.ads`)
-=======================================================================
-
-.. index:: Ada.Containers.Functional_Infinite_Sequences (a-cfinse.ads)
-
-.. index:: Functional Infinite Sequences
-
-This child of ``Ada.Containers`` defines immutable sequences indexed by
-``Big_Integer``. These containers are unbounded and may contain indefinite
-elements. Their API features functions creating new containers from existing
-ones. To remain reasonably efficient, their implementation involves sharing
-between data-structures. As they are functional, that is, no primitives are
-provided which would allow modifying an existing container, these containers
-can still be used safely.
-
-These containers are controlled so that the allocated memory can be reclaimed
-when the container is no longer referenced. Thus, they cannot directly be used
-in contexts where controlled types are not supported.
-The specification of this unit is compatible with SPARK 2014.
-
-.. _`Ada.Containers.Functional_Vectors_(a-cofuve.ads)`:
-
-``Ada.Containers.Functional_Vectors`` (:file:`a-cofuve.ads`)
-============================================================
-
-.. index:: Ada.Containers.Functional_Vectors (a-cofuve.ads)
-
-.. index:: Functional vectors
-
-This child of ``Ada.Containers`` defines immutable vectors. These
-containers are unbounded and may contain indefinite elements. Furthermore, to
-be usable in every context, they are neither controlled nor limited. As they
-are functional, that is, no primitives are provided which would allow modifying
-an existing container, these containers can still be used safely.
-
-Their API features functions creating new containers from existing ones.
-As a consequence, these containers are highly inefficient. They are also
-memory consuming, as the allocated memory is not reclaimed when the container
-is no longer referenced. Thus, they should in general be used in ghost code
-and annotations, so that they can be removed from the final executable. The
-specification of this unit is compatible with SPARK 2014.
-
-.. _`Ada.Containers.Functional_Sets_(a-cofuse.ads)`:
-
-``Ada.Containers.Functional_Sets`` (:file:`a-cofuse.ads`)
-=========================================================
-
-.. index:: Ada.Containers.Functional_Sets (a-cofuse.ads)
-
-.. index:: Functional sets
-
-This child of ``Ada.Containers`` defines immutable sets. These containers are
-unbounded and may contain indefinite elements. Their API features functions
-creating new containers from existing ones. To remain reasonably efficient,
-their implementation involves sharing between data-structures. As they are
-functional, that is, no primitives are provided which would allow modifying an
-existing container, these containers can still be used safely.
-
-These containers are controlled so that the allocated memory can be reclaimed
-when the container is no longer referenced. Thus, they cannot directly be used
-in contexts where controlled types are not supported.
-The specification of this unit is compatible with SPARK 2014.
-
-.. _`Ada.Containers.Functional_Maps_(a-cofuma.ads)`:
-
-``Ada.Containers.Functional_Maps`` (:file:`a-cofuma.ads`)
-=========================================================
-
-.. index:: Ada.Containers.Functional_Maps (a-cofuma.ads)
-
-.. index:: Functional maps
-
-This child of ``Ada.Containers`` defines immutable maps. These containers are
-unbounded and may contain indefinite elements. Their API features functions
-creating new containers from existing ones. To remain reasonably efficient,
-their implementation involves sharing between data-structures. As they are
-functional, that is, no primitives are provided which would allow modifying an
-existing container, these containers can still be used safely.
-
-These containers are controlled so that the allocated memory can be reclaimed
-when the container is no longer referenced. Thus, they cannot directly be used
-in contexts where controlled types are not supported.
-The specification of this unit is compatible with SPARK 2014.
-
.. _`Ada.Containers.Bounded_Holders_(a-coboho.ads)`:
``Ada.Containers.Bounded_Holders`` (:file:`a-coboho.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 37b6e95..6a47809 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
@@ -4455,7 +4455,7 @@ to the default checks required by Ada as described above.
All validity checks are turned on.
That is, :switch:`-gnatVa` is
- equivalent to ``gnatVcdfimoprst``.
+ equivalent to ``gnatVcdefimoprst``.
.. index:: -gnatVc (gcc)
@@ -4463,8 +4463,8 @@ to the default checks required by Ada as described above.
:switch:`-gnatVc`
*Validity checks for copies.*
- The right hand side of assignments, and the initializing values of
- object declarations are validity checked.
+ The right-hand side of assignments, and the (explicit) initializing values
+ of object declarations are validity checked.
.. index:: -gnatVd (gcc)
@@ -4472,12 +4472,14 @@ to the default checks required by Ada as described above.
:switch:`-gnatVd`
*Default (RM) validity checks.*
- Some validity checks are done by default following normal Ada semantics
- (RM 13.9.1 (9-11)).
- A check is done in case statements that the expression is within the range
- of the subtype. If it is not, Constraint_Error is raised.
- For assignments to array components, a check is done that the expression used
- as index is within the range. If it is not, Constraint_Error is raised.
+ Some validity checks are required by Ada (see RM 13.9.1 (9-11)); these
+ (and only these) validity checks are enabled by default.
+ For case statements (and case expressions) that lack a "when others =>"
+ choice, a check is made that the value of the selector expression
+ belongs to its nominal subtype. If it does not, Constraint_Error is raised.
+ For assignments to array components (and for indexed components in some
+ other contexts), a check is made that each index expression belongs to the
+ corresponding index subtype. If it does not, Constraint_Error is raised.
Both these validity checks may be turned off using switch :switch:`-gnatVD`.
They are turned on by default. If :switch:`-gnatVD` is specified, a subsequent
switch :switch:`-gnatVd` will leave the checks turned on.
@@ -4490,28 +4492,31 @@ to the default checks required by Ada as described above.
.. index:: -gnatVe (gcc)
:switch:`-gnatVe`
- *Validity checks for elementary components.*
-
- In the absence of this switch, assignments to record or array components are
- not validity checked, even if validity checks for assignments generally
- (:switch:`-gnatVc`) are turned on. In Ada, assignment of composite values do not
- require valid data, but assignment of individual components does. So for
- example, there is a difference between copying the elements of an array with a
- slice assignment, compared to assigning element by element in a loop. This
- switch allows you to turn off validity checking for components, even when they
- are assigned component by component.
+ *Validity checks for scalar components.*
+ In the absence of this switch, assignments to scalar components of
+ enclosing record or array objects are not validity checked, even if
+ validity checks for assignments generally (:switch:`-gnatVc`) are turned on.
+ Specifying this switch enables such checks.
+ This switch has no effect if the :switch:`-gnatVc` switch is not specified.
.. index:: -gnatVf (gcc)
:switch:`-gnatVf`
*Validity checks for floating-point values.*
- In the absence of this switch, validity checking occurs only for discrete
- values. If :switch:`-gnatVf` is specified, then validity checking also applies
+ Specifying this switch enables validity checking for floating-point
+ values in the same contexts where validity checking is enabled for
+ other scalar values.
+ In the absence of this switch, validity checking is not performed for
+ floating-point values. This takes precedence over other statements about
+ performing validity checking for scalar objects in various scenarios.
+ One way to look at it is that if this switch is not set, then whenever
+ any of the other rules in this section use the word "scalar" they
+ really mean "scalar and not floating-point".
+ If :switch:`-gnatVf` is specified, then validity checking also applies
for floating-point values, and NaNs and infinities are considered invalid,
- as well as out of range values for constrained types. Note that this means
- that standard IEEE infinity mode is not allowed. The exact contexts
+ as well as out-of-range values for constrained types. The exact contexts
in which floating-point values are checked depends on the setting of other
options. For example, :switch:`-gnatVif` or :switch:`-gnatVfi`
(the order does not matter) specifies that floating-point parameters of mode
@@ -4558,7 +4563,8 @@ to the default checks required by Ada as described above.
:switch:`-gnatVo`
*Validity checks for operator and attribute operands.*
- Arguments for predefined operators and attributes are validity checked.
+ Scalar arguments for predefined operators and for attributes are
+ validity checked.
This includes all operators in package ``Standard``,
the shift operators defined as intrinsic in package ``Interfaces``
and operands for attributes such as ``Pos``. Checks are also made
@@ -4572,22 +4578,22 @@ to the default checks required by Ada as described above.
:switch:`-gnatVp`
*Validity checks for parameters.*
- This controls the treatment of parameters within a subprogram (as opposed
- to :switch:`-gnatVi` and :switch:`-gnatVm` which control validity testing
- of parameters on a call. If either of these call options is used, then
- normally an assumption is made within a subprogram that the input arguments
- have been validity checking at the point of call, and do not need checking
- again within a subprogram). If :switch:`-gnatVp` is set, then this assumption
- is not made, and parameters are not assumed to be valid, so their validity
- will be checked (or rechecked) within the subprogram.
-
+ This controls the treatment of formal parameters within a subprogram (as
+ opposed to :switch:`-gnatVi` and :switch:`-gnatVm`, which control validity
+ testing of actual parameters of a call). If either of these call options is
+ specified, then normally an assumption is made within a subprogram that
+ the validity of any incoming formal parameters of the corresponding mode(s)
+ has already been checked at the point of call and does not need rechecking.
+ If :switch:`-gnatVp` is set, then this assumption is not made and so their
+ validity may be checked (or rechecked) within the subprogram. If neither of
+ the two call-related options is specified, then this switch has no effect.
.. index:: -gnatVr (gcc)
:switch:`-gnatVr`
*Validity checks for function returns.*
- The expression in ``return`` statements in functions is validity
+ The expression in simple ``return`` statements in functions is validity
checked.
@@ -4596,9 +4602,10 @@ to the default checks required by Ada as described above.
:switch:`-gnatVs`
*Validity checks for subscripts.*
- All subscripts expressions are checked for validity, whether they appear
- on the right side or left side (in default mode only left side subscripts
- are validity checked).
+ All subscript expressions are checked for validity, whatever context
+ they occur in (in default mode some subscripts are not validity checked;
+ for example, validity checking may be omitted in some cases involving
+ a read of a component of an array).
.. index:: -gnatVt (gcc)
diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads
index ed63019..7ac8cf6 100644
--- a/gcc/ada/einfo.ads
+++ b/gcc/ada/einfo.ads
@@ -4014,9 +4014,7 @@ package Einfo is
-- fully initialized when the full view is frozen.
-- Postconditions_Proc
--- Defined in functions, procedures, entries, and entry families. Refers
--- to the entity of the _Postconditions procedure used to check contract
--- assertions on exit from a subprogram.
+-- Obsolete field which can be removed once CodePeer is fixed ???
-- Predicate_Function (synthesized)
-- Defined in all types. Set for types for which (Has_Predicates is True)
@@ -4767,6 +4765,13 @@ package Einfo is
-- Defined in functions and procedures which have been classified as
-- Is_Primitive_Wrapper. Set to the entity being wrapper.
+-- Wrapped_Statements
+-- Defined in functions, procedures, entries, and entry families. Refers
+-- to the entity of the _Wrapped_Statements procedure which gets
+-- generated as part of the expansion of contracts and postconditions
+-- and contains its enclosing subprogram's original source declarations
+-- and statements.
+
-- LSP_Subprogram
-- Defined in subprogram entities. Set on wrappers created to handle
-- inherited class-wide pre/post conditions that call overridden
@@ -5412,7 +5417,6 @@ package Einfo is
-- Protected_Body_Subprogram
-- Barrier_Function
-- Elaboration_Entity
- -- Postconditions_Proc
-- Entry_Parameters_Type
-- First_Entity
-- Alias (for entry only. Empty)
@@ -5527,7 +5531,6 @@ package Einfo is
-- Protected_Body_Subprogram
-- Next_Inlined_Subprogram
-- Elaboration_Entity (not implicit /=)
- -- Postconditions_Proc (non-generic case only)
-- DT_Position
-- DTC_Entity
-- First_Entity
@@ -5891,7 +5894,6 @@ package Einfo is
-- Protected_Body_Subprogram
-- Next_Inlined_Subprogram
-- Elaboration_Entity
- -- Postconditions_Proc (non-generic case only)
-- DT_Position
-- DTC_Entity
-- First_Entity
diff --git a/gcc/ada/erroutc.adb b/gcc/ada/erroutc.adb
index cab7fec..d0cbe9f 100644
--- a/gcc/ada/erroutc.adb
+++ b/gcc/ada/erroutc.adb
@@ -1317,8 +1317,8 @@ package body Erroutc is
Name_Len := Name_Len - 1;
end if;
- -- If operator name or character literal name, just print it as is
- -- Also print as is if it ends in a right paren (case of x'val(nnn))
+ -- If operator name or character literal name, just print it as is.
+ -- Also print as is if it ends in a right paren (case of x'val(nnn)).
if Name_Buffer (1) = '"'
or else Name_Buffer (1) = '''
@@ -1534,6 +1534,32 @@ package body Erroutc is
elsif Text = "_TYPE_INVARIANT" then
Set_Msg_Str ("TYPE_INVARIANT'CLASS");
+ -- Preserve casing for names that include acronyms
+
+ elsif Text = "Cpp_Class" then
+ Set_Msg_Str ("CPP_Class");
+
+ elsif Text = "Cpp_Constructor" then
+ Set_Msg_Str ("CPP_Constructor");
+
+ elsif Text = "Cpp_Virtual" then
+ Set_Msg_Str ("CPP_Virtual");
+
+ elsif Text = "Cpp_Vtable" then
+ Set_Msg_Str ("CPP_Vtable");
+
+ elsif Text = "Persistent_Bss" then
+ Set_Msg_Str ("Persistent_BSS");
+
+ elsif Text = "Spark_Mode" then
+ Set_Msg_Str ("SPARK_Mode");
+
+ elsif Text = "Use_Vads_Size" then
+ Set_Msg_Str ("Use_VADS_Size");
+
+ elsif Text = "Vads_Size" then
+ Set_Msg_Str ("VADS_size");
+
-- Normal case with no replacement
else
diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb
index 52d47d9..0e79b5d 100644
--- a/gcc/ada/exp_attr.adb
+++ b/gcc/ada/exp_attr.adb
@@ -2079,7 +2079,8 @@ package body Exp_Attr is
case Id is
- -- Attributes related to Ada 2012 iterators
+ -- Attributes related to Ada 2012 iterators. They are only allowed in
+ -- attribute definition clauses and should never be expanded.
when Attribute_Constant_Indexing
| Attribute_Default_Iterator
@@ -2088,7 +2089,7 @@ package body Exp_Attr is
| Attribute_Iterator_Element
| Attribute_Variable_Indexing
=>
- null;
+ raise Program_Error;
-- Internal attributes used to deal with Ada 2012 delayed aspects. These
-- were already rejected by the parser. Thus they shouldn't appear here.
@@ -4883,7 +4884,6 @@ package body Exp_Attr is
---------
when Attribute_Old => Old : declare
- Typ : constant Entity_Id := Etype (N);
CW_Temp : Entity_Id;
CW_Typ : Entity_Id;
Decl : Node_Id;
@@ -4895,24 +4895,25 @@ package body Exp_Attr is
use Old_Attr_Util.Indirect_Temps;
begin
-- Generating C code we don't need to expand this attribute when
- -- we are analyzing the internally built nested postconditions
+ -- we are analyzing the internally built nested _Wrapped_Statements
-- procedure since it will be expanded inline (and later it will
-- be removed by Expand_N_Subprogram_Body). It this expansion is
-- performed in such case then the compiler generates unreferenced
-- extra temporaries.
if Modify_Tree_For_C
- and then Chars (Current_Scope) = Name_uPostconditions
+ and then Chars (Current_Scope) = Name_uWrapped_Statements
then
return;
end if;
- -- Climb the parent chain looking for subprogram _Postconditions
+ -- Climb the parent chain looking for subprogram _Wrapped_Statements
Subp := N;
while Present (Subp) loop
exit when Nkind (Subp) = N_Subprogram_Body
- and then Chars (Defining_Entity (Subp)) = Name_uPostconditions;
+ and then Chars (Defining_Entity (Subp))
+ = Name_uWrapped_Statements;
-- If assertions are disabled, no need to create the declaration
-- that preserves the value. The postcondition pragma in which
@@ -4925,14 +4926,11 @@ package body Exp_Attr is
Subp := Parent (Subp);
end loop;
+ Subp := Empty;
- -- 'Old can only appear in a postcondition, the generated body of
- -- _Postconditions must be in the tree (or inlined if we are
- -- generating C code).
-
- pragma Assert
- (Present (Subp)
- or else (Modify_Tree_For_C and then In_Inlined_Body));
+ -- 'Old can only appear in the case where local contract-related
+ -- wrapper has been generated with the purpose of wrapping the
+ -- original declarations and statements.
Temp := Make_Temporary (Loc, 'T', Pref);
@@ -4952,8 +4950,7 @@ package body Exp_Attr is
-- No need to push the scope when generating C code since the
-- _Postcondition procedure has been inlined.
- else pragma Assert (Modify_Tree_For_C);
- pragma Assert (In_Inlined_Body);
+ else
null;
end if;
@@ -4963,17 +4960,23 @@ package body Exp_Attr is
if Present (Subp) then
Ins_Nod := Subp;
- -- Generating C, the postcondition procedure has been inlined and the
- -- temporary is added before the first declaration of the enclosing
- -- subprogram.
+ -- General case where the postcondtion checks occur after the call
+ -- to _Wrapped_Statements.
- else pragma Assert (Modify_Tree_For_C);
+ else
Ins_Nod := N;
while Nkind (Ins_Nod) /= N_Subprogram_Body loop
Ins_Nod := Parent (Ins_Nod);
end loop;
- Ins_Nod := First (Declarations (Ins_Nod));
+ if Present (Corresponding_Spec (Ins_Nod))
+ and then Present
+ (Wrapped_Statements (Corresponding_Spec (Ins_Nod)))
+ then
+ Ins_Nod := Last (Declarations (Ins_Nod));
+ else
+ Ins_Nod := First (Declarations (Ins_Nod));
+ end if;
end if;
if Eligible_For_Conditional_Evaluation (N) then
@@ -4986,9 +4989,9 @@ package body Exp_Attr is
-- unconditionally) or an evaluation statement (which is
-- to be executed conditionally).
- -------------------------------
- -- Append_For_Indirect_Temp --
- -------------------------------
+ ------------------------------
+ -- Append_For_Indirect_Temp --
+ ------------------------------
procedure Append_For_Indirect_Temp
(N : Node_Id; Is_Eval_Stmt : Boolean)
@@ -5008,7 +5011,7 @@ package body Exp_Attr is
Declare_Indirect_Temporary
(Attr_Prefix => Pref, Indirect_Temp => Temp);
- Insert_Before_And_Analyze (
+ Insert_After_And_Analyze (
Ins_Nod,
Make_If_Statement
(Sloc => Loc,
@@ -5085,7 +5088,17 @@ package body Exp_Attr is
-- to reflect the new placement of the prefix.
if Validity_Checks_On and then Validity_Check_Operands then
- Ensure_Valid (Expression (Decl));
+
+ -- Object declaration that captures the attribute prefix might
+ -- be rewritten into object renaming declaration.
+
+ if Nkind (Decl) = N_Object_Declaration then
+ Ensure_Valid (Expression (Decl));
+ else
+ pragma Assert (Nkind (Decl) = N_Object_Renaming_Declaration
+ and then Is_Rewrite_Substitution (Decl));
+ Ensure_Valid (Name (Decl));
+ end if;
end if;
Rewrite (N, New_Occurrence_Of (Temp, Loc));
@@ -7102,7 +7115,11 @@ package body Exp_Attr is
-- See separate sections below for the generated code in each case.
when Attribute_Valid => Valid : declare
- PBtyp : Entity_Id := Base_Type (Ptyp);
+ PBtyp : Entity_Id := Implementation_Base_Type (Validated_View (Ptyp));
+ pragma Assert (Is_Scalar_Type (PBtyp)
+ or else Serious_Errors_Detected > 0);
+
+ -- The scalar base type, looking through private types
Save_Validity_Checks_On : constant Boolean := Validity_Checks_On;
-- Save the validity checking mode. We always turn off validity
@@ -7149,21 +7166,27 @@ package body Exp_Attr is
Temp := Duplicate_Subexpr (Pref);
end if;
- return
- Make_In (Loc,
- Left_Opnd => Unchecked_Convert_To (PBtyp, Temp),
- Right_Opnd =>
- Make_Range (Loc,
- Low_Bound =>
- Unchecked_Convert_To (PBtyp,
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Ptyp, Loc),
- Attribute_Name => Name_First)),
- High_Bound =>
- Unchecked_Convert_To (PBtyp,
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Ptyp, Loc),
- Attribute_Name => Name_Last))));
+ declare
+ Val_Typ : constant Entity_Id := Validated_View (Ptyp);
+ begin
+ return
+ Make_In (Loc,
+ Left_Opnd => Unchecked_Convert_To (PBtyp, Temp),
+ Right_Opnd =>
+ Make_Range (Loc,
+ Low_Bound =>
+ Unchecked_Convert_To (PBtyp,
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Val_Typ, Loc),
+ Attribute_Name => Name_First)),
+ High_Bound =>
+ Unchecked_Convert_To (PBtyp,
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Val_Typ, Loc),
+ Attribute_Name => Name_Last))));
+ end;
end Make_Range_Test;
-- Local variables
@@ -7185,13 +7208,6 @@ package body Exp_Attr is
Validity_Checks_On := False;
- -- Retrieve the base type. Handle the case where the base type is a
- -- private enumeration type.
-
- if Is_Private_Type (PBtyp) and then Present (Full_View (PBtyp)) then
- PBtyp := Full_View (PBtyp);
- end if;
-
-- Floating-point case. This case is handled by the Valid attribute
-- code in the floating-point attribute run-time library.
@@ -7461,7 +7477,7 @@ package body Exp_Attr is
Uns : constant Boolean :=
Is_Unsigned_Type (Ptyp)
or else (Is_Private_Type (Ptyp)
- and then Is_Unsigned_Type (Btyp));
+ and then Is_Unsigned_Type (PBtyp));
Size : Uint;
P : Node_Id := Pref;
@@ -7946,7 +7962,6 @@ package body Exp_Attr is
| Attribute_Large
| Attribute_Last_Valid
| Attribute_Library_Level
- | Attribute_Lock_Free
| Attribute_Machine_Emax
| Attribute_Machine_Emin
| Attribute_Machine_Mantissa
diff --git a/gcc/ada/exp_ch11.adb b/gcc/ada/exp_ch11.adb
index c4a59f5..98ce886 100644
--- a/gcc/ada/exp_ch11.adb
+++ b/gcc/ada/exp_ch11.adb
@@ -1305,9 +1305,6 @@ package body Exp_Ch11 is
then
pragma Assert (not Is_Thunk (Current_Scope));
Expand_Cleanup_Actions (Parent (N));
-
- else
- Set_First_Real_Statement (N, First (Statements (N)));
end if;
end Expand_N_Handled_Sequence_Of_Statements;
diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb
index 18fb88f..0b7e391 100644
--- a/gcc/ada/exp_ch4.adb
+++ b/gcc/ada/exp_ch4.adb
@@ -6135,6 +6135,10 @@ package body Exp_Ch4 is
-- itself such a slice, in order to catch if expressions with more than
-- two dependent expressions in the source code.
+ -- Also note that this creates variables on branches without an explicit
+ -- scope, causing troubles with e.g. the LLVM IR, so disable this
+ -- optimization when Unnest_Subprogram_Mode (enabled for LLVM).
+
elsif Is_Array_Type (Typ)
and then Number_Dimensions (Typ) = 1
and then not Is_Constrained (Typ)
@@ -6151,6 +6155,7 @@ package body Exp_Ch4 is
and then
OK_For_Single_Subtype (Etype (Thenx), Etype (Prefix (Elsex)))))
and then not Generate_C_Code
+ and then not Unnest_Subprogram_Mode
then
declare
Ityp : constant Entity_Id := Base_Type (Etype (First_Index (Typ)));
diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index fe3bb5b..0873191 100644
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -26,7 +26,6 @@
with Atree; use Atree;
with Aspects; use Aspects;
with Checks; use Checks;
-with Contracts; use Contracts;
with Debug; use Debug;
with Einfo; use Einfo;
with Einfo.Entities; use Einfo.Entities;
@@ -2729,11 +2728,16 @@ package body Exp_Ch6 is
| N_Function_Call
| N_Procedure_Call_Statement);
- -- Check that this is not the call in the body of the wrapper
+ -- Check that this is not the call in the body of the access
+ -- subprogram wrapper or the postconditions wrapper.
if Must_Rewrite_Indirect_Call
and then (not Is_Overloadable (Current_Scope)
- or else not Is_Access_Subprogram_Wrapper (Current_Scope))
+ or else not (Is_Access_Subprogram_Wrapper (Current_Scope)
+ or else
+ (Chars (Current_Scope) = Name_uWrapped_Statements
+ and then Is_Access_Subprogram_Wrapper
+ (Scope (Current_Scope)))))
then
declare
Loc : constant Source_Ptr := Sloc (N);
@@ -4871,11 +4875,12 @@ package body Exp_Ch6 is
then
Must_Inline := not In_Extended_Main_Source_Unit (Subp);
- -- Inline calls to _postconditions when generating C code
+ -- Inline calls to _Wrapped_Statements when generating C
elsif Modify_Tree_For_C
and then In_Same_Extended_Unit (Sloc (Bod), Loc)
- and then Chars (Name (Call_Node)) = Name_uPostconditions
+ and then Chars (Name (Call_Node))
+ = Name_uWrapped_Statements
then
Must_Inline := True;
end if;
@@ -5047,11 +5052,11 @@ package body Exp_Ch6 is
Set_Analyzed (N);
- -- A function which returns a controlled object uses the secondary
- -- stack. Rewrite the call into a temporary which obtains the result of
- -- the function using 'reference.
+ -- Apply the transformation, unless it was already applied manually
- Remove_Side_Effects (N);
+ if Nkind (Par) /= N_Reference then
+ Remove_Side_Effects (N);
+ end if;
-- The side effect removal of the function call produced a temporary.
-- When the context is a case expression, if expression, or expression
@@ -5567,45 +5572,6 @@ package body Exp_Ch6 is
Append_To (Stmts, Stmt);
Set_Analyzed (Stmt);
- -- Call the _Postconditions procedure if the related subprogram
- -- has contract assertions that need to be verified on exit.
-
- -- Also, mark the successful return to signal that postconditions
- -- need to be evaluated when finalization occurs by setting
- -- Return_Success_For_Postcond to be True.
-
- if Ekind (Spec_Id) = E_Procedure
- and then Present (Postconditions_Proc (Spec_Id))
- then
- -- Generate:
- --
- -- Return_Success_For_Postcond := True;
- -- if Postcond_Enabled then
- -- _postconditions;
- -- end if;
-
- Insert_Action (Stmt,
- Make_Assignment_Statement (Loc,
- Name =>
- New_Occurrence_Of
- (Get_Return_Success_For_Postcond (Spec_Id), Loc),
- Expression => New_Occurrence_Of (Standard_True, Loc)));
-
- -- Wrap the call to _postconditions within a test of the
- -- Postcond_Enabled flag to delay postcondition evaluation
- -- until after finalization when required.
-
- Insert_Action (Stmt,
- Make_If_Statement (Loc,
- Condition =>
- New_Occurrence_Of (Get_Postcond_Enabled (Spec_Id), Loc),
- Then_Statements => New_List (
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Occurrence_Of
- (Postconditions_Proc (Spec_Id), Loc)))));
- end if;
-
-- Ada 2022 (AI12-0279): append the call to 'Yield unless this is
-- a generic subprogram (since in such case it will be added to
-- the instantiations).
@@ -6013,44 +5979,6 @@ package body Exp_Ch6 is
Lab_Node : Node_Id;
begin
- -- Call the _Postconditions procedure if the related subprogram has
- -- contract assertions that need to be verified on exit.
-
- -- Also, mark the successful return to signal that postconditions need
- -- to be evaluated when finalization occurs.
-
- if Ekind (Scope_Id) in E_Entry | E_Entry_Family | E_Procedure
- and then Present (Postconditions_Proc (Scope_Id))
- then
- -- Generate:
- --
- -- Return_Success_For_Postcond := True;
- -- if Postcond_Enabled then
- -- _postconditions;
- -- end if;
-
- Insert_Action (N,
- Make_Assignment_Statement (Loc,
- Name =>
- New_Occurrence_Of
- (Get_Return_Success_For_Postcond (Scope_Id), Loc),
- Expression => New_Occurrence_Of (Standard_True, Loc)));
-
- -- Wrap the call to _postconditions within a test of the
- -- Postcond_Enabled flag to delay postcondition evaluation until
- -- after finalization when required.
-
- Insert_Action (N,
- Make_If_Statement (Loc,
- Condition =>
- New_Occurrence_Of (Get_Postcond_Enabled (Scope_Id), Loc),
- Then_Statements => New_List (
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Occurrence_Of
- (Postconditions_Proc (Scope_Id), Loc)))));
- end if;
-
-- Ada 2022 (AI12-0279)
if Has_Yield_Aspect (Scope_Id)
@@ -6995,84 +6923,6 @@ package body Exp_Ch6 is
end;
end if;
- -- Call the _Postconditions procedure if the related function has
- -- contract assertions that need to be verified on exit.
-
- if Ekind (Scope_Id) = E_Function
- and then Present (Postconditions_Proc (Scope_Id))
- then
- -- In the case of discriminated objects, we have created a
- -- constrained subtype above, and used the underlying type. This
- -- transformation is post-analysis and harmless, except that now the
- -- call to the post-condition will be analyzed and the type kinds
- -- have to match.
-
- if Nkind (Exp) = N_Unchecked_Type_Conversion
- and then Is_Private_Type (R_Type) /= Is_Private_Type (Etype (Exp))
- then
- Rewrite (Exp, Expression (Relocate_Node (Exp)));
- end if;
-
- -- We are going to reference the returned value twice in this case,
- -- once in the call to _Postconditions, and once in the actual return
- -- statement, but we can't have side effects happening twice.
-
- Force_Evaluation (Exp, Mode => Strict);
-
- -- Save the return value or a pointer to the return value since we
- -- may need to call postconditions after finalization when cleanup
- -- actions are present.
-
- -- Generate:
- --
- -- Result_Object_For_Postcond := [Exp]'Unrestricted_Access;
-
- Insert_Action (Exp,
- Make_Assignment_Statement (Loc,
- Name =>
- New_Occurrence_Of
- (Get_Result_Object_For_Postcond (Scope_Id), Loc),
- Expression =>
- (if Is_Elementary_Type (Etype (R_Type)) then
- New_Copy_Tree (Exp)
- else
- Make_Attribute_Reference (Loc,
- Attribute_Name => Name_Unrestricted_Access,
- Prefix => New_Copy_Tree (Exp)))));
-
- -- Mark the successful return to signal that postconditions need to
- -- be evaluated when finalization occurs.
-
- -- Generate:
- --
- -- Return_Success_For_Postcond := True;
- -- if Postcond_Enabled then
- -- _Postconditions ([exp]);
- -- end if;
-
- Insert_Action (Exp,
- Make_Assignment_Statement (Loc,
- Name =>
- New_Occurrence_Of
- (Get_Return_Success_For_Postcond (Scope_Id), Loc),
- Expression => New_Occurrence_Of (Standard_True, Loc)));
-
- -- Wrap the call to _postconditions within a test of the
- -- Postcond_Enabled flag to delay postcondition evaluation until
- -- after finalization when required.
-
- Insert_Action (Exp,
- Make_If_Statement (Loc,
- Condition =>
- New_Occurrence_Of (Get_Postcond_Enabled (Scope_Id), Loc),
- Then_Statements => New_List (
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Occurrence_Of
- (Postconditions_Proc (Scope_Id), Loc),
- Parameter_Associations => New_List (New_Copy_Tree (Exp))))));
- end if;
-
-- Ada 2005 (AI-251): If this return statement corresponds with an
-- simple return statement associated with an extended return statement
-- and the type of the returned object is an interface then generate an
diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb
index 7ce39f4..fc4516d 100644
--- a/gcc/ada/exp_ch7.adb
+++ b/gcc/ada/exp_ch7.adb
@@ -28,7 +28,6 @@
-- - transient scopes
with Atree; use Atree;
-with Contracts; use Contracts;
with Debug; use Debug;
with Einfo; use Einfo;
with Einfo.Entities; use Einfo.Entities;
@@ -59,7 +58,6 @@ with Sinfo.Nodes; use Sinfo.Nodes;
with Sinfo.Utils; use Sinfo.Utils;
with Sem; use Sem;
with Sem_Aux; use Sem_Aux;
-with Sem_Ch3; use Sem_Ch3;
with Sem_Ch7; use Sem_Ch7;
with Sem_Ch8; use Sem_Ch8;
with Sem_Res; use Sem_Res;
@@ -306,17 +304,6 @@ package body Exp_Ch7 is
-- such as for task termination. Fin_Id is the finalizer declaration
-- entity.
- procedure Build_Finalizer_Helper
- (N : Node_Id;
- Clean_Stmts : List_Id;
- Mark_Id : Entity_Id;
- Top_Decls : List_Id;
- Defer_Abort : Boolean;
- Fin_Id : out Entity_Id;
- Finalize_Old_Only : Boolean);
- -- An internal routine which does all of the heavy lifting on behalf of
- -- Build_Finalizer.
-
procedure Build_Finalizer_Call (N : Node_Id; Fin_Id : Entity_Id);
-- N is a construct that contains a handled sequence of statements, Fin_Id
-- is the entity of a finalizer. Create an At_End handler that covers the
@@ -927,10 +914,6 @@ package body Exp_Ch7 is
pragma Assert (Present (Param));
pragma Assert (Present (Conc_Typ));
- -- Historical note: In earlier versions of GNAT, there was code
- -- at this point to generate stuff to service entry queues. It is
- -- now abstracted in Build_Protected_Subprogram_Call_Cleanup.
-
Build_Protected_Subprogram_Call_Cleanup
(Specification (N), Conc_Typ, Loc, Stmts);
end;
@@ -1382,18 +1365,17 @@ package body Exp_Ch7 is
end;
end Build_Finalization_Master;
- ----------------------------
- -- Build_Finalizer_Helper --
- ----------------------------
+ ---------------------
+ -- Build_Finalizer --
+ ---------------------
- procedure Build_Finalizer_Helper
+ procedure Build_Finalizer
(N : Node_Id;
Clean_Stmts : List_Id;
Mark_Id : Entity_Id;
Top_Decls : List_Id;
Defer_Abort : Boolean;
- Fin_Id : out Entity_Id;
- Finalize_Old_Only : Boolean)
+ Fin_Id : out Entity_Id)
is
Acts_As_Clean : constant Boolean :=
Present (Mark_Id)
@@ -1687,15 +1669,9 @@ package body Exp_Ch7 is
-- there will need to be multiple finalization routines in the
-- same scope. See Build_Finalizer for details.
- if Finalize_Old_Only then
- Fin_Id :=
- Make_Defining_Identifier (Loc,
- Chars => New_External_Name (Name_uFinalizer_Old));
- else
- Fin_Id :=
- Make_Defining_Identifier (Loc,
- Chars => New_External_Name (Name_uFinalizer));
- end if;
+ Fin_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Name_uFinalizer));
-- The visibility semantics of AT_END handlers force a strange
-- separation of spec and body for stack-related finalizers:
@@ -2066,10 +2042,15 @@ package body Exp_Ch7 is
-- In the case where the last construct to contain a controlled
-- object is either a nested package, an instantiation or a
-- freeze node, the body must be inserted directly after the
- -- construct.
+ -- construct, except if the insertion point is already placed
+ -- after the construct, typically in the statement list.
if Nkind (Last_Top_Level_Ctrl_Construct) in
N_Freeze_Entity | N_Package_Declaration | N_Package_Body
+ and then not
+ (List_Containing (Last_Top_Level_Ctrl_Construct) = Spec_Decls
+ and then Present (Stmts)
+ and then List_Containing (Finalizer_Insert_Nod) = Stmts)
then
Finalizer_Insert_Nod := Last_Top_Level_Ctrl_Construct;
end if;
@@ -2222,26 +2203,9 @@ package body Exp_Ch7 is
Decl := Last_Non_Pragma (Decls);
while Present (Decl) loop
- -- Depending on the value of flag Finalize_Old_Only we determine
- -- which objects get finalized as part of the current finalizer
- -- being built.
-
- -- When True, only temporaries capturing the value of attribute
- -- 'Old are finalized and all other cases are ignored.
-
- -- When False, temporary objects used to capture the value of 'Old
- -- are ignored and all others are considered.
-
- if Finalize_Old_Only
- xor (Nkind (Decl) = N_Object_Declaration
- and then Stores_Attribute_Old_Prefix
- (Defining_Identifier (Decl)))
- then
- null;
-
-- Library-level tagged types
- elsif Nkind (Decl) = N_Full_Type_Declaration then
+ if Nkind (Decl) = N_Full_Type_Declaration then
Typ := Defining_Identifier (Decl);
-- Ignored Ghost types do not need any cleanup actions because
@@ -2546,7 +2510,7 @@ package body Exp_Ch7 is
-- template and not the actually instantiation
-- (which is generated too late for us to process
-- it), so there is no need to update in particular
- -- to update Last_Top_Level_Ctrl_Construct here.
+ -- Last_Top_Level_Ctrl_Construct here.
if Counter_Val > Old_Counter_Val then
Counter_Val := Old_Counter_Val;
@@ -3528,7 +3492,7 @@ package body Exp_Ch7 is
New_Occurrence_Of (DT_Ptr, Loc))));
end Process_Tagged_Type_Declaration;
- -- Start of processing for Build_Finalizer_Helper
+ -- Start of processing for Build_Finalizer
begin
Fin_Id := Empty;
@@ -3685,22 +3649,13 @@ package body Exp_Ch7 is
if Acts_As_Clean or Has_Ctrl_Objs or Has_Tagged_Types then
Create_Finalizer;
end if;
- end Build_Finalizer_Helper;
+ end Build_Finalizer;
--------------------------
-- Build_Finalizer_Call --
--------------------------
procedure Build_Finalizer_Call (N : Node_Id; Fin_Id : Entity_Id) is
- Is_Protected_Subp_Body : constant Boolean :=
- Nkind (N) = N_Subprogram_Body
- and then Is_Protected_Subprogram_Body (N);
- -- Determine whether N denotes the protected version of a subprogram
- -- which belongs to a protected type.
-
- Loc : constant Source_Ptr := Sloc (N);
- HSS : Node_Id := Handled_Statement_Sequence (N);
-
begin
-- Do not perform this expansion in SPARK mode because we do not create
-- finalizers in the first place.
@@ -3730,512 +3685,43 @@ package body Exp_Ch7 is
-- end;
-- end Prot_SubpP;
- if Is_Protected_Subp_Body then
- HSS := Handled_Statement_Sequence (Last (Statements (HSS)));
- end if;
-
- pragma Assert (No (At_End_Proc (HSS)));
- Set_At_End_Proc (HSS, New_Occurrence_Of (Fin_Id, Loc));
-
- -- Attach reference to finalizer to tree, for LLVM use
-
- Set_Parent (At_End_Proc (HSS), HSS);
+ declare
+ Loc : constant Source_Ptr := Sloc (N);
- Analyze (At_End_Proc (HSS));
- Expand_At_End_Handler (HSS, Empty);
+ Is_Protected_Subp_Body : constant Boolean :=
+ Nkind (N) = N_Subprogram_Body
+ and then Is_Protected_Subprogram_Body (N);
+ -- True if N is the protected version of a subprogram that belongs to
+ -- a protected type.
+
+ HSS : constant Node_Id :=
+ (if Is_Protected_Subp_Body
+ then Handled_Statement_Sequence
+ (Last (Statements (Handled_Statement_Sequence (N))))
+ else Handled_Statement_Sequence (N));
+
+ -- We attach the At_End_Proc to the HSS if this is an accept
+ -- statement or extended return statement. Also in the case of
+ -- a protected subprogram, because if Service_Entries raises an
+ -- exception, we do not lock the PO, so we also do not want to
+ -- unlock it.
+
+ Use_HSS : constant Boolean :=
+ Nkind (N) in N_Accept_Statement | N_Extended_Return_Statement
+ or else Is_Protected_Subp_Body;
+
+ At_End_Proc_Bearer : constant Node_Id := (if Use_HSS then HSS else N);
+ begin
+ pragma Assert (No (At_End_Proc (At_End_Proc_Bearer)));
+ Set_At_End_Proc (At_End_Proc_Bearer, New_Occurrence_Of (Fin_Id, Loc));
+ -- Attach reference to finalizer to tree, for LLVM use
+ Set_Parent (At_End_Proc (At_End_Proc_Bearer), At_End_Proc_Bearer);
+ Analyze (At_End_Proc (At_End_Proc_Bearer));
+ Expand_At_End_Handler (At_End_Proc_Bearer, Empty);
+ end;
end Build_Finalizer_Call;
---------------------
- -- Build_Finalizer --
- ---------------------
-
- procedure Build_Finalizer
- (N : Node_Id;
- Clean_Stmts : List_Id;
- Mark_Id : Entity_Id;
- Top_Decls : List_Id;
- Defer_Abort : Boolean;
- Fin_Id : out Entity_Id)
- is
- Def_Ent : constant Entity_Id := Unique_Defining_Entity (N);
- Loc : constant Source_Ptr := Sloc (N);
-
- -- Declarations used for the creation of _finalization_controller
-
- Fin_Old_Id : Entity_Id := Empty;
- Fin_Controller_Id : Entity_Id := Empty;
- Fin_Controller_Decls : List_Id;
- Fin_Controller_Stmts : List_Id;
- Fin_Controller_Body : Node_Id := Empty;
- Fin_Controller_Spec : Node_Id := Empty;
- Postconditions_Call : Node_Id := Empty;
-
- -- Defining identifiers for local objects used to store exception info
-
- Raised_Post_Exception_Id : Entity_Id := Empty;
- Raised_Finalization_Exception_Id : Entity_Id := Empty;
- Saved_Exception_Id : Entity_Id := Empty;
-
- -- Start of processing for Build_Finalizer
-
- begin
- -- Create the general finalization routine
-
- Build_Finalizer_Helper
- (N => N,
- Clean_Stmts => Clean_Stmts,
- Mark_Id => Mark_Id,
- Top_Decls => Top_Decls,
- Defer_Abort => Defer_Abort,
- Fin_Id => Fin_Id,
- Finalize_Old_Only => False);
-
- -- When postconditions are present, expansion gets much more complicated
- -- due to both the fact that they must be called after finalization and
- -- that finalization of 'Old objects must occur after the postconditions
- -- get checked.
-
- -- Additionally, exceptions between general finalization and 'Old
- -- finalization must be propagated correctly and exceptions which happen
- -- during _postconditions need to be saved and reraised after
- -- finalization of 'Old objects.
-
- -- Generate:
- --
- -- Postcond_Enabled := False;
- --
- -- procedure _finalization_controller is
- --
- -- -- Exception capturing and tracking
- --
- -- Saved_Exception : Exception_Occurrence;
- -- Raised_Post_Exception : Boolean := False;
- -- Raised_Finalization_Exception : Boolean := False;
- --
- -- -- Start of processing for _finalization_controller
- --
- -- begin
- -- -- Perform general finalization
- --
- -- begin
- -- _finalizer;
- -- exception
- -- when others =>
- -- -- Save the exception
- --
- -- Raised_Finalization_Exception := True;
- -- Save_Occurrence
- -- (Saved_Exception, Get_Current_Excep.all);
- -- end;
- --
- -- -- Perform postcondition checks after general finalization, but
- -- -- before finalization of 'Old related objects.
- --
- -- if not Raised_Finalization_Exception
- -- and then Return_Success_For_Postcond
- -- then
- -- begin
- -- -- Re-enable postconditions and check them
- --
- -- Postcond_Enabled := True;
- -- _postconditions [(Result_Obj_For_Postcond[.all])];
- -- exception
- -- when others =>
- -- -- Save the exception
- --
- -- Raised_Post_Exception := True;
- -- Save_Occurrence
- -- (Saved_Exception, Get_Current_Excep.all);
- -- end;
- -- end if;
- --
- -- -- Finally finalize 'Old related objects
- --
- -- begin
- -- _finalizer_old;
- -- exception
- -- when others =>
- -- -- Reraise the previous finalization error if there is
- -- -- one.
- --
- -- if Raised_Finalization_Exception then
- -- Reraise_Occurrence (Saved_Exception);
- -- end if;
- --
- -- -- Otherwise, reraise the current one
- --
- -- raise;
- -- end;
- --
- -- -- Reraise any saved exception
- --
- -- if Raised_Finalization_Exception
- -- or else Raised_Post_Exception
- -- then
- -- Reraise_Occurrence (Saved_Exception);
- -- end if;
- -- end _finalization_controller;
-
- if Nkind (N) = N_Subprogram_Body
- and then Present (Postconditions_Proc (Def_Ent))
- then
- Fin_Controller_Stmts := New_List;
- Fin_Controller_Decls := New_List;
-
- -- Build the 'Old finalizer
-
- Build_Finalizer_Helper
- (N => N,
- Clean_Stmts => Empty_List,
- Mark_Id => Mark_Id,
- Top_Decls => Top_Decls,
- Defer_Abort => Defer_Abort,
- Fin_Id => Fin_Old_Id,
- Finalize_Old_Only => True);
-
- -- Create local declarations for _finalization_controller needed for
- -- saving exceptions.
- --
- -- Generate:
- --
- -- Saved_Exception : Exception_Occurrence;
- -- Raised_Post_Exception : Boolean := False;
- -- Raised_Finalization_Exception : Boolean := False;
-
- Saved_Exception_Id := Make_Temporary (Loc, 'S');
- Raised_Post_Exception_Id := Make_Temporary (Loc, 'P');
- Raised_Finalization_Exception_Id := Make_Temporary (Loc, 'F');
-
- Append_List_To (Fin_Controller_Decls, New_List (
- Make_Object_Declaration (Loc,
- Defining_Identifier => Saved_Exception_Id,
- Object_Definition =>
- New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc)),
- Make_Object_Declaration (Loc,
- Defining_Identifier => Raised_Post_Exception_Id,
- Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
- Expression => New_Occurrence_Of (Standard_False, Loc)),
- Make_Object_Declaration (Loc,
- Defining_Identifier => Raised_Finalization_Exception_Id,
- Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
- Expression => New_Occurrence_Of (Standard_False, Loc))));
-
- -- Call _finalizer and save any exceptions which occur
-
- -- Generate:
- --
- -- begin
- -- _finalizer;
- -- exception
- -- when others =>
- -- Raised_Finalization_Exception := True;
- -- Save_Occurrence
- -- (Saved_Exception, Get_Current_Excep.all);
- -- end;
-
- if Present (Fin_Id) then
- Append_To (Fin_Controller_Stmts,
- Make_Block_Statement (Loc,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (
- Make_Procedure_Call_Statement (Loc,
- Name => New_Occurrence_Of (Fin_Id, Loc))),
- Exception_Handlers => New_List (
- Make_Exception_Handler (Loc,
- Exception_Choices => New_List (
- Make_Others_Choice (Loc)),
- Statements => New_List (
- Make_Assignment_Statement (Loc,
- Name =>
- New_Occurrence_Of
- (Raised_Finalization_Exception_Id, Loc),
- Expression =>
- New_Occurrence_Of (Standard_True, Loc)),
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Occurrence_Of
- (RTE (RE_Save_Occurrence), Loc),
- Parameter_Associations => New_List (
- New_Occurrence_Of
- (Saved_Exception_Id, Loc),
- Make_Explicit_Dereference (Loc,
- Prefix =>
- Make_Function_Call (Loc,
- Name =>
- Make_Explicit_Dereference (Loc,
- Prefix =>
- New_Occurrence_Of
- (RTE (RE_Get_Current_Excep),
- Loc))))))))))));
- end if;
-
- -- Create the call to postconditions based on the kind of the current
- -- subprogram, and the type of the Result_Obj_For_Postcond.
-
- -- Generate:
- --
- -- _postconditions (Result_Obj_For_Postcond[.all]);
- --
- -- or
- --
- -- _postconditions;
-
- if Ekind (Def_Ent) = E_Procedure then
- Postconditions_Call :=
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Occurrence_Of
- (Postconditions_Proc (Def_Ent), Loc));
- else
- Postconditions_Call :=
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Occurrence_Of
- (Postconditions_Proc (Def_Ent), Loc),
- Parameter_Associations => New_List (
- (if Is_Elementary_Type (Etype (Def_Ent)) then
- New_Occurrence_Of
- (Get_Result_Object_For_Postcond
- (Def_Ent), Loc)
- else
- Make_Explicit_Dereference (Loc,
- New_Occurrence_Of
- (Get_Result_Object_For_Postcond
- (Def_Ent), Loc)))));
- end if;
-
- -- Call _postconditions when no general finalization exceptions have
- -- occurred taking care to enable the postconditions and save any
- -- exception occurrences.
-
- -- Generate:
- --
- -- if not Raised_Finalization_Exception
- -- and then Return_Success_For_Postcond
- -- then
- -- begin
- -- Postcond_Enabled := True;
- -- _postconditions [(Result_Obj_For_Postcond[.all])];
- -- exception
- -- when others =>
- -- Raised_Post_Exception := True;
- -- Save_Occurrence
- -- (Saved_Exception, Get_Current_Excep.all);
- -- end;
- -- end if;
-
- Append_To (Fin_Controller_Stmts,
- Make_If_Statement (Loc,
- Condition =>
- Make_And_Then (Loc,
- Left_Opnd =>
- Make_Op_Not (Loc,
- Right_Opnd =>
- New_Occurrence_Of
- (Raised_Finalization_Exception_Id, Loc)),
- Right_Opnd =>
- New_Occurrence_Of
- (Get_Return_Success_For_Postcond (Def_Ent), Loc)),
- Then_Statements => New_List (
- Make_Block_Statement (Loc,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (
- Make_Assignment_Statement (Loc,
- Name =>
- New_Occurrence_Of
- (Get_Postcond_Enabled (Def_Ent), Loc),
- Expression =>
- New_Occurrence_Of
- (Standard_True, Loc)),
- Postconditions_Call),
- Exception_Handlers => New_List (
- Make_Exception_Handler (Loc,
- Exception_Choices => New_List (
- Make_Others_Choice (Loc)),
- Statements => New_List (
- Make_Assignment_Statement (Loc,
- Name =>
- New_Occurrence_Of
- (Raised_Post_Exception_Id, Loc),
- Expression =>
- New_Occurrence_Of (Standard_True, Loc)),
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Occurrence_Of
- (RTE (RE_Save_Occurrence), Loc),
- Parameter_Associations => New_List (
- New_Occurrence_Of
- (Saved_Exception_Id, Loc),
- Make_Explicit_Dereference (Loc,
- Prefix =>
- Make_Function_Call (Loc,
- Name =>
- Make_Explicit_Dereference (Loc,
- Prefix =>
- New_Occurrence_Of
- (RTE (RE_Get_Current_Excep),
- Loc))))))))))))));
-
- -- Call _finalizer_old and reraise any exception that occurred during
- -- initial finalization within the exception handler. Otherwise,
- -- propagate the current exception.
-
- -- Generate:
- --
- -- begin
- -- _finalizer_old;
- -- exception
- -- when others =>
- -- if Raised_Finalization_Exception then
- -- Reraise_Occurrence (Saved_Exception);
- -- end if;
- -- raise;
- -- end;
-
- if Present (Fin_Old_Id) then
- Append_To (Fin_Controller_Stmts,
- Make_Block_Statement (Loc,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (
- Make_Procedure_Call_Statement (Loc,
- Name => New_Occurrence_Of (Fin_Old_Id, Loc))),
- Exception_Handlers => New_List (
- Make_Exception_Handler (Loc,
- Exception_Choices => New_List (
- Make_Others_Choice (Loc)),
- Statements => New_List (
- Make_If_Statement (Loc,
- Condition =>
- New_Occurrence_Of
- (Raised_Finalization_Exception_Id, Loc),
- Then_Statements => New_List (
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Occurrence_Of
- (RTE (RE_Reraise_Occurrence), Loc),
- Parameter_Associations => New_List (
- New_Occurrence_Of
- (Saved_Exception_Id, Loc))))),
- Make_Raise_Statement (Loc)))))));
- end if;
-
- -- Once finalization is complete reraise any pending exceptions
-
- -- Generate:
- --
- -- if Raised_Post_Exception
- -- or else Raised_Finalization_Exception
- -- then
- -- Reraise_Occurrence (Saved_Exception);
- -- end if;
-
- Append_To (Fin_Controller_Stmts,
- Make_If_Statement (Loc,
- Condition =>
- Make_Or_Else (Loc,
- Left_Opnd =>
- New_Occurrence_Of
- (Raised_Post_Exception_Id, Loc),
- Right_Opnd =>
- New_Occurrence_Of
- (Raised_Finalization_Exception_Id, Loc)),
- Then_Statements => New_List (
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Occurrence_Of (RTE (RE_Reraise_Occurrence), Loc),
- Parameter_Associations => New_List (
- New_Occurrence_Of
- (Saved_Exception_Id, Loc))))));
-
- -- Make the finalization controller subprogram body and declaration.
-
- -- Generate:
- -- procedure _finalization_controller;
- --
- -- procedure _finalization_controller is
- -- begin
- -- [Fin_Controller_Stmts];
- -- end;
-
- Fin_Controller_Id :=
- Make_Defining_Identifier (Loc,
- Chars => New_External_Name (Name_uFinalization_Controller));
-
- Fin_Controller_Spec :=
- Make_Subprogram_Declaration (Loc,
- Specification =>
- Make_Procedure_Specification (Loc,
- Defining_Unit_Name => Fin_Controller_Id));
-
- Fin_Controller_Body :=
- Make_Subprogram_Body (Loc,
- Specification =>
- Make_Procedure_Specification (Loc,
- Defining_Unit_Name =>
- Make_Defining_Identifier (Loc, Chars (Fin_Controller_Id))),
- Declarations => Fin_Controller_Decls,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => Fin_Controller_Stmts));
-
- -- Disable _postconditions calls which get generated before return
- -- statements to delay their evaluation until after finalization.
-
- -- This is done by way of the local Postcond_Enabled object which is
- -- initially assigned to True - we then create an assignment within
- -- the subprogram's declaration to make it False and assign it back
- -- to True before _postconditions is called within
- -- _finalization_controller.
-
- -- Generate:
- --
- -- Postcond_Enable := False;
-
- -- Note that we do not disable early evaluation of postconditions
- -- for return types that are unconstrained or have unconstrained
- -- elements since the temporary result object could get allocated on
- -- the stack and be out of scope at the point where we perform late
- -- evaluation of postconditions - leading to uninitialized memory
- -- reads.
-
- -- This disabling of early evaluation can lead to incorrect run-time
- -- semantics where functions with unconstrained elements will
- -- have their corresponding postconditions evaluated before
- -- finalization. The proper solution here is to generate a wrapper
- -- to capture the result instead of using multiple flags and playing
- -- with flags which does not even work in all cases ???
-
- if not Has_Unconstrained_Elements (Etype (Def_Ent))
- or else (Is_Array_Type (Etype (Def_Ent))
- and then not Is_Constrained (Etype (Def_Ent)))
- then
- Append_To (Top_Decls,
- Make_Assignment_Statement (Loc,
- Name =>
- New_Occurrence_Of
- (Get_Postcond_Enabled (Def_Ent), Loc),
- Expression =>
- New_Occurrence_Of
- (Standard_False, Loc)));
- end if;
-
- -- Add the subprogram to the list of declarations an analyze it
-
- Append_To (Top_Decls, Fin_Controller_Spec);
- Analyze (Fin_Controller_Spec);
- Insert_After (Fin_Controller_Spec, Fin_Controller_Body);
- Analyze (Fin_Controller_Body, Suppress => All_Checks);
-
- -- Return the finalization controller as the result Fin_Id
-
- Fin_Id := Fin_Controller_Id;
- end if;
- end Build_Finalizer;
-
- ---------------------
-- Build_Late_Proc --
---------------------
@@ -5544,12 +5030,6 @@ package body Exp_Ch7 is
Nkind (N) = N_Block_Statement
and then Present (Cleanup_Actions (N));
- Has_Postcondition : constant Boolean :=
- Nkind (N) = N_Subprogram_Body
- and then Present
- (Postconditions_Proc
- (Unique_Defining_Entity (N)));
-
Actions_Required : constant Boolean :=
Requires_Cleanup_Actions (N, True)
or else Is_Asynchronous_Call
@@ -5560,47 +5040,9 @@ package body Exp_Ch7 is
or else Needs_Sec_Stack_Mark
or else Needs_Custom_Cleanup;
- HSS : Node_Id := Handled_Statement_Sequence (N);
Loc : Source_Ptr;
Cln : List_Id;
- procedure Wrap_HSS_In_Block;
- -- Move HSS inside a new block along with the original exception
- -- handlers. Make the newly generated block the sole statement of HSS.
-
- -----------------------
- -- Wrap_HSS_In_Block --
- -----------------------
-
- procedure Wrap_HSS_In_Block is
- Block : constant Node_Id :=
- Make_Block_Statement (Loc, Handled_Statement_Sequence => HSS);
- Block_Id : constant Entity_Id :=
- New_Internal_Entity (E_Block, Current_Scope, Loc, 'B');
- End_Lab : constant Node_Id := End_Label (HSS);
- -- Preserve end label to provide proper cross-reference information
-
- begin
- Set_Identifier (Block, New_Occurrence_Of (Block_Id, Loc));
- Set_Etype (Block_Id, Standard_Void_Type);
- Set_Block_Node (Block_Id, Identifier (Block));
-
- -- Signal the finalization machinery that this particular block
- -- contains the original context.
-
- Set_Is_Finalization_Wrapper (Block);
-
- HSS := Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (Block),
- End_Label => End_Lab);
- Set_First_Real_Statement (HSS, Block);
- Set_Handled_Statement_Sequence (N, HSS);
-
- if Nkind (N) = N_Subprogram_Body then
- Set_Has_Nested_Block_With_Handler (Scop);
- end if;
- end Wrap_HSS_In_Block;
-
-- Start of processing for Expand_Cleanup_Actions
begin
@@ -5671,12 +5113,14 @@ package body Exp_Ch7 is
Cln := No_List;
end if;
- declare
- Decls : List_Id := Declarations (N);
- Fin_Id : Entity_Id;
- Mark : Entity_Id := Empty;
- New_Decls : List_Id;
+ if No (Declarations (N)) then
+ Set_Declarations (N, New_List);
+ end if;
+ declare
+ Decls : constant List_Id := Declarations (N);
+ Fin_Id : Entity_Id;
+ Mark : Entity_Id := Empty;
begin
-- If we are generating expanded code for debugging purposes, use the
-- Sloc of the point of insertion for the cleanup code. The Sloc will
@@ -5703,109 +5147,22 @@ package body Exp_Ch7 is
Establish_Task_Master (N);
end if;
- New_Decls := New_List;
-
-- If secondary stack is in use, generate:
--
-- Mnn : constant Mark_Id := SS_Mark;
if Needs_Sec_Stack_Mark then
+ Set_Uses_Sec_Stack (Scop, False); -- avoid duplicate SS marks
Mark := Make_Temporary (Loc, 'M');
- Append_To (New_Decls, Build_SS_Mark_Call (Loc, Mark));
- Set_Uses_Sec_Stack (Scop, False);
- end if;
-
- -- If exception handlers are present in a non-subprogram
- -- construct, wrap the sequence of statements in a block.
- -- Otherwise, code can be moved so that the wrong handlers
- -- apply. It is important not to do this for function bodies,
- -- because otherwise transient finalizable objects created
- -- by a return statement get finalized too late. It is harmless
- -- not to do this for procedures.
-
- if Present (Exception_Handlers (HSS))
- and then Nkind (N) /= N_Subprogram_Body
- then
- Wrap_HSS_In_Block;
-
- -- Ensure that the First_Real_Statement field is set
-
- elsif No (First_Real_Statement (HSS)) then
- Set_First_Real_Statement (HSS, First (Statements (HSS)));
- end if;
-
- -- Do not move the Activation_Chain declaration in the context of
- -- task allocation blocks. Task allocation blocks use _chain in their
- -- cleanup handlers and gigi complains if it is declared in the
- -- sequence of statements of the scope that declares the handler.
-
- if Is_Task_Allocation then
- declare
- Chain_Decl : constant N_Object_Declaration_Id :=
- Parent (Activation_Chain_Entity (N));
- pragma Assert (List_Containing (Chain_Decl) = Decls);
- begin
- Remove (Chain_Decl);
- Prepend_To (New_Decls, Chain_Decl);
- end;
- end if;
-
- -- Move the _postconditions subprogram declaration and its associated
- -- objects into the declarations section so that it is callable
- -- within _postconditions.
-
- if Has_Postcondition then
declare
- Decl : Node_Id;
- Prev_Decl : Node_Id;
-
+ Mark_Call : constant Node_Id := Build_SS_Mark_Call (Loc, Mark);
begin
- Decl :=
- Prev (Subprogram_Body
- (Postconditions_Proc (Current_Subprogram)));
- while Present (Decl) loop
- Prev_Decl := Prev (Decl);
-
- Remove (Decl);
- Prepend_To (New_Decls, Decl);
-
- exit when Nkind (Decl) = N_Subprogram_Declaration
- and then Chars (Corresponding_Body (Decl))
- = Name_uPostconditions;
-
- Decl := Prev_Decl;
- end loop;
+ Prepend_To (Decls, Mark_Call);
+ Analyze (Mark_Call);
end;
end if;
- -- Ensure the presence of a declaration list in order to successfully
- -- append all original statements to it.
-
- if No (Decls) then
- Set_Declarations (N, New_List);
- Decls := Declarations (N);
- end if;
-
- -- Move the declarations into the sequence of statements in order to
- -- have them protected by the At_End handler. It may seem weird to
- -- put declarations in the sequence of statement but in fact nothing
- -- forbids that at the tree level.
-
- Append_List_To (Decls, Statements (HSS));
- Set_Statements (HSS, Decls);
-
- -- Reset the Sloc of the handled statement sequence to properly
- -- reflect the new initial "statement" in the sequence.
-
- Set_Sloc (HSS, Sloc (First (Decls)));
-
- -- The declarations of finalizer spec and auxiliary variables replace
- -- the old declarations that have been moved inward.
-
- Set_Declarations (N, New_Decls);
- Analyze_Declarations (New_Decls);
-
-- Generate finalization calls for all controlled objects appearing
-- in the statements of N. Add context specific cleanup for various
-- constructs.
@@ -5814,7 +5171,7 @@ package body Exp_Ch7 is
(N => N,
Clean_Stmts => Build_Cleanup_Statements (N, Cln),
Mark_Id => Mark,
- Top_Decls => New_Decls,
+ Top_Decls => Decls,
Defer_Abort => Nkind (Original_Node (N)) = N_Task_Body
or else Is_Master,
Fin_Id => Fin_Id);
@@ -10103,9 +9460,6 @@ package body Exp_Ch7 is
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (Loop_Copy)));
- Set_First_Real_Statement
- (Handled_Statement_Sequence (Local_Body), Loop_Copy);
-
Rewrite (Loop_Stmt, Local_Body);
Analyze (Loop_Stmt);
diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb
index ed6844e..8abff55 100644
--- a/gcc/ada/exp_ch9.adb
+++ b/gcc/ada/exp_ch9.adb
@@ -26,6 +26,7 @@
with Atree; use Atree;
with Aspects; use Aspects;
with Checks; use Checks;
+with Contracts; use Contracts;
with Einfo; use Einfo;
with Einfo.Entities; use Einfo.Entities;
with Einfo.Utils; use Einfo.Utils;
@@ -134,15 +135,6 @@ package body Exp_Ch9 is
-- Build a specification for a function implementing the protected entry
-- barrier of the specified entry body.
- procedure Build_Contract_Wrapper (E : Entity_Id; Decl : Node_Id);
- -- Build the body of a wrapper procedure for an entry or entry family that
- -- has contract cases, preconditions, or postconditions. The body gathers
- -- the executable contract items and expands them in the usual way, and
- -- performs the entry call itself. This way preconditions are evaluated
- -- before the call is queued. E is the entry in question, and Decl is the
- -- enclosing synchronized type declaration at whose freeze point the
- -- generated body is analyzed.
-
function Build_Corresponding_Record
(N : Node_Id;
Ctyp : Entity_Id;
@@ -1296,288 +1288,6 @@ package body Exp_Ch9 is
Set_Master_Id (Typ, Master_Id);
end Build_Class_Wide_Master;
- ----------------------------
- -- Build_Contract_Wrapper --
- ----------------------------
-
- procedure Build_Contract_Wrapper (E : Entity_Id; Decl : Node_Id) is
- Conc_Typ : constant Entity_Id := Scope (E);
- Loc : constant Source_Ptr := Sloc (E);
-
- procedure Add_Discriminant_Renamings
- (Obj_Id : Entity_Id;
- Decls : List_Id);
- -- Add renaming declarations for all discriminants of concurrent type
- -- Conc_Typ. Obj_Id is the entity of the wrapper formal parameter which
- -- represents the concurrent object.
-
- procedure Add_Matching_Formals
- (Formals : List_Id;
- Actuals : in out List_Id);
- -- Add formal parameters that match those of entry E to list Formals.
- -- The routine also adds matching actuals for the new formals to list
- -- Actuals.
-
- procedure Transfer_Pragma (Prag : Node_Id; To : in out List_Id);
- -- Relocate pragma Prag to list To. The routine creates a new list if
- -- To does not exist.
-
- --------------------------------
- -- Add_Discriminant_Renamings --
- --------------------------------
-
- procedure Add_Discriminant_Renamings
- (Obj_Id : Entity_Id;
- Decls : List_Id)
- is
- Discr : Entity_Id;
-
- begin
- -- Inspect the discriminants of the concurrent type and generate a
- -- renaming for each one.
-
- if Has_Discriminants (Conc_Typ) then
- Discr := First_Discriminant (Conc_Typ);
- while Present (Discr) loop
- Prepend_To (Decls,
- Make_Object_Renaming_Declaration (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Chars (Discr)),
- Subtype_Mark =>
- New_Occurrence_Of (Etype (Discr), Loc),
- Name =>
- Make_Selected_Component (Loc,
- Prefix => New_Occurrence_Of (Obj_Id, Loc),
- Selector_Name =>
- Make_Identifier (Loc, Chars (Discr)))));
-
- Next_Discriminant (Discr);
- end loop;
- end if;
- end Add_Discriminant_Renamings;
-
- --------------------------
- -- Add_Matching_Formals --
- --------------------------
-
- procedure Add_Matching_Formals
- (Formals : List_Id;
- Actuals : in out List_Id)
- is
- Formal : Entity_Id;
- New_Formal : Entity_Id;
-
- begin
- -- Inspect the formal parameters of the entry and generate a new
- -- matching formal with the same name for the wrapper. A reference
- -- to the new formal becomes an actual in the entry call.
-
- Formal := First_Formal (E);
- while Present (Formal) loop
- New_Formal := Make_Defining_Identifier (Loc, Chars (Formal));
- Append_To (Formals,
- Make_Parameter_Specification (Loc,
- Defining_Identifier => New_Formal,
- In_Present => In_Present (Parent (Formal)),
- Out_Present => Out_Present (Parent (Formal)),
- Parameter_Type =>
- New_Occurrence_Of (Etype (Formal), Loc)));
-
- if No (Actuals) then
- Actuals := New_List;
- end if;
-
- Append_To (Actuals, New_Occurrence_Of (New_Formal, Loc));
- Next_Formal (Formal);
- end loop;
- end Add_Matching_Formals;
-
- ---------------------
- -- Transfer_Pragma --
- ---------------------
-
- procedure Transfer_Pragma (Prag : Node_Id; To : in out List_Id) is
- New_Prag : Node_Id;
-
- begin
- if No (To) then
- To := New_List;
- end if;
-
- New_Prag := Relocate_Node (Prag);
-
- Set_Analyzed (New_Prag, False);
- Append (New_Prag, To);
- end Transfer_Pragma;
-
- -- Local variables
-
- Items : constant Node_Id := Contract (E);
- Actuals : List_Id := No_List;
- Call : Node_Id;
- Call_Nam : Node_Id;
- Decls : List_Id := No_List;
- Formals : List_Id;
- Has_Pragma : Boolean := False;
- Index_Id : Entity_Id;
- Obj_Id : Entity_Id;
- Prag : Node_Id;
- Wrapper_Id : Entity_Id;
-
- -- Start of processing for Build_Contract_Wrapper
-
- begin
- -- This routine generates a specialized wrapper for a protected or task
- -- entry [family] which implements precondition/postcondition semantics.
- -- Preconditions and case guards of contract cases are checked before
- -- the protected action or rendezvous takes place. Postconditions and
- -- consequences of contract cases are checked after the protected action
- -- or rendezvous takes place. The structure of the generated wrapper is
- -- as follows:
-
- -- procedure Wrapper
- -- (Obj_Id : Conc_Typ; -- concurrent object
- -- [Index : Index_Typ;] -- index of entry family
- -- [Formal_1 : ...; -- parameters of original entry
- -- Formal_N : ...])
- -- is
- -- [Discr_1 : ... renames Obj_Id.Discr_1; -- discriminant
- -- Discr_N : ... renames Obj_Id.Discr_N;] -- renamings
-
- -- <precondition checks>
- -- <case guard checks>
-
- -- procedure _Postconditions is
- -- begin
- -- <postcondition checks>
- -- <consequence checks>
- -- end _Postconditions;
-
- -- begin
- -- Entry_Call (Obj_Id, [Index,] [Formal_1, Formal_N]);
- -- _Postconditions;
- -- end Wrapper;
-
- -- Create the wrapper only when the entry has at least one executable
- -- contract item such as contract cases, precondition or postcondition.
-
- if Present (Items) then
-
- -- Inspect the list of pre/postconditions and transfer all available
- -- pragmas to the declarative list of the wrapper.
-
- Prag := Pre_Post_Conditions (Items);
- while Present (Prag) loop
- if Pragma_Name_Unmapped (Prag) in Name_Postcondition
- | Name_Precondition
- and then Is_Checked (Prag)
- then
- Has_Pragma := True;
- Transfer_Pragma (Prag, To => Decls);
- end if;
-
- Prag := Next_Pragma (Prag);
- end loop;
-
- -- Inspect the list of test/contract cases and transfer only contract
- -- cases pragmas to the declarative part of the wrapper.
-
- Prag := Contract_Test_Cases (Items);
- while Present (Prag) loop
- if Pragma_Name (Prag) = Name_Contract_Cases
- and then Is_Checked (Prag)
- then
- Has_Pragma := True;
- Transfer_Pragma (Prag, To => Decls);
- end if;
-
- Prag := Next_Pragma (Prag);
- end loop;
- end if;
-
- -- The entry lacks executable contract items and a wrapper is not needed
-
- if not Has_Pragma then
- return;
- end if;
-
- -- Create the profile of the wrapper. The first formal parameter is the
- -- concurrent object.
-
- Obj_Id :=
- Make_Defining_Identifier (Loc,
- Chars => New_External_Name (Chars (Conc_Typ), 'A'));
-
- Formals := New_List (
- Make_Parameter_Specification (Loc,
- Defining_Identifier => Obj_Id,
- Out_Present => True,
- In_Present => True,
- Parameter_Type => New_Occurrence_Of (Conc_Typ, Loc)));
-
- -- Construct the call to the original entry. The call will be gradually
- -- augmented with an optional entry index and extra parameters.
-
- Call_Nam :=
- Make_Selected_Component (Loc,
- Prefix => New_Occurrence_Of (Obj_Id, Loc),
- Selector_Name => New_Occurrence_Of (E, Loc));
-
- -- When creating a wrapper for an entry family, the second formal is the
- -- entry index.
-
- if Ekind (E) = E_Entry_Family then
- Index_Id := Make_Defining_Identifier (Loc, Name_I);
-
- Append_To (Formals,
- Make_Parameter_Specification (Loc,
- Defining_Identifier => Index_Id,
- Parameter_Type =>
- New_Occurrence_Of (Entry_Index_Type (E), Loc)));
-
- -- The call to the original entry becomes an indexed component to
- -- accommodate the entry index.
-
- Call_Nam :=
- Make_Indexed_Component (Loc,
- Prefix => Call_Nam,
- Expressions => New_List (New_Occurrence_Of (Index_Id, Loc)));
- end if;
-
- -- Add formal parameters to match those of the entry and build actuals
- -- for the entry call.
-
- Add_Matching_Formals (Formals, Actuals);
-
- Call :=
- Make_Procedure_Call_Statement (Loc,
- Name => Call_Nam,
- Parameter_Associations => Actuals);
-
- -- Add renaming declarations for the discriminants of the enclosing type
- -- as the various contract items may reference them.
-
- Add_Discriminant_Renamings (Obj_Id, Decls);
-
- Wrapper_Id :=
- Make_Defining_Identifier (Loc, New_External_Name (Chars (E), 'E'));
- Set_Contract_Wrapper (E, Wrapper_Id);
- Set_Is_Entry_Wrapper (Wrapper_Id);
-
- -- The wrapper body is analyzed when the enclosing type is frozen
-
- Append_Freeze_Action (Defining_Entity (Decl),
- Make_Subprogram_Body (Loc,
- Specification =>
- Make_Procedure_Specification (Loc,
- Defining_Unit_Name => Wrapper_Id,
- Parameter_Specifications => Formals),
- Declarations => Decls,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (Call))));
- end Build_Contract_Wrapper;
-
--------------------------------
-- Build_Corresponding_Record --
--------------------------------
@@ -3811,6 +3521,7 @@ package body Exp_Ch9 is
-- Establish link between subprogram body and source entry body
Set_Corresponding_Entry_Body (Proc_Body, N);
+ Set_At_End_Proc (Proc_Body, At_End_Proc (N));
Reset_Scopes_To (Proc_Body, Protected_Body_Subprogram (Ent));
return Proc_Body;
@@ -3867,32 +3578,35 @@ package body Exp_Ch9 is
Ident : Entity_Id;
Unprotected : Boolean := False) return List_Id
is
- Loc : constant Source_Ptr := Sloc (N);
- Decl : Node_Id;
- Formal : Entity_Id;
- New_Plist : List_Id;
- New_Param : Node_Id;
+ Loc : constant Source_Ptr := Sloc (N);
+
+ Decl : Node_Id;
+ Formal : Entity_Id;
+ New_Formal : Entity_Id;
+ New_Plist : List_Id;
begin
New_Plist := New_List;
Formal := First_Formal (Ident);
while Present (Formal) loop
- New_Param :=
+ New_Formal :=
+ Make_Defining_Identifier (Sloc (Formal), Chars (Formal));
+ Set_Comes_From_Source (New_Formal, Comes_From_Source (Formal));
+
+ if Unprotected then
+ Mutate_Ekind (New_Formal, Ekind (Formal));
+ Set_Protected_Formal (Formal, New_Formal);
+ end if;
+
+ Append_To (New_Plist,
Make_Parameter_Specification (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Sloc (Formal), Chars (Formal)),
+ Defining_Identifier => New_Formal,
Aliased_Present => Aliased_Present (Parent (Formal)),
In_Present => In_Present (Parent (Formal)),
Out_Present => Out_Present (Parent (Formal)),
- Parameter_Type => New_Occurrence_Of (Etype (Formal), Loc));
-
- if Unprotected then
- Set_Protected_Formal (Formal, Defining_Identifier (New_Param));
- Mutate_Ekind (Defining_Identifier (New_Param), Ekind (Formal));
- end if;
+ Parameter_Type => New_Occurrence_Of (Etype (Formal), Loc)));
- Append (New_Param, New_Plist);
Next_Formal (Formal);
end loop;
@@ -4021,8 +3735,7 @@ package body Exp_Ch9 is
Pid : Node_Id;
N_Op_Spec : Node_Id) return Node_Id
is
- Exc_Safe : constant Boolean := not Might_Raise (N);
- -- True if N cannot raise an exception
+ Might_Raise : constant Boolean := Sem_Util.Might_Raise (N);
Loc : constant Source_Ptr := Sloc (N);
Op_Spec : constant Node_Id := Specification (N);
@@ -4059,7 +3772,17 @@ package body Exp_Ch9 is
-- for use by the protected version built below.
if Nkind (Op_Spec) = N_Function_Specification then
- if Exc_Safe then
+ if Might_Raise then
+ Unprot_Call :=
+ Make_Simple_Return_Statement (Loc,
+ Expression =>
+ Make_Function_Call (Loc,
+ Name =>
+ Make_Identifier (Loc,
+ Chars => Chars (Defining_Unit_Name (N_Op_Spec))),
+ Parameter_Associations => Uactuals));
+
+ else
R := Make_Temporary (Loc, 'R');
Unprot_Call :=
@@ -4078,16 +3801,6 @@ package body Exp_Ch9 is
Return_Stmt :=
Make_Simple_Return_Statement (Loc,
Expression => New_Occurrence_Of (R, Loc));
-
- else
- Unprot_Call :=
- Make_Simple_Return_Statement (Loc,
- Expression =>
- Make_Function_Call (Loc,
- Name =>
- Make_Identifier (Loc,
- Chars => Chars (Defining_Unit_Name (N_Op_Spec))),
- Parameter_Associations => Uactuals));
end if;
if Has_Aspect (Pid, Aspect_Exclusive_Functions)
@@ -4113,7 +3826,7 @@ package body Exp_Ch9 is
-- Wrap call in block that will be covered by an at_end handler
- if not Exc_Safe then
+ if Might_Raise then
Unprot_Call :=
Make_Block_Statement (Loc,
Handled_Statement_Sequence =>
@@ -4160,7 +3873,7 @@ package body Exp_Ch9 is
Stmts := New_List (Lock_Stmt);
end if;
- if not Exc_Safe then
+ if Might_Raise then
Append (Unprot_Call, Stmts);
else
if Nkind (Op_Spec) = N_Function_Specification then
@@ -4170,10 +3883,6 @@ package body Exp_Ch9 is
Append (Unprot_Call, Stmts);
end if;
- -- Historical note: Previously, call to the cleanup was inserted
- -- here. This is now done by Build_Protected_Subprogram_Call_Cleanup,
- -- which is also shared by the 'not Exc_Safe' path.
-
Build_Protected_Subprogram_Call_Cleanup (Op_Spec, Pid, Loc, Stmts);
if Nkind (Op_Spec) = N_Function_Specification then
@@ -4196,10 +3905,10 @@ package body Exp_Ch9 is
Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts));
-- Mark this subprogram as a protected subprogram body so that the
- -- cleanup will be inserted. This is done only in the 'not Exc_Safe'
- -- path as otherwise the cleanup has already been inserted.
+ -- cleanup will be inserted. This is done only in the Might_Raise
+ -- case because otherwise the cleanup has already been inserted.
- if not Exc_Safe then
+ if Might_Raise then
Set_Is_Protected_Subprogram_Body (Sub_Body);
end if;
@@ -5236,7 +4945,8 @@ package body Exp_Ch9 is
Specification =>
Build_Protected_Sub_Specification (N, Pid, Unprotected_Mode),
Declarations => Decls,
- Handled_Statement_Sequence => Handled_Statement_Sequence (N));
+ Handled_Statement_Sequence => Handled_Statement_Sequence (N),
+ At_End_Proc => At_End_Proc (N));
end Build_Unprotected_Subprogram_Body;
----------------------------
@@ -8216,7 +7926,7 @@ package body Exp_Ch9 is
else
Transient_Blk :=
- First_Real_Statement (Handled_Statement_Sequence (Blk));
+ First (Statements (Handled_Statement_Sequence (Blk)));
if Present (Transient_Blk)
and then Nkind (Transient_Blk) = N_Block_Statement
@@ -9135,7 +8845,7 @@ package body Exp_Ch9 is
-- Build a wrapper procedure to handle contract cases, preconditions,
-- and postconditions.
- Build_Contract_Wrapper (Ent_Id, N);
+ Build_Entry_Contract_Wrapper (Ent_Id, N);
-- Create the barrier function
@@ -11833,17 +11543,11 @@ package body Exp_Ch9 is
if Abort_Allowed then
Call := Build_Runtime_Call (Loc, RE_Abort_Undefer);
- Insert_Before
- (First (Statements (Handled_Statement_Sequence (N))), Call);
+ Prepend (Call, Declarations (N));
Analyze (Call);
end if;
- -- The statement part has already been protected with an at_end and
- -- cleanup actions. The call to Complete_Activation must be placed
- -- at the head of the sequence of statements of that block. The
- -- declarations have been merged in this sequence of statements but
- -- the first real statement is accessible from the First_Real_Statement
- -- field (which was set for exactly this purpose).
+ -- Place call to Complete_Activation at the head of the statement list.
if Restricted_Profile then
Call := Build_Runtime_Call (Loc, RE_Complete_Restricted_Activation);
@@ -11852,7 +11556,7 @@ package body Exp_Ch9 is
end if;
Insert_Before
- (First_Real_Statement (Handled_Statement_Sequence (N)), Call);
+ (First (Statements (Handled_Statement_Sequence (N))), Call);
Analyze (Call);
New_N :=
@@ -11861,6 +11565,7 @@ package body Exp_Ch9 is
Declarations => Declarations (N),
Handled_Statement_Sequence => Handled_Statement_Sequence (N));
Set_Is_Task_Body_Procedure (New_N);
+ Set_At_End_Proc (New_N, At_End_Proc (N));
-- If the task contains generic instantiations, cleanup actions are
-- delayed until after instantiation. Transfer the activation chain to
@@ -12534,7 +12239,7 @@ package body Exp_Ch9 is
Ent := First_Entity (Tasktyp);
while Present (Ent) loop
if Ekind (Ent) in E_Entry | E_Entry_Family then
- Build_Contract_Wrapper (Ent, N);
+ Build_Entry_Contract_Wrapper (Ent, N);
end if;
Next_Entity (Ent);
@@ -13736,6 +13441,7 @@ package body Exp_Ch9 is
Make_Selected_Component (Loc,
Prefix => New_Occurrence_Of (Obj_Ent, Loc),
Selector_Name => Make_Identifier (Loc, Name_uObject)));
+
Add (Decl);
end;
end if;
@@ -13767,6 +13473,7 @@ package body Exp_Ch9 is
Make_Selected_Component (Loc,
Prefix => New_Occurrence_Of (Obj_Ent, Loc),
Selector_Name => Make_Identifier (Loc, Chars (D))));
+
Add (Decl);
-- Set debug info needed on this renaming declaration even
@@ -13833,6 +13540,7 @@ package body Exp_Ch9 is
Make_Selected_Component (Loc,
Prefix => New_Occurrence_Of (Obj_Ent, Loc),
Selector_Name => Make_Identifier (Loc, Nam)));
+
Add (Decl);
end if;
diff --git a/gcc/ada/exp_prag.adb b/gcc/ada/exp_prag.adb
index 0631172..2def83c 100644
--- a/gcc/ada/exp_prag.adb
+++ b/gcc/ada/exp_prag.adb
@@ -453,6 +453,8 @@ package body Exp_Prag is
New_Occurrence_Of (RTE (RE_Assert_Failure),
Loc))))))));
+ Set_Comes_From_Check_Or_Contract (N);
+
-- Case where we call the procedure
else
@@ -541,6 +543,8 @@ package body Exp_Prag is
Name =>
New_Occurrence_Of (RTE (RE_Raise_Assert_Failure), Loc),
Parameter_Associations => New_List (Relocate_Node (Msg))))));
+
+ Set_Comes_From_Check_Or_Contract (N);
end if;
Analyze (N);
@@ -1433,6 +1437,8 @@ package body Exp_Prag is
Condition => Cond,
Then_Statements => New_List (Error));
+ Set_Comes_From_Check_Or_Contract (Checks);
+
else
if No (Elsif_Parts (Checks)) then
Set_Elsif_Parts (Checks, New_List);
@@ -1642,6 +1648,8 @@ package body Exp_Prag is
Condition => New_Occurrence_Of (Flag, Loc),
Then_Statements => Eval_Stmts);
+ Set_Comes_From_Check_Or_Contract (Evals);
+
-- Otherwise generate:
-- elsif Flag then
-- <evaluation statements>
@@ -1836,6 +1844,8 @@ package body Exp_Prag is
Set (Flag),
Increment (Count)));
+ Set_Comes_From_Check_Or_Contract (If_Stmt);
+
Append_To (Decls, If_Stmt);
Analyze (If_Stmt);
@@ -1904,6 +1914,8 @@ package body Exp_Prag is
Right_Opnd => Make_Integer_Literal (Loc, 0)),
Then_Statements => CG_Stmts);
+ Set_Comes_From_Check_Or_Contract (CG_Checks);
+
-- Detect a possible failure due to several case guards evaluating to
-- True.
@@ -1937,15 +1949,17 @@ package body Exp_Prag is
New_Occurrence_Of (Msg_Str, Loc))))))))));
end if;
+ -- Append the checks, but do not analyze them at this point, because
+ -- contracts get potentially expanded as part of a wrapper which gets
+ -- fully analyzed once it is fully formed.
+
Append_To (Decls, CG_Checks);
- Analyze (CG_Checks);
-- Once all case guards are evaluated and checked, evaluate any prefixes
-- of attribute 'Old founds in the selected consequence.
if Present (Old_Evals) then
Append_To (Decls, Old_Evals);
- Analyze (Old_Evals);
end if;
-- Raise Assertion_Error when the corresponding consequence of a case
diff --git a/gcc/ada/exp_unst.adb b/gcc/ada/exp_unst.adb
index 2fb9299..9164644 100644
--- a/gcc/ada/exp_unst.adb
+++ b/gcc/ada/exp_unst.adb
@@ -938,7 +938,7 @@ package body Exp_Unst is
-- subprogram. As above, the called entity must be local and
-- not imported.
- when N_Handled_Sequence_Of_Statements =>
+ when N_Handled_Sequence_Of_Statements | N_Block_Statement =>
if Present (At_End_Proc (N))
and then Scope_Within (Entity (At_End_Proc (N)), Subp)
and then not Is_Imported (Entity (At_End_Proc (N)))
@@ -1184,6 +1184,15 @@ package body Exp_Unst is
Register_Subprogram (Ent, N);
+ -- Record a call from an At_End_Proc
+
+ if Present (At_End_Proc (N))
+ and then Scope_Within (Entity (At_End_Proc (N)), Subp)
+ and then not Is_Imported (Entity (At_End_Proc (N)))
+ then
+ Append_Unique_Call ((N, Ent, Entity (At_End_Proc (N))));
+ end if;
+
-- We make a recursive call to scan the subprogram body, so
-- that we can save and restore Current_Subprogram.
@@ -2583,6 +2592,8 @@ package body Exp_Unst is
and then Is_Library_Level_Entity (Spec_Id)
then
Unnest_Subprogram (Spec_Id, N);
+ else
+ return Skip;
end if;
end;
diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb
index 0bc22a4..61395ad 100644
--- a/gcc/ada/exp_util.adb
+++ b/gcc/ada/exp_util.adb
@@ -1293,7 +1293,8 @@ package body Exp_Util is
-- Gigi expects a different profile in the Secondary_Stack_Pool
-- case. There must be no uses of the two missing formals
-- (i.e., Pool_Param and Alignment_Param) in this case.
- Formal_Params := New_List (Address_Param, Size_Param);
+ Formal_Params := New_List
+ (Address_Param, Size_Param, Alignment_Param);
else
Formal_Params := New_List (
Pool_Param, Address_Param, Size_Param, Alignment_Param);
diff --git a/gcc/ada/fe.h b/gcc/ada/fe.h
index b002bdc..02cf105 100644
--- a/gcc/ada/fe.h
+++ b/gcc/ada/fe.h
@@ -217,6 +217,7 @@ extern Boolean In_Extended_Main_Code_Unit (Entity_Id);
#define List_Representation_Info opt__list_representation_info
#define No_Strict_Aliasing_CP opt__no_strict_aliasing
#define Suppress_Checks opt__suppress_checks
+#define Unnest_Subprogram_Mode opt__unnest_subprogram_mode
typedef enum {
Ada_83, Ada_95, Ada_2005, Ada_2012, Ada_2022, Ada_With_Extensions
@@ -233,6 +234,7 @@ extern Boolean GNAT_Mode;
extern Int List_Representation_Info;
extern Boolean No_Strict_Aliasing_CP;
extern Boolean Suppress_Checks;
+extern Boolean Unnest_Subprogram_Mode;
#define ZCX_Exceptions opt__zcx_exceptions
#define SJLJ_Exceptions opt__sjlj_exceptions
diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb
index 52858e2..346904e 100644
--- a/gcc/ada/freeze.adb
+++ b/gcc/ada/freeze.adb
@@ -6248,6 +6248,32 @@ package body Freeze is
and then Scope (Test_E) /= Current_Scope
and then Ekind (Test_E) /= E_Constant
then
+ -- Here we deal with the special case of the expansion of
+ -- postconditions. Previously this was handled by the loop below,
+ -- since these postcondition checks got isolated to a separate,
+ -- internally generated, subprogram. Now, however, the postcondition
+ -- checks get contained within their corresponding subprogram
+ -- directly.
+
+ if not Comes_From_Source (N)
+ and then Nkind (N) = N_Pragma
+ and then From_Aspect_Specification (N)
+ and then Is_Valid_Assertion_Kind (Original_Aspect_Pragma_Name (N))
+
+ -- Now, verify the placement of the pragma is within an expanded
+ -- subprogram which contains postcondition expansion - detected
+ -- through the presence of the "Wrapped_Statements" field.
+
+ and then Present (Enclosing_Subprogram (Current_Scope))
+ and then Present (Wrapped_Statements
+ (Enclosing_Subprogram (Current_Scope)))
+ then
+ goto Leave;
+ end if;
+
+ -- Otherwise, loop through scopes checking if an enclosing scope
+ -- comes from source or is a generic.
+
declare
S : Entity_Id;
@@ -8330,9 +8356,9 @@ package body Freeze is
-- If the parent is a subprogram body, the candidate insertion
-- point is just ahead of it.
- if Nkind (Parent_P) = N_Subprogram_Body
- and then Unique_Defining_Entity (Parent_P) =
- Freeze_Outside_Subp
+ if Nkind (Parent_P) = N_Subprogram_Body
+ and then Unique_Defining_Entity (Parent_P) =
+ Freeze_Outside_Subp
then
P := Parent_P;
exit;
diff --git a/gcc/ada/gcc-interface/decl.cc b/gcc/ada/gcc-interface/decl.cc
index 96ea13e..c5a93fb 100644
--- a/gcc/ada/gcc-interface/decl.cc
+++ b/gcc/ada/gcc-interface/decl.cc
@@ -436,7 +436,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
/* If this is a numeric or enumeral type, or an access type, a nonzero Esize
must be specified unless it was specified by the programmer. Exceptions
are for access-to-protected-subprogram types and all access subtypes, as
- another GNAT type is used to lay out the GCC type for them. */
+ another GNAT type is used to lay out the GCC type for them, as well as
+ access-to-subprogram types if front-end unnesting is enabled. */
gcc_assert (!is_type
|| Known_Esize (gnat_entity)
|| Has_Size_Clause (gnat_entity)
@@ -445,6 +446,9 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
&& (!IN (kind, Access_Kind)
|| kind == E_Access_Protected_Subprogram_Type
|| kind == E_Anonymous_Access_Protected_Subprogram_Type
+ || ((kind == E_Access_Subprogram_Type
+ || kind == E_Anonymous_Access_Subprogram_Type)
+ && Unnest_Subprogram_Mode)
|| kind == E_Access_Subtype
|| type_annotate_only)));
@@ -5602,6 +5606,7 @@ gnat_to_gnu_param (Entity_Id gnat_param, tree gnu_param_type, bool first,
gnu_param = create_param_decl (gnu_param_name, gnu_param_type);
TREE_READONLY (gnu_param) = ro_param || by_ref || by_component_ptr;
+ DECL_ARTIFICIAL (gnu_param) = !Comes_From_Source (gnat_param);
DECL_BY_REF_P (gnu_param) = by_ref;
DECL_FORCED_BY_REF_P (gnu_param) = forced_by_ref;
DECL_BY_COMPONENT_PTR_P (gnu_param) = by_component_ptr;
diff --git a/gcc/ada/gcc-interface/trans.cc b/gcc/ada/gcc-interface/trans.cc
index c1dd567..f2e0cb2 100644
--- a/gcc/ada/gcc-interface/trans.cc
+++ b/gcc/ada/gcc-interface/trans.cc
@@ -234,7 +234,7 @@ static inline bool stmt_group_may_fallthru (void);
static enum gimplify_status gnat_gimplify_stmt (tree *);
static void elaborate_all_entities (Node_Id);
static void process_freeze_entity (Node_Id);
-static void process_decls (List_Id, List_Id, Node_Id, bool, bool);
+static void process_decls (List_Id, List_Id, bool, bool);
static tree emit_check (tree, tree, int, Node_Id);
static tree build_unary_op_trapv (enum tree_code, tree, tree, Node_Id);
static tree build_binary_op_trapv (enum tree_code, tree, tree, tree, Node_Id);
@@ -1088,6 +1088,28 @@ Gigi_Types_Compatible (Entity_Id type, Entity_Id def_type)
return false;
}
+/* Return the full view of a private constant E, or of a renaming thereof, if
+ its type has discriminants, and Empty otherwise. */
+
+static Entity_Id
+Full_View_Of_Private_Constant (Entity_Id E)
+{
+ while (Present (Renamed_Object (E)) && Is_Entity_Name (Renamed_Object (E)))
+ E = Entity (Renamed_Object (E));
+
+ if (Ekind (E) != E_Constant || No (Full_View (E)))
+ return Empty;
+
+ const Entity_Id T = Etype (E);
+
+ if (Is_Private_Type (T)
+ && (Has_Unknown_Discriminants (T)
+ || (Present (Full_View (T)) && Has_Discriminants (Full_View (T)))))
+ return Full_View (E);
+
+ return Empty;
+}
+
/* Subroutine of gnat_to_gnu to translate GNAT_NODE, an N_Identifier, to a GCC
tree, which is returned. GNU_RESULT_TYPE_P is a pointer to where we should
place the result type. */
@@ -1095,21 +1117,19 @@ Gigi_Types_Compatible (Entity_Id type, Entity_Id def_type)
static tree
Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p)
{
- /* The entity of GNAT_NODE and its type. */
- Node_Id gnat_entity = (Nkind (gnat_node) == N_Defining_Identifier
- || Nkind (gnat_node) == N_Defining_Operator_Symbol)
- ? gnat_node : Entity (gnat_node);
- Node_Id gnat_entity_type = Etype (gnat_entity);
+ Entity_Id gnat_entity = (Nkind (gnat_node) == N_Defining_Identifier
+ || Nkind (gnat_node) == N_Defining_Operator_Symbol)
+ ? gnat_node : Entity (gnat_node);
+ Entity_Id gnat_result_type;
+ tree gnu_result, gnu_result_type;
/* If GNAT_NODE is a constant, whether we should use the initialization
value instead of the constant entity, typically for scalars with an
address clause when the parent doesn't require an lvalue. */
- bool use_constant_initializer = false;
+ bool use_constant_initializer;
/* Whether we should require an lvalue for GNAT_NODE. Needed in
specific circumstances only, so evaluated lazily. < 0 means
unknown, > 0 means known true, 0 means known false. */
- int require_lvalue = -1;
- Entity_Id gnat_result_type;
- tree gnu_result, gnu_result_type;
+ int require_lvalue;
/* If the Etype of this node is not the same as that of the Entity, then
something went wrong, probably in generic instantiation. However, this
@@ -1118,25 +1138,17 @@ Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p)
may have been changed to a subtype by Exp_Ch3.Adjust_Discriminants. */
gcc_assert (!Is_Object (gnat_entity)
|| Ekind (gnat_entity) == E_Discriminant
- || Etype (gnat_node) == gnat_entity_type
- || Gigi_Types_Compatible (Etype (gnat_node), gnat_entity_type));
+ || Etype (gnat_node) == Etype (gnat_entity)
+ || Gigi_Types_Compatible (Etype (gnat_node),
+ Etype (gnat_entity)));
- /* If this is a reference to a deferred constant whose partial view is an
+ /* If this is a reference to a deferred constant whose partial view is of
unconstrained private type, the proper type is on the full view of the
- constant, not on the full view of the type, which may be unconstrained.
-
- This may be a reference to a type, for example in the prefix of the
- attribute Position, generated for dispatching code (see Make_DT in
- exp_disp,adb). In that case we need the type itself, not is parent,
- in particular if it is a derived type */
- if (Ekind (gnat_entity) == E_Constant
- && Is_Private_Type (gnat_entity_type)
- && (Has_Unknown_Discriminants (gnat_entity_type)
- || (Present (Full_View (gnat_entity_type))
- && Has_Discriminants (Full_View (gnat_entity_type))))
- && Present (Full_View (gnat_entity)))
+ constant, not on the full view of the type which may be unconstrained. */
+ const Entity_Id gnat_full_view = Full_View_Of_Private_Constant (gnat_entity);
+ if (Present (gnat_full_view))
{
- gnat_entity = Full_View (gnat_entity);
+ gnat_entity = gnat_full_view;
gnat_result_type = Etype (gnat_entity);
}
else
@@ -1184,7 +1196,13 @@ Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p)
= lvalue_required_p (gnat_node, gnu_result_type, true, false);
use_constant_initializer = !require_lvalue;
}
+ else
+ {
+ require_lvalue = -1;
+ use_constant_initializer = false;
+ }
+ /* Fetch the initialization value of a constant if requested. */
if (use_constant_initializer)
{
/* If this is a deferred constant, the initializer is attached to
@@ -3778,6 +3796,39 @@ build_return_expr (tree ret_obj, tree ret_val)
return build1 (RETURN_EXPR, void_type_node, result_expr);
}
+/* Subroutine of gnat_to_gnu to translate the At_End_Proc of GNAT_NODE, an
+ N_Block_Statement or N_Handled_Sequence_Of_Statements or N_*_Body node.
+
+ To invoked the GCC mechanism, we call add_cleanup and when we leave the
+ group, end_stmt_group will create the TRY_FINALLY_EXPR construct. */
+
+static void
+At_End_Proc_to_gnu (Node_Id gnat_node)
+{
+ tree proc_decl = gnat_to_gnu (At_End_Proc (gnat_node));
+ Node_Id gnat_end_label;
+
+ /* When not optimizing, disable inlining of finalizers as this can
+ create a more complex CFG in the parent function. */
+ if (!optimize || optimize_debug)
+ DECL_DECLARED_INLINE_P (proc_decl) = 0;
+
+ /* Retrieve the end label attached to the node, if any. */
+ if (Nkind (gnat_node) == N_Handled_Sequence_Of_Statements)
+ gnat_end_label = End_Label (gnat_node);
+ else if (Present (Handled_Statement_Sequence (gnat_node)))
+ gnat_end_label = End_Label (Handled_Statement_Sequence (gnat_node));
+ else
+ gnat_end_label = Empty;
+
+ /* If there is no end label attached, we use the location of the At_End
+ procedure because Expand_Cleanup_Actions might reset the location of
+ the enclosing construct to that of an inner statement. */
+ add_cleanup (build_call_n_expr (proc_decl, 0),
+ Present (gnat_end_label)
+ ? gnat_end_label : At_End_Proc (gnat_node));
+}
+
/* Subroutine of gnat_to_gnu to translate GNAT_NODE, an N_Subprogram_Body. */
static void
@@ -3928,12 +3979,16 @@ Subprogram_Body_to_gnu (Node_Id gnat_node)
gnat_pushlevel ();
/* First translate the declarations of the subprogram. */
- process_decls (Declarations (gnat_node), Empty, Empty, true, true);
+ process_decls (Declarations (gnat_node), Empty, true, true);
/* Then generate the code of the subprogram itself. A return statement will
be present and any Out parameters will be handled there. */
add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node)));
+ /* Process the At_End_Proc, if any. */
+ if (Present (At_End_Proc (gnat_node)))
+ At_End_Proc_to_gnu (gnat_node);
+
gnat_poplevel ();
tree gnu_result = end_stmt_group ();
@@ -5305,76 +5360,39 @@ static tree
Handled_Sequence_Of_Statements_to_gnu (Node_Id gnat_node)
{
/* If just annotating, ignore all EH and cleanups. */
- const bool gcc_eh
+ const bool eh
= !type_annotate_only && Present (Exception_Handlers (gnat_node));
const bool at_end = !type_annotate_only && Present (At_End_Proc (gnat_node));
- const bool binding_for_block = (at_end || gcc_eh);
- tree gnu_inner_block; /* The statement(s) for the block itself. */
tree gnu_result;
Node_Id gnat_temp;
- /* The GCC exception handling mechanism can handle both ZCX and SJLJ schemes.
- To call the GCC mechanism, we call add_cleanup, and when we leave the
- binding, end_stmt_group will create the TRY_FINALLY_EXPR construct.
+ /* The exception handling mechanism can handle both ZCX and SJLJ schemes, and
+ is exposed through the TRY_CATCH_EXPR construct that we build manually.
??? The region level calls down there have been specifically put in place
for a ZCX context and currently the order in which things are emitted
(region/handlers) is different from the SJLJ case. Instead of putting
other calls with different conditions at other places for the SJLJ case,
it seems cleaner to reorder things for the SJLJ case and generalize the
- condition to make it not ZCX specific.
-
- If there are any exceptions or cleanup processing involved, we need an
- outer statement group and binding level. */
- if (binding_for_block)
- {
- start_stmt_group ();
- gnat_pushlevel ();
- }
-
- /* If we are to call a function when exiting this block, add a cleanup
- to the binding level we made above. Note that add_cleanup is FIFO
- so we must register this cleanup after the EH cleanup just above. */
- if (at_end)
- {
- tree proc_decl = gnat_to_gnu (At_End_Proc (gnat_node));
-
- /* When not optimizing, disable inlining of finalizers as this can
- create a more complex CFG in the parent function. */
- if (!optimize || optimize_debug)
- DECL_DECLARED_INLINE_P (proc_decl) = 0;
-
- /* If there is no end label attached, we use the location of the At_End
- procedure because Expand_Cleanup_Actions might reset the location of
- the enclosing construct to that of an inner statement. */
- add_cleanup (build_call_n_expr (proc_decl, 0),
- Present (End_Label (gnat_node))
- ? End_Label (gnat_node) : At_End_Proc (gnat_node));
- }
+ condition to make it not ZCX specific. */
- /* Now build the tree for the declarations and statements inside this
- block. */
+ /* First build the tree for the statements inside the sequence. */
start_stmt_group ();
- if (Present (First_Real_Statement (gnat_node)))
- process_decls (Statements (gnat_node), Empty,
- First_Real_Statement (gnat_node), true, true);
-
- /* Generate code for each statement in the block. */
- for (gnat_temp = (Present (First_Real_Statement (gnat_node))
- ? First_Real_Statement (gnat_node)
- : First (Statements (gnat_node)));
- Present (gnat_temp); gnat_temp = Next (gnat_temp))
+ for (gnat_temp = First (Statements (gnat_node));
+ Present (gnat_temp);
+ gnat_temp = Next (gnat_temp))
add_stmt (gnat_to_gnu (gnat_temp));
- gnu_inner_block = end_stmt_group ();
+ gnu_result = end_stmt_group ();
- if (gcc_eh)
+ /* Then process the exception handlers, if any. */
+ if (eh)
{
tree gnu_handlers;
location_t locus;
- /* First make a block containing the handlers. */
+ /* First make a group containing the handlers. */
start_stmt_group ();
for (gnat_temp = First_Non_Pragma (Exception_Handlers (gnat_node));
Present (gnat_temp);
@@ -5382,9 +5400,10 @@ Handled_Sequence_Of_Statements_to_gnu (Node_Id gnat_node)
add_stmt (gnat_to_gnu (gnat_temp));
gnu_handlers = end_stmt_group ();
- /* Now make the TRY_CATCH_EXPR for the block. */
- gnu_result = build2 (TRY_CATCH_EXPR, void_type_node,
- gnu_inner_block, gnu_handlers);
+ /* Now make the TRY_CATCH_EXPR for the group. */
+ gnu_result
+ = build2 (TRY_CATCH_EXPR, void_type_node, gnu_result, gnu_handlers);
+
/* Set a location. We need to find a unique location for the dispatching
code, otherwise we can get coverage or debugging issues. Try with
the location of the end label. */
@@ -5398,14 +5417,13 @@ Handled_Sequence_Of_Statements_to_gnu (Node_Id gnat_node)
coverage analysis tools. */
set_expr_location_from_node (gnu_result, gnat_node, true);
}
- else
- gnu_result = gnu_inner_block;
- /* Now close our outer block, if we had to make one. */
- if (binding_for_block)
+ /* Process the At_End_Proc, if any. */
+ if (at_end)
{
+ start_stmt_group ();
add_stmt (gnu_result);
- gnat_poplevel ();
+ At_End_Proc_to_gnu (gnat_node);
gnu_result = end_stmt_group ();
}
@@ -5493,7 +5511,6 @@ Exception_Handler_to_gnu (Node_Id gnat_node)
}
start_stmt_group ();
- gnat_pushlevel ();
/* Expand a call to the begin_handler hook at the beginning of the
handler, and arrange for a call to the end_handler hook to occur
@@ -5584,7 +5601,7 @@ Exception_Handler_to_gnu (Node_Id gnat_node)
else
{
start_stmt_group ();
- gnat_pushlevel ();
+
/* CODE: void *EXPRP = __builtin_eh_handler (0); */
tree prop_ptr
= create_var_decl (get_identifier ("EXPRP"), NULL_TREE,
@@ -5604,14 +5621,11 @@ Exception_Handler_to_gnu (Node_Id gnat_node)
add_stmt_with_node (ecall, gnat_node);
/* CODE: } */
- gnat_poplevel ();
tree eblk = end_stmt_group ();
tree ehls = build2 (EH_ELSE_EXPR, void_type_node, call, eblk);
add_cleanup (ehls, gnat_node);
}
- gnat_poplevel ();
-
gnu_incoming_exc_ptr = prev_gnu_incoming_exc_ptr;
return
@@ -5677,7 +5691,7 @@ Compilation_Unit_to_gnu (Node_Id gnat_node)
gnat_pragma = Next (gnat_pragma))
if (Nkind (gnat_pragma) == N_Pragma)
add_stmt (gnat_to_gnu (gnat_pragma));
- process_decls (Declarations (Aux_Decls_Node (gnat_node)), Empty, Empty,
+ process_decls (Declarations (Aux_Decls_Node (gnat_node)), Empty,
true, true);
/* Process the unit itself. */
@@ -6877,6 +6891,11 @@ gnat_to_gnu (Node_Id gnat_node)
: (Rounded_Result (gnat_node)
? ROUND_DIV_EXPR : TRUNC_DIV_EXPR),
gnu_result_type, gnu_lhs, gnu_rhs);
+ /* If the result type is larger than a word, then declare the dependence
+ on the libgcc routine. */
+ if (INTEGRAL_TYPE_P (gnu_result_type)
+ && TYPE_PRECISION (gnu_result_type) > BITS_PER_WORD)
+ Check_Restriction_No_Dependence_On_System (Name_Gcc, gnat_node);
break;
case N_Op_Eq:
@@ -6936,6 +6955,10 @@ gnat_to_gnu (Node_Id gnat_node)
gnu_rhs = convert (gnu_count_type, gnu_rhs);
gnu_max_shift
= convert (TREE_TYPE (gnu_rhs), TYPE_SIZE (gnu_type));
+ /* If the result type is larger than a word, then declare the dependence
+ on the libgcc routine. */
+ if (TYPE_PRECISION (gnu_result_type) > BITS_PER_WORD)
+ Check_Restriction_No_Dependence_On_System (Name_Gcc, gnat_node);
}
/* If this is a comparison between (potentially) large aggregates, then
@@ -6948,6 +6971,12 @@ gnat_to_gnu (Node_Id gnat_node)
Check_Restriction_No_Dependence_On_System (Name_Memory_Compare,
gnat_node);
+ /* If this is a modulo/remainder and the result type is larger than a
+ word, then declare the dependence on the libgcc routine. */
+ else if ((kind == N_Op_Mod ||kind == N_Op_Rem)
+ && TYPE_PRECISION (gnu_result_type) > BITS_PER_WORD)
+ Check_Restriction_No_Dependence_On_System (Name_Gcc, gnat_node);
+
/* Pending generic support for efficient vector logical operations in
GCC, convert vectors to their representative array type view. */
gnu_lhs = maybe_vector_array (gnu_lhs);
@@ -7365,8 +7394,10 @@ gnat_to_gnu (Node_Id gnat_node)
{
start_stmt_group ();
gnat_pushlevel ();
- process_decls (Declarations (gnat_node), Empty, Empty, true, true);
+ process_decls (Declarations (gnat_node), Empty, true, true);
add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node)));
+ if (Present (At_End_Proc (gnat_node)))
+ At_End_Proc_to_gnu (gnat_node);
gnat_poplevel ();
gnu_result = end_stmt_group ();
}
@@ -7606,15 +7637,14 @@ gnat_to_gnu (Node_Id gnat_node)
break;
case N_Package_Specification:
-
start_stmt_group ();
process_decls (Visible_Declarations (gnat_node),
- Private_Declarations (gnat_node), Empty, true, true);
+ Private_Declarations (gnat_node),
+ true, true);
gnu_result = end_stmt_group ();
break;
case N_Package_Body:
-
/* If this is the body of a generic package - do nothing. */
if (Ekind (Corresponding_Spec (gnat_node)) == E_Generic_Package)
{
@@ -7623,11 +7653,11 @@ gnat_to_gnu (Node_Id gnat_node)
}
start_stmt_group ();
- process_decls (Declarations (gnat_node), Empty, Empty, true, true);
-
+ process_decls (Declarations (gnat_node), Empty, true, true);
if (Present (Handled_Statement_Sequence (gnat_node)))
add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node)));
-
+ if (Present (At_End_Proc (gnat_node)))
+ At_End_Proc_to_gnu (gnat_node);
gnu_result = end_stmt_group ();
break;
@@ -7673,7 +7703,7 @@ gnat_to_gnu (Node_Id gnat_node)
case N_Task_Body:
/* These nodes should only be present when annotating types. */
gcc_assert (type_annotate_only);
- process_decls (Declarations (gnat_node), Empty, Empty, true, true);
+ process_decls (Declarations (gnat_node), Empty, true, true);
gnu_result = alloc_stmt_list ();
break;
@@ -7975,7 +8005,7 @@ gnat_to_gnu (Node_Id gnat_node)
case N_Freeze_Entity:
start_stmt_group ();
process_freeze_entity (gnat_node);
- process_decls (Actions (gnat_node), Empty, Empty, true, true);
+ process_decls (Actions (gnat_node), Empty, true, true);
gnu_result = end_stmt_group ();
break;
@@ -9203,17 +9233,13 @@ process_freeze_entity (Node_Id gnat_node)
we declare a function if there was no spec). The second pass
elaborates the bodies.
- GNAT_END_LIST gives the element in the list past the end. Normally,
- this is Empty, but can be First_Real_Statement for a
- Handled_Sequence_Of_Statements.
-
We make a complete pass through both lists if PASS1P is true, then make
the second pass over both lists if PASS2P is true. The lists usually
correspond to the public and private parts of a package. */
static void
process_decls (List_Id gnat_decls, List_Id gnat_decls2,
- Node_Id gnat_end_list, bool pass1p, bool pass2p)
+ bool pass1p, bool pass2p)
{
List_Id gnat_decl_array[2];
Node_Id gnat_decl;
@@ -9225,7 +9251,8 @@ process_decls (List_Id gnat_decls, List_Id gnat_decls2,
for (i = 0; i <= 1; i++)
if (Present (gnat_decl_array[i]))
for (gnat_decl = First (gnat_decl_array[i]);
- gnat_decl != gnat_end_list; gnat_decl = Next (gnat_decl))
+ Present (gnat_decl);
+ gnat_decl = Next (gnat_decl))
{
/* For package specs, we recurse inside the declarations,
thus taking the two pass approach inside the boundary. */
@@ -9234,14 +9261,14 @@ process_decls (List_Id gnat_decls, List_Id gnat_decls2,
== N_Package_Specification)))
process_decls (Visible_Declarations (Specification (gnat_decl)),
Private_Declarations (Specification (gnat_decl)),
- Empty, true, false);
+ true, false);
/* Similarly for any declarations in the actions of a
freeze node. */
else if (Nkind (gnat_decl) == N_Freeze_Entity)
{
process_freeze_entity (gnat_decl);
- process_decls (Actions (gnat_decl), Empty, Empty, true, false);
+ process_decls (Actions (gnat_decl), Empty, true, false);
}
/* Package bodies with freeze nodes get their elaboration deferred
@@ -9308,7 +9335,8 @@ process_decls (List_Id gnat_decls, List_Id gnat_decls2,
for (i = 0; i <= 1; i++)
if (Present (gnat_decl_array[i]))
for (gnat_decl = First (gnat_decl_array[i]);
- gnat_decl != gnat_end_list; gnat_decl = Next (gnat_decl))
+ Present (gnat_decl);
+ gnat_decl = Next (gnat_decl))
{
if (Nkind (gnat_decl) == N_Subprogram_Body
|| Nkind (gnat_decl) == N_Subprogram_Body_Stub
@@ -9321,10 +9349,10 @@ process_decls (List_Id gnat_decls, List_Id gnat_decls2,
== N_Package_Specification)))
process_decls (Visible_Declarations (Specification (gnat_decl)),
Private_Declarations (Specification (gnat_decl)),
- Empty, false, true);
+ false, true);
else if (Nkind (gnat_decl) == N_Freeze_Entity)
- process_decls (Actions (gnat_decl), Empty, Empty, false, true);
+ process_decls (Actions (gnat_decl), Empty, false, true);
else if (Nkind (gnat_decl) == N_Subprogram_Renaming_Declaration)
add_stmt (gnat_to_gnu (gnat_decl));
@@ -9763,6 +9791,16 @@ convert_with_check (Entity_Id gnat_type, tree gnu_expr, bool overflow_p,
else
gnu_result = convert (gnu_base_type, gnu_result);
+ /* If this is a conversion between an integer type larger than a word and a
+ floating-point type, then declare the dependence on the libgcc routine. */
+ if ((INTEGRAL_TYPE_P (gnu_in_base_type)
+ && TYPE_PRECISION (gnu_in_base_type) > BITS_PER_WORD
+ && FLOAT_TYPE_P (gnu_base_type))
+ || (FLOAT_TYPE_P (gnu_in_base_type)
+ && INTEGRAL_TYPE_P (gnu_base_type)
+ && TYPE_PRECISION (gnu_base_type) > BITS_PER_WORD))
+ Check_Restriction_No_Dependence_On_System (Name_Gcc, gnat_node);
+
return convert (gnu_type, gnu_result);
}
@@ -10389,7 +10427,6 @@ set_end_locus_from_node (tree gnu_node, Node_Id gnat_node)
gnat_end_label = End_Label (Handled_Statement_Sequence (gnat_node));
else
gnat_end_label = Empty;
-
break;
case N_Package_Declaration:
@@ -10410,7 +10447,7 @@ set_end_locus_from_node (tree gnu_node, Node_Id gnat_node)
transient block does not receive the sloc of a source condition. */
if (!Sloc_to_locus (Sloc (gnat_node), &end_locus,
No (gnat_end_label)
- && (Nkind (gnat_node) == N_Block_Statement)))
+ && Nkind (gnat_node) == N_Block_Statement))
return false;
switch (TREE_CODE (gnu_node))
diff --git a/gcc/ada/gcc-interface/utils.cc b/gcc/ada/gcc-interface/utils.cc
index a571430..3d4c1c1 100644
--- a/gcc/ada/gcc-interface/utils.cc
+++ b/gcc/ada/gcc-interface/utils.cc
@@ -868,6 +868,13 @@ gnat_pushdecl (tree decl, Node_Id gnat_node)
}
}
+/* Pointer types aren't named types in the C sense so we need to generate a
+ typedef in DWARF for them. Also do that for fat pointer types because,
+ even though they are named types in the C sense, they are still the XUP
+ types created for the base array type at this point. */
+#define TYPE_IS_POINTER_P(NODE) \
+ (TREE_CODE (NODE) == POINTER_TYPE || TYPE_IS_FAT_POINTER_P (NODE))
+
/* For the declaration of a type, set its name either if it isn't already
set or if the previous type name was not derived from a source name.
We'd rather have the type named with a real name and all the pointer
@@ -877,18 +884,14 @@ gnat_pushdecl (tree decl, Node_Id gnat_node)
{
tree t = TREE_TYPE (decl);
- /* Pointer types aren't named types in the C sense so we need to generate
- a typedef in DWARF for them and make sure it is preserved, unless the
- type is artificial. */
+ /* For pointer types, make sure the typedef is generated and preserved
+ in DWARF, unless the type is artificial. */
if (!(TYPE_NAME (t) && TREE_CODE (TYPE_NAME (t)) == TYPE_DECL)
- && (TREE_CODE (t) != POINTER_TYPE || DECL_ARTIFICIAL (decl)))
+ && (!TYPE_IS_POINTER_P (t) || DECL_ARTIFICIAL (decl)))
;
/* For pointer types, create the DECL_ORIGINAL_TYPE that will generate
- the typedef in DWARF. Also do that for fat pointer types because,
- even though they are named types in the C sense, they are still the
- XUP types created for the base array type at this point. */
- else if (!DECL_ARTIFICIAL (decl)
- && (TREE_CODE (t) == POINTER_TYPE || TYPE_IS_FAT_POINTER_P (t)))
+ the typedef in DWARF. */
+ else if (TYPE_IS_POINTER_P (t) && !DECL_ARTIFICIAL (decl))
{
tree tt = build_variant_type_copy (t);
TYPE_NAME (tt) = decl;
@@ -920,9 +923,8 @@ gnat_pushdecl (tree decl, Node_Id gnat_node)
to all parallel types too thanks to gnat_set_type_context. */
if (t)
for (t = TYPE_MAIN_VARIANT (t); t; t = TYPE_NEXT_VARIANT (t))
- /* ??? Because of the previous kludge, we can have variants of fat
- pointer types with different names. */
- if (!(TYPE_IS_FAT_POINTER_P (t)
+ /* Skip it for pointer types to preserve the typedef. */
+ if (!(TYPE_IS_POINTER_P (t)
&& TYPE_NAME (t)
&& TREE_CODE (TYPE_NAME (t)) == TYPE_DECL))
{
@@ -932,6 +934,8 @@ gnat_pushdecl (tree decl, Node_Id gnat_node)
deferred_decl_context);
}
}
+
+#undef TYPE_IS_POINTER_P
}
/* Create a record type that contains a SIZE bytes long field of TYPE with a
diff --git a/gcc/ada/gen_il-fields.ads b/gcc/ada/gen_il-fields.ads
index c6bcb71..83c7180 100644
--- a/gcc/ada/gen_il-fields.ads
+++ b/gcc/ada/gen_il-fields.ads
@@ -96,6 +96,7 @@ package Gen_IL.Fields is
Class_Present,
Classifications,
Cleanup_Actions,
+ Comes_From_Check_Or_Contract,
Comes_From_Extended_Return_Statement,
Compile_Time_Known_Aggregate,
Component_Associations,
@@ -183,7 +184,6 @@ package Gen_IL.Fields is
First_Inlined_Subprogram,
First_Name,
First_Named_Actual,
- First_Real_Statement,
First_Subtype_Link,
Float_Truncate,
Formal_Type_Definition,
@@ -930,7 +930,8 @@ package Gen_IL.Fields is
Warnings_Off_Used_Unmodified,
Warnings_Off_Used_Unreferenced,
Was_Hidden,
- Wrapped_Entity
+ Wrapped_Entity,
+ Wrapped_Statements
-- End of entity fields.
); -- Opt_Field_Enum
diff --git a/gcc/ada/gen_il-gen-gen_entities.adb b/gcc/ada/gen_il-gen-gen_entities.adb
index 89d8659..2e1e3c9 100644
--- a/gcc/ada/gen_il-gen-gen_entities.adb
+++ b/gcc/ada/gen_il-gen-gen_entities.adb
@@ -1046,7 +1046,8 @@ begin -- Gen_IL.Gen.Gen_Entities
Sm (Thunk_Entity, Node_Id,
Pre => "Is_Thunk (N)"),
Sm (Wrapped_Entity, Node_Id,
- Pre => "Is_Primitive_Wrapper (N)")));
+ Pre => "Is_Primitive_Wrapper (N)"),
+ Sm (Wrapped_Statements, Node_Id)));
Cc (E_Operator, Subprogram_Kind,
-- A predefined operator, appearing in Standard, or an implicitly
@@ -1095,7 +1096,8 @@ begin -- Gen_IL.Gen.Gen_Entities
Sm (Thunk_Entity, Node_Id,
Pre => "Is_Thunk (N)"),
Sm (Wrapped_Entity, Node_Id,
- Pre => "Is_Primitive_Wrapper (N)")));
+ Pre => "Is_Primitive_Wrapper (N)"),
+ Sm (Wrapped_Statements, Node_Id)));
Cc (E_Abstract_State, Overloadable_Kind,
-- A state abstraction. Used to designate entities introduced by aspect
@@ -1134,7 +1136,8 @@ begin -- Gen_IL.Gen.Gen_Entities
Sm (Protection_Object, Node_Id),
Sm (Scope_Depth_Value, Unat),
Sm (SPARK_Pragma, Node_Id),
- Sm (SPARK_Pragma_Inherited, Flag)));
+ Sm (SPARK_Pragma_Inherited, Flag),
+ Sm (Wrapped_Statements, Node_Id)));
Cc (E_Entry_Family, Entity_Kind,
-- An entry family, created by an entry family declaration in a
@@ -1161,7 +1164,8 @@ begin -- Gen_IL.Gen.Gen_Entities
Sm (Renamed_Or_Alias, Node_Id),
Sm (Scope_Depth_Value, Unat),
Sm (SPARK_Pragma, Node_Id),
- Sm (SPARK_Pragma_Inherited, Flag)));
+ Sm (SPARK_Pragma_Inherited, Flag),
+ Sm (Wrapped_Statements, Node_Id)));
Cc (E_Block, Entity_Kind,
-- A block identifier, created by an explicit or implicit label on
diff --git a/gcc/ada/gen_il-gen-gen_nodes.adb b/gcc/ada/gen_il-gen-gen_nodes.adb
index 97c16bc..556326a 100644
--- a/gcc/ada/gen_il-gen-gen_nodes.adb
+++ b/gcc/ada/gen_il-gen-gen_nodes.adb
@@ -804,13 +804,15 @@ begin -- Gen_IL.Gen.Gen_Nodes
Cc (N_Package_Body, N_Unit_Body,
(Sy (Defining_Unit_Name, Node_Id),
Sy (Declarations, List_Id, Default_No_List),
- Sy (Handled_Statement_Sequence, Node_Id, Default_Empty)));
+ Sy (Handled_Statement_Sequence, Node_Id, Default_Empty),
+ Sy (At_End_Proc, Node_Id, Default_Empty)));
Cc (N_Subprogram_Body, N_Unit_Body,
(Sy (Specification, Node_Id),
Sy (Declarations, List_Id, Default_No_List),
Sy (Handled_Statement_Sequence, Node_Id, Default_Empty),
Sy (Bad_Is_Detected, Flag),
+ Sy (At_End_Proc, Node_Id, Default_Empty),
Sm (Activation_Chain_Entity, Node_Id),
Sm (Acts_As_Spec, Flag),
Sm (Corresponding_Entry_Body, Node_Id),
@@ -832,6 +834,7 @@ begin -- Gen_IL.Gen.Gen_Nodes
(Sy (Defining_Identifier, Node_Id),
Sy (Declarations, List_Id, Default_No_List),
Sy (Handled_Statement_Sequence, Node_Id, Default_Empty),
+ Sy (At_End_Proc, Node_Id, Default_Empty),
Sm (Activation_Chain_Entity, Node_Id),
Sm (Is_Task_Master, Flag)));
@@ -975,6 +978,7 @@ begin -- Gen_IL.Gen.Gen_Nodes
Sy (Has_Created_Identifier, Flag),
Sy (Is_Asynchronous_Call_Block, Flag),
Sy (Is_Task_Allocation_Block, Flag),
+ Sy (At_End_Proc, Node_Id, Default_Empty),
Sm (Activation_Chain_Entity, Node_Id),
Sm (Cleanup_Actions, List_Id),
Sm (Exception_Junk, Flag),
@@ -1094,7 +1098,8 @@ begin -- Gen_IL.Gen.Gen_Nodes
Sy (Elsif_Parts, List_Id, Default_No_List),
Sy (Else_Statements, List_Id, Default_No_List),
Sy (End_Span, Unat, Default_Uint_0),
- Sm (From_Conditional_Expression, Flag)));
+ Sm (From_Conditional_Expression, Flag),
+ Sm (Comes_From_Check_Or_Contract, Flag)));
Cc (N_Accept_Alternative, Node_Kind,
(Sy (Accept_Statement, Node_Id),
@@ -1334,6 +1339,7 @@ begin -- Gen_IL.Gen.Gen_Nodes
Sy (Entry_Body_Formal_Part, Node_Id),
Sy (Declarations, List_Id, Default_No_List),
Sy (Handled_Statement_Sequence, Node_Id, Default_Empty),
+ Sy (At_End_Proc, Node_Id, Default_Empty),
Sm (Activation_Chain_Entity, Node_Id)));
Cc (N_Entry_Call_Alternative, Node_Kind,
@@ -1421,8 +1427,7 @@ begin -- Gen_IL.Gen.Gen_Nodes
(Sy (Statements, List_Id, Default_Empty_List),
Sy (End_Label, Node_Id, Default_Empty),
Sy (Exception_Handlers, List_Id, Default_No_List),
- Sy (At_End_Proc, Node_Id, Default_Empty),
- Sm (First_Real_Statement, Node_Id)));
+ Sy (At_End_Proc, Node_Id, Default_Empty)));
Cc (N_Index_Or_Discriminant_Constraint, Node_Kind,
(Sy (Constraints, List_Id)));
diff --git a/gcc/ada/ghost.adb b/gcc/ada/ghost.adb
index 1ce1d6a..0f03285 100644
--- a/gcc/ada/ghost.adb
+++ b/gcc/ada/ghost.adb
@@ -271,11 +271,11 @@ package body Ghost is
if Present (Subp_Id) then
- -- The context is the internally built _Postconditions
+ -- The context is the internally built _Wrapped_Statements
-- procedure, which is OK because the real check was done
- -- before expansion activities.
+ -- before contract expansion activities.
- if Chars (Subp_Id) = Name_uPostconditions then
+ if Chars (Subp_Id) = Name_uWrapped_Statements then
return True;
-- The context is the internally built predicate function,
@@ -432,9 +432,7 @@ package body Ghost is
-- but it may still contain references to Ghost entities.
elsif Nkind (Stmt) = N_If_Statement
- and then Nkind (Original_Node (Stmt)) = N_Pragma
- and then Assertion_Expression_Pragma
- (Get_Pragma_Id (Original_Node (Stmt)))
+ and then Comes_From_Check_Or_Contract (Stmt)
then
return True;
end if;
diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi
index fe2f434..cdf8605 100644
--- a/gcc/ada/gnat_rm.texi
+++ b/gcc/ada/gnat_rm.texi
@@ -19,7 +19,7 @@
@copying
@quotation
-GNAT Reference Manual , Aug 25, 2022
+GNAT Reference Manual , Sep 09, 2022
AdaCore
@@ -398,7 +398,6 @@ Implementation Defined Attributes
* Attribute Iterable::
* Attribute Large::
* Attribute Library_Level::
-* Attribute Lock_Free::
* Attribute Loop_Entry::
* Attribute Machine_Size::
* Attribute Mantissa::
@@ -694,17 +693,6 @@ The GNAT Library
* Ada.Characters.Wide_Latin_9 (a-cwila1.ads): Ada Characters Wide_Latin_9 a-cwila1 ads.
* Ada.Characters.Wide_Wide_Latin_1 (a-chzla1.ads): Ada Characters Wide_Wide_Latin_1 a-chzla1 ads.
* Ada.Characters.Wide_Wide_Latin_9 (a-chzla9.ads): Ada Characters Wide_Wide_Latin_9 a-chzla9 ads.
-* Ada.Containers.Formal_Doubly_Linked_Lists (a-cfdlli.ads): Ada Containers Formal_Doubly_Linked_Lists a-cfdlli ads.
-* Ada.Containers.Formal_Hashed_Maps (a-cfhama.ads): Ada Containers Formal_Hashed_Maps a-cfhama ads.
-* Ada.Containers.Formal_Hashed_Sets (a-cfhase.ads): Ada Containers Formal_Hashed_Sets a-cfhase ads.
-* Ada.Containers.Formal_Ordered_Maps (a-cforma.ads): Ada Containers Formal_Ordered_Maps a-cforma ads.
-* Ada.Containers.Formal_Ordered_Sets (a-cforse.ads): Ada Containers Formal_Ordered_Sets a-cforse ads.
-* Ada.Containers.Formal_Vectors (a-cofove.ads): Ada Containers Formal_Vectors a-cofove ads.
-* Ada.Containers.Formal_Indefinite_Vectors (a-cfinve.ads): Ada Containers Formal_Indefinite_Vectors a-cfinve ads.
-* Ada.Containers.Functional_Infinite_Sequences (a-cfinse.ads): Ada Containers Functional_Infinite_Sequences a-cfinse ads.
-* Ada.Containers.Functional_Vectors (a-cofuve.ads): Ada Containers Functional_Vectors a-cofuve ads.
-* Ada.Containers.Functional_Sets (a-cofuse.ads): Ada Containers Functional_Sets a-cofuse ads.
-* Ada.Containers.Functional_Maps (a-cofuma.ads): Ada Containers Functional_Maps a-cofuma ads.
* Ada.Containers.Bounded_Holders (a-coboho.ads): Ada Containers Bounded_Holders a-coboho ads.
* Ada.Command_Line.Environment (a-colien.ads): Ada Command_Line Environment a-colien ads.
* Ada.Command_Line.Remove (a-colire.ads): Ada Command_Line Remove a-colire ads.
@@ -3717,7 +3705,8 @@ set shall be a proper subset of the second (and the later alternative
will not be executed if the earlier alternative “matches”). All possible
values of the composite type shall be covered. The composite type of the
selector shall be an array or record type that is neither limited
-class-wide.
+class-wide. Currently, a “when others =>” case choice is required; it is
+intended that this requirement will be relaxed at some point.
If a subcomponent’s subtype does not meet certain restrictions, then
the only value that can be specified for that subcomponent in a case
@@ -5273,6 +5262,12 @@ May not dereferenced access values
Function calls and attribute references must be static
@end itemize
+If the Lock_Free aspect is specified to be True for a protected unit
+and the Ceiling_Locking locking policy is in effect, then the run-time
+actions associated with the Ceiling_Locking locking policy (described in
+Ada RM D.3) are not performed when a protected operation of the protected
+unit is executed.
+
@node Pragma Loop_Invariant,Pragma Loop_Optimize,Pragma Lock_Free,Implementation Defined Pragmas
@anchor{gnat_rm/implementation_defined_pragmas pragma-loop-invariant}@anchor{95}
@section Pragma Loop_Invariant
@@ -8662,7 +8657,7 @@ be.
For the variable case, warnings are never given for unreferenced variables
whose name contains one of the substrings
-@code{DISCARD, DUMMY, IGNORE, JUNK, UNUSED} in any casing. Such names
+@code{DISCARD, DUMMY, IGNORE, JUNK, UNUSE, TMP, TEMP} in any casing. Such names
are typically to be used in cases where such warnings are expected.
Thus it is never necessary to use @code{pragma Unmodified} for such
variables, though it is harmless to do so.
@@ -9774,33 +9769,37 @@ The following is a typical example of use:
type List is private with
Iterable => (First => First_Cursor,
Next => Advance,
- Has_Element => Cursor_Has_Element,
- [Element => Get_Element]);
+ Has_Element => Cursor_Has_Element
+ [,Element => Get_Element]
+ [,Last => Last_Cursor]
+ [,Previous => Retreat]);
@end example
@itemize *
@item
-The value denoted by @code{First} must denote a primitive operation of the
-container type that returns a @code{Cursor}, which must a be a type declared in
+The values of @code{First} and @code{Last} are primitive operations of the
+container type that return a @code{Cursor}, which must be a type declared in
the container package or visible from it. For example:
@end itemize
@example
function First_Cursor (Cont : Container) return Cursor;
+function Last_Cursor (Cont : Container) return Cursor;
@end example
@itemize *
@item
-The value of @code{Next} is a primitive operation of the container type that takes
-both a container and a cursor and yields a cursor. For example:
+The values of @code{Next} and @code{Previous} are primitive operations of the container type that take
+both a container and a cursor and yield a cursor. For example:
@end itemize
@example
function Advance (Cont : Container; Position : Cursor) return Cursor;
+function Retreat (Cont : Container; Position : Cursor) return Cursor;
@end example
@@ -10261,7 +10260,6 @@ consideration, you should minimize the use of these attributes.
* Attribute Iterable::
* Attribute Large::
* Attribute Library_Level::
-* Attribute Lock_Free::
* Attribute Loop_Entry::
* Attribute Machine_Size::
* Attribute Mantissa::
@@ -10973,7 +10971,7 @@ The @code{Large} attribute is provided for compatibility with Ada 83. See
the Ada 83 reference manual for an exact description of the semantics of
this attribute.
-@node Attribute Library_Level,Attribute Lock_Free,Attribute Large,Implementation Defined Attributes
+@node Attribute Library_Level,Attribute Loop_Entry,Attribute Large,Implementation Defined Attributes
@anchor{gnat_rm/implementation_defined_attributes attribute-library-level}@anchor{188}
@section Attribute Library_Level
@@ -10999,18 +10997,8 @@ package Gen is
end Gen;
@end example
-@node Attribute Lock_Free,Attribute Loop_Entry,Attribute Library_Level,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-lock-free}@anchor{189}
-@section Attribute Lock_Free
-
-
-@geindex Lock_Free
-
-@code{P'Lock_Free}, where P is a protected object, returns True if a
-pragma @code{Lock_Free} applies to P.
-
-@node Attribute Loop_Entry,Attribute Machine_Size,Attribute Lock_Free,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-loop-entry}@anchor{18a}
+@node Attribute Loop_Entry,Attribute Machine_Size,Attribute Library_Level,Implementation Defined Attributes
+@anchor{gnat_rm/implementation_defined_attributes attribute-loop-entry}@anchor{189}
@section Attribute Loop_Entry
@@ -11043,7 +11031,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{18b}
+@anchor{gnat_rm/implementation_defined_attributes attribute-machine-size}@anchor{18a}
@section Attribute Machine_Size
@@ -11053,7 +11041,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{18c}
+@anchor{gnat_rm/implementation_defined_attributes attribute-mantissa}@anchor{18b}
@section Attribute Mantissa
@@ -11066,7 +11054,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{18d}@anchor{gnat_rm/implementation_defined_attributes id2}@anchor{18e}
+@anchor{gnat_rm/implementation_defined_attributes attribute-maximum-alignment}@anchor{18c}@anchor{gnat_rm/implementation_defined_attributes id2}@anchor{18d}
@section Attribute Maximum_Alignment
@@ -11082,7 +11070,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{18f}
+@anchor{gnat_rm/implementation_defined_attributes attribute-max-integer-size}@anchor{18e}
@section Attribute Max_Integer_Size
@@ -11093,7 +11081,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{190}
+@anchor{gnat_rm/implementation_defined_attributes attribute-mechanism-code}@anchor{18f}
@section Attribute Mechanism_Code
@@ -11124,7 +11112,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{191}
+@anchor{gnat_rm/implementation_defined_attributes attribute-null-parameter}@anchor{190}
@section Attribute Null_Parameter
@@ -11149,7 +11137,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{141}@anchor{gnat_rm/implementation_defined_attributes id3}@anchor{192}
+@anchor{gnat_rm/implementation_defined_attributes attribute-object-size}@anchor{141}@anchor{gnat_rm/implementation_defined_attributes id3}@anchor{191}
@section Attribute Object_Size
@@ -11219,7 +11207,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{193}
+@anchor{gnat_rm/implementation_defined_attributes attribute-old}@anchor{192}
@section Attribute Old
@@ -11234,7 +11222,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{194}
+@anchor{gnat_rm/implementation_defined_attributes attribute-passed-by-reference}@anchor{193}
@section Attribute Passed_By_Reference
@@ -11250,7 +11238,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{195}
+@anchor{gnat_rm/implementation_defined_attributes attribute-pool-address}@anchor{194}
@section Attribute Pool_Address
@@ -11272,7 +11260,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{196}
+@anchor{gnat_rm/implementation_defined_attributes attribute-range-length}@anchor{195}
@section Attribute Range_Length
@@ -11285,7 +11273,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{197}
+@anchor{gnat_rm/implementation_defined_attributes attribute-restriction-set}@anchor{196}
@section Attribute Restriction_Set
@@ -11355,7 +11343,7 @@ Restrictions pragma, they are not analyzed semantically,
so they do not have a type.
@node Attribute Result,Attribute Safe_Emax,Attribute Restriction_Set,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-result}@anchor{198}
+@anchor{gnat_rm/implementation_defined_attributes attribute-result}@anchor{197}
@section Attribute Result
@@ -11368,7 +11356,7 @@ For a further discussion of the use of this attribute and examples of its use,
see the description of pragma Postcondition.
@node Attribute Safe_Emax,Attribute Safe_Large,Attribute Result,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-safe-emax}@anchor{199}
+@anchor{gnat_rm/implementation_defined_attributes attribute-safe-emax}@anchor{198}
@section Attribute Safe_Emax
@@ -11381,7 +11369,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{19a}
+@anchor{gnat_rm/implementation_defined_attributes attribute-safe-large}@anchor{199}
@section Attribute Safe_Large
@@ -11394,7 +11382,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{19b}
+@anchor{gnat_rm/implementation_defined_attributes attribute-safe-small}@anchor{19a}
@section Attribute Safe_Small
@@ -11407,7 +11395,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{14f}@anchor{gnat_rm/implementation_defined_attributes id4}@anchor{19c}
+@anchor{gnat_rm/implementation_defined_attributes attribute-scalar-storage-order}@anchor{14f}@anchor{gnat_rm/implementation_defined_attributes id4}@anchor{19b}
@section Attribute Scalar_Storage_Order
@@ -11570,7 +11558,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{e4}@anchor{gnat_rm/implementation_defined_attributes id5}@anchor{19d}
+@anchor{gnat_rm/implementation_defined_attributes attribute-simple-storage-pool}@anchor{e4}@anchor{gnat_rm/implementation_defined_attributes id5}@anchor{19c}
@section Attribute Simple_Storage_Pool
@@ -11633,7 +11621,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{19e}
+@anchor{gnat_rm/implementation_defined_attributes attribute-small}@anchor{19d}
@section Attribute Small
@@ -11649,7 +11637,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{19f}
+@anchor{gnat_rm/implementation_defined_attributes attribute-small-denominator}@anchor{19e}
@section Attribute Small_Denominator
@@ -11662,7 +11650,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{1a0}
+@anchor{gnat_rm/implementation_defined_attributes attribute-small-numerator}@anchor{19f}
@section Attribute Small_Numerator
@@ -11675,7 +11663,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{1a1}
+@anchor{gnat_rm/implementation_defined_attributes attribute-storage-unit}@anchor{1a0}
@section Attribute Storage_Unit
@@ -11685,7 +11673,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{1a2}
+@anchor{gnat_rm/implementation_defined_attributes attribute-stub-type}@anchor{1a1}
@section Attribute Stub_Type
@@ -11709,7 +11697,7 @@ unit @code{System.Partition_Interface}. Use of this attribute will create
an implicit dependency on this unit.
@node Attribute System_Allocator_Alignment,Attribute Target_Name,Attribute Stub_Type,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-system-allocator-alignment}@anchor{1a3}
+@anchor{gnat_rm/implementation_defined_attributes attribute-system-allocator-alignment}@anchor{1a2}
@section Attribute System_Allocator_Alignment
@@ -11726,7 +11714,7 @@ with alignment too large or to enable a realignment circuitry if the
alignment request is larger than this value.
@node Attribute Target_Name,Attribute To_Address,Attribute System_Allocator_Alignment,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-target-name}@anchor{1a4}
+@anchor{gnat_rm/implementation_defined_attributes attribute-target-name}@anchor{1a3}
@section Attribute Target_Name
@@ -11739,7 +11727,7 @@ standard gcc target name without the terminating slash (for
example, GNAT 5.0 on windows yields “i586-pc-mingw32msv”).
@node Attribute To_Address,Attribute To_Any,Attribute Target_Name,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-to-address}@anchor{1a5}
+@anchor{gnat_rm/implementation_defined_attributes attribute-to-address}@anchor{1a4}
@section Attribute To_Address
@@ -11762,7 +11750,7 @@ modular manner (e.g., -1 means the same as 16#FFFF_FFFF# on
a 32 bits machine).
@node Attribute To_Any,Attribute Type_Class,Attribute To_Address,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-to-any}@anchor{1a6}
+@anchor{gnat_rm/implementation_defined_attributes attribute-to-any}@anchor{1a5}
@section Attribute To_Any
@@ -11772,7 +11760,7 @@ This internal attribute is used for the generation of remote subprogram
stubs in the context of the Distributed Systems Annex.
@node Attribute Type_Class,Attribute Type_Key,Attribute To_Any,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-type-class}@anchor{1a7}
+@anchor{gnat_rm/implementation_defined_attributes attribute-type-class}@anchor{1a6}
@section Attribute Type_Class
@@ -11802,7 +11790,7 @@ applies to all concurrent types. This attribute is designed to
be compatible with the DEC Ada 83 attribute of the same name.
@node Attribute Type_Key,Attribute TypeCode,Attribute Type_Class,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-type-key}@anchor{1a8}
+@anchor{gnat_rm/implementation_defined_attributes attribute-type-key}@anchor{1a7}
@section Attribute Type_Key
@@ -11814,7 +11802,7 @@ about the type or subtype. This provides improved compatibility with
other implementations that support this attribute.
@node Attribute TypeCode,Attribute Unconstrained_Array,Attribute Type_Key,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-typecode}@anchor{1a9}
+@anchor{gnat_rm/implementation_defined_attributes attribute-typecode}@anchor{1a8}
@section Attribute TypeCode
@@ -11824,7 +11812,7 @@ This internal attribute is used for the generation of remote subprogram
stubs in the context of the Distributed Systems Annex.
@node Attribute Unconstrained_Array,Attribute Universal_Literal_String,Attribute TypeCode,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-unconstrained-array}@anchor{1aa}
+@anchor{gnat_rm/implementation_defined_attributes attribute-unconstrained-array}@anchor{1a9}
@section Attribute Unconstrained_Array
@@ -11838,7 +11826,7 @@ still static, and yields the result of applying this test to the
generic actual.
@node Attribute Universal_Literal_String,Attribute Unrestricted_Access,Attribute Unconstrained_Array,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-universal-literal-string}@anchor{1ab}
+@anchor{gnat_rm/implementation_defined_attributes attribute-universal-literal-string}@anchor{1aa}
@section Attribute Universal_Literal_String
@@ -11866,7 +11854,7 @@ end;
@end example
@node Attribute Unrestricted_Access,Attribute Update,Attribute Universal_Literal_String,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-unrestricted-access}@anchor{1ac}
+@anchor{gnat_rm/implementation_defined_attributes attribute-unrestricted-access}@anchor{1ab}
@section Attribute Unrestricted_Access
@@ -12053,7 +12041,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_Image,Attribute Unrestricted_Access,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-update}@anchor{1ad}
+@anchor{gnat_rm/implementation_defined_attributes attribute-update}@anchor{1ac}
@section Attribute Update
@@ -12134,7 +12122,7 @@ A := A'Update ((1, 2) => 20, (3, 4) => 30);
which changes element (1,2) to 20 and (3,4) to 30.
@node Attribute Valid_Image,Attribute Valid_Scalars,Attribute Update,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-valid-image}@anchor{1ae}
+@anchor{gnat_rm/implementation_defined_attributes attribute-valid-image}@anchor{1ad}
@section Attribute Valid_Image
@@ -12146,7 +12134,7 @@ a String, and returns Boolean. @code{T'Valid_Image (S)} returns True
if and only if @code{T'Value (S)} would not raise Constraint_Error.
@node Attribute Valid_Scalars,Attribute VADS_Size,Attribute Valid_Image,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-valid-scalars}@anchor{1af}
+@anchor{gnat_rm/implementation_defined_attributes attribute-valid-scalars}@anchor{1ae}
@section Attribute Valid_Scalars
@@ -12180,7 +12168,7 @@ write a function with a single use of the attribute, and then call that
function from multiple places.
@node Attribute VADS_Size,Attribute Value_Size,Attribute Valid_Scalars,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-vads-size}@anchor{1b0}
+@anchor{gnat_rm/implementation_defined_attributes attribute-vads-size}@anchor{1af}
@section Attribute VADS_Size
@@ -12200,7 +12188,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{15d}@anchor{gnat_rm/implementation_defined_attributes id6}@anchor{1b1}
+@anchor{gnat_rm/implementation_defined_attributes attribute-value-size}@anchor{15d}@anchor{gnat_rm/implementation_defined_attributes id6}@anchor{1b0}
@section Attribute Value_Size
@@ -12214,7 +12202,7 @@ a value of the given subtype. It is the same as @code{type'Size},
but, unlike @code{Size}, may be set for non-first subtypes.
@node Attribute Wchar_T_Size,Attribute Word_Size,Attribute Value_Size,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-wchar-t-size}@anchor{1b2}
+@anchor{gnat_rm/implementation_defined_attributes attribute-wchar-t-size}@anchor{1b1}
@section Attribute Wchar_T_Size
@@ -12226,7 +12214,7 @@ primarily for constructing the definition of this type in
package @code{Interfaces.C}. The result is a static constant.
@node Attribute Word_Size,,Attribute Wchar_T_Size,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-word-size}@anchor{1b3}
+@anchor{gnat_rm/implementation_defined_attributes attribute-word-size}@anchor{1b2}
@section Attribute Word_Size
@@ -12237,7 +12225,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{1b4}@anchor{gnat_rm/standard_and_implementation_defined_restrictions id1}@anchor{1b5}@anchor{gnat_rm/standard_and_implementation_defined_restrictions standard-and-implementation-defined-restrictions}@anchor{9}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions doc}@anchor{1b3}@anchor{gnat_rm/standard_and_implementation_defined_restrictions id1}@anchor{1b4}@anchor{gnat_rm/standard_and_implementation_defined_restrictions standard-and-implementation-defined-restrictions}@anchor{9}
@chapter Standard and Implementation Defined Restrictions
@@ -12266,7 +12254,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{1b6}@anchor{gnat_rm/standard_and_implementation_defined_restrictions partition-wide-restrictions}@anchor{1b7}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions id2}@anchor{1b5}@anchor{gnat_rm/standard_and_implementation_defined_restrictions partition-wide-restrictions}@anchor{1b6}
@section Partition-Wide Restrictions
@@ -12357,7 +12345,7 @@ then all compilation units in the partition must obey the restriction).
@end menu
@node Immediate_Reclamation,Max_Asynchronous_Select_Nesting,,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions immediate-reclamation}@anchor{1b8}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions immediate-reclamation}@anchor{1b7}
@subsection Immediate_Reclamation
@@ -12369,7 +12357,7 @@ deallocation, any storage reserved at run time for an object is
immediately reclaimed when the object no longer exists.
@node Max_Asynchronous_Select_Nesting,Max_Entry_Queue_Length,Immediate_Reclamation,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-asynchronous-select-nesting}@anchor{1b9}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-asynchronous-select-nesting}@anchor{1b8}
@subsection Max_Asynchronous_Select_Nesting
@@ -12381,7 +12369,7 @@ detected at compile time. Violations of this restriction with values
other than zero cause Storage_Error to be raised.
@node Max_Entry_Queue_Length,Max_Protected_Entries,Max_Asynchronous_Select_Nesting,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-entry-queue-length}@anchor{1ba}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-entry-queue-length}@anchor{1b9}
@subsection Max_Entry_Queue_Length
@@ -12402,7 +12390,7 @@ compatibility purposes (and a warning will be generated for its use if
warnings on obsolescent features are activated).
@node Max_Protected_Entries,Max_Select_Alternatives,Max_Entry_Queue_Length,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-protected-entries}@anchor{1bb}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-protected-entries}@anchor{1ba}
@subsection Max_Protected_Entries
@@ -12413,7 +12401,7 @@ bounds of every entry family of a protected unit shall be static, or shall be
defined by a discriminant of a subtype whose corresponding bound is static.
@node Max_Select_Alternatives,Max_Storage_At_Blocking,Max_Protected_Entries,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-select-alternatives}@anchor{1bc}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-select-alternatives}@anchor{1bb}
@subsection Max_Select_Alternatives
@@ -12422,7 +12410,7 @@ defined by a discriminant of a subtype whose corresponding bound is static.
[RM D.7] Specifies the maximum number of alternatives in a selective accept.
@node Max_Storage_At_Blocking,Max_Task_Entries,Max_Select_Alternatives,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-storage-at-blocking}@anchor{1bd}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-storage-at-blocking}@anchor{1bc}
@subsection Max_Storage_At_Blocking
@@ -12433,7 +12421,7 @@ Storage_Size that can be retained by a blocked task. A violation of this
restriction causes Storage_Error to be raised.
@node Max_Task_Entries,Max_Tasks,Max_Storage_At_Blocking,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-task-entries}@anchor{1be}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-task-entries}@anchor{1bd}
@subsection Max_Task_Entries
@@ -12446,7 +12434,7 @@ defined by a discriminant of a subtype whose
corresponding bound is static.
@node Max_Tasks,No_Abort_Statements,Max_Task_Entries,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-tasks}@anchor{1bf}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-tasks}@anchor{1be}
@subsection Max_Tasks
@@ -12459,7 +12447,7 @@ time. Violations of this restriction with values other than zero cause
Storage_Error to be raised.
@node No_Abort_Statements,No_Access_Parameter_Allocators,Max_Tasks,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-abort-statements}@anchor{1c0}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-abort-statements}@anchor{1bf}
@subsection No_Abort_Statements
@@ -12469,7 +12457,7 @@ Storage_Error to be raised.
no calls to Task_Identification.Abort_Task.
@node No_Access_Parameter_Allocators,No_Access_Subprograms,No_Abort_Statements,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-access-parameter-allocators}@anchor{1c1}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-access-parameter-allocators}@anchor{1c0}
@subsection No_Access_Parameter_Allocators
@@ -12480,7 +12468,7 @@ occurrences of an allocator as the actual parameter to an access
parameter.
@node No_Access_Subprograms,No_Allocators,No_Access_Parameter_Allocators,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-access-subprograms}@anchor{1c2}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-access-subprograms}@anchor{1c1}
@subsection No_Access_Subprograms
@@ -12490,7 +12478,7 @@ parameter.
declarations of access-to-subprogram types.
@node No_Allocators,No_Anonymous_Allocators,No_Access_Subprograms,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-allocators}@anchor{1c3}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-allocators}@anchor{1c2}
@subsection No_Allocators
@@ -12500,7 +12488,7 @@ declarations of access-to-subprogram types.
occurrences of an allocator.
@node No_Anonymous_Allocators,No_Asynchronous_Control,No_Allocators,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-anonymous-allocators}@anchor{1c4}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-anonymous-allocators}@anchor{1c3}
@subsection No_Anonymous_Allocators
@@ -12510,7 +12498,7 @@ occurrences of an allocator.
occurrences of an allocator of anonymous access type.
@node No_Asynchronous_Control,No_Calendar,No_Anonymous_Allocators,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-asynchronous-control}@anchor{1c5}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-asynchronous-control}@anchor{1c4}
@subsection No_Asynchronous_Control
@@ -12520,7 +12508,7 @@ occurrences of an allocator of anonymous access type.
dependences on the predefined package Asynchronous_Task_Control.
@node No_Calendar,No_Coextensions,No_Asynchronous_Control,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-calendar}@anchor{1c6}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-calendar}@anchor{1c5}
@subsection No_Calendar
@@ -12530,7 +12518,7 @@ dependences on the predefined package Asynchronous_Task_Control.
dependences on package Calendar.
@node No_Coextensions,No_Default_Initialization,No_Calendar,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-coextensions}@anchor{1c7}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-coextensions}@anchor{1c6}
@subsection No_Coextensions
@@ -12540,7 +12528,7 @@ dependences on package Calendar.
coextensions. See 3.10.2.
@node No_Default_Initialization,No_Delay,No_Coextensions,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-default-initialization}@anchor{1c8}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-default-initialization}@anchor{1c7}
@subsection No_Default_Initialization
@@ -12557,7 +12545,7 @@ is to prohibit all cases of variables declared without a specific
initializer (including the case of OUT scalar parameters).
@node No_Delay,No_Dependence,No_Default_Initialization,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-delay}@anchor{1c9}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-delay}@anchor{1c8}
@subsection No_Delay
@@ -12567,7 +12555,7 @@ initializer (including the case of OUT scalar parameters).
delay statements and no semantic dependences on package Calendar.
@node No_Dependence,No_Direct_Boolean_Operators,No_Delay,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dependence}@anchor{1ca}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dependence}@anchor{1c9}
@subsection No_Dependence
@@ -12579,7 +12567,7 @@ dependences on units of the runtime library that are created by the compiler
to support specific constructs of the language.
@node No_Direct_Boolean_Operators,No_Dispatch,No_Dependence,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-direct-boolean-operators}@anchor{1cb}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-direct-boolean-operators}@anchor{1ca}
@subsection No_Direct_Boolean_Operators
@@ -12592,7 +12580,7 @@ protocol requires the use of short-circuit (and then, or else) forms for all
composite boolean operations.
@node No_Dispatch,No_Dispatching_Calls,No_Direct_Boolean_Operators,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dispatch}@anchor{1cc}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dispatch}@anchor{1cb}
@subsection No_Dispatch
@@ -12602,7 +12590,7 @@ composite boolean operations.
occurrences of @code{T'Class}, for any (tagged) subtype @code{T}.
@node No_Dispatching_Calls,No_Dynamic_Attachment,No_Dispatch,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dispatching-calls}@anchor{1cd}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dispatching-calls}@anchor{1cc}
@subsection No_Dispatching_Calls
@@ -12663,7 +12651,7 @@ end Example;
@end example
@node No_Dynamic_Attachment,No_Dynamic_Priorities,No_Dispatching_Calls,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dynamic-attachment}@anchor{1ce}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dynamic-attachment}@anchor{1cd}
@subsection No_Dynamic_Attachment
@@ -12682,7 +12670,7 @@ compatibility purposes (and a warning will be generated for its use if
warnings on obsolescent features are activated).
@node No_Dynamic_Priorities,No_Entry_Calls_In_Elaboration_Code,No_Dynamic_Attachment,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dynamic-priorities}@anchor{1cf}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dynamic-priorities}@anchor{1ce}
@subsection No_Dynamic_Priorities
@@ -12691,7 +12679,7 @@ warnings on obsolescent features are activated).
[RM D.7] There are no semantic dependencies on the package Dynamic_Priorities.
@node No_Entry_Calls_In_Elaboration_Code,No_Enumeration_Maps,No_Dynamic_Priorities,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-entry-calls-in-elaboration-code}@anchor{1d0}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-entry-calls-in-elaboration-code}@anchor{1cf}
@subsection No_Entry_Calls_In_Elaboration_Code
@@ -12703,7 +12691,7 @@ restriction, the compiler can assume that no code past an accept statement
in a task can be executed at elaboration time.
@node No_Enumeration_Maps,No_Exception_Handlers,No_Entry_Calls_In_Elaboration_Code,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-enumeration-maps}@anchor{1d1}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-enumeration-maps}@anchor{1d0}
@subsection No_Enumeration_Maps
@@ -12714,7 +12702,7 @@ enumeration maps are used (that is Image and Value attributes applied
to enumeration types).
@node No_Exception_Handlers,No_Exception_Propagation,No_Enumeration_Maps,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-exception-handlers}@anchor{1d2}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-exception-handlers}@anchor{1d1}
@subsection No_Exception_Handlers
@@ -12739,7 +12727,7 @@ statement generated by the compiler). The Line parameter when nonzero
represents the line number in the source program where the raise occurs.
@node No_Exception_Propagation,No_Exception_Registration,No_Exception_Handlers,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-exception-propagation}@anchor{1d3}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-exception-propagation}@anchor{1d2}
@subsection No_Exception_Propagation
@@ -12756,7 +12744,7 @@ the package GNAT.Current_Exception is not permitted, and reraise
statements (raise with no operand) are not permitted.
@node No_Exception_Registration,No_Exceptions,No_Exception_Propagation,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-exception-registration}@anchor{1d4}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-exception-registration}@anchor{1d3}
@subsection No_Exception_Registration
@@ -12770,7 +12758,7 @@ code is simplified by omitting the otherwise-required global registration
of exceptions when they are declared.
@node No_Exceptions,No_Finalization,No_Exception_Registration,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-exceptions}@anchor{1d5}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-exceptions}@anchor{1d4}
@subsection No_Exceptions
@@ -12781,7 +12769,7 @@ raise statements and no exception handlers and also suppresses the
generation of language-defined run-time checks.
@node No_Finalization,No_Fixed_Point,No_Exceptions,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-finalization}@anchor{1d6}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-finalization}@anchor{1d5}
@subsection No_Finalization
@@ -12822,7 +12810,7 @@ object or a nested component, either declared on the stack or on the heap. The
deallocation of a controlled object no longer finalizes its contents.
@node No_Fixed_Point,No_Floating_Point,No_Finalization,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-fixed-point}@anchor{1d7}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-fixed-point}@anchor{1d6}
@subsection No_Fixed_Point
@@ -12832,7 +12820,7 @@ deallocation of a controlled object no longer finalizes its contents.
occurrences of fixed point types and operations.
@node No_Floating_Point,No_Implicit_Conditionals,No_Fixed_Point,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-floating-point}@anchor{1d8}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-floating-point}@anchor{1d7}
@subsection No_Floating_Point
@@ -12842,7 +12830,7 @@ occurrences of fixed point types and operations.
occurrences of floating point types and operations.
@node No_Implicit_Conditionals,No_Implicit_Dynamic_Code,No_Floating_Point,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-conditionals}@anchor{1d9}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-conditionals}@anchor{1d8}
@subsection No_Implicit_Conditionals
@@ -12858,7 +12846,7 @@ normal manner. Constructs generating implicit conditionals include comparisons
of composite objects and the Max/Min attributes.
@node No_Implicit_Dynamic_Code,No_Implicit_Heap_Allocations,No_Implicit_Conditionals,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-dynamic-code}@anchor{1da}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-dynamic-code}@anchor{1d9}
@subsection No_Implicit_Dynamic_Code
@@ -12888,7 +12876,7 @@ foreign-language convention; primitive operations of nested tagged
types.
@node No_Implicit_Heap_Allocations,No_Implicit_Protected_Object_Allocations,No_Implicit_Dynamic_Code,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-heap-allocations}@anchor{1db}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-heap-allocations}@anchor{1da}
@subsection No_Implicit_Heap_Allocations
@@ -12897,7 +12885,7 @@ types.
[RM D.7] No constructs are allowed to cause implicit heap allocation.
@node No_Implicit_Protected_Object_Allocations,No_Implicit_Task_Allocations,No_Implicit_Heap_Allocations,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-protected-object-allocations}@anchor{1dc}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-protected-object-allocations}@anchor{1db}
@subsection No_Implicit_Protected_Object_Allocations
@@ -12907,7 +12895,7 @@ types.
protected object.
@node No_Implicit_Task_Allocations,No_Initialize_Scalars,No_Implicit_Protected_Object_Allocations,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-task-allocations}@anchor{1dd}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-task-allocations}@anchor{1dc}
@subsection No_Implicit_Task_Allocations
@@ -12916,7 +12904,7 @@ protected object.
[GNAT] No constructs are allowed to cause implicit heap allocation of a task.
@node No_Initialize_Scalars,No_IO,No_Implicit_Task_Allocations,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-initialize-scalars}@anchor{1de}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-initialize-scalars}@anchor{1dd}
@subsection No_Initialize_Scalars
@@ -12928,7 +12916,7 @@ code, and in particular eliminates dummy null initialization routines that
are otherwise generated for some record and array types.
@node No_IO,No_Local_Allocators,No_Initialize_Scalars,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-io}@anchor{1df}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-io}@anchor{1de}
@subsection No_IO
@@ -12939,7 +12927,7 @@ dependences on any of the library units Sequential_IO, Direct_IO,
Text_IO, Wide_Text_IO, Wide_Wide_Text_IO, or Stream_IO.
@node No_Local_Allocators,No_Local_Protected_Objects,No_IO,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-local-allocators}@anchor{1e0}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-local-allocators}@anchor{1df}
@subsection No_Local_Allocators
@@ -12950,7 +12938,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{1e1}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-local-protected-objects}@anchor{1e0}
@subsection No_Local_Protected_Objects
@@ -12960,7 +12948,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{1e2}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-local-tagged-types}@anchor{1e1}
@subsection No_Local_Tagged_Types
@@ -12970,7 +12958,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{1e3}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-local-timing-events}@anchor{1e2}
@subsection No_Local_Timing_Events
@@ -12980,7 +12968,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{1e4}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-long-long-integers}@anchor{1e3}
@subsection No_Long_Long_Integers
@@ -12992,7 +12980,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{1e5}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-multiple-elaboration}@anchor{1e4}
@subsection No_Multiple_Elaboration
@@ -13008,7 +12996,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{1e6}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-nested-finalization}@anchor{1e5}
@subsection No_Nested_Finalization
@@ -13017,7 +13005,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{1e7}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-protected-type-allocators}@anchor{1e6}
@subsection No_Protected_Type_Allocators
@@ -13027,7 +13015,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{1e8}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-protected-types}@anchor{1e7}
@subsection No_Protected_Types
@@ -13037,7 +13025,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{1e9}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-recursion}@anchor{1e8}
@subsection No_Recursion
@@ -13047,7 +13035,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{1ea}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-reentrancy}@anchor{1e9}
@subsection No_Reentrancy
@@ -13057,7 +13045,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{1eb}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-relative-delay}@anchor{1ea}
@subsection No_Relative_Delay
@@ -13068,7 +13056,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{1ec}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-requeue-statements}@anchor{1eb}
@subsection No_Requeue_Statements
@@ -13086,7 +13074,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{1ed}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-secondary-stack}@anchor{1ec}
@subsection No_Secondary_Stack
@@ -13099,7 +13087,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{1ee}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-select-statements}@anchor{1ed}
@subsection No_Select_Statements
@@ -13109,7 +13097,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{1ef}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-specific-termination-handlers}@anchor{1ee}
@subsection No_Specific_Termination_Handlers
@@ -13119,7 +13107,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{1f0}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-specification-of-aspect}@anchor{1ef}
@subsection No_Specification_of_Aspect
@@ -13130,7 +13118,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{1f1}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-standard-allocators-after-elaboration}@anchor{1f0}
@subsection No_Standard_Allocators_After_Elaboration
@@ -13142,7 +13130,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{1f2}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-standard-storage-pools}@anchor{1f1}
@subsection No_Standard_Storage_Pools
@@ -13154,7 +13142,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{1f3}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-stream-optimizations}@anchor{1f2}
@subsection No_Stream_Optimizations
@@ -13167,7 +13155,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{1f4}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-streams}@anchor{1f3}
@subsection No_Streams
@@ -13188,7 +13176,7 @@ unit declaring a tagged type should be compiled with the restriction,
though this is not required.
@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{1f5}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-tagged-type-registration}@anchor{1f4}
@subsection No_Tagged_Type_Registration
@@ -13203,7 +13191,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{1f6}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-task-allocators}@anchor{1f5}
@subsection No_Task_Allocators
@@ -13213,7 +13201,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{1f7}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-task-at-interrupt-priority}@anchor{1f6}
@subsection No_Task_At_Interrupt_Priority
@@ -13225,7 +13213,7 @@ a consequence, the tasks are always created with a priority below
that an interrupt priority.
@node No_Task_Attributes_Package,No_Task_Hierarchy,No_Task_At_Interrupt_Priority,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-task-attributes-package}@anchor{1f8}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-task-attributes-package}@anchor{1f7}
@subsection No_Task_Attributes_Package
@@ -13242,7 +13230,7 @@ compatibility purposes (and a warning will be generated for its use if
warnings on obsolescent features are activated).
@node No_Task_Hierarchy,No_Task_Termination,No_Task_Attributes_Package,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-task-hierarchy}@anchor{1f9}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-task-hierarchy}@anchor{1f8}
@subsection No_Task_Hierarchy
@@ -13252,7 +13240,7 @@ warnings on obsolescent features are activated).
directly on the environment task of the partition.
@node No_Task_Termination,No_Tasking,No_Task_Hierarchy,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-task-termination}@anchor{1fa}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-task-termination}@anchor{1f9}
@subsection No_Task_Termination
@@ -13261,7 +13249,7 @@ directly on the environment task of the partition.
[RM D.7] Tasks that terminate are erroneous.
@node No_Tasking,No_Terminate_Alternatives,No_Task_Termination,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-tasking}@anchor{1fb}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-tasking}@anchor{1fa}
@subsection No_Tasking
@@ -13274,7 +13262,7 @@ and cause an error message to be output either by the compiler or
binder.
@node No_Terminate_Alternatives,No_Unchecked_Access,No_Tasking,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-terminate-alternatives}@anchor{1fc}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-terminate-alternatives}@anchor{1fb}
@subsection No_Terminate_Alternatives
@@ -13283,7 +13271,7 @@ binder.
[RM D.7] There are no selective accepts with terminate alternatives.
@node No_Unchecked_Access,No_Unchecked_Conversion,No_Terminate_Alternatives,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-unchecked-access}@anchor{1fd}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-unchecked-access}@anchor{1fc}
@subsection No_Unchecked_Access
@@ -13293,7 +13281,7 @@ binder.
occurrences of the Unchecked_Access attribute.
@node No_Unchecked_Conversion,No_Unchecked_Deallocation,No_Unchecked_Access,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-unchecked-conversion}@anchor{1fe}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-unchecked-conversion}@anchor{1fd}
@subsection No_Unchecked_Conversion
@@ -13303,7 +13291,7 @@ occurrences of the Unchecked_Access attribute.
dependences on the predefined generic function Unchecked_Conversion.
@node No_Unchecked_Deallocation,No_Use_Of_Entity,No_Unchecked_Conversion,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-unchecked-deallocation}@anchor{1ff}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-unchecked-deallocation}@anchor{1fe}
@subsection No_Unchecked_Deallocation
@@ -13313,7 +13301,7 @@ dependences on the predefined generic function Unchecked_Conversion.
dependences on the predefined generic procedure Unchecked_Deallocation.
@node No_Use_Of_Entity,Pure_Barriers,No_Unchecked_Deallocation,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-use-of-entity}@anchor{200}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-use-of-entity}@anchor{1ff}
@subsection No_Use_Of_Entity
@@ -13333,7 +13321,7 @@ No_Use_Of_Entity => Ada.Text_IO.Put_Line
@end example
@node Pure_Barriers,Simple_Barriers,No_Use_Of_Entity,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions pure-barriers}@anchor{201}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions pure-barriers}@anchor{200}
@subsection Pure_Barriers
@@ -13384,7 +13372,7 @@ but still ensures absence of side effects, exceptions, and recursion
during the evaluation of the barriers.
@node Simple_Barriers,Static_Priorities,Pure_Barriers,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions simple-barriers}@anchor{202}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions simple-barriers}@anchor{201}
@subsection Simple_Barriers
@@ -13403,7 +13391,7 @@ compatibility purposes (and a warning will be generated for its use if
warnings on obsolescent features are activated).
@node Static_Priorities,Static_Storage_Size,Simple_Barriers,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions static-priorities}@anchor{203}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions static-priorities}@anchor{202}
@subsection Static_Priorities
@@ -13414,7 +13402,7 @@ are static, and that there are no dependences on the package
@code{Ada.Dynamic_Priorities}.
@node Static_Storage_Size,,Static_Priorities,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions static-storage-size}@anchor{204}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions static-storage-size}@anchor{203}
@subsection Static_Storage_Size
@@ -13424,7 +13412,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{205}@anchor{gnat_rm/standard_and_implementation_defined_restrictions program-unit-level-restrictions}@anchor{206}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions id3}@anchor{204}@anchor{gnat_rm/standard_and_implementation_defined_restrictions program-unit-level-restrictions}@anchor{205}
@section Program Unit Level Restrictions
@@ -13455,7 +13443,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{207}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-elaboration-code}@anchor{206}
@subsection No_Elaboration_Code
@@ -13511,7 +13499,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{208}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dynamic-accessibility-checks}@anchor{207}
@subsection No_Dynamic_Accessibility_Checks
@@ -13560,7 +13548,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{209}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dynamic-sized-objects}@anchor{208}
@subsection No_Dynamic_Sized_Objects
@@ -13578,7 +13566,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{20a}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-entry-queue}@anchor{209}
@subsection No_Entry_Queue
@@ -13591,7 +13579,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{20b}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-aspect-specifications}@anchor{20a}
@subsection No_Implementation_Aspect_Specifications
@@ -13602,7 +13590,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{20c}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-attributes}@anchor{20b}
@subsection No_Implementation_Attributes
@@ -13614,7 +13602,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{20d}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-identifiers}@anchor{20c}
@subsection No_Implementation_Identifiers
@@ -13625,7 +13613,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{20e}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-pragmas}@anchor{20d}
@subsection No_Implementation_Pragmas
@@ -13636,7 +13624,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{20f}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-restrictions}@anchor{20e}
@subsection No_Implementation_Restrictions
@@ -13648,7 +13636,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{210}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-units}@anchor{20f}
@subsection No_Implementation_Units
@@ -13659,7 +13647,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{211}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-aliasing}@anchor{210}
@subsection No_Implicit_Aliasing
@@ -13674,7 +13662,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{212}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-loops}@anchor{211}
@subsection No_Implicit_Loops
@@ -13691,7 +13679,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{213}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-obsolescent-features}@anchor{212}
@subsection No_Obsolescent_Features
@@ -13701,7 +13689,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{214}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-wide-characters}@anchor{213}
@subsection No_Wide_Characters
@@ -13715,7 +13703,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{215}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions static-dispatch-tables}@anchor{214}
@subsection Static_Dispatch_Tables
@@ -13725,7 +13713,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{216}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions spark-05}@anchor{215}
@subsection SPARK_05
@@ -13748,7 +13736,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{217}@anchor{gnat_rm/implementation_advice id1}@anchor{218}@anchor{gnat_rm/implementation_advice implementation-advice}@anchor{a}
+@anchor{gnat_rm/implementation_advice doc}@anchor{216}@anchor{gnat_rm/implementation_advice id1}@anchor{217}@anchor{gnat_rm/implementation_advice implementation-advice}@anchor{a}
@chapter Implementation Advice
@@ -13846,7 +13834,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{219}
+@anchor{gnat_rm/implementation_advice rm-1-1-3-20-error-detection}@anchor{218}
@section RM 1.1.3(20): Error Detection
@@ -13863,7 +13851,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{21a}
+@anchor{gnat_rm/implementation_advice rm-1-1-3-31-child-units}@anchor{219}
@section RM 1.1.3(31): Child Units
@@ -13879,7 +13867,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{21b}
+@anchor{gnat_rm/implementation_advice rm-1-1-5-12-bounded-errors}@anchor{21a}
@section RM 1.1.5(12): Bounded Errors
@@ -13896,7 +13884,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{21c}@anchor{gnat_rm/implementation_advice rm-2-8-16-pragmas}@anchor{21d}
+@anchor{gnat_rm/implementation_advice id2}@anchor{21b}@anchor{gnat_rm/implementation_advice rm-2-8-16-pragmas}@anchor{21c}
@section RM 2.8(16): Pragmas
@@ -14009,7 +13997,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{21e}
+@anchor{gnat_rm/implementation_advice rm-2-8-17-19-pragmas}@anchor{21d}
@section RM 2.8(17-19): Pragmas
@@ -14030,14 +14018,14 @@ replacing @code{library_items}.”
@end itemize
@end quotation
-See @ref{21d,,RM 2.8(16); Pragmas}.
+See @ref{21c,,RM 2.8(16); Pragmas}.
@geindex Character Sets
@geindex Alternative Character Sets
@node RM 3 5 2 5 Alternative Character Sets,RM 3 5 4 28 Integer Types,RM 2 8 17-19 Pragmas,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-3-5-2-5-alternative-character-sets}@anchor{21f}
+@anchor{gnat_rm/implementation_advice rm-3-5-2-5-alternative-character-sets}@anchor{21e}
@section RM 3.5.2(5): Alternative Character Sets
@@ -14065,7 +14053,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{220}
+@anchor{gnat_rm/implementation_advice rm-3-5-4-28-integer-types}@anchor{21f}
@section RM 3.5.4(28): Integer Types
@@ -14084,7 +14072,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{221}
+@anchor{gnat_rm/implementation_advice rm-3-5-4-29-integer-types}@anchor{220}
@section RM 3.5.4(29): Integer Types
@@ -14100,7 +14088,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{222}
+@anchor{gnat_rm/implementation_advice rm-3-5-5-8-enumeration-values}@anchor{221}
@section RM 3.5.5(8): Enumeration Values
@@ -14120,7 +14108,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{223}
+@anchor{gnat_rm/implementation_advice rm-3-5-7-17-float-types}@anchor{222}
@section RM 3.5.7(17): Float Types
@@ -14150,7 +14138,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{224}
+@anchor{gnat_rm/implementation_advice rm-3-6-2-11-multidimensional-arrays}@anchor{223}
@section RM 3.6.2(11): Multidimensional Arrays
@@ -14168,7 +14156,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{225}
+@anchor{gnat_rm/implementation_advice rm-9-6-30-31-duration-small}@anchor{224}
@section RM 9.6(30-31): Duration’Small
@@ -14189,7 +14177,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{226}
+@anchor{gnat_rm/implementation_advice rm-10-2-1-12-consistent-representation}@anchor{225}
@section RM 10.2.1(12): Consistent Representation
@@ -14211,7 +14199,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{227}
+@anchor{gnat_rm/implementation_advice rm-11-4-1-19-exception-information}@anchor{226}
@section RM 11.4.1(19): Exception Information
@@ -14242,7 +14230,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{228}
+@anchor{gnat_rm/implementation_advice rm-11-5-28-suppression-of-checks}@anchor{227}
@section RM 11.5(28): Suppression of Checks
@@ -14257,7 +14245,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{229}
+@anchor{gnat_rm/implementation_advice rm-13-1-21-24-representation-clauses}@anchor{228}
@section RM 13.1 (21-24): Representation Clauses
@@ -14306,7 +14294,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{22a}
+@anchor{gnat_rm/implementation_advice rm-13-2-6-8-packed-types}@anchor{229}
@section RM 13.2(6-8): Packed Types
@@ -14337,7 +14325,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{22b}
+@anchor{gnat_rm/implementation_advice rm-13-3-14-19-address-clauses}@anchor{22a}
@section RM 13.3(14-19): Address Clauses
@@ -14390,7 +14378,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{22c}
+@anchor{gnat_rm/implementation_advice rm-13-3-29-35-alignment-clauses}@anchor{22b}
@section RM 13.3(29-35): Alignment Clauses
@@ -14447,7 +14435,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{22d}
+@anchor{gnat_rm/implementation_advice rm-13-3-42-43-size-clauses}@anchor{22c}
@section RM 13.3(42-43): Size Clauses
@@ -14465,7 +14453,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{22e}
+@anchor{gnat_rm/implementation_advice rm-13-3-50-56-size-clauses}@anchor{22d}
@section RM 13.3(50-56): Size Clauses
@@ -14516,7 +14504,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{22f}
+@anchor{gnat_rm/implementation_advice rm-13-3-71-73-component-size-clauses}@anchor{22e}
@section RM 13.3(71-73): Component Size Clauses
@@ -14550,7 +14538,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{230}
+@anchor{gnat_rm/implementation_advice rm-13-4-9-10-enumeration-representation-clauses}@anchor{22f}
@section RM 13.4(9-10): Enumeration Representation Clauses
@@ -14572,7 +14560,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{231}
+@anchor{gnat_rm/implementation_advice rm-13-5-1-17-22-record-representation-clauses}@anchor{230}
@section RM 13.5.1(17-22): Record Representation Clauses
@@ -14632,7 +14620,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{232}
+@anchor{gnat_rm/implementation_advice rm-13-5-2-5-storage-place-attributes}@anchor{231}
@section RM 13.5.2(5): Storage Place Attributes
@@ -14652,7 +14640,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{233}
+@anchor{gnat_rm/implementation_advice rm-13-5-3-7-8-bit-ordering}@anchor{232}
@section RM 13.5.3(7-8): Bit Ordering
@@ -14672,7 +14660,7 @@ Thus non-default bit ordering is not supported.
@geindex as private type
@node RM 13 7 37 Address as Private,RM 13 7 1 16 Address Operations,RM 13 5 3 7-8 Bit Ordering,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-13-7-37-address-as-private}@anchor{234}
+@anchor{gnat_rm/implementation_advice rm-13-7-37-address-as-private}@anchor{233}
@section RM 13.7(37): Address as Private
@@ -14690,7 +14678,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{235}
+@anchor{gnat_rm/implementation_advice rm-13-7-1-16-address-operations}@anchor{234}
@section RM 13.7.1(16): Address Operations
@@ -14708,7 +14696,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{236}
+@anchor{gnat_rm/implementation_advice rm-13-9-14-17-unchecked-conversion}@anchor{235}
@section RM 13.9(14-17): Unchecked Conversion
@@ -14752,7 +14740,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{237}
+@anchor{gnat_rm/implementation_advice rm-13-11-23-25-implicit-heap-usage}@anchor{236}
@section RM 13.11(23-25): Implicit Heap Usage
@@ -14803,7 +14791,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{238}
+@anchor{gnat_rm/implementation_advice rm-13-11-2-17-unchecked-deallocation}@anchor{237}
@section RM 13.11.2(17): Unchecked Deallocation
@@ -14818,7 +14806,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{239}
+@anchor{gnat_rm/implementation_advice rm-13-13-2-1-6-stream-oriented-attributes}@anchor{238}
@section RM 13.13.2(1.6): Stream Oriented Attributes
@@ -14849,7 +14837,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{23a}
+@anchor{gnat_rm/implementation_advice rm-a-1-52-names-of-predefined-numeric-types}@anchor{239}
@section RM A.1(52): Names of Predefined Numeric Types
@@ -14867,7 +14855,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{23b}
+@anchor{gnat_rm/implementation_advice rm-a-3-2-49-ada-characters-handling}@anchor{23a}
@section RM A.3.2(49): @code{Ada.Characters.Handling}
@@ -14884,7 +14872,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{23c}
+@anchor{gnat_rm/implementation_advice rm-a-4-4-106-bounded-length-string-handling}@anchor{23b}
@section RM A.4.4(106): Bounded-Length String Handling
@@ -14899,7 +14887,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{23d}
+@anchor{gnat_rm/implementation_advice rm-a-5-2-46-47-random-number-generation}@anchor{23c}
@section RM A.5.2(46-47): Random Number Generation
@@ -14928,7 +14916,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{23e}
+@anchor{gnat_rm/implementation_advice rm-a-10-7-23-get-immediate}@anchor{23d}
@section RM A.10.7(23): @code{Get_Immediate}
@@ -14952,7 +14940,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{23f}
+@anchor{gnat_rm/implementation_advice rm-a-18-containers}@anchor{23e}
@section RM A.18: @code{Containers}
@@ -14973,7 +14961,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{240}
+@anchor{gnat_rm/implementation_advice rm-b-1-39-41-pragma-export}@anchor{23f}
@section RM B.1(39-41): Pragma @code{Export}
@@ -15021,7 +15009,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{241}
+@anchor{gnat_rm/implementation_advice rm-b-2-12-13-package-interfaces}@anchor{240}
@section RM B.2(12-13): Package @code{Interfaces}
@@ -15051,7 +15039,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{242}
+@anchor{gnat_rm/implementation_advice rm-b-3-63-71-interfacing-with-c}@anchor{241}
@section RM B.3(63-71): Interfacing with C
@@ -15139,7 +15127,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{243}
+@anchor{gnat_rm/implementation_advice rm-b-4-95-98-interfacing-with-cobol}@anchor{242}
@section RM B.4(95-98): Interfacing with COBOL
@@ -15180,7 +15168,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{244}
+@anchor{gnat_rm/implementation_advice rm-b-5-22-26-interfacing-with-fortran}@anchor{243}
@section RM B.5(22-26): Interfacing with Fortran
@@ -15231,7 +15219,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{245}
+@anchor{gnat_rm/implementation_advice rm-c-1-3-5-access-to-machine-operations}@anchor{244}
@section RM C.1(3-5): Access to Machine Operations
@@ -15266,7 +15254,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{246}
+@anchor{gnat_rm/implementation_advice rm-c-1-10-16-access-to-machine-operations}@anchor{245}
@section RM C.1(10-16): Access to Machine Operations
@@ -15327,7 +15315,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{247}
+@anchor{gnat_rm/implementation_advice rm-c-3-28-interrupt-support}@anchor{246}
@section RM C.3(28): Interrupt Support
@@ -15345,7 +15333,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{248}
+@anchor{gnat_rm/implementation_advice rm-c-3-1-20-21-protected-procedure-handlers}@anchor{247}
@section RM C.3.1(20-21): Protected Procedure Handlers
@@ -15371,7 +15359,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{249}
+@anchor{gnat_rm/implementation_advice rm-c-3-2-25-package-interrupts}@anchor{248}
@section RM C.3.2(25): Package @code{Interrupts}
@@ -15389,7 +15377,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{24a}
+@anchor{gnat_rm/implementation_advice rm-c-4-14-pre-elaboration-requirements}@anchor{249}
@section RM C.4(14): Pre-elaboration Requirements
@@ -15405,7 +15393,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{24b}
+@anchor{gnat_rm/implementation_advice rm-c-5-8-pragma-discard-names}@anchor{24a}
@section RM C.5(8): Pragma @code{Discard_Names}
@@ -15423,7 +15411,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{24c}
+@anchor{gnat_rm/implementation_advice rm-c-7-2-30-the-package-task-attributes}@anchor{24b}
@section RM C.7.2(30): The Package Task_Attributes
@@ -15444,7 +15432,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{24d}
+@anchor{gnat_rm/implementation_advice rm-d-3-17-locking-policies}@anchor{24c}
@section RM D.3(17): Locking Policies
@@ -15461,7 +15449,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{24e}
+@anchor{gnat_rm/implementation_advice rm-d-4-16-entry-queuing-policies}@anchor{24d}
@section RM D.4(16): Entry Queuing Policies
@@ -15476,7 +15464,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{24f}
+@anchor{gnat_rm/implementation_advice rm-d-6-9-10-preemptive-abort}@anchor{24e}
@section RM D.6(9-10): Preemptive Abort
@@ -15502,7 +15490,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{250}
+@anchor{gnat_rm/implementation_advice rm-d-7-21-tasking-restrictions}@anchor{24f}
@section RM D.7(21): Tasking Restrictions
@@ -15521,7 +15509,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{251}
+@anchor{gnat_rm/implementation_advice rm-d-8-47-49-monotonic-time}@anchor{250}
@section RM D.8(47-49): Monotonic Time
@@ -15556,7 +15544,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{252}
+@anchor{gnat_rm/implementation_advice rm-e-5-28-29-partition-communication-subsystem}@anchor{251}
@section RM E.5(28-29): Partition Communication Subsystem
@@ -15584,7 +15572,7 @@ GNAT.
@geindex COBOL support
@node RM F 7 COBOL Support,RM F 1 2 Decimal Radix Support,RM E 5 28-29 Partition Communication Subsystem,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-f-7-cobol-support}@anchor{253}
+@anchor{gnat_rm/implementation_advice rm-f-7-cobol-support}@anchor{252}
@section RM F(7): COBOL Support
@@ -15604,7 +15592,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{254}
+@anchor{gnat_rm/implementation_advice rm-f-1-2-decimal-radix-support}@anchor{253}
@section RM F.1(2): Decimal Radix Support
@@ -15620,7 +15608,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{255}
+@anchor{gnat_rm/implementation_advice rm-g-numerics}@anchor{254}
@section RM G: Numerics
@@ -15640,7 +15628,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{256}
+@anchor{gnat_rm/implementation_advice rm-g-1-1-56-58-complex-types}@anchor{255}
@section RM G.1.1(56-58): Complex Types
@@ -15702,7 +15690,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{257}
+@anchor{gnat_rm/implementation_advice rm-g-1-2-49-complex-elementary-functions}@anchor{256}
@section RM G.1.2(49): Complex Elementary Functions
@@ -15724,7 +15712,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{258}
+@anchor{gnat_rm/implementation_advice rm-g-2-4-19-accuracy-requirements}@anchor{257}
@section RM G.2.4(19): Accuracy Requirements
@@ -15748,7 +15736,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{259}
+@anchor{gnat_rm/implementation_advice rm-g-2-6-15-complex-arithmetic-accuracy}@anchor{258}
@section RM G.2.6(15): Complex Arithmetic Accuracy
@@ -15766,7 +15754,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{25a}
+@anchor{gnat_rm/implementation_advice rm-h-6-15-2-pragma-partition-elaboration-policy}@anchor{259}
@section RM H.6(15/2): Pragma Partition_Elaboration_Policy
@@ -15781,7 +15769,7 @@ immediately terminated.”
Not followed.
@node Implementation Defined Characteristics,Intrinsic Subprograms,Implementation Advice,Top
-@anchor{gnat_rm/implementation_defined_characteristics doc}@anchor{25b}@anchor{gnat_rm/implementation_defined_characteristics id1}@anchor{25c}@anchor{gnat_rm/implementation_defined_characteristics implementation-defined-characteristics}@anchor{b}
+@anchor{gnat_rm/implementation_defined_characteristics doc}@anchor{25a}@anchor{gnat_rm/implementation_defined_characteristics id1}@anchor{25b}@anchor{gnat_rm/implementation_defined_characteristics implementation-defined-characteristics}@anchor{b}
@chapter Implementation Defined Characteristics
@@ -17076,7 +17064,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{25d,,GNAT.Regexp (g-regexp.ads)}.
+See @ref{25c,,GNAT.Regexp (g-regexp.ads)}.
@itemize *
@@ -18166,7 +18154,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{25e}@anchor{gnat_rm/intrinsic_subprograms id1}@anchor{25f}@anchor{gnat_rm/intrinsic_subprograms intrinsic-subprograms}@anchor{c}
+@anchor{gnat_rm/intrinsic_subprograms doc}@anchor{25d}@anchor{gnat_rm/intrinsic_subprograms id1}@anchor{25e}@anchor{gnat_rm/intrinsic_subprograms intrinsic-subprograms}@anchor{c}
@chapter Intrinsic Subprograms
@@ -18204,7 +18192,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{260}@anchor{gnat_rm/intrinsic_subprograms intrinsic-operators}@anchor{261}
+@anchor{gnat_rm/intrinsic_subprograms id2}@anchor{25f}@anchor{gnat_rm/intrinsic_subprograms intrinsic-operators}@anchor{260}
@section Intrinsic Operators
@@ -18235,7 +18223,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{262}@anchor{gnat_rm/intrinsic_subprograms id3}@anchor{263}
+@anchor{gnat_rm/intrinsic_subprograms compilation-iso-date}@anchor{261}@anchor{gnat_rm/intrinsic_subprograms id3}@anchor{262}
@section Compilation_ISO_Date
@@ -18249,7 +18237,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{264}@anchor{gnat_rm/intrinsic_subprograms id4}@anchor{265}
+@anchor{gnat_rm/intrinsic_subprograms compilation-date}@anchor{263}@anchor{gnat_rm/intrinsic_subprograms id4}@anchor{264}
@section Compilation_Date
@@ -18259,7 +18247,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{266}@anchor{gnat_rm/intrinsic_subprograms id5}@anchor{267}
+@anchor{gnat_rm/intrinsic_subprograms compilation-time}@anchor{265}@anchor{gnat_rm/intrinsic_subprograms id5}@anchor{266}
@section Compilation_Time
@@ -18273,7 +18261,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{268}@anchor{gnat_rm/intrinsic_subprograms id6}@anchor{269}
+@anchor{gnat_rm/intrinsic_subprograms enclosing-entity}@anchor{267}@anchor{gnat_rm/intrinsic_subprograms id6}@anchor{268}
@section Enclosing_Entity
@@ -18287,7 +18275,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{26a}@anchor{gnat_rm/intrinsic_subprograms id7}@anchor{26b}
+@anchor{gnat_rm/intrinsic_subprograms exception-information}@anchor{269}@anchor{gnat_rm/intrinsic_subprograms id7}@anchor{26a}
@section Exception_Information
@@ -18301,7 +18289,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{26c}@anchor{gnat_rm/intrinsic_subprograms id8}@anchor{26d}
+@anchor{gnat_rm/intrinsic_subprograms exception-message}@anchor{26b}@anchor{gnat_rm/intrinsic_subprograms id8}@anchor{26c}
@section Exception_Message
@@ -18315,7 +18303,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{26e}@anchor{gnat_rm/intrinsic_subprograms id9}@anchor{26f}
+@anchor{gnat_rm/intrinsic_subprograms exception-name}@anchor{26d}@anchor{gnat_rm/intrinsic_subprograms id9}@anchor{26e}
@section Exception_Name
@@ -18329,7 +18317,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{270}@anchor{gnat_rm/intrinsic_subprograms id10}@anchor{271}
+@anchor{gnat_rm/intrinsic_subprograms file}@anchor{26f}@anchor{gnat_rm/intrinsic_subprograms id10}@anchor{270}
@section File
@@ -18343,7 +18331,7 @@ application program should simply call the function
file.
@node Line,Shifts and Rotates,File,Intrinsic Subprograms
-@anchor{gnat_rm/intrinsic_subprograms id11}@anchor{272}@anchor{gnat_rm/intrinsic_subprograms line}@anchor{273}
+@anchor{gnat_rm/intrinsic_subprograms id11}@anchor{271}@anchor{gnat_rm/intrinsic_subprograms line}@anchor{272}
@section Line
@@ -18357,7 +18345,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{274}@anchor{gnat_rm/intrinsic_subprograms shifts-and-rotates}@anchor{275}
+@anchor{gnat_rm/intrinsic_subprograms id12}@anchor{273}@anchor{gnat_rm/intrinsic_subprograms shifts-and-rotates}@anchor{274}
@section Shifts and Rotates
@@ -18400,7 +18388,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{276}@anchor{gnat_rm/intrinsic_subprograms source-location}@anchor{277}
+@anchor{gnat_rm/intrinsic_subprograms id13}@anchor{275}@anchor{gnat_rm/intrinsic_subprograms source-location}@anchor{276}
@section Source_Location
@@ -18414,7 +18402,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{278}@anchor{gnat_rm/representation_clauses_and_pragmas id1}@anchor{279}@anchor{gnat_rm/representation_clauses_and_pragmas representation-clauses-and-pragmas}@anchor{d}
+@anchor{gnat_rm/representation_clauses_and_pragmas doc}@anchor{277}@anchor{gnat_rm/representation_clauses_and_pragmas id1}@anchor{278}@anchor{gnat_rm/representation_clauses_and_pragmas representation-clauses-and-pragmas}@anchor{d}
@chapter Representation Clauses and Pragmas
@@ -18460,7 +18448,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{27a}@anchor{gnat_rm/representation_clauses_and_pragmas id2}@anchor{27b}
+@anchor{gnat_rm/representation_clauses_and_pragmas alignment-clauses}@anchor{279}@anchor{gnat_rm/representation_clauses_and_pragmas id2}@anchor{27a}
@section Alignment Clauses
@@ -18482,7 +18470,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{18d,,Attribute Maximum_Alignment}.)
+@code{Standard'Maximum_Alignment}; see @ref{18c,,Attribute Maximum_Alignment}.)
@geindex Maximum_Alignment attribute
@@ -18591,7 +18579,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{27c}@anchor{gnat_rm/representation_clauses_and_pragmas size-clauses}@anchor{27d}
+@anchor{gnat_rm/representation_clauses_and_pragmas id3}@anchor{27b}@anchor{gnat_rm/representation_clauses_and_pragmas size-clauses}@anchor{27c}
@section Size Clauses
@@ -18668,7 +18656,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{27e}@anchor{gnat_rm/representation_clauses_and_pragmas storage-size-clauses}@anchor{27f}
+@anchor{gnat_rm/representation_clauses_and_pragmas id4}@anchor{27d}@anchor{gnat_rm/representation_clauses_and_pragmas storage-size-clauses}@anchor{27e}
@section Storage_Size Clauses
@@ -18741,7 +18729,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{280}@anchor{gnat_rm/representation_clauses_and_pragmas size-of-variant-record-objects}@anchor{281}
+@anchor{gnat_rm/representation_clauses_and_pragmas id5}@anchor{27f}@anchor{gnat_rm/representation_clauses_and_pragmas size-of-variant-record-objects}@anchor{280}
@section Size of Variant Record Objects
@@ -18851,7 +18839,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{282}@anchor{gnat_rm/representation_clauses_and_pragmas id6}@anchor{283}
+@anchor{gnat_rm/representation_clauses_and_pragmas biased-representation}@anchor{281}@anchor{gnat_rm/representation_clauses_and_pragmas id6}@anchor{282}
@section Biased Representation
@@ -18889,7 +18877,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{284}@anchor{gnat_rm/representation_clauses_and_pragmas value-size-and-object-size-clauses}@anchor{285}
+@anchor{gnat_rm/representation_clauses_and_pragmas id7}@anchor{283}@anchor{gnat_rm/representation_clauses_and_pragmas value-size-and-object-size-clauses}@anchor{284}
@section Value_Size and Object_Size Clauses
@@ -19205,7 +19193,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{286}@anchor{gnat_rm/representation_clauses_and_pragmas id8}@anchor{287}
+@anchor{gnat_rm/representation_clauses_and_pragmas component-size-clauses}@anchor{285}@anchor{gnat_rm/representation_clauses_and_pragmas id8}@anchor{286}
@section Component_Size Clauses
@@ -19253,7 +19241,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{288}@anchor{gnat_rm/representation_clauses_and_pragmas id9}@anchor{289}
+@anchor{gnat_rm/representation_clauses_and_pragmas bit-order-clauses}@anchor{287}@anchor{gnat_rm/representation_clauses_and_pragmas id9}@anchor{288}
@section Bit_Order Clauses
@@ -19359,7 +19347,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{28a}@anchor{gnat_rm/representation_clauses_and_pragmas id10}@anchor{28b}
+@anchor{gnat_rm/representation_clauses_and_pragmas effect-of-bit-order-on-byte-ordering}@anchor{289}@anchor{gnat_rm/representation_clauses_and_pragmas id10}@anchor{28a}
@section Effect of Bit_Order on Byte Ordering
@@ -19616,7 +19604,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{28c}@anchor{gnat_rm/representation_clauses_and_pragmas pragma-pack-for-arrays}@anchor{28d}
+@anchor{gnat_rm/representation_clauses_and_pragmas id11}@anchor{28b}@anchor{gnat_rm/representation_clauses_and_pragmas pragma-pack-for-arrays}@anchor{28c}
@section Pragma Pack for Arrays
@@ -19736,7 +19724,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{28e}@anchor{gnat_rm/representation_clauses_and_pragmas pragma-pack-for-records}@anchor{28f}
+@anchor{gnat_rm/representation_clauses_and_pragmas id12}@anchor{28d}@anchor{gnat_rm/representation_clauses_and_pragmas pragma-pack-for-records}@anchor{28e}
@section Pragma Pack for Records
@@ -19820,7 +19808,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{290}@anchor{gnat_rm/representation_clauses_and_pragmas record-representation-clauses}@anchor{291}
+@anchor{gnat_rm/representation_clauses_and_pragmas id13}@anchor{28f}@anchor{gnat_rm/representation_clauses_and_pragmas record-representation-clauses}@anchor{290}
@section Record Representation Clauses
@@ -19899,7 +19887,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{292}@anchor{gnat_rm/representation_clauses_and_pragmas id14}@anchor{293}
+@anchor{gnat_rm/representation_clauses_and_pragmas handling-of-records-with-holes}@anchor{291}@anchor{gnat_rm/representation_clauses_and_pragmas id14}@anchor{292}
@section Handling of Records with Holes
@@ -19975,7 +19963,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{294}@anchor{gnat_rm/representation_clauses_and_pragmas id15}@anchor{295}
+@anchor{gnat_rm/representation_clauses_and_pragmas enumeration-clauses}@anchor{293}@anchor{gnat_rm/representation_clauses_and_pragmas id15}@anchor{294}
@section Enumeration Clauses
@@ -20018,7 +20006,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{296}@anchor{gnat_rm/representation_clauses_and_pragmas id16}@anchor{297}
+@anchor{gnat_rm/representation_clauses_and_pragmas address-clauses}@anchor{295}@anchor{gnat_rm/representation_clauses_and_pragmas id16}@anchor{296}
@section Address Clauses
@@ -20358,7 +20346,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{298}@anchor{gnat_rm/representation_clauses_and_pragmas use-of-address-clauses-for-memory-mapped-i-o}@anchor{299}
+@anchor{gnat_rm/representation_clauses_and_pragmas id17}@anchor{297}@anchor{gnat_rm/representation_clauses_and_pragmas use-of-address-clauses-for-memory-mapped-i-o}@anchor{298}
@section Use of Address Clauses for Memory-Mapped I/O
@@ -20416,7 +20404,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{29a}@anchor{gnat_rm/representation_clauses_and_pragmas id18}@anchor{29b}
+@anchor{gnat_rm/representation_clauses_and_pragmas effect-of-convention-on-representation}@anchor{299}@anchor{gnat_rm/representation_clauses_and_pragmas id18}@anchor{29a}
@section Effect of Convention on Representation
@@ -20494,7 +20482,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{29c}@anchor{gnat_rm/representation_clauses_and_pragmas id19}@anchor{29d}
+@anchor{gnat_rm/representation_clauses_and_pragmas conventions-and-anonymous-access-types}@anchor{29b}@anchor{gnat_rm/representation_clauses_and_pragmas id19}@anchor{29c}
@section Conventions and Anonymous Access Types
@@ -20570,7 +20558,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{29e}@anchor{gnat_rm/representation_clauses_and_pragmas id20}@anchor{29f}
+@anchor{gnat_rm/representation_clauses_and_pragmas determining-the-representations-chosen-by-gnat}@anchor{29d}@anchor{gnat_rm/representation_clauses_and_pragmas id20}@anchor{29e}
@section Determining the Representations chosen by GNAT
@@ -20722,7 +20710,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{2a0}@anchor{gnat_rm/standard_library_routines id1}@anchor{2a1}@anchor{gnat_rm/standard_library_routines standard-library-routines}@anchor{e}
+@anchor{gnat_rm/standard_library_routines doc}@anchor{29f}@anchor{gnat_rm/standard_library_routines id1}@anchor{2a0}@anchor{gnat_rm/standard_library_routines standard-library-routines}@anchor{e}
@chapter Standard Library Routines
@@ -21546,7 +21534,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{2a2}@anchor{gnat_rm/the_implementation_of_standard_i_o id1}@anchor{2a3}@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{2a1}@anchor{gnat_rm/the_implementation_of_standard_i_o id1}@anchor{2a2}@anchor{gnat_rm/the_implementation_of_standard_i_o the-implementation-of-standard-i-o}@anchor{f}
@chapter The Implementation of Standard I/O
@@ -21598,7 +21586,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{2a4}@anchor{gnat_rm/the_implementation_of_standard_i_o standard-i-o-packages}@anchor{2a5}
+@anchor{gnat_rm/the_implementation_of_standard_i_o id2}@anchor{2a3}@anchor{gnat_rm/the_implementation_of_standard_i_o standard-i-o-packages}@anchor{2a4}
@section Standard I/O Packages
@@ -21669,7 +21657,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{2a6}@anchor{gnat_rm/the_implementation_of_standard_i_o id3}@anchor{2a7}
+@anchor{gnat_rm/the_implementation_of_standard_i_o form-strings}@anchor{2a5}@anchor{gnat_rm/the_implementation_of_standard_i_o id3}@anchor{2a6}
@section FORM Strings
@@ -21695,7 +21683,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{2a8}@anchor{gnat_rm/the_implementation_of_standard_i_o id4}@anchor{2a9}
+@anchor{gnat_rm/the_implementation_of_standard_i_o direct-io}@anchor{2a7}@anchor{gnat_rm/the_implementation_of_standard_i_o id4}@anchor{2a8}
@section Direct_IO
@@ -21715,7 +21703,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{2aa}@anchor{gnat_rm/the_implementation_of_standard_i_o sequential-io}@anchor{2ab}
+@anchor{gnat_rm/the_implementation_of_standard_i_o id5}@anchor{2a9}@anchor{gnat_rm/the_implementation_of_standard_i_o sequential-io}@anchor{2aa}
@section Sequential_IO
@@ -21762,7 +21750,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{2ac}@anchor{gnat_rm/the_implementation_of_standard_i_o text-io}@anchor{2ad}
+@anchor{gnat_rm/the_implementation_of_standard_i_o id6}@anchor{2ab}@anchor{gnat_rm/the_implementation_of_standard_i_o text-io}@anchor{2ac}
@section Text_IO
@@ -21845,7 +21833,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{2ae}@anchor{gnat_rm/the_implementation_of_standard_i_o stream-pointer-positioning}@anchor{2af}
+@anchor{gnat_rm/the_implementation_of_standard_i_o id7}@anchor{2ad}@anchor{gnat_rm/the_implementation_of_standard_i_o stream-pointer-positioning}@anchor{2ae}
@subsection Stream Pointer Positioning
@@ -21881,7 +21869,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{2b0}@anchor{gnat_rm/the_implementation_of_standard_i_o reading-and-writing-non-regular-files}@anchor{2b1}
+@anchor{gnat_rm/the_implementation_of_standard_i_o id8}@anchor{2af}@anchor{gnat_rm/the_implementation_of_standard_i_o reading-and-writing-non-regular-files}@anchor{2b0}
@subsection Reading and Writing Non-Regular Files
@@ -21932,7 +21920,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{2b2}@anchor{gnat_rm/the_implementation_of_standard_i_o id9}@anchor{2b3}
+@anchor{gnat_rm/the_implementation_of_standard_i_o get-immediate}@anchor{2b1}@anchor{gnat_rm/the_implementation_of_standard_i_o id9}@anchor{2b2}
@subsection Get_Immediate
@@ -21950,7 +21938,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{2b4}@anchor{gnat_rm/the_implementation_of_standard_i_o treating-text-io-files-as-streams}@anchor{2b5}
+@anchor{gnat_rm/the_implementation_of_standard_i_o id10}@anchor{2b3}@anchor{gnat_rm/the_implementation_of_standard_i_o treating-text-io-files-as-streams}@anchor{2b4}
@subsection Treating Text_IO Files as Streams
@@ -21966,7 +21954,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{2b6}@anchor{gnat_rm/the_implementation_of_standard_i_o text-io-extensions}@anchor{2b7}
+@anchor{gnat_rm/the_implementation_of_standard_i_o id11}@anchor{2b5}@anchor{gnat_rm/the_implementation_of_standard_i_o text-io-extensions}@anchor{2b6}
@subsection Text_IO Extensions
@@ -21994,7 +21982,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{2b8}@anchor{gnat_rm/the_implementation_of_standard_i_o text-io-facilities-for-unbounded-strings}@anchor{2b9}
+@anchor{gnat_rm/the_implementation_of_standard_i_o id12}@anchor{2b7}@anchor{gnat_rm/the_implementation_of_standard_i_o text-io-facilities-for-unbounded-strings}@anchor{2b8}
@subsection Text_IO Facilities for Unbounded Strings
@@ -22042,7 +22030,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{2ba}@anchor{gnat_rm/the_implementation_of_standard_i_o wide-text-io}@anchor{2bb}
+@anchor{gnat_rm/the_implementation_of_standard_i_o id13}@anchor{2b9}@anchor{gnat_rm/the_implementation_of_standard_i_o wide-text-io}@anchor{2ba}
@section Wide_Text_IO
@@ -22289,12 +22277,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{2bc}@anchor{gnat_rm/the_implementation_of_standard_i_o stream-pointer-positioning-1}@anchor{2bd}
+@anchor{gnat_rm/the_implementation_of_standard_i_o id14}@anchor{2bb}@anchor{gnat_rm/the_implementation_of_standard_i_o stream-pointer-positioning-1}@anchor{2bc}
@subsection Stream Pointer Positioning
@code{Ada.Wide_Text_IO} is similar to @code{Ada.Text_IO} in its handling
-of stream pointer positioning (@ref{2ad,,Text_IO}). There is one additional
+of stream pointer positioning (@ref{2ac,,Text_IO}). There is one additional
case:
If @code{Ada.Wide_Text_IO.Look_Ahead} reads a character outside the
@@ -22313,7 +22301,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{2be}@anchor{gnat_rm/the_implementation_of_standard_i_o reading-and-writing-non-regular-files-1}@anchor{2bf}
+@anchor{gnat_rm/the_implementation_of_standard_i_o id15}@anchor{2bd}@anchor{gnat_rm/the_implementation_of_standard_i_o reading-and-writing-non-regular-files-1}@anchor{2be}
@subsection Reading and Writing Non-Regular Files
@@ -22324,7 +22312,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{2c0}@anchor{gnat_rm/the_implementation_of_standard_i_o wide-wide-text-io}@anchor{2c1}
+@anchor{gnat_rm/the_implementation_of_standard_i_o id16}@anchor{2bf}@anchor{gnat_rm/the_implementation_of_standard_i_o wide-wide-text-io}@anchor{2c0}
@section Wide_Wide_Text_IO
@@ -22493,12 +22481,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{2c2}@anchor{gnat_rm/the_implementation_of_standard_i_o stream-pointer-positioning-2}@anchor{2c3}
+@anchor{gnat_rm/the_implementation_of_standard_i_o id17}@anchor{2c1}@anchor{gnat_rm/the_implementation_of_standard_i_o stream-pointer-positioning-2}@anchor{2c2}
@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{2ad,,Text_IO}). There is one additional
+of stream pointer positioning (@ref{2ac,,Text_IO}). There is one additional
case:
If @code{Ada.Wide_Wide_Text_IO.Look_Ahead} reads a character outside the
@@ -22517,7 +22505,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{2c4}@anchor{gnat_rm/the_implementation_of_standard_i_o reading-and-writing-non-regular-files-2}@anchor{2c5}
+@anchor{gnat_rm/the_implementation_of_standard_i_o id18}@anchor{2c3}@anchor{gnat_rm/the_implementation_of_standard_i_o reading-and-writing-non-regular-files-2}@anchor{2c4}
@subsection Reading and Writing Non-Regular Files
@@ -22528,7 +22516,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{2c6}@anchor{gnat_rm/the_implementation_of_standard_i_o stream-io}@anchor{2c7}
+@anchor{gnat_rm/the_implementation_of_standard_i_o id19}@anchor{2c5}@anchor{gnat_rm/the_implementation_of_standard_i_o stream-io}@anchor{2c6}
@section Stream_IO
@@ -22550,7 +22538,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{2c8}@anchor{gnat_rm/the_implementation_of_standard_i_o text-translation}@anchor{2c9}
+@anchor{gnat_rm/the_implementation_of_standard_i_o id20}@anchor{2c7}@anchor{gnat_rm/the_implementation_of_standard_i_o text-translation}@anchor{2c8}
@section Text Translation
@@ -22584,7 +22572,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{2ca}@anchor{gnat_rm/the_implementation_of_standard_i_o shared-files}@anchor{2cb}
+@anchor{gnat_rm/the_implementation_of_standard_i_o id21}@anchor{2c9}@anchor{gnat_rm/the_implementation_of_standard_i_o shared-files}@anchor{2ca}
@section Shared Files
@@ -22647,7 +22635,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{2cc}@anchor{gnat_rm/the_implementation_of_standard_i_o id22}@anchor{2cd}
+@anchor{gnat_rm/the_implementation_of_standard_i_o filenames-encoding}@anchor{2cb}@anchor{gnat_rm/the_implementation_of_standard_i_o id22}@anchor{2cc}
@section Filenames encoding
@@ -22687,7 +22675,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{2ce}@anchor{gnat_rm/the_implementation_of_standard_i_o id23}@anchor{2cf}
+@anchor{gnat_rm/the_implementation_of_standard_i_o file-content-encoding}@anchor{2cd}@anchor{gnat_rm/the_implementation_of_standard_i_o id23}@anchor{2ce}
@section File content encoding
@@ -22720,7 +22708,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{2d0}@anchor{gnat_rm/the_implementation_of_standard_i_o open-modes}@anchor{2d1}
+@anchor{gnat_rm/the_implementation_of_standard_i_o id24}@anchor{2cf}@anchor{gnat_rm/the_implementation_of_standard_i_o open-modes}@anchor{2d0}
@section Open Modes
@@ -22823,7 +22811,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{2d2}@anchor{gnat_rm/the_implementation_of_standard_i_o operations-on-c-streams}@anchor{2d3}
+@anchor{gnat_rm/the_implementation_of_standard_i_o id25}@anchor{2d1}@anchor{gnat_rm/the_implementation_of_standard_i_o operations-on-c-streams}@anchor{2d2}
@section Operations on C Streams
@@ -22983,7 +22971,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{2d4}@anchor{gnat_rm/the_implementation_of_standard_i_o interfacing-to-c-streams}@anchor{2d5}
+@anchor{gnat_rm/the_implementation_of_standard_i_o id26}@anchor{2d3}@anchor{gnat_rm/the_implementation_of_standard_i_o interfacing-to-c-streams}@anchor{2d4}
@section Interfacing to C Streams
@@ -23076,7 +23064,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{2d6}@anchor{gnat_rm/the_gnat_library id1}@anchor{2d7}@anchor{gnat_rm/the_gnat_library the-gnat-library}@anchor{10}
+@anchor{gnat_rm/the_gnat_library doc}@anchor{2d5}@anchor{gnat_rm/the_gnat_library id1}@anchor{2d6}@anchor{gnat_rm/the_gnat_library the-gnat-library}@anchor{10}
@chapter The GNAT Library
@@ -23115,17 +23103,6 @@ of GNAT, and will generate a warning message.
* Ada.Characters.Wide_Latin_9 (a-cwila1.ads): Ada Characters Wide_Latin_9 a-cwila1 ads.
* Ada.Characters.Wide_Wide_Latin_1 (a-chzla1.ads): Ada Characters Wide_Wide_Latin_1 a-chzla1 ads.
* Ada.Characters.Wide_Wide_Latin_9 (a-chzla9.ads): Ada Characters Wide_Wide_Latin_9 a-chzla9 ads.
-* Ada.Containers.Formal_Doubly_Linked_Lists (a-cfdlli.ads): Ada Containers Formal_Doubly_Linked_Lists a-cfdlli ads.
-* Ada.Containers.Formal_Hashed_Maps (a-cfhama.ads): Ada Containers Formal_Hashed_Maps a-cfhama ads.
-* Ada.Containers.Formal_Hashed_Sets (a-cfhase.ads): Ada Containers Formal_Hashed_Sets a-cfhase ads.
-* Ada.Containers.Formal_Ordered_Maps (a-cforma.ads): Ada Containers Formal_Ordered_Maps a-cforma ads.
-* Ada.Containers.Formal_Ordered_Sets (a-cforse.ads): Ada Containers Formal_Ordered_Sets a-cforse ads.
-* Ada.Containers.Formal_Vectors (a-cofove.ads): Ada Containers Formal_Vectors a-cofove ads.
-* Ada.Containers.Formal_Indefinite_Vectors (a-cfinve.ads): Ada Containers Formal_Indefinite_Vectors a-cfinve ads.
-* Ada.Containers.Functional_Infinite_Sequences (a-cfinse.ads): Ada Containers Functional_Infinite_Sequences a-cfinse ads.
-* Ada.Containers.Functional_Vectors (a-cofuve.ads): Ada Containers Functional_Vectors a-cofuve ads.
-* Ada.Containers.Functional_Sets (a-cofuse.ads): Ada Containers Functional_Sets a-cofuse ads.
-* Ada.Containers.Functional_Maps (a-cofuma.ads): Ada Containers Functional_Maps a-cofuma ads.
* Ada.Containers.Bounded_Holders (a-coboho.ads): Ada Containers Bounded_Holders a-coboho ads.
* Ada.Command_Line.Environment (a-colien.ads): Ada Command_Line Environment a-colien ads.
* Ada.Command_Line.Remove (a-colire.ads): Ada Command_Line Remove a-colire ads.
@@ -23273,7 +23250,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{2d8}@anchor{gnat_rm/the_gnat_library id2}@anchor{2d9}
+@anchor{gnat_rm/the_gnat_library ada-characters-latin-9-a-chlat9-ads}@anchor{2d7}@anchor{gnat_rm/the_gnat_library id2}@anchor{2d8}
@section @code{Ada.Characters.Latin_9} (@code{a-chlat9.ads})
@@ -23290,7 +23267,7 @@ is specifically authorized by the Ada Reference Manual
(RM A.3.3(27)).
@node Ada Characters Wide_Latin_1 a-cwila1 ads,Ada Characters Wide_Latin_9 a-cwila1 ads,Ada Characters Latin_9 a-chlat9 ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library ada-characters-wide-latin-1-a-cwila1-ads}@anchor{2da}@anchor{gnat_rm/the_gnat_library id3}@anchor{2db}
+@anchor{gnat_rm/the_gnat_library ada-characters-wide-latin-1-a-cwila1-ads}@anchor{2d9}@anchor{gnat_rm/the_gnat_library id3}@anchor{2da}
@section @code{Ada.Characters.Wide_Latin_1} (@code{a-cwila1.ads})
@@ -23307,7 +23284,7 @@ is specifically authorized by the Ada Reference Manual
(RM A.3.3(27)).
@node Ada Characters Wide_Latin_9 a-cwila1 ads,Ada Characters Wide_Wide_Latin_1 a-chzla1 ads,Ada Characters Wide_Latin_1 a-cwila1 ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library ada-characters-wide-latin-9-a-cwila1-ads}@anchor{2dc}@anchor{gnat_rm/the_gnat_library id4}@anchor{2dd}
+@anchor{gnat_rm/the_gnat_library ada-characters-wide-latin-9-a-cwila1-ads}@anchor{2db}@anchor{gnat_rm/the_gnat_library id4}@anchor{2dc}
@section @code{Ada.Characters.Wide_Latin_9} (@code{a-cwila1.ads})
@@ -23324,7 +23301,7 @@ is specifically authorized by the Ada Reference Manual
(RM A.3.3(27)).
@node Ada Characters Wide_Wide_Latin_1 a-chzla1 ads,Ada Characters Wide_Wide_Latin_9 a-chzla9 ads,Ada Characters Wide_Latin_9 a-cwila1 ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library ada-characters-wide-wide-latin-1-a-chzla1-ads}@anchor{2de}@anchor{gnat_rm/the_gnat_library id5}@anchor{2df}
+@anchor{gnat_rm/the_gnat_library ada-characters-wide-wide-latin-1-a-chzla1-ads}@anchor{2dd}@anchor{gnat_rm/the_gnat_library id5}@anchor{2de}
@section @code{Ada.Characters.Wide_Wide_Latin_1} (@code{a-chzla1.ads})
@@ -23340,8 +23317,8 @@ instead of @code{Character}. The provision of such a package
is specifically authorized by the Ada Reference Manual
(RM A.3.3(27)).
-@node Ada Characters Wide_Wide_Latin_9 a-chzla9 ads,Ada Containers Formal_Doubly_Linked_Lists a-cfdlli ads,Ada Characters Wide_Wide_Latin_1 a-chzla1 ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library ada-characters-wide-wide-latin-9-a-chzla9-ads}@anchor{2e0}@anchor{gnat_rm/the_gnat_library id6}@anchor{2e1}
+@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{2df}@anchor{gnat_rm/the_gnat_library id6}@anchor{2e0}
@section @code{Ada.Characters.Wide_Wide_Latin_9} (@code{a-chzla9.ads})
@@ -23357,227 +23334,8 @@ instead of @code{Character}. The provision of such a package
is specifically authorized by the Ada Reference Manual
(RM A.3.3(27)).
-@node Ada Containers Formal_Doubly_Linked_Lists a-cfdlli ads,Ada Containers Formal_Hashed_Maps a-cfhama ads,Ada Characters Wide_Wide_Latin_9 a-chzla9 ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library ada-containers-formal-doubly-linked-lists-a-cfdlli-ads}@anchor{2e2}@anchor{gnat_rm/the_gnat_library id7}@anchor{2e3}
-@section @code{Ada.Containers.Formal_Doubly_Linked_Lists} (@code{a-cfdlli.ads})
-
-
-@geindex Ada.Containers.Formal_Doubly_Linked_Lists (a-cfdlli.ads)
-
-@geindex Formal container for doubly linked lists
-
-This child of @code{Ada.Containers} defines a modified version of the
-Ada 2005 container for doubly linked lists, meant to facilitate formal
-verification of code using such containers. The specification of this
-unit is compatible with SPARK 2014.
-
-Note that although this container was designed with formal verification
-in mind, it may well be generally useful in that it is a simplified more
-efficient version than the one defined in the standard. In particular it
-does not have the complex overhead required to detect cursor tampering.
-
-@node Ada Containers Formal_Hashed_Maps a-cfhama ads,Ada Containers Formal_Hashed_Sets a-cfhase ads,Ada Containers Formal_Doubly_Linked_Lists a-cfdlli ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library ada-containers-formal-hashed-maps-a-cfhama-ads}@anchor{2e4}@anchor{gnat_rm/the_gnat_library id8}@anchor{2e5}
-@section @code{Ada.Containers.Formal_Hashed_Maps} (@code{a-cfhama.ads})
-
-
-@geindex Ada.Containers.Formal_Hashed_Maps (a-cfhama.ads)
-
-@geindex Formal container for hashed maps
-
-This child of @code{Ada.Containers} defines a modified version of the
-Ada 2005 container for hashed maps, meant to facilitate formal
-verification of code using such containers. The specification of this
-unit is compatible with SPARK 2014.
-
-Note that although this container was designed with formal verification
-in mind, it may well be generally useful in that it is a simplified more
-efficient version than the one defined in the standard. In particular it
-does not have the complex overhead required to detect cursor tampering.
-
-@node Ada Containers Formal_Hashed_Sets a-cfhase ads,Ada Containers Formal_Ordered_Maps a-cforma ads,Ada Containers Formal_Hashed_Maps a-cfhama ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library ada-containers-formal-hashed-sets-a-cfhase-ads}@anchor{2e6}@anchor{gnat_rm/the_gnat_library id9}@anchor{2e7}
-@section @code{Ada.Containers.Formal_Hashed_Sets} (@code{a-cfhase.ads})
-
-
-@geindex Ada.Containers.Formal_Hashed_Sets (a-cfhase.ads)
-
-@geindex Formal container for hashed sets
-
-This child of @code{Ada.Containers} defines a modified version of the
-Ada 2005 container for hashed sets, meant to facilitate formal
-verification of code using such containers. The specification of this
-unit is compatible with SPARK 2014.
-
-Note that although this container was designed with formal verification
-in mind, it may well be generally useful in that it is a simplified more
-efficient version than the one defined in the standard. In particular it
-does not have the complex overhead required to detect cursor tampering.
-
-@node Ada Containers Formal_Ordered_Maps a-cforma ads,Ada Containers Formal_Ordered_Sets a-cforse ads,Ada Containers Formal_Hashed_Sets a-cfhase ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library ada-containers-formal-ordered-maps-a-cforma-ads}@anchor{2e8}@anchor{gnat_rm/the_gnat_library id10}@anchor{2e9}
-@section @code{Ada.Containers.Formal_Ordered_Maps} (@code{a-cforma.ads})
-
-
-@geindex Ada.Containers.Formal_Ordered_Maps (a-cforma.ads)
-
-@geindex Formal container for ordered maps
-
-This child of @code{Ada.Containers} defines a modified version of the
-Ada 2005 container for ordered maps, meant to facilitate formal
-verification of code using such containers. The specification of this
-unit is compatible with SPARK 2014.
-
-Note that although this container was designed with formal verification
-in mind, it may well be generally useful in that it is a simplified more
-efficient version than the one defined in the standard. In particular it
-does not have the complex overhead required to detect cursor tampering.
-
-@node Ada Containers Formal_Ordered_Sets a-cforse ads,Ada Containers Formal_Vectors a-cofove ads,Ada Containers Formal_Ordered_Maps a-cforma ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library ada-containers-formal-ordered-sets-a-cforse-ads}@anchor{2ea}@anchor{gnat_rm/the_gnat_library id11}@anchor{2eb}
-@section @code{Ada.Containers.Formal_Ordered_Sets} (@code{a-cforse.ads})
-
-
-@geindex Ada.Containers.Formal_Ordered_Sets (a-cforse.ads)
-
-@geindex Formal container for ordered sets
-
-This child of @code{Ada.Containers} defines a modified version of the
-Ada 2005 container for ordered sets, meant to facilitate formal
-verification of code using such containers. The specification of this
-unit is compatible with SPARK 2014.
-
-Note that although this container was designed with formal verification
-in mind, it may well be generally useful in that it is a simplified more
-efficient version than the one defined in the standard. In particular it
-does not have the complex overhead required to detect cursor tampering.
-
-@node Ada Containers Formal_Vectors a-cofove ads,Ada Containers Formal_Indefinite_Vectors a-cfinve ads,Ada Containers Formal_Ordered_Sets a-cforse ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library ada-containers-formal-vectors-a-cofove-ads}@anchor{2ec}@anchor{gnat_rm/the_gnat_library id12}@anchor{2ed}
-@section @code{Ada.Containers.Formal_Vectors} (@code{a-cofove.ads})
-
-
-@geindex Ada.Containers.Formal_Vectors (a-cofove.ads)
-
-@geindex Formal container for vectors
-
-This child of @code{Ada.Containers} defines a modified version of the
-Ada 2005 container for vectors, meant to facilitate formal
-verification of code using such containers. The specification of this
-unit is compatible with SPARK 2014.
-
-Note that although this container was designed with formal verification
-in mind, it may well be generally useful in that it is a simplified more
-efficient version than the one defined in the standard. In particular it
-does not have the complex overhead required to detect cursor tampering.
-
-@node Ada Containers Formal_Indefinite_Vectors a-cfinve ads,Ada Containers Functional_Infinite_Sequences a-cfinse ads,Ada Containers Formal_Vectors a-cofove ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library ada-containers-formal-indefinite-vectors-a-cfinve-ads}@anchor{2ee}@anchor{gnat_rm/the_gnat_library id13}@anchor{2ef}
-@section @code{Ada.Containers.Formal_Indefinite_Vectors} (@code{a-cfinve.ads})
-
-
-@geindex Ada.Containers.Formal_Indefinite_Vectors (a-cfinve.ads)
-
-@geindex Formal container for vectors
-
-This child of @code{Ada.Containers} defines a modified version of the
-Ada 2005 container for vectors of indefinite elements, meant to
-facilitate formal verification of code using such containers. The
-specification of this unit is compatible with SPARK 2014.
-
-Note that although this container was designed with formal verification
-in mind, it may well be generally useful in that it is a simplified more
-efficient version than the one defined in the standard. In particular it
-does not have the complex overhead required to detect cursor tampering.
-
-@node Ada Containers Functional_Infinite_Sequences a-cfinse ads,Ada Containers Functional_Vectors a-cofuve ads,Ada Containers Formal_Indefinite_Vectors a-cfinve ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library ada-containers-functional-infinite-sequences-a-cfinse-ads}@anchor{2f0}@anchor{gnat_rm/the_gnat_library id14}@anchor{2f1}
-@section @code{Ada.Containers.Functional_Infinite_Sequences} (@code{a-cfinse.ads})
-
-
-@geindex Ada.Containers.Functional_Infinite_Sequences (a-cfinse.ads)
-
-@geindex Functional Infinite Sequences
-
-This child of @code{Ada.Containers} defines immutable sequences indexed by
-@code{Big_Integer}. These containers are unbounded and may contain indefinite
-elements. Their API features functions creating new containers from existing
-ones. To remain reasonably efficient, their implementation involves sharing
-between data-structures. As they are functional, that is, no primitives are
-provided which would allow modifying an existing container, these containers
-can still be used safely.
-
-These containers are controlled so that the allocated memory can be reclaimed
-when the container is no longer referenced. Thus, they cannot directly be used
-in contexts where controlled types are not supported.
-The specification of this unit is compatible with SPARK 2014.
-
-@node Ada Containers Functional_Vectors a-cofuve ads,Ada Containers Functional_Sets a-cofuse ads,Ada Containers Functional_Infinite_Sequences a-cfinse ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library ada-containers-functional-vectors-a-cofuve-ads}@anchor{2f2}@anchor{gnat_rm/the_gnat_library id15}@anchor{2f3}
-@section @code{Ada.Containers.Functional_Vectors} (@code{a-cofuve.ads})
-
-
-@geindex Ada.Containers.Functional_Vectors (a-cofuve.ads)
-
-@geindex Functional vectors
-
-This child of @code{Ada.Containers} defines immutable vectors. These
-containers are unbounded and may contain indefinite elements. Furthermore, to
-be usable in every context, they are neither controlled nor limited. As they
-are functional, that is, no primitives are provided which would allow modifying
-an existing container, these containers can still be used safely.
-
-Their API features functions creating new containers from existing ones.
-As a consequence, these containers are highly inefficient. They are also
-memory consuming, as the allocated memory is not reclaimed when the container
-is no longer referenced. Thus, they should in general be used in ghost code
-and annotations, so that they can be removed from the final executable. The
-specification of this unit is compatible with SPARK 2014.
-
-@node Ada Containers Functional_Sets a-cofuse ads,Ada Containers Functional_Maps a-cofuma ads,Ada Containers Functional_Vectors a-cofuve ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library ada-containers-functional-sets-a-cofuse-ads}@anchor{2f4}@anchor{gnat_rm/the_gnat_library id16}@anchor{2f5}
-@section @code{Ada.Containers.Functional_Sets} (@code{a-cofuse.ads})
-
-
-@geindex Ada.Containers.Functional_Sets (a-cofuse.ads)
-
-@geindex Functional sets
-
-This child of @code{Ada.Containers} defines immutable sets. These containers are
-unbounded and may contain indefinite elements. Their API features functions
-creating new containers from existing ones. To remain reasonably efficient,
-their implementation involves sharing between data-structures. As they are
-functional, that is, no primitives are provided which would allow modifying an
-existing container, these containers can still be used safely.
-
-These containers are controlled so that the allocated memory can be reclaimed
-when the container is no longer referenced. Thus, they cannot directly be used
-in contexts where controlled types are not supported.
-The specification of this unit is compatible with SPARK 2014.
-
-@node Ada Containers Functional_Maps a-cofuma ads,Ada Containers Bounded_Holders a-coboho ads,Ada Containers Functional_Sets a-cofuse ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library ada-containers-functional-maps-a-cofuma-ads}@anchor{2f6}@anchor{gnat_rm/the_gnat_library id17}@anchor{2f7}
-@section @code{Ada.Containers.Functional_Maps} (@code{a-cofuma.ads})
-
-
-@geindex Ada.Containers.Functional_Maps (a-cofuma.ads)
-
-@geindex Functional maps
-
-This child of @code{Ada.Containers} defines immutable maps. These containers are
-unbounded and may contain indefinite elements. Their API features functions
-creating new containers from existing ones. To remain reasonably efficient,
-their implementation involves sharing between data-structures. As they are
-functional, that is, no primitives are provided which would allow modifying an
-existing container, these containers can still be used safely.
-
-These containers are controlled so that the allocated memory can be reclaimed
-when the container is no longer referenced. Thus, they cannot directly be used
-in contexts where controlled types are not supported.
-The specification of this unit is compatible with SPARK 2014.
-
-@node Ada Containers Bounded_Holders a-coboho ads,Ada Command_Line Environment a-colien ads,Ada Containers Functional_Maps a-cofuma ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library ada-containers-bounded-holders-a-coboho-ads}@anchor{2f8}@anchor{gnat_rm/the_gnat_library id18}@anchor{2f9}
+@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{2e1}@anchor{gnat_rm/the_gnat_library id7}@anchor{2e2}
@section @code{Ada.Containers.Bounded_Holders} (@code{a-coboho.ads})
@@ -23589,7 +23347,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{2fa}@anchor{gnat_rm/the_gnat_library id19}@anchor{2fb}
+@anchor{gnat_rm/the_gnat_library ada-command-line-environment-a-colien-ads}@anchor{2e3}@anchor{gnat_rm/the_gnat_library id8}@anchor{2e4}
@section @code{Ada.Command_Line.Environment} (@code{a-colien.ads})
@@ -23602,7 +23360,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{2fc}@anchor{gnat_rm/the_gnat_library id20}@anchor{2fd}
+@anchor{gnat_rm/the_gnat_library ada-command-line-remove-a-colire-ads}@anchor{2e5}@anchor{gnat_rm/the_gnat_library id9}@anchor{2e6}
@section @code{Ada.Command_Line.Remove} (@code{a-colire.ads})
@@ -23620,7 +23378,7 @@ to further calls on the subprograms in @code{Ada.Command_Line} will not
see the removed argument.
@node Ada Command_Line Response_File a-clrefi ads,Ada Direct_IO C_Streams a-diocst ads,Ada Command_Line Remove a-colire ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library ada-command-line-response-file-a-clrefi-ads}@anchor{2fe}@anchor{gnat_rm/the_gnat_library id21}@anchor{2ff}
+@anchor{gnat_rm/the_gnat_library ada-command-line-response-file-a-clrefi-ads}@anchor{2e7}@anchor{gnat_rm/the_gnat_library id10}@anchor{2e8}
@section @code{Ada.Command_Line.Response_File} (@code{a-clrefi.ads})
@@ -23640,7 +23398,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{300}@anchor{gnat_rm/the_gnat_library id22}@anchor{301}
+@anchor{gnat_rm/the_gnat_library ada-direct-io-c-streams-a-diocst-ads}@anchor{2e9}@anchor{gnat_rm/the_gnat_library id11}@anchor{2ea}
@section @code{Ada.Direct_IO.C_Streams} (@code{a-diocst.ads})
@@ -23655,7 +23413,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{302}@anchor{gnat_rm/the_gnat_library id23}@anchor{303}
+@anchor{gnat_rm/the_gnat_library ada-exceptions-is-null-occurrence-a-einuoc-ads}@anchor{2eb}@anchor{gnat_rm/the_gnat_library id12}@anchor{2ec}
@section @code{Ada.Exceptions.Is_Null_Occurrence} (@code{a-einuoc.ads})
@@ -23669,7 +23427,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{304}@anchor{gnat_rm/the_gnat_library id24}@anchor{305}
+@anchor{gnat_rm/the_gnat_library ada-exceptions-last-chance-handler-a-elchha-ads}@anchor{2ed}@anchor{gnat_rm/the_gnat_library id13}@anchor{2ee}
@section @code{Ada.Exceptions.Last_Chance_Handler} (@code{a-elchha.ads})
@@ -23683,7 +23441,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{306}@anchor{gnat_rm/the_gnat_library id25}@anchor{307}
+@anchor{gnat_rm/the_gnat_library ada-exceptions-traceback-a-exctra-ads}@anchor{2ef}@anchor{gnat_rm/the_gnat_library id14}@anchor{2f0}
@section @code{Ada.Exceptions.Traceback} (@code{a-exctra.ads})
@@ -23696,7 +23454,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{308}@anchor{gnat_rm/the_gnat_library id26}@anchor{309}
+@anchor{gnat_rm/the_gnat_library ada-sequential-io-c-streams-a-siocst-ads}@anchor{2f1}@anchor{gnat_rm/the_gnat_library id15}@anchor{2f2}
@section @code{Ada.Sequential_IO.C_Streams} (@code{a-siocst.ads})
@@ -23711,7 +23469,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{30a}@anchor{gnat_rm/the_gnat_library id27}@anchor{30b}
+@anchor{gnat_rm/the_gnat_library ada-streams-stream-io-c-streams-a-ssicst-ads}@anchor{2f3}@anchor{gnat_rm/the_gnat_library id16}@anchor{2f4}
@section @code{Ada.Streams.Stream_IO.C_Streams} (@code{a-ssicst.ads})
@@ -23726,7 +23484,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{30c}@anchor{gnat_rm/the_gnat_library id28}@anchor{30d}
+@anchor{gnat_rm/the_gnat_library ada-strings-unbounded-text-io-a-suteio-ads}@anchor{2f5}@anchor{gnat_rm/the_gnat_library id17}@anchor{2f6}
@section @code{Ada.Strings.Unbounded.Text_IO} (@code{a-suteio.ads})
@@ -23743,7 +23501,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{30e}@anchor{gnat_rm/the_gnat_library id29}@anchor{30f}
+@anchor{gnat_rm/the_gnat_library ada-strings-wide-unbounded-wide-text-io-a-swuwti-ads}@anchor{2f7}@anchor{gnat_rm/the_gnat_library id18}@anchor{2f8}
@section @code{Ada.Strings.Wide_Unbounded.Wide_Text_IO} (@code{a-swuwti.ads})
@@ -23760,7 +23518,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{310}@anchor{gnat_rm/the_gnat_library id30}@anchor{311}
+@anchor{gnat_rm/the_gnat_library ada-strings-wide-wide-unbounded-wide-wide-text-io-a-szuzti-ads}@anchor{2f9}@anchor{gnat_rm/the_gnat_library id19}@anchor{2fa}
@section @code{Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO} (@code{a-szuzti.ads})
@@ -23777,7 +23535,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{312}@anchor{gnat_rm/the_gnat_library id31}@anchor{313}
+@anchor{gnat_rm/the_gnat_library ada-task-initialization-a-tasini-ads}@anchor{2fb}@anchor{gnat_rm/the_gnat_library id20}@anchor{2fc}
@section @code{Ada.Task_Initialization} (@code{a-tasini.ads})
@@ -23789,7 +23547,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{314}@anchor{gnat_rm/the_gnat_library id32}@anchor{315}
+@anchor{gnat_rm/the_gnat_library ada-text-io-c-streams-a-tiocst-ads}@anchor{2fd}@anchor{gnat_rm/the_gnat_library id21}@anchor{2fe}
@section @code{Ada.Text_IO.C_Streams} (@code{a-tiocst.ads})
@@ -23804,7 +23562,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{316}@anchor{gnat_rm/the_gnat_library id33}@anchor{317}
+@anchor{gnat_rm/the_gnat_library ada-text-io-reset-standard-files-a-tirsfi-ads}@anchor{2ff}@anchor{gnat_rm/the_gnat_library id22}@anchor{300}
@section @code{Ada.Text_IO.Reset_Standard_Files} (@code{a-tirsfi.ads})
@@ -23819,7 +23577,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{318}@anchor{gnat_rm/the_gnat_library id34}@anchor{319}
+@anchor{gnat_rm/the_gnat_library ada-wide-characters-unicode-a-wichun-ads}@anchor{301}@anchor{gnat_rm/the_gnat_library id23}@anchor{302}
@section @code{Ada.Wide_Characters.Unicode} (@code{a-wichun.ads})
@@ -23832,7 +23590,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{31a}@anchor{gnat_rm/the_gnat_library id35}@anchor{31b}
+@anchor{gnat_rm/the_gnat_library ada-wide-text-io-c-streams-a-wtcstr-ads}@anchor{303}@anchor{gnat_rm/the_gnat_library id24}@anchor{304}
@section @code{Ada.Wide_Text_IO.C_Streams} (@code{a-wtcstr.ads})
@@ -23847,7 +23605,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{31c}@anchor{gnat_rm/the_gnat_library id36}@anchor{31d}
+@anchor{gnat_rm/the_gnat_library ada-wide-text-io-reset-standard-files-a-wrstfi-ads}@anchor{305}@anchor{gnat_rm/the_gnat_library id25}@anchor{306}
@section @code{Ada.Wide_Text_IO.Reset_Standard_Files} (@code{a-wrstfi.ads})
@@ -23862,7 +23620,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{31e}@anchor{gnat_rm/the_gnat_library id37}@anchor{31f}
+@anchor{gnat_rm/the_gnat_library ada-wide-wide-characters-unicode-a-zchuni-ads}@anchor{307}@anchor{gnat_rm/the_gnat_library id26}@anchor{308}
@section @code{Ada.Wide_Wide_Characters.Unicode} (@code{a-zchuni.ads})
@@ -23875,7 +23633,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{320}@anchor{gnat_rm/the_gnat_library id38}@anchor{321}
+@anchor{gnat_rm/the_gnat_library ada-wide-wide-text-io-c-streams-a-ztcstr-ads}@anchor{309}@anchor{gnat_rm/the_gnat_library id27}@anchor{30a}
@section @code{Ada.Wide_Wide_Text_IO.C_Streams} (@code{a-ztcstr.ads})
@@ -23890,7 +23648,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{322}@anchor{gnat_rm/the_gnat_library id39}@anchor{323}
+@anchor{gnat_rm/the_gnat_library ada-wide-wide-text-io-reset-standard-files-a-zrstfi-ads}@anchor{30b}@anchor{gnat_rm/the_gnat_library id28}@anchor{30c}
@section @code{Ada.Wide_Wide_Text_IO.Reset_Standard_Files} (@code{a-zrstfi.ads})
@@ -23905,7 +23663,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{324}@anchor{gnat_rm/the_gnat_library id40}@anchor{325}
+@anchor{gnat_rm/the_gnat_library gnat-altivec-g-altive-ads}@anchor{30d}@anchor{gnat_rm/the_gnat_library id29}@anchor{30e}
@section @code{GNAT.Altivec} (@code{g-altive.ads})
@@ -23918,7 +23676,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{326}@anchor{gnat_rm/the_gnat_library id41}@anchor{327}
+@anchor{gnat_rm/the_gnat_library gnat-altivec-conversions-g-altcon-ads}@anchor{30f}@anchor{gnat_rm/the_gnat_library id30}@anchor{310}
@section @code{GNAT.Altivec.Conversions} (@code{g-altcon.ads})
@@ -23929,7 +23687,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{328}@anchor{gnat_rm/the_gnat_library id42}@anchor{329}
+@anchor{gnat_rm/the_gnat_library gnat-altivec-vector-operations-g-alveop-ads}@anchor{311}@anchor{gnat_rm/the_gnat_library id31}@anchor{312}
@section @code{GNAT.Altivec.Vector_Operations} (@code{g-alveop.ads})
@@ -23943,7 +23701,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{32a}@anchor{gnat_rm/the_gnat_library id43}@anchor{32b}
+@anchor{gnat_rm/the_gnat_library gnat-altivec-vector-types-g-alvety-ads}@anchor{313}@anchor{gnat_rm/the_gnat_library id32}@anchor{314}
@section @code{GNAT.Altivec.Vector_Types} (@code{g-alvety.ads})
@@ -23955,7 +23713,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{32c}@anchor{gnat_rm/the_gnat_library id44}@anchor{32d}
+@anchor{gnat_rm/the_gnat_library gnat-altivec-vector-views-g-alvevi-ads}@anchor{315}@anchor{gnat_rm/the_gnat_library id33}@anchor{316}
@section @code{GNAT.Altivec.Vector_Views} (@code{g-alvevi.ads})
@@ -23970,7 +23728,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{32e}@anchor{gnat_rm/the_gnat_library id45}@anchor{32f}
+@anchor{gnat_rm/the_gnat_library gnat-array-split-g-arrspl-ads}@anchor{317}@anchor{gnat_rm/the_gnat_library id34}@anchor{318}
@section @code{GNAT.Array_Split} (@code{g-arrspl.ads})
@@ -23983,7 +23741,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{330}@anchor{gnat_rm/the_gnat_library id46}@anchor{331}
+@anchor{gnat_rm/the_gnat_library gnat-awk-g-awk-ads}@anchor{319}@anchor{gnat_rm/the_gnat_library id35}@anchor{31a}
@section @code{GNAT.AWK} (@code{g-awk.ads})
@@ -23998,7 +23756,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{332}@anchor{gnat_rm/the_gnat_library id47}@anchor{333}
+@anchor{gnat_rm/the_gnat_library gnat-binary-search-g-binsea-ads}@anchor{31b}@anchor{gnat_rm/the_gnat_library id36}@anchor{31c}
@section @code{GNAT.Binary_Search} (@code{g-binsea.ads})
@@ -24010,7 +23768,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{334}@anchor{gnat_rm/the_gnat_library id48}@anchor{335}
+@anchor{gnat_rm/the_gnat_library gnat-bind-environment-g-binenv-ads}@anchor{31d}@anchor{gnat_rm/the_gnat_library id37}@anchor{31e}
@section @code{GNAT.Bind_Environment} (@code{g-binenv.ads})
@@ -24023,7 +23781,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{336}@anchor{gnat_rm/the_gnat_library id49}@anchor{337}
+@anchor{gnat_rm/the_gnat_library gnat-branch-prediction-g-brapre-ads}@anchor{31f}@anchor{gnat_rm/the_gnat_library id38}@anchor{320}
@section @code{GNAT.Branch_Prediction} (@code{g-brapre.ads})
@@ -24034,7 +23792,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{338}@anchor{gnat_rm/the_gnat_library id50}@anchor{339}
+@anchor{gnat_rm/the_gnat_library gnat-bounded-buffers-g-boubuf-ads}@anchor{321}@anchor{gnat_rm/the_gnat_library id39}@anchor{322}
@section @code{GNAT.Bounded_Buffers} (@code{g-boubuf.ads})
@@ -24049,7 +23807,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{33a}@anchor{gnat_rm/the_gnat_library id51}@anchor{33b}
+@anchor{gnat_rm/the_gnat_library gnat-bounded-mailboxes-g-boumai-ads}@anchor{323}@anchor{gnat_rm/the_gnat_library id40}@anchor{324}
@section @code{GNAT.Bounded_Mailboxes} (@code{g-boumai.ads})
@@ -24062,7 +23820,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{33c}@anchor{gnat_rm/the_gnat_library id52}@anchor{33d}
+@anchor{gnat_rm/the_gnat_library gnat-bubble-sort-g-bubsor-ads}@anchor{325}@anchor{gnat_rm/the_gnat_library id41}@anchor{326}
@section @code{GNAT.Bubble_Sort} (@code{g-bubsor.ads})
@@ -24077,7 +23835,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{33e}@anchor{gnat_rm/the_gnat_library id53}@anchor{33f}
+@anchor{gnat_rm/the_gnat_library gnat-bubble-sort-a-g-busora-ads}@anchor{327}@anchor{gnat_rm/the_gnat_library id42}@anchor{328}
@section @code{GNAT.Bubble_Sort_A} (@code{g-busora.ads})
@@ -24093,7 +23851,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{340}@anchor{gnat_rm/the_gnat_library id54}@anchor{341}
+@anchor{gnat_rm/the_gnat_library gnat-bubble-sort-g-g-busorg-ads}@anchor{329}@anchor{gnat_rm/the_gnat_library id43}@anchor{32a}
@section @code{GNAT.Bubble_Sort_G} (@code{g-busorg.ads})
@@ -24109,7 +23867,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{342}@anchor{gnat_rm/the_gnat_library id55}@anchor{343}
+@anchor{gnat_rm/the_gnat_library gnat-byte-order-mark-g-byorma-ads}@anchor{32b}@anchor{gnat_rm/the_gnat_library id44}@anchor{32c}
@section @code{GNAT.Byte_Order_Mark} (@code{g-byorma.ads})
@@ -24125,7 +23883,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{344}@anchor{gnat_rm/the_gnat_library id56}@anchor{345}
+@anchor{gnat_rm/the_gnat_library gnat-byte-swapping-g-bytswa-ads}@anchor{32d}@anchor{gnat_rm/the_gnat_library id45}@anchor{32e}
@section @code{GNAT.Byte_Swapping} (@code{g-bytswa.ads})
@@ -24139,7 +23897,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{346}@anchor{gnat_rm/the_gnat_library id57}@anchor{347}
+@anchor{gnat_rm/the_gnat_library gnat-calendar-g-calend-ads}@anchor{32f}@anchor{gnat_rm/the_gnat_library id46}@anchor{330}
@section @code{GNAT.Calendar} (@code{g-calend.ads})
@@ -24153,7 +23911,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{348}@anchor{gnat_rm/the_gnat_library id58}@anchor{349}
+@anchor{gnat_rm/the_gnat_library gnat-calendar-time-io-g-catiio-ads}@anchor{331}@anchor{gnat_rm/the_gnat_library id47}@anchor{332}
@section @code{GNAT.Calendar.Time_IO} (@code{g-catiio.ads})
@@ -24164,7 +23922,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{34a}@anchor{gnat_rm/the_gnat_library id59}@anchor{34b}
+@anchor{gnat_rm/the_gnat_library gnat-crc32-g-crc32-ads}@anchor{333}@anchor{gnat_rm/the_gnat_library id48}@anchor{334}
@section @code{GNAT.CRC32} (@code{g-crc32.ads})
@@ -24181,7 +23939,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{34c}@anchor{gnat_rm/the_gnat_library id60}@anchor{34d}
+@anchor{gnat_rm/the_gnat_library gnat-case-util-g-casuti-ads}@anchor{335}@anchor{gnat_rm/the_gnat_library id49}@anchor{336}
@section @code{GNAT.Case_Util} (@code{g-casuti.ads})
@@ -24196,7 +23954,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{34e}@anchor{gnat_rm/the_gnat_library id61}@anchor{34f}
+@anchor{gnat_rm/the_gnat_library gnat-cgi-g-cgi-ads}@anchor{337}@anchor{gnat_rm/the_gnat_library id50}@anchor{338}
@section @code{GNAT.CGI} (@code{g-cgi.ads})
@@ -24211,7 +23969,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{350}@anchor{gnat_rm/the_gnat_library id62}@anchor{351}
+@anchor{gnat_rm/the_gnat_library gnat-cgi-cookie-g-cgicoo-ads}@anchor{339}@anchor{gnat_rm/the_gnat_library id51}@anchor{33a}
@section @code{GNAT.CGI.Cookie} (@code{g-cgicoo.ads})
@@ -24226,7 +23984,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{352}@anchor{gnat_rm/the_gnat_library id63}@anchor{353}
+@anchor{gnat_rm/the_gnat_library gnat-cgi-debug-g-cgideb-ads}@anchor{33b}@anchor{gnat_rm/the_gnat_library id52}@anchor{33c}
@section @code{GNAT.CGI.Debug} (@code{g-cgideb.ads})
@@ -24238,7 +23996,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{354}@anchor{gnat_rm/the_gnat_library id64}@anchor{355}
+@anchor{gnat_rm/the_gnat_library gnat-command-line-g-comlin-ads}@anchor{33d}@anchor{gnat_rm/the_gnat_library id53}@anchor{33e}
@section @code{GNAT.Command_Line} (@code{g-comlin.ads})
@@ -24251,7 +24009,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{356}@anchor{gnat_rm/the_gnat_library id65}@anchor{357}
+@anchor{gnat_rm/the_gnat_library gnat-compiler-version-g-comver-ads}@anchor{33f}@anchor{gnat_rm/the_gnat_library id54}@anchor{340}
@section @code{GNAT.Compiler_Version} (@code{g-comver.ads})
@@ -24269,7 +24027,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{358}@anchor{gnat_rm/the_gnat_library id66}@anchor{359}
+@anchor{gnat_rm/the_gnat_library gnat-ctrl-c-g-ctrl-c-ads}@anchor{341}@anchor{gnat_rm/the_gnat_library id55}@anchor{342}
@section @code{GNAT.Ctrl_C} (@code{g-ctrl_c.ads})
@@ -24280,7 +24038,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{35a}@anchor{gnat_rm/the_gnat_library id67}@anchor{35b}
+@anchor{gnat_rm/the_gnat_library gnat-current-exception-g-curexc-ads}@anchor{343}@anchor{gnat_rm/the_gnat_library id56}@anchor{344}
@section @code{GNAT.Current_Exception} (@code{g-curexc.ads})
@@ -24297,7 +24055,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{35c}@anchor{gnat_rm/the_gnat_library id68}@anchor{35d}
+@anchor{gnat_rm/the_gnat_library gnat-debug-pools-g-debpoo-ads}@anchor{345}@anchor{gnat_rm/the_gnat_library id57}@anchor{346}
@section @code{GNAT.Debug_Pools} (@code{g-debpoo.ads})
@@ -24314,7 +24072,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{35e}@anchor{gnat_rm/the_gnat_library id69}@anchor{35f}
+@anchor{gnat_rm/the_gnat_library gnat-debug-utilities-g-debuti-ads}@anchor{347}@anchor{gnat_rm/the_gnat_library id58}@anchor{348}
@section @code{GNAT.Debug_Utilities} (@code{g-debuti.ads})
@@ -24327,7 +24085,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{360}@anchor{gnat_rm/the_gnat_library id70}@anchor{361}
+@anchor{gnat_rm/the_gnat_library gnat-decode-string-g-decstr-ads}@anchor{349}@anchor{gnat_rm/the_gnat_library id59}@anchor{34a}
@section @code{GNAT.Decode_String} (@code{g-decstr.ads})
@@ -24351,7 +24109,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{362}@anchor{gnat_rm/the_gnat_library id71}@anchor{363}
+@anchor{gnat_rm/the_gnat_library gnat-decode-utf8-string-g-deutst-ads}@anchor{34b}@anchor{gnat_rm/the_gnat_library id60}@anchor{34c}
@section @code{GNAT.Decode_UTF8_String} (@code{g-deutst.ads})
@@ -24372,7 +24130,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{364}@anchor{gnat_rm/the_gnat_library id72}@anchor{365}
+@anchor{gnat_rm/the_gnat_library gnat-directory-operations-g-dirope-ads}@anchor{34d}@anchor{gnat_rm/the_gnat_library id61}@anchor{34e}
@section @code{GNAT.Directory_Operations} (@code{g-dirope.ads})
@@ -24385,7 +24143,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{366}@anchor{gnat_rm/the_gnat_library id73}@anchor{367}
+@anchor{gnat_rm/the_gnat_library gnat-directory-operations-iteration-g-diopit-ads}@anchor{34f}@anchor{gnat_rm/the_gnat_library id62}@anchor{350}
@section @code{GNAT.Directory_Operations.Iteration} (@code{g-diopit.ads})
@@ -24397,7 +24155,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{368}@anchor{gnat_rm/the_gnat_library id74}@anchor{369}
+@anchor{gnat_rm/the_gnat_library gnat-dynamic-htables-g-dynhta-ads}@anchor{351}@anchor{gnat_rm/the_gnat_library id63}@anchor{352}
@section @code{GNAT.Dynamic_HTables} (@code{g-dynhta.ads})
@@ -24415,7 +24173,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{36a}@anchor{gnat_rm/the_gnat_library id75}@anchor{36b}
+@anchor{gnat_rm/the_gnat_library gnat-dynamic-tables-g-dyntab-ads}@anchor{353}@anchor{gnat_rm/the_gnat_library id64}@anchor{354}
@section @code{GNAT.Dynamic_Tables} (@code{g-dyntab.ads})
@@ -24435,7 +24193,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{36c}@anchor{gnat_rm/the_gnat_library id76}@anchor{36d}
+@anchor{gnat_rm/the_gnat_library gnat-encode-string-g-encstr-ads}@anchor{355}@anchor{gnat_rm/the_gnat_library id65}@anchor{356}
@section @code{GNAT.Encode_String} (@code{g-encstr.ads})
@@ -24457,7 +24215,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{36e}@anchor{gnat_rm/the_gnat_library id77}@anchor{36f}
+@anchor{gnat_rm/the_gnat_library gnat-encode-utf8-string-g-enutst-ads}@anchor{357}@anchor{gnat_rm/the_gnat_library id66}@anchor{358}
@section @code{GNAT.Encode_UTF8_String} (@code{g-enutst.ads})
@@ -24478,7 +24236,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{370}@anchor{gnat_rm/the_gnat_library id78}@anchor{371}
+@anchor{gnat_rm/the_gnat_library gnat-exception-actions-g-excact-ads}@anchor{359}@anchor{gnat_rm/the_gnat_library id67}@anchor{35a}
@section @code{GNAT.Exception_Actions} (@code{g-excact.ads})
@@ -24491,7 +24249,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{372}@anchor{gnat_rm/the_gnat_library id79}@anchor{373}
+@anchor{gnat_rm/the_gnat_library gnat-exception-traces-g-exctra-ads}@anchor{35b}@anchor{gnat_rm/the_gnat_library id68}@anchor{35c}
@section @code{GNAT.Exception_Traces} (@code{g-exctra.ads})
@@ -24505,7 +24263,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{374}@anchor{gnat_rm/the_gnat_library id80}@anchor{375}
+@anchor{gnat_rm/the_gnat_library gnat-exceptions-g-except-ads}@anchor{35d}@anchor{gnat_rm/the_gnat_library id69}@anchor{35e}
@section @code{GNAT.Exceptions} (@code{g-except.ads})
@@ -24526,7 +24284,7 @@ predefined exceptions, and for example allow raising
@code{Constraint_Error} with a message from a pure subprogram.
@node GNAT Expect g-expect ads,GNAT Expect TTY g-exptty ads,GNAT Exceptions g-except ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-expect-g-expect-ads}@anchor{376}@anchor{gnat_rm/the_gnat_library id81}@anchor{377}
+@anchor{gnat_rm/the_gnat_library gnat-expect-g-expect-ads}@anchor{35f}@anchor{gnat_rm/the_gnat_library id70}@anchor{360}
@section @code{GNAT.Expect} (@code{g-expect.ads})
@@ -24542,7 +24300,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{378}@anchor{gnat_rm/the_gnat_library id82}@anchor{379}
+@anchor{gnat_rm/the_gnat_library gnat-expect-tty-g-exptty-ads}@anchor{361}@anchor{gnat_rm/the_gnat_library id71}@anchor{362}
@section @code{GNAT.Expect.TTY} (@code{g-exptty.ads})
@@ -24554,7 +24312,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{37a}@anchor{gnat_rm/the_gnat_library id83}@anchor{37b}
+@anchor{gnat_rm/the_gnat_library gnat-float-control-g-flocon-ads}@anchor{363}@anchor{gnat_rm/the_gnat_library id72}@anchor{364}
@section @code{GNAT.Float_Control} (@code{g-flocon.ads})
@@ -24568,7 +24326,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{37c}@anchor{gnat_rm/the_gnat_library id84}@anchor{37d}
+@anchor{gnat_rm/the_gnat_library gnat-formatted-string-g-forstr-ads}@anchor{365}@anchor{gnat_rm/the_gnat_library id73}@anchor{366}
@section @code{GNAT.Formatted_String} (@code{g-forstr.ads})
@@ -24583,7 +24341,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{37e}@anchor{gnat_rm/the_gnat_library id85}@anchor{37f}
+@anchor{gnat_rm/the_gnat_library gnat-generic-fast-math-functions-g-gfmafu-ads}@anchor{367}@anchor{gnat_rm/the_gnat_library id74}@anchor{368}
@section @code{GNAT.Generic_Fast_Math_Functions} (@code{g-gfmafu.ads})
@@ -24601,7 +24359,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{380}@anchor{gnat_rm/the_gnat_library id86}@anchor{381}
+@anchor{gnat_rm/the_gnat_library gnat-heap-sort-g-heasor-ads}@anchor{369}@anchor{gnat_rm/the_gnat_library id75}@anchor{36a}
@section @code{GNAT.Heap_Sort} (@code{g-heasor.ads})
@@ -24615,7 +24373,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{382}@anchor{gnat_rm/the_gnat_library id87}@anchor{383}
+@anchor{gnat_rm/the_gnat_library gnat-heap-sort-a-g-hesora-ads}@anchor{36b}@anchor{gnat_rm/the_gnat_library id76}@anchor{36c}
@section @code{GNAT.Heap_Sort_A} (@code{g-hesora.ads})
@@ -24631,7 +24389,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{384}@anchor{gnat_rm/the_gnat_library id88}@anchor{385}
+@anchor{gnat_rm/the_gnat_library gnat-heap-sort-g-g-hesorg-ads}@anchor{36d}@anchor{gnat_rm/the_gnat_library id77}@anchor{36e}
@section @code{GNAT.Heap_Sort_G} (@code{g-hesorg.ads})
@@ -24645,7 +24403,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{386}@anchor{gnat_rm/the_gnat_library id89}@anchor{387}
+@anchor{gnat_rm/the_gnat_library gnat-htable-g-htable-ads}@anchor{36f}@anchor{gnat_rm/the_gnat_library id78}@anchor{370}
@section @code{GNAT.HTable} (@code{g-htable.ads})
@@ -24658,7 +24416,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{388}@anchor{gnat_rm/the_gnat_library id90}@anchor{389}
+@anchor{gnat_rm/the_gnat_library gnat-io-g-io-ads}@anchor{371}@anchor{gnat_rm/the_gnat_library id79}@anchor{372}
@section @code{GNAT.IO} (@code{g-io.ads})
@@ -24674,7 +24432,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{38a}@anchor{gnat_rm/the_gnat_library id91}@anchor{38b}
+@anchor{gnat_rm/the_gnat_library gnat-io-aux-g-io-aux-ads}@anchor{373}@anchor{gnat_rm/the_gnat_library id80}@anchor{374}
@section @code{GNAT.IO_Aux} (@code{g-io_aux.ads})
@@ -24688,7 +24446,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{38c}@anchor{gnat_rm/the_gnat_library id92}@anchor{38d}
+@anchor{gnat_rm/the_gnat_library gnat-lock-files-g-locfil-ads}@anchor{375}@anchor{gnat_rm/the_gnat_library id81}@anchor{376}
@section @code{GNAT.Lock_Files} (@code{g-locfil.ads})
@@ -24702,7 +24460,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{38e}@anchor{gnat_rm/the_gnat_library id93}@anchor{38f}
+@anchor{gnat_rm/the_gnat_library gnat-mbbs-discrete-random-g-mbdira-ads}@anchor{377}@anchor{gnat_rm/the_gnat_library id82}@anchor{378}
@section @code{GNAT.MBBS_Discrete_Random} (@code{g-mbdira.ads})
@@ -24714,7 +24472,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{390}@anchor{gnat_rm/the_gnat_library id94}@anchor{391}
+@anchor{gnat_rm/the_gnat_library gnat-mbbs-float-random-g-mbflra-ads}@anchor{379}@anchor{gnat_rm/the_gnat_library id83}@anchor{37a}
@section @code{GNAT.MBBS_Float_Random} (@code{g-mbflra.ads})
@@ -24726,7 +24484,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{392}@anchor{gnat_rm/the_gnat_library id95}@anchor{393}
+@anchor{gnat_rm/the_gnat_library gnat-md5-g-md5-ads}@anchor{37b}@anchor{gnat_rm/the_gnat_library id84}@anchor{37c}
@section @code{GNAT.MD5} (@code{g-md5.ads})
@@ -24739,7 +24497,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{394}@anchor{gnat_rm/the_gnat_library id96}@anchor{395}
+@anchor{gnat_rm/the_gnat_library gnat-memory-dump-g-memdum-ads}@anchor{37d}@anchor{gnat_rm/the_gnat_library id85}@anchor{37e}
@section @code{GNAT.Memory_Dump} (@code{g-memdum.ads})
@@ -24752,7 +24510,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{396}@anchor{gnat_rm/the_gnat_library id97}@anchor{397}
+@anchor{gnat_rm/the_gnat_library gnat-most-recent-exception-g-moreex-ads}@anchor{37f}@anchor{gnat_rm/the_gnat_library id86}@anchor{380}
@section @code{GNAT.Most_Recent_Exception} (@code{g-moreex.ads})
@@ -24766,7 +24524,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{398}@anchor{gnat_rm/the_gnat_library id98}@anchor{399}
+@anchor{gnat_rm/the_gnat_library gnat-os-lib-g-os-lib-ads}@anchor{381}@anchor{gnat_rm/the_gnat_library id87}@anchor{382}
@section @code{GNAT.OS_Lib} (@code{g-os_lib.ads})
@@ -24782,7 +24540,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{39a}@anchor{gnat_rm/the_gnat_library id99}@anchor{39b}
+@anchor{gnat_rm/the_gnat_library gnat-perfect-hash-generators-g-pehage-ads}@anchor{383}@anchor{gnat_rm/the_gnat_library id88}@anchor{384}
@section @code{GNAT.Perfect_Hash_Generators} (@code{g-pehage.ads})
@@ -24800,7 +24558,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{39c}@anchor{gnat_rm/the_gnat_library id100}@anchor{39d}
+@anchor{gnat_rm/the_gnat_library gnat-random-numbers-g-rannum-ads}@anchor{385}@anchor{gnat_rm/the_gnat_library id89}@anchor{386}
@section @code{GNAT.Random_Numbers} (@code{g-rannum.ads})
@@ -24812,7 +24570,7 @@ Provides random number capabilities which extend those available in the
standard Ada library and are more convenient to use.
@node GNAT Regexp g-regexp ads,GNAT Registry g-regist ads,GNAT Random_Numbers g-rannum ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-regexp-g-regexp-ads}@anchor{25d}@anchor{gnat_rm/the_gnat_library id101}@anchor{39e}
+@anchor{gnat_rm/the_gnat_library gnat-regexp-g-regexp-ads}@anchor{25c}@anchor{gnat_rm/the_gnat_library id90}@anchor{387}
@section @code{GNAT.Regexp} (@code{g-regexp.ads})
@@ -24828,7 +24586,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{39f}@anchor{gnat_rm/the_gnat_library id102}@anchor{3a0}
+@anchor{gnat_rm/the_gnat_library gnat-registry-g-regist-ads}@anchor{388}@anchor{gnat_rm/the_gnat_library id91}@anchor{389}
@section @code{GNAT.Registry} (@code{g-regist.ads})
@@ -24842,7 +24600,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{3a1}@anchor{gnat_rm/the_gnat_library id103}@anchor{3a2}
+@anchor{gnat_rm/the_gnat_library gnat-regpat-g-regpat-ads}@anchor{38a}@anchor{gnat_rm/the_gnat_library id92}@anchor{38b}
@section @code{GNAT.Regpat} (@code{g-regpat.ads})
@@ -24857,7 +24615,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{3a3}@anchor{gnat_rm/the_gnat_library id104}@anchor{3a4}
+@anchor{gnat_rm/the_gnat_library gnat-rewrite-data-g-rewdat-ads}@anchor{38c}@anchor{gnat_rm/the_gnat_library id93}@anchor{38d}
@section @code{GNAT.Rewrite_Data} (@code{g-rewdat.ads})
@@ -24871,7 +24629,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{3a5}@anchor{gnat_rm/the_gnat_library id105}@anchor{3a6}
+@anchor{gnat_rm/the_gnat_library gnat-secondary-stack-info-g-sestin-ads}@anchor{38e}@anchor{gnat_rm/the_gnat_library id94}@anchor{38f}
@section @code{GNAT.Secondary_Stack_Info} (@code{g-sestin.ads})
@@ -24883,7 +24641,7 @@ Provide the capability to query the high water mark of the current task’s
secondary stack.
@node GNAT Semaphores g-semaph ads,GNAT Serial_Communications g-sercom ads,GNAT Secondary_Stack_Info g-sestin ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-semaphores-g-semaph-ads}@anchor{3a7}@anchor{gnat_rm/the_gnat_library id106}@anchor{3a8}
+@anchor{gnat_rm/the_gnat_library gnat-semaphores-g-semaph-ads}@anchor{390}@anchor{gnat_rm/the_gnat_library id95}@anchor{391}
@section @code{GNAT.Semaphores} (@code{g-semaph.ads})
@@ -24894,7 +24652,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{3a9}@anchor{gnat_rm/the_gnat_library id107}@anchor{3aa}
+@anchor{gnat_rm/the_gnat_library gnat-serial-communications-g-sercom-ads}@anchor{392}@anchor{gnat_rm/the_gnat_library id96}@anchor{393}
@section @code{GNAT.Serial_Communications} (@code{g-sercom.ads})
@@ -24906,7 +24664,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{3ab}@anchor{gnat_rm/the_gnat_library id108}@anchor{3ac}
+@anchor{gnat_rm/the_gnat_library gnat-sha1-g-sha1-ads}@anchor{394}@anchor{gnat_rm/the_gnat_library id97}@anchor{395}
@section @code{GNAT.SHA1} (@code{g-sha1.ads})
@@ -24919,7 +24677,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{3ad}@anchor{gnat_rm/the_gnat_library id109}@anchor{3ae}
+@anchor{gnat_rm/the_gnat_library gnat-sha224-g-sha224-ads}@anchor{396}@anchor{gnat_rm/the_gnat_library id98}@anchor{397}
@section @code{GNAT.SHA224} (@code{g-sha224.ads})
@@ -24932,7 +24690,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{3af}@anchor{gnat_rm/the_gnat_library id110}@anchor{3b0}
+@anchor{gnat_rm/the_gnat_library gnat-sha256-g-sha256-ads}@anchor{398}@anchor{gnat_rm/the_gnat_library id99}@anchor{399}
@section @code{GNAT.SHA256} (@code{g-sha256.ads})
@@ -24945,7 +24703,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{3b1}@anchor{gnat_rm/the_gnat_library id111}@anchor{3b2}
+@anchor{gnat_rm/the_gnat_library gnat-sha384-g-sha384-ads}@anchor{39a}@anchor{gnat_rm/the_gnat_library id100}@anchor{39b}
@section @code{GNAT.SHA384} (@code{g-sha384.ads})
@@ -24958,7 +24716,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{3b3}@anchor{gnat_rm/the_gnat_library id112}@anchor{3b4}
+@anchor{gnat_rm/the_gnat_library gnat-sha512-g-sha512-ads}@anchor{39c}@anchor{gnat_rm/the_gnat_library id101}@anchor{39d}
@section @code{GNAT.SHA512} (@code{g-sha512.ads})
@@ -24971,7 +24729,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{3b5}@anchor{gnat_rm/the_gnat_library id113}@anchor{3b6}
+@anchor{gnat_rm/the_gnat_library gnat-signals-g-signal-ads}@anchor{39e}@anchor{gnat_rm/the_gnat_library id102}@anchor{39f}
@section @code{GNAT.Signals} (@code{g-signal.ads})
@@ -24983,7 +24741,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{3b7}@anchor{gnat_rm/the_gnat_library id114}@anchor{3b8}
+@anchor{gnat_rm/the_gnat_library gnat-sockets-g-socket-ads}@anchor{3a0}@anchor{gnat_rm/the_gnat_library id103}@anchor{3a1}
@section @code{GNAT.Sockets} (@code{g-socket.ads})
@@ -24998,7 +24756,7 @@ on all native GNAT ports and on VxWorks cross prots. It is not implemented for
the LynxOS cross port.
@node GNAT Source_Info g-souinf ads,GNAT Spelling_Checker g-speche ads,GNAT Sockets g-socket ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-source-info-g-souinf-ads}@anchor{3b9}@anchor{gnat_rm/the_gnat_library id115}@anchor{3ba}
+@anchor{gnat_rm/the_gnat_library gnat-source-info-g-souinf-ads}@anchor{3a2}@anchor{gnat_rm/the_gnat_library id104}@anchor{3a3}
@section @code{GNAT.Source_Info} (@code{g-souinf.ads})
@@ -25012,7 +24770,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{3bb}@anchor{gnat_rm/the_gnat_library id116}@anchor{3bc}
+@anchor{gnat_rm/the_gnat_library gnat-spelling-checker-g-speche-ads}@anchor{3a4}@anchor{gnat_rm/the_gnat_library id105}@anchor{3a5}
@section @code{GNAT.Spelling_Checker} (@code{g-speche.ads})
@@ -25024,7 +24782,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{3bd}@anchor{gnat_rm/the_gnat_library id117}@anchor{3be}
+@anchor{gnat_rm/the_gnat_library gnat-spelling-checker-generic-g-spchge-ads}@anchor{3a6}@anchor{gnat_rm/the_gnat_library id106}@anchor{3a7}
@section @code{GNAT.Spelling_Checker_Generic} (@code{g-spchge.ads})
@@ -25037,7 +24795,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{3bf}@anchor{gnat_rm/the_gnat_library id118}@anchor{3c0}
+@anchor{gnat_rm/the_gnat_library gnat-spitbol-patterns-g-spipat-ads}@anchor{3a8}@anchor{gnat_rm/the_gnat_library id107}@anchor{3a9}
@section @code{GNAT.Spitbol.Patterns} (@code{g-spipat.ads})
@@ -25053,7 +24811,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{3c1}@anchor{gnat_rm/the_gnat_library id119}@anchor{3c2}
+@anchor{gnat_rm/the_gnat_library gnat-spitbol-g-spitbo-ads}@anchor{3aa}@anchor{gnat_rm/the_gnat_library id108}@anchor{3ab}
@section @code{GNAT.Spitbol} (@code{g-spitbo.ads})
@@ -25068,7 +24826,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{3c3}@anchor{gnat_rm/the_gnat_library id120}@anchor{3c4}
+@anchor{gnat_rm/the_gnat_library gnat-spitbol-table-boolean-g-sptabo-ads}@anchor{3ac}@anchor{gnat_rm/the_gnat_library id109}@anchor{3ad}
@section @code{GNAT.Spitbol.Table_Boolean} (@code{g-sptabo.ads})
@@ -25083,7 +24841,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{3c5}@anchor{gnat_rm/the_gnat_library id121}@anchor{3c6}
+@anchor{gnat_rm/the_gnat_library gnat-spitbol-table-integer-g-sptain-ads}@anchor{3ae}@anchor{gnat_rm/the_gnat_library id110}@anchor{3af}
@section @code{GNAT.Spitbol.Table_Integer} (@code{g-sptain.ads})
@@ -25100,7 +24858,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{3c7}@anchor{gnat_rm/the_gnat_library id122}@anchor{3c8}
+@anchor{gnat_rm/the_gnat_library gnat-spitbol-table-vstring-g-sptavs-ads}@anchor{3b0}@anchor{gnat_rm/the_gnat_library id111}@anchor{3b1}
@section @code{GNAT.Spitbol.Table_VString} (@code{g-sptavs.ads})
@@ -25117,7 +24875,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{3c9}@anchor{gnat_rm/the_gnat_library id123}@anchor{3ca}
+@anchor{gnat_rm/the_gnat_library gnat-sse-g-sse-ads}@anchor{3b2}@anchor{gnat_rm/the_gnat_library id112}@anchor{3b3}
@section @code{GNAT.SSE} (@code{g-sse.ads})
@@ -25129,7 +24887,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{3cb}@anchor{gnat_rm/the_gnat_library id124}@anchor{3cc}
+@anchor{gnat_rm/the_gnat_library gnat-sse-vector-types-g-ssvety-ads}@anchor{3b4}@anchor{gnat_rm/the_gnat_library id113}@anchor{3b5}
@section @code{GNAT.SSE.Vector_Types} (@code{g-ssvety.ads})
@@ -25138,7 +24896,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{3cd}@anchor{gnat_rm/the_gnat_library id125}@anchor{3ce}
+@anchor{gnat_rm/the_gnat_library gnat-string-hash-g-strhas-ads}@anchor{3b6}@anchor{gnat_rm/the_gnat_library id114}@anchor{3b7}
@section @code{GNAT.String_Hash} (@code{g-strhas.ads})
@@ -25150,7 +24908,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{3cf}@anchor{gnat_rm/the_gnat_library id126}@anchor{3d0}
+@anchor{gnat_rm/the_gnat_library gnat-strings-g-string-ads}@anchor{3b8}@anchor{gnat_rm/the_gnat_library id115}@anchor{3b9}
@section @code{GNAT.Strings} (@code{g-string.ads})
@@ -25160,7 +24918,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{3d1}@anchor{gnat_rm/the_gnat_library id127}@anchor{3d2}
+@anchor{gnat_rm/the_gnat_library gnat-string-split-g-strspl-ads}@anchor{3ba}@anchor{gnat_rm/the_gnat_library id116}@anchor{3bb}
@section @code{GNAT.String_Split} (@code{g-strspl.ads})
@@ -25174,7 +24932,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{3d3}@anchor{gnat_rm/the_gnat_library id128}@anchor{3d4}
+@anchor{gnat_rm/the_gnat_library gnat-table-g-table-ads}@anchor{3bc}@anchor{gnat_rm/the_gnat_library id117}@anchor{3bd}
@section @code{GNAT.Table} (@code{g-table.ads})
@@ -25194,7 +24952,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{3d5}@anchor{gnat_rm/the_gnat_library id129}@anchor{3d6}
+@anchor{gnat_rm/the_gnat_library gnat-task-lock-g-tasloc-ads}@anchor{3be}@anchor{gnat_rm/the_gnat_library id118}@anchor{3bf}
@section @code{GNAT.Task_Lock} (@code{g-tasloc.ads})
@@ -25211,7 +24969,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{3d7}@anchor{gnat_rm/the_gnat_library id130}@anchor{3d8}
+@anchor{gnat_rm/the_gnat_library gnat-time-stamp-g-timsta-ads}@anchor{3c0}@anchor{gnat_rm/the_gnat_library id119}@anchor{3c1}
@section @code{GNAT.Time_Stamp} (@code{g-timsta.ads})
@@ -25226,7 +24984,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{3d9}@anchor{gnat_rm/the_gnat_library id131}@anchor{3da}
+@anchor{gnat_rm/the_gnat_library gnat-threads-g-thread-ads}@anchor{3c2}@anchor{gnat_rm/the_gnat_library id120}@anchor{3c3}
@section @code{GNAT.Threads} (@code{g-thread.ads})
@@ -25243,7 +25001,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{3db}@anchor{gnat_rm/the_gnat_library id132}@anchor{3dc}
+@anchor{gnat_rm/the_gnat_library gnat-traceback-g-traceb-ads}@anchor{3c4}@anchor{gnat_rm/the_gnat_library id121}@anchor{3c5}
@section @code{GNAT.Traceback} (@code{g-traceb.ads})
@@ -25255,7 +25013,7 @@ Provides a facility for obtaining non-symbolic traceback information, useful
in various debugging situations.
@node GNAT Traceback Symbolic g-trasym ads,GNAT UTF_32 g-table ads,GNAT Traceback g-traceb ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-traceback-symbolic-g-trasym-ads}@anchor{3dd}@anchor{gnat_rm/the_gnat_library id133}@anchor{3de}
+@anchor{gnat_rm/the_gnat_library gnat-traceback-symbolic-g-trasym-ads}@anchor{3c6}@anchor{gnat_rm/the_gnat_library id122}@anchor{3c7}
@section @code{GNAT.Traceback.Symbolic} (@code{g-trasym.ads})
@@ -25264,7 +25022,7 @@ in various debugging situations.
@geindex Trace back facilities
@node GNAT UTF_32 g-table ads,GNAT Wide_Spelling_Checker g-u3spch ads,GNAT Traceback Symbolic g-trasym ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-utf-32-g-table-ads}@anchor{3df}@anchor{gnat_rm/the_gnat_library id134}@anchor{3e0}
+@anchor{gnat_rm/the_gnat_library gnat-utf-32-g-table-ads}@anchor{3c8}@anchor{gnat_rm/the_gnat_library id123}@anchor{3c9}
@section @code{GNAT.UTF_32} (@code{g-table.ads})
@@ -25283,7 +25041,7 @@ lower case to upper case fold routine corresponding to
the Ada 2005 rules for identifier equivalence.
@node GNAT Wide_Spelling_Checker g-u3spch ads,GNAT Wide_Spelling_Checker g-wispch ads,GNAT UTF_32 g-table ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-wide-spelling-checker-g-u3spch-ads}@anchor{3e1}@anchor{gnat_rm/the_gnat_library id135}@anchor{3e2}
+@anchor{gnat_rm/the_gnat_library gnat-wide-spelling-checker-g-u3spch-ads}@anchor{3ca}@anchor{gnat_rm/the_gnat_library id124}@anchor{3cb}
@section @code{GNAT.Wide_Spelling_Checker} (@code{g-u3spch.ads})
@@ -25296,7 +25054,7 @@ near misspelling of another wide wide string, where the strings are represented
using the UTF_32_String type defined in System.Wch_Cnv.
@node GNAT Wide_Spelling_Checker g-wispch ads,GNAT Wide_String_Split g-wistsp ads,GNAT Wide_Spelling_Checker g-u3spch ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-wide-spelling-checker-g-wispch-ads}@anchor{3e3}@anchor{gnat_rm/the_gnat_library id136}@anchor{3e4}
+@anchor{gnat_rm/the_gnat_library gnat-wide-spelling-checker-g-wispch-ads}@anchor{3cc}@anchor{gnat_rm/the_gnat_library id125}@anchor{3cd}
@section @code{GNAT.Wide_Spelling_Checker} (@code{g-wispch.ads})
@@ -25308,7 +25066,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{3e5}@anchor{gnat_rm/the_gnat_library id137}@anchor{3e6}
+@anchor{gnat_rm/the_gnat_library gnat-wide-string-split-g-wistsp-ads}@anchor{3ce}@anchor{gnat_rm/the_gnat_library id126}@anchor{3cf}
@section @code{GNAT.Wide_String_Split} (@code{g-wistsp.ads})
@@ -25322,7 +25080,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{3e7}@anchor{gnat_rm/the_gnat_library id138}@anchor{3e8}
+@anchor{gnat_rm/the_gnat_library gnat-wide-wide-spelling-checker-g-zspche-ads}@anchor{3d0}@anchor{gnat_rm/the_gnat_library id127}@anchor{3d1}
@section @code{GNAT.Wide_Wide_Spelling_Checker} (@code{g-zspche.ads})
@@ -25334,7 +25092,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{3e9}@anchor{gnat_rm/the_gnat_library id139}@anchor{3ea}
+@anchor{gnat_rm/the_gnat_library gnat-wide-wide-string-split-g-zistsp-ads}@anchor{3d2}@anchor{gnat_rm/the_gnat_library id128}@anchor{3d3}
@section @code{GNAT.Wide_Wide_String_Split} (@code{g-zistsp.ads})
@@ -25348,7 +25106,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 id140}@anchor{3eb}@anchor{gnat_rm/the_gnat_library interfaces-c-extensions-i-cexten-ads}@anchor{3ec}
+@anchor{gnat_rm/the_gnat_library id129}@anchor{3d4}@anchor{gnat_rm/the_gnat_library interfaces-c-extensions-i-cexten-ads}@anchor{3d5}
@section @code{Interfaces.C.Extensions} (@code{i-cexten.ads})
@@ -25359,7 +25117,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 id141}@anchor{3ed}@anchor{gnat_rm/the_gnat_library interfaces-c-streams-i-cstrea-ads}@anchor{3ee}
+@anchor{gnat_rm/the_gnat_library id130}@anchor{3d6}@anchor{gnat_rm/the_gnat_library interfaces-c-streams-i-cstrea-ads}@anchor{3d7}
@section @code{Interfaces.C.Streams} (@code{i-cstrea.ads})
@@ -25372,7 +25130,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 id142}@anchor{3ef}@anchor{gnat_rm/the_gnat_library interfaces-packed-decimal-i-pacdec-ads}@anchor{3f0}
+@anchor{gnat_rm/the_gnat_library id131}@anchor{3d8}@anchor{gnat_rm/the_gnat_library interfaces-packed-decimal-i-pacdec-ads}@anchor{3d9}
@section @code{Interfaces.Packed_Decimal} (@code{i-pacdec.ads})
@@ -25387,7 +25145,7 @@ from a packed decimal format compatible with that used on IBM
mainframes.
@node Interfaces VxWorks i-vxwork ads,Interfaces VxWorks Int_Connection i-vxinco ads,Interfaces Packed_Decimal i-pacdec ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id143}@anchor{3f1}@anchor{gnat_rm/the_gnat_library interfaces-vxworks-i-vxwork-ads}@anchor{3f2}
+@anchor{gnat_rm/the_gnat_library id132}@anchor{3da}@anchor{gnat_rm/the_gnat_library interfaces-vxworks-i-vxwork-ads}@anchor{3db}
@section @code{Interfaces.VxWorks} (@code{i-vxwork.ads})
@@ -25403,7 +25161,7 @@ In particular, it interfaces with the
VxWorks hardware interrupt facilities.
@node Interfaces VxWorks Int_Connection i-vxinco ads,Interfaces VxWorks IO i-vxwoio ads,Interfaces VxWorks i-vxwork ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id144}@anchor{3f3}@anchor{gnat_rm/the_gnat_library interfaces-vxworks-int-connection-i-vxinco-ads}@anchor{3f4}
+@anchor{gnat_rm/the_gnat_library id133}@anchor{3dc}@anchor{gnat_rm/the_gnat_library interfaces-vxworks-int-connection-i-vxinco-ads}@anchor{3dd}
@section @code{Interfaces.VxWorks.Int_Connection} (@code{i-vxinco.ads})
@@ -25419,7 +25177,7 @@ intConnect() with a custom routine for installing interrupt
handlers.
@node Interfaces VxWorks IO i-vxwoio ads,System Address_Image s-addima ads,Interfaces VxWorks Int_Connection i-vxinco ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id145}@anchor{3f5}@anchor{gnat_rm/the_gnat_library interfaces-vxworks-io-i-vxwoio-ads}@anchor{3f6}
+@anchor{gnat_rm/the_gnat_library id134}@anchor{3de}@anchor{gnat_rm/the_gnat_library interfaces-vxworks-io-i-vxwoio-ads}@anchor{3df}
@section @code{Interfaces.VxWorks.IO} (@code{i-vxwoio.ads})
@@ -25442,7 +25200,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 id146}@anchor{3f7}@anchor{gnat_rm/the_gnat_library system-address-image-s-addima-ads}@anchor{3f8}
+@anchor{gnat_rm/the_gnat_library id135}@anchor{3e0}@anchor{gnat_rm/the_gnat_library system-address-image-s-addima-ads}@anchor{3e1}
@section @code{System.Address_Image} (@code{s-addima.ads})
@@ -25458,7 +25216,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 id147}@anchor{3f9}@anchor{gnat_rm/the_gnat_library system-assertions-s-assert-ads}@anchor{3fa}
+@anchor{gnat_rm/the_gnat_library id136}@anchor{3e2}@anchor{gnat_rm/the_gnat_library system-assertions-s-assert-ads}@anchor{3e3}
@section @code{System.Assertions} (@code{s-assert.ads})
@@ -25474,7 +25232,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 id148}@anchor{3fb}@anchor{gnat_rm/the_gnat_library system-atomic-counters-s-atocou-ads}@anchor{3fc}
+@anchor{gnat_rm/the_gnat_library id137}@anchor{3e4}@anchor{gnat_rm/the_gnat_library system-atomic-counters-s-atocou-ads}@anchor{3e5}
@section @code{System.Atomic_Counters} (@code{s-atocou.ads})
@@ -25488,7 +25246,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 id149}@anchor{3fd}@anchor{gnat_rm/the_gnat_library system-memory-s-memory-ads}@anchor{3fe}
+@anchor{gnat_rm/the_gnat_library id138}@anchor{3e6}@anchor{gnat_rm/the_gnat_library system-memory-s-memory-ads}@anchor{3e7}
@section @code{System.Memory} (@code{s-memory.ads})
@@ -25506,7 +25264,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 id150}@anchor{3ff}@anchor{gnat_rm/the_gnat_library system-multiprocessors-s-multip-ads}@anchor{400}
+@anchor{gnat_rm/the_gnat_library id139}@anchor{3e8}@anchor{gnat_rm/the_gnat_library system-multiprocessors-s-multip-ads}@anchor{3e9}
@section @code{System.Multiprocessors} (@code{s-multip.ads})
@@ -25519,7 +25277,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 id151}@anchor{401}@anchor{gnat_rm/the_gnat_library system-multiprocessors-dispatching-domains-s-mudido-ads}@anchor{402}
+@anchor{gnat_rm/the_gnat_library id140}@anchor{3ea}@anchor{gnat_rm/the_gnat_library system-multiprocessors-dispatching-domains-s-mudido-ads}@anchor{3eb}
@section @code{System.Multiprocessors.Dispatching_Domains} (@code{s-mudido.ads})
@@ -25532,7 +25290,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 id152}@anchor{403}@anchor{gnat_rm/the_gnat_library system-partition-interface-s-parint-ads}@anchor{404}
+@anchor{gnat_rm/the_gnat_library id141}@anchor{3ec}@anchor{gnat_rm/the_gnat_library system-partition-interface-s-parint-ads}@anchor{3ed}
@section @code{System.Partition_Interface} (@code{s-parint.ads})
@@ -25545,7 +25303,7 @@ is used primarily in a distribution context when using Annex E
with @code{GLADE}.
@node System Pool_Global s-pooglo ads,System Pool_Local s-pooloc ads,System Partition_Interface s-parint ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id153}@anchor{405}@anchor{gnat_rm/the_gnat_library system-pool-global-s-pooglo-ads}@anchor{406}
+@anchor{gnat_rm/the_gnat_library id142}@anchor{3ee}@anchor{gnat_rm/the_gnat_library system-pool-global-s-pooglo-ads}@anchor{3ef}
@section @code{System.Pool_Global} (@code{s-pooglo.ads})
@@ -25562,7 +25320,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 id154}@anchor{407}@anchor{gnat_rm/the_gnat_library system-pool-local-s-pooloc-ads}@anchor{408}
+@anchor{gnat_rm/the_gnat_library id143}@anchor{3f0}@anchor{gnat_rm/the_gnat_library system-pool-local-s-pooloc-ads}@anchor{3f1}
@section @code{System.Pool_Local} (@code{s-pooloc.ads})
@@ -25579,7 +25337,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 id155}@anchor{409}@anchor{gnat_rm/the_gnat_library system-restrictions-s-restri-ads}@anchor{40a}
+@anchor{gnat_rm/the_gnat_library id144}@anchor{3f2}@anchor{gnat_rm/the_gnat_library system-restrictions-s-restri-ads}@anchor{3f3}
@section @code{System.Restrictions} (@code{s-restri.ads})
@@ -25595,7 +25353,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 id156}@anchor{40b}@anchor{gnat_rm/the_gnat_library system-rident-s-rident-ads}@anchor{40c}
+@anchor{gnat_rm/the_gnat_library id145}@anchor{3f4}@anchor{gnat_rm/the_gnat_library system-rident-s-rident-ads}@anchor{3f5}
@section @code{System.Rident} (@code{s-rident.ads})
@@ -25611,7 +25369,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 id157}@anchor{40d}@anchor{gnat_rm/the_gnat_library system-strings-stream-ops-s-ststop-ads}@anchor{40e}
+@anchor{gnat_rm/the_gnat_library id146}@anchor{3f6}@anchor{gnat_rm/the_gnat_library system-strings-stream-ops-s-ststop-ads}@anchor{3f7}
@section @code{System.Strings.Stream_Ops} (@code{s-ststop.ads})
@@ -25627,7 +25385,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 id158}@anchor{40f}@anchor{gnat_rm/the_gnat_library system-unsigned-types-s-unstyp-ads}@anchor{410}
+@anchor{gnat_rm/the_gnat_library id147}@anchor{3f8}@anchor{gnat_rm/the_gnat_library system-unsigned-types-s-unstyp-ads}@anchor{3f9}
@section @code{System.Unsigned_Types} (@code{s-unstyp.ads})
@@ -25640,7 +25398,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 id159}@anchor{411}@anchor{gnat_rm/the_gnat_library system-wch-cnv-s-wchcnv-ads}@anchor{412}
+@anchor{gnat_rm/the_gnat_library id148}@anchor{3fa}@anchor{gnat_rm/the_gnat_library system-wch-cnv-s-wchcnv-ads}@anchor{3fb}
@section @code{System.Wch_Cnv} (@code{s-wchcnv.ads})
@@ -25661,7 +25419,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 id160}@anchor{413}@anchor{gnat_rm/the_gnat_library system-wch-con-s-wchcon-ads}@anchor{414}
+@anchor{gnat_rm/the_gnat_library id149}@anchor{3fc}@anchor{gnat_rm/the_gnat_library system-wch-con-s-wchcon-ads}@anchor{3fd}
@section @code{System.Wch_Con} (@code{s-wchcon.ads})
@@ -25673,7 +25431,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{3fe}@anchor{gnat_rm/interfacing_to_other_languages id1}@anchor{3ff}@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-other-languages}@anchor{11}
@chapter Interfacing to Other Languages
@@ -25691,7 +25449,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{400}@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-c}@anchor{401}
@section Interfacing to C
@@ -25831,7 +25589,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{47}@anchor{gnat_rm/interfacing_to_other_languages id4}@anchor{419}
+@anchor{gnat_rm/interfacing_to_other_languages id3}@anchor{47}@anchor{gnat_rm/interfacing_to_other_languages id4}@anchor{402}
@section Interfacing to C++
@@ -25888,7 +25646,7 @@ The @code{External_Name} is the name of the C++ RTTI symbol. You can then
cover a specific C++ exception in an exception handler.
@node Interfacing to COBOL,Interfacing to Fortran,Interfacing to C++,Interfacing to Other Languages
-@anchor{gnat_rm/interfacing_to_other_languages id5}@anchor{41a}@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-cobol}@anchor{41b}
+@anchor{gnat_rm/interfacing_to_other_languages id5}@anchor{403}@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-cobol}@anchor{404}
@section Interfacing to COBOL
@@ -25896,7 +25654,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{405}@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-fortran}@anchor{406}
@section Interfacing to Fortran
@@ -25906,7 +25664,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{407}@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-non-gnat-ada-code}@anchor{408}
@section Interfacing to non-GNAT Ada code
@@ -25930,7 +25688,7 @@ values or simple record types without variants, or simple array
types with fixed bounds.
@node Specialized Needs Annexes,Implementation of Specific Ada Features,Interfacing to Other Languages,Top
-@anchor{gnat_rm/specialized_needs_annexes 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{409}@anchor{gnat_rm/specialized_needs_annexes id1}@anchor{40a}@anchor{gnat_rm/specialized_needs_annexes specialized-needs-annexes}@anchor{12}
@chapter Specialized Needs Annexes
@@ -25971,7 +25729,7 @@ in Ada 2005) is fully implemented.
@end table
@node Implementation of Specific Ada Features,Implementation of Ada 2012 Features,Specialized Needs Annexes,Top
-@anchor{gnat_rm/implementation_of_specific_ada_features 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}
+@anchor{gnat_rm/implementation_of_specific_ada_features doc}@anchor{40b}@anchor{gnat_rm/implementation_of_specific_ada_features id1}@anchor{40c}@anchor{gnat_rm/implementation_of_specific_ada_features implementation-of-specific-ada-features}@anchor{13}
@chapter Implementation of Specific Ada Features
@@ -25990,7 +25748,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{166}
+@anchor{gnat_rm/implementation_of_specific_ada_features id2}@anchor{40d}@anchor{gnat_rm/implementation_of_specific_ada_features machine-code-insertions}@anchor{166}
@section Machine Code Insertions
@@ -26158,7 +25916,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{40e}@anchor{gnat_rm/implementation_of_specific_ada_features id3}@anchor{40f}
@section GNAT Implementation of Tasking
@@ -26174,7 +25932,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{410}@anchor{gnat_rm/implementation_of_specific_ada_features mapping-ada-tasks-onto-the-underlying-kernel-threads}@anchor{411}
@subsection Mapping Ada Tasks onto the Underlying Kernel Threads
@@ -26243,7 +26001,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{412}@anchor{gnat_rm/implementation_of_specific_ada_features id5}@anchor{413}
@subsection Ensuring Compliance with the Real-Time Annex
@@ -26294,7 +26052,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{414}
@subsection Support for Locking Policies
@@ -26328,7 +26086,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{415}@anchor{gnat_rm/implementation_of_specific_ada_features id6}@anchor{416}
@section GNAT Implementation of Shared Passive Packages
@@ -26426,7 +26184,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{417}@anchor{gnat_rm/implementation_of_specific_ada_features id7}@anchor{418}
@section Code Generation for Array Aggregates
@@ -26457,7 +26215,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{419}@anchor{gnat_rm/implementation_of_specific_ada_features static-constant-aggregates-with-static-bounds}@anchor{41a}
@subsection Static constant aggregates with static bounds
@@ -26504,7 +26262,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{41b}@anchor{gnat_rm/implementation_of_specific_ada_features id9}@anchor{41c}
@subsection Constant aggregates with unconstrained nominal types
@@ -26519,7 +26277,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{41d}@anchor{gnat_rm/implementation_of_specific_ada_features id10}@anchor{41e}
@subsection Aggregates with static bounds
@@ -26547,7 +26305,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{41f}@anchor{gnat_rm/implementation_of_specific_ada_features id11}@anchor{420}
@subsection Aggregates with nonstatic bounds
@@ -26558,7 +26316,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{421}@anchor{gnat_rm/implementation_of_specific_ada_features id12}@anchor{422}
@subsection Aggregates in assignment statements
@@ -26600,7 +26358,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{423}@anchor{gnat_rm/implementation_of_specific_ada_features the-size-of-discriminated-records-with-default-discriminants}@anchor{424}
@section The Size of Discriminated Records with Default Discriminants
@@ -26680,7 +26438,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{425}@anchor{gnat_rm/implementation_of_specific_ada_features image-values-for-nonscalar-types}@anchor{426}
@section Image Values For Nonscalar Types
@@ -26700,7 +26458,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{427}@anchor{gnat_rm/implementation_of_specific_ada_features strict-conformance-to-the-ada-reference-manual}@anchor{428}
@section Strict Conformance to the Ada Reference Manual
@@ -26727,7 +26485,7 @@ behavior (although at the cost of a significant performance penalty), so
infinite and NaN values are properly generated.
@node Implementation of Ada 2012 Features,Security Hardening Features,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}
+@anchor{gnat_rm/implementation_of_ada_2012_features doc}@anchor{429}@anchor{gnat_rm/implementation_of_ada_2012_features id1}@anchor{42a}@anchor{gnat_rm/implementation_of_ada_2012_features implementation-of-ada-2012-features}@anchor{14}
@chapter Implementation of Ada 2012 Features
@@ -28893,7 +28651,7 @@ RM References: H.04 (8/1)
@end itemize
@node Security Hardening Features,Obsolescent Features,Implementation of Ada 2012 Features,Top
-@anchor{gnat_rm/security_hardening_features doc}@anchor{442}@anchor{gnat_rm/security_hardening_features id1}@anchor{443}@anchor{gnat_rm/security_hardening_features security-hardening-features}@anchor{15}
+@anchor{gnat_rm/security_hardening_features doc}@anchor{42b}@anchor{gnat_rm/security_hardening_features id1}@anchor{42c}@anchor{gnat_rm/security_hardening_features security-hardening-features}@anchor{15}
@chapter Security Hardening Features
@@ -28915,7 +28673,7 @@ change.
@end menu
@node Register Scrubbing,Stack Scrubbing,,Security Hardening Features
-@anchor{gnat_rm/security_hardening_features register-scrubbing}@anchor{444}
+@anchor{gnat_rm/security_hardening_features register-scrubbing}@anchor{42d}
@section Register Scrubbing
@@ -28945,7 +28703,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{445}
+@anchor{gnat_rm/security_hardening_features stack-scrubbing}@anchor{42e}
@section Stack Scrubbing
@@ -29040,7 +28798,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{446}
+@anchor{gnat_rm/security_hardening_features hardened-conditionals}@anchor{42f}
@section Hardened Conditionals
@@ -29087,7 +28845,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{447}
+@anchor{gnat_rm/security_hardening_features hardened-booleans}@anchor{430}
@section Hardened Booleans
@@ -29128,7 +28886,7 @@ For usage and more details on that attribute, see @cite{Using the GNU Compiler C
@c Control Flow Redundancy:
@node Control Flow Redundancy,,Hardened Booleans,Security Hardening Features
-@anchor{gnat_rm/security_hardening_features control-flow-redundancy}@anchor{448}
+@anchor{gnat_rm/security_hardening_features control-flow-redundancy}@anchor{431}
@section Control Flow Redundancy
@@ -29177,7 +28935,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{449}@anchor{gnat_rm/obsolescent_features id1}@anchor{44a}@anchor{gnat_rm/obsolescent_features obsolescent-features}@anchor{16}
+@anchor{gnat_rm/obsolescent_features doc}@anchor{432}@anchor{gnat_rm/obsolescent_features id1}@anchor{433}@anchor{gnat_rm/obsolescent_features obsolescent-features}@anchor{16}
@chapter Obsolescent Features
@@ -29196,7 +28954,7 @@ compatibility purposes.
@end menu
@node pragma No_Run_Time,pragma Ravenscar,,Obsolescent Features
-@anchor{gnat_rm/obsolescent_features id2}@anchor{44b}@anchor{gnat_rm/obsolescent_features pragma-no-run-time}@anchor{44c}
+@anchor{gnat_rm/obsolescent_features id2}@anchor{434}@anchor{gnat_rm/obsolescent_features pragma-no-run-time}@anchor{435}
@section pragma No_Run_Time
@@ -29209,7 +28967,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{44d}@anchor{gnat_rm/obsolescent_features pragma-ravenscar}@anchor{44e}
+@anchor{gnat_rm/obsolescent_features id3}@anchor{436}@anchor{gnat_rm/obsolescent_features pragma-ravenscar}@anchor{437}
@section pragma Ravenscar
@@ -29218,7 +28976,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{44f}@anchor{gnat_rm/obsolescent_features pragma-restricted-run-time}@anchor{450}
+@anchor{gnat_rm/obsolescent_features id4}@anchor{438}@anchor{gnat_rm/obsolescent_features pragma-restricted-run-time}@anchor{439}
@section pragma Restricted_Run_Time
@@ -29228,7 +28986,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{451}@anchor{gnat_rm/obsolescent_features pragma-task-info}@anchor{452}
+@anchor{gnat_rm/obsolescent_features id5}@anchor{43a}@anchor{gnat_rm/obsolescent_features pragma-task-info}@anchor{43b}
@section pragma Task_Info
@@ -29254,7 +29012,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{453}@anchor{gnat_rm/obsolescent_features package-system-task-info-s-tasinf-ads}@anchor{454}
+@anchor{gnat_rm/obsolescent_features package-system-task-info}@anchor{43c}@anchor{gnat_rm/obsolescent_features package-system-task-info-s-tasinf-ads}@anchor{43d}
@section package System.Task_Info (@code{s-tasinf.ads})
@@ -29264,7 +29022,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{455}@anchor{gnat_rm/compatibility_and_porting_guide compatibility-and-porting-guide}@anchor{17}@anchor{gnat_rm/compatibility_and_porting_guide id1}@anchor{456}
+@anchor{gnat_rm/compatibility_and_porting_guide doc}@anchor{43e}@anchor{gnat_rm/compatibility_and_porting_guide compatibility-and-porting-guide}@anchor{17}@anchor{gnat_rm/compatibility_and_porting_guide id1}@anchor{43f}
@chapter Compatibility and Porting Guide
@@ -29286,7 +29044,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{457}@anchor{gnat_rm/compatibility_and_porting_guide writing-portable-fixed-point-declarations}@anchor{458}
+@anchor{gnat_rm/compatibility_and_porting_guide id2}@anchor{440}@anchor{gnat_rm/compatibility_and_porting_guide writing-portable-fixed-point-declarations}@anchor{441}
@section Writing Portable Fixed-Point Declarations
@@ -29408,7 +29166,7 @@ If you follow this scheme you will be guaranteed that your fixed-point
types will be portable.
@node Compatibility with Ada 83,Compatibility between Ada 95 and Ada 2005,Writing Portable Fixed-Point Declarations,Compatibility and Porting Guide
-@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-ada-83}@anchor{459}@anchor{gnat_rm/compatibility_and_porting_guide id3}@anchor{45a}
+@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-ada-83}@anchor{442}@anchor{gnat_rm/compatibility_and_porting_guide id3}@anchor{443}
@section Compatibility with Ada 83
@@ -29436,7 +29194,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{45b}@anchor{gnat_rm/compatibility_and_porting_guide legal-ada-83-programs-that-are-illegal-in-ada-95}@anchor{45c}
+@anchor{gnat_rm/compatibility_and_porting_guide id4}@anchor{444}@anchor{gnat_rm/compatibility_and_porting_guide legal-ada-83-programs-that-are-illegal-in-ada-95}@anchor{445}
@subsection Legal Ada 83 programs that are illegal in Ada 95
@@ -29536,7 +29294,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{45d}@anchor{gnat_rm/compatibility_and_porting_guide more-deterministic-semantics}@anchor{45e}
+@anchor{gnat_rm/compatibility_and_porting_guide id5}@anchor{446}@anchor{gnat_rm/compatibility_and_porting_guide more-deterministic-semantics}@anchor{447}
@subsection More deterministic semantics
@@ -29564,7 +29322,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{45f}@anchor{gnat_rm/compatibility_and_porting_guide id6}@anchor{460}
+@anchor{gnat_rm/compatibility_and_porting_guide changed-semantics}@anchor{448}@anchor{gnat_rm/compatibility_and_porting_guide id6}@anchor{449}
@subsection Changed semantics
@@ -29606,7 +29364,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{461}@anchor{gnat_rm/compatibility_and_porting_guide other-language-compatibility-issues}@anchor{462}
+@anchor{gnat_rm/compatibility_and_porting_guide id7}@anchor{44a}@anchor{gnat_rm/compatibility_and_porting_guide other-language-compatibility-issues}@anchor{44b}
@subsection Other language compatibility issues
@@ -29639,7 +29397,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{463}@anchor{gnat_rm/compatibility_and_porting_guide id8}@anchor{464}
+@anchor{gnat_rm/compatibility_and_porting_guide compatibility-between-ada-95-and-ada-2005}@anchor{44c}@anchor{gnat_rm/compatibility_and_porting_guide id8}@anchor{44d}
@section Compatibility between Ada 95 and Ada 2005
@@ -29711,7 +29469,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{465}@anchor{gnat_rm/compatibility_and_porting_guide implementation-dependent-characteristics}@anchor{466}
+@anchor{gnat_rm/compatibility_and_porting_guide id9}@anchor{44e}@anchor{gnat_rm/compatibility_and_porting_guide implementation-dependent-characteristics}@anchor{44f}
@section Implementation-dependent characteristics
@@ -29734,7 +29492,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{467}@anchor{gnat_rm/compatibility_and_porting_guide implementation-defined-pragmas}@anchor{468}
+@anchor{gnat_rm/compatibility_and_porting_guide id10}@anchor{450}@anchor{gnat_rm/compatibility_and_porting_guide implementation-defined-pragmas}@anchor{451}
@subsection Implementation-defined pragmas
@@ -29756,7 +29514,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{469}@anchor{gnat_rm/compatibility_and_porting_guide implementation-defined-attributes}@anchor{46a}
+@anchor{gnat_rm/compatibility_and_porting_guide id11}@anchor{452}@anchor{gnat_rm/compatibility_and_porting_guide implementation-defined-attributes}@anchor{453}
@subsection Implementation-defined attributes
@@ -29770,7 +29528,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{46b}@anchor{gnat_rm/compatibility_and_porting_guide libraries}@anchor{46c}
+@anchor{gnat_rm/compatibility_and_porting_guide id12}@anchor{454}@anchor{gnat_rm/compatibility_and_porting_guide libraries}@anchor{455}
@subsection Libraries
@@ -29799,7 +29557,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{46d}@anchor{gnat_rm/compatibility_and_porting_guide id13}@anchor{46e}
+@anchor{gnat_rm/compatibility_and_porting_guide elaboration-order}@anchor{456}@anchor{gnat_rm/compatibility_and_porting_guide id13}@anchor{457}
@subsection Elaboration order
@@ -29835,7 +29593,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{46f}@anchor{gnat_rm/compatibility_and_porting_guide target-specific-aspects}@anchor{470}
+@anchor{gnat_rm/compatibility_and_porting_guide id14}@anchor{458}@anchor{gnat_rm/compatibility_and_porting_guide target-specific-aspects}@anchor{459}
@subsection Target-specific aspects
@@ -29848,10 +29606,10 @@ on the robustness of the original design. Moreover, Ada 95 (and thus
Ada 2005 and Ada 2012) are sometimes
incompatible with typical Ada 83 compiler practices regarding implicit
packing, the meaning of the Size attribute, and the size of access values.
-GNAT’s approach to these issues is described in @ref{471,,Representation Clauses}.
+GNAT’s approach to these issues is described in @ref{45a,,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{472}@anchor{gnat_rm/compatibility_and_porting_guide id15}@anchor{473}
+@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-other-ada-systems}@anchor{45b}@anchor{gnat_rm/compatibility_and_porting_guide id15}@anchor{45c}
@section Compatibility with Other Ada Systems
@@ -29894,7 +29652,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{474}@anchor{gnat_rm/compatibility_and_porting_guide representation-clauses}@anchor{471}
+@anchor{gnat_rm/compatibility_and_porting_guide id16}@anchor{45d}@anchor{gnat_rm/compatibility_and_porting_guide representation-clauses}@anchor{45a}
@section Representation Clauses
@@ -29987,7 +29745,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{475}@anchor{gnat_rm/compatibility_and_porting_guide id17}@anchor{476}
+@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-hp-ada-83}@anchor{45e}@anchor{gnat_rm/compatibility_and_porting_guide id17}@anchor{45f}
@section Compatibility with HP Ada 83
@@ -30017,7 +29775,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{477}@anchor{share/gnu_free_documentation_license gnu-fdl}@anchor{1}@anchor{share/gnu_free_documentation_license gnu-free-documentation-license}@anchor{478}
+@anchor{share/gnu_free_documentation_license doc}@anchor{460}@anchor{share/gnu_free_documentation_license gnu-fdl}@anchor{1}@anchor{share/gnu_free_documentation_license gnu-free-documentation-license}@anchor{461}
@chapter GNU Free Documentation License
diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi
index e1a4192..f2cb1ed 100644
--- a/gcc/ada/gnat_ugn.texi
+++ b/gcc/ada/gnat_ugn.texi
@@ -19,7 +19,7 @@
@copying
@quotation
-GNAT User's Guide for Native Platforms , Aug 25, 2022
+GNAT User's Guide for Native Platforms , Sep 09, 2022
AdaCore
@@ -12984,7 +12984,7 @@ to the default checks required by Ada as described above.
All validity checks are turned on.
That is, @code{-gnatVa} is
-equivalent to @code{gnatVcdfimoprst}.
+equivalent to @code{gnatVcdefimoprst}.
@end table
@geindex -gnatVc (gcc)
@@ -12996,8 +12996,8 @@ equivalent to @code{gnatVcdfimoprst}.
`Validity checks for copies.'
-The right hand side of assignments, and the initializing values of
-object declarations are validity checked.
+The right-hand side of assignments, and the (explicit) initializing values
+of object declarations are validity checked.
@end table
@geindex -gnatVd (gcc)
@@ -13009,12 +13009,14 @@ object declarations are validity checked.
`Default (RM) validity checks.'
-Some validity checks are done by default following normal Ada semantics
-(RM 13.9.1 (9-11)).
-A check is done in case statements that the expression is within the range
-of the subtype. If it is not, Constraint_Error is raised.
-For assignments to array components, a check is done that the expression used
-as index is within the range. If it is not, Constraint_Error is raised.
+Some validity checks are required by Ada (see RM 13.9.1 (9-11)); these
+(and only these) validity checks are enabled by default.
+For case statements (and case expressions) that lack a “when others =>”
+choice, a check is made that the value of the selector expression
+belongs to its nominal subtype. If it does not, Constraint_Error is raised.
+For assignments to array components (and for indexed components in some
+other contexts), a check is made that each index expression belongs to the
+corresponding index subtype. If it does not, Constraint_Error is raised.
Both these validity checks may be turned off using switch @code{-gnatVD}.
They are turned on by default. If @code{-gnatVD} is specified, a subsequent
switch @code{-gnatVd} will leave the checks turned on.
@@ -13031,16 +13033,13 @@ overwriting may occur.
@item @code{-gnatVe}
-`Validity checks for elementary components.'
+`Validity checks for scalar components.'
-In the absence of this switch, assignments to record or array components are
-not validity checked, even if validity checks for assignments generally
-(@code{-gnatVc}) are turned on. In Ada, assignment of composite values do not
-require valid data, but assignment of individual components does. So for
-example, there is a difference between copying the elements of an array with a
-slice assignment, compared to assigning element by element in a loop. This
-switch allows you to turn off validity checking for components, even when they
-are assigned component by component.
+In the absence of this switch, assignments to scalar components of
+enclosing record or array objects are not validity checked, even if
+validity checks for assignments generally (@code{-gnatVc}) are turned on.
+Specifying this switch enables such checks.
+This switch has no effect if the @code{-gnatVc} switch is not specified.
@end table
@geindex -gnatVf (gcc)
@@ -13052,11 +13051,18 @@ are assigned component by component.
`Validity checks for floating-point values.'
-In the absence of this switch, validity checking occurs only for discrete
-values. If @code{-gnatVf} is specified, then validity checking also applies
+Specifying this switch enables validity checking for floating-point
+values in the same contexts where validity checking is enabled for
+other scalar values.
+In the absence of this switch, validity checking is not performed for
+floating-point values. This takes precedence over other statements about
+performing validity checking for scalar objects in various scenarios.
+One way to look at it is that if this switch is not set, then whenever
+any of the other rules in this section use the word “scalar” they
+really mean “scalar and not floating-point”.
+If @code{-gnatVf} is specified, then validity checking also applies
for floating-point values, and NaNs and infinities are considered invalid,
-as well as out of range values for constrained types. Note that this means
-that standard IEEE infinity mode is not allowed. The exact contexts
+as well as out-of-range values for constrained types. The exact contexts
in which floating-point values are checked depends on the setting of other
options. For example, @code{-gnatVif} or @code{-gnatVfi}
(the order does not matter) specifies that floating-point parameters of mode
@@ -13119,7 +13125,8 @@ is used, it cancels any other @code{-gnatV} previously issued.
`Validity checks for operator and attribute operands.'
-Arguments for predefined operators and attributes are validity checked.
+Scalar arguments for predefined operators and for attributes are
+validity checked.
This includes all operators in package @code{Standard},
the shift operators defined as intrinsic in package @code{Interfaces}
and operands for attributes such as @code{Pos}. Checks are also made
@@ -13137,14 +13144,15 @@ also made on explicit ranges using @code{..} (e.g., slices, loops etc).
`Validity checks for parameters.'
-This controls the treatment of parameters within a subprogram (as opposed
-to @code{-gnatVi} and @code{-gnatVm} which control validity testing
-of parameters on a call. If either of these call options is used, then
-normally an assumption is made within a subprogram that the input arguments
-have been validity checking at the point of call, and do not need checking
-again within a subprogram). If @code{-gnatVp} is set, then this assumption
-is not made, and parameters are not assumed to be valid, so their validity
-will be checked (or rechecked) within the subprogram.
+This controls the treatment of formal parameters within a subprogram (as
+opposed to @code{-gnatVi} and @code{-gnatVm}, which control validity
+testing of actual parameters of a call). If either of these call options is
+specified, then normally an assumption is made within a subprogram that
+the validity of any incoming formal parameters of the corresponding mode(s)
+has already been checked at the point of call and does not need rechecking.
+If @code{-gnatVp} is set, then this assumption is not made and so their
+validity may be checked (or rechecked) within the subprogram. If neither of
+the two call-related options is specified, then this switch has no effect.
@end table
@geindex -gnatVr (gcc)
@@ -13156,7 +13164,7 @@ will be checked (or rechecked) within the subprogram.
`Validity checks for function returns.'
-The expression in @code{return} statements in functions is validity
+The expression in simple @code{return} statements in functions is validity
checked.
@end table
@@ -13169,9 +13177,10 @@ checked.
`Validity checks for subscripts.'
-All subscripts expressions are checked for validity, whether they appear
-on the right side or left side (in default mode only left side subscripts
-are validity checked).
+All subscript expressions are checked for validity, whatever context
+they occur in (in default mode some subscripts are not validity checked;
+for example, validity checking may be omitted in some cases involving
+a read of a component of an array).
@end table
@geindex -gnatVt (gcc)
diff --git a/gcc/ada/impunit.adb b/gcc/ada/impunit.adb
index 343a9db..6562c12 100644
--- a/gcc/ada/impunit.adb
+++ b/gcc/ada/impunit.adb
@@ -605,19 +605,7 @@ package body Impunit is
-- GNAT Defined Additions to Ada 2012 --
----------------------------------------
- ("a-cfidll", F), -- Ada.Containers.Formal_Indefinite_Doubly_Linked_Lists
- ("a-cfinse", F), -- Ada.Containers.Functional_Infinite_Sequences
- ("a-cfinve", F), -- Ada.Containers.Formal_Indefinite_Vectors
("a-coboho", F), -- Ada.Containers.Bounded_Holders
- ("a-cofove", F), -- Ada.Containers.Formal_Vectors
- ("a-cofuma", F), -- Ada.Containers.Functional_Maps
- ("a-cofuse", F), -- Ada.Containers.Functional_Sets
- ("a-cofuve", F), -- Ada.Containers.Functional_Vectors
- ("a-cfdlli", F), -- Ada.Containers.Formal_Doubly_Linked_Lists
- ("a-cforse", F), -- Ada.Containers.Formal_Ordered_Sets
- ("a-cforma", F), -- Ada.Containers.Formal_Ordered_Maps
- ("a-cfhase", F), -- Ada.Containers.Formal_Hashed_Sets
- ("a-cfhama", F), -- Ada.Containers.Formal_Hashed_Maps
("a-cvgpso", F) -- Ada.Containers.Vectors.Generic_Parallel_Sorting from
); -- GNATCOLL.OMP
diff --git a/gcc/ada/inline.adb b/gcc/ada/inline.adb
index e32df68..e3f35da 100644
--- a/gcc/ada/inline.adb
+++ b/gcc/ada/inline.adb
@@ -3257,7 +3257,7 @@ package body Inline is
pragma Assert
(Modify_Tree_For_C
and then Is_Subprogram (Enclosing_Subp)
- and then Present (Postconditions_Proc (Enclosing_Subp)));
+ and then Present (Wrapped_Statements (Enclosing_Subp)));
if Ekind (Enclosing_Subp) = E_Function then
if Nkind (First (Parameter_Associations (N))) in
@@ -3367,6 +3367,8 @@ package body Inline is
E : Entity_Id;
Ret : Node_Id;
+ Had_Private_View : Boolean;
+
begin
if Is_Entity_Name (N) and then Present (Entity (N)) then
E := Entity (N);
@@ -3380,13 +3382,21 @@ package body Inline is
-- subtype is private at the call point but its full view is
-- visible to the body, then the inlined tree here must be
-- analyzed with the full view).
+ --
+ -- The Has_Private_View flag is cleared by rewriting, so it
+ -- must be explicitly saved and restored, just like when
+ -- instantiating the body to inline.
if Is_Entity_Name (A) then
+ Had_Private_View := Has_Private_View (N);
Rewrite (N, New_Occurrence_Of (Entity (A), Sloc (N)));
+ Set_Has_Private_View (N, Had_Private_View);
Check_Private_View (N);
elsif Nkind (A) = N_Defining_Identifier then
+ Had_Private_View := Has_Private_View (N);
Rewrite (N, New_Occurrence_Of (A, Sloc (N)));
+ Set_Has_Private_View (N, Had_Private_View);
Check_Private_View (N);
-- Numeric literal
@@ -3841,7 +3851,7 @@ package body Inline is
if Modify_Tree_For_C
and then Nkind (N) = N_Procedure_Call_Statement
- and then Chars (Name (N)) = Name_uPostconditions
+ and then Chars (Name (N)) = Name_uWrapped_Statements
then
Declare_Postconditions_Result;
end if;
@@ -4536,13 +4546,14 @@ package body Inline is
Decl : Node_Id;
begin
- if No (E_Body) then -- imported subprogram
+ if No (E_Body) then -- imported subprogram
return False;
else
Decl := First (Declarations (E_Body));
while Present (Decl) loop
if Nkind (Decl) = N_Full_Type_Declaration
+ and then Comes_From_Source (Decl)
and then Present (Init_Proc (Defining_Identifier (Decl)))
then
return True;
@@ -4698,8 +4709,9 @@ package body Inline is
procedure Inline_Static_Function_Call (N : Node_Id; Subp : Entity_Id) is
function Replace_Formal (N : Node_Id) return Traverse_Result;
- -- Replace each occurrence of a formal with the corresponding actual,
- -- using the mapping created by Establish_Mapping_For_Inlined_Call.
+ -- Replace each occurrence of a formal with the
+ -- corresponding actual, using the mapping created
+ -- by Establish_Actual_Mapping_For_Inlined_Call.
function Reset_Sloc (Nod : Node_Id) return Traverse_Result;
-- Reset the Sloc of a node to that of the call itself, so that errors
diff --git a/gcc/ada/lib-xref.adb b/gcc/ada/lib-xref.adb
index a4ff69a..043444c 100644
--- a/gcc/ada/lib-xref.adb
+++ b/gcc/ada/lib-xref.adb
@@ -618,15 +618,6 @@ package body Lib.Xref is
end if;
end if;
- -- Do not generate references if we are within a postcondition sub-
- -- program, because the reference does not comes from source, and the
- -- preanalysis of the aspect has already created an entry for the ALI
- -- file at the proper source location.
-
- if Chars (Current_Scope) = Name_uPostconditions then
- return;
- end if;
-
-- Never collect references if not in main source unit. However, we omit
-- this test if Typ is 'e' or 'k', since these entries are structural,
-- and it is useful to have them in units that reference packages as
diff --git a/gcc/ada/lib.adb b/gcc/ada/lib.adb
index 6c51cc7..691d8e4 100644
--- a/gcc/ada/lib.adb
+++ b/gcc/ada/lib.adb
@@ -992,6 +992,15 @@ package body Lib is
return Is_Predefined_Renaming (Unit);
end In_Predefined_Renaming;
+ ---------
+ -- ipu --
+ ---------
+
+ function ipu (N : Node_Or_Entity_Id) return Boolean is
+ begin
+ return In_Predefined_Unit (N);
+ end ipu;
+
------------------------
-- In_Predefined_Unit --
------------------------
diff --git a/gcc/ada/lib.ads b/gcc/ada/lib.ads
index e29d42a..c308ac1 100644
--- a/gcc/ada/lib.ads
+++ b/gcc/ada/lib.ads
@@ -633,6 +633,12 @@ package Lib is
function In_Extended_Main_Source_Unit (Loc : Source_Ptr) return Boolean;
-- Same function as above, but argument is a source pointer
+ 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.
+
function In_Predefined_Unit (N : Node_Or_Entity_Id) return Boolean;
-- Returns True if the given node or entity appears within the source text
-- of a predefined unit (i.e. within Ada, Interfaces, System or within one
diff --git a/gcc/ada/libgnarl/s-tpoben.ads b/gcc/ada/libgnarl/s-tpoben.ads
index 2fd91ac..c6866f9 100644
--- a/gcc/ada/libgnarl/s-tpoben.ads
+++ b/gcc/ada/libgnarl/s-tpoben.ads
@@ -189,14 +189,19 @@ package System.Tasking.Protected_Objects.Entries is
-- Lock a protected object for write access. Upon return, the caller owns
-- the lock to this object, and no other call to Lock or Lock_Read_Only
-- with the same argument will return until the corresponding call to
- -- Unlock has been made by the caller. Program_Error is raised in case of
- -- ceiling violation.
+ -- Unlock has been made by the caller. Program_Error is raised in case
+ -- of ceiling violation, or if the protected object has already been
+ -- finalized, or if Detect_Blocking is true and the protected object
+ -- is already locked by the current task. In the Program_Error cases,
+ -- the object is not locked.
procedure Lock_Entries_With_Status
(Object : Protection_Entries_Access;
Ceiling_Violation : out Boolean);
-- Same as above, but return the ceiling violation status instead of
- -- raising Program_Error.
+ -- raising Program_Error. This raises Program_Error in the other
+ -- cases mentioned for Lock_Entries. In the Program_Error cases,
+ -- the object is not locked.
procedure Lock_Read_Only_Entries (Object : Protection_Entries_Access);
-- Lock a protected object for read access. Upon return, the caller owns
diff --git a/gcc/ada/libgnat/a-cfdlli.adb b/gcc/ada/libgnat/a-cfdlli.adb
deleted file mode 100644
index bbb8fd4..0000000
--- a/gcc/ada/libgnat/a-cfdlli.adb
+++ /dev/null
@@ -1,1905 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT LIBRARY COMPONENTS --
--- --
--- ADA.CONTAINERS.FORMAL_DOUBLY_LINKED_LISTS --
--- --
--- B o d y --
--- --
--- Copyright (C) 2010-2022, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
-------------------------------------------------------------------------------
-
-with Ada.Containers.Stable_Sorting; use Ada.Containers.Stable_Sorting;
-
-with System; use type System.Address;
-
-with Ada.Numerics.Big_Numbers.Big_Integers;
-use Ada.Numerics.Big_Numbers.Big_Integers;
-
-package body Ada.Containers.Formal_Doubly_Linked_Lists with
- SPARK_Mode => Off
-is
- -- Convert Count_Type to Big_Interger
-
- package Conversions is new Signed_Conversions (Int => Count_Type);
- use Conversions;
-
- -----------------------
- -- Local Subprograms --
- -----------------------
-
- procedure Allocate
- (Container : in out List;
- New_Item : Element_Type;
- New_Node : out Count_Type);
-
- procedure Free (Container : in out List; X : Count_Type);
-
- procedure Insert_Internal
- (Container : in out List;
- Before : Count_Type;
- New_Node : Count_Type);
-
- function Vet (L : List; Position : Cursor) return Boolean with Inline;
-
- ---------
- -- "=" --
- ---------
-
- function "=" (Left : List; Right : List) return Boolean is
- LI : Count_Type;
- RI : Count_Type;
-
- begin
- if Left'Address = Right'Address then
- return True;
- end if;
-
- if Left.Length /= Right.Length then
- return False;
- end if;
-
- LI := Left.First;
- RI := Right.First;
- while LI /= 0 loop
- if Left.Nodes (LI).Element /= Right.Nodes (RI).Element then
- return False;
- end if;
-
- LI := Left.Nodes (LI).Next;
- RI := Right.Nodes (RI).Next;
- end loop;
-
- return True;
- end "=";
-
- --------------
- -- Allocate --
- --------------
-
- procedure Allocate
- (Container : in out List;
- New_Item : Element_Type;
- New_Node : out Count_Type)
- is
- N : Node_Array renames Container.Nodes;
-
- begin
- if Container.Free >= 0 then
- New_Node := Container.Free;
- N (New_Node).Element := New_Item;
- Container.Free := N (New_Node).Next;
-
- else
- New_Node := abs Container.Free;
- N (New_Node).Element := New_Item;
- Container.Free := Container.Free - 1;
- end if;
- end Allocate;
-
- ------------
- -- Append --
- ------------
-
- procedure Append (Container : in out List; New_Item : Element_Type) is
- begin
- Insert (Container, No_Element, New_Item, 1);
- end Append;
-
- procedure Append
- (Container : in out List;
- New_Item : Element_Type;
- Count : Count_Type)
- is
- begin
- Insert (Container, No_Element, New_Item, Count);
- end Append;
-
- ------------
- -- Assign --
- ------------
-
- procedure Assign (Target : in out List; Source : List) is
- N : Node_Array renames Source.Nodes;
- J : Count_Type;
-
- begin
- if Target'Address = Source'Address then
- return;
- end if;
-
- if Target.Capacity < Source.Length then
- raise Constraint_Error with -- ???
- "Source length exceeds Target capacity";
- end if;
-
- Clear (Target);
-
- J := Source.First;
- while J /= 0 loop
- Append (Target, N (J).Element, 1);
- J := N (J).Next;
- end loop;
- end Assign;
-
- -----------
- -- Clear --
- -----------
-
- procedure Clear (Container : in out List) is
- N : Node_Array renames Container.Nodes;
- X : Count_Type;
-
- begin
- if Container.Length = 0 then
- pragma Assert (Container.First = 0);
- pragma Assert (Container.Last = 0);
- return;
- end if;
-
- pragma Assert (Container.First >= 1);
- pragma Assert (Container.Last >= 1);
- pragma Assert (N (Container.First).Prev = 0);
- pragma Assert (N (Container.Last).Next = 0);
-
- while Container.Length > 1 loop
- X := Container.First;
-
- Container.First := N (X).Next;
- N (Container.First).Prev := 0;
-
- Container.Length := Container.Length - 1;
-
- Free (Container, X);
- end loop;
-
- X := Container.First;
-
- Container.First := 0;
- Container.Last := 0;
- Container.Length := 0;
-
- Free (Container, X);
- end Clear;
-
- ------------------------
- -- Constant_Reference --
- ------------------------
-
- function Constant_Reference
- (Container : aliased List;
- Position : Cursor) return not null access constant Element_Type
- is
- begin
- if not Has_Element (Container => Container, Position => Position) then
- raise Constraint_Error with "Position cursor has no element";
- end if;
-
- return Container.Nodes (Position.Node).Element'Access;
- end Constant_Reference;
-
- --------------
- -- Contains --
- --------------
-
- function Contains
- (Container : List;
- Item : Element_Type) return Boolean
- is
- begin
- return Find (Container, Item) /= No_Element;
- end Contains;
-
- ----------
- -- Copy --
- ----------
-
- function Copy
- (Source : List;
- Capacity : Count_Type := 0) return List
- is
- C : constant Count_Type := Count_Type'Max (Source.Capacity, Capacity);
- N : Count_Type;
- P : List (C);
-
- begin
- if 0 < Capacity and then Capacity < Source.Capacity then
- raise Capacity_Error;
- end if;
-
- N := 1;
- while N <= Source.Capacity loop
- P.Nodes (N).Prev := Source.Nodes (N).Prev;
- P.Nodes (N).Next := Source.Nodes (N).Next;
- P.Nodes (N).Element := Source.Nodes (N).Element;
- N := N + 1;
- end loop;
-
- P.Free := Source.Free;
- P.Length := Source.Length;
- P.First := Source.First;
- P.Last := Source.Last;
-
- if P.Free >= 0 then
- N := Source.Capacity + 1;
- while N <= C loop
- Free (P, N);
- N := N + 1;
- end loop;
- end if;
-
- return P;
- end Copy;
-
- ------------
- -- Delete --
- ------------
-
- procedure Delete (Container : in out List; Position : in out Cursor) is
- begin
- Delete
- (Container => Container,
- Position => Position,
- Count => 1);
- end Delete;
-
- procedure Delete
- (Container : in out List;
- Position : in out Cursor;
- Count : Count_Type)
- is
- N : Node_Array renames Container.Nodes;
- X : Count_Type;
-
- begin
- if not Has_Element (Container => Container,
- Position => Position)
- then
- raise Constraint_Error with "Position cursor has no element";
- end if;
-
- pragma Assert (Vet (Container, Position), "bad cursor in Delete");
- pragma Assert (Container.First >= 1);
- pragma Assert (Container.Last >= 1);
- pragma Assert (N (Container.First).Prev = 0);
- pragma Assert (N (Container.Last).Next = 0);
-
- if Position.Node = Container.First then
- Delete_First (Container, Count);
- Position := No_Element;
- return;
- end if;
-
- if Count = 0 then
- Position := No_Element;
- return;
- end if;
-
- for Index in 1 .. Count loop
- pragma Assert (Container.Length >= 2);
-
- X := Position.Node;
- Container.Length := Container.Length - 1;
-
- if X = Container.Last then
- Position := No_Element;
-
- Container.Last := N (X).Prev;
- N (Container.Last).Next := 0;
-
- Free (Container, X);
- return;
- end if;
-
- Position.Node := N (X).Next;
- pragma Assert (N (Position.Node).Prev >= 0);
-
- N (N (X).Next).Prev := N (X).Prev;
- N (N (X).Prev).Next := N (X).Next;
-
- Free (Container, X);
- end loop;
-
- Position := No_Element;
- end Delete;
-
- ------------------
- -- Delete_First --
- ------------------
-
- procedure Delete_First (Container : in out List) is
- begin
- Delete_First
- (Container => Container,
- Count => 1);
- end Delete_First;
-
- procedure Delete_First (Container : in out List; Count : Count_Type) is
- N : Node_Array renames Container.Nodes;
- X : Count_Type;
-
- begin
- if Count >= Container.Length then
- Clear (Container);
- return;
- end if;
-
- if Count = 0 then
- return;
- end if;
-
- for J in 1 .. Count loop
- X := Container.First;
- pragma Assert (N (N (X).Next).Prev = Container.First);
-
- Container.First := N (X).Next;
- N (Container.First).Prev := 0;
-
- Container.Length := Container.Length - 1;
-
- Free (Container, X);
- end loop;
- end Delete_First;
-
- -----------------
- -- Delete_Last --
- -----------------
-
- procedure Delete_Last (Container : in out List) is
- begin
- Delete_Last
- (Container => Container,
- Count => 1);
- end Delete_Last;
-
- procedure Delete_Last (Container : in out List; Count : Count_Type) is
- N : Node_Array renames Container.Nodes;
- X : Count_Type;
-
- begin
- if Count >= Container.Length then
- Clear (Container);
- return;
- end if;
-
- if Count = 0 then
- return;
- end if;
-
- for J in 1 .. Count loop
- X := Container.Last;
- pragma Assert (N (N (X).Prev).Next = Container.Last);
-
- Container.Last := N (X).Prev;
- N (Container.Last).Next := 0;
-
- Container.Length := Container.Length - 1;
-
- Free (Container, X);
- end loop;
- end Delete_Last;
-
- -------------
- -- Element --
- -------------
-
- function Element
- (Container : List;
- Position : Cursor) return Element_Type
- is
- begin
- if not Has_Element (Container => Container, Position => Position) then
- raise Constraint_Error with "Position cursor has no element";
- end if;
-
- return Container.Nodes (Position.Node).Element;
- end Element;
-
- ----------
- -- Find --
- ----------
-
- function Find
- (Container : List;
- Item : Element_Type;
- Position : Cursor := No_Element) return Cursor
- is
- From : Count_Type := Position.Node;
-
- begin
- if From = 0 and Container.Length = 0 then
- return No_Element;
- end if;
-
- if From = 0 then
- From := Container.First;
- end if;
-
- if Position.Node /= 0 and then not Has_Element (Container, Position) then
- raise Constraint_Error with "Position cursor has no element";
- end if;
-
- while From /= 0 loop
- if Container.Nodes (From).Element = Item then
- return (Node => From);
- end if;
-
- From := Container.Nodes (From).Next;
- end loop;
-
- return No_Element;
- end Find;
-
- -----------
- -- First --
- -----------
-
- function First (Container : List) return Cursor is
- begin
- if Container.First = 0 then
- return No_Element;
- end if;
-
- return (Node => Container.First);
- end First;
-
- -------------------
- -- First_Element --
- -------------------
-
- function First_Element (Container : List) return Element_Type is
- F : constant Count_Type := Container.First;
-
- begin
- if F = 0 then
- raise Constraint_Error with "list is empty";
- else
- return Container.Nodes (F).Element;
- end if;
- end First_Element;
-
- ------------------
- -- Formal_Model --
- ------------------
-
- package body Formal_Model is
-
- ----------------------------
- -- Lift_Abstraction_Level --
- ----------------------------
-
- procedure Lift_Abstraction_Level (Container : List) is null;
-
- -------------------------
- -- M_Elements_In_Union --
- -------------------------
-
- function M_Elements_In_Union
- (Container : M.Sequence;
- Left : M.Sequence;
- Right : M.Sequence) return Boolean
- is
- Elem : Element_Type;
-
- begin
- for Index in 1 .. M.Length (Container) loop
- Elem := Element (Container, Index);
-
- if not M.Contains (Left, 1, M.Length (Left), Elem)
- and then not M.Contains (Right, 1, M.Length (Right), Elem)
- then
- return False;
- end if;
- end loop;
-
- return True;
- end M_Elements_In_Union;
-
- -------------------------
- -- M_Elements_Included --
- -------------------------
-
- function M_Elements_Included
- (Left : M.Sequence;
- L_Fst : Positive_Count_Type := 1;
- L_Lst : Count_Type;
- Right : M.Sequence;
- R_Fst : Positive_Count_Type := 1;
- R_Lst : Count_Type) return Boolean
- is
- begin
- for I in L_Fst .. L_Lst loop
- declare
- Found : Boolean := False;
- J : Count_Type := R_Fst - 1;
-
- begin
- while not Found and J < R_Lst loop
- J := J + 1;
- if Element (Left, I) = Element (Right, J) then
- Found := True;
- end if;
- end loop;
-
- if not Found then
- return False;
- end if;
- end;
- end loop;
-
- return True;
- end M_Elements_Included;
-
- -------------------------
- -- M_Elements_Reversed --
- -------------------------
-
- function M_Elements_Reversed
- (Left : M.Sequence;
- Right : M.Sequence) return Boolean
- is
- L : constant Count_Type := M.Length (Left);
-
- begin
- if L /= M.Length (Right) then
- return False;
- end if;
-
- for I in 1 .. L loop
- if Element (Left, I) /= Element (Right, L - I + 1) then
- return False;
- end if;
- end loop;
-
- return True;
- end M_Elements_Reversed;
-
- ------------------------
- -- M_Elements_Swapped --
- ------------------------
-
- function M_Elements_Swapped
- (Left : M.Sequence;
- Right : M.Sequence;
- X : Positive_Count_Type;
- Y : Positive_Count_Type) return Boolean
- is
- begin
- if M.Length (Left) /= M.Length (Right)
- or else Element (Left, X) /= Element (Right, Y)
- or else Element (Left, Y) /= Element (Right, X)
- then
- return False;
- end if;
-
- for I in 1 .. M.Length (Left) loop
- if I /= X and then I /= Y
- and then Element (Left, I) /= Element (Right, I)
- then
- return False;
- end if;
- end loop;
-
- return True;
- end M_Elements_Swapped;
-
- -----------
- -- Model --
- -----------
-
- function Model (Container : List) return M.Sequence is
- Position : Count_Type := Container.First;
- R : M.Sequence;
-
- begin
- -- Can't use First, Next or Element here, since they depend on models
- -- for their postconditions.
-
- while Position /= 0 loop
- R := M.Add (R, Container.Nodes (Position).Element);
- Position := Container.Nodes (Position).Next;
- end loop;
-
- return R;
- end Model;
-
- -----------------------
- -- Mapping_Preserved --
- -----------------------
-
- function Mapping_Preserved
- (M_Left : M.Sequence;
- M_Right : M.Sequence;
- P_Left : P.Map;
- P_Right : P.Map) return Boolean
- is
- begin
- for C of P_Left loop
- if not P.Has_Key (P_Right, C)
- or else P.Get (P_Left, C) > M.Length (M_Left)
- or else P.Get (P_Right, C) > M.Length (M_Right)
- or else M.Get (M_Left, P.Get (P_Left, C)) /=
- M.Get (M_Right, P.Get (P_Right, C))
- then
- return False;
- end if;
- end loop;
-
- for C of P_Right loop
- if not P.Has_Key (P_Left, C) then
- return False;
- end if;
- end loop;
-
- return True;
- end Mapping_Preserved;
-
- -------------------------
- -- P_Positions_Shifted --
- -------------------------
-
- function P_Positions_Shifted
- (Small : P.Map;
- Big : P.Map;
- Cut : Positive_Count_Type;
- Count : Count_Type := 1) return Boolean
- is
- begin
- for Cu of Small loop
- if not P.Has_Key (Big, Cu) then
- return False;
- end if;
- end loop;
-
- for Cu of Big loop
- declare
- Pos : constant Positive_Count_Type := P.Get (Big, Cu);
-
- begin
- if Pos < Cut then
- if not P.Has_Key (Small, Cu)
- or else Pos /= P.Get (Small, Cu)
- then
- return False;
- end if;
-
- elsif Pos >= Cut + Count then
- if not P.Has_Key (Small, Cu)
- or else Pos /= P.Get (Small, Cu) + Count
- then
- return False;
- end if;
-
- else
- if P.Has_Key (Small, Cu) then
- return False;
- end if;
- end if;
- end;
- end loop;
-
- return True;
- end P_Positions_Shifted;
-
- -------------------------
- -- P_Positions_Swapped --
- -------------------------
-
- function P_Positions_Swapped
- (Left : P.Map;
- Right : P.Map;
- X : Cursor;
- Y : Cursor) return Boolean
- is
- begin
- if not P.Has_Key (Left, X)
- or not P.Has_Key (Left, Y)
- or not P.Has_Key (Right, X)
- or not P.Has_Key (Right, Y)
- then
- return False;
- end if;
-
- if P.Get (Left, X) /= P.Get (Right, Y)
- or P.Get (Left, Y) /= P.Get (Right, X)
- then
- return False;
- end if;
-
- for C of Left loop
- if not P.Has_Key (Right, C) then
- return False;
- end if;
- end loop;
-
- for C of Right loop
- if not P.Has_Key (Left, C)
- or else (C /= X
- and C /= Y
- and P.Get (Left, C) /= P.Get (Right, C))
- then
- return False;
- end if;
- end loop;
-
- return True;
- end P_Positions_Swapped;
-
- ---------------------------
- -- P_Positions_Truncated --
- ---------------------------
-
- function P_Positions_Truncated
- (Small : P.Map;
- Big : P.Map;
- Cut : Positive_Count_Type;
- Count : Count_Type := 1) return Boolean
- is
- begin
- for Cu of Small loop
- if not P.Has_Key (Big, Cu) then
- return False;
- end if;
- end loop;
-
- for Cu of Big loop
- declare
- Pos : constant Positive_Count_Type := P.Get (Big, Cu);
-
- begin
- if Pos < Cut then
- if not P.Has_Key (Small, Cu)
- or else Pos /= P.Get (Small, Cu)
- then
- return False;
- end if;
-
- elsif Pos >= Cut + Count then
- return False;
-
- elsif P.Has_Key (Small, Cu) then
- return False;
- end if;
- end;
- end loop;
-
- return True;
- end P_Positions_Truncated;
-
- ---------------
- -- Positions --
- ---------------
-
- function Positions (Container : List) return P.Map is
- I : Count_Type := 1;
- Position : Count_Type := Container.First;
- R : P.Map;
-
- begin
- -- Can't use First, Next or Element here, since they depend on models
- -- for their postconditions.
-
- while Position /= 0 loop
- R := P.Add (R, (Node => Position), I);
- pragma Assert (P.Length (R) = To_Big_Integer (I));
- Position := Container.Nodes (Position).Next;
- I := I + 1;
- end loop;
-
- return R;
- end Positions;
-
- end Formal_Model;
-
- ----------
- -- Free --
- ----------
-
- procedure Free (Container : in out List; X : Count_Type) is
- pragma Assert (X > 0);
- pragma Assert (X <= Container.Capacity);
-
- N : Node_Array renames Container.Nodes;
-
- begin
- N (X).Prev := -1; -- Node is deallocated (not on active list)
-
- if Container.Free >= 0 then
- N (X).Next := Container.Free;
- Container.Free := X;
-
- elsif X + 1 = abs Container.Free then
- N (X).Next := 0; -- Not strictly necessary, but marginally safer
- Container.Free := Container.Free + 1;
-
- else
- Container.Free := abs Container.Free;
-
- if Container.Free > Container.Capacity then
- Container.Free := 0;
-
- else
- for J in Container.Free .. Container.Capacity - 1 loop
- N (J).Next := J + 1;
- end loop;
-
- N (Container.Capacity).Next := 0;
- end if;
-
- N (X).Next := Container.Free;
- Container.Free := X;
- end if;
- end Free;
-
- ---------------------
- -- Generic_Sorting --
- ---------------------
-
- package body Generic_Sorting with SPARK_Mode => Off is
-
- ------------------
- -- Formal_Model --
- ------------------
-
- package body Formal_Model is
-
- -----------------------
- -- M_Elements_Sorted --
- -----------------------
-
- function M_Elements_Sorted (Container : M.Sequence) return Boolean is
- begin
- if M.Length (Container) = 0 then
- return True;
- end if;
-
- declare
- E1 : Element_Type := Element (Container, 1);
-
- begin
- for I in 2 .. M.Length (Container) loop
- declare
- E2 : constant Element_Type := Element (Container, I);
-
- begin
- if E2 < E1 then
- return False;
- end if;
-
- E1 := E2;
- end;
- end loop;
- end;
-
- return True;
- end M_Elements_Sorted;
-
- end Formal_Model;
-
- ---------------
- -- Is_Sorted --
- ---------------
-
- function Is_Sorted (Container : List) return Boolean is
- Nodes : Node_Array renames Container.Nodes;
- Node : Count_Type := Container.First;
-
- begin
- for J in 2 .. Container.Length loop
- if Nodes (Nodes (Node).Next).Element < Nodes (Node).Element then
- return False;
- else
- Node := Nodes (Node).Next;
- end if;
- end loop;
-
- return True;
- end Is_Sorted;
-
- -----------
- -- Merge --
- -----------
-
- procedure Merge (Target : in out List; Source : in out List) is
- LN : Node_Array renames Target.Nodes;
- RN : Node_Array renames Source.Nodes;
- LI : Cursor;
- RI : Cursor;
-
- begin
- if Target'Address = Source'Address then
- raise Program_Error with "Target and Source denote same container";
- end if;
-
- LI := First (Target);
- RI := First (Source);
- while RI.Node /= 0 loop
- pragma Assert
- (RN (RI.Node).Next = 0
- or else not (RN (RN (RI.Node).Next).Element <
- RN (RI.Node).Element));
-
- if LI.Node = 0 then
- Splice (Target, No_Element, Source);
- return;
- end if;
-
- pragma Assert
- (LN (LI.Node).Next = 0
- or else not (LN (LN (LI.Node).Next).Element <
- LN (LI.Node).Element));
-
- if RN (RI.Node).Element < LN (LI.Node).Element then
- declare
- RJ : Cursor := RI;
- pragma Warnings (Off, RJ);
- begin
- RI.Node := RN (RI.Node).Next;
- Splice (Target, LI, Source, RJ);
- end;
-
- else
- LI.Node := LN (LI.Node).Next;
- end if;
- end loop;
- end Merge;
-
- ----------
- -- Sort --
- ----------
-
- procedure Sort (Container : in out List) is
- N : Node_Array renames Container.Nodes;
- begin
- if Container.Length <= 1 then
- return;
- end if;
-
- pragma Assert (N (Container.First).Prev = 0);
- pragma Assert (N (Container.Last).Next = 0);
-
- declare
- package Descriptors is new List_Descriptors
- (Node_Ref => Count_Type, Nil => 0);
- use Descriptors;
-
- function Next (Idx : Count_Type) return Count_Type is
- (N (Idx).Next);
- procedure Set_Next (Idx : Count_Type; Next : Count_Type)
- with Inline;
- procedure Set_Prev (Idx : Count_Type; Prev : Count_Type)
- with Inline;
- function "<" (L, R : Count_Type) return Boolean is
- (N (L).Element < N (R).Element);
- procedure Update_Container (List : List_Descriptor) with Inline;
-
- procedure Set_Next (Idx : Count_Type; Next : Count_Type) is
- begin
- N (Idx).Next := Next;
- end Set_Next;
-
- procedure Set_Prev (Idx : Count_Type; Prev : Count_Type) is
- begin
- N (Idx).Prev := Prev;
- end Set_Prev;
-
- procedure Update_Container (List : List_Descriptor) is
- begin
- Container.First := List.First;
- Container.Last := List.Last;
- Container.Length := List.Length;
- end Update_Container;
-
- procedure Sort_List is new Doubly_Linked_List_Sort;
- begin
- Sort_List (List_Descriptor'(First => Container.First,
- Last => Container.Last,
- Length => Container.Length));
- end;
-
- pragma Assert (N (Container.First).Prev = 0);
- pragma Assert (N (Container.Last).Next = 0);
- end Sort;
-
- end Generic_Sorting;
-
- -----------------
- -- Has_Element --
- -----------------
-
- function Has_Element (Container : List; Position : Cursor) return Boolean is
- begin
- if Position.Node = 0 then
- return False;
- end if;
-
- return Container.Nodes (Position.Node).Prev /= -1;
- end Has_Element;
-
- ------------
- -- Insert --
- ------------
-
- procedure Insert
- (Container : in out List;
- Before : Cursor;
- New_Item : Element_Type;
- Position : out Cursor;
- Count : Count_Type)
- is
- J : Count_Type;
-
- begin
- if Before.Node /= 0 then
- pragma Assert (Vet (Container, Before), "bad cursor in Insert");
- end if;
-
- if Count = 0 then
- Position := Before;
- return;
- end if;
-
- if Container.Length > Container.Capacity - Count then
- raise Constraint_Error with "new length exceeds capacity";
- end if;
-
- Allocate (Container, New_Item, New_Node => J);
- Insert_Internal (Container, Before.Node, New_Node => J);
- Position := (Node => J);
-
- for Index in 2 .. Count loop
- Allocate (Container, New_Item, New_Node => J);
- Insert_Internal (Container, Before.Node, New_Node => J);
- end loop;
- end Insert;
-
- procedure Insert
- (Container : in out List;
- Before : Cursor;
- New_Item : Element_Type;
- Position : out Cursor)
- is
- begin
- Insert
- (Container => Container,
- Before => Before,
- New_Item => New_Item,
- Position => Position,
- Count => 1);
- end Insert;
-
- procedure Insert
- (Container : in out List;
- Before : Cursor;
- New_Item : Element_Type;
- Count : Count_Type)
- is
- Position : Cursor;
-
- begin
- Insert (Container, Before, New_Item, Position, Count);
- end Insert;
-
- procedure Insert
- (Container : in out List;
- Before : Cursor;
- New_Item : Element_Type)
- is
- Position : Cursor;
-
- begin
- Insert (Container, Before, New_Item, Position, 1);
- end Insert;
-
- ---------------------
- -- Insert_Internal --
- ---------------------
-
- procedure Insert_Internal
- (Container : in out List;
- Before : Count_Type;
- New_Node : Count_Type)
- is
- N : Node_Array renames Container.Nodes;
-
- begin
- if Container.Length = 0 then
- pragma Assert (Before = 0);
- pragma Assert (Container.First = 0);
- pragma Assert (Container.Last = 0);
-
- Container.First := New_Node;
- Container.Last := New_Node;
-
- N (Container.First).Prev := 0;
- N (Container.Last).Next := 0;
-
- elsif Before = 0 then
- pragma Assert (N (Container.Last).Next = 0);
-
- N (Container.Last).Next := New_Node;
- N (New_Node).Prev := Container.Last;
-
- Container.Last := New_Node;
- N (Container.Last).Next := 0;
-
- elsif Before = Container.First then
- pragma Assert (N (Container.First).Prev = 0);
-
- N (Container.First).Prev := New_Node;
- N (New_Node).Next := Container.First;
-
- Container.First := New_Node;
- N (Container.First).Prev := 0;
-
- else
- pragma Assert (N (Container.First).Prev = 0);
- pragma Assert (N (Container.Last).Next = 0);
-
- N (New_Node).Next := Before;
- N (New_Node).Prev := N (Before).Prev;
-
- N (N (Before).Prev).Next := New_Node;
- N (Before).Prev := New_Node;
- end if;
-
- Container.Length := Container.Length + 1;
- end Insert_Internal;
-
- --------------
- -- Is_Empty --
- --------------
-
- function Is_Empty (Container : List) return Boolean is
- begin
- return Length (Container) = 0;
- end Is_Empty;
-
- ----------
- -- Last --
- ----------
-
- function Last (Container : List) return Cursor is
- begin
- if Container.Last = 0 then
- return No_Element;
- end if;
-
- return (Node => Container.Last);
- end Last;
-
- ------------------
- -- Last_Element --
- ------------------
-
- function Last_Element (Container : List) return Element_Type is
- L : constant Count_Type := Container.Last;
-
- begin
- if L = 0 then
- raise Constraint_Error with "list is empty";
- else
- return Container.Nodes (L).Element;
- end if;
- end Last_Element;
-
- ------------
- -- Length --
- ------------
-
- function Length (Container : List) return Count_Type is
- begin
- return Container.Length;
- end Length;
-
- ----------
- -- Move --
- ----------
-
- procedure Move (Target : in out List; Source : in out List) is
- N : Node_Array renames Source.Nodes;
- X : Count_Type;
-
- begin
- if Target'Address = Source'Address then
- return;
- end if;
-
- if Target.Capacity < Source.Length then
- raise Constraint_Error with -- ???
- "Source length exceeds Target capacity";
- end if;
-
- Clear (Target);
-
- while Source.Length > 1 loop
- pragma Assert (Source.First in 1 .. Source.Capacity);
- pragma Assert (Source.Last /= Source.First);
- pragma Assert (N (Source.First).Prev = 0);
- pragma Assert (N (Source.Last).Next = 0);
-
- -- Copy first element from Source to Target
-
- X := Source.First;
- Append (Target, N (X).Element); -- optimize away???
-
- -- Unlink first node of Source
-
- Source.First := N (X).Next;
- N (Source.First).Prev := 0;
-
- Source.Length := Source.Length - 1;
-
- -- The representation invariants for Source have been restored. It is
- -- now safe to free the unlinked node, without fear of corrupting the
- -- active links of Source.
-
- -- Note that the algorithm we use here models similar algorithms used
- -- in the unbounded form of the doubly-linked list container. In that
- -- case, Free is an instantation of Unchecked_Deallocation, which can
- -- fail (because PE will be raised if controlled Finalize fails), so
- -- we must defer the call until the last step. Here in the bounded
- -- form, Free merely links the node we have just "deallocated" onto a
- -- list of inactive nodes, so technically Free cannot fail. However,
- -- for consistency, we handle Free the same way here as we do for the
- -- unbounded form, with the pessimistic assumption that it can fail.
-
- Free (Source, X);
- end loop;
-
- if Source.Length = 1 then
- pragma Assert (Source.First in 1 .. Source.Capacity);
- pragma Assert (Source.Last = Source.First);
- pragma Assert (N (Source.First).Prev = 0);
- pragma Assert (N (Source.Last).Next = 0);
-
- -- Copy element from Source to Target
-
- X := Source.First;
- Append (Target, N (X).Element);
-
- -- Unlink node of Source
-
- Source.First := 0;
- Source.Last := 0;
- Source.Length := 0;
-
- -- Return the unlinked node to the free store
-
- Free (Source, X);
- end if;
- end Move;
-
- ----------
- -- Next --
- ----------
-
- procedure Next (Container : List; Position : in out Cursor) is
- begin
- Position := Next (Container, Position);
- end Next;
-
- function Next (Container : List; Position : Cursor) return Cursor is
- begin
- if Position.Node = 0 then
- return No_Element;
- end if;
-
- if not Has_Element (Container, Position) then
- raise Program_Error with "Position cursor has no element";
- end if;
-
- return (Node => Container.Nodes (Position.Node).Next);
- end Next;
-
- -------------
- -- Prepend --
- -------------
-
- procedure Prepend (Container : in out List; New_Item : Element_Type) is
- begin
- Insert (Container, First (Container), New_Item, 1);
- end Prepend;
-
- procedure Prepend
- (Container : in out List;
- New_Item : Element_Type;
- Count : Count_Type)
- is
- begin
- Insert (Container, First (Container), New_Item, Count);
- end Prepend;
-
- --------------
- -- Previous --
- --------------
-
- procedure Previous (Container : List; Position : in out Cursor) is
- begin
- Position := Previous (Container, Position);
- end Previous;
-
- function Previous (Container : List; Position : Cursor) return Cursor is
- begin
- if Position.Node = 0 then
- return No_Element;
- end if;
-
- if not Has_Element (Container, Position) then
- raise Program_Error with "Position cursor has no element";
- end if;
-
- return (Node => Container.Nodes (Position.Node).Prev);
- end Previous;
-
- ---------------
- -- Reference --
- ---------------
-
- function Reference
- (Container : not null access List;
- Position : Cursor) return not null access Element_Type
- is
- begin
- if not Has_Element (Container.all, Position) then
- raise Constraint_Error with "Position cursor has no element";
- end if;
-
- return Container.Nodes (Position.Node).Element'Access;
- end Reference;
-
- ---------------------
- -- Replace_Element --
- ---------------------
-
- procedure Replace_Element
- (Container : in out List;
- Position : Cursor;
- New_Item : Element_Type)
- is
- begin
- if not Has_Element (Container, Position) then
- raise Constraint_Error with "Position cursor has no element";
- end if;
-
- pragma Assert
- (Vet (Container, Position), "bad cursor in Replace_Element");
-
- Container.Nodes (Position.Node).Element := New_Item;
- end Replace_Element;
-
- ----------------------
- -- Reverse_Elements --
- ----------------------
-
- procedure Reverse_Elements (Container : in out List) is
- N : Node_Array renames Container.Nodes;
- I : Count_Type := Container.First;
- J : Count_Type := Container.Last;
-
- procedure Swap (L : Count_Type; R : Count_Type);
-
- ----------
- -- Swap --
- ----------
-
- procedure Swap (L : Count_Type; R : Count_Type) is
- LN : constant Count_Type := N (L).Next;
- LP : constant Count_Type := N (L).Prev;
-
- RN : constant Count_Type := N (R).Next;
- RP : constant Count_Type := N (R).Prev;
-
- begin
- if LP /= 0 then
- N (LP).Next := R;
- end if;
-
- if RN /= 0 then
- N (RN).Prev := L;
- end if;
-
- N (L).Next := RN;
- N (R).Prev := LP;
-
- if LN = R then
- pragma Assert (RP = L);
-
- N (L).Prev := R;
- N (R).Next := L;
-
- else
- N (L).Prev := RP;
- N (RP).Next := L;
-
- N (R).Next := LN;
- N (LN).Prev := R;
- end if;
- end Swap;
-
- -- Start of processing for Reverse_Elements
-
- begin
- if Container.Length <= 1 then
- return;
- end if;
-
- pragma Assert (N (Container.First).Prev = 0);
- pragma Assert (N (Container.Last).Next = 0);
-
- Container.First := J;
- Container.Last := I;
- loop
- Swap (L => I, R => J);
-
- J := N (J).Next;
- exit when I = J;
-
- I := N (I).Prev;
- exit when I = J;
-
- Swap (L => J, R => I);
-
- I := N (I).Next;
- exit when I = J;
-
- J := N (J).Prev;
- exit when I = J;
- end loop;
-
- pragma Assert (N (Container.First).Prev = 0);
- pragma Assert (N (Container.Last).Next = 0);
- end Reverse_Elements;
-
- ------------------
- -- Reverse_Find --
- ------------------
-
- function Reverse_Find
- (Container : List;
- Item : Element_Type;
- Position : Cursor := No_Element) return Cursor
- is
- CFirst : Count_Type := Position.Node;
-
- begin
- if CFirst = 0 then
- CFirst := Container.Last;
- end if;
-
- if Container.Length = 0 then
- return No_Element;
-
- else
- while CFirst /= 0 loop
- if Container.Nodes (CFirst).Element = Item then
- return (Node => CFirst);
- else
- CFirst := Container.Nodes (CFirst).Prev;
- end if;
- end loop;
-
- return No_Element;
- end if;
- end Reverse_Find;
-
- ------------
- -- Splice --
- ------------
-
- procedure Splice
- (Target : in out List;
- Before : Cursor;
- Source : in out List)
- is
- SN : Node_Array renames Source.Nodes;
-
- begin
- if Target'Address = Source'Address then
- raise Program_Error with "Target and Source denote same container";
- end if;
-
- if Before.Node /= 0 then
- pragma Assert (Vet (Target, Before), "bad cursor in Splice");
- end if;
-
- pragma Assert (SN (Source.First).Prev = 0);
- pragma Assert (SN (Source.Last).Next = 0);
-
- if Target.Length > Count_Type'Base'Last - Source.Length then
- raise Constraint_Error with "new length exceeds maximum";
- end if;
-
- if Target.Length + Source.Length > Target.Capacity then
- raise Constraint_Error;
- end if;
-
- loop
- Insert (Target, Before, SN (Source.Last).Element);
- Delete_Last (Source);
- exit when Is_Empty (Source);
- end loop;
- end Splice;
-
- procedure Splice
- (Target : in out List;
- Before : Cursor;
- Source : in out List;
- Position : in out Cursor)
- is
- Target_Position : Cursor;
-
- begin
- if Target'Address = Source'Address then
- raise Program_Error with "Target and Source denote same container";
- end if;
-
- if Position.Node = 0 then
- raise Constraint_Error with "Position cursor has no element";
- end if;
-
- pragma Assert (Vet (Source, Position), "bad Position cursor in Splice");
-
- if Target.Length >= Target.Capacity then
- raise Constraint_Error;
- end if;
-
- Insert
- (Container => Target,
- Before => Before,
- New_Item => Source.Nodes (Position.Node).Element,
- Position => Target_Position);
-
- Delete (Source, Position);
- Position := Target_Position;
- end Splice;
-
- procedure Splice
- (Container : in out List;
- Before : Cursor;
- Position : Cursor)
- is
- N : Node_Array renames Container.Nodes;
-
- begin
- if Before.Node /= 0 then
- pragma Assert
- (Vet (Container, Before), "bad Before cursor in Splice");
- end if;
-
- if Position.Node = 0 then
- raise Constraint_Error with "Position cursor has no element";
- end if;
-
- pragma Assert
- (Vet (Container, Position), "bad Position cursor in Splice");
-
- if Position.Node = Before.Node
- or else N (Position.Node).Next = Before.Node
- then
- return;
- end if;
-
- pragma Assert (Container.Length >= 2);
-
- if Before.Node = 0 then
- pragma Assert (Position.Node /= Container.Last);
-
- if Position.Node = Container.First then
- Container.First := N (Position.Node).Next;
- N (Container.First).Prev := 0;
-
- else
- N (N (Position.Node).Prev).Next := N (Position.Node).Next;
- N (N (Position.Node).Next).Prev := N (Position.Node).Prev;
- end if;
-
- N (Container.Last).Next := Position.Node;
- N (Position.Node).Prev := Container.Last;
-
- Container.Last := Position.Node;
- N (Container.Last).Next := 0;
-
- return;
- end if;
-
- if Before.Node = Container.First then
- pragma Assert (Position.Node /= Container.First);
-
- if Position.Node = Container.Last then
- Container.Last := N (Position.Node).Prev;
- N (Container.Last).Next := 0;
-
- else
- N (N (Position.Node).Prev).Next := N (Position.Node).Next;
- N (N (Position.Node).Next).Prev := N (Position.Node).Prev;
- end if;
-
- N (Container.First).Prev := Position.Node;
- N (Position.Node).Next := Container.First;
-
- Container.First := Position.Node;
- N (Container.First).Prev := 0;
-
- return;
- end if;
-
- if Position.Node = Container.First then
- Container.First := N (Position.Node).Next;
- N (Container.First).Prev := 0;
-
- elsif Position.Node = Container.Last then
- Container.Last := N (Position.Node).Prev;
- N (Container.Last).Next := 0;
-
- else
- N (N (Position.Node).Prev).Next := N (Position.Node).Next;
- N (N (Position.Node).Next).Prev := N (Position.Node).Prev;
- end if;
-
- N (N (Before.Node).Prev).Next := Position.Node;
- N (Position.Node).Prev := N (Before.Node).Prev;
-
- N (Before.Node).Prev := Position.Node;
- N (Position.Node).Next := Before.Node;
-
- pragma Assert (N (Container.First).Prev = 0);
- pragma Assert (N (Container.Last).Next = 0);
- end Splice;
-
- ----------
- -- Swap --
- ----------
-
- procedure Swap
- (Container : in out List;
- I : Cursor;
- J : Cursor)
- is
- begin
- if I.Node = 0 then
- raise Constraint_Error with "I cursor has no element";
- end if;
-
- if J.Node = 0 then
- raise Constraint_Error with "J cursor has no element";
- end if;
-
- if I.Node = J.Node then
- return;
- end if;
-
- pragma Assert (Vet (Container, I), "bad I cursor in Swap");
- pragma Assert (Vet (Container, J), "bad J cursor in Swap");
-
- declare
- NN : Node_Array renames Container.Nodes;
- NI : Node_Type renames NN (I.Node);
- NJ : Node_Type renames NN (J.Node);
-
- EI_Copy : constant Element_Type := NI.Element;
-
- begin
- NI.Element := NJ.Element;
- NJ.Element := EI_Copy;
- end;
- end Swap;
-
- ----------------
- -- Swap_Links --
- ----------------
-
- procedure Swap_Links
- (Container : in out List;
- I : Cursor;
- J : Cursor)
- is
- I_Next : Cursor;
- J_Next : Cursor;
-
- begin
- if I.Node = 0 then
- raise Constraint_Error with "I cursor has no element";
- end if;
-
- if J.Node = 0 then
- raise Constraint_Error with "J cursor has no element";
- end if;
-
- if I.Node = J.Node then
- return;
- end if;
-
- pragma Assert (Vet (Container, I), "bad I cursor in Swap_Links");
- pragma Assert (Vet (Container, J), "bad J cursor in Swap_Links");
-
- I_Next := Next (Container, I);
-
- if I_Next = J then
- Splice (Container, Before => I, Position => J);
-
- else
- J_Next := Next (Container, J);
-
- if J_Next = I then
- Splice (Container, Before => J, Position => I);
-
- else
- pragma Assert (Container.Length >= 3);
- Splice (Container, Before => I_Next, Position => J);
- Splice (Container, Before => J_Next, Position => I);
- end if;
- end if;
- end Swap_Links;
-
- ---------
- -- Vet --
- ---------
-
- function Vet (L : List; Position : Cursor) return Boolean is
- N : Node_Array renames L.Nodes;
- begin
- if not Container_Checks'Enabled then
- return True;
- end if;
-
- if L.Length = 0 then
- return False;
- end if;
-
- if L.First = 0 then
- return False;
- end if;
-
- if L.Last = 0 then
- return False;
- end if;
-
- if Position.Node > L.Capacity then
- return False;
- end if;
-
- if N (Position.Node).Prev < 0
- or else N (Position.Node).Prev > L.Capacity
- then
- return False;
- end if;
-
- if N (Position.Node).Next > L.Capacity then
- return False;
- end if;
-
- if N (L.First).Prev /= 0 then
- return False;
- end if;
-
- if N (L.Last).Next /= 0 then
- return False;
- end if;
-
- if N (Position.Node).Prev = 0 and then Position.Node /= L.First then
- return False;
- end if;
-
- if N (Position.Node).Next = 0 and then Position.Node /= L.Last then
- return False;
- end if;
-
- if L.Length = 1 then
- return L.First = L.Last;
- end if;
-
- if L.First = L.Last then
- return False;
- end if;
-
- if N (L.First).Next = 0 then
- return False;
- end if;
-
- if N (L.Last).Prev = 0 then
- return False;
- end if;
-
- if N (N (L.First).Next).Prev /= L.First then
- return False;
- end if;
-
- if N (N (L.Last).Prev).Next /= L.Last then
- return False;
- end if;
-
- if L.Length = 2 then
- if N (L.First).Next /= L.Last then
- return False;
- end if;
-
- if N (L.Last).Prev /= L.First then
- return False;
- end if;
-
- return True;
- end if;
-
- if N (L.First).Next = L.Last then
- return False;
- end if;
-
- if N (L.Last).Prev = L.First then
- return False;
- end if;
-
- if Position.Node = L.First then
- return True;
- end if;
-
- if Position.Node = L.Last then
- return True;
- end if;
-
- if N (Position.Node).Next = 0 then
- return False;
- end if;
-
- if N (Position.Node).Prev = 0 then
- return False;
- end if;
-
- if N (N (Position.Node).Next).Prev /= Position.Node then
- return False;
- end if;
-
- if N (N (Position.Node).Prev).Next /= Position.Node then
- return False;
- end if;
-
- if L.Length = 3 then
- if N (L.First).Next /= Position.Node then
- return False;
- end if;
-
- if N (L.Last).Prev /= Position.Node then
- return False;
- end if;
- end if;
-
- return True;
- end Vet;
-
-end Ada.Containers.Formal_Doubly_Linked_Lists;
diff --git a/gcc/ada/libgnat/a-cfdlli.ads b/gcc/ada/libgnat/a-cfdlli.ads
index 01e7db2..3a53ca5 100644
--- a/gcc/ada/libgnat/a-cfdlli.ads
+++ b/gcc/ada/libgnat/a-cfdlli.ads
@@ -29,1643 +29,12 @@
-- <http://www.gnu.org/licenses/>. --
------------------------------------------------------------------------------
-with Ada.Containers.Functional_Vectors;
-with Ada.Containers.Functional_Maps;
-
generic
- type Element_Type is private;
- with function "=" (Left, Right : Element_Type) return Boolean is <>;
-
-package Ada.Containers.Formal_Doubly_Linked_Lists with
- SPARK_Mode,
- Annotate => (GNATprove, Always_Return)
-is
-
- -- Contracts in this unit are meant for analysis only, not for run-time
- -- checking.
-
- pragma Assertion_Policy (Pre => Ignore);
- pragma Assertion_Policy (Post => Ignore);
- pragma Assertion_Policy (Contract_Cases => Ignore);
- pragma Annotate (CodePeer, Skip_Analysis);
-
- type List (Capacity : Count_Type) is private with
- Iterable => (First => First,
- Next => Next,
- Has_Element => Has_Element,
- Element => Element),
- Default_Initial_Condition => Is_Empty (List);
- pragma Preelaborable_Initialization (List);
-
- type Cursor is record
- Node : Count_Type := 0;
- end record;
-
- No_Element : constant Cursor := Cursor'(Node => 0);
-
- Empty_List : constant List;
-
- function Length (Container : List) return Count_Type with
- Global => null,
- Post => Length'Result <= Container.Capacity;
-
- pragma Unevaluated_Use_Of_Old (Allow);
-
- package Formal_Model with Ghost is
- subtype Positive_Count_Type is Count_Type range 1 .. Count_Type'Last;
-
- package M is new Ada.Containers.Functional_Vectors
- (Index_Type => Positive_Count_Type,
- Element_Type => Element_Type);
-
- function "="
- (Left : M.Sequence;
- Right : M.Sequence) return Boolean renames M."=";
-
- function "<"
- (Left : M.Sequence;
- Right : M.Sequence) return Boolean renames M."<";
-
- function "<="
- (Left : M.Sequence;
- Right : M.Sequence) return Boolean renames M."<=";
-
- function M_Elements_In_Union
- (Container : M.Sequence;
- Left : M.Sequence;
- Right : M.Sequence) return Boolean
- -- The elements of Container are contained in either Left or Right
- with
- Global => null,
- Post =>
- M_Elements_In_Union'Result =
- (for all I in 1 .. M.Length (Container) =>
- (for some J in 1 .. M.Length (Left) =>
- Element (Container, I) = Element (Left, J))
- or (for some J in 1 .. M.Length (Right) =>
- Element (Container, I) = Element (Right, J)));
- pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_In_Union);
-
- function M_Elements_Included
- (Left : M.Sequence;
- L_Fst : Positive_Count_Type := 1;
- L_Lst : Count_Type;
- Right : M.Sequence;
- R_Fst : Positive_Count_Type := 1;
- R_Lst : Count_Type) return Boolean
- -- The elements of the slice from L_Fst to L_Lst in Left are contained
- -- in the slide from R_Fst to R_Lst in Right.
- with
- Global => null,
- Pre => L_Lst <= M.Length (Left) and R_Lst <= M.Length (Right),
- Post =>
- M_Elements_Included'Result =
- (for all I in L_Fst .. L_Lst =>
- (for some J in R_Fst .. R_Lst =>
- Element (Left, I) = Element (Right, J)));
- pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_Included);
-
- function M_Elements_Reversed
- (Left : M.Sequence;
- Right : M.Sequence) return Boolean
- -- Right is Left in reverse order
- with
- Global => null,
- Post =>
- M_Elements_Reversed'Result =
- (M.Length (Left) = M.Length (Right)
- and (for all I in 1 .. M.Length (Left) =>
- Element (Left, I) =
- Element (Right, M.Length (Left) - I + 1))
- and (for all I in 1 .. M.Length (Left) =>
- Element (Right, I) =
- Element (Left, M.Length (Left) - I + 1)));
- pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_Reversed);
-
- function M_Elements_Swapped
- (Left : M.Sequence;
- Right : M.Sequence;
- X : Positive_Count_Type;
- Y : Positive_Count_Type) return Boolean
- -- Elements stored at X and Y are reversed in Left and Right
- with
- Global => null,
- Pre => X <= M.Length (Left) and Y <= M.Length (Left),
- Post =>
- M_Elements_Swapped'Result =
- (M.Length (Left) = M.Length (Right)
- and Element (Left, X) = Element (Right, Y)
- and Element (Left, Y) = Element (Right, X)
- and M.Equal_Except (Left, Right, X, Y));
- pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_Swapped);
-
- package P is new Ada.Containers.Functional_Maps
- (Key_Type => Cursor,
- Element_Type => Positive_Count_Type,
- Equivalent_Keys => "=",
- Enable_Handling_Of_Equivalence => False);
-
- function "="
- (Left : P.Map;
- Right : P.Map) return Boolean renames P."=";
-
- function "<="
- (Left : P.Map;
- Right : P.Map) return Boolean renames P."<=";
-
- function P_Positions_Shifted
- (Small : P.Map;
- Big : P.Map;
- Cut : Positive_Count_Type;
- Count : Count_Type := 1) return Boolean
- with
- Global => null,
- Post =>
- P_Positions_Shifted'Result =
-
- -- Big contains all cursors of Small
-
- (P.Keys_Included (Small, Big)
-
- -- Cursors located before Cut are not moved, cursors located
- -- after are shifted by Count.
-
- and (for all I of Small =>
- (if P.Get (Small, I) < Cut then
- P.Get (Big, I) = P.Get (Small, I)
- else
- P.Get (Big, I) - Count = P.Get (Small, I)))
-
- -- New cursors of Big (if any) are between Cut and Cut - 1 +
- -- Count.
-
- and (for all I of Big =>
- P.Has_Key (Small, I)
- or P.Get (Big, I) - Count in Cut - Count .. Cut - 1));
-
- function P_Positions_Swapped
- (Left : P.Map;
- Right : P.Map;
- X : Cursor;
- Y : Cursor) return Boolean
- -- Left and Right contain the same cursors, but the positions of X and Y
- -- are reversed.
- with
- Ghost,
- Global => null,
- Post =>
- P_Positions_Swapped'Result =
- (P.Same_Keys (Left, Right)
- and P.Elements_Equal_Except (Left, Right, X, Y)
- and P.Has_Key (Left, X)
- and P.Has_Key (Left, Y)
- and P.Get (Left, X) = P.Get (Right, Y)
- and P.Get (Left, Y) = P.Get (Right, X));
-
- function P_Positions_Truncated
- (Small : P.Map;
- Big : P.Map;
- Cut : Positive_Count_Type;
- Count : Count_Type := 1) return Boolean
- with
- Ghost,
- Global => null,
- Post =>
- P_Positions_Truncated'Result =
-
- -- Big contains all cursors of Small at the same position
-
- (Small <= Big
-
- -- New cursors of Big (if any) are between Cut and Cut - 1 +
- -- Count.
-
- and (for all I of Big =>
- P.Has_Key (Small, I)
- or P.Get (Big, I) - Count in Cut - Count .. Cut - 1));
-
- function Mapping_Preserved
- (M_Left : M.Sequence;
- M_Right : M.Sequence;
- P_Left : P.Map;
- P_Right : P.Map) return Boolean
- with
- Ghost,
- Global => null,
- Post =>
- (if Mapping_Preserved'Result then
-
- -- Left and Right contain the same cursors
-
- P.Same_Keys (P_Left, P_Right)
-
- -- Mappings from cursors to elements induced by M_Left, P_Left
- -- and M_Right, P_Right are the same.
-
- and (for all C of P_Left =>
- M.Get (M_Left, P.Get (P_Left, C)) =
- M.Get (M_Right, P.Get (P_Right, C))));
-
- function Model (Container : List) return M.Sequence with
- -- The high-level model of a list is a sequence of elements. Cursors are
- -- not represented in this model.
-
- Ghost,
- Global => null,
- Post => M.Length (Model'Result) = Length (Container);
- pragma Annotate (GNATprove, Iterable_For_Proof, "Model", Model);
-
- function Positions (Container : List) return P.Map with
- -- The Positions map is used to model cursors. It only contains valid
- -- cursors and map them to their position in the container.
-
- Ghost,
- Global => null,
- Post =>
- not P.Has_Key (Positions'Result, No_Element)
-
- -- Positions of cursors are smaller than the container's length.
-
- and then
- (for all I of Positions'Result =>
- P.Get (Positions'Result, I) in 1 .. Length (Container)
-
- -- No two cursors have the same position. Note that we do not
- -- state that there is a cursor in the map for each position, as
- -- it is rarely needed.
-
- and then
- (for all J of Positions'Result =>
- (if P.Get (Positions'Result, I) = P.Get (Positions'Result, J)
- then I = J)));
-
- procedure Lift_Abstraction_Level (Container : List) with
- -- Lift_Abstraction_Level is a ghost procedure that does nothing but
- -- assume that we can access to the same elements by iterating over
- -- positions or cursors.
- -- This information is not generally useful except when switching from
- -- a low-level cursor-aware view of a container to a high-level
- -- position-based view.
-
- Ghost,
- Global => null,
- Post =>
- (for all Elt of Model (Container) =>
- (for some I of Positions (Container) =>
- M.Get (Model (Container), P.Get (Positions (Container), I)) =
- Elt));
-
- function Element
- (S : M.Sequence;
- I : Count_Type) return Element_Type renames M.Get;
- -- To improve readability of contracts, we rename the function used to
- -- access an element in the model to Element.
-
- end Formal_Model;
- use Formal_Model;
-
- function "=" (Left, Right : List) return Boolean with
- Global => null,
- Post => "="'Result = (Model (Left) = Model (Right));
-
- function Is_Empty (Container : List) return Boolean with
- Global => null,
- Post => Is_Empty'Result = (Length (Container) = 0);
-
- procedure Clear (Container : in out List) with
- Global => null,
- Post => Length (Container) = 0;
-
- procedure Assign (Target : in out List; Source : List) with
- Global => null,
- Pre => Target.Capacity >= Length (Source),
- Post => Model (Target) = Model (Source);
-
- function Copy (Source : List; Capacity : Count_Type := 0) return List with
- Global => null,
- Pre => Capacity = 0 or else Capacity >= Source.Capacity,
- Post =>
- Model (Copy'Result) = Model (Source)
- and Positions (Copy'Result) = Positions (Source)
- and (if Capacity = 0 then
- Copy'Result.Capacity = Source.Capacity
- else
- Copy'Result.Capacity = Capacity);
-
- function Element
- (Container : List;
- Position : Cursor) return Element_Type
- with
- Global => null,
- Pre => Has_Element (Container, Position),
- Post =>
- Element'Result =
- Element (Model (Container), P.Get (Positions (Container), Position));
- pragma Annotate (GNATprove, Inline_For_Proof, Element);
-
- procedure Replace_Element
- (Container : in out List;
- Position : Cursor;
- New_Item : Element_Type)
- with
- Global => null,
- Pre => Has_Element (Container, Position),
- Post =>
- Length (Container) = Length (Container)'Old
-
- -- Cursors are preserved
-
- and Positions (Container)'Old = Positions (Container)
-
- -- The element at the position of Position in Container is New_Item
-
- and Element
- (Model (Container),
- P.Get (Positions (Container), Position)) = New_Item
-
- -- Other elements are preserved
-
- and M.Equal_Except
- (Model (Container)'Old,
- Model (Container),
- P.Get (Positions (Container), Position));
-
- function At_End (E : access constant List) return access constant List
- is (E)
- with Ghost,
- Annotate => (GNATprove, At_End_Borrow);
-
- function At_End
- (E : access constant Element_Type) return access constant Element_Type
- is (E)
- with Ghost,
- Annotate => (GNATprove, At_End_Borrow);
-
- function Constant_Reference
- (Container : aliased List;
- Position : Cursor) return not null access constant Element_Type
- with
- Global => null,
- Pre => Has_Element (Container, Position),
- Post =>
- Constant_Reference'Result.all =
- Element (Model (Container), P.Get (Positions (Container), Position));
-
- function Reference
- (Container : not null access List;
- Position : Cursor) return not null access Element_Type
- with
- Global => null,
- Pre => Has_Element (Container.all, Position),
- Post =>
- Length (Container.all) = Length (At_End (Container).all)
-
- -- Cursors are preserved
-
- and Positions (Container.all) = Positions (At_End (Container).all)
-
- -- Container will have Result.all at position Position
-
- and At_End (Reference'Result).all =
- Element (Model (At_End (Container).all),
- P.Get (Positions (At_End (Container).all), Position))
-
- -- All other elements are preserved
-
- and M.Equal_Except
- (Model (Container.all),
- Model (At_End (Container).all),
- P.Get (Positions (At_End (Container).all), Position));
-
- procedure Move (Target : in out List; Source : in out List) with
- Global => null,
- Pre => Target.Capacity >= Length (Source),
- Post => Model (Target) = Model (Source'Old) and Length (Source) = 0;
-
- procedure Insert
- (Container : in out List;
- Before : Cursor;
- New_Item : Element_Type)
- with
- Global => null,
- Pre =>
- Length (Container) < Container.Capacity
- and then (Has_Element (Container, Before)
- or else Before = No_Element),
- Post => Length (Container) = Length (Container)'Old + 1,
- Contract_Cases =>
- (Before = No_Element =>
-
- -- Positions contains a new mapping from the last cursor of
- -- Container to its length.
-
- P.Get (Positions (Container), Last (Container)) = Length (Container)
-
- -- Other cursors come from Container'Old
-
- and P.Keys_Included_Except
- (Left => Positions (Container),
- Right => Positions (Container)'Old,
- New_Key => Last (Container))
-
- -- Cursors of Container'Old keep the same position
-
- and Positions (Container)'Old <= Positions (Container)
-
- -- Model contains a new element New_Item at the end
-
- and Element (Model (Container), Length (Container)) = New_Item
-
- -- Elements of Container'Old are preserved
-
- and Model (Container)'Old <= Model (Container),
-
- others =>
-
- -- The elements of Container located before Before are preserved
-
- M.Range_Equal
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => 1,
- Lst => P.Get (Positions (Container)'Old, Before) - 1)
-
- -- Other elements are shifted by 1
-
- and M.Range_Shifted
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => P.Get (Positions (Container)'Old, Before),
- Lst => Length (Container)'Old,
- Offset => 1)
-
- -- New_Item is stored at the previous position of Before in
- -- Container.
-
- and Element
- (Model (Container),
- P.Get (Positions (Container)'Old, Before)) = New_Item
-
- -- A new cursor has been inserted at position Before in Container
-
- and P_Positions_Shifted
- (Positions (Container)'Old,
- Positions (Container),
- Cut => P.Get (Positions (Container)'Old, Before)));
-
- procedure Insert
- (Container : in out List;
- Before : Cursor;
- New_Item : Element_Type;
- Count : Count_Type)
- with
- Global => null,
- Pre =>
- Length (Container) <= Container.Capacity - Count
- and then (Has_Element (Container, Before)
- or else Before = No_Element),
- Post => Length (Container) = Length (Container)'Old + Count,
- Contract_Cases =>
- (Before = No_Element =>
-
- -- The elements of Container are preserved
-
- M.Range_Equal
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => 1,
- Lst => Length (Container)'Old)
-
- -- Container contains Count times New_Item at the end
-
- and (if Count > 0 then
- M.Constant_Range
- (Container => Model (Container),
- Fst => Length (Container)'Old + 1,
- Lst => Length (Container),
- Item => New_Item))
-
- -- Count cursors have been inserted at the end of Container
-
- and P_Positions_Truncated
- (Positions (Container)'Old,
- Positions (Container),
- Cut => Length (Container)'Old + 1,
- Count => Count),
-
- others =>
-
- -- The elements of Container located before Before are preserved
-
- M.Range_Equal
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => 1,
- Lst => P.Get (Positions (Container)'Old, Before) - 1)
-
- -- Other elements are shifted by Count
-
- and M.Range_Shifted
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => P.Get (Positions (Container)'Old, Before),
- Lst => Length (Container)'Old,
- Offset => Count)
-
- -- Container contains Count times New_Item after position Before
-
- and M.Constant_Range
- (Container => Model (Container),
- Fst => P.Get (Positions (Container)'Old, Before),
- Lst =>
- P.Get (Positions (Container)'Old, Before) - 1 + Count,
- Item => New_Item)
-
- -- Count cursors have been inserted at position Before in
- -- Container.
-
- and P_Positions_Shifted
- (Positions (Container)'Old,
- Positions (Container),
- Cut => P.Get (Positions (Container)'Old, Before),
- Count => Count));
-
- procedure Insert
- (Container : in out List;
- Before : Cursor;
- New_Item : Element_Type;
- Position : out Cursor)
- with
- Global => null,
- Pre =>
- Length (Container) < Container.Capacity
- and then (Has_Element (Container, Before)
- or else Before = No_Element),
- Post =>
- Length (Container) = Length (Container)'Old + 1
-
- -- Positions is valid in Container and it is located either before
- -- Before if it is valid in Container or at the end if it is
- -- No_Element.
-
- and P.Has_Key (Positions (Container), Position)
- and (if Before = No_Element then
- P.Get (Positions (Container), Position) = Length (Container)
- else
- P.Get (Positions (Container), Position) =
- P.Get (Positions (Container)'Old, Before))
-
- -- The elements of Container located before Position are preserved
-
- and M.Range_Equal
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => 1,
- Lst => P.Get (Positions (Container), Position) - 1)
-
- -- Other elements are shifted by 1
-
- and M.Range_Shifted
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => P.Get (Positions (Container), Position),
- Lst => Length (Container)'Old,
- Offset => 1)
-
- -- New_Item is stored at Position in Container
-
- and Element
- (Model (Container),
- P.Get (Positions (Container), Position)) = New_Item
-
- -- A new cursor has been inserted at position Position in Container
-
- and P_Positions_Shifted
- (Positions (Container)'Old,
- Positions (Container),
- Cut => P.Get (Positions (Container), Position));
-
- procedure Insert
- (Container : in out List;
- Before : Cursor;
- New_Item : Element_Type;
- Position : out Cursor;
- Count : Count_Type)
- with
- Global => null,
- Pre =>
- Length (Container) <= Container.Capacity - Count
- and then (Has_Element (Container, Before)
- or else Before = No_Element),
- Post => Length (Container) = Length (Container)'Old + Count,
- Contract_Cases =>
- (Count = 0 =>
- Position = Before
- and Model (Container) = Model (Container)'Old
- and Positions (Container) = Positions (Container)'Old,
-
- others =>
-
- -- Positions is valid in Container and it is located either before
- -- Before if it is valid in Container or at the end if it is
- -- No_Element.
-
- P.Has_Key (Positions (Container), Position)
- and (if Before = No_Element then
- P.Get (Positions (Container), Position) =
- Length (Container)'Old + 1
- else
- P.Get (Positions (Container), Position) =
- P.Get (Positions (Container)'Old, Before))
-
- -- The elements of Container located before Position are preserved
-
- and M.Range_Equal
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => 1,
- Lst => P.Get (Positions (Container), Position) - 1)
-
- -- Other elements are shifted by Count
-
- and M.Range_Shifted
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => P.Get (Positions (Container), Position),
- Lst => Length (Container)'Old,
- Offset => Count)
-
- -- Container contains Count times New_Item after position Position
-
- and M.Constant_Range
- (Container => Model (Container),
- Fst => P.Get (Positions (Container), Position),
- Lst =>
- P.Get (Positions (Container), Position) - 1 + Count,
- Item => New_Item)
-
- -- Count cursor have been inserted at Position in Container
-
- and P_Positions_Shifted
- (Positions (Container)'Old,
- Positions (Container),
- Cut => P.Get (Positions (Container), Position),
- Count => Count));
-
- procedure Prepend (Container : in out List; New_Item : Element_Type) with
- Global => null,
- Pre => Length (Container) < Container.Capacity,
- Post =>
- Length (Container) = Length (Container)'Old + 1
-
- -- Elements are shifted by 1
-
- and M.Range_Shifted
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => 1,
- Lst => Length (Container)'Old,
- Offset => 1)
-
- -- New_Item is the first element of Container
-
- and Element (Model (Container), 1) = New_Item
-
- -- A new cursor has been inserted at the beginning of Container
-
- and P_Positions_Shifted
- (Positions (Container)'Old,
- Positions (Container),
- Cut => 1);
-
- procedure Prepend
- (Container : in out List;
- New_Item : Element_Type;
- Count : Count_Type)
- with
- Global => null,
- Pre => Length (Container) <= Container.Capacity - Count,
- Post =>
- Length (Container) = Length (Container)'Old + Count
-
- -- Elements are shifted by Count
-
- and M.Range_Shifted
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => 1,
- Lst => Length (Container)'Old,
- Offset => Count)
-
- -- Container starts with Count times New_Item
-
- and M.Constant_Range
- (Container => Model (Container),
- Fst => 1,
- Lst => Count,
- Item => New_Item)
-
- -- Count cursors have been inserted at the beginning of Container
-
- and P_Positions_Shifted
- (Positions (Container)'Old,
- Positions (Container),
- Cut => 1,
- Count => Count);
-
- procedure Append (Container : in out List; New_Item : Element_Type) with
- Global => null,
- Pre => Length (Container) < Container.Capacity,
- Post =>
- Length (Container) = Length (Container)'Old + 1
-
- -- Positions contains a new mapping from the last cursor of Container
- -- to its length.
-
- and P.Get (Positions (Container), Last (Container)) =
- Length (Container)
-
- -- Other cursors come from Container'Old
-
- and P.Keys_Included_Except
- (Left => Positions (Container),
- Right => Positions (Container)'Old,
- New_Key => Last (Container))
-
- -- Cursors of Container'Old keep the same position
-
- and Positions (Container)'Old <= Positions (Container)
-
- -- Model contains a new element New_Item at the end
-
- and Element (Model (Container), Length (Container)) = New_Item
-
- -- Elements of Container'Old are preserved
-
- and Model (Container)'Old <= Model (Container);
-
- procedure Append
- (Container : in out List;
- New_Item : Element_Type;
- Count : Count_Type)
- with
- Global => null,
- Pre => Length (Container) <= Container.Capacity - Count,
- Post =>
- Length (Container) = Length (Container)'Old + Count
-
- -- The elements of Container are preserved
-
- and Model (Container)'Old <= Model (Container)
-
- -- Container contains Count times New_Item at the end
-
- and (if Count > 0 then
- M.Constant_Range
- (Container => Model (Container),
- Fst => Length (Container)'Old + 1,
- Lst => Length (Container),
- Item => New_Item))
-
- -- Count cursors have been inserted at the end of Container
-
- and P_Positions_Truncated
- (Positions (Container)'Old,
- Positions (Container),
- Cut => Length (Container)'Old + 1,
- Count => Count);
-
- procedure Delete (Container : in out List; Position : in out Cursor) with
- Global => null,
- Depends => (Container =>+ Position, Position => null),
- Pre => Has_Element (Container, Position),
- Post =>
- Length (Container) = Length (Container)'Old - 1
-
- -- Position is set to No_Element
-
- and Position = No_Element
-
- -- The elements of Container located before Position are preserved.
-
- and M.Range_Equal
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => 1,
- Lst => P.Get (Positions (Container)'Old, Position'Old) - 1)
-
- -- The elements located after Position are shifted by 1
-
- and M.Range_Shifted
- (Left => Model (Container),
- Right => Model (Container)'Old,
- Fst => P.Get (Positions (Container)'Old, Position'Old),
- Lst => Length (Container),
- Offset => 1)
-
- -- Position has been removed from Container
-
- and P_Positions_Shifted
- (Positions (Container),
- Positions (Container)'Old,
- Cut => P.Get (Positions (Container)'Old, Position'Old));
-
- procedure Delete
- (Container : in out List;
- Position : in out Cursor;
- Count : Count_Type)
- with
- Global => null,
- Pre => Has_Element (Container, Position),
- Post =>
- Length (Container) in
- Length (Container)'Old - Count .. Length (Container)'Old
-
- -- Position is set to No_Element
-
- and Position = No_Element
-
- -- The elements of Container located before Position are preserved.
-
- and M.Range_Equal
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => 1,
- Lst => P.Get (Positions (Container)'Old, Position'Old) - 1),
-
- Contract_Cases =>
-
- -- All the elements after Position have been erased
-
- (Length (Container) - Count < P.Get (Positions (Container), Position) =>
- Length (Container) =
- P.Get (Positions (Container)'Old, Position'Old) - 1
-
- -- At most Count cursors have been removed at the end of Container
-
- and P_Positions_Truncated
- (Positions (Container),
- Positions (Container)'Old,
- Cut => P.Get (Positions (Container)'Old, Position'Old),
- Count => Count),
-
- others =>
- Length (Container) = Length (Container)'Old - Count
-
- -- Other elements are shifted by Count
-
- and M.Range_Shifted
- (Left => Model (Container),
- Right => Model (Container)'Old,
- Fst => P.Get (Positions (Container)'Old, Position'Old),
- Lst => Length (Container),
- Offset => Count)
-
- -- Count cursors have been removed from Container at Position
-
- and P_Positions_Shifted
- (Positions (Container),
- Positions (Container)'Old,
- Cut => P.Get (Positions (Container)'Old, Position'Old),
- Count => Count));
-
- procedure Delete_First (Container : in out List) with
- Global => null,
- Pre => not Is_Empty (Container),
- Post =>
- Length (Container) = Length (Container)'Old - 1
-
- -- The elements of Container are shifted by 1
-
- and M.Range_Shifted
- (Left => Model (Container),
- Right => Model (Container)'Old,
- Fst => 1,
- Lst => Length (Container),
- Offset => 1)
-
- -- The first cursor of Container has been removed
-
- and P_Positions_Shifted
- (Positions (Container),
- Positions (Container)'Old,
- Cut => 1);
-
- procedure Delete_First (Container : in out List; Count : Count_Type) with
- Global => null,
- Contract_Cases =>
-
- -- All the elements of Container have been erased
-
- (Length (Container) <= Count =>
- Length (Container) = 0,
-
- others =>
- Length (Container) = Length (Container)'Old - Count
-
- -- Elements of Container are shifted by Count
-
- and M.Range_Shifted
- (Left => Model (Container),
- Right => Model (Container)'Old,
- Fst => 1,
- Lst => Length (Container),
- Offset => Count)
-
- -- The first Count cursors have been removed from Container
-
- and P_Positions_Shifted
- (Positions (Container),
- Positions (Container)'Old,
- Cut => 1,
- Count => Count));
-
- procedure Delete_Last (Container : in out List) with
- Global => null,
- Pre => not Is_Empty (Container),
- Post =>
- Length (Container) = Length (Container)'Old - 1
-
- -- The elements of Container are preserved
-
- and Model (Container) <= Model (Container)'Old
-
- -- The last cursor of Container has been removed
-
- and not P.Has_Key (Positions (Container), Last (Container)'Old)
-
- -- Other cursors are still valid
-
- and P.Keys_Included_Except
- (Left => Positions (Container)'Old,
- Right => Positions (Container)'Old,
- New_Key => Last (Container)'Old)
-
- -- The positions of other cursors are preserved
-
- and Positions (Container) <= Positions (Container)'Old;
-
- procedure Delete_Last (Container : in out List; Count : Count_Type) with
- Global => null,
- Contract_Cases =>
-
- -- All the elements of Container have been erased
-
- (Length (Container) <= Count =>
- Length (Container) = 0,
-
- others =>
- Length (Container) = Length (Container)'Old - Count
-
- -- The elements of Container are preserved
-
- and Model (Container) <= Model (Container)'Old
-
- -- At most Count cursors have been removed at the end of Container
-
- and P_Positions_Truncated
- (Positions (Container),
- Positions (Container)'Old,
- Cut => Length (Container) + 1,
- Count => Count));
-
- procedure Reverse_Elements (Container : in out List) with
- Global => null,
- Post => M_Elements_Reversed (Model (Container)'Old, Model (Container));
-
- procedure Swap
- (Container : in out List;
- I : Cursor;
- J : Cursor)
- with
- Global => null,
- Pre => Has_Element (Container, I) and then Has_Element (Container, J),
- Post =>
- M_Elements_Swapped
- (Model (Container)'Old,
- Model (Container),
- X => P.Get (Positions (Container)'Old, I),
- Y => P.Get (Positions (Container)'Old, J))
-
- and Positions (Container) = Positions (Container)'Old;
-
- procedure Swap_Links
- (Container : in out List;
- I : Cursor;
- J : Cursor)
- with
- Global => null,
- Pre => Has_Element (Container, I) and then Has_Element (Container, J),
- Post =>
- M_Elements_Swapped
- (Model (Container'Old),
- Model (Container),
- X => P.Get (Positions (Container)'Old, I),
- Y => P.Get (Positions (Container)'Old, J))
- and P_Positions_Swapped
- (Positions (Container)'Old, Positions (Container), I, J);
-
- procedure Splice
- (Target : in out List;
- Before : Cursor;
- Source : in out List)
- -- Target and Source should not be aliased
- with
- Global => null,
- Pre =>
- Length (Source) <= Target.Capacity - Length (Target)
- and then (Has_Element (Target, Before)
- or else Before = No_Element),
- Post =>
- Length (Source) = 0
- and Length (Target) = Length (Target)'Old + Length (Source)'Old,
- Contract_Cases =>
- (Before = No_Element =>
-
- -- The elements of Target are preserved
-
- M.Range_Equal
- (Left => Model (Target)'Old,
- Right => Model (Target),
- Fst => 1,
- Lst => Length (Target)'Old)
-
- -- The elements of Source are appended to target, the order is not
- -- specified.
-
- and M_Elements_Included
- (Left => Model (Source)'Old,
- L_Lst => Length (Source)'Old,
- Right => Model (Target),
- R_Fst => Length (Target)'Old + 1,
- R_Lst => Length (Target))
-
- and M_Elements_Included
- (Left => Model (Target),
- L_Fst => Length (Target)'Old + 1,
- L_Lst => Length (Target),
- Right => Model (Source)'Old,
- R_Lst => Length (Source)'Old)
-
- -- Cursors have been inserted at the end of Target
-
- and P_Positions_Truncated
- (Positions (Target)'Old,
- Positions (Target),
- Cut => Length (Target)'Old + 1,
- Count => Length (Source)'Old),
-
- others =>
-
- -- The elements of Target located before Before are preserved
-
- M.Range_Equal
- (Left => Model (Target)'Old,
- Right => Model (Target),
- Fst => 1,
- Lst => P.Get (Positions (Target)'Old, Before) - 1)
-
- -- The elements of Source are inserted before Before, the order is
- -- not specified.
-
- and M_Elements_Included
- (Left => Model (Source)'Old,
- L_Lst => Length (Source)'Old,
- Right => Model (Target),
- R_Fst => P.Get (Positions (Target)'Old, Before),
- R_Lst =>
- P.Get (Positions (Target)'Old, Before) - 1 +
- Length (Source)'Old)
-
- and M_Elements_Included
- (Left => Model (Target),
- L_Fst => P.Get (Positions (Target)'Old, Before),
- L_Lst =>
- P.Get (Positions (Target)'Old, Before) - 1 +
- Length (Source)'Old,
- Right => Model (Source)'Old,
- R_Lst => Length (Source)'Old)
-
- -- Other elements are shifted by the length of Source
-
- and M.Range_Shifted
- (Left => Model (Target)'Old,
- Right => Model (Target),
- Fst => P.Get (Positions (Target)'Old, Before),
- Lst => Length (Target)'Old,
- Offset => Length (Source)'Old)
-
- -- Cursors have been inserted at position Before in Target
-
- and P_Positions_Shifted
- (Positions (Target)'Old,
- Positions (Target),
- Cut => P.Get (Positions (Target)'Old, Before),
- Count => Length (Source)'Old));
-
- procedure Splice
- (Target : in out List;
- Before : Cursor;
- Source : in out List;
- Position : in out Cursor)
- -- Target and Source should not be aliased
- with
- Global => null,
- Pre =>
- (Has_Element (Target, Before) or else Before = No_Element)
- and then Has_Element (Source, Position)
- and then Length (Target) < Target.Capacity,
- Post =>
- Length (Target) = Length (Target)'Old + 1
- and Length (Source) = Length (Source)'Old - 1
-
- -- The elements of Source located before Position are preserved
-
- and M.Range_Equal
- (Left => Model (Source)'Old,
- Right => Model (Source),
- Fst => 1,
- Lst => P.Get (Positions (Source)'Old, Position'Old) - 1)
-
- -- The elements located after Position are shifted by 1
-
- and M.Range_Shifted
- (Left => Model (Source)'Old,
- Right => Model (Source),
- Fst => P.Get (Positions (Source)'Old, Position'Old) + 1,
- Lst => Length (Source)'Old,
- Offset => -1)
-
- -- Position has been removed from Source
-
- and P_Positions_Shifted
- (Positions (Source),
- Positions (Source)'Old,
- Cut => P.Get (Positions (Source)'Old, Position'Old))
-
- -- Positions is valid in Target and it is located either before
- -- Before if it is valid in Target or at the end if it is No_Element.
-
- and P.Has_Key (Positions (Target), Position)
- and (if Before = No_Element then
- P.Get (Positions (Target), Position) = Length (Target)
- else
- P.Get (Positions (Target), Position) =
- P.Get (Positions (Target)'Old, Before))
-
- -- The elements of Target located before Position are preserved
-
- and M.Range_Equal
- (Left => Model (Target)'Old,
- Right => Model (Target),
- Fst => 1,
- Lst => P.Get (Positions (Target), Position) - 1)
-
- -- Other elements are shifted by 1
-
- and M.Range_Shifted
- (Left => Model (Target)'Old,
- Right => Model (Target),
- Fst => P.Get (Positions (Target), Position),
- Lst => Length (Target)'Old,
- Offset => 1)
-
- -- The element located at Position in Source is moved to Target
-
- and Element (Model (Target),
- P.Get (Positions (Target), Position)) =
- Element (Model (Source)'Old,
- P.Get (Positions (Source)'Old, Position'Old))
-
- -- A new cursor has been inserted at position Position in Target
-
- and P_Positions_Shifted
- (Positions (Target)'Old,
- Positions (Target),
- Cut => P.Get (Positions (Target), Position));
-
- procedure Splice
- (Container : in out List;
- Before : Cursor;
- Position : Cursor)
- with
- Global => null,
- Pre =>
- (Has_Element (Container, Before) or else Before = No_Element)
- and then Has_Element (Container, Position),
- Post => Length (Container) = Length (Container)'Old,
- Contract_Cases =>
- (Before = Position =>
- Model (Container) = Model (Container)'Old
- and Positions (Container) = Positions (Container)'Old,
-
- Before = No_Element =>
-
- -- The elements located before Position are preserved
-
- M.Range_Equal
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => 1,
- Lst => P.Get (Positions (Container)'Old, Position) - 1)
-
- -- The elements located after Position are shifted by 1
-
- and M.Range_Shifted
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => P.Get (Positions (Container)'Old, Position) + 1,
- Lst => Length (Container)'Old,
- Offset => -1)
-
- -- The last element of Container is the one that was previously at
- -- Position.
-
- and Element (Model (Container),
- Length (Container)) =
- Element (Model (Container)'Old,
- P.Get (Positions (Container)'Old, Position))
-
- -- Cursors from Container continue designating the same elements
-
- and Mapping_Preserved
- (M_Left => Model (Container)'Old,
- M_Right => Model (Container),
- P_Left => Positions (Container)'Old,
- P_Right => Positions (Container)),
-
- others =>
-
- -- The elements located before Position and Before are preserved
-
- M.Range_Equal
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => 1,
- Lst =>
- Count_Type'Min
- (P.Get (Positions (Container)'Old, Position) - 1,
- P.Get (Positions (Container)'Old, Before) - 1))
-
- -- The elements located after Position and Before are preserved
-
- and M.Range_Equal
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst =>
- Count_Type'Max
- (P.Get (Positions (Container)'Old, Position) + 1,
- P.Get (Positions (Container)'Old, Before) + 1),
- Lst => Length (Container))
-
- -- The elements located after Before and before Position are
- -- shifted by 1 to the right.
-
- and M.Range_Shifted
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => P.Get (Positions (Container)'Old, Before) + 1,
- Lst => P.Get (Positions (Container)'Old, Position) - 1,
- Offset => 1)
-
- -- The elements located after Position and before Before are
- -- shifted by 1 to the left.
-
- and M.Range_Shifted
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => P.Get (Positions (Container)'Old, Position) + 1,
- Lst => P.Get (Positions (Container)'Old, Before) - 1,
- Offset => -1)
-
- -- The element previously at Position is now before Before
-
- and Element
- (Model (Container),
- P.Get (Positions (Container)'Old, Before)) =
- Element
- (Model (Container)'Old,
- P.Get (Positions (Container)'Old, Position))
-
- -- Cursors from Container continue designating the same elements
-
- and Mapping_Preserved
- (M_Left => Model (Container)'Old,
- M_Right => Model (Container),
- P_Left => Positions (Container)'Old,
- P_Right => Positions (Container)));
-
- function First (Container : List) return Cursor with
- Global => null,
- Contract_Cases =>
- (Length (Container) = 0 =>
- First'Result = No_Element,
-
- others =>
- Has_Element (Container, First'Result)
- and P.Get (Positions (Container), First'Result) = 1);
-
- function First_Element (Container : List) return Element_Type with
- Global => null,
- Pre => not Is_Empty (Container),
- Post => First_Element'Result = M.Get (Model (Container), 1);
-
- function Last (Container : List) return Cursor with
- Global => null,
- Contract_Cases =>
- (Length (Container) = 0 =>
- Last'Result = No_Element,
-
- others =>
- Has_Element (Container, Last'Result)
- and P.Get (Positions (Container), Last'Result) =
- Length (Container));
-
- function Last_Element (Container : List) return Element_Type with
- Global => null,
- Pre => not Is_Empty (Container),
- Post =>
- Last_Element'Result = M.Get (Model (Container), Length (Container));
-
- function Next (Container : List; Position : Cursor) return Cursor with
- Global => null,
- Pre =>
- Has_Element (Container, Position) or else Position = No_Element,
- Contract_Cases =>
- (Position = No_Element
- or else P.Get (Positions (Container), Position) = Length (Container)
- =>
- Next'Result = No_Element,
-
- others =>
- Has_Element (Container, Next'Result)
- and then P.Get (Positions (Container), Next'Result) =
- P.Get (Positions (Container), Position) + 1);
-
- procedure Next (Container : List; Position : in out Cursor) with
- Global => null,
- Pre =>
- Has_Element (Container, Position) or else Position = No_Element,
- Contract_Cases =>
- (Position = No_Element
- or else P.Get (Positions (Container), Position) = Length (Container)
- =>
- Position = No_Element,
-
- others =>
- Has_Element (Container, Position)
- and then P.Get (Positions (Container), Position) =
- P.Get (Positions (Container), Position'Old) + 1);
-
- function Previous (Container : List; Position : Cursor) return Cursor with
- Global => null,
- Pre =>
- Has_Element (Container, Position) or else Position = No_Element,
- Contract_Cases =>
- (Position = No_Element
- or else P.Get (Positions (Container), Position) = 1
- =>
- Previous'Result = No_Element,
-
- others =>
- Has_Element (Container, Previous'Result)
- and then P.Get (Positions (Container), Previous'Result) =
- P.Get (Positions (Container), Position) - 1);
-
- procedure Previous (Container : List; Position : in out Cursor) with
- Global => null,
- Pre =>
- Has_Element (Container, Position) or else Position = No_Element,
- Contract_Cases =>
- (Position = No_Element
- or else P.Get (Positions (Container), Position) = 1
- =>
- Position = No_Element,
-
- others =>
- Has_Element (Container, Position)
- and then P.Get (Positions (Container), Position) =
- P.Get (Positions (Container), Position'Old) - 1);
-
- function Find
- (Container : List;
- Item : Element_Type;
- Position : Cursor := No_Element) return Cursor
- with
- Global => null,
- Pre =>
- Has_Element (Container, Position) or else Position = No_Element,
- Contract_Cases =>
-
- -- If Item is not contained in Container after Position, Find returns
- -- No_Element.
-
- (not M.Contains
- (Container => Model (Container),
- Fst =>
- (if Position = No_Element then
- 1
- else
- P.Get (Positions (Container), Position)),
- Lst => Length (Container),
- Item => Item)
- =>
- Find'Result = No_Element,
-
- -- Otherwise, Find returns a valid cursor in Container
-
- others =>
- P.Has_Key (Positions (Container), Find'Result)
-
- -- The element designated by the result of Find is Item
-
- and Element
- (Model (Container),
- P.Get (Positions (Container), Find'Result)) = Item
-
- -- The result of Find is located after Position
-
- and (if Position /= No_Element then
- P.Get (Positions (Container), Find'Result) >=
- P.Get (Positions (Container), Position))
-
- -- It is the first occurrence of Item in this slice
-
- and not M.Contains
- (Container => Model (Container),
- Fst =>
- (if Position = No_Element then
- 1
- else
- P.Get (Positions (Container), Position)),
- Lst =>
- P.Get (Positions (Container), Find'Result) - 1,
- Item => Item));
-
- function Reverse_Find
- (Container : List;
- Item : Element_Type;
- Position : Cursor := No_Element) return Cursor
- with
- Global => null,
- Pre =>
- Has_Element (Container, Position) or else Position = No_Element,
- Contract_Cases =>
-
- -- If Item is not contained in Container before Position, Find returns
- -- No_Element.
-
- (not M.Contains
- (Container => Model (Container),
- Fst => 1,
- Lst =>
- (if Position = No_Element then
- Length (Container)
- else
- P.Get (Positions (Container), Position)),
- Item => Item)
- =>
- Reverse_Find'Result = No_Element,
-
- -- Otherwise, Find returns a valid cursor in Container
-
- others =>
- P.Has_Key (Positions (Container), Reverse_Find'Result)
-
- -- The element designated by the result of Find is Item
-
- and Element
- (Model (Container),
- P.Get (Positions (Container), Reverse_Find'Result)) = Item
-
- -- The result of Find is located before Position
-
- and (if Position /= No_Element then
- P.Get (Positions (Container), Reverse_Find'Result) <=
- P.Get (Positions (Container), Position))
-
- -- It is the last occurrence of Item in this slice
-
- and not M.Contains
- (Container => Model (Container),
- Fst =>
- P.Get (Positions (Container),
- Reverse_Find'Result) + 1,
- Lst =>
- (if Position = No_Element then
- Length (Container)
- else
- P.Get (Positions (Container), Position)),
- Item => Item));
-
- function Contains
- (Container : List;
- Item : Element_Type) return Boolean
- with
- Global => null,
- Post =>
- Contains'Result = M.Contains (Container => Model (Container),
- Fst => 1,
- Lst => Length (Container),
- Item => Item);
-
- function Has_Element
- (Container : List;
- Position : Cursor) return Boolean
- with
- Global => null,
- Post =>
- Has_Element'Result = P.Has_Key (Positions (Container), Position);
- pragma Annotate (GNATprove, Inline_For_Proof, Has_Element);
-
- generic
- with function "<" (Left, Right : Element_Type) return Boolean is <>;
-
- package Generic_Sorting with SPARK_Mode is
-
- package Formal_Model with Ghost is
- function M_Elements_Sorted (Container : M.Sequence) return Boolean
- with
- Global => null,
- Post =>
- M_Elements_Sorted'Result =
- (for all I in 1 .. M.Length (Container) =>
- (for all J in I .. M.Length (Container) =>
- not (Element (Container, J) < Element (Container, I))));
- pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_Sorted);
-
- end Formal_Model;
- use Formal_Model;
-
- function Is_Sorted (Container : List) return Boolean with
- Global => null,
- Post => Is_Sorted'Result = M_Elements_Sorted (Model (Container));
-
- procedure Sort (Container : in out List) with
- Global => null,
- Post =>
- Length (Container) = Length (Container)'Old
- and M_Elements_Sorted (Model (Container))
- and M_Elements_Included
- (Left => Model (Container)'Old,
- L_Lst => Length (Container),
- Right => Model (Container),
- R_Lst => Length (Container))
- and M_Elements_Included
- (Left => Model (Container),
- L_Lst => Length (Container),
- Right => Model (Container)'Old,
- R_Lst => Length (Container));
-
- procedure Merge (Target : in out List; Source : in out List) with
- -- Target and Source should not be aliased
- Global => null,
- Pre => Length (Source) <= Target.Capacity - Length (Target),
- Post =>
- Length (Target) = Length (Target)'Old + Length (Source)'Old
- and Length (Source) = 0
- and (if M_Elements_Sorted (Model (Target)'Old)
- and M_Elements_Sorted (Model (Source)'Old)
- then
- M_Elements_Sorted (Model (Target)))
- and M_Elements_Included
- (Left => Model (Target)'Old,
- L_Lst => Length (Target)'Old,
- Right => Model (Target),
- R_Lst => Length (Target))
- and M_Elements_Included
- (Left => Model (Source)'Old,
- L_Lst => Length (Source)'Old,
- Right => Model (Target),
- R_Lst => Length (Target))
- and M_Elements_In_Union
- (Model (Target),
- Model (Source)'Old,
- Model (Target)'Old);
- end Generic_Sorting;
-
-private
- pragma SPARK_Mode (Off);
-
- type Node_Type is record
- Prev : Count_Type'Base := -1;
- Next : Count_Type;
- Element : aliased Element_Type;
- end record;
-
- function "=" (L, R : Node_Type) return Boolean is abstract;
-
- type Node_Array is array (Count_Type range <>) of Node_Type;
- function "=" (L, R : Node_Array) return Boolean is abstract;
-
- type List (Capacity : Count_Type) is record
- Free : Count_Type'Base := -1;
- Length : Count_Type := 0;
- First : Count_Type := 0;
- Last : Count_Type := 0;
- Nodes : Node_Array (1 .. Capacity);
- end record;
+package Ada.Containers.Formal_Doubly_Linked_Lists with SPARK_Mode is
- Empty_List : constant List := (0, others => <>);
+ pragma Compile_Time_Error
+ (True,
+ "This package has been moved to the SPARK library shipped with any"
+ & " SPARK release starting with version 23.");
end Ada.Containers.Formal_Doubly_Linked_Lists;
diff --git a/gcc/ada/libgnat/a-cfhama.adb b/gcc/ada/libgnat/a-cfhama.adb
deleted file mode 100644
index bdf2c61..0000000
--- a/gcc/ada/libgnat/a-cfhama.adb
+++ /dev/null
@@ -1,976 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT LIBRARY COMPONENTS --
--- --
--- A D A . C O N T A I N E R S . F O R M A L _ H A S H E D _ M A P S --
--- --
--- B o d y --
--- --
--- Copyright (C) 2010-2022, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
-------------------------------------------------------------------------------
-
-with Ada.Containers.Hash_Tables.Generic_Formal_Operations;
-pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Formal_Operations);
-
-with Ada.Containers.Hash_Tables.Generic_Formal_Keys;
-pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Formal_Keys);
-
-with Ada.Containers.Prime_Numbers; use Ada.Containers.Prime_Numbers;
-
-with Ada.Numerics.Big_Numbers.Big_Integers;
-use Ada.Numerics.Big_Numbers.Big_Integers;
-
-with System; use type System.Address;
-
-package body Ada.Containers.Formal_Hashed_Maps with
- SPARK_Mode => Off
-is
- -----------------------
- -- Local Subprograms --
- -----------------------
-
- -- All local subprograms require comments ???
-
- function Equivalent_Keys
- (Key : Key_Type;
- Node : Node_Type) return Boolean;
- pragma Inline (Equivalent_Keys);
-
- procedure Free
- (HT : in out Map;
- X : Count_Type);
-
- generic
- with procedure Set_Element (Node : in out Node_Type);
- procedure Generic_Allocate
- (HT : in out HT_Types.Hash_Table_Type;
- Node : out Count_Type);
-
- function Hash_Node (Node : Node_Type) return Hash_Type;
- pragma Inline (Hash_Node);
-
- function Next (Node : Node_Type) return Count_Type;
- pragma Inline (Next);
-
- procedure Set_Next (Node : in out Node_Type; Next : Count_Type);
- pragma Inline (Set_Next);
-
- function Vet (Container : Map; Position : Cursor) return Boolean
- with Inline;
-
- -- Convert Count_Type to Big_Interger
-
- package Conversions is new Signed_Conversions (Int => Count_Type);
-
- function Big (J : Count_Type) return Big_Integer renames
- Conversions.To_Big_Integer;
-
- --------------------------
- -- Local Instantiations --
- --------------------------
-
- package HT_Ops is
- new Hash_Tables.Generic_Formal_Operations
- (HT_Types => HT_Types,
- Hash_Node => Hash_Node,
- Next => Next,
- Set_Next => Set_Next);
-
- package Key_Ops is
- new Hash_Tables.Generic_Formal_Keys
- (HT_Types => HT_Types,
- Next => Next,
- Set_Next => Set_Next,
- Key_Type => Key_Type,
- Hash => Hash,
- Equivalent_Keys => Equivalent_Keys);
-
- ---------
- -- "=" --
- ---------
-
- function "=" (Left, Right : Map) return Boolean is
- begin
- if Length (Left) /= Length (Right) then
- return False;
- end if;
-
- if Length (Left) = 0 then
- return True;
- end if;
-
- declare
- Node : Count_Type;
- ENode : Count_Type;
-
- begin
- Node := First (Left).Node;
- while Node /= 0 loop
- ENode :=
- Find
- (Container => Right,
- Key => Left.Content.Nodes (Node).Key).Node;
-
- if ENode = 0 or else
- Right.Content.Nodes (ENode).Element /=
- Left.Content.Nodes (Node).Element
- then
- return False;
- end if;
-
- Node := HT_Ops.Next (Left.Content, Node);
- end loop;
-
- return True;
- end;
- end "=";
-
- ------------
- -- Assign --
- ------------
-
- procedure Assign (Target : in out Map; Source : Map) is
- procedure Insert_Element (Source_Node : Count_Type);
- pragma Inline (Insert_Element);
-
- procedure Insert_Elements is
- new HT_Ops.Generic_Iteration (Insert_Element);
-
- --------------------
- -- Insert_Element --
- --------------------
-
- procedure Insert_Element (Source_Node : Count_Type) is
- N : Node_Type renames Source.Content.Nodes (Source_Node);
- begin
- Insert (Target, N.Key, N.Element);
- end Insert_Element;
-
- -- Start of processing for Assign
-
- begin
- if Target.Capacity < Length (Source) then
- raise Constraint_Error with -- correct exception ???
- "Source length exceeds Target capacity";
- end if;
-
- Clear (Target);
-
- Insert_Elements (Source.Content);
- end Assign;
-
- --------------
- -- Capacity --
- --------------
-
- function Capacity (Container : Map) return Count_Type is
- begin
- return Container.Content.Nodes'Length;
- end Capacity;
-
- -----------
- -- Clear --
- -----------
-
- procedure Clear (Container : in out Map) is
- begin
- HT_Ops.Clear (Container.Content);
- end Clear;
-
- ------------------------
- -- Constant_Reference --
- ------------------------
-
- function Constant_Reference
- (Container : aliased Map;
- Position : Cursor) return not null access constant Element_Type
- is
- begin
- if not Has_Element (Container, Position) then
- raise Constraint_Error with "Position cursor has no element";
- end if;
-
- pragma Assert
- (Vet (Container, Position),
- "bad cursor in function Constant_Reference");
-
- return Container.Content.Nodes (Position.Node).Element'Access;
- end Constant_Reference;
-
- function Constant_Reference
- (Container : aliased Map;
- Key : Key_Type) return not null access constant Element_Type
- is
- Node : constant Count_Type := Find (Container, Key).Node;
-
- begin
- if Node = 0 then
- raise Constraint_Error with
- "no element available because key not in map";
- end if;
-
- return Container.Content.Nodes (Node).Element'Access;
- end Constant_Reference;
-
- --------------
- -- Contains --
- --------------
-
- function Contains (Container : Map; Key : Key_Type) return Boolean is
- begin
- return Find (Container, Key) /= No_Element;
- end Contains;
-
- ----------
- -- Copy --
- ----------
-
- function Copy
- (Source : Map;
- Capacity : Count_Type := 0) return Map
- is
- C : constant Count_Type :=
- Count_Type'Max (Capacity, Source.Capacity);
- Cu : Cursor;
- H : Hash_Type;
- N : Count_Type;
- Target : Map (C, Source.Modulus);
-
- begin
- if 0 < Capacity and then Capacity < Source.Capacity then
- raise Capacity_Error;
- end if;
-
- Target.Content.Length := Source.Content.Length;
- Target.Content.Free := Source.Content.Free;
-
- H := 1;
- while H <= Source.Modulus loop
- Target.Content.Buckets (H) := Source.Content.Buckets (H);
- H := H + 1;
- end loop;
-
- N := 1;
- while N <= Source.Capacity loop
- Target.Content.Nodes (N) := Source.Content.Nodes (N);
- N := N + 1;
- end loop;
-
- while N <= C loop
- Cu := (Node => N);
- Free (Target, Cu.Node);
- N := N + 1;
- end loop;
-
- return Target;
- end Copy;
-
- ---------------------
- -- Default_Modulus --
- ---------------------
-
- function Default_Modulus (Capacity : Count_Type) return Hash_Type is
- begin
- return To_Prime (Capacity);
- end Default_Modulus;
-
- ------------
- -- Delete --
- ------------
-
- procedure Delete (Container : in out Map; Key : Key_Type) is
- X : Count_Type;
-
- begin
- Key_Ops.Delete_Key_Sans_Free (Container.Content, Key, X);
-
- if X = 0 then
- raise Constraint_Error with "attempt to delete key not in map";
- end if;
-
- Free (Container, X);
- end Delete;
-
- procedure Delete (Container : in out Map; Position : in out Cursor) is
- begin
- if not Has_Element (Container, Position) then
- raise Constraint_Error with
- "Position cursor of Delete has no element";
- end if;
-
- pragma Assert (Vet (Container, Position), "bad cursor in Delete");
-
- HT_Ops.Delete_Node_Sans_Free (Container.Content, Position.Node);
-
- Free (Container, Position.Node);
- Position := No_Element;
- end Delete;
-
- -------------
- -- Element --
- -------------
-
- function Element (Container : Map; Key : Key_Type) return Element_Type is
- Node : constant Count_Type := Find (Container, Key).Node;
-
- begin
- if Node = 0 then
- raise Constraint_Error with
- "no element available because key not in map";
- end if;
-
- return Container.Content.Nodes (Node).Element;
- end Element;
-
- function Element (Container : Map; Position : Cursor) return Element_Type is
- begin
- if not Has_Element (Container, Position) then
- raise Constraint_Error with "Position cursor equals No_Element";
- end if;
-
- pragma Assert
- (Vet (Container, Position), "bad cursor in function Element");
-
- return Container.Content.Nodes (Position.Node).Element;
- end Element;
-
- ---------------------
- -- Equivalent_Keys --
- ---------------------
-
- function Equivalent_Keys
- (Key : Key_Type;
- Node : Node_Type) return Boolean
- is
- begin
- return Equivalent_Keys (Key, Node.Key);
- end Equivalent_Keys;
-
- -------------
- -- Exclude --
- -------------
-
- procedure Exclude (Container : in out Map; Key : Key_Type) is
- X : Count_Type;
- begin
- Key_Ops.Delete_Key_Sans_Free (Container.Content, Key, X);
- Free (Container, X);
- end Exclude;
-
- ----------
- -- Find --
- ----------
-
- function Find (Container : Map; Key : Key_Type) return Cursor is
- Node : constant Count_Type := Key_Ops.Find (Container.Content, Key);
-
- begin
- if Node = 0 then
- return No_Element;
- end if;
-
- return (Node => Node);
- end Find;
-
- -----------
- -- First --
- -----------
-
- function First (Container : Map) return Cursor is
- Node : constant Count_Type := HT_Ops.First (Container.Content);
-
- begin
- if Node = 0 then
- return No_Element;
- end if;
-
- return (Node => Node);
- end First;
-
- ------------------
- -- Formal_Model --
- ------------------
-
- package body Formal_Model is
-
- ----------
- -- Find --
- ----------
-
- function Find
- (Container : K.Sequence;
- Key : Key_Type) return Count_Type
- is
- begin
- for I in 1 .. K.Length (Container) loop
- if Equivalent_Keys (Key, K.Get (Container, I)) then
- return I;
- end if;
- end loop;
- return 0;
- end Find;
-
- ---------------------
- -- K_Keys_Included --
- ---------------------
-
- function K_Keys_Included
- (Left : K.Sequence;
- Right : K.Sequence) return Boolean
- is
- begin
- for I in 1 .. K.Length (Left) loop
- if not K.Contains (Right, 1, K.Length (Right), K.Get (Left, I))
- then
- return False;
- end if;
- end loop;
-
- return True;
- end K_Keys_Included;
-
- ----------
- -- Keys --
- ----------
-
- function Keys (Container : Map) return K.Sequence is
- Position : Count_Type := HT_Ops.First (Container.Content);
- R : K.Sequence;
-
- begin
- -- Can't use First, Next or Element here, since they depend on models
- -- for their postconditions.
-
- while Position /= 0 loop
- R := K.Add (R, Container.Content.Nodes (Position).Key);
- Position := HT_Ops.Next (Container.Content, Position);
- end loop;
-
- return R;
- end Keys;
-
- ----------------------------
- -- Lift_Abstraction_Level --
- ----------------------------
-
- procedure Lift_Abstraction_Level (Container : Map) is null;
-
- -----------------------
- -- Mapping_Preserved --
- -----------------------
-
- function Mapping_Preserved
- (K_Left : K.Sequence;
- K_Right : K.Sequence;
- P_Left : P.Map;
- P_Right : P.Map) return Boolean
- is
- begin
- for C of P_Left loop
- if not P.Has_Key (P_Right, C)
- or else P.Get (P_Left, C) > K.Length (K_Left)
- or else P.Get (P_Right, C) > K.Length (K_Right)
- or else K.Get (K_Left, P.Get (P_Left, C)) /=
- K.Get (K_Right, P.Get (P_Right, C))
- then
- return False;
- end if;
- end loop;
-
- return True;
- end Mapping_Preserved;
-
- -----------
- -- Model --
- -----------
-
- function Model (Container : Map) return M.Map is
- Position : Count_Type := HT_Ops.First (Container.Content);
- R : M.Map;
-
- begin
- -- Can't use First, Next or Element here, since they depend on models
- -- for their postconditions.
-
- while Position /= 0 loop
- R :=
- M.Add
- (Container => R,
- New_Key => Container.Content.Nodes (Position).Key,
- New_Item => Container.Content.Nodes (Position).Element);
-
- Position := HT_Ops.Next (Container.Content, Position);
- end loop;
-
- return R;
- end Model;
-
- ---------------
- -- Positions --
- ---------------
-
- function Positions (Container : Map) return P.Map is
- I : Count_Type := 1;
- Position : Count_Type := HT_Ops.First (Container.Content);
- R : P.Map;
-
- begin
- -- Can't use First, Next or Element here, since they depend on models
- -- for their postconditions.
-
- while Position /= 0 loop
- R := P.Add (R, (Node => Position), I);
- pragma Assert (P.Length (R) = Big (I));
- Position := HT_Ops.Next (Container.Content, Position);
- I := I + 1;
- end loop;
-
- return R;
- end Positions;
-
- end Formal_Model;
-
- ----------
- -- Free --
- ----------
-
- procedure Free (HT : in out Map; X : Count_Type) is
- begin
- if X /= 0 then
- pragma Assert (X <= HT.Capacity);
- HT.Content.Nodes (X).Has_Element := False;
- HT_Ops.Free (HT.Content, X);
- end if;
- end Free;
-
- ----------------------
- -- Generic_Allocate --
- ----------------------
-
- procedure Generic_Allocate
- (HT : in out HT_Types.Hash_Table_Type;
- Node : out Count_Type)
- is
- procedure Allocate is
- new HT_Ops.Generic_Allocate (Set_Element);
-
- begin
- Allocate (HT, Node);
- HT.Nodes (Node).Has_Element := True;
- end Generic_Allocate;
-
- -----------------
- -- Has_Element --
- -----------------
-
- function Has_Element (Container : Map; Position : Cursor) return Boolean is
- begin
- if Position.Node = 0
- or else not Container.Content.Nodes (Position.Node).Has_Element
- then
- return False;
- else
- return True;
- end if;
- end Has_Element;
-
- ---------------
- -- Hash_Node --
- ---------------
-
- function Hash_Node (Node : Node_Type) return Hash_Type is
- begin
- return Hash (Node.Key);
- end Hash_Node;
-
- -------------
- -- Include --
- -------------
-
- procedure Include
- (Container : in out Map;
- Key : Key_Type;
- New_Item : Element_Type)
- is
- Position : Cursor;
- Inserted : Boolean;
-
- begin
- Insert (Container, Key, New_Item, Position, Inserted);
-
- if not Inserted then
- declare
- P : constant Count_Type := Position.Node;
- N : Node_Type renames Container.Content.Nodes (P);
- begin
- N.Key := Key;
- N.Element := New_Item;
- end;
- end if;
- end Include;
-
- ------------
- -- Insert --
- ------------
-
- procedure Insert
- (Container : in out Map;
- Key : Key_Type;
- New_Item : Element_Type;
- Position : out Cursor;
- Inserted : out Boolean)
- is
- procedure Assign_Key (Node : in out Node_Type);
- pragma Inline (Assign_Key);
-
- procedure New_Node
- (HT : in out HT_Types.Hash_Table_Type;
- Node : out Count_Type);
- pragma Inline (New_Node);
-
- procedure Local_Insert is
- new Key_Ops.Generic_Conditional_Insert (New_Node);
-
- procedure Allocate is
- new Generic_Allocate (Assign_Key);
-
- -----------------
- -- Assign_Key --
- -----------------
-
- procedure Assign_Key (Node : in out Node_Type) is
- begin
- Node.Key := Key;
- Node.Element := New_Item;
- end Assign_Key;
-
- --------------
- -- New_Node --
- --------------
-
- procedure New_Node
- (HT : in out HT_Types.Hash_Table_Type;
- Node : out Count_Type)
- is
- begin
- Allocate (HT, Node);
- end New_Node;
-
- -- Start of processing for Insert
-
- begin
- Local_Insert (Container.Content, Key, Position.Node, Inserted);
- end Insert;
-
- procedure Insert
- (Container : in out Map;
- Key : Key_Type;
- New_Item : Element_Type)
- is
- Unused_Position : Cursor;
- Inserted : Boolean;
-
- begin
- Insert (Container, Key, New_Item, Unused_Position, Inserted);
-
- if not Inserted then
- raise Constraint_Error with "attempt to insert key already in map";
- end if;
- end Insert;
-
- --------------
- -- Is_Empty --
- --------------
-
- function Is_Empty (Container : Map) return Boolean is
- begin
- return Length (Container) = 0;
- end Is_Empty;
-
- ---------
- -- Key --
- ---------
-
- function Key (Container : Map; Position : Cursor) return Key_Type is
- begin
- if not Has_Element (Container, Position) then
- raise Constraint_Error with
- "Position cursor of function Key has no element";
- end if;
-
- pragma Assert (Vet (Container, Position), "bad cursor in function Key");
-
- return Container.Content.Nodes (Position.Node).Key;
- end Key;
-
- ------------
- -- Length --
- ------------
-
- function Length (Container : Map) return Count_Type is
- begin
- return Container.Content.Length;
- end Length;
-
- ----------
- -- Move --
- ----------
-
- procedure Move
- (Target : in out Map;
- Source : in out Map)
- is
- NN : HT_Types.Nodes_Type renames Source.Content.Nodes;
- X : Count_Type;
- Y : Count_Type;
-
- begin
- if Target.Capacity < Length (Source) then
- raise Constraint_Error with -- ???
- "Source length exceeds Target capacity";
- end if;
-
- Clear (Target);
-
- if Source.Content.Length = 0 then
- return;
- end if;
-
- X := HT_Ops.First (Source.Content);
- while X /= 0 loop
- Insert (Target, NN (X).Key, NN (X).Element); -- optimize???
-
- Y := HT_Ops.Next (Source.Content, X);
-
- HT_Ops.Delete_Node_Sans_Free (Source.Content, X);
- Free (Source, X);
-
- X := Y;
- end loop;
- end Move;
-
- ----------
- -- Next --
- ----------
-
- function Next (Node : Node_Type) return Count_Type is
- begin
- return Node.Next;
- end Next;
-
- function Next (Container : Map; Position : Cursor) return Cursor is
- begin
- if Position.Node = 0 then
- return No_Element;
- end if;
-
- if not Has_Element (Container, Position) then
- raise Constraint_Error with "Position has no element";
- end if;
-
- pragma Assert (Vet (Container, Position), "bad cursor in function Next");
-
- declare
- Node : constant Count_Type :=
- HT_Ops.Next (Container.Content, Position.Node);
-
- begin
- if Node = 0 then
- return No_Element;
- end if;
-
- return (Node => Node);
- end;
- end Next;
-
- procedure Next (Container : Map; Position : in out Cursor) is
- begin
- Position := Next (Container, Position);
- end Next;
-
- ---------------
- -- Reference --
- ---------------
-
- function Reference
- (Container : not null access Map;
- Position : Cursor) return not null access Element_Type
- is
- begin
- if not Has_Element (Container.all, Position) then
- raise Constraint_Error with "Position cursor has no element";
- end if;
-
- pragma Assert
- (Vet (Container.all, Position), "bad cursor in function Reference");
-
- return Container.Content.Nodes (Position.Node).Element'Access;
- end Reference;
-
- function Reference
- (Container : not null access Map;
- Key : Key_Type) return not null access Element_Type
- is
- Node : constant Count_Type := Find (Container.all, Key).Node;
-
- begin
- if Node = 0 then
- raise Constraint_Error with
- "no element available because key not in map";
- end if;
-
- return Container.Content.Nodes (Node).Element'Access;
- end Reference;
-
- -------------
- -- Replace --
- -------------
-
- procedure Replace
- (Container : in out Map;
- Key : Key_Type;
- New_Item : Element_Type)
- is
- Node : constant Count_Type := Key_Ops.Find (Container.Content, Key);
-
- begin
- if Node = 0 then
- raise Constraint_Error with "attempt to replace key not in map";
- end if;
-
- declare
- N : Node_Type renames Container.Content.Nodes (Node);
- begin
- N.Key := Key;
- N.Element := New_Item;
- end;
- end Replace;
-
- ---------------------
- -- Replace_Element --
- ---------------------
-
- procedure Replace_Element
- (Container : in out Map;
- Position : Cursor;
- New_Item : Element_Type)
- is
- begin
- if not Has_Element (Container, Position) then
- raise Constraint_Error with
- "Position cursor of Replace_Element has no element";
- end if;
-
- pragma Assert
- (Vet (Container, Position), "bad cursor in Replace_Element");
-
- Container.Content.Nodes (Position.Node).Element := New_Item;
- end Replace_Element;
-
- ----------------------
- -- Reserve_Capacity --
- ----------------------
-
- procedure Reserve_Capacity
- (Container : in out Map;
- Capacity : Count_Type)
- is
- begin
- if Capacity > Container.Capacity then
- raise Capacity_Error with "requested capacity is too large";
- end if;
- end Reserve_Capacity;
-
- --------------
- -- Set_Next --
- --------------
-
- procedure Set_Next (Node : in out Node_Type; Next : Count_Type) is
- begin
- Node.Next := Next;
- end Set_Next;
-
- ---------
- -- Vet --
- ---------
-
- function Vet (Container : Map; Position : Cursor) return Boolean is
- begin
- if not Container_Checks'Enabled then
- return True;
- end if;
-
- if Position.Node = 0 then
- return True;
- end if;
-
- declare
- X : Count_Type;
-
- begin
- if Container.Content.Length = 0 then
- return False;
- end if;
-
- if Container.Capacity = 0 then
- return False;
- end if;
-
- if Container.Content.Buckets'Length = 0 then
- return False;
- end if;
-
- if Position.Node > Container.Capacity then
- return False;
- end if;
-
- if Container.Content.Nodes (Position.Node).Next = Position.Node then
- return False;
- end if;
-
- X :=
- Container.Content.Buckets
- (Key_Ops.Index
- (Container.Content,
- Container.Content.Nodes (Position.Node).Key));
-
- for J in 1 .. Container.Content.Length loop
- if X = Position.Node then
- return True;
- end if;
-
- if X = 0 then
- return False;
- end if;
-
- if X = Container.Content.Nodes (X).Next then
-
- -- Prevent unnecessary looping
-
- return False;
- end if;
-
- X := Container.Content.Nodes (X).Next;
- end loop;
-
- return False;
- end;
- end Vet;
-
-end Ada.Containers.Formal_Hashed_Maps;
diff --git a/gcc/ada/libgnat/a-cfhama.ads b/gcc/ada/libgnat/a-cfhama.ads
index 8cb7488..42c7fbd 100644
--- a/gcc/ada/libgnat/a-cfhama.ads
+++ b/gcc/ada/libgnat/a-cfhama.ads
@@ -29,885 +29,12 @@
-- <http://www.gnu.org/licenses/>. --
------------------------------------------------------------------------------
--- This spec is derived from package Ada.Containers.Bounded_Hashed_Maps in the
--- Ada 2012 RM. The modifications are meant to facilitate formal proofs by
--- making it easier to express properties, and by making the specification of
--- this unit compatible with SPARK 2014. Note that the API of this unit may be
--- subject to incompatible changes as SPARK 2014 evolves.
-
--- The modifications are:
-
--- A parameter for the container is added to every function reading the
--- contents of a container: Key, Element, Next, Query_Element, Has_Element,
--- Iterate, Equivalent_Keys. This change is motivated by the need to have
--- cursors which are valid on different containers (typically a container C
--- and its previous version C'Old) for expressing properties, which is not
--- possible if cursors encapsulate an access to the underlying container.
-
--- Iteration over maps is done using the Iterable aspect, which is SPARK
--- compatible. "For of" iteration ranges over keys instead of elements.
-
-with Ada.Containers.Functional_Vectors;
-with Ada.Containers.Functional_Maps;
-private with Ada.Containers.Hash_Tables;
-
generic
- type Key_Type is private;
- type Element_Type is private;
-
- with function Hash (Key : Key_Type) return Hash_Type;
- with function Equivalent_Keys
- (Left : Key_Type;
- Right : Key_Type) return Boolean is "=";
- with function "=" (Left, Right : Element_Type) return Boolean is <>;
-
-package Ada.Containers.Formal_Hashed_Maps with
- SPARK_Mode,
- Annotate => (GNATprove, Always_Return)
-is
-
- -- Contracts in this unit are meant for analysis only, not for run-time
- -- checking.
-
- pragma Assertion_Policy (Pre => Ignore);
- pragma Assertion_Policy (Post => Ignore);
- pragma Assertion_Policy (Contract_Cases => Ignore);
- pragma Annotate (CodePeer, Skip_Analysis);
-
- type Map (Capacity : Count_Type; Modulus : Hash_Type) is private with
- Iterable => (First => First,
- Next => Next,
- Has_Element => Has_Element,
- Element => Key),
- Default_Initial_Condition => Is_Empty (Map);
- pragma Preelaborable_Initialization (Map);
-
- Empty_Map : constant Map;
-
- type Cursor is record
- Node : Count_Type;
- end record;
-
- No_Element : constant Cursor := (Node => 0);
-
- function Length (Container : Map) return Count_Type with
- Global => null,
- Post => Length'Result <= Container.Capacity;
-
- pragma Unevaluated_Use_Of_Old (Allow);
-
- package Formal_Model with Ghost is
- subtype Positive_Count_Type is Count_Type range 1 .. Count_Type'Last;
-
- package M is new Ada.Containers.Functional_Maps
- (Element_Type => Element_Type,
- Key_Type => Key_Type,
- Equivalent_Keys => Equivalent_Keys);
-
- function "="
- (Left : M.Map;
- Right : M.Map) return Boolean renames M."=";
-
- function "<="
- (Left : M.Map;
- Right : M.Map) return Boolean renames M."<=";
-
- package K is new Ada.Containers.Functional_Vectors
- (Element_Type => Key_Type,
- Index_Type => Positive_Count_Type);
-
- function "="
- (Left : K.Sequence;
- Right : K.Sequence) return Boolean renames K."=";
-
- function "<"
- (Left : K.Sequence;
- Right : K.Sequence) return Boolean renames K."<";
-
- function "<="
- (Left : K.Sequence;
- Right : K.Sequence) return Boolean renames K."<=";
-
- function Find (Container : K.Sequence; Key : Key_Type) return Count_Type
- -- Search for Key in Container
-
- with
- Global => null,
- Post =>
- (if Find'Result > 0 then
- Find'Result <= K.Length (Container)
- and Equivalent_Keys (Key, K.Get (Container, Find'Result)));
-
- function K_Keys_Included
- (Left : K.Sequence;
- Right : K.Sequence) return Boolean
- -- Return True if Right contains all the keys of Left
-
- with
- Global => null,
- Post =>
- K_Keys_Included'Result =
- (for all I in 1 .. K.Length (Left) =>
- Find (Right, K.Get (Left, I)) > 0
- and then K.Get (Right, Find (Right, K.Get (Left, I))) =
- K.Get (Left, I));
-
- package P is new Ada.Containers.Functional_Maps
- (Key_Type => Cursor,
- Element_Type => Positive_Count_Type,
- Equivalent_Keys => "=",
- Enable_Handling_Of_Equivalence => False);
-
- function "="
- (Left : P.Map;
- Right : P.Map) return Boolean renames P."=";
-
- function "<="
- (Left : P.Map;
- Right : P.Map) return Boolean renames P."<=";
-
- function Mapping_Preserved
- (K_Left : K.Sequence;
- K_Right : K.Sequence;
- P_Left : P.Map;
- P_Right : P.Map) return Boolean
- with
- Global => null,
- Post =>
- (if Mapping_Preserved'Result then
-
- -- Right contains all the cursors of Left
-
- P.Keys_Included (P_Left, P_Right)
-
- -- Right contains all the keys of Left
-
- and K_Keys_Included (K_Left, K_Right)
-
- -- Mappings from cursors to elements induced by K_Left, P_Left
- -- and K_Right, P_Right are the same.
-
- and (for all C of P_Left =>
- K.Get (K_Left, P.Get (P_Left, C)) =
- K.Get (K_Right, P.Get (P_Right, C))));
-
- function Model (Container : Map) return M.Map with
- -- The high-level model of a map is a map from keys to elements. Neither
- -- cursors nor order of elements are represented in this model. Keys are
- -- modeled up to equivalence.
-
- Ghost,
- Global => null;
-
- function Keys (Container : Map) return K.Sequence with
- -- The Keys sequence represents the underlying list structure of maps
- -- that is used for iteration. It stores the actual values of keys in
- -- the map. It does not model cursors nor elements.
-
- Ghost,
- Global => null,
- Post =>
- K.Length (Keys'Result) = Length (Container)
-
- -- It only contains keys contained in Model
-
- and (for all Key of Keys'Result =>
- M.Has_Key (Model (Container), Key))
-
- -- It contains all the keys contained in Model
-
- and (for all Key of Model (Container) =>
- (Find (Keys'Result, Key) > 0
- and then Equivalent_Keys
- (K.Get (Keys'Result, Find (Keys'Result, Key)),
- Key)))
-
- -- It has no duplicate
-
- and (for all I in 1 .. Length (Container) =>
- Find (Keys'Result, K.Get (Keys'Result, I)) = I)
-
- and (for all I in 1 .. Length (Container) =>
- (for all J in 1 .. Length (Container) =>
- (if Equivalent_Keys
- (K.Get (Keys'Result, I), K.Get (Keys'Result, J))
- then
- I = J)));
- pragma Annotate (GNATprove, Iterable_For_Proof, "Model", Keys);
-
- function Positions (Container : Map) return P.Map with
- -- The Positions map is used to model cursors. It only contains valid
- -- cursors and maps them to their position in the container.
-
- Ghost,
- Global => null,
- Post =>
- not P.Has_Key (Positions'Result, No_Element)
-
- -- Positions of cursors are smaller than the container's length
-
- and then
- (for all I of Positions'Result =>
- P.Get (Positions'Result, I) in 1 .. Length (Container)
-
- -- No two cursors have the same position. Note that we do not
- -- state that there is a cursor in the map for each position, as
- -- it is rarely needed.
-
- and then
- (for all J of Positions'Result =>
- (if P.Get (Positions'Result, I) = P.Get (Positions'Result, J)
- then I = J)));
-
- procedure Lift_Abstraction_Level (Container : Map) with
- -- Lift_Abstraction_Level is a ghost procedure that does nothing but
- -- assume that we can access the same elements by iterating over
- -- positions or cursors.
- -- This information is not generally useful except when switching from
- -- a low-level, cursor-aware view of a container, to a high-level,
- -- position-based view.
-
- Ghost,
- Global => null,
- Post =>
- (for all Key of Keys (Container) =>
- (for some I of Positions (Container) =>
- K.Get (Keys (Container), P.Get (Positions (Container), I)) =
- Key));
-
- function Contains
- (C : M.Map;
- K : Key_Type) return Boolean renames M.Has_Key;
- -- To improve readability of contracts, we rename the function used to
- -- search for a key in the model to Contains.
-
- function Element
- (C : M.Map;
- K : Key_Type) return Element_Type renames M.Get;
- -- To improve readability of contracts, we rename the function used to
- -- access an element in the model to Element.
-
- end Formal_Model;
- use Formal_Model;
-
- function "=" (Left, Right : Map) return Boolean with
- Global => null,
- Post => "="'Result = (Model (Left) = Model (Right));
-
- function Capacity (Container : Map) return Count_Type with
- Global => null,
- Post => Capacity'Result = Container.Capacity;
-
- procedure Reserve_Capacity
- (Container : in out Map;
- Capacity : Count_Type)
- with
- Global => null,
- Pre => Capacity <= Container.Capacity,
- Post =>
- Model (Container) = Model (Container)'Old
- and Length (Container)'Old = Length (Container)
-
- -- Actual keys are preserved
-
- and K_Keys_Included (Keys (Container), Keys (Container)'Old)
- and K_Keys_Included (Keys (Container)'Old, Keys (Container));
-
- function Is_Empty (Container : Map) return Boolean with
- Global => null,
- Post => Is_Empty'Result = (Length (Container) = 0);
-
- procedure Clear (Container : in out Map) with
- Global => null,
- Post => Length (Container) = 0 and M.Is_Empty (Model (Container));
-
- procedure Assign (Target : in out Map; Source : Map) with
- Global => null,
- Pre => Target.Capacity >= Length (Source),
- Post =>
- Model (Target) = Model (Source)
- and Length (Source) = Length (Target)
-
- -- Actual keys are preserved
-
- and K_Keys_Included (Keys (Target), Keys (Source))
- and K_Keys_Included (Keys (Source), Keys (Target));
-
- function Copy
- (Source : Map;
- Capacity : Count_Type := 0) return Map
- with
- Global => null,
- Pre => Capacity = 0 or else Capacity >= Source.Capacity,
- Post =>
- Model (Copy'Result) = Model (Source)
- and Keys (Copy'Result) = Keys (Source)
- and Positions (Copy'Result) = Positions (Source)
- and (if Capacity = 0 then
- Copy'Result.Capacity = Source.Capacity
- else
- Copy'Result.Capacity = Capacity);
- -- Copy returns a container stricty equal to Source. It must have the same
- -- cursors associated with each element. Therefore:
- -- - capacity=0 means use Source.Capacity as capacity of target
- -- - the modulus cannot be changed.
-
- function Key (Container : Map; Position : Cursor) return Key_Type with
- Global => null,
- Pre => Has_Element (Container, Position),
- Post =>
- Key'Result =
- K.Get (Keys (Container), P.Get (Positions (Container), Position));
- pragma Annotate (GNATprove, Inline_For_Proof, Key);
-
- function Element
- (Container : Map;
- Position : Cursor) return Element_Type
- with
- Global => null,
- Pre => Has_Element (Container, Position),
- Post =>
- Element'Result = Element (Model (Container), Key (Container, Position));
- pragma Annotate (GNATprove, Inline_For_Proof, Element);
-
- procedure Replace_Element
- (Container : in out Map;
- Position : Cursor;
- New_Item : Element_Type)
- with
- Global => null,
- Pre => Has_Element (Container, Position),
- Post =>
-
- -- Order of keys and cursors is preserved
-
- Keys (Container) = Keys (Container)'Old
- and Positions (Container) = Positions (Container)'Old
-
- -- New_Item is now associated with the key at position Position in
- -- Container.
-
- and Element (Container, Position) = New_Item
-
- -- Elements associated with other keys are preserved
-
- and M.Same_Keys (Model (Container), Model (Container)'Old)
- and M.Elements_Equal_Except
- (Model (Container),
- Model (Container)'Old,
- Key (Container, Position));
-
- function At_End
- (E : not null access constant Map) return not null access constant Map
- is (E)
- with Ghost,
- Annotate => (GNATprove, At_End_Borrow);
-
- function At_End
- (E : access constant Element_Type) return access constant Element_Type
- is (E)
- with Ghost,
- Annotate => (GNATprove, At_End_Borrow);
-
- function Constant_Reference
- (Container : aliased Map;
- Position : Cursor) return not null access constant Element_Type
- with
- Global => null,
- Pre => Has_Element (Container, Position),
- Post =>
- Constant_Reference'Result.all =
- Element (Model (Container), Key (Container, Position));
-
- function Reference
- (Container : not null access Map;
- Position : Cursor) return not null access Element_Type
- with
- Global => null,
- Pre => Has_Element (Container.all, Position),
- Post =>
-
- -- Order of keys and cursors is preserved
-
- Keys (At_End (Container).all) = Keys (Container.all)
- and Positions (At_End (Container).all) = Positions (Container.all)
-
- -- The value designated by the result of Reference is now associated
- -- with the key at position Position in Container.
-
- and Element (At_End (Container).all, Position) =
- At_End (Reference'Result).all
-
- -- Elements associated with other keys are preserved
-
- and M.Same_Keys
- (Model (At_End (Container).all),
- Model (Container.all))
- and M.Elements_Equal_Except
- (Model (At_End (Container).all),
- Model (Container.all),
- Key (At_End (Container).all, Position));
-
- function Constant_Reference
- (Container : aliased Map;
- Key : Key_Type) return not null access constant Element_Type
- with
- Global => null,
- Pre => Contains (Container, Key),
- Post =>
- Constant_Reference'Result.all = Element (Model (Container), Key);
-
- function Reference
- (Container : not null access Map;
- Key : Key_Type) return not null access Element_Type
- with
- Global => null,
- Pre => Contains (Container.all, Key),
- Post =>
-
- -- Order of keys and cursors is preserved
-
- Keys (At_End (Container).all) = Keys (Container.all)
- and Positions (At_End (Container).all) = Positions (Container.all)
-
- -- The value designated by the result of Reference is now associated
- -- with Key in Container.
-
- and Element (Model (At_End (Container).all), Key) =
- At_End (Reference'Result).all
-
- -- Elements associated with other keys are preserved
-
- and M.Same_Keys
- (Model (At_End (Container).all),
- Model (Container.all))
- and M.Elements_Equal_Except
- (Model (At_End (Container).all),
- Model (Container.all),
- Key);
-
- procedure Move (Target : in out Map; Source : in out Map) with
- Global => null,
- Pre => Target.Capacity >= Length (Source),
- Post =>
- Model (Target) = Model (Source)'Old
- and Length (Source)'Old = Length (Target)
- and Length (Source) = 0
-
- -- Actual keys are preserved
-
- and K_Keys_Included (Keys (Target), Keys (Source)'Old)
- and K_Keys_Included (Keys (Source)'Old, Keys (Target));
-
- procedure Insert
- (Container : in out Map;
- Key : Key_Type;
- New_Item : Element_Type;
- Position : out Cursor;
- Inserted : out Boolean)
- with
- Global => null,
- Pre =>
- Length (Container) < Container.Capacity or Contains (Container, Key),
- Post =>
- Contains (Container, Key)
- and Has_Element (Container, Position)
- and Equivalent_Keys
- (Formal_Hashed_Maps.Key (Container, Position), Key),
- Contract_Cases =>
-
- -- If Key is already in Container, it is not modified and Inserted is
- -- set to False.
-
- (Contains (Container, Key) =>
- not Inserted
- and Model (Container) = Model (Container)'Old
- and Keys (Container) = Keys (Container)'Old
- and Positions (Container) = Positions (Container)'Old,
-
- -- Otherwise, Key is inserted in Container and Inserted is set to True
-
- others =>
- Inserted
- and Length (Container) = Length (Container)'Old + 1
-
- -- Key now maps to New_Item
-
- and Formal_Hashed_Maps.Key (Container, Position) = Key
- and Element (Model (Container), Key) = New_Item
-
- -- Other keys are preserved
-
- and Model (Container)'Old <= Model (Container)
- and M.Keys_Included_Except
- (Model (Container),
- Model (Container)'Old,
- Key)
-
- -- Mapping from cursors to keys is preserved
-
- and Mapping_Preserved
- (K_Left => Keys (Container)'Old,
- K_Right => Keys (Container),
- P_Left => Positions (Container)'Old,
- P_Right => Positions (Container))
- and P.Keys_Included_Except
- (Positions (Container),
- Positions (Container)'Old,
- Position));
-
- procedure Insert
- (Container : in out Map;
- Key : Key_Type;
- New_Item : Element_Type)
- with
- Global => null,
- Pre =>
- Length (Container) < Container.Capacity
- and then (not Contains (Container, Key)),
- Post =>
- Length (Container) = Length (Container)'Old + 1
- and Contains (Container, Key)
-
- -- Key now maps to New_Item
-
- and Formal_Hashed_Maps.Key (Container, Find (Container, Key)) = Key
- and Element (Model (Container), Key) = New_Item
-
- -- Other keys are preserved
-
- and Model (Container)'Old <= Model (Container)
- and M.Keys_Included_Except
- (Model (Container),
- Model (Container)'Old,
- Key)
-
- -- Mapping from cursors to keys is preserved
-
- and Mapping_Preserved
- (K_Left => Keys (Container)'Old,
- K_Right => Keys (Container),
- P_Left => Positions (Container)'Old,
- P_Right => Positions (Container))
- and P.Keys_Included_Except
- (Positions (Container),
- Positions (Container)'Old,
- Find (Container, Key));
-
- procedure Include
- (Container : in out Map;
- Key : Key_Type;
- New_Item : Element_Type)
- with
- Global => null,
- Pre =>
- Length (Container) < Container.Capacity or Contains (Container, Key),
- Post =>
- Contains (Container, Key) and Element (Container, Key) = New_Item,
- Contract_Cases =>
-
- -- If Key is already in Container, Key is mapped to New_Item
-
- (Contains (Container, Key) =>
-
- -- Cursors are preserved
-
- Positions (Container) = Positions (Container)'Old
-
- -- The key equivalent to Key in Container is replaced by Key
-
- and K.Get
- (Keys (Container),
- P.Get (Positions (Container), Find (Container, Key))) = Key
- and K.Equal_Except
- (Keys (Container)'Old,
- Keys (Container),
- P.Get (Positions (Container), Find (Container, Key)))
-
- -- Elements associated with other keys are preserved
-
- and M.Same_Keys (Model (Container), Model (Container)'Old)
- and M.Elements_Equal_Except
- (Model (Container),
- Model (Container)'Old,
- Key),
-
- -- Otherwise, Key is inserted in Container
-
- others =>
- Length (Container) = Length (Container)'Old + 1
-
- -- Other keys are preserved
-
- and Model (Container)'Old <= Model (Container)
- and M.Keys_Included_Except
- (Model (Container),
- Model (Container)'Old,
- Key)
-
- -- Key is inserted in Container
-
- and K.Get
- (Keys (Container),
- P.Get (Positions (Container), Find (Container, Key))) = Key
-
- -- Mapping from cursors to keys is preserved
-
- and Mapping_Preserved
- (K_Left => Keys (Container)'Old,
- K_Right => Keys (Container),
- P_Left => Positions (Container)'Old,
- P_Right => Positions (Container))
- and P.Keys_Included_Except
- (Positions (Container),
- Positions (Container)'Old,
- Find (Container, Key)));
-
- procedure Replace
- (Container : in out Map;
- Key : Key_Type;
- New_Item : Element_Type)
- with
- Global => null,
- Pre => Contains (Container, Key),
- Post =>
-
- -- Cursors are preserved
-
- Positions (Container) = Positions (Container)'Old
-
- -- The key equivalent to Key in Container is replaced by Key
-
- and K.Get
- (Keys (Container),
- P.Get (Positions (Container), Find (Container, Key))) = Key
- and K.Equal_Except
- (Keys (Container)'Old,
- Keys (Container),
- P.Get (Positions (Container), Find (Container, Key)))
-
- -- New_Item is now associated with the Key in Container
-
- and Element (Model (Container), Key) = New_Item
-
- -- Elements associated with other keys are preserved
-
- and M.Same_Keys (Model (Container), Model (Container)'Old)
- and M.Elements_Equal_Except
- (Model (Container),
- Model (Container)'Old,
- Key);
-
- procedure Exclude (Container : in out Map; Key : Key_Type) with
- Global => null,
- Post => not Contains (Container, Key),
- Contract_Cases =>
-
- -- If Key is not in Container, nothing is changed
-
- (not Contains (Container, Key) =>
- Model (Container) = Model (Container)'Old
- and Keys (Container) = Keys (Container)'Old
- and Positions (Container) = Positions (Container)'Old,
-
- -- Otherwise, Key is removed from Container
-
- others =>
- Length (Container) = Length (Container)'Old - 1
-
- -- Other keys are preserved
-
- and Model (Container) <= Model (Container)'Old
- and M.Keys_Included_Except
- (Model (Container)'Old,
- Model (Container),
- Key)
-
- -- Mapping from cursors to keys is preserved
-
- and Mapping_Preserved
- (K_Left => Keys (Container),
- K_Right => Keys (Container)'Old,
- P_Left => Positions (Container),
- P_Right => Positions (Container)'Old)
- and P.Keys_Included_Except
- (Positions (Container)'Old,
- Positions (Container),
- Find (Container, Key)'Old));
-
- procedure Delete (Container : in out Map; Key : Key_Type) with
- Global => null,
- Pre => Contains (Container, Key),
- Post =>
- Length (Container) = Length (Container)'Old - 1
-
- -- Key is no longer in Container
-
- and not Contains (Container, Key)
-
- -- Other keys are preserved
-
- and Model (Container) <= Model (Container)'Old
- and M.Keys_Included_Except
- (Model (Container)'Old,
- Model (Container),
- Key)
-
- -- Mapping from cursors to keys is preserved
-
- and Mapping_Preserved
- (K_Left => Keys (Container),
- K_Right => Keys (Container)'Old,
- P_Left => Positions (Container),
- P_Right => Positions (Container)'Old)
- and P.Keys_Included_Except
- (Positions (Container)'Old,
- Positions (Container),
- Find (Container, Key)'Old);
-
- procedure Delete (Container : in out Map; Position : in out Cursor) with
- Global => null,
- Depends => (Container =>+ Position, Position => null),
- Pre => Has_Element (Container, Position),
- Post =>
- Position = No_Element
- and Length (Container) = Length (Container)'Old - 1
-
- -- The key at position Position is no longer in Container
-
- and not Contains (Container, Key (Container, Position)'Old)
- and not P.Has_Key (Positions (Container), Position'Old)
-
- -- Other keys are preserved
-
- and Model (Container) <= Model (Container)'Old
- and M.Keys_Included_Except
- (Model (Container)'Old,
- Model (Container),
- Key (Container, Position)'Old)
-
- -- Mapping from cursors to keys is preserved
-
- and Mapping_Preserved
- (K_Left => Keys (Container),
- K_Right => Keys (Container)'Old,
- P_Left => Positions (Container),
- P_Right => Positions (Container)'Old)
- and P.Keys_Included_Except
- (Positions (Container)'Old,
- Positions (Container),
- Position'Old);
-
- function First (Container : Map) return Cursor with
- Global => null,
- Contract_Cases =>
- (Length (Container) = 0 =>
- First'Result = No_Element,
-
- others =>
- Has_Element (Container, First'Result)
- and P.Get (Positions (Container), First'Result) = 1);
-
- function Next (Container : Map; Position : Cursor) return Cursor with
- Global => null,
- Pre =>
- Has_Element (Container, Position) or else Position = No_Element,
- Contract_Cases =>
- (Position = No_Element
- or else P.Get (Positions (Container), Position) = Length (Container)
- =>
- Next'Result = No_Element,
-
- others =>
- Has_Element (Container, Next'Result)
- and then P.Get (Positions (Container), Next'Result) =
- P.Get (Positions (Container), Position) + 1);
-
- procedure Next (Container : Map; Position : in out Cursor) with
- Global => null,
- Pre =>
- Has_Element (Container, Position) or else Position = No_Element,
- Contract_Cases =>
- (Position = No_Element
- or else P.Get (Positions (Container), Position) = Length (Container)
- =>
- Position = No_Element,
-
- others =>
- Has_Element (Container, Position)
- and then P.Get (Positions (Container), Position) =
- P.Get (Positions (Container), Position'Old) + 1);
-
- function Find (Container : Map; Key : Key_Type) return Cursor with
- Global => null,
- Contract_Cases =>
-
- -- If Key is not contained in Container, Find returns No_Element
-
- (not Contains (Model (Container), Key) =>
- Find'Result = No_Element,
-
- -- Otherwise, Find returns a valid cursor in Container
-
- others =>
- P.Has_Key (Positions (Container), Find'Result)
- and P.Get (Positions (Container), Find'Result) =
- Find (Keys (Container), Key)
-
- -- The key designated by the result of Find is Key
-
- and Equivalent_Keys
- (Formal_Hashed_Maps.Key (Container, Find'Result), Key));
-
- function Contains (Container : Map; Key : Key_Type) return Boolean with
- Global => null,
- Post => Contains'Result = Contains (Model (Container), Key);
- pragma Annotate (GNATprove, Inline_For_Proof, Contains);
-
- function Element (Container : Map; Key : Key_Type) return Element_Type with
- Global => null,
- Pre => Contains (Container, Key),
- Post => Element'Result = Element (Model (Container), Key);
- pragma Annotate (GNATprove, Inline_For_Proof, Element);
-
- function Has_Element (Container : Map; Position : Cursor) return Boolean
- with
- Global => null,
- Post =>
- Has_Element'Result = P.Has_Key (Positions (Container), Position);
- pragma Annotate (GNATprove, Inline_For_Proof, Has_Element);
-
- function Default_Modulus (Capacity : Count_Type) return Hash_Type with
- Global => null;
-
-private
- pragma SPARK_Mode (Off);
-
- pragma Inline (Length);
- pragma Inline (Is_Empty);
- pragma Inline (Clear);
- pragma Inline (Key);
- pragma Inline (Element);
- pragma Inline (Contains);
- pragma Inline (Capacity);
- pragma Inline (Has_Element);
- pragma Inline (Equivalent_Keys);
- pragma Inline (Next);
-
- type Node_Type is record
- Key : Key_Type;
- Element : aliased Element_Type;
- Next : Count_Type;
- Has_Element : Boolean := False;
- end record;
-
- package HT_Types is new
- Ada.Containers.Hash_Tables.Generic_Formal_Hash_Table_Types (Node_Type);
-
- type Map (Capacity : Count_Type; Modulus : Hash_Type) is record
- Content : HT_Types.Hash_Table_Type (Capacity, Modulus);
- end record;
+package Ada.Containers.Formal_Hashed_Maps with SPARK_Mode is
- Empty_Map : constant Map := (Capacity => 0, Modulus => 0, others => <>);
+ pragma Compile_Time_Error
+ (True,
+ "This package has been moved to the SPARK library shipped with any"
+ & " SPARK release starting with version 23.");
end Ada.Containers.Formal_Hashed_Maps;
diff --git a/gcc/ada/libgnat/a-cfhase.adb b/gcc/ada/libgnat/a-cfhase.adb
deleted file mode 100644
index 34afa55..0000000
--- a/gcc/ada/libgnat/a-cfhase.adb
+++ /dev/null
@@ -1,1559 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT LIBRARY COMPONENTS --
--- --
--- A D A . C O N T A I N E R S . F O R M A L _ H A S H E D _ S E T S --
--- --
--- B o d y --
--- --
--- Copyright (C) 2010-2022, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
-------------------------------------------------------------------------------
-
-with Ada.Containers.Hash_Tables.Generic_Formal_Operations;
-pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Formal_Operations);
-
-with Ada.Containers.Hash_Tables.Generic_Formal_Keys;
-pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Formal_Keys);
-
-with Ada.Containers.Prime_Numbers; use Ada.Containers.Prime_Numbers;
-
-with System; use type System.Address;
-
-package body Ada.Containers.Formal_Hashed_Sets with
- SPARK_Mode => Off
-is
- -----------------------
- -- Local Subprograms --
- -----------------------
-
- -- All need comments ???
-
- procedure Difference (Left : Set; Right : Set; Target : in out Set);
-
- function Equivalent_Keys
- (Key : Element_Type;
- Node : Node_Type) return Boolean;
- pragma Inline (Equivalent_Keys);
-
- procedure Free
- (HT : in out Set;
- X : Count_Type);
-
- generic
- with procedure Set_Element (Node : in out Node_Type);
- procedure Generic_Allocate
- (HT : in out Hash_Table_Type;
- Node : out Count_Type);
-
- function Hash_Node (Node : Node_Type) return Hash_Type;
- pragma Inline (Hash_Node);
-
- procedure Insert
- (Container : in out Set;
- New_Item : Element_Type;
- Node : out Count_Type;
- Inserted : out Boolean);
-
- procedure Intersection
- (Left : Set;
- Right : Set;
- Target : in out Set);
-
- function Is_In
- (HT : Set;
- Key : Node_Type) return Boolean;
- pragma Inline (Is_In);
-
- procedure Set_Element (Node : in out Node_Type; Item : Element_Type);
- pragma Inline (Set_Element);
-
- function Next (Node : Node_Type) return Count_Type;
- pragma Inline (Next);
-
- procedure Set_Next (Node : in out Node_Type; Next : Count_Type);
- pragma Inline (Set_Next);
-
- function Vet (Container : Set; Position : Cursor) return Boolean
- with Inline;
-
- --------------------------
- -- Local Instantiations --
- --------------------------
-
- package HT_Ops is new Hash_Tables.Generic_Formal_Operations
- (HT_Types => HT_Types,
- Hash_Node => Hash_Node,
- Next => Next,
- Set_Next => Set_Next);
-
- package Element_Keys is new Hash_Tables.Generic_Formal_Keys
- (HT_Types => HT_Types,
- Next => Next,
- Set_Next => Set_Next,
- Key_Type => Element_Type,
- Hash => Hash,
- Equivalent_Keys => Equivalent_Keys);
-
- procedure Replace_Element is
- new Element_Keys.Generic_Replace_Element (Hash_Node, Set_Element);
-
- ---------
- -- "=" --
- ---------
-
- function "=" (Left, Right : Set) return Boolean is
- begin
- if Length (Left) /= Length (Right) then
- return False;
- end if;
-
- if Length (Left) = 0 then
- return True;
- end if;
-
- declare
- Node : Count_Type;
- ENode : Count_Type;
-
- begin
- Node := First (Left).Node;
- while Node /= 0 loop
- ENode :=
- Find
- (Container => Right,
- Item => Left.Content.Nodes (Node).Element).Node;
-
- if ENode = 0
- or else Right.Content.Nodes (ENode).Element /=
- Left.Content.Nodes (Node).Element
- then
- return False;
- end if;
-
- Node := HT_Ops.Next (Left.Content, Node);
- end loop;
-
- return True;
- end;
- end "=";
-
- ------------
- -- Assign --
- ------------
-
- procedure Assign (Target : in out Set; Source : Set) is
- procedure Insert_Element (Source_Node : Count_Type);
-
- procedure Insert_Elements is
- new HT_Ops.Generic_Iteration (Insert_Element);
-
- --------------------
- -- Insert_Element --
- --------------------
-
- procedure Insert_Element (Source_Node : Count_Type) is
- N : Node_Type renames Source.Content.Nodes (Source_Node);
- Unused_X : Count_Type;
- B : Boolean;
-
- begin
- Insert (Target, N.Element, Unused_X, B);
- pragma Assert (B);
- end Insert_Element;
-
- -- Start of processing for Assign
-
- begin
- if Target.Capacity < Length (Source) then
- raise Storage_Error with "not enough capacity"; -- SE or CE? ???
- end if;
-
- HT_Ops.Clear (Target.Content);
- Insert_Elements (Source.Content);
- end Assign;
-
- --------------
- -- Capacity --
- --------------
-
- function Capacity (Container : Set) return Count_Type is
- begin
- return Container.Content.Nodes'Length;
- end Capacity;
-
- -----------
- -- Clear --
- -----------
-
- procedure Clear (Container : in out Set) is
- begin
- HT_Ops.Clear (Container.Content);
- end Clear;
-
- ------------------------
- -- Constant_Reference --
- ------------------------
-
- function Constant_Reference
- (Container : aliased Set;
- Position : Cursor) return not null access constant Element_Type
- is
- begin
- if not Has_Element (Container, Position) then
- raise Constraint_Error with "Position cursor equals No_Element";
- end if;
-
- pragma Assert
- (Vet (Container, Position), "bad cursor in function Element");
-
- return Container.Content.Nodes (Position.Node).Element'Access;
- end Constant_Reference;
-
- --------------
- -- Contains --
- --------------
-
- function Contains (Container : Set; Item : Element_Type) return Boolean is
- begin
- return Find (Container, Item) /= No_Element;
- end Contains;
-
- ----------
- -- Copy --
- ----------
-
- function Copy
- (Source : Set;
- Capacity : Count_Type := 0) return Set
- is
- C : constant Count_Type :=
- Count_Type'Max (Capacity, Source.Capacity);
- Cu : Cursor;
- H : Hash_Type;
- N : Count_Type;
- Target : Set (C, Source.Modulus);
-
- begin
- if 0 < Capacity and then Capacity < Source.Capacity then
- raise Capacity_Error;
- end if;
-
- Target.Content.Length := Source.Content.Length;
- Target.Content.Free := Source.Content.Free;
-
- H := 1;
- while H <= Source.Modulus loop
- Target.Content.Buckets (H) := Source.Content.Buckets (H);
- H := H + 1;
- end loop;
-
- N := 1;
- while N <= Source.Capacity loop
- Target.Content.Nodes (N) := Source.Content.Nodes (N);
- N := N + 1;
- end loop;
-
- while N <= C loop
- Cu := (Node => N);
- Free (Target, Cu.Node);
- N := N + 1;
- end loop;
-
- return Target;
- end Copy;
-
- ---------------------
- -- Default_Modulus --
- ---------------------
-
- function Default_Modulus (Capacity : Count_Type) return Hash_Type is
- begin
- return To_Prime (Capacity);
- end Default_Modulus;
-
- ------------
- -- Delete --
- ------------
-
- procedure Delete (Container : in out Set; Item : Element_Type) is
- X : Count_Type;
-
- begin
- Element_Keys.Delete_Key_Sans_Free (Container.Content, Item, X);
-
- if X = 0 then
- raise Constraint_Error with "attempt to delete element not in set";
- end if;
-
- Free (Container, X);
- end Delete;
-
- procedure Delete (Container : in out Set; Position : in out Cursor) is
- begin
- if not Has_Element (Container, Position) then
- raise Constraint_Error with "Position cursor has no element";
- end if;
-
- pragma Assert (Vet (Container, Position), "bad cursor in Delete");
-
- HT_Ops.Delete_Node_Sans_Free (Container.Content, Position.Node);
- Free (Container, Position.Node);
-
- Position := No_Element;
- end Delete;
-
- ----------------
- -- Difference --
- ----------------
-
- procedure Difference (Target : in out Set; Source : Set) is
- Src_Last : Count_Type;
- Src_Length : Count_Type;
- Src_Node : Count_Type;
- Tgt_Node : Count_Type;
-
- TN : Nodes_Type renames Target.Content.Nodes;
- SN : Nodes_Type renames Source.Content.Nodes;
-
- begin
- Src_Length := Source.Content.Length;
-
- if Src_Length = 0 then
- return;
- end if;
-
- if Src_Length >= Target.Content.Length then
- Tgt_Node := HT_Ops.First (Target.Content);
- while Tgt_Node /= 0 loop
- if Element_Keys.Find (Source.Content, TN (Tgt_Node).Element) /= 0
- then
- declare
- X : constant Count_Type := Tgt_Node;
- begin
- Tgt_Node := HT_Ops.Next (Target.Content, Tgt_Node);
- HT_Ops.Delete_Node_Sans_Free (Target.Content, X);
- Free (Target, X);
- end;
-
- else
- Tgt_Node := HT_Ops.Next (Target.Content, Tgt_Node);
- end if;
- end loop;
-
- return;
- else
- Src_Node := HT_Ops.First (Source.Content);
- Src_Last := 0;
- end if;
-
- while Src_Node /= Src_Last loop
- Tgt_Node := Element_Keys.Find (Target.Content, SN (Src_Node).Element);
-
- if Tgt_Node /= 0 then
- HT_Ops.Delete_Node_Sans_Free (Target.Content, Tgt_Node);
- Free (Target, Tgt_Node);
- end if;
-
- Src_Node := HT_Ops.Next (Source.Content, Src_Node);
- end loop;
- end Difference;
-
- procedure Difference (Left : Set; Right : Set; Target : in out Set) is
- procedure Process (L_Node : Count_Type);
-
- procedure Iterate is
- new HT_Ops.Generic_Iteration (Process);
-
- -------------
- -- Process --
- -------------
-
- procedure Process (L_Node : Count_Type) is
- B : Boolean;
- E : Element_Type renames Left.Content.Nodes (L_Node).Element;
- Unused_X : Count_Type;
-
- begin
- if Find (Right, E).Node = 0 then
- Insert (Target, E, Unused_X, B);
- pragma Assert (B);
- end if;
- end Process;
-
- -- Start of processing for Difference
-
- begin
- Iterate (Left.Content);
- end Difference;
-
- function Difference (Left : Set; Right : Set) return Set is
- begin
- if Length (Left) = 0 then
- return Empty_Set;
- end if;
-
- if Length (Right) = 0 then
- return Copy (Left);
- end if;
-
- declare
- C : constant Count_Type := Length (Left);
- H : constant Hash_Type := Default_Modulus (C);
- begin
- return S : Set (C, H) do
- Difference (Left, Right, Target => S);
- end return;
- end;
- end Difference;
-
- -------------
- -- Element --
- -------------
-
- function Element
- (Container : Set;
- Position : Cursor) return Element_Type
- is
- begin
- if not Has_Element (Container, Position) then
- raise Constraint_Error with "Position cursor equals No_Element";
- end if;
-
- pragma Assert
- (Vet (Container, Position), "bad cursor in function Element");
-
- return Container.Content.Nodes (Position.Node).Element;
- end Element;
-
- ---------------------
- -- Equivalent_Sets --
- ---------------------
-
- function Equivalent_Sets (Left, Right : Set) return Boolean is
-
- function Find_Equivalent_Key
- (R_HT : Hash_Table_Type;
- L_Node : Node_Type) return Boolean;
- pragma Inline (Find_Equivalent_Key);
-
- function Is_Equivalent is
- new HT_Ops.Generic_Equal (Find_Equivalent_Key);
-
- -------------------------
- -- Find_Equivalent_Key --
- -------------------------
-
- function Find_Equivalent_Key
- (R_HT : Hash_Table_Type;
- L_Node : Node_Type) return Boolean
- is
- R_Index : constant Hash_Type :=
- Element_Keys.Index (R_HT, L_Node.Element);
- R_Node : Count_Type := R_HT.Buckets (R_Index);
- RN : Nodes_Type renames R_HT.Nodes;
-
- begin
- loop
- if R_Node = 0 then
- return False;
- end if;
-
- if Equivalent_Elements
- (L_Node.Element, RN (R_Node).Element)
- then
- return True;
- end if;
-
- R_Node := HT_Ops.Next (R_HT, R_Node);
- end loop;
- end Find_Equivalent_Key;
-
- -- Start of processing for Equivalent_Sets
-
- begin
- return Is_Equivalent (Left.Content, Right.Content);
- end Equivalent_Sets;
-
- ---------------------
- -- Equivalent_Keys --
- ---------------------
-
- function Equivalent_Keys
- (Key : Element_Type;
- Node : Node_Type) return Boolean
- is
- begin
- return Equivalent_Elements (Key, Node.Element);
- end Equivalent_Keys;
-
- -------------
- -- Exclude --
- -------------
-
- procedure Exclude (Container : in out Set; Item : Element_Type) is
- X : Count_Type;
- begin
- Element_Keys.Delete_Key_Sans_Free (Container.Content, Item, X);
- Free (Container, X);
- end Exclude;
-
- ----------
- -- Find --
- ----------
-
- function Find
- (Container : Set;
- Item : Element_Type) return Cursor
- is
- Node : constant Count_Type :=
- Element_Keys.Find (Container.Content, Item);
-
- begin
- if Node = 0 then
- return No_Element;
- end if;
-
- return (Node => Node);
- end Find;
-
- -----------
- -- First --
- -----------
-
- function First (Container : Set) return Cursor is
- Node : constant Count_Type := HT_Ops.First (Container.Content);
-
- begin
- if Node = 0 then
- return No_Element;
- end if;
-
- return (Node => Node);
- end First;
-
- ------------------
- -- Formal_Model --
- ------------------
-
- package body Formal_Model is
-
- -------------------------
- -- E_Elements_Included --
- -------------------------
-
- function E_Elements_Included
- (Left : E.Sequence;
- Right : E.Sequence) return Boolean
- is
- begin
- for I in 1 .. E.Length (Left) loop
- if not E.Contains (Right, 1, E.Length (Right), E.Get (Left, I))
- then
- return False;
- end if;
- end loop;
-
- return True;
- end E_Elements_Included;
-
- function E_Elements_Included
- (Left : E.Sequence;
- Model : M.Set;
- Right : E.Sequence) return Boolean
- is
- begin
- for I in 1 .. E.Length (Left) loop
- declare
- Item : constant Element_Type := E.Get (Left, I);
- begin
- if M.Contains (Model, Item) then
- if not E.Contains (Right, 1, E.Length (Right), Item) then
- return False;
- end if;
- end if;
- end;
- end loop;
-
- return True;
- end E_Elements_Included;
-
- function E_Elements_Included
- (Container : E.Sequence;
- Model : M.Set;
- Left : E.Sequence;
- Right : E.Sequence) return Boolean
- is
- begin
- for I in 1 .. E.Length (Container) loop
- declare
- Item : constant Element_Type := E.Get (Container, I);
- begin
- if M.Contains (Model, Item) then
- if not E.Contains (Left, 1, E.Length (Left), Item) then
- return False;
- end if;
- else
- if not E.Contains (Right, 1, E.Length (Right), Item) then
- return False;
- end if;
- end if;
- end;
- end loop;
-
- return True;
- end E_Elements_Included;
-
- ----------
- -- Find --
- ----------
-
- function Find
- (Container : E.Sequence;
- Item : Element_Type) return Count_Type
- is
- begin
- for I in 1 .. E.Length (Container) loop
- if Equivalent_Elements (Item, E.Get (Container, I)) then
- return I;
- end if;
- end loop;
- return 0;
- end Find;
-
- --------------
- -- Elements --
- --------------
-
- function Elements (Container : Set) return E.Sequence is
- Position : Count_Type := HT_Ops.First (Container.Content);
- R : E.Sequence;
-
- begin
- -- Can't use First, Next or Element here, since they depend on models
- -- for their postconditions.
-
- while Position /= 0 loop
- R := E.Add (R, Container.Content.Nodes (Position).Element);
- Position := HT_Ops.Next (Container.Content, Position);
- end loop;
-
- return R;
- end Elements;
-
- ----------------------------
- -- Lift_Abstraction_Level --
- ----------------------------
-
- procedure Lift_Abstraction_Level (Container : Set) is null;
-
- -----------------------
- -- Mapping_Preserved --
- -----------------------
-
- function Mapping_Preserved
- (E_Left : E.Sequence;
- E_Right : E.Sequence;
- P_Left : P.Map;
- P_Right : P.Map) return Boolean
- is
- begin
- for C of P_Left loop
- if not P.Has_Key (P_Right, C)
- or else P.Get (P_Left, C) > E.Length (E_Left)
- or else P.Get (P_Right, C) > E.Length (E_Right)
- or else E.Get (E_Left, P.Get (P_Left, C)) /=
- E.Get (E_Right, P.Get (P_Right, C))
- then
- return False;
- end if;
- end loop;
-
- return True;
- end Mapping_Preserved;
-
- ------------------------------
- -- Mapping_Preserved_Except --
- ------------------------------
-
- function Mapping_Preserved_Except
- (E_Left : E.Sequence;
- E_Right : E.Sequence;
- P_Left : P.Map;
- P_Right : P.Map;
- Position : Cursor) return Boolean
- is
- begin
- for C of P_Left loop
- if C /= Position
- and (not P.Has_Key (P_Right, C)
- or else P.Get (P_Left, C) > E.Length (E_Left)
- or else P.Get (P_Right, C) > E.Length (E_Right)
- or else E.Get (E_Left, P.Get (P_Left, C)) /=
- E.Get (E_Right, P.Get (P_Right, C)))
- then
- return False;
- end if;
- end loop;
-
- return True;
- end Mapping_Preserved_Except;
-
- -----------
- -- Model --
- -----------
-
- function Model (Container : Set) return M.Set is
- Position : Count_Type := HT_Ops.First (Container.Content);
- R : M.Set;
-
- begin
- -- Can't use First, Next or Element here, since they depend on models
- -- for their postconditions.
-
- while Position /= 0 loop
- R :=
- M.Add
- (Container => R,
- Item => Container.Content.Nodes (Position).Element);
-
- Position := HT_Ops.Next (Container.Content, Position);
- end loop;
-
- return R;
- end Model;
-
- ---------------
- -- Positions --
- ---------------
-
- function Positions (Container : Set) return P.Map is
- I : Count_Type := 1;
- Position : Count_Type := HT_Ops.First (Container.Content);
- R : P.Map;
-
- begin
- -- Can't use First, Next or Element here, since they depend on models
- -- for their postconditions.
-
- while Position /= 0 loop
- R := P.Add (R, (Node => Position), I);
- pragma Assert (P.Length (R) = Big (I));
- Position := HT_Ops.Next (Container.Content, Position);
- I := I + 1;
- end loop;
-
- return R;
- end Positions;
-
- end Formal_Model;
-
- ----------
- -- Free --
- ----------
-
- procedure Free (HT : in out Set; X : Count_Type) is
- begin
- if X /= 0 then
- pragma Assert (X <= HT.Capacity);
- HT.Content.Nodes (X).Has_Element := False;
- HT_Ops.Free (HT.Content, X);
- end if;
- end Free;
-
- ----------------------
- -- Generic_Allocate --
- ----------------------
-
- procedure Generic_Allocate
- (HT : in out Hash_Table_Type;
- Node : out Count_Type)
- is
- procedure Allocate is new HT_Ops.Generic_Allocate (Set_Element);
- begin
- Allocate (HT, Node);
- HT.Nodes (Node).Has_Element := True;
- end Generic_Allocate;
-
- package body Generic_Keys with SPARK_Mode => Off is
-
- -----------------------
- -- Local Subprograms --
- -----------------------
-
- function Equivalent_Key_Node
- (Key : Key_Type;
- Node : Node_Type) return Boolean;
- pragma Inline (Equivalent_Key_Node);
-
- --------------------------
- -- Local Instantiations --
- --------------------------
-
- package Key_Keys is new Hash_Tables.Generic_Formal_Keys
- (HT_Types => HT_Types,
- Next => Next,
- Set_Next => Set_Next,
- Key_Type => Key_Type,
- Hash => Hash,
- Equivalent_Keys => Equivalent_Key_Node);
-
- --------------
- -- Contains --
- --------------
-
- function Contains
- (Container : Set;
- Key : Key_Type) return Boolean
- is
- begin
- return Find (Container, Key) /= No_Element;
- end Contains;
-
- ------------
- -- Delete --
- ------------
-
- procedure Delete (Container : in out Set; Key : Key_Type) is
- X : Count_Type;
-
- begin
- Key_Keys.Delete_Key_Sans_Free (Container.Content, Key, X);
-
- if X = 0 then
- raise Constraint_Error with "attempt to delete key not in set";
- end if;
-
- Free (Container, X);
- end Delete;
-
- -------------
- -- Element --
- -------------
-
- function Element
- (Container : Set;
- Key : Key_Type) return Element_Type
- is
- Node : constant Count_Type := Find (Container, Key).Node;
-
- begin
- if Node = 0 then
- raise Constraint_Error with "key not in map";
- end if;
-
- return Container.Content.Nodes (Node).Element;
- end Element;
-
- -------------------------
- -- Equivalent_Key_Node --
- -------------------------
-
- function Equivalent_Key_Node
- (Key : Key_Type;
- Node : Node_Type) return Boolean
- is
- begin
- return Equivalent_Keys (Key, Generic_Keys.Key (Node.Element));
- end Equivalent_Key_Node;
-
- -------------
- -- Exclude --
- -------------
-
- procedure Exclude (Container : in out Set; Key : Key_Type) is
- X : Count_Type;
- begin
- Key_Keys.Delete_Key_Sans_Free (Container.Content, Key, X);
- Free (Container, X);
- end Exclude;
-
- ----------
- -- Find --
- ----------
-
- function Find
- (Container : Set;
- Key : Key_Type) return Cursor
- is
- Node : constant Count_Type := Key_Keys.Find (Container.Content, Key);
- begin
- return (if Node = 0 then No_Element else (Node => Node));
- end Find;
-
- ------------------
- -- Formal_Model --
- ------------------
-
- package body Formal_Model is
-
- -----------------------
- -- M_Included_Except --
- -----------------------
-
- function M_Included_Except
- (Left : M.Set;
- Right : M.Set;
- Key : Key_Type) return Boolean
- is
- begin
- for E of Left loop
- if not Contains (Right, E)
- and not Equivalent_Keys (Generic_Keys.Key (E), Key)
- then
- return False;
- end if;
- end loop;
-
- return True;
- end M_Included_Except;
-
- end Formal_Model;
-
- ---------
- -- Key --
- ---------
-
- function Key (Container : Set; Position : Cursor) return Key_Type is
- begin
- if not Has_Element (Container, Position) then
- raise Constraint_Error with "Position cursor has no element";
- end if;
-
- pragma Assert
- (Vet (Container, Position), "bad cursor in function Key");
-
- declare
- N : Node_Type renames Container.Content.Nodes (Position.Node);
- begin
- return Key (N.Element);
- end;
- end Key;
-
- -------------
- -- Replace --
- -------------
-
- procedure Replace
- (Container : in out Set;
- Key : Key_Type;
- New_Item : Element_Type)
- is
- Node : constant Count_Type := Key_Keys.Find (Container.Content, Key);
-
- begin
- if Node = 0 then
- raise Constraint_Error with "attempt to replace key not in set";
- end if;
-
- Replace_Element (Container.Content, Node, New_Item);
- end Replace;
-
- end Generic_Keys;
-
- -----------------
- -- Has_Element --
- -----------------
-
- function Has_Element (Container : Set; Position : Cursor) return Boolean is
- begin
- if Position.Node = 0
- or else not Container.Content.Nodes (Position.Node).Has_Element
- then
- return False;
- end if;
-
- return True;
- end Has_Element;
-
- ---------------
- -- Hash_Node --
- ---------------
-
- function Hash_Node (Node : Node_Type) return Hash_Type is
- begin
- return Hash (Node.Element);
- end Hash_Node;
-
- -------------
- -- Include --
- -------------
-
- procedure Include (Container : in out Set; New_Item : Element_Type) is
- Inserted : Boolean;
- Position : Cursor;
-
- begin
- Insert (Container, New_Item, Position, Inserted);
-
- if not Inserted then
- Container.Content.Nodes (Position.Node).Element := New_Item;
- end if;
- end Include;
-
- ------------
- -- Insert --
- ------------
-
- procedure Insert
- (Container : in out Set;
- New_Item : Element_Type;
- Position : out Cursor;
- Inserted : out Boolean)
- is
- begin
- Insert (Container, New_Item, Position.Node, Inserted);
- end Insert;
-
- procedure Insert (Container : in out Set; New_Item : Element_Type) is
- Inserted : Boolean;
- Unused_Position : Cursor;
-
- begin
- Insert (Container, New_Item, Unused_Position, Inserted);
-
- if not Inserted then
- raise Constraint_Error with
- "attempt to insert element already in set";
- end if;
- end Insert;
-
- procedure Insert
- (Container : in out Set;
- New_Item : Element_Type;
- Node : out Count_Type;
- Inserted : out Boolean)
- is
- procedure Allocate_Set_Element (Node : in out Node_Type);
- pragma Inline (Allocate_Set_Element);
-
- procedure New_Node
- (HT : in out Hash_Table_Type;
- Node : out Count_Type);
- pragma Inline (New_Node);
-
- procedure Local_Insert is
- new Element_Keys.Generic_Conditional_Insert (New_Node);
-
- procedure Allocate is
- new Generic_Allocate (Allocate_Set_Element);
-
- ---------------------------
- -- Allocate_Set_Element --
- ---------------------------
-
- procedure Allocate_Set_Element (Node : in out Node_Type) is
- begin
- Node.Element := New_Item;
- end Allocate_Set_Element;
-
- --------------
- -- New_Node --
- --------------
-
- procedure New_Node
- (HT : in out Hash_Table_Type;
- Node : out Count_Type)
- is
- begin
- Allocate (HT, Node);
- end New_Node;
-
- -- Start of processing for Insert
-
- begin
- Local_Insert (Container.Content, New_Item, Node, Inserted);
- end Insert;
-
- ------------------
- -- Intersection --
- ------------------
-
- procedure Intersection (Target : in out Set; Source : Set) is
- Tgt_Node : Count_Type;
- TN : Nodes_Type renames Target.Content.Nodes;
-
- begin
- if Source.Content.Length = 0 then
- Clear (Target);
- return;
- end if;
-
- Tgt_Node := HT_Ops.First (Target.Content);
- while Tgt_Node /= 0 loop
- if Find (Source, TN (Tgt_Node).Element).Node /= 0 then
- Tgt_Node := HT_Ops.Next (Target.Content, Tgt_Node);
-
- else
- declare
- X : constant Count_Type := Tgt_Node;
- begin
- Tgt_Node := HT_Ops.Next (Target.Content, Tgt_Node);
- HT_Ops.Delete_Node_Sans_Free (Target.Content, X);
- Free (Target, X);
- end;
- end if;
- end loop;
- end Intersection;
-
- procedure Intersection (Left : Set; Right : Set; Target : in out Set) is
- procedure Process (L_Node : Count_Type);
-
- procedure Iterate is
- new HT_Ops.Generic_Iteration (Process);
-
- -------------
- -- Process --
- -------------
-
- procedure Process (L_Node : Count_Type) is
- E : Element_Type renames Left.Content.Nodes (L_Node).Element;
- Unused_X : Count_Type;
- B : Boolean;
-
- begin
- if Find (Right, E).Node /= 0 then
- Insert (Target, E, Unused_X, B);
- pragma Assert (B);
- end if;
- end Process;
-
- -- Start of processing for Intersection
-
- begin
- Iterate (Left.Content);
- end Intersection;
-
- function Intersection (Left : Set; Right : Set) return Set is
- C : constant Count_Type :=
- Count_Type'Min (Length (Left), Length (Right)); -- ???
- H : constant Hash_Type := Default_Modulus (C);
-
- begin
- return S : Set (C, H) do
- if Length (Left) /= 0 and Length (Right) /= 0 then
- Intersection (Left, Right, Target => S);
- end if;
- end return;
- end Intersection;
-
- --------------
- -- Is_Empty --
- --------------
-
- function Is_Empty (Container : Set) return Boolean is
- begin
- return Length (Container) = 0;
- end Is_Empty;
-
- -----------
- -- Is_In --
- -----------
-
- function Is_In (HT : Set; Key : Node_Type) return Boolean is
- begin
- return Element_Keys.Find (HT.Content, Key.Element) /= 0;
- end Is_In;
-
- ---------------
- -- Is_Subset --
- ---------------
-
- function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is
- Subset_Node : Count_Type;
- Subset_Nodes : Nodes_Type renames Subset.Content.Nodes;
-
- begin
- if Length (Subset) > Length (Of_Set) then
- return False;
- end if;
-
- Subset_Node := First (Subset).Node;
- while Subset_Node /= 0 loop
- declare
- S : constant Count_Type := Subset_Node;
- N : Node_Type renames Subset_Nodes (S);
- E : Element_Type renames N.Element;
-
- begin
- if Find (Of_Set, E).Node = 0 then
- return False;
- end if;
- end;
-
- Subset_Node := HT_Ops.Next (Subset.Content, Subset_Node);
- end loop;
-
- return True;
- end Is_Subset;
-
- ------------
- -- Length --
- ------------
-
- function Length (Container : Set) return Count_Type is
- begin
- return Container.Content.Length;
- end Length;
-
- ----------
- -- Move --
- ----------
-
- -- Comments???
-
- procedure Move (Target : in out Set; Source : in out Set) is
- NN : HT_Types.Nodes_Type renames Source.Content.Nodes;
- X, Y : Count_Type;
-
- begin
- if Target.Capacity < Length (Source) then
- raise Constraint_Error with -- ???
- "Source length exceeds Target capacity";
- end if;
-
- Clear (Target);
-
- if Source.Content.Length = 0 then
- return;
- end if;
-
- X := HT_Ops.First (Source.Content);
- while X /= 0 loop
- Insert (Target, NN (X).Element); -- optimize???
-
- Y := HT_Ops.Next (Source.Content, X);
-
- HT_Ops.Delete_Node_Sans_Free (Source.Content, X);
- Free (Source, X);
-
- X := Y;
- end loop;
- end Move;
-
- ----------
- -- Next --
- ----------
-
- function Next (Node : Node_Type) return Count_Type is
- begin
- return Node.Next;
- end Next;
-
- function Next (Container : Set; Position : Cursor) return Cursor is
- begin
- if Position.Node = 0 then
- return No_Element;
- end if;
-
- if not Has_Element (Container, Position) then
- raise Constraint_Error with "Position has no element";
- end if;
-
- pragma Assert (Vet (Container, Position), "bad cursor in Next");
-
- return (Node => HT_Ops.Next (Container.Content, Position.Node));
- end Next;
-
- procedure Next (Container : Set; Position : in out Cursor) is
- begin
- Position := Next (Container, Position);
- end Next;
-
- -------------
- -- Overlap --
- -------------
-
- function Overlap (Left, Right : Set) return Boolean is
- Left_Node : Count_Type;
- Left_Nodes : Nodes_Type renames Left.Content.Nodes;
-
- begin
- if Length (Right) = 0 or Length (Left) = 0 then
- return False;
- end if;
-
- Left_Node := First (Left).Node;
- while Left_Node /= 0 loop
- declare
- L : constant Count_Type := Left_Node;
- N : Node_Type renames Left_Nodes (L);
- E : Element_Type renames N.Element;
- begin
- if Find (Right, E).Node /= 0 then
- return True;
- end if;
- end;
-
- Left_Node := HT_Ops.Next (Left.Content, Left_Node);
- end loop;
-
- return False;
- end Overlap;
-
- -------------
- -- Replace --
- -------------
-
- procedure Replace (Container : in out Set; New_Item : Element_Type) is
- Node : constant Count_Type :=
- Element_Keys.Find (Container.Content, New_Item);
-
- begin
- if Node = 0 then
- raise Constraint_Error with "attempt to replace element not in set";
- end if;
-
- Container.Content.Nodes (Node).Element := New_Item;
- end Replace;
-
- ---------------------
- -- Replace_Element --
- ---------------------
-
- procedure Replace_Element
- (Container : in out Set;
- Position : Cursor;
- New_Item : Element_Type)
- is
- begin
- if not Has_Element (Container, Position) then
- raise Constraint_Error with "Position cursor equals No_Element";
- end if;
-
- pragma Assert
- (Vet (Container, Position), "bad cursor in Replace_Element");
-
- Replace_Element (Container.Content, Position.Node, New_Item);
- end Replace_Element;
-
- ----------------------
- -- Reserve_Capacity --
- ----------------------
-
- procedure Reserve_Capacity
- (Container : in out Set;
- Capacity : Count_Type)
- is
- begin
- if Capacity > Container.Capacity then
- raise Constraint_Error with "requested capacity is too large";
- end if;
- end Reserve_Capacity;
-
- ------------------
- -- Set_Element --
- ------------------
-
- procedure Set_Element (Node : in out Node_Type; Item : Element_Type) is
- begin
- Node.Element := Item;
- end Set_Element;
-
- --------------
- -- Set_Next --
- --------------
-
- procedure Set_Next (Node : in out Node_Type; Next : Count_Type) is
- begin
- Node.Next := Next;
- end Set_Next;
-
- --------------------------
- -- Symmetric_Difference --
- --------------------------
-
- procedure Symmetric_Difference (Target : in out Set; Source : Set) is
- procedure Process (Source_Node : Count_Type);
- pragma Inline (Process);
-
- procedure Iterate is new HT_Ops.Generic_Iteration (Process);
-
- -------------
- -- Process --
- -------------
-
- procedure Process (Source_Node : Count_Type) is
- B : Boolean;
- N : Node_Type renames Source.Content.Nodes (Source_Node);
- Unused_X : Count_Type;
-
- begin
- if Is_In (Target, N) then
- Delete (Target, N.Element);
- else
- Insert (Target, N.Element, Unused_X, B);
- pragma Assert (B);
- end if;
- end Process;
-
- -- Start of processing for Symmetric_Difference
-
- begin
- if Length (Target) = 0 then
- Assign (Target, Source);
- return;
- end if;
-
- Iterate (Source.Content);
- end Symmetric_Difference;
-
- function Symmetric_Difference (Left : Set; Right : Set) return Set is
- begin
- if Length (Right) = 0 then
- return Copy (Left);
- end if;
-
- if Length (Left) = 0 then
- return Copy (Right);
- end if;
-
- declare
- C : constant Count_Type := Length (Left) + Length (Right);
- H : constant Hash_Type := Default_Modulus (C);
- begin
- return S : Set (C, H) do
- Difference (Left, Right, S);
- Difference (Right, Left, S);
- end return;
- end;
- end Symmetric_Difference;
-
- ------------
- -- To_Set --
- ------------
-
- function To_Set (New_Item : Element_Type) return Set is
- Unused_X : Count_Type;
- B : Boolean;
-
- begin
- return S : Set (Capacity => 1, Modulus => 1) do
- Insert (S, New_Item, Unused_X, B);
- pragma Assert (B);
- end return;
- end To_Set;
-
- -----------
- -- Union --
- -----------
-
- procedure Union (Target : in out Set; Source : Set) is
- procedure Process (Src_Node : Count_Type);
-
- procedure Iterate is
- new HT_Ops.Generic_Iteration (Process);
-
- -------------
- -- Process --
- -------------
-
- procedure Process (Src_Node : Count_Type) is
- N : Node_Type renames Source.Content.Nodes (Src_Node);
- E : Element_Type renames N.Element;
-
- Unused_X : Count_Type;
- Unused_B : Boolean;
-
- begin
- Insert (Target, E, Unused_X, Unused_B);
- end Process;
-
- -- Start of processing for Union
-
- begin
- Iterate (Source.Content);
- end Union;
-
- function Union (Left : Set; Right : Set) return Set is
- begin
- if Length (Right) = 0 then
- return Copy (Left);
- end if;
-
- if Length (Left) = 0 then
- return Copy (Right);
- end if;
-
- declare
- C : constant Count_Type := Length (Left) + Length (Right);
- H : constant Hash_Type := Default_Modulus (C);
- begin
- return S : Set (C, H) do
- Assign (Target => S, Source => Left);
- Union (Target => S, Source => Right);
- end return;
- end;
- end Union;
-
- ---------
- -- Vet --
- ---------
-
- function Vet (Container : Set; Position : Cursor) return Boolean is
- begin
- if not Container_Checks'Enabled then
- return True;
- end if;
-
- if Position.Node = 0 then
- return True;
- end if;
-
- declare
- S : Set renames Container;
- N : Nodes_Type renames S.Content.Nodes;
- X : Count_Type;
-
- begin
- if S.Content.Length = 0 then
- return False;
- end if;
-
- if Position.Node > N'Last then
- return False;
- end if;
-
- if N (Position.Node).Next = Position.Node then
- return False;
- end if;
-
- X := S.Content.Buckets
- (Element_Keys.Index (S.Content, N (Position.Node).Element));
-
- for J in 1 .. S.Content.Length loop
- if X = Position.Node then
- return True;
- end if;
-
- if X = 0 then
- return False;
- end if;
-
- if X = N (X).Next then -- to prevent unnecessary looping
- return False;
- end if;
-
- X := N (X).Next;
- end loop;
-
- return False;
- end;
- end Vet;
-
-end Ada.Containers.Formal_Hashed_Sets;
diff --git a/gcc/ada/libgnat/a-cfhase.ads b/gcc/ada/libgnat/a-cfhase.ads
index 248a0ac..633ed20 100644
--- a/gcc/ada/libgnat/a-cfhase.ads
+++ b/gcc/ada/libgnat/a-cfhase.ads
@@ -29,1475 +29,12 @@
-- <http://www.gnu.org/licenses/>. --
------------------------------------------------------------------------------
--- This spec is derived from package Ada.Containers.Bounded_Hashed_Sets in the
--- Ada 2012 RM. The modifications are meant to facilitate formal proofs by
--- making it easier to express properties, and by making the specification of
--- this unit compatible with SPARK 2014. Note that the API of this unit may be
--- subject to incompatible changes as SPARK 2014 evolves.
-
--- The modifications are:
-
--- A parameter for the container is added to every function reading the
--- content of a container: Element, Next, Query_Element, Has_Element, Key,
--- Iterate, Equivalent_Elements. This change is motivated by the need to
--- have cursors which are valid on different containers (typically a
--- container C and its previous version C'Old) for expressing properties,
--- which is not possible if cursors encapsulate an access to the underlying
--- container.
-
-with Ada.Containers.Functional_Maps;
-with Ada.Containers.Functional_Sets;
-with Ada.Containers.Functional_Vectors;
-with Ada.Numerics.Big_Numbers.Big_Integers;
-use Ada.Numerics.Big_Numbers.Big_Integers;
-private with Ada.Containers.Hash_Tables;
-
generic
- type Element_Type is private;
-
- with function Hash (Element : Element_Type) return Hash_Type;
-
- with function Equivalent_Elements
- (Left : Element_Type;
- Right : Element_Type) return Boolean is "=";
-
-package Ada.Containers.Formal_Hashed_Sets with
- SPARK_Mode,
- Annotate => (GNATprove, Always_Return)
-is
-
- -- Contracts in this unit are meant for analysis only, not for run-time
- -- checking.
-
- pragma Assertion_Policy (Pre => Ignore);
- pragma Assertion_Policy (Post => Ignore);
- pragma Assertion_Policy (Contract_Cases => Ignore);
- pragma Annotate (CodePeer, Skip_Analysis);
-
- -- Convert Count_Type to Big_Interger.
-
- package Conversions is new Signed_Conversions (Int => Count_Type);
-
- function Big (J : Count_Type) return Big_Integer renames
- Conversions.To_Big_Integer;
-
- type Set (Capacity : Count_Type; Modulus : Hash_Type) is private with
- Iterable => (First => First,
- Next => Next,
- Has_Element => Has_Element,
- Element => Element),
- Default_Initial_Condition => Is_Empty (Set);
- pragma Preelaborable_Initialization (Set);
-
- type Cursor is record
- Node : Count_Type;
- end record;
-
- No_Element : constant Cursor := (Node => 0);
-
- function Length (Container : Set) return Count_Type with
- Global => null,
- Post => Length'Result <= Container.Capacity;
-
- pragma Unevaluated_Use_Of_Old (Allow);
-
- package Formal_Model with Ghost is
- subtype Positive_Count_Type is Count_Type range 1 .. Count_Type'Last;
-
- package M is new Ada.Containers.Functional_Sets
- (Element_Type => Element_Type,
- Equivalent_Elements => Equivalent_Elements);
-
- function "="
- (Left : M.Set;
- Right : M.Set) return Boolean renames M."=";
-
- function "<="
- (Left : M.Set;
- Right : M.Set) return Boolean renames M."<=";
-
- package E is new Ada.Containers.Functional_Vectors
- (Element_Type => Element_Type,
- Index_Type => Positive_Count_Type);
-
- function "="
- (Left : E.Sequence;
- Right : E.Sequence) return Boolean renames E."=";
-
- function "<"
- (Left : E.Sequence;
- Right : E.Sequence) return Boolean renames E."<";
-
- function "<="
- (Left : E.Sequence;
- Right : E.Sequence) return Boolean renames E."<=";
-
- function Find
- (Container : E.Sequence;
- Item : Element_Type) return Count_Type
- -- Search for Item in Container
-
- with
- Global => null,
- Post =>
- (if Find'Result > 0 then
- Find'Result <= E.Length (Container)
- and Equivalent_Elements
- (Item, E.Get (Container, Find'Result)));
-
- function E_Elements_Included
- (Left : E.Sequence;
- Right : E.Sequence) return Boolean
- -- The elements of Left are contained in Right
-
- with
- Global => null,
- Post =>
- E_Elements_Included'Result =
- (for all I in 1 .. E.Length (Left) =>
- Find (Right, E.Get (Left, I)) > 0
- and then E.Get (Right, Find (Right, E.Get (Left, I))) =
- E.Get (Left, I));
- pragma Annotate (GNATprove, Inline_For_Proof, E_Elements_Included);
-
- function E_Elements_Included
- (Left : E.Sequence;
- Model : M.Set;
- Right : E.Sequence) return Boolean
- -- The elements of Container contained in Model are in Right
-
- with
- Global => null,
- Post =>
- E_Elements_Included'Result =
- (for all I in 1 .. E.Length (Left) =>
- (if M.Contains (Model, E.Get (Left, I)) then
- Find (Right, E.Get (Left, I)) > 0
- and then E.Get (Right, Find (Right, E.Get (Left, I))) =
- E.Get (Left, I)));
- pragma Annotate (GNATprove, Inline_For_Proof, E_Elements_Included);
-
- function E_Elements_Included
- (Container : E.Sequence;
- Model : M.Set;
- Left : E.Sequence;
- Right : E.Sequence) return Boolean
- -- The elements of Container contained in Model are in Left and others
- -- are in Right.
-
- with
- Global => null,
- Post =>
- E_Elements_Included'Result =
- (for all I in 1 .. E.Length (Container) =>
- (if M.Contains (Model, E.Get (Container, I)) then
- Find (Left, E.Get (Container, I)) > 0
- and then E.Get (Left, Find (Left, E.Get (Container, I))) =
- E.Get (Container, I)
- else
- Find (Right, E.Get (Container, I)) > 0
- and then E.Get
- (Right, Find (Right, E.Get (Container, I))) =
- E.Get (Container, I)));
- pragma Annotate (GNATprove, Inline_For_Proof, E_Elements_Included);
-
- package P is new Ada.Containers.Functional_Maps
- (Key_Type => Cursor,
- Element_Type => Positive_Count_Type,
- Equivalent_Keys => "=",
- Enable_Handling_Of_Equivalence => False);
-
- function "="
- (Left : P.Map;
- Right : P.Map) return Boolean renames P."=";
-
- function "<="
- (Left : P.Map;
- Right : P.Map) return Boolean renames P."<=";
-
- function Mapping_Preserved
- (E_Left : E.Sequence;
- E_Right : E.Sequence;
- P_Left : P.Map;
- P_Right : P.Map) return Boolean
- with
- Ghost,
- Global => null,
- Post =>
- (if Mapping_Preserved'Result then
-
- -- Right contains all the cursors of Left
-
- P.Keys_Included (P_Left, P_Right)
-
- -- Right contains all the elements of Left
-
- and E_Elements_Included (E_Left, E_Right)
-
- -- Mappings from cursors to elements induced by E_Left, P_Left
- -- and E_Right, P_Right are the same.
-
- and (for all C of P_Left =>
- E.Get (E_Left, P.Get (P_Left, C)) =
- E.Get (E_Right, P.Get (P_Right, C))));
-
- function Mapping_Preserved_Except
- (E_Left : E.Sequence;
- E_Right : E.Sequence;
- P_Left : P.Map;
- P_Right : P.Map;
- Position : Cursor) return Boolean
- with
- Ghost,
- Global => null,
- Post =>
- (if Mapping_Preserved_Except'Result then
-
- -- Right contains all the cursors of Left
-
- P.Keys_Included (P_Left, P_Right)
-
- -- Mappings from cursors to elements induced by E_Left, P_Left
- -- and E_Right, P_Right are the same except for Position.
-
- and (for all C of P_Left =>
- (if C /= Position then
- E.Get (E_Left, P.Get (P_Left, C)) =
- E.Get (E_Right, P.Get (P_Right, C)))));
-
- function Model (Container : Set) return M.Set with
- -- The high-level model of a set is a set of elements. Neither cursors
- -- nor order of elements are represented in this model. Elements are
- -- modeled up to equivalence.
-
- Ghost,
- Global => null,
- Post => M.Length (Model'Result) = Big (Length (Container));
-
- function Elements (Container : Set) return E.Sequence with
- -- The Elements sequence represents the underlying list structure of
- -- sets that is used for iteration. It stores the actual values of
- -- elements in the set. It does not model cursors.
-
- Ghost,
- Global => null,
- Post =>
- E.Length (Elements'Result) = Length (Container)
-
- -- It only contains keys contained in Model
-
- and (for all Item of Elements'Result =>
- M.Contains (Model (Container), Item))
-
- -- It contains all the elements contained in Model
-
- and (for all Item of Model (Container) =>
- (Find (Elements'Result, Item) > 0
- and then Equivalent_Elements
- (E.Get (Elements'Result,
- Find (Elements'Result, Item)),
- Item)))
-
- -- It has no duplicate
-
- and (for all I in 1 .. Length (Container) =>
- Find (Elements'Result, E.Get (Elements'Result, I)) = I)
-
- and (for all I in 1 .. Length (Container) =>
- (for all J in 1 .. Length (Container) =>
- (if Equivalent_Elements
- (E.Get (Elements'Result, I),
- E.Get (Elements'Result, J))
- then I = J)));
- pragma Annotate (GNATprove, Iterable_For_Proof, "Model", Elements);
-
- function Positions (Container : Set) return P.Map with
- -- The Positions map is used to model cursors. It only contains valid
- -- cursors and maps them to their position in the container.
-
- Ghost,
- Global => null,
- Post =>
- not P.Has_Key (Positions'Result, No_Element)
-
- -- Positions of cursors are smaller than the container's length
-
- and then
- (for all I of Positions'Result =>
- P.Get (Positions'Result, I) in 1 .. Length (Container)
-
- -- No two cursors have the same position. Note that we do not
- -- state that there is a cursor in the map for each position, as
- -- it is rarely needed.
-
- and then
- (for all J of Positions'Result =>
- (if P.Get (Positions'Result, I) = P.Get (Positions'Result, J)
- then I = J)));
-
- procedure Lift_Abstraction_Level (Container : Set) with
- -- Lift_Abstraction_Level is a ghost procedure that does nothing but
- -- assume that we can access the same elements by iterating over
- -- positions or cursors.
- -- This information is not generally useful except when switching from
- -- a low-level, cursor-aware view of a container, to a high-level,
- -- position-based view.
-
- Ghost,
- Global => null,
- Post =>
- (for all Item of Elements (Container) =>
- (for some I of Positions (Container) =>
- E.Get (Elements (Container), P.Get (Positions (Container), I)) =
- Item));
-
- function Contains
- (C : M.Set;
- K : Element_Type) return Boolean renames M.Contains;
- -- To improve readability of contracts, we rename the function used to
- -- search for an element in the model to Contains.
-
- end Formal_Model;
- use Formal_Model;
-
- Empty_Set : constant Set;
-
- function "=" (Left, Right : Set) return Boolean with
- Global => null,
- Post =>
- "="'Result =
- (Length (Left) = Length (Right)
- and E_Elements_Included (Elements (Left), Elements (Right)))
- and
- "="'Result =
- (E_Elements_Included (Elements (Left), Elements (Right))
- and E_Elements_Included (Elements (Right), Elements (Left)));
- -- For each element in Left, set equality attempts to find the equal
- -- element in Right; if a search fails, then set equality immediately
- -- returns False. The search works by calling Hash to find the bucket in
- -- the Right set that corresponds to the Left element. If the bucket is
- -- non-empty, the search calls the generic formal element equality operator
- -- to compare the element (in Left) to the element of each node in the
- -- bucket (in Right); the search terminates when a matching node in the
- -- bucket is found, or the nodes in the bucket are exhausted. (Note that
- -- element equality is called here, not Equivalent_Elements. Set equality
- -- is the only operation in which element equality is used. Compare set
- -- equality to Equivalent_Sets, which does call Equivalent_Elements.)
-
- function Equivalent_Sets (Left, Right : Set) return Boolean with
- Global => null,
- Post => Equivalent_Sets'Result = (Model (Left) = Model (Right));
- -- Similar to set equality, with the difference that the element in Left is
- -- compared to the elements in Right using the generic formal
- -- Equivalent_Elements operation instead of element equality.
-
- function To_Set (New_Item : Element_Type) return Set with
- Global => null,
- Post =>
- M.Is_Singleton (Model (To_Set'Result), New_Item)
- and Length (To_Set'Result) = 1
- and E.Get (Elements (To_Set'Result), 1) = New_Item;
- -- Constructs a singleton set comprising New_Element. To_Set calls Hash to
- -- determine the bucket for New_Item.
-
- function Capacity (Container : Set) return Count_Type with
- Global => null,
- Post => Capacity'Result = Container.Capacity;
- -- Returns the current capacity of the set. Capacity is the maximum length
- -- before which rehashing in guaranteed not to occur.
-
- procedure Reserve_Capacity
- (Container : in out Set;
- Capacity : Count_Type)
- with
- Global => null,
- Pre => Capacity <= Container.Capacity,
- Post =>
- Model (Container) = Model (Container)'Old
- and Length (Container)'Old = Length (Container)
-
- -- Actual elements are preserved
-
- and E_Elements_Included
- (Elements (Container), Elements (Container)'Old)
- and E_Elements_Included
- (Elements (Container)'Old, Elements (Container));
- -- If the value of the Capacity actual parameter is less or equal to
- -- Container.Capacity, then the operation has no effect. Otherwise it
- -- raises Capacity_Error (as no expansion of capacity is possible for a
- -- bounded form).
-
- function Is_Empty (Container : Set) return Boolean with
- Global => null,
- Post => Is_Empty'Result = (Length (Container) = 0);
- -- Equivalent to Length (Container) = 0
-
- procedure Clear (Container : in out Set) with
- Global => null,
- Post => Length (Container) = 0 and M.Is_Empty (Model (Container));
- -- Removes all of the items from the set. This will deallocate all memory
- -- associated with this set.
-
- procedure Assign (Target : in out Set; Source : Set) with
- Global => null,
- Pre => Target.Capacity >= Length (Source),
- Post =>
- Model (Target) = Model (Source)
- and Length (Target) = Length (Source)
-
- -- Actual elements are preserved
-
- and E_Elements_Included (Elements (Target), Elements (Source))
- and E_Elements_Included (Elements (Source), Elements (Target));
- -- If Target denotes the same object as Source, then the operation has no
- -- effect. If the Target capacity is less than the Source length, then
- -- Assign raises Capacity_Error. Otherwise, Assign clears Target and then
- -- copies the (active) elements from Source to Target.
-
- function Copy
- (Source : Set;
- Capacity : Count_Type := 0) return Set
- with
- Global => null,
- Pre => Capacity = 0 or else Capacity >= Source.Capacity,
- Post =>
- Model (Copy'Result) = Model (Source)
- and Elements (Copy'Result) = Elements (Source)
- and Positions (Copy'Result) = Positions (Source)
- and (if Capacity = 0 then
- Copy'Result.Capacity = Source.Capacity
- else
- Copy'Result.Capacity = Capacity);
- -- Constructs a new set object whose elements correspond to Source. If the
- -- Capacity parameter is 0, then the capacity of the result is the same as
- -- the length of Source. If the Capacity parameter is equal or greater than
- -- the length of Source, then the capacity of the result is the specified
- -- value. Otherwise, Copy raises Capacity_Error. If the Modulus parameter
- -- is 0, then the modulus of the result is the value returned by a call to
- -- Default_Modulus with the capacity parameter determined as above;
- -- otherwise the modulus of the result is the specified value.
-
- function Element
- (Container : Set;
- Position : Cursor) return Element_Type
- with
- Global => null,
- Pre => Has_Element (Container, Position),
- Post =>
- Element'Result =
- E.Get (Elements (Container), P.Get (Positions (Container), Position));
- pragma Annotate (GNATprove, Inline_For_Proof, Element);
-
- procedure Replace_Element
- (Container : in out Set;
- Position : Cursor;
- New_Item : Element_Type)
- with
- Global => null,
- Pre => Has_Element (Container, Position),
- Post =>
- Length (Container) = Length (Container)'Old
-
- -- Position now maps to New_Item
-
- and Element (Container, Position) = New_Item
-
- -- New_Item is contained in Container
-
- and Contains (Model (Container), New_Item)
-
- -- Other elements are preserved
-
- and M.Included_Except
- (Model (Container)'Old,
- Model (Container),
- Element (Container, Position)'Old)
- and M.Included_Except
- (Model (Container),
- Model (Container)'Old,
- New_Item)
-
- -- Mapping from cursors to elements is preserved
-
- and Mapping_Preserved_Except
- (E_Left => Elements (Container)'Old,
- E_Right => Elements (Container),
- P_Left => Positions (Container)'Old,
- P_Right => Positions (Container),
- Position => Position)
- and Positions (Container) = Positions (Container)'Old;
-
- function Constant_Reference
- (Container : aliased Set;
- Position : Cursor) return not null access constant Element_Type
- with
- Global => null,
- Pre => Has_Element (Container, Position),
- Post =>
- Constant_Reference'Result.all =
- E.Get (Elements (Container), P.Get (Positions (Container), Position));
-
- procedure Move (Target : in out Set; Source : in out Set) with
- Global => null,
- Pre => Target.Capacity >= Length (Source),
- Post =>
- Length (Source) = 0
- and Model (Target) = Model (Source)'Old
- and Length (Target) = Length (Source)'Old
-
- -- Actual elements are preserved
-
- and E_Elements_Included (Elements (Target), Elements (Source)'Old)
- and E_Elements_Included (Elements (Source)'Old, Elements (Target));
- -- Clears Target (if it's not empty), and then moves (not copies) the
- -- buckets array and nodes from Source to Target.
-
- procedure Insert
- (Container : in out Set;
- New_Item : Element_Type;
- Position : out Cursor;
- Inserted : out Boolean)
- with
- Global => null,
- Pre =>
- Length (Container) < Container.Capacity
- or Contains (Container, New_Item),
- Post =>
- Contains (Container, New_Item)
- and Has_Element (Container, Position)
- and Equivalent_Elements (Element (Container, Position), New_Item),
- Contract_Cases =>
-
- -- If New_Item is already in Container, it is not modified and Inserted
- -- is set to False.
-
- (Contains (Container, New_Item) =>
- not Inserted
- and Model (Container) = Model (Container)'Old
- and Elements (Container) = Elements (Container)'Old
- and Positions (Container) = Positions (Container)'Old,
-
- -- Otherwise, New_Item is inserted in Container and Inserted is set to
- -- True.
-
- others =>
- Inserted
- and Length (Container) = Length (Container)'Old + 1
-
- -- Position now maps to New_Item
-
- and Element (Container, Position) = New_Item
-
- -- Other elements are preserved
-
- and Model (Container)'Old <= Model (Container)
- and M.Included_Except
- (Model (Container),
- Model (Container)'Old,
- New_Item)
-
- -- Mapping from cursors to elements is preserved
-
- and Mapping_Preserved
- (E_Left => Elements (Container)'Old,
- E_Right => Elements (Container),
- P_Left => Positions (Container)'Old,
- P_Right => Positions (Container))
- and P.Keys_Included_Except
- (Positions (Container),
- Positions (Container)'Old,
- Position));
- -- Conditionally inserts New_Item into the set. If New_Item is already in
- -- the set, then Inserted returns False and Position designates the node
- -- containing the existing element (which is not modified). If New_Item is
- -- not already in the set, then Inserted returns True and Position
- -- designates the newly-inserted node containing New_Item. The search for
- -- an existing element works as follows. Hash is called to determine
- -- New_Item's bucket; if the bucket is non-empty, then Equivalent_Elements
- -- is called to compare New_Item to the element of each node in that
- -- bucket. If the bucket is empty, or there were no equivalent elements in
- -- the bucket, the search "fails" and the New_Item is inserted in the set
- -- (and Inserted returns True); otherwise, the search "succeeds" (and
- -- Inserted returns False).
-
- procedure Insert (Container : in out Set; New_Item : Element_Type) with
- Global => null,
- Pre => Length (Container) < Container.Capacity
- and then (not Contains (Container, New_Item)),
- Post =>
- Length (Container) = Length (Container)'Old + 1
- and Contains (Container, New_Item)
- and Element (Container, Find (Container, New_Item)) = New_Item
-
- -- Other elements are preserved
-
- and Model (Container)'Old <= Model (Container)
- and M.Included_Except
- (Model (Container),
- Model (Container)'Old,
- New_Item)
-
- -- Mapping from cursors to elements is preserved
-
- and Mapping_Preserved
- (E_Left => Elements (Container)'Old,
- E_Right => Elements (Container),
- P_Left => Positions (Container)'Old,
- P_Right => Positions (Container))
- and P.Keys_Included_Except
- (Positions (Container),
- Positions (Container)'Old,
- Find (Container, New_Item));
- -- Attempts to insert New_Item into the set, performing the usual insertion
- -- search (which involves calling both Hash and Equivalent_Elements); if
- -- the search succeeds (New_Item is equivalent to an element already in the
- -- set, and so was not inserted), then this operation raises
- -- Constraint_Error. (This version of Insert is similar to Replace, but
- -- having the opposite exception behavior. It is intended for use when you
- -- want to assert that the item is not already in the set.)
-
- procedure Include (Container : in out Set; New_Item : Element_Type) with
- Global => null,
- Pre =>
- Length (Container) < Container.Capacity
- or Contains (Container, New_Item),
- Post =>
- Contains (Container, New_Item)
- and Element (Container, Find (Container, New_Item)) = New_Item,
- Contract_Cases =>
-
- -- If an element equivalent to New_Item is already in Container, it is
- -- replaced by New_Item.
-
- (Contains (Container, New_Item) =>
-
- -- Elements are preserved modulo equivalence
-
- Model (Container) = Model (Container)'Old
-
- -- Cursors are preserved
-
- and Positions (Container) = Positions (Container)'Old
-
- -- The actual value of other elements is preserved
-
- and E.Equal_Except
- (Elements (Container)'Old,
- Elements (Container),
- P.Get (Positions (Container), Find (Container, New_Item))),
-
- -- Otherwise, New_Item is inserted in Container
-
- others =>
- Length (Container) = Length (Container)'Old + 1
-
- -- Other elements are preserved
-
- and Model (Container)'Old <= Model (Container)
- and M.Included_Except
- (Model (Container),
- Model (Container)'Old,
- New_Item)
-
- -- Mapping from cursors to elements is preserved
-
- and Mapping_Preserved
- (E_Left => Elements (Container)'Old,
- E_Right => Elements (Container),
- P_Left => Positions (Container)'Old,
- P_Right => Positions (Container))
- and P.Keys_Included_Except
- (Positions (Container),
- Positions (Container)'Old,
- Find (Container, New_Item)));
- -- Attempts to insert New_Item into the set. If an element equivalent to
- -- New_Item is already in the set (the insertion search succeeded, and
- -- hence New_Item was not inserted), then the value of New_Item is assigned
- -- to the existing element. (This insertion operation only raises an
- -- exception if cursor tampering occurs. It is intended for use when you
- -- want to insert the item in the set, and you don't care whether an
- -- equivalent element is already present.)
-
- procedure Replace (Container : in out Set; New_Item : Element_Type) with
- Global => null,
- Pre => Contains (Container, New_Item),
- Post =>
-
- -- Elements are preserved modulo equivalence
-
- Model (Container) = Model (Container)'Old
- and Contains (Container, New_Item)
-
- -- Cursors are preserved
-
- and Positions (Container) = Positions (Container)'Old
-
- -- The element equivalent to New_Item in Container is replaced by
- -- New_Item.
-
- and Element (Container, Find (Container, New_Item)) = New_Item
- and E.Equal_Except
- (Elements (Container)'Old,
- Elements (Container),
- P.Get (Positions (Container), Find (Container, New_Item)));
- -- Searches for New_Item in the set; if the search fails (because an
- -- equivalent element was not in the set), then it raises
- -- Constraint_Error. Otherwise, the existing element is assigned the value
- -- New_Item. (This is similar to Insert, but with the opposite exception
- -- behavior. It is intended for use when you want to assert that the item
- -- is already in the set.)
-
- procedure Exclude (Container : in out Set; Item : Element_Type) with
- Global => null,
- Post => not Contains (Container, Item),
- Contract_Cases =>
-
- -- If Item is not in Container, nothing is changed
-
- (not Contains (Container, Item) =>
- Model (Container) = Model (Container)'Old
- and Elements (Container) = Elements (Container)'Old
- and Positions (Container) = Positions (Container)'Old,
-
- -- Otherwise, Item is removed from Container
-
- others =>
- Length (Container) = Length (Container)'Old - 1
-
- -- Other elements are preserved
-
- and Model (Container) <= Model (Container)'Old
- and M.Included_Except
- (Model (Container)'Old,
- Model (Container),
- Item)
-
- -- Mapping from cursors to elements is preserved
-
- and Mapping_Preserved
- (E_Left => Elements (Container),
- E_Right => Elements (Container)'Old,
- P_Left => Positions (Container),
- P_Right => Positions (Container)'Old)
- and P.Keys_Included_Except
- (Positions (Container)'Old,
- Positions (Container),
- Find (Container, Item)'Old));
- -- Searches for Item in the set, and if found, removes its node from the
- -- set and then deallocates it. The search works as follows. The operation
- -- calls Hash to determine the item's bucket; if the bucket is not empty,
- -- it calls Equivalent_Elements to compare Item to the element of each node
- -- in the bucket. (This is the deletion analog of Include. It is intended
- -- for use when you want to remove the item from the set, but don't care
- -- whether the item is already in the set.)
-
- procedure Delete (Container : in out Set; Item : Element_Type) with
- Global => null,
- Pre => Contains (Container, Item),
- Post =>
- Length (Container) = Length (Container)'Old - 1
-
- -- Item is no longer in Container
-
- and not Contains (Container, Item)
-
- -- Other elements are preserved
-
- and Model (Container) <= Model (Container)'Old
- and M.Included_Except
- (Model (Container)'Old,
- Model (Container),
- Item)
-
- -- Mapping from cursors to elements is preserved
-
- and Mapping_Preserved
- (E_Left => Elements (Container),
- E_Right => Elements (Container)'Old,
- P_Left => Positions (Container),
- P_Right => Positions (Container)'Old)
- and P.Keys_Included_Except
- (Positions (Container)'Old,
- Positions (Container),
- Find (Container, Item)'Old);
- -- Searches for Item in the set (which involves calling both Hash and
- -- Equivalent_Elements). If the search fails, then the operation raises
- -- Constraint_Error. Otherwise it removes the node from the set and then
- -- deallocates it. (This is the deletion analog of non-conditional
- -- Insert. It is intended for use when you want to assert that the item is
- -- already in the set.)
-
- procedure Delete (Container : in out Set; Position : in out Cursor) with
- Global => null,
- Depends => (Container =>+ Position, Position => null),
- Pre => Has_Element (Container, Position),
- Post =>
- Position = No_Element
- and Length (Container) = Length (Container)'Old - 1
-
- -- The element at position Position is no longer in Container
-
- and not Contains (Container, Element (Container, Position)'Old)
- and not P.Has_Key (Positions (Container), Position'Old)
-
- -- Other elements are preserved
-
- and Model (Container) <= Model (Container)'Old
- and M.Included_Except
- (Model (Container)'Old,
- Model (Container),
- Element (Container, Position)'Old)
-
- -- Mapping from cursors to elements is preserved
-
- and Mapping_Preserved
- (E_Left => Elements (Container),
- E_Right => Elements (Container)'Old,
- P_Left => Positions (Container),
- P_Right => Positions (Container)'Old)
- and P.Keys_Included_Except
- (Positions (Container)'Old,
- Positions (Container),
- Position'Old);
- -- Removes the node designated by Position from the set, and then
- -- deallocates the node. The operation calls Hash to determine the bucket,
- -- and then compares Position to each node in the bucket until there's a
- -- match (it does not call Equivalent_Elements).
-
- procedure Union (Target : in out Set; Source : Set) with
- Global => null,
- Pre =>
- Length (Source) - Length (Target and Source) <=
- Target.Capacity - Length (Target),
- Post =>
- Big (Length (Target)) = Big (Length (Target)'Old)
- - M.Num_Overlaps (Model (Target)'Old, Model (Source))
- + Big (Length (Source))
-
- -- Elements already in Target are still in Target
-
- and Model (Target)'Old <= Model (Target)
-
- -- Elements of Source are included in Target
-
- and Model (Source) <= Model (Target)
-
- -- Elements of Target come from either Source or Target
-
- and M.Included_In_Union
- (Model (Target), Model (Source), Model (Target)'Old)
-
- -- Actual value of elements come from either Left or Right
-
- and E_Elements_Included
- (Elements (Target),
- Model (Target)'Old,
- Elements (Target)'Old,
- Elements (Source))
-
- and E_Elements_Included
- (Elements (Target)'Old, Model (Target)'Old, Elements (Target))
-
- and E_Elements_Included
- (Elements (Source),
- Model (Target)'Old,
- Elements (Source),
- Elements (Target))
-
- -- Mapping from cursors of Target to elements is preserved
-
- and Mapping_Preserved
- (E_Left => Elements (Target)'Old,
- E_Right => Elements (Target),
- P_Left => Positions (Target)'Old,
- P_Right => Positions (Target));
- -- Iterates over the Source set, and conditionally inserts each element
- -- into Target.
-
- function Union (Left, Right : Set) return Set with
- Global => null,
- Pre => Length (Left) <= Count_Type'Last - Length (Right),
- Post =>
- Big (Length (Union'Result)) = Big (Length (Left))
- - M.Num_Overlaps (Model (Left), Model (Right))
- + Big (Length (Right))
-
- -- Elements of Left and Right are in the result of Union
-
- and Model (Left) <= Model (Union'Result)
- and Model (Right) <= Model (Union'Result)
-
- -- Elements of the result of union come from either Left or Right
-
- and
- M.Included_In_Union
- (Model (Union'Result), Model (Left), Model (Right))
-
- -- Actual value of elements come from either Left or Right
-
- and E_Elements_Included
- (Elements (Union'Result),
- Model (Left),
- Elements (Left),
- Elements (Right))
-
- and E_Elements_Included
- (Elements (Left), Model (Left), Elements (Union'Result))
-
- and E_Elements_Included
- (Elements (Right),
- Model (Left),
- Elements (Right),
- Elements (Union'Result));
- -- The operation first copies the Left set to the result, and then iterates
- -- over the Right set to conditionally insert each element into the result.
-
- function "or" (Left, Right : Set) return Set renames Union;
-
- procedure Intersection (Target : in out Set; Source : Set) with
- Global => null,
- Post =>
- Big (Length (Target)) =
- M.Num_Overlaps (Model (Target)'Old, Model (Source))
-
- -- Elements of Target were already in Target
-
- and Model (Target) <= Model (Target)'Old
-
- -- Elements of Target are in Source
-
- and Model (Target) <= Model (Source)
-
- -- Elements both in Source and Target are in the intersection
-
- and M.Includes_Intersection
- (Model (Target), Model (Source), Model (Target)'Old)
-
- -- Actual value of elements of Target is preserved
-
- and E_Elements_Included (Elements (Target), Elements (Target)'Old)
- and E_Elements_Included
- (Elements (Target)'Old, Model (Source), Elements (Target))
-
- -- Mapping from cursors of Target to elements is preserved
-
- and Mapping_Preserved
- (E_Left => Elements (Target),
- E_Right => Elements (Target)'Old,
- P_Left => Positions (Target),
- P_Right => Positions (Target)'Old);
- -- Iterates over the Target set (calling First and Next), calling Find to
- -- determine whether the element is in Source. If an equivalent element is
- -- not found in Source, the element is deleted from Target.
-
- function Intersection (Left, Right : Set) return Set with
- Global => null,
- Post =>
- Big (Length (Intersection'Result)) =
- M.Num_Overlaps (Model (Left), Model (Right))
-
- -- Elements in the result of Intersection are in Left and Right
-
- and Model (Intersection'Result) <= Model (Left)
- and Model (Intersection'Result) <= Model (Right)
-
- -- Elements both in Left and Right are in the result of Intersection
-
- and M.Includes_Intersection
- (Model (Intersection'Result), Model (Left), Model (Right))
-
- -- Actual value of elements come from Left
-
- and E_Elements_Included
- (Elements (Intersection'Result), Elements (Left))
-
- and E_Elements_Included
- (Elements (Left), Model (Right),
- Elements (Intersection'Result));
- -- Iterates over the Left set, calling Find to determine whether the
- -- element is in Right. If an equivalent element is found, it is inserted
- -- into the result set.
-
- function "and" (Left, Right : Set) return Set renames Intersection;
-
- procedure Difference (Target : in out Set; Source : Set) with
- Global => null,
- Post =>
- Big (Length (Target)) = Big (Length (Target)'Old) -
- M.Num_Overlaps (Model (Target)'Old, Model (Source))
-
- -- Elements of Target were already in Target
-
- and Model (Target) <= Model (Target)'Old
-
- -- Elements of Target are not in Source
-
- and M.No_Overlap (Model (Target), Model (Source))
-
- -- Elements in Target but not in Source are in the difference
-
- and M.Included_In_Union
- (Model (Target)'Old, Model (Target), Model (Source))
-
- -- Actual value of elements of Target is preserved
-
- and E_Elements_Included (Elements (Target), Elements (Target)'Old)
- and E_Elements_Included
- (Elements (Target)'Old, Model (Target), Elements (Target))
-
- -- Mapping from cursors of Target to elements is preserved
-
- and Mapping_Preserved
- (E_Left => Elements (Target),
- E_Right => Elements (Target)'Old,
- P_Left => Positions (Target),
- P_Right => Positions (Target)'Old);
- -- Iterates over the Source (calling First and Next), calling Find to
- -- determine whether the element is in Target. If an equivalent element is
- -- found, it is deleted from Target.
-
- function Difference (Left, Right : Set) return Set with
- Global => null,
- Post =>
- Big (Length (Difference'Result)) = Big (Length (Left)) -
- M.Num_Overlaps (Model (Left), Model (Right))
-
- -- Elements of the result of Difference are in Left
-
- and Model (Difference'Result) <= Model (Left)
-
- -- Elements of the result of Difference are in Right
-
- and M.No_Overlap (Model (Difference'Result), Model (Right))
-
- -- Elements in Left but not in Right are in the difference
-
- and M.Included_In_Union
- (Model (Left), Model (Difference'Result), Model (Right))
-
- -- Actual value of elements come from Left
-
- and E_Elements_Included
- (Elements (Difference'Result), Elements (Left))
-
- and E_Elements_Included
- (Elements (Left),
- Model (Difference'Result),
- Elements (Difference'Result));
- -- Iterates over the Left set, calling Find to determine whether the
- -- element is in the Right set. If an equivalent element is not found, the
- -- element is inserted into the result set.
-
- function "-" (Left, Right : Set) return Set renames Difference;
-
- procedure Symmetric_Difference (Target : in out Set; Source : Set) with
- Global => null,
- Pre =>
- Length (Source) - Length (Target and Source) <=
- Target.Capacity - Length (Target) + Length (Target and Source),
- Post =>
- Big (Length (Target)) = Big (Length (Target)'Old) -
- 2 * M.Num_Overlaps (Model (Target)'Old, Model (Source)) +
- Big (Length (Source))
-
- -- Elements of the difference were not both in Source and in Target
-
- and M.Not_In_Both (Model (Target), Model (Target)'Old, Model (Source))
-
- -- Elements in Target but not in Source are in the difference
-
- and M.Included_In_Union
- (Model (Target)'Old, Model (Target), Model (Source))
-
- -- Elements in Source but not in Target are in the difference
-
- and M.Included_In_Union
- (Model (Source), Model (Target), Model (Target)'Old)
-
- -- Actual value of elements come from either Left or Right
-
- and E_Elements_Included
- (Elements (Target),
- Model (Target)'Old,
- Elements (Target)'Old,
- Elements (Source))
-
- and E_Elements_Included
- (Elements (Target)'Old, Model (Target), Elements (Target))
-
- and E_Elements_Included
- (Elements (Source), Model (Target), Elements (Target));
- -- The operation iterates over the Source set, searching for the element
- -- in Target (calling Hash and Equivalent_Elements). If an equivalent
- -- element is found, it is removed from Target; otherwise it is inserted
- -- into Target.
-
- function Symmetric_Difference (Left, Right : Set) return Set with
- Global => null,
- Pre => Length (Left) <= Count_Type'Last - Length (Right),
- Post =>
- Big (Length (Symmetric_Difference'Result)) = Big (Length (Left)) -
- 2 * M.Num_Overlaps (Model (Left), Model (Right)) +
- Big (Length (Right))
-
- -- Elements of the difference were not both in Left and Right
-
- and M.Not_In_Both
- (Model (Symmetric_Difference'Result),
- Model (Left),
- Model (Right))
-
- -- Elements in Left but not in Right are in the difference
-
- and M.Included_In_Union
- (Model (Left),
- Model (Symmetric_Difference'Result),
- Model (Right))
-
- -- Elements in Right but not in Left are in the difference
-
- and M.Included_In_Union
- (Model (Right),
- Model (Symmetric_Difference'Result),
- Model (Left))
-
- -- Actual value of elements come from either Left or Right
-
- and E_Elements_Included
- (Elements (Symmetric_Difference'Result),
- Model (Left),
- Elements (Left),
- Elements (Right))
-
- and E_Elements_Included
- (Elements (Left),
- Model (Symmetric_Difference'Result),
- Elements (Symmetric_Difference'Result))
-
- and E_Elements_Included
- (Elements (Right),
- Model (Symmetric_Difference'Result),
- Elements (Symmetric_Difference'Result));
- -- The operation first iterates over the Left set. It calls Find to
- -- determine whether the element is in the Right set. If no equivalent
- -- element is found, the element from Left is inserted into the result. The
- -- operation then iterates over the Right set, to determine whether the
- -- element is in the Left set. If no equivalent element is found, the Right
- -- element is inserted into the result.
-
- function "xor" (Left, Right : Set) return Set
- renames Symmetric_Difference;
-
- function Overlap (Left, Right : Set) return Boolean with
- Global => null,
- Post =>
- Overlap'Result = not (M.No_Overlap (Model (Left), Model (Right)));
- -- Iterates over the Left set (calling First and Next), calling Find to
- -- determine whether the element is in the Right set. If an equivalent
- -- element is found, the operation immediately returns True. The operation
- -- returns False if the iteration over Left terminates without finding any
- -- equivalent element in Right.
-
- function Is_Subset (Subset : Set; Of_Set : Set) return Boolean with
- Global => null,
- Post => Is_Subset'Result = (Model (Subset) <= Model (Of_Set));
- -- Iterates over Subset (calling First and Next), calling Find to determine
- -- whether the element is in Of_Set. If no equivalent element is found in
- -- Of_Set, the operation immediately returns False. The operation returns
- -- True if the iteration over Subset terminates without finding an element
- -- not in Of_Set (that is, every element in Subset is equivalent to an
- -- element in Of_Set).
-
- function First (Container : Set) return Cursor with
- Global => null,
- Contract_Cases =>
- (Length (Container) = 0 =>
- First'Result = No_Element,
-
- others =>
- Has_Element (Container, First'Result)
- and P.Get (Positions (Container), First'Result) = 1);
- -- Returns a cursor that designates the first non-empty bucket, by
- -- searching from the beginning of the buckets array.
-
- function Next (Container : Set; Position : Cursor) return Cursor with
- Global => null,
- Pre =>
- Has_Element (Container, Position) or else Position = No_Element,
- Contract_Cases =>
- (Position = No_Element
- or else P.Get (Positions (Container), Position) = Length (Container)
- =>
- Next'Result = No_Element,
-
- others =>
- Has_Element (Container, Next'Result)
- and then P.Get (Positions (Container), Next'Result) =
- P.Get (Positions (Container), Position) + 1);
- -- Returns a cursor that designates the node that follows the current one
- -- designated by Position. If Position designates the last node in its
- -- bucket, the operation calls Hash to compute the index of this bucket,
- -- and searches the buckets array for the first non-empty bucket, starting
- -- from that index; otherwise, it simply follows the link to the next node
- -- in the same bucket.
-
- procedure Next (Container : Set; Position : in out Cursor) with
- Global => null,
- Pre =>
- Has_Element (Container, Position) or else Position = No_Element,
- Contract_Cases =>
- (Position = No_Element
- or else P.Get (Positions (Container), Position) = Length (Container)
- =>
- Position = No_Element,
-
- others =>
- Has_Element (Container, Position)
- and then P.Get (Positions (Container), Position) =
- P.Get (Positions (Container), Position'Old) + 1);
- -- Equivalent to Position := Next (Position)
-
- function Find
- (Container : Set;
- Item : Element_Type) return Cursor
- with
- Global => null,
- Contract_Cases =>
-
- -- If Item is not contained in Container, Find returns No_Element
-
- (not Contains (Model (Container), Item) =>
- Find'Result = No_Element,
-
- -- Otherwise, Find returns a valid cursor in Container
-
- others =>
- P.Has_Key (Positions (Container), Find'Result)
- and P.Get (Positions (Container), Find'Result) =
- Find (Elements (Container), Item)
-
- -- The element designated by the result of Find is Item
-
- and Equivalent_Elements
- (Element (Container, Find'Result), Item));
- -- Searches for Item in the set. Find calls Hash to determine the item's
- -- bucket; if the bucket is not empty, it calls Equivalent_Elements to
- -- compare Item to each element in the bucket. If the search succeeds, Find
- -- returns a cursor designating the node containing the equivalent element;
- -- otherwise, it returns No_Element.
-
- function Contains (Container : Set; Item : Element_Type) return Boolean with
- Global => null,
- Post => Contains'Result = Contains (Model (Container), Item);
- pragma Annotate (GNATprove, Inline_For_Proof, Contains);
-
- function Has_Element (Container : Set; Position : Cursor) return Boolean
- with
- Global => null,
- Post =>
- Has_Element'Result = P.Has_Key (Positions (Container), Position);
- pragma Annotate (GNATprove, Inline_For_Proof, Has_Element);
-
- function Default_Modulus (Capacity : Count_Type) return Hash_Type with
- Global => null;
-
- generic
- type Key_Type (<>) is private;
-
- with function Key (Element : Element_Type) return Key_Type;
-
- with function Hash (Key : Key_Type) return Hash_Type;
-
- with function Equivalent_Keys (Left, Right : Key_Type) return Boolean;
-
- package Generic_Keys with SPARK_Mode is
-
- package Formal_Model with Ghost is
-
- function M_Included_Except
- (Left : M.Set;
- Right : M.Set;
- Key : Key_Type) return Boolean
- with
- Global => null,
- Post =>
- M_Included_Except'Result =
- (for all E of Left =>
- Contains (Right, E)
- or Equivalent_Keys (Generic_Keys.Key (E), Key));
-
- end Formal_Model;
- use Formal_Model;
-
- function Key (Container : Set; Position : Cursor) return Key_Type with
- Global => null,
- Post => Key'Result = Key (Element (Container, Position));
- pragma Annotate (GNATprove, Inline_For_Proof, Key);
-
- function Element (Container : Set; Key : Key_Type) return Element_Type
- with
- Global => null,
- Pre => Contains (Container, Key),
- Post =>
- Element'Result = Element (Container, Find (Container, Key));
- pragma Annotate (GNATprove, Inline_For_Proof, Element);
-
- procedure Replace
- (Container : in out Set;
- Key : Key_Type;
- New_Item : Element_Type)
- with
- Global => null,
- Pre => Contains (Container, Key),
- Post =>
- Length (Container) = Length (Container)'Old
-
- -- Key now maps to New_Item
-
- and Element (Container, Key) = New_Item
-
- -- New_Item is contained in Container
-
- and Contains (Model (Container), New_Item)
-
- -- Other elements are preserved
-
- and M_Included_Except
- (Model (Container)'Old,
- Model (Container),
- Key)
- and M.Included_Except
- (Model (Container),
- Model (Container)'Old,
- New_Item)
-
- -- Mapping from cursors to elements is preserved
-
- and Mapping_Preserved_Except
- (E_Left => Elements (Container)'Old,
- E_Right => Elements (Container),
- P_Left => Positions (Container)'Old,
- P_Right => Positions (Container),
- Position => Find (Container, Key))
- and Positions (Container) = Positions (Container)'Old;
-
- procedure Exclude (Container : in out Set; Key : Key_Type) with
- Global => null,
- Post => not Contains (Container, Key),
- Contract_Cases =>
-
- -- If Key is not in Container, nothing is changed
-
- (not Contains (Container, Key) =>
- Model (Container) = Model (Container)'Old
- and Elements (Container) = Elements (Container)'Old
- and Positions (Container) = Positions (Container)'Old,
-
- -- Otherwise, Key is removed from Container
-
- others =>
- Length (Container) = Length (Container)'Old - 1
-
- -- Other elements are preserved
-
- and Model (Container) <= Model (Container)'Old
- and M_Included_Except
- (Model (Container)'Old,
- Model (Container),
- Key)
-
- -- Mapping from cursors to elements is preserved
-
- and Mapping_Preserved
- (E_Left => Elements (Container),
- E_Right => Elements (Container)'Old,
- P_Left => Positions (Container),
- P_Right => Positions (Container)'Old)
- and P.Keys_Included_Except
- (Positions (Container)'Old,
- Positions (Container),
- Find (Container, Key)'Old));
-
- procedure Delete (Container : in out Set; Key : Key_Type) with
- Global => null,
- Pre => Contains (Container, Key),
- Post =>
- Length (Container) = Length (Container)'Old - 1
-
- -- Key is no longer in Container
-
- and not Contains (Container, Key)
-
- -- Other elements are preserved
-
- and Model (Container) <= Model (Container)'Old
- and M_Included_Except
- (Model (Container)'Old,
- Model (Container),
- Key)
-
- -- Mapping from cursors to elements is preserved
-
- and Mapping_Preserved
- (E_Left => Elements (Container),
- E_Right => Elements (Container)'Old,
- P_Left => Positions (Container),
- P_Right => Positions (Container)'Old)
- and P.Keys_Included_Except
- (Positions (Container)'Old,
- Positions (Container),
- Find (Container, Key)'Old);
-
- function Find (Container : Set; Key : Key_Type) return Cursor with
- Global => null,
- Contract_Cases =>
-
- -- If Key is not contained in Container, Find returns No_Element
-
- ((for all E of Model (Container) =>
- not Equivalent_Keys (Key, Generic_Keys.Key (E))) =>
- Find'Result = No_Element,
-
- -- Otherwise, Find returns a valid cursor in Container
-
- others =>
- P.Has_Key (Positions (Container), Find'Result)
-
- -- The key designated by the result of Find is Key
-
- and Equivalent_Keys
- (Generic_Keys.Key (Container, Find'Result), Key));
-
- function Contains (Container : Set; Key : Key_Type) return Boolean with
- Global => null,
- Post =>
- Contains'Result =
- (for some E of Model (Container) =>
- Equivalent_Keys (Key, Generic_Keys.Key (E)));
-
- end Generic_Keys;
-
-private
- pragma SPARK_Mode (Off);
-
- pragma Inline (Next);
-
- type Node_Type is
- record
- Element : aliased Element_Type;
- Next : Count_Type;
- Has_Element : Boolean := False;
- end record;
-
- package HT_Types is new
- Ada.Containers.Hash_Tables.Generic_Formal_Hash_Table_Types (Node_Type);
-
- type Set (Capacity : Count_Type; Modulus : Hash_Type) is record
- Content : HT_Types.Hash_Table_Type (Capacity, Modulus);
- end record;
-
- use HT_Types;
+package Ada.Containers.Formal_Hashed_Sets with SPARK_Mode is
- Empty_Set : constant Set := (Capacity => 0, Modulus => 0, others => <>);
+ pragma Compile_Time_Error
+ (True,
+ "This package has been moved to the SPARK library shipped with any"
+ & " SPARK release starting with version 23.");
end Ada.Containers.Formal_Hashed_Sets;
diff --git a/gcc/ada/libgnat/a-cfidll.adb b/gcc/ada/libgnat/a-cfidll.adb
deleted file mode 100644
index 17e48d2..0000000
--- a/gcc/ada/libgnat/a-cfidll.adb
+++ /dev/null
@@ -1,2054 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT LIBRARY COMPONENTS --
--- --
--- ADA.CONTAINERS.FORMAL_INDEFINITE_DOUBLY_LINKED_LISTS --
--- --
--- B o d y --
--- --
--- Copyright (C) 2022-2022, Free Software Foundation, Inc. --
--- --
--- This specification is derived from the Ada Reference Manual for use with --
--- GNAT. The copyright notice above, and the license provisions that follow --
--- apply solely to the contents of the part following the private keyword. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
-------------------------------------------------------------------------------
-
-with Ada.Unchecked_Deallocation;
-
-with Ada.Containers.Stable_Sorting; use Ada.Containers.Stable_Sorting;
-
-with System; use type System.Address;
-
-with Ada.Numerics.Big_Numbers.Big_Integers;
-use Ada.Numerics.Big_Numbers.Big_Integers;
-
-package body Ada.Containers.Formal_Indefinite_Doubly_Linked_Lists with
- SPARK_Mode => Off
-is
- -- Convert Count_Type to Big_Integer
-
- package Conversions is new Signed_Conversions (Int => Count_Type);
- use Conversions;
-
- -----------------------
- -- Local Subprograms --
- -----------------------
-
- procedure Allocate
- (Container : in out List;
- New_Item : Element_Type;
- New_Node : out Count_Type);
-
- procedure Allocate
- (Container : in out List;
- New_Node : out Count_Type);
-
- procedure Free (Container : in out List; X : Count_Type);
-
- procedure Insert_Internal
- (Container : in out List;
- Before : Count_Type;
- New_Node : Count_Type);
-
- function Vet (L : List; Position : Cursor) return Boolean with Inline;
-
- procedure Resize (Container : in out List) with
- -- Add more room in the internal array
-
- Global => null,
- Pre => Container.Nodes = null
- or else Length (Container) = Container.Nodes'Length,
- Post => Model (Container) = Model (Container)'Old
- and Positions (Container) = Positions (Container)'Old;
-
- procedure Finalize_Element is new Ada.Unchecked_Deallocation
- (Object => Element_Type,
- Name => Element_Access);
-
- procedure Finalize_Nodes is new Ada.Unchecked_Deallocation
- (Object => Node_Array,
- Name => Node_Array_Access);
-
- ---------
- -- "=" --
- ---------
-
- function "=" (Left : List; Right : List) return Boolean is
- LI : Count_Type;
- RI : Count_Type;
-
- begin
- if Left'Address = Right'Address then
- return True;
- end if;
-
- if Left.Length /= Right.Length then
- return False;
- end if;
-
- LI := Left.First;
- RI := Right.First;
- while LI /= 0 loop
- if Left.Nodes (LI).Element.all /= Right.Nodes (RI).Element.all then
- return False;
- end if;
-
- LI := Left.Nodes (LI).Next;
- RI := Right.Nodes (RI).Next;
- end loop;
-
- return True;
- end "=";
-
- ------------
- -- Adjust --
- ------------
-
- overriding procedure Adjust (Container : in out List) is
- N_Src : Node_Array_Access renames Container.Nodes;
- N_Tar : Node_Array_Access;
-
- begin
- if N_Src = null then
- return;
- end if;
-
- if Container.Length = 0 then
- Container.Nodes := null;
- Container.Free := -1;
- return;
- end if;
-
- N_Tar := new Node_Array (1 .. N_Src'Length);
-
- for X in 1 .. Count_Type (N_Src'Length) loop
- N_Tar (X) := N_Src (X);
- if N_Src (X).Element /= null
- then
- N_Tar (X).Element := new Element_Type'(N_Src (X).Element.all);
- end if;
- end loop;
-
- N_Src := N_Tar;
-
- end Adjust;
-
- --------------
- -- Allocate --
- --------------
-
- procedure Allocate
- (Container : in out List;
- New_Node : out Count_Type)
- is
- N : Node_Array_Access renames Container.Nodes;
-
- begin
- if Container.Nodes = null
- or else Length (Container) = Container.Nodes'Length
- then
- Resize (Container);
- end if;
-
- if Container.Free >= 0 then
- New_Node := Container.Free;
- Container.Free := N (New_Node).Next;
- else
- New_Node := abs Container.Free;
- Container.Free := Container.Free - 1;
- end if;
-
- N (New_Node).Element := null;
- end Allocate;
-
- procedure Allocate
- (Container : in out List;
- New_Item : Element_Type;
- New_Node : out Count_Type)
- is
- N : Node_Array_Access renames Container.Nodes;
-
- begin
- Allocate (Container, New_Node);
-
- N (New_Node).Element := new Element_Type'(New_Item);
- end Allocate;
-
- ------------
- -- Append --
- ------------
-
- procedure Append (Container : in out List; New_Item : Element_Type) is
- begin
- Insert (Container, No_Element, New_Item, 1);
- end Append;
-
- procedure Append
- (Container : in out List;
- New_Item : Element_Type;
- Count : Count_Type)
- is
- begin
- Insert (Container, No_Element, New_Item, Count);
- end Append;
-
- ------------
- -- Assign --
- ------------
-
- procedure Assign (Target : in out List; Source : List) is
- N : Node_Array_Access renames Source.Nodes;
- J : Count_Type;
-
- begin
- if Target'Address = Source'Address then
- return;
- end if;
-
- Clear (Target);
-
- J := Source.First;
- while J /= 0 loop
- Append (Target, N (J).Element.all);
- J := N (J).Next;
- end loop;
- end Assign;
-
- -----------
- -- Clear --
- -----------
-
- procedure Clear (Container : in out List) is
- N : Node_Array_Access renames Container.Nodes;
- X : Count_Type;
-
- begin
- if Container.Length = 0 then
- pragma Assert (Container.First = 0);
- pragma Assert (Container.Last = 0);
- return;
- end if;
-
- pragma Assert (Container.First >= 1);
- pragma Assert (Container.Last >= 1);
- pragma Assert (N (Container.First).Prev = 0);
- pragma Assert (N (Container.Last).Next = 0);
-
- while Container.Length > 1 loop
- X := Container.First;
-
- Container.First := N (X).Next;
- N (Container.First).Prev := 0;
-
- Container.Length := Container.Length - 1;
-
- Free (Container, X);
- end loop;
-
- X := Container.First;
-
- Container.First := 0;
- Container.Last := 0;
- Container.Length := 0;
-
- Free (Container, X);
- end Clear;
-
- ------------------------
- -- Constant_Reference --
- ------------------------
-
- function Constant_Reference
- (Container : List;
- Position : Cursor) return not null access constant Element_Type
- is
- begin
- if not Has_Element (Container => Container, Position => Position) then
- raise Constraint_Error with "Position cursor has no element";
- end if;
-
- return Container.Nodes (Position.Node).Element;
- end Constant_Reference;
-
- --------------
- -- Contains --
- --------------
-
- function Contains
- (Container : List;
- Item : Element_Type) return Boolean
- is
- begin
- return Find (Container, Item) /= No_Element;
- end Contains;
-
- ----------
- -- Copy --
- ----------
-
- function Copy (Source : List) return List
- is
- N : Count_Type;
- P : List;
-
- begin
- if Source.Nodes = null then
- return P;
- end if;
-
- P.Nodes := new Node_Array (1 .. Source.Nodes'Length);
-
- N := 1;
- while N <= Source.Nodes'Length loop
- P.Nodes (N).Prev := Source.Nodes (N).Prev;
- P.Nodes (N).Next := Source.Nodes (N).Next;
- if Source.Nodes (N).Element /= null then
- P.Nodes (N).Element :=
- new Element_Type'(Source.Nodes (N).Element.all);
- end if;
- N := N + 1;
- end loop;
-
- P.Free := Source.Free;
- P.Length := Source.Length;
- P.First := Source.First;
- P.Last := Source.Last;
-
- return P;
- end Copy;
-
- ------------
- -- Delete --
- ------------
-
- procedure Delete (Container : in out List; Position : in out Cursor) is
- begin
- Delete
- (Container => Container,
- Position => Position,
- Count => 1);
- end Delete;
-
- procedure Delete
- (Container : in out List;
- Position : in out Cursor;
- Count : Count_Type)
- is
- N : Node_Array_Access renames Container.Nodes;
- X : Count_Type;
-
- begin
- if not Has_Element (Container => Container,
- Position => Position)
- then
- raise Constraint_Error with "Position cursor has no element";
- end if;
-
- pragma Assert (Vet (Container, Position), "bad cursor in Delete");
- pragma Assert (Container.First >= 1);
- pragma Assert (Container.Last >= 1);
- pragma Assert (N (Container.First).Prev = 0);
- pragma Assert (N (Container.Last).Next = 0);
-
- if Position.Node = Container.First then
- Delete_First (Container, Count);
- Position := No_Element;
- return;
- end if;
-
- if Count = 0 then
- Position := No_Element;
- return;
- end if;
-
- for Index in 1 .. Count loop
- pragma Assert (Container.Length >= 2);
-
- X := Position.Node;
- Container.Length := Container.Length - 1;
-
- if X = Container.Last then
- Position := No_Element;
-
- Container.Last := N (X).Prev;
- N (Container.Last).Next := 0;
-
- Free (Container, X);
- return;
- end if;
-
- Position.Node := N (X).Next;
- pragma Assert (N (Position.Node).Prev >= 0);
-
- N (N (X).Next).Prev := N (X).Prev;
- N (N (X).Prev).Next := N (X).Next;
-
- Free (Container, X);
- end loop;
-
- Position := No_Element;
- end Delete;
-
- ------------------
- -- Delete_First --
- ------------------
-
- procedure Delete_First (Container : in out List) is
- begin
- Delete_First
- (Container => Container,
- Count => 1);
- end Delete_First;
-
- procedure Delete_First (Container : in out List; Count : Count_Type) is
- N : Node_Array_Access renames Container.Nodes;
- X : Count_Type;
-
- begin
- if Count >= Container.Length then
- Clear (Container);
- return;
- end if;
-
- if Count = 0 then
- return;
- end if;
-
- for J in 1 .. Count loop
- X := Container.First;
- pragma Assert (N (N (X).Next).Prev = Container.First);
-
- Container.First := N (X).Next;
- N (Container.First).Prev := 0;
-
- Container.Length := Container.Length - 1;
-
- Free (Container, X);
- end loop;
- end Delete_First;
-
- -----------------
- -- Delete_Last --
- -----------------
-
- procedure Delete_Last (Container : in out List) is
- begin
- Delete_Last
- (Container => Container,
- Count => 1);
- end Delete_Last;
-
- procedure Delete_Last (Container : in out List; Count : Count_Type) is
- N : Node_Array_Access renames Container.Nodes;
- X : Count_Type;
-
- begin
- if Count >= Container.Length then
- Clear (Container);
- return;
- end if;
-
- if Count = 0 then
- return;
- end if;
-
- for J in 1 .. Count loop
- X := Container.Last;
- pragma Assert (N (N (X).Prev).Next = Container.Last);
-
- Container.Last := N (X).Prev;
- N (Container.Last).Next := 0;
-
- Container.Length := Container.Length - 1;
-
- Free (Container, X);
- end loop;
- end Delete_Last;
-
- -------------
- -- Element --
- -------------
-
- function Element
- (Container : List;
- Position : Cursor) return Element_Type
- is
- begin
- if not Has_Element (Container => Container, Position => Position) then
- raise Constraint_Error with "Position cursor has no element";
- end if;
-
- return Container.Nodes (Position.Node).Element.all;
- end Element;
-
- ----------------
- -- Empty_List --
- ----------------
-
- function Empty_List return List is
- ((Controlled with others => <>));
-
- --------------
- -- Finalize --
- --------------
-
- procedure Finalize (Container : in out List) is
- X : Count_Type := Container.First;
- N : Node_Array_Access renames Container.Nodes;
- begin
-
- if N = null then
- return;
- end if;
-
- while X /= 0 loop
- Finalize_Element (N (X).Element);
- X := N (X).Next;
- end loop;
-
- Finalize_Nodes (N);
-
- Container.Free := 0;
- Container.Last := 0;
- Container.First := 0;
- Container.Length := 0;
- end Finalize;
-
- ----------
- -- Find --
- ----------
-
- function Find
- (Container : List;
- Item : Element_Type;
- Position : Cursor := No_Element) return Cursor
- is
- From : Count_Type := Position.Node;
-
- begin
- if From = 0 and Container.Length = 0 then
- return No_Element;
- end if;
-
- if From = 0 then
- From := Container.First;
- end if;
-
- if Position.Node /= 0 and then not Has_Element (Container, Position) then
- raise Constraint_Error with "Position cursor has no element";
- end if;
-
- while From /= 0 loop
- if Container.Nodes (From).Element.all = Item then
- return (Node => From);
- end if;
-
- From := Container.Nodes (From).Next;
- end loop;
-
- return No_Element;
- end Find;
-
- -----------
- -- First --
- -----------
-
- function First (Container : List) return Cursor is
- begin
- if Container.First = 0 then
- return No_Element;
- end if;
-
- return (Node => Container.First);
- end First;
-
- -------------------
- -- First_Element --
- -------------------
-
- function First_Element (Container : List) return Element_Type is
- F : constant Count_Type := Container.First;
- begin
- if F = 0 then
- raise Constraint_Error with "list is empty";
- else
- return Container.Nodes (F).Element.all;
- end if;
- end First_Element;
-
- ------------------
- -- Formal_Model --
- ------------------
-
- package body Formal_Model is
-
- ----------------------------
- -- Lift_Abstraction_Level --
- ----------------------------
-
- procedure Lift_Abstraction_Level (Container : List) is null;
-
- -------------------------
- -- M_Elements_In_Union --
- -------------------------
-
- function M_Elements_In_Union
- (Container : M.Sequence;
- Left : M.Sequence;
- Right : M.Sequence) return Boolean
- is
- Elem : Element_Type;
-
- begin
- for Index in 1 .. M.Length (Container) loop
- Elem := Element (Container, Index);
-
- if not M.Contains (Left, 1, M.Length (Left), Elem)
- and then not M.Contains (Right, 1, M.Length (Right), Elem)
- then
- return False;
- end if;
- end loop;
-
- return True;
- end M_Elements_In_Union;
-
- -------------------------
- -- M_Elements_Included --
- -------------------------
-
- function M_Elements_Included
- (Left : M.Sequence;
- L_Fst : Positive_Count_Type := 1;
- L_Lst : Count_Type;
- Right : M.Sequence;
- R_Fst : Positive_Count_Type := 1;
- R_Lst : Count_Type) return Boolean
- is
- begin
- for I in L_Fst .. L_Lst loop
- declare
- Found : Boolean := False;
- J : Count_Type := R_Fst - 1;
-
- begin
- while not Found and J < R_Lst loop
- J := J + 1;
- if Element (Left, I) = Element (Right, J) then
- Found := True;
- end if;
- end loop;
-
- if not Found then
- return False;
- end if;
- end;
- end loop;
-
- return True;
- end M_Elements_Included;
-
- -------------------------
- -- M_Elements_Reversed --
- -------------------------
-
- function M_Elements_Reversed
- (Left : M.Sequence;
- Right : M.Sequence) return Boolean
- is
- L : constant Count_Type := M.Length (Left);
-
- begin
- if L /= M.Length (Right) then
- return False;
- end if;
-
- for I in 1 .. L loop
- if Element (Left, I) /= Element (Right, L - I + 1) then
- return False;
- end if;
- end loop;
-
- return True;
- end M_Elements_Reversed;
-
- ------------------------
- -- M_Elements_Swapped --
- ------------------------
-
- function M_Elements_Swapped
- (Left : M.Sequence;
- Right : M.Sequence;
- X : Positive_Count_Type;
- Y : Positive_Count_Type) return Boolean
- is
- begin
- if M.Length (Left) /= M.Length (Right)
- or else Element (Left, X) /= Element (Right, Y)
- or else Element (Left, Y) /= Element (Right, X)
- then
- return False;
- end if;
-
- for I in 1 .. M.Length (Left) loop
- if I /= X and then I /= Y
- and then Element (Left, I) /= Element (Right, I)
- then
- return False;
- end if;
- end loop;
-
- return True;
- end M_Elements_Swapped;
-
- -----------
- -- Model --
- -----------
-
- function Model (Container : List) return M.Sequence is
- Position : Count_Type := Container.First;
- R : M.Sequence;
-
- begin
- -- Can't use First, Next or Element here, since they depend on models
- -- for their postconditions.
-
- while Position /= 0 loop
- R := M.Add (R, Container.Nodes (Position).Element.all);
- Position := Container.Nodes (Position).Next;
- end loop;
-
- return R;
- end Model;
-
- -----------------------
- -- Mapping_Preserved --
- -----------------------
-
- function Mapping_Preserved
- (M_Left : M.Sequence;
- M_Right : M.Sequence;
- P_Left : P.Map;
- P_Right : P.Map) return Boolean
- is
- begin
- for C of P_Left loop
- if not P.Has_Key (P_Right, C)
- or else P.Get (P_Left, C) > M.Length (M_Left)
- or else P.Get (P_Right, C) > M.Length (M_Right)
- or else M.Get (M_Left, P.Get (P_Left, C)) /=
- M.Get (M_Right, P.Get (P_Right, C))
- then
- return False;
- end if;
- end loop;
-
- for C of P_Right loop
- if not P.Has_Key (P_Left, C) then
- return False;
- end if;
- end loop;
-
- return True;
- end Mapping_Preserved;
-
- -------------------------
- -- P_Positions_Shifted --
- -------------------------
-
- function P_Positions_Shifted
- (Small : P.Map;
- Big : P.Map;
- Cut : Positive_Count_Type;
- Count : Count_Type := 1) return Boolean
- is
- begin
- for Cu of Small loop
- if not P.Has_Key (Big, Cu) then
- return False;
- end if;
- end loop;
-
- for Cu of Big loop
- declare
- Pos : constant Positive_Count_Type := P.Get (Big, Cu);
-
- begin
- if Pos < Cut then
- if not P.Has_Key (Small, Cu)
- or else Pos /= P.Get (Small, Cu)
- then
- return False;
- end if;
-
- elsif Pos >= Cut + Count then
- if not P.Has_Key (Small, Cu)
- or else Pos /= P.Get (Small, Cu) + Count
- then
- return False;
- end if;
-
- else
- if P.Has_Key (Small, Cu) then
- return False;
- end if;
- end if;
- end;
- end loop;
-
- return True;
- end P_Positions_Shifted;
-
- -------------------------
- -- P_Positions_Swapped --
- -------------------------
-
- function P_Positions_Swapped
- (Left : P.Map;
- Right : P.Map;
- X : Cursor;
- Y : Cursor) return Boolean
- is
- begin
- if not P.Has_Key (Left, X)
- or not P.Has_Key (Left, Y)
- or not P.Has_Key (Right, X)
- or not P.Has_Key (Right, Y)
- then
- return False;
- end if;
-
- if P.Get (Left, X) /= P.Get (Right, Y)
- or P.Get (Left, Y) /= P.Get (Right, X)
- then
- return False;
- end if;
-
- for C of Left loop
- if not P.Has_Key (Right, C) then
- return False;
- end if;
- end loop;
-
- for C of Right loop
- if not P.Has_Key (Left, C)
- or else (C /= X
- and C /= Y
- and P.Get (Left, C) /= P.Get (Right, C))
- then
- return False;
- end if;
- end loop;
-
- return True;
- end P_Positions_Swapped;
-
- ---------------------------
- -- P_Positions_Truncated --
- ---------------------------
-
- function P_Positions_Truncated
- (Small : P.Map;
- Big : P.Map;
- Cut : Positive_Count_Type;
- Count : Count_Type := 1) return Boolean
- is
- begin
- for Cu of Small loop
- if not P.Has_Key (Big, Cu) then
- return False;
- end if;
- end loop;
-
- for Cu of Big loop
- declare
- Pos : constant Positive_Count_Type := P.Get (Big, Cu);
-
- begin
- if Pos < Cut then
- if not P.Has_Key (Small, Cu)
- or else Pos /= P.Get (Small, Cu)
- then
- return False;
- end if;
-
- elsif Pos >= Cut + Count then
- return False;
-
- elsif P.Has_Key (Small, Cu) then
- return False;
- end if;
- end;
- end loop;
-
- return True;
- end P_Positions_Truncated;
-
- ---------------
- -- Positions --
- ---------------
-
- function Positions (Container : List) return P.Map is
- I : Count_Type := 1;
- Position : Count_Type := Container.First;
- R : P.Map;
-
- begin
- -- Can't use First, Next or Element here, since they depend on models
- -- for their postconditions.
-
- while Position /= 0 loop
- R := P.Add (R, (Node => Position), I);
- pragma Assert (P.Length (R) = To_Big_Integer (I));
- Position := Container.Nodes (Position).Next;
- I := I + 1;
- end loop;
-
- return R;
- end Positions;
-
- end Formal_Model;
-
- ----------
- -- Free --
- ----------
-
- procedure Free (Container : in out List; X : Count_Type) is
- pragma Assert (X > 0);
- pragma Assert (X <= Container.Nodes'Length);
-
- N : Node_Array_Access renames Container.Nodes;
-
- begin
- N (X).Prev := -1; -- Node is deallocated (not on active list)
-
- if N (X).Element /= null then
- Finalize_Element (N (X).Element);
- end if;
-
- if Container.Free >= 0 then
- N (X).Next := Container.Free;
- Container.Free := X;
- elsif X + 1 = abs Container.Free then
- N (X).Next := 0; -- Not strictly necessary, but marginally safer
- Container.Free := Container.Free + 1;
- else
- Container.Free := abs Container.Free;
-
- for J in Container.Free .. Container.Nodes'Length loop
- N (J).Next := J + 1;
- end loop;
-
- N (Container.Nodes'Length).Next := 0;
-
- N (X).Next := Container.Free;
- Container.Free := X;
- end if;
- end Free;
-
- ---------------------
- -- Generic_Sorting --
- ---------------------
-
- package body Generic_Sorting with SPARK_Mode => Off is
-
- ------------------
- -- Formal_Model --
- ------------------
-
- package body Formal_Model is
-
- -----------------------
- -- M_Elements_Sorted --
- -----------------------
-
- function M_Elements_Sorted (Container : M.Sequence) return Boolean is
- begin
- if M.Length (Container) = 0 then
- return True;
- end if;
-
- declare
- E1 : Element_Type := Element (Container, 1);
-
- begin
- for I in 2 .. M.Length (Container) loop
- declare
- E2 : constant Element_Type := Element (Container, I);
-
- begin
- if E2 < E1 then
- return False;
- end if;
-
- E1 := E2;
- end;
- end loop;
- end;
-
- return True;
- end M_Elements_Sorted;
-
- end Formal_Model;
-
- ---------------
- -- Is_Sorted --
- ---------------
-
- function Is_Sorted (Container : List) return Boolean is
- Nodes : Node_Array_Access renames Container.Nodes;
- Node : Count_Type := Container.First;
-
- begin
- for J in 2 .. Container.Length loop
- if Nodes (Nodes (Node).Next).Element.all < Nodes (Node).Element.all
- then
- return False;
- else
- Node := Nodes (Node).Next;
- end if;
- end loop;
-
- return True;
- end Is_Sorted;
-
- -----------
- -- Merge --
- -----------
-
- procedure Merge (Target : in out List; Source : in out List) is
- LN : Node_Array_Access renames Target.Nodes;
- RN : Node_Array_Access renames Source.Nodes;
- LI : Cursor;
- RI : Cursor;
-
- begin
- if Target'Address = Source'Address then
- raise Program_Error with "Target and Source denote same container";
- end if;
-
- LI := First (Target);
- RI := First (Source);
- while RI.Node /= 0 loop
- pragma Assert
- (RN (RI.Node).Next = 0
- or else not (RN (RN (RI.Node).Next).Element.all <
- RN (RI.Node).Element.all));
-
- if LI.Node = 0 then
- Splice (Target, No_Element, Source);
- return;
- end if;
-
- pragma Assert
- (LN (LI.Node).Next = 0
- or else not (LN (LN (LI.Node).Next).Element.all <
- LN (LI.Node).Element.all));
-
- if RN (RI.Node).Element.all < LN (LI.Node).Element.all then
- declare
- RJ : Cursor := RI;
- pragma Warnings (Off, RJ);
- begin
- RI.Node := RN (RI.Node).Next;
- Splice (Target, LI, Source, RJ);
- end;
-
- else
- LI.Node := LN (LI.Node).Next;
- end if;
- end loop;
- end Merge;
-
- ----------
- -- Sort --
- ----------
-
- procedure Sort (Container : in out List) is
- N : Node_Array_Access renames Container.Nodes;
- begin
- if Container.Length <= 1 then
- return;
- end if;
-
- pragma Assert (N (Container.First).Prev = 0);
- pragma Assert (N (Container.Last).Next = 0);
-
- declare
- package Descriptors is new List_Descriptors
- (Node_Ref => Count_Type, Nil => 0);
- use Descriptors;
-
- function Next (Idx : Count_Type) return Count_Type is
- (N (Idx).Next);
- procedure Set_Next (Idx : Count_Type; Next : Count_Type)
- with Inline;
- procedure Set_Prev (Idx : Count_Type; Prev : Count_Type)
- with Inline;
- function "<" (L, R : Count_Type) return Boolean is
- (N (L).Element.all < N (R).Element.all);
- procedure Update_Container (List : List_Descriptor) with Inline;
-
- procedure Set_Next (Idx : Count_Type; Next : Count_Type) is
- begin
- N (Idx).Next := Next;
- end Set_Next;
-
- procedure Set_Prev (Idx : Count_Type; Prev : Count_Type) is
- begin
- N (Idx).Prev := Prev;
- end Set_Prev;
-
- procedure Update_Container (List : List_Descriptor) is
- begin
- Container.First := List.First;
- Container.Last := List.Last;
- Container.Length := List.Length;
- end Update_Container;
-
- procedure Sort_List is new Doubly_Linked_List_Sort;
- begin
- Sort_List (List_Descriptor'(First => Container.First,
- Last => Container.Last,
- Length => Container.Length));
- end;
-
- pragma Assert (N (Container.First).Prev = 0);
- pragma Assert (N (Container.Last).Next = 0);
- end Sort;
-
- end Generic_Sorting;
-
- -----------------
- -- Has_Element --
- -----------------
-
- function Has_Element (Container : List; Position : Cursor) return Boolean is
- begin
- if Position.Node = 0 then
- return False;
- end if;
-
- return Container.Nodes (Position.Node).Prev /= -1;
- end Has_Element;
-
- ------------
- -- Insert --
- ------------
-
- procedure Insert
- (Container : in out List;
- Before : Cursor;
- New_Item : Element_Type;
- Position : out Cursor;
- Count : Count_Type)
- is
- J : Count_Type;
-
- begin
- if Before.Node /= 0 then
- pragma Assert (Vet (Container, Before), "bad cursor in Insert");
- end if;
-
- if Count = 0 then
- Position := Before;
- return;
- end if;
- Allocate (Container, New_Item, New_Node => J);
- Insert_Internal (Container, Before.Node, New_Node => J);
- Position := (Node => J);
-
- for Index in 2 .. Count loop
- Allocate (Container, New_Item, New_Node => J);
- Insert_Internal (Container, Before.Node, New_Node => J);
- end loop;
- end Insert;
-
- procedure Insert
- (Container : in out List;
- Before : Cursor;
- New_Item : Element_Type;
- Position : out Cursor)
- is
- begin
- Insert
- (Container => Container,
- Before => Before,
- New_Item => New_Item,
- Position => Position,
- Count => 1);
- end Insert;
-
- procedure Insert
- (Container : in out List;
- Before : Cursor;
- New_Item : Element_Type;
- Count : Count_Type)
- is
- Position : Cursor;
-
- begin
- Insert (Container, Before, New_Item, Position, Count);
- end Insert;
-
- procedure Insert
- (Container : in out List;
- Before : Cursor;
- New_Item : Element_Type)
- is
- Position : Cursor;
-
- begin
- Insert (Container, Before, New_Item, Position, 1);
- end Insert;
-
- ---------------------
- -- Insert_Internal --
- ---------------------
-
- procedure Insert_Internal
- (Container : in out List;
- Before : Count_Type;
- New_Node : Count_Type)
- is
- N : Node_Array_Access renames Container.Nodes;
-
- begin
- if Container.Length = 0 then
- pragma Assert (Before = 0);
- pragma Assert (Container.First = 0);
- pragma Assert (Container.Last = 0);
-
- Container.First := New_Node;
- Container.Last := New_Node;
-
- N (Container.First).Prev := 0;
- N (Container.Last).Next := 0;
-
- elsif Before = 0 then
- pragma Assert (N (Container.Last).Next = 0);
-
- N (Container.Last).Next := New_Node;
- N (New_Node).Prev := Container.Last;
-
- Container.Last := New_Node;
- N (Container.Last).Next := 0;
-
- elsif Before = Container.First then
- pragma Assert (N (Container.First).Prev = 0);
-
- N (Container.First).Prev := New_Node;
- N (New_Node).Next := Container.First;
-
- Container.First := New_Node;
- N (Container.First).Prev := 0;
-
- else
- pragma Assert (N (Container.First).Prev = 0);
- pragma Assert (N (Container.Last).Next = 0);
-
- N (New_Node).Next := Before;
- N (New_Node).Prev := N (Before).Prev;
-
- N (N (Before).Prev).Next := New_Node;
- N (Before).Prev := New_Node;
- end if;
- Container.Length := Container.Length + 1;
- end Insert_Internal;
-
- --------------
- -- Is_Empty --
- --------------
-
- function Is_Empty (Container : List) return Boolean is
- begin
- return Length (Container) = 0;
- end Is_Empty;
-
- ----------
- -- Last --
- ----------
-
- function Last (Container : List) return Cursor is
- begin
- if Container.Last = 0 then
- return No_Element;
- end if;
-
- return (Node => Container.Last);
- end Last;
-
- ------------------
- -- Last_Element --
- ------------------
-
- function Last_Element (Container : List) return Element_Type is
- L : constant Count_Type := Container.Last;
-
- begin
- if L = 0 then
- raise Constraint_Error with "list is empty";
- else
- return Container.Nodes (L).Element.all;
- end if;
- end Last_Element;
-
- ------------
- -- Length --
- ------------
-
- function Length (Container : List) return Count_Type is
- begin
- return Container.Length;
- end Length;
-
- ----------
- -- Move --
- ----------
-
- procedure Move (Target : in out List; Source : in out List) is
- N : Node_Array_Access renames Source.Nodes;
-
- procedure Finalize_Node_Array is new Ada.Unchecked_Deallocation
- (Object => Node_Array,
- Name => Node_Array_Access);
-
- begin
- if Target'Address = Source'Address then
- return;
- end if;
-
- Clear (Target);
-
- if Source.Length = 0 then
- return;
- end if;
-
- -- Make sure that Target is large enough
-
- if Target.Nodes = null
- or else Target.Nodes'Length < Source.Length
- then
- if Target.Nodes /= null then
- Finalize_Node_Array (Target.Nodes);
- end if;
- Target.Nodes := new Node_Array (1 .. Source.Length);
- end if;
-
- -- Copy first element from Source to Target
-
- Target.First := 1;
-
- Target.Nodes (1).Prev := 0;
- Target.Nodes (1).Element := N (Source.First).Element;
- N (Source.First).Element := null;
-
- -- Copy the other elements
-
- declare
- X_Src : Count_Type := N (Source.First).Next;
- X_Tar : Count_Type := 2;
-
- begin
- while X_Src /= 0 loop
- Target.Nodes (X_Tar).Prev := X_Tar - 1;
- Target.Nodes (X_Tar - 1).Next := X_Tar;
-
- Target.Nodes (X_Tar).Element := N (X_Src).Element;
- N (X_Src).Element := null;
-
- X_Src := N (X_Src).Next;
- X_Tar := X_Tar + 1;
- end loop;
- end;
-
- Target.Last := Source.Length;
- Target.Length := Source.Length;
- Target.Nodes (Target.Last).Next := 0;
-
- -- Set up the free list
-
- Target.Free := -Source.Length - 1;
-
- -- It is possible to Clear Source because the Element accesses were
- -- set to null.
-
- Clear (Source);
- end Move;
-
- ----------
- -- Next --
- ----------
-
- procedure Next (Container : List; Position : in out Cursor) is
- begin
- Position := Next (Container, Position);
- end Next;
-
- function Next (Container : List; Position : Cursor) return Cursor is
- begin
- if Position.Node = 0 then
- return No_Element;
- end if;
-
- if not Has_Element (Container, Position) then
- raise Program_Error with "Position cursor has no element";
- end if;
-
- return (Node => Container.Nodes (Position.Node).Next);
- end Next;
-
- -------------
- -- Prepend --
- -------------
-
- procedure Prepend (Container : in out List; New_Item : Element_Type) is
- begin
- Insert (Container, First (Container), New_Item, 1);
- end Prepend;
-
- procedure Prepend
- (Container : in out List;
- New_Item : Element_Type;
- Count : Count_Type)
- is
- begin
- Insert (Container, First (Container), New_Item, Count);
- end Prepend;
-
- --------------
- -- Previous --
- --------------
-
- procedure Previous (Container : List; Position : in out Cursor) is
- begin
- Position := Previous (Container, Position);
- end Previous;
-
- function Previous (Container : List; Position : Cursor) return Cursor is
- begin
- if Position.Node = 0 then
- return No_Element;
- end if;
-
- if not Has_Element (Container, Position) then
- raise Program_Error with "Position cursor has no element";
- end if;
-
- return (Node => Container.Nodes (Position.Node).Prev);
- end Previous;
-
- ---------------
- -- Reference --
- ---------------
-
- function Reference
- (Container : not null access List;
- Position : Cursor) return not null access Element_Type
- is
- begin
- if not Has_Element (Container.all, Position) then
- raise Constraint_Error with "Position cursor has no element";
- end if;
-
- return Container.Nodes (Position.Node).Element;
- end Reference;
-
- ---------------------
- -- Replace_Element --
- ---------------------
-
- procedure Replace_Element
- (Container : in out List;
- Position : Cursor;
- New_Item : Element_Type)
- is
- begin
- if not Has_Element (Container, Position) then
- raise Constraint_Error with "Position cursor has no element";
- end if;
-
- pragma Assert
- (Vet (Container, Position), "bad cursor in Replace_Element");
-
- Finalize_Element (Container.Nodes (Position.Node).Element);
- Container.Nodes (Position.Node).Element := new Element_Type'(New_Item);
- end Replace_Element;
-
- ------------
- -- Resize --
- ------------
-
- procedure Resize (Container : in out List) is
- Min_Size : constant Count_Type := 100;
- begin
- if Container.Nodes = null then
- Container.Nodes := new Node_Array (1 .. Min_Size);
- Container.First := 0;
- Container.Last := 0;
- Container.Length := 0;
- Container.Free := -1;
-
- return;
- end if;
-
- if Container.Length /= Container.Nodes'Length then
- raise Program_Error with "List must be at size max to resize";
- end if;
-
- declare
- procedure Finalize_Node_Array is new Ada.Unchecked_Deallocation
- (Object => Node_Array,
- Name => Node_Array_Access);
-
- New_Size : constant Count_Type :=
- (if Container.Nodes'Length > Count_Type'Last / 2
- then Count_Type'Last
- else 2 * Container.Nodes'Length);
- New_Nodes : Node_Array_Access;
-
- begin
- New_Nodes :=
- new Node_Array (1 .. Count_Type'Max (New_Size, Min_Size));
-
- New_Nodes (1 .. Container.Nodes'Length) :=
- Container.Nodes (1 .. Container.Nodes'Length);
-
- Container.Free := -Container.Nodes'Length - 1;
-
- Finalize_Node_Array (Container.Nodes);
- Container.Nodes := New_Nodes;
- end;
- end Resize;
-
- ----------------------
- -- Reverse_Elements --
- ----------------------
-
- procedure Reverse_Elements (Container : in out List) is
- N : Node_Array_Access renames Container.Nodes;
- I : Count_Type := Container.First;
- J : Count_Type := Container.Last;
-
- procedure Swap (L : Count_Type; R : Count_Type);
-
- ----------
- -- Swap --
- ----------
-
- procedure Swap (L : Count_Type; R : Count_Type) is
- LN : constant Count_Type := N (L).Next;
- LP : constant Count_Type := N (L).Prev;
-
- RN : constant Count_Type := N (R).Next;
- RP : constant Count_Type := N (R).Prev;
-
- begin
- if LP /= 0 then
- N (LP).Next := R;
- end if;
-
- if RN /= 0 then
- N (RN).Prev := L;
- end if;
-
- N (L).Next := RN;
- N (R).Prev := LP;
-
- if LN = R then
- pragma Assert (RP = L);
-
- N (L).Prev := R;
- N (R).Next := L;
-
- else
- N (L).Prev := RP;
- N (RP).Next := L;
-
- N (R).Next := LN;
- N (LN).Prev := R;
- end if;
- end Swap;
-
- -- Start of processing for Reverse_Elements
-
- begin
- if Container.Length <= 1 then
- return;
- end if;
-
- pragma Assert (N (Container.First).Prev = 0);
- pragma Assert (N (Container.Last).Next = 0);
-
- Container.First := J;
- Container.Last := I;
- loop
- Swap (L => I, R => J);
-
- J := N (J).Next;
- exit when I = J;
-
- I := N (I).Prev;
- exit when I = J;
-
- Swap (L => J, R => I);
-
- I := N (I).Next;
- exit when I = J;
-
- J := N (J).Prev;
- exit when I = J;
- end loop;
-
- pragma Assert (N (Container.First).Prev = 0);
- pragma Assert (N (Container.Last).Next = 0);
- end Reverse_Elements;
-
- ------------------
- -- Reverse_Find --
- ------------------
-
- function Reverse_Find
- (Container : List;
- Item : Element_Type;
- Position : Cursor := No_Element) return Cursor
- is
- CFirst : Count_Type := Position.Node;
-
- begin
- if CFirst = 0 then
- CFirst := Container.Last;
- end if;
-
- if Container.Length = 0 then
- return No_Element;
- else
- while CFirst /= 0 loop
- if Container.Nodes (CFirst).Element.all = Item then
- return (Node => CFirst);
- else
- CFirst := Container.Nodes (CFirst).Prev;
- end if;
- end loop;
-
- return No_Element;
- end if;
- end Reverse_Find;
-
- ------------
- -- Splice --
- ------------
-
- procedure Splice
- (Target : in out List;
- Before : Cursor;
- Source : in out List)
- is
- SN : Node_Array_Access renames Source.Nodes;
- TN : Node_Array_Access renames Target.Nodes;
-
- begin
- if Target'Address = Source'Address then
- raise Program_Error with "Target and Source denote same container";
- end if;
-
- if Before.Node /= 0 then
- pragma Assert (Vet (Target, Before), "bad cursor in Splice");
- end if;
-
- if Is_Empty (Source) then
- return;
- end if;
-
- pragma Assert (SN (Source.First).Prev = 0);
- pragma Assert (SN (Source.Last).Next = 0);
-
- declare
- X : Count_Type;
-
- begin
- while not Is_Empty (Source) loop
- Allocate (Target, X);
-
- TN (X).Element := SN (Source.Last).Element;
-
- -- Insert the new node in Target
-
- Insert_Internal (Target, Before.Node, X);
-
- -- Free the last node of Source
-
- SN (Source.Last).Element := null;
- Delete_Last (Source);
- end loop;
- end;
-
- end Splice;
-
- procedure Splice
- (Target : in out List;
- Before : Cursor;
- Source : in out List;
- Position : in out Cursor)
- is
- begin
- if Target'Address = Source'Address then
- raise Program_Error with "Target and Source denote same container";
- end if;
-
- if Position.Node = 0 then
- raise Constraint_Error with "Position cursor has no element";
- end if;
-
- pragma Assert (Vet (Source, Position), "bad Position cursor in Splice");
-
- declare
- X : Count_Type;
-
- begin
- Allocate (Target, X);
-
- Target.Nodes (X).Element := Source.Nodes (Position.Node).Element;
-
- -- Insert the new node in Target
-
- Insert_Internal (Target, Before.Node, X);
-
- -- Free the node at position Position in Source
-
- Source.Nodes (Position.Node).Element := null;
- Delete (Source, Position);
-
- Position := (Node => X);
- end;
- end Splice;
-
- procedure Splice
- (Container : in out List;
- Before : Cursor;
- Position : Cursor)
- is
- N : Node_Array_Access renames Container.Nodes;
-
- begin
- if Before.Node /= 0 then
- pragma Assert
- (Vet (Container, Before), "bad Before cursor in Splice");
- end if;
-
- if Position.Node = 0 then
- raise Constraint_Error with "Position cursor has no element";
- end if;
-
- pragma Assert
- (Vet (Container, Position), "bad Position cursor in Splice");
-
- if Position.Node = Before.Node
- or else N (Position.Node).Next = Before.Node
- then
- return;
- end if;
-
- pragma Assert (Container.Length >= 2);
-
- if Before.Node = 0 then
- pragma Assert (Position.Node /= Container.Last);
-
- if Position.Node = Container.First then
- Container.First := N (Position.Node).Next;
- N (Container.First).Prev := 0;
-
- else
- N (N (Position.Node).Prev).Next := N (Position.Node).Next;
- N (N (Position.Node).Next).Prev := N (Position.Node).Prev;
- end if;
-
- N (Container.Last).Next := Position.Node;
- N (Position.Node).Prev := Container.Last;
-
- Container.Last := Position.Node;
- N (Container.Last).Next := 0;
-
- return;
- end if;
-
- if Before.Node = Container.First then
- pragma Assert (Position.Node /= Container.First);
-
- if Position.Node = Container.Last then
- Container.Last := N (Position.Node).Prev;
- N (Container.Last).Next := 0;
-
- else
- N (N (Position.Node).Prev).Next := N (Position.Node).Next;
- N (N (Position.Node).Next).Prev := N (Position.Node).Prev;
- end if;
-
- N (Container.First).Prev := Position.Node;
- N (Position.Node).Next := Container.First;
-
- Container.First := Position.Node;
- N (Container.First).Prev := 0;
-
- return;
- end if;
-
- if Position.Node = Container.First then
- Container.First := N (Position.Node).Next;
- N (Container.First).Prev := 0;
-
- elsif Position.Node = Container.Last then
- Container.Last := N (Position.Node).Prev;
- N (Container.Last).Next := 0;
-
- else
- N (N (Position.Node).Prev).Next := N (Position.Node).Next;
- N (N (Position.Node).Next).Prev := N (Position.Node).Prev;
- end if;
-
- N (N (Before.Node).Prev).Next := Position.Node;
- N (Position.Node).Prev := N (Before.Node).Prev;
-
- N (Before.Node).Prev := Position.Node;
- N (Position.Node).Next := Before.Node;
-
- pragma Assert (N (Container.First).Prev = 0);
- pragma Assert (N (Container.Last).Next = 0);
- end Splice;
-
- ----------
- -- Swap --
- ----------
-
- procedure Swap
- (Container : in out List;
- I : Cursor;
- J : Cursor)
- is
- begin
- if I.Node = 0 then
- raise Constraint_Error with "I cursor has no element";
- end if;
-
- if J.Node = 0 then
- raise Constraint_Error with "J cursor has no element";
- end if;
-
- if I.Node = J.Node then
- return;
- end if;
-
- pragma Assert (Vet (Container, I), "bad I cursor in Swap");
- pragma Assert (Vet (Container, J), "bad J cursor in Swap");
-
- declare
- NN : Node_Array_Access renames Container.Nodes;
- NI : Node_Type renames NN (I.Node);
- NJ : Node_Type renames NN (J.Node);
-
- EI_Copy : constant Element_Access := NI.Element;
-
- begin
- NI.Element := NJ.Element;
- NJ.Element := EI_Copy;
- end;
- end Swap;
-
- ----------------
- -- Swap_Links --
- ----------------
-
- procedure Swap_Links
- (Container : in out List;
- I : Cursor;
- J : Cursor)
- is
- I_Next : Cursor;
- J_Next : Cursor;
-
- begin
- if I.Node = 0 then
- raise Constraint_Error with "I cursor has no element";
- end if;
-
- if J.Node = 0 then
- raise Constraint_Error with "J cursor has no element";
- end if;
-
- if I.Node = J.Node then
- return;
- end if;
-
- pragma Assert (Vet (Container, I), "bad I cursor in Swap_Links");
- pragma Assert (Vet (Container, J), "bad J cursor in Swap_Links");
-
- I_Next := Next (Container, I);
-
- if I_Next = J then
- Splice (Container, Before => I, Position => J);
-
- else
- J_Next := Next (Container, J);
-
- if J_Next = I then
- Splice (Container, Before => J, Position => I);
-
- else
- pragma Assert (Container.Length >= 3);
- Splice (Container, Before => I_Next, Position => J);
- Splice (Container, Before => J_Next, Position => I);
- end if;
- end if;
- end Swap_Links;
-
- ---------
- -- Vet --
- ---------
-
- function Vet (L : List; Position : Cursor) return Boolean is
- N : Node_Array_Access renames L.Nodes;
- begin
- if not Container_Checks'Enabled then
- return True;
- end if;
-
- if L.Length = 0 then
- return False;
- end if;
-
- if L.First = 0 then
- return False;
- end if;
-
- if L.Last = 0 then
- return False;
- end if;
-
- if Position.Node > L.Nodes'Length then
- return False;
- end if;
-
- if N (Position.Node).Prev < 0
- or else N (Position.Node).Prev > L.Nodes'Length
- then
- return False;
- end if;
-
- if N (Position.Node).Next > L.Nodes'Length then
- return False;
- end if;
-
- if N (L.First).Prev /= 0 then
- return False;
- end if;
-
- if N (L.Last).Next /= 0 then
- return False;
- end if;
-
- if N (Position.Node).Prev = 0 and then Position.Node /= L.First then
- return False;
- end if;
-
- if N (Position.Node).Next = 0 and then Position.Node /= L.Last then
- return False;
- end if;
-
- if L.Length = 1 then
- return L.First = L.Last;
- end if;
-
- if L.First = L.Last then
- return False;
- end if;
-
- if N (L.First).Next = 0 then
- return False;
- end if;
-
- if N (L.Last).Prev = 0 then
- return False;
- end if;
-
- if N (N (L.First).Next).Prev /= L.First then
- return False;
- end if;
-
- if N (N (L.Last).Prev).Next /= L.Last then
- return False;
- end if;
-
- if L.Length = 2 then
- if N (L.First).Next /= L.Last then
- return False;
- end if;
-
- if N (L.Last).Prev /= L.First then
- return False;
- end if;
-
- return True;
- end if;
-
- if N (L.First).Next = L.Last then
- return False;
- end if;
-
- if N (L.Last).Prev = L.First then
- return False;
- end if;
-
- if Position.Node = L.First then
- return True;
- end if;
-
- if Position.Node = L.Last then
- return True;
- end if;
-
- if N (Position.Node).Next = 0 then
- return False;
- end if;
-
- if N (Position.Node).Prev = 0 then
- return False;
- end if;
-
- if N (N (Position.Node).Next).Prev /= Position.Node then
- return False;
- end if;
-
- if N (N (Position.Node).Prev).Next /= Position.Node then
- return False;
- end if;
-
- if L.Length = 3 then
- if N (L.First).Next /= Position.Node then
- return False;
- end if;
-
- if N (L.Last).Prev /= Position.Node then
- return False;
- end if;
- end if;
-
- return True;
- end Vet;
-
-end Ada.Containers.Formal_Indefinite_Doubly_Linked_Lists;
diff --git a/gcc/ada/libgnat/a-cfidll.ads b/gcc/ada/libgnat/a-cfidll.ads
index c4d244a..cbddde3 100644
--- a/gcc/ada/libgnat/a-cfidll.ads
+++ b/gcc/ada/libgnat/a-cfidll.ads
@@ -29,1642 +29,12 @@
-- <http://www.gnu.org/licenses/>. --
------------------------------------------------------------------------------
-with Ada.Containers.Functional_Vectors;
-with Ada.Containers.Functional_Maps;
-private with Ada.Finalization;
-
generic
- type Element_Type is private;
- with function "=" (Left, Right : Element_Type) return Boolean is <>;
-
-package Ada.Containers.Formal_Indefinite_Doubly_Linked_Lists with
- SPARK_Mode
-is
- -- Contracts in this unit are meant for analysis only, not for run-time
- -- checking.
-
- pragma Assertion_Policy (Pre => Ignore);
- pragma Assertion_Policy (Post => Ignore);
- pragma Assertion_Policy (Contract_Cases => Ignore);
- pragma Annotate (CodePeer, Skip_Analysis);
-
- type List is private with
- Iterable => (First => First,
- Next => Next,
- Has_Element => Has_Element,
- Element => Element),
- Default_Initial_Condition => Is_Empty (List);
-
- type Cursor is record
- Node : Count_Type := 0;
- end record;
-
- No_Element : constant Cursor := Cursor'(Node => 0);
-
- function Length (Container : List) return Count_Type with
- Global => null;
-
- function Empty_List return List with
- Global => null,
- Post => Length (Empty_List'Result) = 0;
-
- pragma Unevaluated_Use_Of_Old (Allow);
-
- package Formal_Model with Ghost is
- subtype Positive_Count_Type is Count_Type range 1 .. Count_Type'Last;
-
- package M is new Ada.Containers.Functional_Vectors
- (Index_Type => Positive_Count_Type,
- Element_Type => Element_Type);
-
- function "="
- (Left : M.Sequence;
- Right : M.Sequence) return Boolean renames M."=";
-
- function "<"
- (Left : M.Sequence;
- Right : M.Sequence) return Boolean renames M."<";
-
- function "<="
- (Left : M.Sequence;
- Right : M.Sequence) return Boolean renames M."<=";
-
- function M_Elements_In_Union
- (Container : M.Sequence;
- Left : M.Sequence;
- Right : M.Sequence) return Boolean
- -- The elements of Container are contained in either Left or Right
- with
- Global => null,
- Post =>
- M_Elements_In_Union'Result =
- (for all I in 1 .. M.Length (Container) =>
- (for some J in 1 .. M.Length (Left) =>
- Element (Container, I) = Element (Left, J))
- or (for some J in 1 .. M.Length (Right) =>
- Element (Container, I) = Element (Right, J)));
- pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_In_Union);
-
- function M_Elements_Included
- (Left : M.Sequence;
- L_Fst : Positive_Count_Type := 1;
- L_Lst : Count_Type;
- Right : M.Sequence;
- R_Fst : Positive_Count_Type := 1;
- R_Lst : Count_Type) return Boolean
- -- The elements of the slice from L_Fst to L_Lst in Left are contained
- -- in the slide from R_Fst to R_Lst in Right.
- with
- Global => null,
- Pre => L_Lst <= M.Length (Left) and R_Lst <= M.Length (Right),
- Post =>
- M_Elements_Included'Result =
- (for all I in L_Fst .. L_Lst =>
- (for some J in R_Fst .. R_Lst =>
- Element (Left, I) = Element (Right, J)));
- pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_Included);
-
- function M_Elements_Reversed
- (Left : M.Sequence;
- Right : M.Sequence) return Boolean
- -- Right is Left in reverse order
- with
- Global => null,
- Post =>
- M_Elements_Reversed'Result =
- (M.Length (Left) = M.Length (Right)
- and (for all I in 1 .. M.Length (Left) =>
- Element (Left, I) =
- Element (Right, M.Length (Left) - I + 1))
- and (for all I in 1 .. M.Length (Left) =>
- Element (Right, I) =
- Element (Left, M.Length (Left) - I + 1)));
- pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_Reversed);
-
- function M_Elements_Swapped
- (Left : M.Sequence;
- Right : M.Sequence;
- X : Positive_Count_Type;
- Y : Positive_Count_Type) return Boolean
- -- Elements stored at X and Y are reversed in Left and Right
- with
- Global => null,
- Pre => X <= M.Length (Left) and Y <= M.Length (Left),
- Post =>
- M_Elements_Swapped'Result =
- (M.Length (Left) = M.Length (Right)
- and Element (Left, X) = Element (Right, Y)
- and Element (Left, Y) = Element (Right, X)
- and M.Equal_Except (Left, Right, X, Y));
- pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_Swapped);
-
- package P is new Ada.Containers.Functional_Maps
- (Key_Type => Cursor,
- Element_Type => Positive_Count_Type,
- Equivalent_Keys => "=",
- Enable_Handling_Of_Equivalence => False);
-
- function "="
- (Left : P.Map;
- Right : P.Map) return Boolean renames P."=";
-
- function "<="
- (Left : P.Map;
- Right : P.Map) return Boolean renames P."<=";
-
- function P_Positions_Shifted
- (Small : P.Map;
- Big : P.Map;
- Cut : Positive_Count_Type;
- Count : Count_Type := 1) return Boolean
- with
- Global => null,
- Post =>
- P_Positions_Shifted'Result =
-
- -- Big contains all cursors of Small
-
- (P.Keys_Included (Small, Big)
-
- -- Cursors located before Cut are not moved, cursors located
- -- after are shifted by Count.
-
- and (for all I of Small =>
- (if P.Get (Small, I) < Cut then
- P.Get (Big, I) = P.Get (Small, I)
- else
- P.Get (Big, I) - Count = P.Get (Small, I)))
-
- -- New cursors of Big (if any) are between Cut and Cut - 1 +
- -- Count.
-
- and (for all I of Big =>
- P.Has_Key (Small, I)
- or P.Get (Big, I) - Count in Cut - Count .. Cut - 1));
-
- function P_Positions_Swapped
- (Left : P.Map;
- Right : P.Map;
- X : Cursor;
- Y : Cursor) return Boolean
- -- Left and Right contain the same cursors, but the positions of X and Y
- -- are reversed.
- with
- Ghost,
- Global => null,
- Post =>
- P_Positions_Swapped'Result =
- (P.Same_Keys (Left, Right)
- and P.Elements_Equal_Except (Left, Right, X, Y)
- and P.Has_Key (Left, X)
- and P.Has_Key (Left, Y)
- and P.Get (Left, X) = P.Get (Right, Y)
- and P.Get (Left, Y) = P.Get (Right, X));
-
- function P_Positions_Truncated
- (Small : P.Map;
- Big : P.Map;
- Cut : Positive_Count_Type;
- Count : Count_Type := 1) return Boolean
- with
- Ghost,
- Global => null,
- Post =>
- P_Positions_Truncated'Result =
-
- -- Big contains all cursors of Small at the same position
-
- (Small <= Big
-
- -- New cursors of Big (if any) are between Cut and Cut - 1 +
- -- Count.
-
- and (for all I of Big =>
- P.Has_Key (Small, I)
- or P.Get (Big, I) - Count in Cut - Count .. Cut - 1));
-
- function Mapping_Preserved
- (M_Left : M.Sequence;
- M_Right : M.Sequence;
- P_Left : P.Map;
- P_Right : P.Map) return Boolean
- with
- Ghost,
- Global => null,
- Post =>
- (if Mapping_Preserved'Result then
-
- -- Left and Right contain the same cursors
-
- P.Same_Keys (P_Left, P_Right)
-
- -- Mappings from cursors to elements induced by M_Left, P_Left
- -- and M_Right, P_Right are the same.
-
- and (for all C of P_Left =>
- M.Get (M_Left, P.Get (P_Left, C)) =
- M.Get (M_Right, P.Get (P_Right, C))));
-
- function Model (Container : List) return M.Sequence with
- -- The high-level model of a list is a sequence of elements. Cursors are
- -- not represented in this model.
-
- Ghost,
- Global => null,
- Post => M.Length (Model'Result) = Length (Container);
- pragma Annotate (GNATprove, Iterable_For_Proof, "Model", Model);
-
- function Positions (Container : List) return P.Map with
- -- The Positions map is used to model cursors. It only contains valid
- -- cursors and map them to their position in the container.
-
- Ghost,
- Global => null,
- Post =>
- not P.Has_Key (Positions'Result, No_Element)
-
- -- Positions of cursors are smaller than the container's length
-
- and then
- (for all I of Positions'Result =>
- P.Get (Positions'Result, I) in 1 .. Length (Container)
-
- -- No two cursors have the same position. Note that we do not
- -- state that there is a cursor in the map for each position, as
- -- it is rarely needed.
-
- and then
- (for all J of Positions'Result =>
- (if P.Get (Positions'Result, I) = P.Get (Positions'Result, J)
- then I = J)));
-
- procedure Lift_Abstraction_Level (Container : List) with
- -- Lift_Abstraction_Level is a ghost procedure that does nothing but
- -- assume that we can access to the same elements by iterating over
- -- positions or cursors.
- -- This information is not generally useful except when switching from
- -- a low-level cursor-aware view of a container to a high-level
- -- position-based view.
-
- Ghost,
- Global => null,
- Post =>
- (for all Elt of Model (Container) =>
- (for some I of Positions (Container) =>
- M.Get (Model (Container), P.Get (Positions (Container), I)) =
- Elt));
-
- function Element
- (S : M.Sequence;
- I : Count_Type) return Element_Type renames M.Get;
- -- To improve readability of contracts, we rename the function used to
- -- access an element in the model to Element.
-
- end Formal_Model;
- use Formal_Model;
-
- function "=" (Left, Right : List) return Boolean with
- Global => null,
- Post => "="'Result = (Model (Left) = Model (Right));
-
- function Is_Empty (Container : List) return Boolean with
- Global => null,
- Post => Is_Empty'Result = (Length (Container) = 0);
-
- procedure Clear (Container : in out List) with
- Global => null,
- Post => Length (Container) = 0;
-
- procedure Assign (Target : in out List; Source : List) with
- Global => null,
- Post => Model (Target) = Model (Source);
-
- function Copy (Source : List) return List with
- Global => null,
- Post =>
- Model (Copy'Result) = Model (Source)
- and Positions (Copy'Result) = Positions (Source);
-
- function Element
- (Container : List;
- Position : Cursor) return Element_Type
- with
- Global => null,
- Pre => Has_Element (Container, Position),
- Post =>
- Element'Result =
- Element (Model (Container), P.Get (Positions (Container), Position));
- pragma Annotate (GNATprove, Inline_For_Proof, Element);
-
- procedure Replace_Element
- (Container : in out List;
- Position : Cursor;
- New_Item : Element_Type)
- with
- Global => null,
- Pre => Has_Element (Container, Position),
- Post =>
- Length (Container) = Length (Container)'Old
-
- -- Cursors are preserved
-
- and Positions (Container)'Old = Positions (Container)
-
- -- The element at the position of Position in Container is New_Item
-
- and Element
- (Model (Container),
- P.Get (Positions (Container), Position)) = New_Item
-
- -- Other elements are preserved
-
- and M.Equal_Except
- (Model (Container)'Old,
- Model (Container),
- P.Get (Positions (Container), Position));
-
- function At_End (E : access constant List) return access constant List
- is (E)
- with Ghost,
- Annotate => (GNATprove, At_End_Borrow);
-
- function At_End
- (E : access constant Element_Type) return access constant Element_Type
- is (E)
- with Ghost,
- Annotate => (GNATprove, At_End_Borrow);
-
- function Constant_Reference
- (Container : List;
- Position : Cursor) return not null access constant Element_Type
- with
- Global => null,
- Pre => Has_Element (Container, Position),
- Post =>
- Constant_Reference'Result.all =
- Element (Model (Container), P.Get (Positions (Container), Position));
-
- function Reference
- (Container : not null access List;
- Position : Cursor) return not null access Element_Type
- with
- Global => null,
- Pre => Has_Element (Container.all, Position),
- Post =>
- Length (Container.all) = Length (At_End (Container).all)
-
- -- Cursors are preserved
-
- and Positions (Container.all) = Positions (At_End (Container).all)
-
- -- Container will have Result.all at position Position
-
- and At_End (Reference'Result).all =
- Element (Model (At_End (Container).all),
- P.Get (Positions (At_End (Container).all), Position))
-
- -- All other elements are preserved
-
- and M.Equal_Except
- (Model (Container.all),
- Model (At_End (Container).all),
- P.Get (Positions (At_End (Container).all), Position));
-
- procedure Move (Target : in out List; Source : in out List) with
- Global => null,
- Post => Model (Target) = Model (Source'Old) and Length (Source) = 0;
-
- procedure Insert
- (Container : in out List;
- Before : Cursor;
- New_Item : Element_Type)
- with
- Global => null,
- Pre =>
- Length (Container) < Count_Type'Last
- and then (Has_Element (Container, Before)
- or else Before = No_Element),
- Post => Length (Container) = Length (Container)'Old + 1,
- Contract_Cases =>
- (Before = No_Element =>
-
- -- Positions contains a new mapping from the last cursor of
- -- Container to its length.
-
- P.Get (Positions (Container), Last (Container)) = Length (Container)
-
- -- Other cursors come from Container'Old
-
- and P.Keys_Included_Except
- (Left => Positions (Container),
- Right => Positions (Container)'Old,
- New_Key => Last (Container))
-
- -- Cursors of Container'Old keep the same position
-
- and Positions (Container)'Old <= Positions (Container)
-
- -- Model contains a new element New_Item at the end
-
- and Element (Model (Container), Length (Container)) = New_Item
-
- -- Elements of Container'Old are preserved
-
- and Model (Container)'Old <= Model (Container),
-
- others =>
-
- -- The elements of Container located before Before are preserved
-
- M.Range_Equal
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => 1,
- Lst => P.Get (Positions (Container)'Old, Before) - 1)
-
- -- Other elements are shifted by 1
-
- and M.Range_Shifted
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => P.Get (Positions (Container)'Old, Before),
- Lst => Length (Container)'Old,
- Offset => 1)
-
- -- New_Item is stored at the previous position of Before in
- -- Container.
-
- and Element
- (Model (Container),
- P.Get (Positions (Container)'Old, Before)) = New_Item
-
- -- A new cursor has been inserted at position Before in Container
-
- and P_Positions_Shifted
- (Positions (Container)'Old,
- Positions (Container),
- Cut => P.Get (Positions (Container)'Old, Before)));
-
- procedure Insert
- (Container : in out List;
- Before : Cursor;
- New_Item : Element_Type;
- Count : Count_Type)
- with
- Global => null,
- Pre =>
- Length (Container) <= Count_Type'Last - Count
- and then (Has_Element (Container, Before)
- or else Before = No_Element),
- Post => Length (Container) = Length (Container)'Old + Count,
- Contract_Cases =>
- (Before = No_Element =>
-
- -- The elements of Container are preserved
-
- M.Range_Equal
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => 1,
- Lst => Length (Container)'Old)
-
- -- Container contains Count times New_Item at the end
-
- and (if Count > 0 then
- M.Constant_Range
- (Container => Model (Container),
- Fst => Length (Container)'Old + 1,
- Lst => Length (Container),
- Item => New_Item))
-
- -- Count cursors have been inserted at the end of Container
-
- and P_Positions_Truncated
- (Positions (Container)'Old,
- Positions (Container),
- Cut => Length (Container)'Old + 1,
- Count => Count),
-
- others =>
-
- -- The elements of Container located before Before are preserved
-
- M.Range_Equal
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => 1,
- Lst => P.Get (Positions (Container)'Old, Before) - 1)
-
- -- Other elements are shifted by Count
-
- and M.Range_Shifted
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => P.Get (Positions (Container)'Old, Before),
- Lst => Length (Container)'Old,
- Offset => Count)
-
- -- Container contains Count times New_Item after position Before
-
- and M.Constant_Range
- (Container => Model (Container),
- Fst => P.Get (Positions (Container)'Old, Before),
- Lst =>
- P.Get (Positions (Container)'Old, Before) - 1 + Count,
- Item => New_Item)
-
- -- Count cursors have been inserted at position Before in
- -- Container.
-
- and P_Positions_Shifted
- (Positions (Container)'Old,
- Positions (Container),
- Cut => P.Get (Positions (Container)'Old, Before),
- Count => Count));
-
- procedure Insert
- (Container : in out List;
- Before : Cursor;
- New_Item : Element_Type;
- Position : out Cursor)
- with
- Global => null,
- Pre =>
- Length (Container) < Count_Type'Last
- and then (Has_Element (Container, Before)
- or else Before = No_Element),
- Post =>
- Length (Container) = Length (Container)'Old + 1
-
- -- Positions is valid in Container and it is located either before
- -- Before if it is valid in Container or at the end if it is
- -- No_Element.
-
- and P.Has_Key (Positions (Container), Position)
- and (if Before = No_Element then
- P.Get (Positions (Container), Position) = Length (Container)
- else
- P.Get (Positions (Container), Position) =
- P.Get (Positions (Container)'Old, Before))
-
- -- The elements of Container located before Position are preserved
-
- and M.Range_Equal
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => 1,
- Lst => P.Get (Positions (Container), Position) - 1)
-
- -- Other elements are shifted by 1
-
- and M.Range_Shifted
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => P.Get (Positions (Container), Position),
- Lst => Length (Container)'Old,
- Offset => 1)
-
- -- New_Item is stored at Position in Container
-
- and Element
- (Model (Container),
- P.Get (Positions (Container), Position)) = New_Item
-
- -- A new cursor has been inserted at position Position in Container
-
- and P_Positions_Shifted
- (Positions (Container)'Old,
- Positions (Container),
- Cut => P.Get (Positions (Container), Position));
-
- procedure Insert
- (Container : in out List;
- Before : Cursor;
- New_Item : Element_Type;
- Position : out Cursor;
- Count : Count_Type)
- with
- Global => null,
- Pre =>
- Length (Container) <= Count_Type'Last - Count
- and then (Has_Element (Container, Before)
- or else Before = No_Element),
- Post => Length (Container) = Length (Container)'Old + Count,
- Contract_Cases =>
- (Count = 0 =>
- Position = Before
- and Model (Container) = Model (Container)'Old
- and Positions (Container) = Positions (Container)'Old,
-
- others =>
-
- -- Positions is valid in Container and it is located either before
- -- Before if it is valid in Container or at the end if it is
- -- No_Element.
-
- P.Has_Key (Positions (Container), Position)
- and (if Before = No_Element then
- P.Get (Positions (Container), Position) =
- Length (Container)'Old + 1
- else
- P.Get (Positions (Container), Position) =
- P.Get (Positions (Container)'Old, Before))
-
- -- The elements of Container located before Position are preserved
-
- and M.Range_Equal
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => 1,
- Lst => P.Get (Positions (Container), Position) - 1)
-
- -- Other elements are shifted by Count
-
- and M.Range_Shifted
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => P.Get (Positions (Container), Position),
- Lst => Length (Container)'Old,
- Offset => Count)
-
- -- Container contains Count times New_Item after position Position
-
- and M.Constant_Range
- (Container => Model (Container),
- Fst => P.Get (Positions (Container), Position),
- Lst =>
- P.Get (Positions (Container), Position) - 1 + Count,
- Item => New_Item)
-
- -- Count cursor have been inserted at Position in Container
-
- and P_Positions_Shifted
- (Positions (Container)'Old,
- Positions (Container),
- Cut => P.Get (Positions (Container), Position),
- Count => Count));
-
- procedure Prepend (Container : in out List; New_Item : Element_Type) with
- Global => null,
- Pre => Length (Container) < Count_Type'Last,
- Post =>
- Length (Container) = Length (Container)'Old + 1
-
- -- Elements are shifted by 1
-
- and M.Range_Shifted
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => 1,
- Lst => Length (Container)'Old,
- Offset => 1)
-
- -- New_Item is the first element of Container
-
- and Element (Model (Container), 1) = New_Item
-
- -- A new cursor has been inserted at the beginning of Container
-
- and P_Positions_Shifted
- (Positions (Container)'Old,
- Positions (Container),
- Cut => 1);
-
- procedure Prepend
- (Container : in out List;
- New_Item : Element_Type;
- Count : Count_Type)
- with
- Global => null,
- Pre => Length (Container) <= Count_Type'Last - Count,
- Post =>
- Length (Container) = Length (Container)'Old + Count
-
- -- Elements are shifted by Count
-
- and M.Range_Shifted
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => 1,
- Lst => Length (Container)'Old,
- Offset => Count)
-
- -- Container starts with Count times New_Item
-
- and M.Constant_Range
- (Container => Model (Container),
- Fst => 1,
- Lst => Count,
- Item => New_Item)
-
- -- Count cursors have been inserted at the beginning of Container
-
- and P_Positions_Shifted
- (Positions (Container)'Old,
- Positions (Container),
- Cut => 1,
- Count => Count);
-
- procedure Append (Container : in out List; New_Item : Element_Type) with
- Global => null,
- Pre => Length (Container) < Count_Type'Last,
- Post =>
- Length (Container) = Length (Container)'Old + 1
-
- -- Positions contains a new mapping from the last cursor of Container
- -- to its length.
-
- and P.Get (Positions (Container), Last (Container)) =
- Length (Container)
-
- -- Other cursors come from Container'Old
-
- and P.Keys_Included_Except
- (Left => Positions (Container),
- Right => Positions (Container)'Old,
- New_Key => Last (Container))
-
- -- Cursors of Container'Old keep the same position
-
- and Positions (Container)'Old <= Positions (Container)
-
- -- Model contains a new element New_Item at the end
-
- and Element (Model (Container), Length (Container)) = New_Item
-
- -- Elements of Container'Old are preserved
-
- and Model (Container)'Old <= Model (Container);
-
- procedure Append
- (Container : in out List;
- New_Item : Element_Type;
- Count : Count_Type)
- with
- Global => null,
- Pre => Length (Container) <= Count_Type'Last - Count,
- Post =>
- Length (Container) = Length (Container)'Old + Count
-
- -- The elements of Container are preserved
-
- and Model (Container)'Old <= Model (Container)
-
- -- Container contains Count times New_Item at the end
-
- and (if Count > 0 then
- M.Constant_Range
- (Container => Model (Container),
- Fst => Length (Container)'Old + 1,
- Lst => Length (Container),
- Item => New_Item))
-
- -- Count cursors have been inserted at the end of Container
-
- and P_Positions_Truncated
- (Positions (Container)'Old,
- Positions (Container),
- Cut => Length (Container)'Old + 1,
- Count => Count);
-
- procedure Delete (Container : in out List; Position : in out Cursor) with
- Global => null,
- Depends => (Container =>+ Position, Position => null),
- Pre => Has_Element (Container, Position),
- Post =>
- Length (Container) = Length (Container)'Old - 1
-
- -- Position is set to No_Element
-
- and Position = No_Element
-
- -- The elements of Container located before Position are preserved.
-
- and M.Range_Equal
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => 1,
- Lst => P.Get (Positions (Container)'Old, Position'Old) - 1)
-
- -- The elements located after Position are shifted by 1
-
- and M.Range_Shifted
- (Left => Model (Container),
- Right => Model (Container)'Old,
- Fst => P.Get (Positions (Container)'Old, Position'Old),
- Lst => Length (Container),
- Offset => 1)
-
- -- Position has been removed from Container
-
- and P_Positions_Shifted
- (Positions (Container),
- Positions (Container)'Old,
- Cut => P.Get (Positions (Container)'Old, Position'Old));
-
- procedure Delete
- (Container : in out List;
- Position : in out Cursor;
- Count : Count_Type)
- with
- Global => null,
- Pre => Has_Element (Container, Position),
- Post =>
- Length (Container) in
- Length (Container)'Old - Count .. Length (Container)'Old
-
- -- Position is set to No_Element
-
- and Position = No_Element
-
- -- The elements of Container located before Position are preserved.
-
- and M.Range_Equal
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => 1,
- Lst => P.Get (Positions (Container)'Old, Position'Old) - 1),
-
- Contract_Cases =>
-
- -- All the elements after Position have been erased
-
- (Length (Container) - Count < P.Get (Positions (Container), Position) =>
- Length (Container) =
- P.Get (Positions (Container)'Old, Position'Old) - 1
-
- -- At most Count cursors have been removed at the end of Container
-
- and P_Positions_Truncated
- (Positions (Container),
- Positions (Container)'Old,
- Cut => P.Get (Positions (Container)'Old, Position'Old),
- Count => Count),
-
- others =>
- Length (Container) = Length (Container)'Old - Count
-
- -- Other elements are shifted by Count
-
- and M.Range_Shifted
- (Left => Model (Container),
- Right => Model (Container)'Old,
- Fst => P.Get (Positions (Container)'Old, Position'Old),
- Lst => Length (Container),
- Offset => Count)
-
- -- Count cursors have been removed from Container at Position
-
- and P_Positions_Shifted
- (Positions (Container),
- Positions (Container)'Old,
- Cut => P.Get (Positions (Container)'Old, Position'Old),
- Count => Count));
-
- procedure Delete_First (Container : in out List) with
- Global => null,
- Pre => not Is_Empty (Container),
- Post =>
- Length (Container) = Length (Container)'Old - 1
-
- -- The elements of Container are shifted by 1
-
- and M.Range_Shifted
- (Left => Model (Container),
- Right => Model (Container)'Old,
- Fst => 1,
- Lst => Length (Container),
- Offset => 1)
-
- -- The first cursor of Container has been removed
-
- and P_Positions_Shifted
- (Positions (Container),
- Positions (Container)'Old,
- Cut => 1);
-
- procedure Delete_First (Container : in out List; Count : Count_Type) with
- Global => null,
- Contract_Cases =>
-
- -- All the elements of Container have been erased
-
- (Length (Container) <= Count =>
- Length (Container) = 0,
-
- others =>
- Length (Container) = Length (Container)'Old - Count
-
- -- Elements of Container are shifted by Count
-
- and M.Range_Shifted
- (Left => Model (Container),
- Right => Model (Container)'Old,
- Fst => 1,
- Lst => Length (Container),
- Offset => Count)
-
- -- The first Count cursors have been removed from Container
-
- and P_Positions_Shifted
- (Positions (Container),
- Positions (Container)'Old,
- Cut => 1,
- Count => Count));
-
- procedure Delete_Last (Container : in out List) with
- Global => null,
- Pre => not Is_Empty (Container),
- Post =>
- Length (Container) = Length (Container)'Old - 1
-
- -- The elements of Container are preserved
-
- and Model (Container) <= Model (Container)'Old
-
- -- The last cursor of Container has been removed
-
- and not P.Has_Key (Positions (Container), Last (Container)'Old)
-
- -- Other cursors are still valid
-
- and P.Keys_Included_Except
- (Left => Positions (Container)'Old,
- Right => Positions (Container)'Old,
- New_Key => Last (Container)'Old)
-
- -- The positions of other cursors are preserved
-
- and Positions (Container) <= Positions (Container)'Old;
-
- procedure Delete_Last (Container : in out List; Count : Count_Type) with
- Global => null,
- Contract_Cases =>
-
- -- All the elements of Container have been erased
-
- (Length (Container) <= Count =>
- Length (Container) = 0,
-
- others =>
- Length (Container) = Length (Container)'Old - Count
-
- -- The elements of Container are preserved
-
- and Model (Container) <= Model (Container)'Old
-
- -- At most Count cursors have been removed at the end of Container
-
- and P_Positions_Truncated
- (Positions (Container),
- Positions (Container)'Old,
- Cut => Length (Container) + 1,
- Count => Count));
-
- procedure Reverse_Elements (Container : in out List) with
- Global => null,
- Post => M_Elements_Reversed (Model (Container)'Old, Model (Container));
-
- procedure Swap
- (Container : in out List;
- I : Cursor;
- J : Cursor)
- with
- Global => null,
- Pre => Has_Element (Container, I) and then Has_Element (Container, J),
- Post =>
- M_Elements_Swapped
- (Model (Container)'Old,
- Model (Container),
- X => P.Get (Positions (Container)'Old, I),
- Y => P.Get (Positions (Container)'Old, J))
-
- and Positions (Container) = Positions (Container)'Old;
-
- procedure Swap_Links
- (Container : in out List;
- I : Cursor;
- J : Cursor)
- with
- Global => null,
- Pre => Has_Element (Container, I) and then Has_Element (Container, J),
- Post =>
- M_Elements_Swapped
- (Model (Container'Old),
- Model (Container),
- X => P.Get (Positions (Container)'Old, I),
- Y => P.Get (Positions (Container)'Old, J))
- and P_Positions_Swapped
- (Positions (Container)'Old, Positions (Container), I, J);
-
- procedure Splice
- (Target : in out List;
- Before : Cursor;
- Source : in out List)
- -- Target and Source should not be aliased
- with
- Global => null,
- Pre =>
- Length (Source) <= Count_Type'Last - Length (Target)
- and then (Has_Element (Target, Before) or else Before = No_Element),
- Post =>
- Length (Source) = 0
- and Length (Target) = Length (Target)'Old + Length (Source)'Old,
- Contract_Cases =>
- (Before = No_Element =>
-
- -- The elements of Target are preserved
-
- M.Range_Equal
- (Left => Model (Target)'Old,
- Right => Model (Target),
- Fst => 1,
- Lst => Length (Target)'Old)
-
- -- The elements of Source are appended to target, the order is not
- -- specified.
-
- and M_Elements_Included
- (Left => Model (Source)'Old,
- L_Lst => Length (Source)'Old,
- Right => Model (Target),
- R_Fst => Length (Target)'Old + 1,
- R_Lst => Length (Target))
-
- and M_Elements_Included
- (Left => Model (Target),
- L_Fst => Length (Target)'Old + 1,
- L_Lst => Length (Target),
- Right => Model (Source)'Old,
- R_Lst => Length (Source)'Old)
-
- -- Cursors have been inserted at the end of Target
-
- and P_Positions_Truncated
- (Positions (Target)'Old,
- Positions (Target),
- Cut => Length (Target)'Old + 1,
- Count => Length (Source)'Old),
-
- others =>
-
- -- The elements of Target located before Before are preserved
-
- M.Range_Equal
- (Left => Model (Target)'Old,
- Right => Model (Target),
- Fst => 1,
- Lst => P.Get (Positions (Target)'Old, Before) - 1)
-
- -- The elements of Source are inserted before Before, the order is
- -- not specified.
-
- and M_Elements_Included
- (Left => Model (Source)'Old,
- L_Lst => Length (Source)'Old,
- Right => Model (Target),
- R_Fst => P.Get (Positions (Target)'Old, Before),
- R_Lst =>
- P.Get (Positions (Target)'Old, Before) - 1 +
- Length (Source)'Old)
-
- and M_Elements_Included
- (Left => Model (Target),
- L_Fst => P.Get (Positions (Target)'Old, Before),
- L_Lst =>
- P.Get (Positions (Target)'Old, Before) - 1 +
- Length (Source)'Old,
- Right => Model (Source)'Old,
- R_Lst => Length (Source)'Old)
-
- -- Other elements are shifted by the length of Source
-
- and M.Range_Shifted
- (Left => Model (Target)'Old,
- Right => Model (Target),
- Fst => P.Get (Positions (Target)'Old, Before),
- Lst => Length (Target)'Old,
- Offset => Length (Source)'Old)
-
- -- Cursors have been inserted at position Before in Target
-
- and P_Positions_Shifted
- (Positions (Target)'Old,
- Positions (Target),
- Cut => P.Get (Positions (Target)'Old, Before),
- Count => Length (Source)'Old));
-
- procedure Splice
- (Target : in out List;
- Before : Cursor;
- Source : in out List;
- Position : in out Cursor)
- -- Target and Source should not be aliased
- with
- Global => null,
- Pre =>
- (Has_Element (Target, Before) or else Before = No_Element)
- and then Has_Element (Source, Position)
- and then Length (Target) < Count_Type'Last,
- Post =>
- Length (Target) = Length (Target)'Old + 1
- and Length (Source) = Length (Source)'Old - 1
-
- -- The elements of Source located before Position are preserved
-
- and M.Range_Equal
- (Left => Model (Source)'Old,
- Right => Model (Source),
- Fst => 1,
- Lst => P.Get (Positions (Source)'Old, Position'Old) - 1)
-
- -- The elements located after Position are shifted by 1
-
- and M.Range_Shifted
- (Left => Model (Source)'Old,
- Right => Model (Source),
- Fst => P.Get (Positions (Source)'Old, Position'Old) + 1,
- Lst => Length (Source)'Old,
- Offset => -1)
-
- -- Position has been removed from Source
-
- and P_Positions_Shifted
- (Positions (Source),
- Positions (Source)'Old,
- Cut => P.Get (Positions (Source)'Old, Position'Old))
-
- -- Positions is valid in Target and it is located either before
- -- Before if it is valid in Target or at the end if it is No_Element.
-
- and P.Has_Key (Positions (Target), Position)
- and (if Before = No_Element then
- P.Get (Positions (Target), Position) = Length (Target)
- else
- P.Get (Positions (Target), Position) =
- P.Get (Positions (Target)'Old, Before))
-
- -- The elements of Target located before Position are preserved
-
- and M.Range_Equal
- (Left => Model (Target)'Old,
- Right => Model (Target),
- Fst => 1,
- Lst => P.Get (Positions (Target), Position) - 1)
-
- -- Other elements are shifted by 1
-
- and M.Range_Shifted
- (Left => Model (Target)'Old,
- Right => Model (Target),
- Fst => P.Get (Positions (Target), Position),
- Lst => Length (Target)'Old,
- Offset => 1)
-
- -- The element located at Position in Source is moved to Target
-
- and Element (Model (Target),
- P.Get (Positions (Target), Position)) =
- Element (Model (Source)'Old,
- P.Get (Positions (Source)'Old, Position'Old))
-
- -- A new cursor has been inserted at position Position in Target
-
- and P_Positions_Shifted
- (Positions (Target)'Old,
- Positions (Target),
- Cut => P.Get (Positions (Target), Position));
-
- procedure Splice
- (Container : in out List;
- Before : Cursor;
- Position : Cursor)
- with
- Global => null,
- Pre =>
- (Has_Element (Container, Before) or else Before = No_Element)
- and then Has_Element (Container, Position),
- Post => Length (Container) = Length (Container)'Old,
- Contract_Cases =>
- (Before = Position =>
- Model (Container) = Model (Container)'Old
- and Positions (Container) = Positions (Container)'Old,
-
- Before = No_Element =>
-
- -- The elements located before Position are preserved
-
- M.Range_Equal
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => 1,
- Lst => P.Get (Positions (Container)'Old, Position) - 1)
-
- -- The elements located after Position are shifted by 1
-
- and M.Range_Shifted
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => P.Get (Positions (Container)'Old, Position) + 1,
- Lst => Length (Container)'Old,
- Offset => -1)
-
- -- The last element of Container is the one that was previously at
- -- Position.
-
- and Element (Model (Container),
- Length (Container)) =
- Element (Model (Container)'Old,
- P.Get (Positions (Container)'Old, Position))
-
- -- Cursors from Container continue designating the same elements
-
- and Mapping_Preserved
- (M_Left => Model (Container)'Old,
- M_Right => Model (Container),
- P_Left => Positions (Container)'Old,
- P_Right => Positions (Container)),
-
- others =>
-
- -- The elements located before Position and Before are preserved
-
- M.Range_Equal
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => 1,
- Lst =>
- Count_Type'Min
- (P.Get (Positions (Container)'Old, Position) - 1,
- P.Get (Positions (Container)'Old, Before) - 1))
-
- -- The elements located after Position and Before are preserved
-
- and M.Range_Equal
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst =>
- Count_Type'Max
- (P.Get (Positions (Container)'Old, Position) + 1,
- P.Get (Positions (Container)'Old, Before) + 1),
- Lst => Length (Container))
-
- -- The elements located after Before and before Position are
- -- shifted by 1 to the right.
-
- and M.Range_Shifted
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => P.Get (Positions (Container)'Old, Before) + 1,
- Lst => P.Get (Positions (Container)'Old, Position) - 1,
- Offset => 1)
-
- -- The elements located after Position and before Before are
- -- shifted by 1 to the left.
-
- and M.Range_Shifted
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => P.Get (Positions (Container)'Old, Position) + 1,
- Lst => P.Get (Positions (Container)'Old, Before) - 1,
- Offset => -1)
-
- -- The element previously at Position is now before Before
-
- and Element
- (Model (Container),
- P.Get (Positions (Container)'Old, Before)) =
- Element
- (Model (Container)'Old,
- P.Get (Positions (Container)'Old, Position))
-
- -- Cursors from Container continue designating the same elements
-
- and Mapping_Preserved
- (M_Left => Model (Container)'Old,
- M_Right => Model (Container),
- P_Left => Positions (Container)'Old,
- P_Right => Positions (Container)));
-
- function First (Container : List) return Cursor with
- Global => null,
- Contract_Cases =>
- (Length (Container) = 0 =>
- First'Result = No_Element,
-
- others =>
- Has_Element (Container, First'Result)
- and P.Get (Positions (Container), First'Result) = 1);
-
- function First_Element (Container : List) return Element_Type with
- Global => null,
- Pre => not Is_Empty (Container),
- Post => First_Element'Result = M.Get (Model (Container), 1);
-
- function Last (Container : List) return Cursor with
- Global => null,
- Contract_Cases =>
- (Length (Container) = 0 =>
- Last'Result = No_Element,
-
- others =>
- Has_Element (Container, Last'Result)
- and P.Get (Positions (Container), Last'Result) =
- Length (Container));
-
- function Last_Element (Container : List) return Element_Type with
- Global => null,
- Pre => not Is_Empty (Container),
- Post =>
- Last_Element'Result = M.Get (Model (Container), Length (Container));
-
- function Next (Container : List; Position : Cursor) return Cursor with
- Global => null,
- Pre =>
- Has_Element (Container, Position) or else Position = No_Element,
- Contract_Cases =>
- (Position = No_Element
- or else P.Get (Positions (Container), Position) = Length (Container)
- =>
- Next'Result = No_Element,
-
- others =>
- Has_Element (Container, Next'Result)
- and then P.Get (Positions (Container), Next'Result) =
- P.Get (Positions (Container), Position) + 1);
-
- procedure Next (Container : List; Position : in out Cursor) with
- Global => null,
- Pre =>
- Has_Element (Container, Position) or else Position = No_Element,
- Contract_Cases =>
- (Position = No_Element
- or else P.Get (Positions (Container), Position) = Length (Container)
- =>
- Position = No_Element,
-
- others =>
- Has_Element (Container, Position)
- and then P.Get (Positions (Container), Position) =
- P.Get (Positions (Container), Position'Old) + 1);
-
- function Previous (Container : List; Position : Cursor) return Cursor with
- Global => null,
- Pre =>
- Has_Element (Container, Position) or else Position = No_Element,
- Contract_Cases =>
- (Position = No_Element
- or else P.Get (Positions (Container), Position) = 1
- =>
- Previous'Result = No_Element,
-
- others =>
- Has_Element (Container, Previous'Result)
- and then P.Get (Positions (Container), Previous'Result) =
- P.Get (Positions (Container), Position) - 1);
-
- procedure Previous (Container : List; Position : in out Cursor) with
- Global => null,
- Pre =>
- Has_Element (Container, Position) or else Position = No_Element,
- Contract_Cases =>
- (Position = No_Element
- or else P.Get (Positions (Container), Position) = 1
- =>
- Position = No_Element,
-
- others =>
- Has_Element (Container, Position)
- and then P.Get (Positions (Container), Position) =
- P.Get (Positions (Container), Position'Old) - 1);
-
- function Find
- (Container : List;
- Item : Element_Type;
- Position : Cursor := No_Element) return Cursor
- with
- Global => null,
- Pre =>
- Has_Element (Container, Position) or else Position = No_Element,
- Contract_Cases =>
-
- -- If Item is not contained in Container after Position, Find returns
- -- No_Element.
-
- (not M.Contains
- (Container => Model (Container),
- Fst =>
- (if Position = No_Element then
- 1
- else
- P.Get (Positions (Container), Position)),
- Lst => Length (Container),
- Item => Item)
- =>
- Find'Result = No_Element,
-
- -- Otherwise, Find returns a valid cursor in Container
-
- others =>
- P.Has_Key (Positions (Container), Find'Result)
-
- -- The element designated by the result of Find is Item
-
- and Element
- (Model (Container),
- P.Get (Positions (Container), Find'Result)) = Item
-
- -- The result of Find is located after Position
-
- and (if Position /= No_Element then
- P.Get (Positions (Container), Find'Result) >=
- P.Get (Positions (Container), Position))
-
- -- It is the first occurrence of Item in this slice
-
- and not M.Contains
- (Container => Model (Container),
- Fst =>
- (if Position = No_Element then
- 1
- else
- P.Get (Positions (Container), Position)),
- Lst =>
- P.Get (Positions (Container), Find'Result) - 1,
- Item => Item));
-
- function Reverse_Find
- (Container : List;
- Item : Element_Type;
- Position : Cursor := No_Element) return Cursor
- with
- Global => null,
- Pre =>
- Has_Element (Container, Position) or else Position = No_Element,
- Contract_Cases =>
-
- -- If Item is not contained in Container before Position, Find returns
- -- No_Element.
-
- (not M.Contains
- (Container => Model (Container),
- Fst => 1,
- Lst =>
- (if Position = No_Element then
- Length (Container)
- else
- P.Get (Positions (Container), Position)),
- Item => Item)
- =>
- Reverse_Find'Result = No_Element,
-
- -- Otherwise, Find returns a valid cursor in Container
-
- others =>
- P.Has_Key (Positions (Container), Reverse_Find'Result)
-
- -- The element designated by the result of Find is Item
-
- and Element
- (Model (Container),
- P.Get (Positions (Container), Reverse_Find'Result)) = Item
-
- -- The result of Find is located before Position
-
- and (if Position /= No_Element then
- P.Get (Positions (Container), Reverse_Find'Result) <=
- P.Get (Positions (Container), Position))
-
- -- It is the last occurrence of Item in this slice
-
- and not M.Contains
- (Container => Model (Container),
- Fst =>
- P.Get (Positions (Container),
- Reverse_Find'Result) + 1,
- Lst =>
- (if Position = No_Element then
- Length (Container)
- else
- P.Get (Positions (Container), Position)),
- Item => Item));
-
- function Contains
- (Container : List;
- Item : Element_Type) return Boolean
- with
- Global => null,
- Post =>
- Contains'Result = M.Contains (Container => Model (Container),
- Fst => 1,
- Lst => Length (Container),
- Item => Item);
-
- function Has_Element
- (Container : List;
- Position : Cursor) return Boolean
- with
- Global => null,
- Post =>
- Has_Element'Result = P.Has_Key (Positions (Container), Position);
- pragma Annotate (GNATprove, Inline_For_Proof, Has_Element);
-
- generic
- with function "<" (Left, Right : Element_Type) return Boolean is <>;
-
- package Generic_Sorting with SPARK_Mode is
-
- package Formal_Model with Ghost is
- function M_Elements_Sorted (Container : M.Sequence) return Boolean
- with
- Global => null,
- Post =>
- M_Elements_Sorted'Result =
- (for all I in 1 .. M.Length (Container) =>
- (for all J in I .. M.Length (Container) =>
- not (Element (Container, J) < Element (Container, I))));
- pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_Sorted);
-
- end Formal_Model;
- use Formal_Model;
-
- function Is_Sorted (Container : List) return Boolean with
- Global => null,
- Post => Is_Sorted'Result = M_Elements_Sorted (Model (Container));
-
- procedure Sort (Container : in out List) with
- Global => null,
- Post =>
- Length (Container) = Length (Container)'Old
- and M_Elements_Sorted (Model (Container))
- and M_Elements_Included
- (Left => Model (Container)'Old,
- L_Lst => Length (Container),
- Right => Model (Container),
- R_Lst => Length (Container))
- and M_Elements_Included
- (Left => Model (Container),
- L_Lst => Length (Container),
- Right => Model (Container)'Old,
- R_Lst => Length (Container));
-
- procedure Merge (Target : in out List; Source : in out List) with
- -- Target and Source should not be aliased
- Global => null,
- Pre => Length (Target) <= Count_Type'Last - Length (Source),
- Post =>
- Length (Target) = Length (Target)'Old + Length (Source)'Old
- and Length (Source) = 0
- and (if M_Elements_Sorted (Model (Target)'Old)
- and M_Elements_Sorted (Model (Source)'Old)
- then
- M_Elements_Sorted (Model (Target)))
- and M_Elements_Included
- (Left => Model (Target)'Old,
- L_Lst => Length (Target)'Old,
- Right => Model (Target),
- R_Lst => Length (Target))
- and M_Elements_Included
- (Left => Model (Source)'Old,
- L_Lst => Length (Source)'Old,
- Right => Model (Target),
- R_Lst => Length (Target))
- and M_Elements_In_Union
- (Model (Target),
- Model (Source)'Old,
- Model (Target)'Old);
- end Generic_Sorting;
-
-private
- pragma SPARK_Mode (Off);
-
- use Ada.Finalization;
-
- type Element_Access is access all Element_Type;
-
- type Node_Type is record
- Prev : Count_Type'Base := -1;
- Next : Count_Type := 0;
- Element : Element_Access := null;
- end record;
-
- type Node_Access is access all Node_Type;
-
- function "=" (L, R : Node_Type) return Boolean is abstract;
-
- type Node_Array is array (Count_Type range <>) of Node_Type;
- function "=" (L, R : Node_Array) return Boolean is abstract;
-
- type Node_Array_Access is access all Node_Array;
+package Ada.Containers.Formal_Indefinite_Doubly_Linked_Lists with SPARK_Mode is
- type List is new Controlled with record
- Free : Count_Type'Base := -1;
- Length : Count_Type := 0;
- First : Count_Type := 0;
- Last : Count_Type := 0;
- Nodes : Node_Array_Access := null;
- end record;
+ pragma Compile_Time_Error
+ (True,
+ "This package has been moved to the SPARK library shipped with any"
+ & " SPARK release starting with version 23.");
- overriding procedure Finalize (Container : in out List);
- overriding procedure Adjust (Container : in out List);
end Ada.Containers.Formal_Indefinite_Doubly_Linked_Lists;
diff --git a/gcc/ada/libgnat/a-cfinse.adb b/gcc/ada/libgnat/a-cfinse.adb
deleted file mode 100644
index 7b457f6..0000000
--- a/gcc/ada/libgnat/a-cfinse.adb
+++ /dev/null
@@ -1,304 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT LIBRARY COMPONENTS --
--- --
--- ADA.CONTAINERS.FUNCTIONAL_INFINITE_SEQUENCE --
--- --
--- B o d y --
--- --
--- Copyright (C) 2022-2022, Free Software Foundation, Inc. --
--- --
--- This specification is derived from the Ada Reference Manual for use with --
--- GNAT. The copyright notice above, and the license provisions that follow --
--- apply solely to the contents of the part following the private keyword. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
-------------------------------------------------------------------------------
-
-pragma Ada_2012;
-
-package body Ada.Containers.Functional_Infinite_Sequences
-with SPARK_Mode => Off
-is
- use Containers;
-
- -----------------------
- -- Local Subprograms --
- -----------------------
-
- package Big_From_Count is new Signed_Conversions
- (Int => Count_Type);
-
- function Big (C : Count_Type) return Big_Integer renames
- Big_From_Count.To_Big_Integer;
-
- -- Store Count_Type'Last as a Big Natural because it is often used
-
- Count_Type_Big_Last : constant Big_Natural := Big (Count_Type'Last);
-
- function To_Count (C : Big_Natural) return Count_Type;
- -- Convert Big_Natural to Count_Type
-
- ---------
- -- "<" --
- ---------
-
- function "<" (Left : Sequence; Right : Sequence) return Boolean is
- (Length (Left) < Length (Right)
- and then (for all N in Left =>
- Get (Left, N) = Get (Right, N)));
-
- ----------
- -- "<=" --
- ----------
-
- function "<=" (Left : Sequence; Right : Sequence) return Boolean is
- (Length (Left) <= Length (Right)
- and then (for all N in Left =>
- Get (Left, N) = Get (Right, N)));
-
- ---------
- -- "=" --
- ---------
-
- function "=" (Left : Sequence; Right : Sequence) return Boolean is
- (Left.Content = Right.Content);
-
- ---------
- -- Add --
- ---------
-
- function Add (Container : Sequence; New_Item : Element_Type) return Sequence
- is
- (Add (Container, Last (Container) + 1, New_Item));
-
- function Add
- (Container : Sequence;
- Position : Big_Positive;
- New_Item : Element_Type) return Sequence is
- (Content => Add (Container.Content, To_Count (Position), New_Item));
-
- --------------------
- -- Constant_Range --
- --------------------
-
- function Constant_Range
- (Container : Sequence;
- Fst : Big_Positive;
- Lst : Big_Natural;
- Item : Element_Type) return Boolean
- is
- Count_Fst : constant Count_Type := To_Count (Fst);
- Count_Lst : constant Count_Type := To_Count (Lst);
-
- begin
- for J in Count_Fst .. Count_Lst loop
- if Get (Container.Content, J) /= Item then
- return False;
- end if;
- end loop;
-
- return True;
- end Constant_Range;
-
- --------------
- -- Contains --
- --------------
-
- function Contains
- (Container : Sequence;
- Fst : Big_Positive;
- Lst : Big_Natural;
- Item : Element_Type) return Boolean
- is
- Count_Fst : constant Count_Type := To_Count (Fst);
- Count_Lst : constant Count_Type := To_Count (Lst);
-
- begin
- for J in Count_Fst .. Count_Lst loop
- if Get (Container.Content, J) = Item then
- return True;
- end if;
- end loop;
-
- return False;
- end Contains;
-
- --------------------
- -- Empty_Sequence --
- --------------------
-
- function Empty_Sequence return Sequence is
- (Content => <>);
-
- ------------------
- -- Equal_Except --
- ------------------
-
- function Equal_Except
- (Left : Sequence;
- Right : Sequence;
- Position : Big_Positive) return Boolean
- is
- Count_Pos : constant Count_Type := To_Count (Position);
- Count_Lst : constant Count_Type := To_Count (Last (Left));
-
- begin
- if Length (Left) /= Length (Right) then
- return False;
- end if;
-
- for J in 1 .. Count_Lst loop
- if J /= Count_Pos
- and then Get (Left.Content, J) /= Get (Right.Content, J)
- then
- return False;
- end if;
- end loop;
-
- return True;
- end Equal_Except;
-
- function Equal_Except
- (Left : Sequence;
- Right : Sequence;
- X : Big_Positive;
- Y : Big_Positive) return Boolean
- is
- Count_X : constant Count_Type := To_Count (X);
- Count_Y : constant Count_Type := To_Count (Y);
- Count_Lst : constant Count_Type := To_Count (Last (Left));
-
- begin
- if Length (Left) /= Length (Right) then
- return False;
- end if;
-
- for J in 1 .. Count_Lst loop
- if J /= Count_X
- and then J /= Count_Y
- and then Get (Left.Content, J) /= Get (Right.Content, J)
- then
- return False;
- end if;
- end loop;
-
- return True;
- end Equal_Except;
-
- ---------
- -- Get --
- ---------
-
- function Get
- (Container : Sequence;
- Position : Big_Integer) return Element_Type is
- (Get (Container.Content, To_Count (Position)));
-
- ----------
- -- Last --
- ----------
-
- function Last (Container : Sequence) return Big_Natural is
- (Length (Container));
-
- ------------
- -- Length --
- ------------
-
- function Length (Container : Sequence) return Big_Natural is
- (Big (Length (Container.Content)));
-
- -----------------
- -- Range_Equal --
- -----------------
-
- function Range_Equal
- (Left : Sequence;
- Right : Sequence;
- Fst : Big_Positive;
- Lst : Big_Natural) return Boolean
- is
- Count_Fst : constant Count_Type := To_Count (Fst);
- Count_Lst : constant Count_Type := To_Count (Lst);
-
- begin
- for J in Count_Fst .. Count_Lst loop
- if Get (Left.Content, J) /= Get (Right.Content, J) then
- return False;
- end if;
- end loop;
-
- return True;
- end Range_Equal;
-
- -------------------
- -- Range_Shifted --
- -------------------
-
- function Range_Shifted
- (Left : Sequence;
- Right : Sequence;
- Fst : Big_Positive;
- Lst : Big_Natural;
- Offset : Big_Integer) return Boolean
- is
- Count_Fst : constant Count_Type := To_Count (Fst);
- Count_Lst : constant Count_Type := To_Count (Lst);
-
- begin
- for J in Count_Fst .. Count_Lst loop
- if Get (Left.Content, J) /= Get (Right, Big (J) + Offset) then
- return False;
- end if;
- end loop;
-
- return True;
- end Range_Shifted;
-
- ------------
- -- Remove --
- ------------
-
- function Remove
- (Container : Sequence;
- Position : Big_Positive) return Sequence is
- (Content => Remove (Container.Content, To_Count (Position)));
-
- ---------
- -- Set --
- ---------
-
- function Set
- (Container : Sequence;
- Position : Big_Positive;
- New_Item : Element_Type) return Sequence is
- (Content => Set (Container.Content, To_Count (Position), New_Item));
-
- --------------
- -- To_Count --
- --------------
-
- function To_Count (C : Big_Natural) return Count_Type is
- begin
- if C > Count_Type_Big_Last then
- raise Program_Error with "Big_Integer too large for Count_Type";
- end if;
- return Big_From_Count.From_Big_Integer (C);
- end To_Count;
-
-end Ada.Containers.Functional_Infinite_Sequences;
diff --git a/gcc/ada/libgnat/a-cfinse.ads b/gcc/ada/libgnat/a-cfinse.ads
index d7fdb04..6f517fa 100644
--- a/gcc/ada/libgnat/a-cfinse.ads
+++ b/gcc/ada/libgnat/a-cfinse.ads
@@ -29,352 +29,12 @@
-- <http://www.gnu.org/licenses/>. --
------------------------------------------------------------------------------
-pragma Ada_2012;
-private with Ada.Containers.Functional_Base;
-with Ada.Numerics.Big_Numbers.Big_Integers;
-use Ada.Numerics.Big_Numbers.Big_Integers;
-
generic
- type Element_Type (<>) is private;
- with function "=" (Left, Right : Element_Type) return Boolean is <>;
-
-package Ada.Containers.Functional_Infinite_Sequences with
- SPARK_Mode,
- Annotate => (GNATprove, Always_Return)
-is
-
- type Sequence is private
- with Default_Initial_Condition => Length (Sequence) = 0,
- Iterable => (First => Iter_First,
- Has_Element => Iter_Has_Element,
- Next => Iter_Next,
- Element => Get);
- -- Sequences are empty when default initialized.
- -- Quantification over sequences can be done using the regular
- -- quantification over its range or directly on its elements with "for of".
-
- -----------------------
- -- Basic operations --
- -----------------------
-
- -- Sequences are axiomatized using Length and Get, providing respectively
- -- the length of a sequence and an accessor to its Nth element:
-
- function Length (Container : Sequence) return Big_Natural with
- -- Length of a sequence
-
- Global => null;
-
- function Get
- (Container : Sequence;
- Position : Big_Integer) return Element_Type
- -- Access the Element at position Position in Container
-
- with
- Global => null,
- Pre => Iter_Has_Element (Container, Position);
-
- function Last (Container : Sequence) return Big_Natural with
- -- Last index of a sequence
-
- Global => null,
- Post =>
- Last'Result = Length (Container);
- pragma Annotate (GNATprove, Inline_For_Proof, Last);
-
- function First return Big_Positive is (1) with
- -- First index of a sequence
-
- Global => null;
-
- ------------------------
- -- Property Functions --
- ------------------------
-
- function "=" (Left : Sequence; Right : Sequence) return Boolean with
- -- Extensional equality over sequences
-
- Global => null,
- Post =>
- "="'Result =
- (Length (Left) = Length (Right)
- and then (for all N in Left => Get (Left, N) = Get (Right, N)));
- pragma Annotate (GNATprove, Inline_For_Proof, "=");
-
- function "<" (Left : Sequence; Right : Sequence) return Boolean with
- -- Left is a strict subsequence of Right
-
- Global => null,
- Post =>
- "<"'Result =
- (Length (Left) < Length (Right)
- and then (for all N in Left => Get (Left, N) = Get (Right, N)));
- pragma Annotate (GNATprove, Inline_For_Proof, "<");
-
- function "<=" (Left : Sequence; Right : Sequence) return Boolean with
- -- Left is a subsequence of Right
-
- Global => null,
- Post =>
- "<="'Result =
- (Length (Left) <= Length (Right)
- and then (for all N in Left => Get (Left, N) = Get (Right, N)));
- pragma Annotate (GNATprove, Inline_For_Proof, "<=");
-
- function Contains
- (Container : Sequence;
- Fst : Big_Positive;
- Lst : Big_Natural;
- Item : Element_Type) return Boolean
- -- Returns True if Item occurs in the range from Fst to Lst of Container
-
- with
- Global => null,
- Pre => Lst <= Last (Container),
- Post =>
- Contains'Result =
- (for some J in Container =>
- Fst <= J and J <= Lst and Get (Container, J) = Item);
- pragma Annotate (GNATprove, Inline_For_Proof, Contains);
-
- function Constant_Range
- (Container : Sequence;
- Fst : Big_Positive;
- Lst : Big_Natural;
- Item : Element_Type) return Boolean
- -- Returns True if every element of the range from Fst to Lst of Container
- -- is equal to Item.
-
- with
- Global => null,
- Pre => Lst <= Last (Container),
- Post =>
- Constant_Range'Result =
- (for all J in Container =>
- (if Fst <= J and J <= Lst then Get (Container, J) = Item));
- pragma Annotate (GNATprove, Inline_For_Proof, Constant_Range);
-
- function Equal_Except
- (Left : Sequence;
- Right : Sequence;
- Position : Big_Positive) return Boolean
- -- Returns True is Left and Right are the same except at position Position
-
- with
- Global => null,
- Pre => Position <= Last (Left),
- Post =>
- Equal_Except'Result =
- (Length (Left) = Length (Right)
- and then (for all J in Left =>
- (if J /= Position then
- Get (Left, J) = Get (Right, J))));
- pragma Annotate (GNATprove, Inline_For_Proof, Equal_Except);
-
- function Equal_Except
- (Left : Sequence;
- Right : Sequence;
- X : Big_Positive;
- Y : Big_Positive) return Boolean
- -- Returns True is Left and Right are the same except at positions X and Y
-
- with
- Global => null,
- Pre => X <= Last (Left) and Y <= Last (Left),
- Post =>
- Equal_Except'Result =
- (Length (Left) = Length (Right)
- and then (for all J in Left =>
- (if J /= X and J /= Y then
- Get (Left, J) = Get (Right, J))));
- pragma Annotate (GNATprove, Inline_For_Proof, Equal_Except);
-
- function Range_Equal
- (Left : Sequence;
- Right : Sequence;
- Fst : Big_Positive;
- Lst : Big_Natural) return Boolean
- -- Returns True if the ranges from Fst to Lst contain the same elements in
- -- Left and Right.
-
- with
- Global => null,
- Pre => Lst <= Last (Left) and Lst <= Last (Right),
- Post =>
- Range_Equal'Result =
- (for all J in Left =>
- (if Fst <= J and J <= Lst then Get (Left, J) = Get (Right, J)));
- pragma Annotate (GNATprove, Inline_For_Proof, Range_Equal);
-
- function Range_Shifted
- (Left : Sequence;
- Right : Sequence;
- Fst : Big_Positive;
- Lst : Big_Natural;
- Offset : Big_Integer) return Boolean
- -- Returns True if the range from Fst to Lst in Left contains the same
- -- elements as the range from Fst + Offset to Lst + Offset in Right.
-
- with
- Global => null,
- Pre =>
- Lst <= Last (Left)
- and then
- (if Fst <= Lst then
- Offset + Fst >= 1 and Offset + Lst <= Length (Right)),
- Post =>
- Range_Shifted'Result =
- ((for all J in Left =>
- (if Fst <= J and J <= Lst then
- Get (Left, J) = Get (Right, J + Offset)))
- and
- (for all J in Right =>
- (if Fst + Offset <= J and J <= Lst + Offset then
- Get (Left, J - Offset) = Get (Right, J))));
- pragma Annotate (GNATprove, Inline_For_Proof, Range_Shifted);
-
- ----------------------------
- -- Construction Functions --
- ----------------------------
-
- -- For better efficiency of both proofs and execution, avoid using
- -- construction functions in annotations and rather use property functions.
-
- function Set
- (Container : Sequence;
- Position : Big_Positive;
- New_Item : Element_Type) return Sequence
- -- Returns a new sequence which contains the same elements as Container
- -- except for the one at position Position which is replaced by New_Item.
-
- with
- Global => null,
- Pre => Position <= Last (Container),
- Post =>
- Get (Set'Result, Position) = New_Item
- and then Equal_Except (Container, Set'Result, Position);
-
- function Add (Container : Sequence; New_Item : Element_Type) return Sequence
- -- Returns a new sequence which contains the same elements as Container
- -- plus New_Item at the end.
-
- with
- Global => null,
- Post =>
- Length (Add'Result) = Length (Container) + 1
- and then Get (Add'Result, Last (Add'Result)) = New_Item
- and then Container <= Add'Result;
-
- function Add
- (Container : Sequence;
- Position : Big_Positive;
- New_Item : Element_Type) return Sequence
- with
- -- Returns a new sequence which contains the same elements as Container
- -- except that New_Item has been inserted at position Position.
-
- Global => null,
- Pre => Position <= Last (Container) + 1,
- Post =>
- Length (Add'Result) = Length (Container) + 1
- and then Get (Add'Result, Position) = New_Item
- and then Range_Equal
- (Left => Container,
- Right => Add'Result,
- Fst => 1,
- Lst => Position - 1)
- and then Range_Shifted
- (Left => Container,
- Right => Add'Result,
- Fst => Position,
- Lst => Last (Container),
- Offset => 1);
-
- function Remove
- (Container : Sequence;
- Position : Big_Positive) return Sequence
- -- Returns a new sequence which contains the same elements as Container
- -- except that the element at position Position has been removed.
-
- with
- Global => null,
- Pre => Position <= Last (Container),
- Post =>
- Length (Remove'Result) = Length (Container) - 1
- and then Range_Equal
- (Left => Container,
- Right => Remove'Result,
- Fst => 1,
- Lst => Position - 1)
- and then Range_Shifted
- (Left => Remove'Result,
- Right => Container,
- Fst => Position,
- Lst => Last (Remove'Result),
- Offset => 1);
-
- function Copy_Element (Item : Element_Type) return Element_Type is (Item);
- -- Elements of containers are copied by numerous primitives in this
- -- package. This function causes GNATprove to verify that such a copy is
- -- valid (in particular, it does not break the ownership policy of SPARK,
- -- i.e. it does not contain pointers that could be used to alias mutable
- -- data).
-
- function Empty_Sequence return Sequence with
- -- Return an empty Sequence
-
- Global => null,
- Post => Length (Empty_Sequence'Result) = 0;
-
- ---------------------------
- -- Iteration Primitives --
- ---------------------------
-
- function Iter_First (Container : Sequence) return Big_Integer with
- Global => null,
- Post => Iter_First'Result = 1;
-
- function Iter_Has_Element
- (Container : Sequence;
- Position : Big_Integer) return Boolean
- with
- Global => null,
- Post => Iter_Has_Element'Result =
- In_Range (Position, 1, Length (Container));
- pragma Annotate (GNATprove, Inline_For_Proof, Iter_Has_Element);
-
- function Iter_Next
- (Container : Sequence;
- Position : Big_Integer) return Big_Integer
- with
- Global => null,
- Pre => Iter_Has_Element (Container, Position),
- Post => Iter_Next'Result = Position + 1;
-
-private
- pragma SPARK_Mode (Off);
-
- subtype Positive_Count_Type is Count_Type range 1 .. Count_Type'Last;
-
- package Containers is new Ada.Containers.Functional_Base
- (Index_Type => Positive_Count_Type,
- Element_Type => Element_Type);
-
- type Sequence is record
- Content : Containers.Container;
- end record;
-
- function Iter_First (Container : Sequence) return Big_Integer is (1);
+package Ada.Containers.Functional_Infinite_Sequences with SPARK_Mode is
- function Iter_Next
- (Container : Sequence;
- Position : Big_Integer) return Big_Integer
- is
- (Position + 1);
+ pragma Compile_Time_Error
+ (True,
+ "This package has been moved to the SPARK library shipped with any"
+ & " SPARK release starting with version 23.");
- function Iter_Has_Element
- (Container : Sequence;
- Position : Big_Integer) return Boolean
- is
- (In_Range (Position, 1, Length (Container)));
end Ada.Containers.Functional_Infinite_Sequences;
diff --git a/gcc/ada/libgnat/a-cfinve.adb b/gcc/ada/libgnat/a-cfinve.adb
deleted file mode 100644
index a55786d..0000000
--- a/gcc/ada/libgnat/a-cfinve.adb
+++ /dev/null
@@ -1,1452 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT LIBRARY COMPONENTS --
--- --
--- ADA.CONTAINERS.FORMAL_INDEFINITE_VECTORS --
--- --
--- B o d y --
--- --
--- Copyright (C) 2010-2022, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
-------------------------------------------------------------------------------
-
-with Ada.Containers.Generic_Array_Sort;
-with Ada.Unchecked_Deallocation;
-
-with System; use type System.Address;
-
-package body Ada.Containers.Formal_Indefinite_Vectors with
- SPARK_Mode => Off
-is
- function H (New_Item : Element_Type) return Holder renames To_Holder;
- function E (Container : Holder) return Element_Type renames Get;
-
- Growth_Factor : constant := 2;
- -- When growing a container, multiply current capacity by this. Doubling
- -- leads to amortized linear-time copying.
-
- subtype Int is Long_Long_Integer;
-
- procedure Free is
- new Ada.Unchecked_Deallocation (Elements_Array, Elements_Array_Ptr);
-
- type Maximal_Array_Ptr is access all Elements_Array (Array_Index)
- with Storage_Size => 0;
- type Maximal_Array_Ptr_Const is access constant Elements_Array (Array_Index)
- with Storage_Size => 0;
-
- function Elems (Container : in out Vector) return Maximal_Array_Ptr;
- function Elemsc
- (Container : Vector) return Maximal_Array_Ptr_Const;
- -- Returns a pointer to the Elements array currently in use -- either
- -- Container.Elements_Ptr or a pointer to Container.Elements. We work with
- -- pointers to a bogus array subtype that is constrained with the maximum
- -- possible bounds. This means that the pointer is a thin pointer. This is
- -- necessary because 'Unrestricted_Access doesn't work when it produces
- -- access-to-unconstrained and is returned from a function.
- --
- -- Note that this is dangerous: make sure calls to this use an indexed
- -- component or slice that is within the bounds 1 .. Length (Container).
-
- function Get_Element
- (Container : Vector;
- Position : Capacity_Range) return Element_Type;
-
- function To_Array_Index (Index : Index_Type'Base) return Count_Type'Base;
-
- function Current_Capacity (Container : Vector) return Capacity_Range;
-
- procedure Insert_Space
- (Container : in out Vector;
- Before : Extended_Index;
- Count : Count_Type := 1);
-
- ---------
- -- "=" --
- ---------
-
- function "=" (Left : Vector; Right : Vector) return Boolean is
- begin
- if Left'Address = Right'Address then
- return True;
- end if;
-
- if Length (Left) /= Length (Right) then
- return False;
- end if;
-
- for J in 1 .. Length (Left) loop
- if Get_Element (Left, J) /= Get_Element (Right, J) then
- return False;
- end if;
- end loop;
-
- return True;
- end "=";
-
- ------------
- -- Append --
- ------------
-
- procedure Append (Container : in out Vector; New_Item : Vector) is
- begin
- if Is_Empty (New_Item) then
- return;
- end if;
-
- if Container.Last >= Index_Type'Last then
- raise Constraint_Error with "vector is already at its maximum length";
- end if;
-
- Insert (Container, Container.Last + 1, New_Item);
- end Append;
-
- procedure Append (Container : in out Vector; New_Item : Element_Type) is
- begin
- Append (Container, New_Item, 1);
- end Append;
-
- procedure Append
- (Container : in out Vector;
- New_Item : Element_Type;
- Count : Count_Type)
- is
- begin
- if Count = 0 then
- return;
- end if;
-
- if Container.Last >= Index_Type'Last then
- raise Constraint_Error with "vector is already at its maximum length";
- end if;
-
- Insert (Container, Container.Last + 1, New_Item, Count);
- end Append;
-
- ------------
- -- Assign --
- ------------
-
- procedure Assign (Target : in out Vector; Source : Vector) is
- LS : constant Capacity_Range := Length (Source);
-
- begin
- if Target'Address = Source'Address then
- return;
- end if;
-
- if Bounded and then Target.Capacity < LS then
- raise Constraint_Error;
- end if;
-
- Clear (Target);
- Append (Target, Source);
- end Assign;
-
- --------------
- -- Capacity --
- --------------
-
- function Capacity (Container : Vector) return Capacity_Range is
- begin
- return
- (if Bounded then
- Container.Capacity
- else
- Capacity_Range'Last);
- end Capacity;
-
- -----------
- -- Clear --
- -----------
-
- procedure Clear (Container : in out Vector) is
- begin
- Container.Last := No_Index;
-
- -- Free element, note that this is OK if Elements_Ptr is null
-
- Free (Container.Elements_Ptr);
- end Clear;
-
- ------------------------
- -- Constant_Reference --
- ------------------------
-
- function Constant_Reference
- (Container : aliased Vector;
- Index : Index_Type) return not null access constant Element_Type
- is
- begin
- if Index > Container.Last then
- raise Constraint_Error with "Index is out of range";
- end if;
-
- declare
- II : constant Int'Base := Int (Index) - Int (No_Index);
- I : constant Capacity_Range := Capacity_Range (II);
-
- begin
- return Constant_Reference (Elemsc (Container) (I));
- end;
- end Constant_Reference;
-
- --------------
- -- Contains --
- --------------
-
- function Contains
- (Container : Vector;
- Item : Element_Type) return Boolean
- is
- begin
- return Find_Index (Container, Item) /= No_Index;
- end Contains;
-
- ----------
- -- Copy --
- ----------
-
- function Copy
- (Source : Vector;
- Capacity : Capacity_Range := 0) return Vector
- is
- LS : constant Capacity_Range := Length (Source);
- C : Capacity_Range;
-
- begin
- if Capacity = 0 then
- C := LS;
- elsif Capacity >= LS then
- C := Capacity;
- else
- raise Capacity_Error;
- end if;
-
- return Target : Vector (C) do
- Elems (Target) (1 .. LS) := Elemsc (Source) (1 .. LS);
- Target.Last := Source.Last;
- end return;
- end Copy;
-
- ----------------------
- -- Current_Capacity --
- ----------------------
-
- function Current_Capacity (Container : Vector) return Capacity_Range is
- begin
- return
- (if Container.Elements_Ptr = null then
- Container.Elements'Length
- else
- Container.Elements_Ptr.all'Length);
- end Current_Capacity;
-
- ------------
- -- Delete --
- ------------
-
- procedure Delete (Container : in out Vector; Index : Extended_Index) is
- begin
- Delete (Container, Index, 1);
- end Delete;
-
- procedure Delete
- (Container : in out Vector;
- Index : Extended_Index;
- Count : Count_Type)
- is
- Old_Last : constant Index_Type'Base := Container.Last;
- Old_Len : constant Count_Type := Length (Container);
- New_Last : Index_Type'Base;
- Count2 : Count_Type'Base; -- count of items from Index to Old_Last
- Off : Count_Type'Base; -- Index expressed as offset from IT'First
-
- begin
- -- Delete removes items from the vector, the number of which is the
- -- minimum of the specified Count and the items (if any) that exist from
- -- Index to Container.Last. There are no constraints on the specified
- -- value of Count (it can be larger than what's available at this
- -- position in the vector, for example), but there are constraints on
- -- the allowed values of the Index.
-
- -- As a precondition on the generic actual Index_Type, the base type
- -- must include Index_Type'Pred (Index_Type'First); this is the value
- -- that Container.Last assumes when the vector is empty. However, we do
- -- not allow that as the value for Index when specifying which items
- -- should be deleted, so we must manually check. (That the user is
- -- allowed to specify the value at all here is a consequence of the
- -- declaration of the Extended_Index subtype, which includes the values
- -- in the base range that immediately precede and immediately follow the
- -- values in the Index_Type.)
-
- if Index < Index_Type'First then
- raise Constraint_Error with "Index is out of range (too small)";
- end if;
-
- -- We do allow a value greater than Container.Last to be specified as
- -- the Index, but only if it's immediately greater. This allows the
- -- corner case of deleting no items from the back end of the vector to
- -- be treated as a no-op. (It is assumed that specifying an index value
- -- greater than Last + 1 indicates some deeper flaw in the caller's
- -- algorithm, so that case is treated as a proper error.)
-
- if Index > Old_Last then
- if Index > Old_Last + 1 then
- raise Constraint_Error with "Index is out of range (too large)";
- end if;
-
- return;
- end if;
-
- if Count = 0 then
- return;
- end if;
-
- -- We first calculate what's available for deletion starting at
- -- Index. Here and elsewhere we use the wider of Index_Type'Base and
- -- Count_Type'Base as the type for intermediate values. (See function
- -- Length for more information.)
-
- if Count_Type'Base'Last >= Index_Type'Pos (Index_Type'Base'Last) then
- Count2 := Count_Type'Base (Old_Last) - Count_Type'Base (Index) + 1;
- else
- Count2 := Count_Type'Base (Old_Last - Index + 1);
- end if;
-
- -- If more elements are requested (Count) for deletion than are
- -- available (Count2) for deletion beginning at Index, then everything
- -- from Index is deleted. There are no elements to slide down, and so
- -- all we need to do is set the value of Container.Last.
-
- if Count >= Count2 then
- Container.Last := Index - 1;
- return;
- end if;
-
- -- There are some elements that aren't being deleted (the requested
- -- count was less than the available count), so we must slide them down
- -- to Index. We first calculate the index values of the respective array
- -- slices, using the wider of Index_Type'Base and Count_Type'Base as the
- -- type for intermediate calculations.
-
- if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
- Off := Count_Type'Base (Index - Index_Type'First);
- New_Last := Old_Last - Index_Type'Base (Count);
- else
- Off := Count_Type'Base (Index) - Count_Type'Base (Index_Type'First);
- New_Last := Index_Type'Base (Count_Type'Base (Old_Last) - Count);
- end if;
-
- -- The array index values for each slice have already been determined,
- -- so we just slide down to Index the elements that weren't deleted.
-
- declare
- EA : Maximal_Array_Ptr renames Elems (Container);
- Idx : constant Count_Type := EA'First + Off;
-
- begin
- EA (Idx .. Old_Len - Count) := EA (Idx + Count .. Old_Len);
- Container.Last := New_Last;
- end;
- end Delete;
-
- ------------------
- -- Delete_First --
- ------------------
-
- procedure Delete_First (Container : in out Vector) is
- begin
- Delete_First (Container, 1);
- end Delete_First;
-
- procedure Delete_First (Container : in out Vector; Count : Count_Type) is
- begin
- if Count = 0 then
- return;
-
- elsif Count >= Length (Container) then
- Clear (Container);
- return;
-
- else
- Delete (Container, Index_Type'First, Count);
- end if;
- end Delete_First;
-
- -----------------
- -- Delete_Last --
- -----------------
-
- procedure Delete_Last (Container : in out Vector) is
- begin
- Delete_Last (Container, 1);
- end Delete_Last;
-
- procedure Delete_Last (Container : in out Vector; Count : Count_Type) is
- begin
- if Count = 0 then
- return;
- end if;
-
- -- There is no restriction on how large Count can be when deleting
- -- items. If it is equal or greater than the current length, then this
- -- is equivalent to clearing the vector. (In particular, there's no need
- -- for us to actually calculate the new value for Last.)
-
- -- If the requested count is less than the current length, then we must
- -- calculate the new value for Last. For the type we use the widest of
- -- Index_Type'Base and Count_Type'Base for the intermediate values of
- -- our calculation. (See the comments in Length for more information.)
-
- if Count >= Length (Container) then
- Container.Last := No_Index;
-
- elsif Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
- Container.Last := Container.Last - Index_Type'Base (Count);
-
- else
- Container.Last :=
- Index_Type'Base (Count_Type'Base (Container.Last) - Count);
- end if;
- end Delete_Last;
-
- -------------
- -- Element --
- -------------
-
- function Element
- (Container : Vector;
- Index : Extended_Index) return Element_Type
- is
- begin
- if Index > Container.Last then
- raise Constraint_Error with "Index is out of range";
- end if;
-
- declare
- II : constant Int'Base := Int (Index) - Int (No_Index);
- I : constant Capacity_Range := Capacity_Range (II);
-
- begin
- return Get_Element (Container, I);
- end;
- end Element;
-
- -----------
- -- Elems --
- -----------
-
- function Elems (Container : in out Vector) return Maximal_Array_Ptr is
- begin
- return
- (if Container.Elements_Ptr = null then
- Container.Elements'Unrestricted_Access
- else
- Container.Elements_Ptr.all'Unrestricted_Access);
- end Elems;
-
- function Elemsc (Container : Vector) return Maximal_Array_Ptr_Const is
- begin
- return
- (if Container.Elements_Ptr = null then
- Container.Elements'Unrestricted_Access
- else
- Container.Elements_Ptr.all'Unrestricted_Access);
- end Elemsc;
-
- ----------------
- -- Find_Index --
- ----------------
-
- function Find_Index
- (Container : Vector;
- Item : Element_Type;
- Index : Index_Type := Index_Type'First) return Extended_Index
- is
- K : Count_Type;
- Last : constant Extended_Index := Last_Index (Container);
-
- begin
- K := Capacity_Range (Int (Index) - Int (No_Index));
- for Indx in Index .. Last loop
- if Get_Element (Container, K) = Item then
- return Indx;
- end if;
-
- K := K + 1;
- end loop;
-
- return No_Index;
- end Find_Index;
-
- -------------------
- -- First_Element --
- -------------------
-
- function First_Element (Container : Vector) return Element_Type is
- begin
- if Is_Empty (Container) then
- raise Constraint_Error with "Container is empty";
- else
- return Get_Element (Container, 1);
- end if;
- end First_Element;
-
- -----------------
- -- First_Index --
- -----------------
-
- function First_Index (Container : Vector) return Index_Type is
- pragma Unreferenced (Container);
- begin
- return Index_Type'First;
- end First_Index;
-
- ------------------
- -- Formal_Model --
- ------------------
-
- package body Formal_Model is
-
- -------------------------
- -- M_Elements_In_Union --
- -------------------------
-
- function M_Elements_In_Union
- (Container : M.Sequence;
- Left : M.Sequence;
- Right : M.Sequence) return Boolean
- is
- begin
- for Index in Index_Type'First .. M.Last (Container) loop
- declare
- Elem : constant Element_Type := Element (Container, Index);
- begin
- if not M.Contains (Left, Index_Type'First, M.Last (Left), Elem)
- and then
- not M.Contains
- (Right, Index_Type'First, M.Last (Right), Elem)
- then
- return False;
- end if;
- end;
- end loop;
-
- return True;
- end M_Elements_In_Union;
-
- -------------------------
- -- M_Elements_Included --
- -------------------------
-
- function M_Elements_Included
- (Left : M.Sequence;
- L_Fst : Index_Type := Index_Type'First;
- L_Lst : Extended_Index;
- Right : M.Sequence;
- R_Fst : Index_Type := Index_Type'First;
- R_Lst : Extended_Index) return Boolean
- is
- begin
- for I in L_Fst .. L_Lst loop
- declare
- Found : Boolean := False;
- J : Extended_Index := R_Fst - 1;
-
- begin
- while not Found and J < R_Lst loop
- J := J + 1;
- if Element (Left, I) = Element (Right, J) then
- Found := True;
- end if;
- end loop;
-
- if not Found then
- return False;
- end if;
- end;
- end loop;
-
- return True;
- end M_Elements_Included;
-
- -------------------------
- -- M_Elements_Reversed --
- -------------------------
-
- function M_Elements_Reversed
- (Left : M.Sequence;
- Right : M.Sequence) return Boolean
- is
- L : constant Index_Type := M.Last (Left);
-
- begin
- if L /= M.Last (Right) then
- return False;
- end if;
-
- for I in Index_Type'First .. L loop
- if Element (Left, I) /= Element (Right, L - I + 1)
- then
- return False;
- end if;
- end loop;
-
- return True;
- end M_Elements_Reversed;
-
- ------------------------
- -- M_Elements_Swapped --
- ------------------------
-
- function M_Elements_Swapped
- (Left : M.Sequence;
- Right : M.Sequence;
- X : Index_Type;
- Y : Index_Type) return Boolean
- is
- begin
- if M.Length (Left) /= M.Length (Right)
- or else Element (Left, X) /= Element (Right, Y)
- or else Element (Left, Y) /= Element (Right, X)
- then
- return False;
- end if;
-
- for I in Index_Type'First .. M.Last (Left) loop
- if I /= X and then I /= Y
- and then Element (Left, I) /= Element (Right, I)
- then
- return False;
- end if;
- end loop;
-
- return True;
- end M_Elements_Swapped;
-
- -----------
- -- Model --
- -----------
-
- function Model (Container : Vector) return M.Sequence is
- R : M.Sequence;
-
- begin
- for Position in 1 .. Length (Container) loop
- R := M.Add (R, E (Elemsc (Container) (Position)));
- end loop;
-
- return R;
- end Model;
-
- end Formal_Model;
-
- ---------------------
- -- Generic_Sorting --
- ---------------------
-
- package body Generic_Sorting with SPARK_Mode => Off is
-
- ------------------
- -- Formal_Model --
- ------------------
-
- package body Formal_Model is
-
- -----------------------
- -- M_Elements_Sorted --
- -----------------------
-
- function M_Elements_Sorted (Container : M.Sequence) return Boolean is
- begin
- if M.Length (Container) = 0 then
- return True;
- end if;
-
- declare
- E1 : Element_Type := Element (Container, Index_Type'First);
-
- begin
- for I in Index_Type'First + 1 .. M.Last (Container) loop
- declare
- E2 : constant Element_Type := Element (Container, I);
-
- begin
- if E2 < E1 then
- return False;
- end if;
-
- E1 := E2;
- end;
- end loop;
- end;
-
- return True;
- end M_Elements_Sorted;
-
- end Formal_Model;
-
- ---------------
- -- Is_Sorted --
- ---------------
-
- function Is_Sorted (Container : Vector) return Boolean is
- L : constant Capacity_Range := Length (Container);
-
- begin
- for J in 1 .. L - 1 loop
- if Get_Element (Container, J + 1) < Get_Element (Container, J) then
- return False;
- end if;
- end loop;
-
- return True;
- end Is_Sorted;
-
- ----------
- -- Sort --
- ----------
-
- procedure Sort (Container : in out Vector) is
- function "<" (Left : Holder; Right : Holder) return Boolean is
- (E (Left) < E (Right));
-
- procedure Sort is new Generic_Array_Sort
- (Index_Type => Array_Index,
- Element_Type => Holder,
- Array_Type => Elements_Array,
- "<" => "<");
-
- Len : constant Capacity_Range := Length (Container);
-
- begin
- if Container.Last <= Index_Type'First then
- return;
- else
- Sort (Elems (Container) (1 .. Len));
- end if;
- end Sort;
-
- -----------
- -- Merge --
- -----------
-
- procedure Merge (Target : in out Vector; Source : in out Vector) is
- I : Count_Type;
- J : Count_Type;
-
- begin
- if Target'Address = Source'Address then
- raise Program_Error with "Target and Source denote same container";
- end if;
-
- if Length (Source) = 0 then
- return;
- end if;
-
- if Length (Target) = 0 then
- Move (Target => Target, Source => Source);
- return;
- end if;
-
- I := Length (Target);
-
- declare
- New_Length : constant Count_Type := I + Length (Source);
-
- begin
- if not Bounded
- and then Current_Capacity (Target) < Capacity_Range (New_Length)
- then
- Reserve_Capacity
- (Target,
- Capacity_Range'Max
- (Current_Capacity (Target) * Growth_Factor,
- Capacity_Range (New_Length)));
- end if;
-
- if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
- Target.Last := No_Index + Index_Type'Base (New_Length);
-
- else
- Target.Last :=
- Index_Type'Base (Count_Type'Base (No_Index) + New_Length);
- end if;
- end;
-
- declare
- TA : Maximal_Array_Ptr renames Elems (Target);
- SA : Maximal_Array_Ptr renames Elems (Source);
-
- begin
- J := Length (Target);
- while Length (Source) /= 0 loop
- if I = 0 then
- TA (1 .. J) := SA (1 .. Length (Source));
- Source.Last := No_Index;
- exit;
- end if;
-
- if E (SA (Length (Source))) < E (TA (I)) then
- TA (J) := TA (I);
- I := I - 1;
-
- else
- TA (J) := SA (Length (Source));
- Source.Last := Source.Last - 1;
- end if;
-
- J := J - 1;
- end loop;
- end;
- end Merge;
-
- end Generic_Sorting;
-
- -----------------
- -- Get_Element --
- -----------------
-
- function Get_Element
- (Container : Vector;
- Position : Capacity_Range) return Element_Type
- is
- begin
- return E (Elemsc (Container) (Position));
- end Get_Element;
-
- -----------------
- -- Has_Element --
- -----------------
-
- function Has_Element
- (Container : Vector;
- Position : Extended_Index) return Boolean
- is
- begin
- return Position in First_Index (Container) .. Last_Index (Container);
- end Has_Element;
-
- ------------
- -- Insert --
- ------------
-
- procedure Insert
- (Container : in out Vector;
- Before : Extended_Index;
- New_Item : Element_Type)
- is
- begin
- Insert (Container, Before, New_Item, 1);
- end Insert;
-
- procedure Insert
- (Container : in out Vector;
- Before : Extended_Index;
- New_Item : Element_Type;
- Count : Count_Type)
- is
- J : Count_Type'Base; -- scratch
-
- begin
- -- Use Insert_Space to create the "hole" (the destination slice)
-
- Insert_Space (Container, Before, Count);
-
- J := To_Array_Index (Before);
-
- Elems (Container) (J .. J - 1 + Count) := [others => H (New_Item)];
- end Insert;
-
- procedure Insert
- (Container : in out Vector;
- Before : Extended_Index;
- New_Item : Vector)
- is
- N : constant Count_Type := Length (New_Item);
- B : Count_Type; -- index Before converted to Count_Type
-
- begin
- if Container'Address = New_Item'Address then
- raise Program_Error with
- "Container and New_Item denote same container";
- end if;
-
- -- Use Insert_Space to create the "hole" (the destination slice) into
- -- which we copy the source items.
-
- Insert_Space (Container, Before, Count => N);
-
- if N = 0 then
- -- There's nothing else to do here (vetting of parameters was
- -- performed already in Insert_Space), so we simply return.
-
- return;
- end if;
-
- B := To_Array_Index (Before);
-
- Elems (Container) (B .. B + N - 1) := Elemsc (New_Item) (1 .. N);
- end Insert;
-
- ------------------
- -- Insert_Space --
- ------------------
-
- procedure Insert_Space
- (Container : in out Vector;
- Before : Extended_Index;
- Count : Count_Type := 1)
- is
- Old_Length : constant Count_Type := Length (Container);
-
- Max_Length : Count_Type'Base; -- determined from range of Index_Type
- New_Length : Count_Type'Base; -- sum of current length and Count
-
- Index : Index_Type'Base; -- scratch for intermediate values
- J : Count_Type'Base; -- scratch
-
- begin
- -- As a precondition on the generic actual Index_Type, the base type
- -- must include Index_Type'Pred (Index_Type'First); this is the value
- -- that Container.Last assumes when the vector is empty. However, we do
- -- not allow that as the value for Index when specifying where the new
- -- items should be inserted, so we must manually check. (That the user
- -- is allowed to specify the value at all here is a consequence of the
- -- declaration of the Extended_Index subtype, which includes the values
- -- in the base range that immediately precede and immediately follow the
- -- values in the Index_Type.)
-
- if Before < Index_Type'First then
- raise Constraint_Error with
- "Before index is out of range (too small)";
- end if;
-
- -- We do allow a value greater than Container.Last to be specified as
- -- the Index, but only if it's immediately greater. This allows for the
- -- case of appending items to the back end of the vector. (It is assumed
- -- that specifying an index value greater than Last + 1 indicates some
- -- deeper flaw in the caller's algorithm, so that case is treated as a
- -- proper error.)
-
- if Before > Container.Last
- and then Before - 1 > Container.Last
- then
- raise Constraint_Error with
- "Before index is out of range (too large)";
- end if;
-
- -- We treat inserting 0 items into the container as a no-op, so we
- -- simply return.
-
- if Count = 0 then
- return;
- end if;
-
- -- There are two constraints we need to satisfy. The first constraint is
- -- that a container cannot have more than Count_Type'Last elements, so
- -- we must check the sum of the current length and the insertion
- -- count. Note that we cannot simply add these values, because of the
- -- possibility of overflow.
-
- if Old_Length > Count_Type'Last - Count then
- raise Constraint_Error with "Count is out of range";
- end if;
-
- -- It is now safe compute the length of the new vector, without fear of
- -- overflow.
-
- New_Length := Old_Length + Count;
-
- -- The second constraint is that the new Last index value cannot exceed
- -- Index_Type'Last. In each branch below, we calculate the maximum
- -- length (computed from the range of values in Index_Type), and then
- -- compare the new length to the maximum length. If the new length is
- -- acceptable, then we compute the new last index from that.
-
- if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
-
- -- We have to handle the case when there might be more values in the
- -- range of Index_Type than in the range of Count_Type.
-
- if Index_Type'First <= 0 then
-
- -- We know that No_Index (the same as Index_Type'First - 1) is
- -- less than 0, so it is safe to compute the following sum without
- -- fear of overflow.
-
- Index := No_Index + Index_Type'Base (Count_Type'Last);
-
- if Index <= Index_Type'Last then
-
- -- We have determined that range of Index_Type has at least as
- -- many values as in Count_Type, so Count_Type'Last is the
- -- maximum number of items that are allowed.
-
- Max_Length := Count_Type'Last;
-
- else
- -- The range of Index_Type has fewer values than in Count_Type,
- -- so the maximum number of items is computed from the range of
- -- the Index_Type.
-
- Max_Length := Count_Type'Base (Index_Type'Last - No_Index);
- end if;
-
- else
- -- No_Index is equal or greater than 0, so we can safely compute
- -- the difference without fear of overflow (which we would have to
- -- worry about if No_Index were less than 0, but that case is
- -- handled above).
-
- if Index_Type'Last - No_Index >= Count_Type'Pos (Count_Type'Last)
- then
- -- We have determined that range of Index_Type has at least as
- -- many values as in Count_Type, so Count_Type'Last is the
- -- maximum number of items that are allowed.
-
- Max_Length := Count_Type'Last;
-
- else
- -- The range of Index_Type has fewer values than in Count_Type,
- -- so the maximum number of items is computed from the range of
- -- the Index_Type.
-
- Max_Length := Count_Type'Base (Index_Type'Last - No_Index);
- end if;
- end if;
-
- elsif Index_Type'First <= 0 then
-
- -- We know that No_Index (the same as Index_Type'First - 1) is less
- -- than 0, so it is safe to compute the following sum without fear of
- -- overflow.
-
- J := Count_Type'Base (No_Index) + Count_Type'Last;
-
- if J <= Count_Type'Base (Index_Type'Last) then
-
- -- We have determined that range of Index_Type has at least as
- -- many values as in Count_Type, so Count_Type'Last is the maximum
- -- number of items that are allowed.
-
- Max_Length := Count_Type'Last;
-
- else
- -- The range of Index_Type has fewer values than Count_Type does,
- -- so the maximum number of items is computed from the range of
- -- the Index_Type.
-
- Max_Length :=
- Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index);
- end if;
-
- else
- -- No_Index is equal or greater than 0, so we can safely compute the
- -- difference without fear of overflow (which we would have to worry
- -- about if No_Index were less than 0, but that case is handled
- -- above).
-
- Max_Length :=
- Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index);
- end if;
-
- -- We have just computed the maximum length (number of items). We must
- -- now compare the requested length to the maximum length, as we do not
- -- allow a vector expand beyond the maximum (because that would create
- -- an internal array with a last index value greater than
- -- Index_Type'Last, with no way to index those elements).
-
- if New_Length > Max_Length then
- raise Constraint_Error with "Count is out of range";
- end if;
-
- J := To_Array_Index (Before);
-
- -- Increase the capacity of container if needed
-
- if not Bounded
- and then Current_Capacity (Container) < Capacity_Range (New_Length)
- then
- Reserve_Capacity
- (Container,
- Capacity_Range'Max
- (Current_Capacity (Container) * Growth_Factor,
- Capacity_Range (New_Length)));
- end if;
-
- declare
- EA : Maximal_Array_Ptr renames Elems (Container);
-
- begin
- if Before <= Container.Last then
-
- -- The new items are being inserted before some existing
- -- elements, so we must slide the existing elements up to their
- -- new home.
-
- EA (J + Count .. New_Length) := EA (J .. Old_Length);
- end if;
- end;
-
- if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
- Container.Last := No_Index + Index_Type'Base (New_Length);
-
- else
- Container.Last :=
- Index_Type'Base (Count_Type'Base (No_Index) + New_Length);
- end if;
- end Insert_Space;
-
- --------------
- -- Is_Empty --
- --------------
-
- function Is_Empty (Container : Vector) return Boolean is
- begin
- return Last_Index (Container) < Index_Type'First;
- end Is_Empty;
-
- ------------------
- -- Last_Element --
- ------------------
-
- function Last_Element (Container : Vector) return Element_Type is
- begin
- if Is_Empty (Container) then
- raise Constraint_Error with "Container is empty";
- else
- return Get_Element (Container, Length (Container));
- end if;
- end Last_Element;
-
- ----------------
- -- Last_Index --
- ----------------
-
- function Last_Index (Container : Vector) return Extended_Index is
- begin
- return Container.Last;
- end Last_Index;
-
- ------------
- -- Length --
- ------------
-
- function Length (Container : Vector) return Capacity_Range is
- L : constant Int := Int (Container.Last);
- F : constant Int := Int (Index_Type'First);
- N : constant Int'Base := L - F + 1;
-
- begin
- return Capacity_Range (N);
- end Length;
-
- ----------
- -- Move --
- ----------
-
- procedure Move (Target : in out Vector; Source : in out Vector) is
- LS : constant Capacity_Range := Length (Source);
-
- begin
- if Target'Address = Source'Address then
- return;
- end if;
-
- if Bounded and then Target.Capacity < LS then
- raise Constraint_Error;
- end if;
-
- Clear (Target);
- Append (Target, Source);
- Clear (Source);
- end Move;
-
- ------------
- -- Prepend --
- ------------
-
- procedure Prepend (Container : in out Vector; New_Item : Vector) is
- begin
- Insert (Container, Index_Type'First, New_Item);
- end Prepend;
-
- procedure Prepend (Container : in out Vector; New_Item : Element_Type) is
- begin
- Prepend (Container, New_Item, 1);
- end Prepend;
-
- procedure Prepend
- (Container : in out Vector;
- New_Item : Element_Type;
- Count : Count_Type)
- is
- begin
- Insert (Container, Index_Type'First, New_Item, Count);
- end Prepend;
-
- ---------------
- -- Reference --
- ---------------
-
- function Reference
- (Container : not null access Vector;
- Index : Index_Type) return not null access Element_Type
- is
- begin
- if Index > Container.Last then
- raise Constraint_Error with "Index is out of range";
- end if;
-
- declare
- II : constant Int'Base := Int (Index) - Int (No_Index);
- I : constant Capacity_Range := Capacity_Range (II);
-
- begin
- if Container.Elements_Ptr = null then
- return Reference (Container.Elements (I)'Access);
- else
- return Reference (Container.Elements_Ptr (I)'Access);
- end if;
- end;
- end Reference;
-
- ---------------------
- -- Replace_Element --
- ---------------------
-
- procedure Replace_Element
- (Container : in out Vector;
- Index : Index_Type;
- New_Item : Element_Type)
- is
- begin
- if Index > Container.Last then
- raise Constraint_Error with "Index is out of range";
- end if;
-
- declare
- II : constant Int'Base := Int (Index) - Int (No_Index);
- I : constant Capacity_Range := Capacity_Range (II);
-
- begin
- Elems (Container) (I) := H (New_Item);
- end;
- end Replace_Element;
-
- ----------------------
- -- Reserve_Capacity --
- ----------------------
-
- procedure Reserve_Capacity
- (Container : in out Vector;
- Capacity : Capacity_Range)
- is
- begin
- if Bounded then
- if Capacity > Container.Capacity then
- raise Constraint_Error with "Capacity is out of range";
- end if;
-
- else
- if Capacity > Current_Capacity (Container) then
- declare
- New_Elements : constant Elements_Array_Ptr :=
- new Elements_Array (1 .. Capacity);
- L : constant Capacity_Range := Length (Container);
-
- begin
- New_Elements (1 .. L) := Elemsc (Container) (1 .. L);
- Free (Container.Elements_Ptr);
- Container.Elements_Ptr := New_Elements;
- end;
- end if;
- end if;
- end Reserve_Capacity;
-
- ----------------------
- -- Reverse_Elements --
- ----------------------
-
- procedure Reverse_Elements (Container : in out Vector) is
- begin
- if Length (Container) <= 1 then
- return;
- end if;
-
- declare
- I : Capacity_Range;
- J : Capacity_Range;
- E : Elements_Array renames
- Elems (Container) (1 .. Length (Container));
-
- begin
- I := 1;
- J := Length (Container);
- while I < J loop
- declare
- EI : constant Holder := E (I);
-
- begin
- E (I) := E (J);
- E (J) := EI;
- end;
-
- I := I + 1;
- J := J - 1;
- end loop;
- end;
- end Reverse_Elements;
-
- ------------------------
- -- Reverse_Find_Index --
- ------------------------
-
- function Reverse_Find_Index
- (Container : Vector;
- Item : Element_Type;
- Index : Index_Type := Index_Type'Last) return Extended_Index
- is
- Last : Index_Type'Base;
- K : Count_Type'Base;
-
- begin
- if Index > Last_Index (Container) then
- Last := Last_Index (Container);
- else
- Last := Index;
- end if;
-
- K := Capacity_Range (Int (Last) - Int (No_Index));
- for Indx in reverse Index_Type'First .. Last loop
- if Get_Element (Container, K) = Item then
- return Indx;
- end if;
-
- K := K - 1;
- end loop;
-
- return No_Index;
- end Reverse_Find_Index;
-
- ----------
- -- Swap --
- ----------
-
- procedure Swap
- (Container : in out Vector;
- I : Index_Type;
- J : Index_Type)
- is
- begin
- if I > Container.Last then
- raise Constraint_Error with "I index is out of range";
- end if;
-
- if J > Container.Last then
- raise Constraint_Error with "J index is out of range";
- end if;
-
- if I = J then
- return;
- end if;
-
- declare
- II : constant Int'Base := Int (I) - Int (No_Index);
- JJ : constant Int'Base := Int (J) - Int (No_Index);
-
- EI : Holder renames Elems (Container) (Capacity_Range (II));
- EJ : Holder renames Elems (Container) (Capacity_Range (JJ));
-
- EI_Copy : constant Holder := EI;
-
- begin
- EI := EJ;
- EJ := EI_Copy;
- end;
- end Swap;
-
- --------------------
- -- To_Array_Index --
- --------------------
-
- function To_Array_Index (Index : Index_Type'Base) return Count_Type'Base is
- Offset : Count_Type'Base;
-
- begin
- -- We know that
- -- Index >= Index_Type'First
- -- hence we also know that
- -- Index - Index_Type'First >= 0
-
- -- The issue is that even though 0 is guaranteed to be a value in the
- -- type Index_Type'Base, there's no guarantee that the difference is a
- -- value in that type. To prevent overflow we use the wider of
- -- Count_Type'Base and Index_Type'Base to perform intermediate
- -- calculations.
-
- if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
- Offset := Count_Type'Base (Index - Index_Type'First);
-
- else
- Offset := Count_Type'Base (Index) -
- Count_Type'Base (Index_Type'First);
- end if;
-
- -- The array index subtype for all container element arrays always
- -- starts with 1.
-
- return 1 + Offset;
- end To_Array_Index;
-
- ---------------
- -- To_Vector --
- ---------------
-
- function To_Vector
- (New_Item : Element_Type;
- Length : Capacity_Range) return Vector
- is
- begin
- if Length = 0 then
- return Empty_Vector;
- end if;
-
- declare
- First : constant Int := Int (Index_Type'First);
- Last_As_Int : constant Int'Base := First + Int (Length) - 1;
- Last : Index_Type;
-
- begin
- if Last_As_Int > Index_Type'Pos (Index_Type'Last) then
- raise Constraint_Error with "Length is out of range"; -- ???
- end if;
-
- Last := Index_Type (Last_As_Int);
-
- return
- (Capacity => Length,
- Last => Last,
- Elements_Ptr => <>,
- Elements => [others => H (New_Item)]);
- end;
- end To_Vector;
-
-end Ada.Containers.Formal_Indefinite_Vectors;
diff --git a/gcc/ada/libgnat/a-cfinve.ads b/gcc/ada/libgnat/a-cfinve.ads
index f44e45b..dcec6ba 100644
--- a/gcc/ada/libgnat/a-cfinve.ads
+++ b/gcc/ada/libgnat/a-cfinve.ads
@@ -29,959 +29,12 @@
-- <http://www.gnu.org/licenses/>. --
------------------------------------------------------------------------------
--- Similar to Ada.Containers.Formal_Vectors. The main difference is that
--- Element_Type may be indefinite (but not an unconstrained array).
-
-with Ada.Containers.Bounded_Holders;
-with Ada.Containers.Functional_Vectors;
-
generic
- type Index_Type is range <>;
- type Element_Type (<>) is private;
- with function "=" (Left, Right : Element_Type) return Boolean is <>;
- Max_Size_In_Storage_Elements : Natural;
- -- Maximum size of Vector elements in bytes. This has the same meaning as
- -- in Ada.Containers.Bounded_Holders, with the same restrictions. Note that
- -- setting this too small can lead to erroneous execution; see comments in
- -- Ada.Containers.Bounded_Holders. If Element_Type is class-wide, it is the
- -- responsibility of clients to calculate the maximum size of all types in
- -- the class.
-
- Bounded : Boolean := True;
- -- If True, the containers are bounded; the initial capacity is the maximum
- -- size, and heap allocation will be avoided. If False, the containers can
- -- grow via heap allocation.
-
-package Ada.Containers.Formal_Indefinite_Vectors with
- SPARK_Mode,
- Annotate => (GNATprove, Always_Return)
-is
-
- -- Contracts in this unit are meant for analysis only, not for run-time
- -- checking.
-
- pragma Assertion_Policy (Pre => Ignore);
- pragma Assertion_Policy (Post => Ignore);
- pragma Assertion_Policy (Contract_Cases => Ignore);
- pragma Annotate (CodePeer, Skip_Analysis);
-
- subtype Extended_Index is Index_Type'Base
- range Index_Type'First - 1 ..
- Index_Type'Min (Index_Type'Base'Last - 1, Index_Type'Last) + 1;
-
- No_Index : constant Extended_Index := Extended_Index'First;
-
- Last_Count : constant Count_Type :=
- (if Index_Type'Last < Index_Type'First then
- 0
- elsif Index_Type'Last < -1
- or else Index_Type'Pos (Index_Type'First) >
- Index_Type'Pos (Index_Type'Last) - Count_Type'Last
- then
- Index_Type'Pos (Index_Type'Last) -
- Index_Type'Pos (Index_Type'First) + 1
- else
- Count_Type'Last);
- -- Maximal capacity of any vector. It is the minimum of the size of the
- -- index range and the last possible Count_Type.
-
- subtype Capacity_Range is Count_Type range 0 .. Last_Count;
-
- type Vector (Capacity : Capacity_Range) is limited private with
- Default_Initial_Condition => Is_Empty (Vector);
- -- In the bounded case, Capacity is the capacity of the container, which
- -- never changes. In the unbounded case, Capacity is the initial capacity
- -- of the container, and operations such as Reserve_Capacity and Append can
- -- increase the capacity. The capacity never shrinks, except in the case of
- -- Clear.
- --
- -- Note that all objects of type Vector are constrained, including in the
- -- unbounded case; you can't assign from one object to another if the
- -- Capacity is different.
-
- function Length (Container : Vector) return Capacity_Range with
- Global => null,
- Post => Length'Result <= Capacity (Container);
-
- pragma Unevaluated_Use_Of_Old (Allow);
-
- package Formal_Model with Ghost is
-
- package M is new Ada.Containers.Functional_Vectors
- (Index_Type => Index_Type,
- Element_Type => Element_Type);
-
- function "="
- (Left : M.Sequence;
- Right : M.Sequence) return Boolean renames M."=";
-
- function "<"
- (Left : M.Sequence;
- Right : M.Sequence) return Boolean renames M."<";
-
- function "<="
- (Left : M.Sequence;
- Right : M.Sequence) return Boolean renames M."<=";
-
- function M_Elements_In_Union
- (Container : M.Sequence;
- Left : M.Sequence;
- Right : M.Sequence) return Boolean
- -- The elements of Container are contained in either Left or Right
- with
- Global => null,
- Post =>
- M_Elements_In_Union'Result =
- (for all I in Index_Type'First .. M.Last (Container) =>
- (for some J in Index_Type'First .. M.Last (Left) =>
- Element (Container, I) = Element (Left, J))
- or (for some J in Index_Type'First .. M.Last (Right) =>
- Element (Container, I) = Element (Right, J)));
- pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_In_Union);
-
- function M_Elements_Included
- (Left : M.Sequence;
- L_Fst : Index_Type := Index_Type'First;
- L_Lst : Extended_Index;
- Right : M.Sequence;
- R_Fst : Index_Type := Index_Type'First;
- R_Lst : Extended_Index) return Boolean
- -- The elements of the slice from L_Fst to L_Lst in Left are contained
- -- in the slide from R_Fst to R_Lst in Right.
- with
- Global => null,
- Pre => L_Lst <= M.Last (Left) and R_Lst <= M.Last (Right),
- Post =>
- M_Elements_Included'Result =
- (for all I in L_Fst .. L_Lst =>
- (for some J in R_Fst .. R_Lst =>
- Element (Left, I) = Element (Right, J)));
- pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_Included);
-
- function M_Elements_Reversed
- (Left : M.Sequence;
- Right : M.Sequence) return Boolean
- -- Right is Left in reverse order
- with
- Global => null,
- Post =>
- M_Elements_Reversed'Result =
- (M.Length (Left) = M.Length (Right)
- and (for all I in Index_Type'First .. M.Last (Left) =>
- Element (Left, I) =
- Element (Right, M.Last (Left) - I + 1))
- and (for all I in Index_Type'First .. M.Last (Right) =>
- Element (Right, I) =
- Element (Left, M.Last (Left) - I + 1)));
- pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_Reversed);
-
- function M_Elements_Swapped
- (Left : M.Sequence;
- Right : M.Sequence;
- X : Index_Type;
- Y : Index_Type) return Boolean
- -- Elements stored at X and Y are reversed in Left and Right
- with
- Global => null,
- Pre => X <= M.Last (Left) and Y <= M.Last (Left),
- Post =>
- M_Elements_Swapped'Result =
- (M.Length (Left) = M.Length (Right)
- and Element (Left, X) = Element (Right, Y)
- and Element (Left, Y) = Element (Right, X)
- and M.Equal_Except (Left, Right, X, Y));
- pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_Swapped);
-
- function Model (Container : Vector) return M.Sequence with
- -- The high-level model of a vector is a sequence of elements. The
- -- sequence really is similar to the vector itself. However, it is not
- -- limited which allows usage of 'Old and 'Loop_Entry attributes.
-
- Ghost,
- Global => null,
- Post => M.Length (Model'Result) = Length (Container);
-
- function Element
- (S : M.Sequence;
- I : Index_Type) return Element_Type renames M.Get;
- -- To improve readability of contracts, we rename the function used to
- -- access an element in the model to Element.
-
- end Formal_Model;
- use Formal_Model;
-
- function Empty_Vector return Vector with
- Global => null,
- Post => Length (Empty_Vector'Result) = 0;
-
- function "=" (Left, Right : Vector) return Boolean with
- Global => null,
- Post => "="'Result = (Model (Left) = Model (Right));
-
- function To_Vector
- (New_Item : Element_Type;
- Length : Capacity_Range) return Vector
- with
- Global => null,
- Post =>
- Formal_Indefinite_Vectors.Length (To_Vector'Result) = Length
- and M.Constant_Range
- (Container => Model (To_Vector'Result),
- Fst => Index_Type'First,
- Lst => Last_Index (To_Vector'Result),
- Item => New_Item);
-
- function Capacity (Container : Vector) return Capacity_Range with
- Global => null,
- Post =>
- Capacity'Result =
- (if Bounded then
- Container.Capacity
- else
- Capacity_Range'Last);
- pragma Annotate (GNATprove, Inline_For_Proof, Capacity);
-
- procedure Reserve_Capacity
- (Container : in out Vector;
- Capacity : Capacity_Range)
- with
- Global => null,
- Pre => (if Bounded then Capacity <= Container.Capacity),
- Post => Model (Container) = Model (Container)'Old;
-
- function Is_Empty (Container : Vector) return Boolean with
- Global => null,
- Post => Is_Empty'Result = (Length (Container) = 0);
-
- procedure Clear (Container : in out Vector) with
- Global => null,
- Post => Length (Container) = 0;
- -- Note that this reclaims storage in the unbounded case. You need to call
- -- this before a container goes out of scope in order to avoid storage
- -- leaks. In addition, "X := ..." can leak unless you Clear(X) first.
-
- procedure Assign (Target : in out Vector; Source : Vector) with
- Global => null,
- Pre => (if Bounded then Length (Source) <= Target.Capacity),
- Post => Model (Target) = Model (Source);
-
- function Copy
- (Source : Vector;
- Capacity : Capacity_Range := 0) return Vector
- with
- Global => null,
- Pre => (if Bounded then (Capacity = 0 or Length (Source) <= Capacity)),
- Post =>
- Model (Copy'Result) = Model (Source)
- and (if Capacity = 0 then
- Copy'Result.Capacity = Length (Source)
- else
- Copy'Result.Capacity = Capacity);
-
- procedure Move (Target : in out Vector; Source : in out Vector)
- with
- Global => null,
- Pre => (if Bounded then Length (Source) <= Capacity (Target)),
- Post => Model (Target) = Model (Source)'Old and Length (Source) = 0;
-
- function Element
- (Container : Vector;
- Index : Extended_Index) return Element_Type
- with
- Global => null,
- Pre => Index in First_Index (Container) .. Last_Index (Container),
- Post => Element'Result = Element (Model (Container), Index);
- pragma Annotate (GNATprove, Inline_For_Proof, Element);
-
- procedure Replace_Element
- (Container : in out Vector;
- Index : Index_Type;
- New_Item : Element_Type)
- with
- Global => null,
- Pre => Index in First_Index (Container) .. Last_Index (Container),
- Post =>
- Length (Container) = Length (Container)'Old
-
- -- Container now has New_Item at index Index
-
- and Element (Model (Container), Index) = New_Item
-
- -- All other elements are preserved
-
- and M.Equal_Except
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Position => Index);
-
- function At_End (E : access constant Vector) return access constant Vector
- is (E)
- with Ghost,
- Annotate => (GNATprove, At_End_Borrow);
-
- function At_End
- (E : access constant Element_Type) return access constant Element_Type
- is (E)
- with Ghost,
- Annotate => (GNATprove, At_End_Borrow);
-
- function Constant_Reference
- (Container : aliased Vector;
- Index : Index_Type) return not null access constant Element_Type
- with
- Global => null,
- Pre => Index in First_Index (Container) .. Last_Index (Container),
- Post =>
- Constant_Reference'Result.all = Element (Model (Container), Index);
-
- function Reference
- (Container : not null access Vector;
- Index : Index_Type) return not null access Element_Type
- with
- Global => null,
- Pre =>
- Index in First_Index (Container.all) .. Last_Index (Container.all),
- Post =>
- Length (Container.all) = Length (At_End (Container).all)
-
- -- Container will have Result.all at index Index
-
- and At_End (Reference'Result).all =
- Element (Model (At_End (Container).all), Index)
-
- -- All other elements are preserved
-
- and M.Equal_Except
- (Left => Model (Container.all),
- Right => Model (At_End (Container).all),
- Position => Index);
-
- procedure Insert
- (Container : in out Vector;
- Before : Extended_Index;
- New_Item : Vector)
- with
- Global => null,
- Pre =>
- Length (Container) <= Capacity (Container) - Length (New_Item)
- and (Before in Index_Type'First .. Last_Index (Container)
- or (Before /= No_Index
- and then Before - 1 = Last_Index (Container))),
- Post =>
- Length (Container) = Length (Container)'Old + Length (New_Item)
-
- -- Elements located before Before in Container are preserved
-
- and M.Range_Equal
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => Index_Type'First,
- Lst => Before - 1)
-
- -- Elements of New_Item are inserted at position Before
-
- and (if Length (New_Item) > 0 then
- M.Range_Shifted
- (Left => Model (New_Item),
- Right => Model (Container),
- Fst => Index_Type'First,
- Lst => Last_Index (New_Item),
- Offset => Count_Type (Before - Index_Type'First)))
-
- -- Elements located after Before in Container are shifted
-
- and M.Range_Shifted
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => Before,
- Lst => Last_Index (Container)'Old,
- Offset => Length (New_Item));
-
- procedure Insert
- (Container : in out Vector;
- Before : Extended_Index;
- New_Item : Element_Type)
- with
- Global => null,
- Pre =>
- Length (Container) < Capacity (Container)
- and then (Before in Index_Type'First .. Last_Index (Container) + 1),
- Post =>
- Length (Container) = Length (Container)'Old + 1
-
- -- Elements located before Before in Container are preserved
-
- and M.Range_Equal
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => Index_Type'First,
- Lst => Before - 1)
-
- -- Container now has New_Item at index Before
-
- and Element (Model (Container), Before) = New_Item
-
- -- Elements located after Before in Container are shifted by 1
-
- and M.Range_Shifted
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => Before,
- Lst => Last_Index (Container)'Old,
- Offset => 1);
-
- procedure Insert
- (Container : in out Vector;
- Before : Extended_Index;
- New_Item : Element_Type;
- Count : Count_Type)
- with
- Global => null,
- Pre =>
- Length (Container) <= Capacity (Container) - Count
- and (Before in Index_Type'First .. Last_Index (Container)
- or (Before /= No_Index
- and then Before - 1 = Last_Index (Container))),
- Post =>
- Length (Container) = Length (Container)'Old + Count
-
- -- Elements located before Before in Container are preserved
-
- and M.Range_Equal
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => Index_Type'First,
- Lst => Before - 1)
-
- -- New_Item is inserted Count times at position Before
-
- and (if Count > 0 then
- M.Constant_Range
- (Container => Model (Container),
- Fst => Before,
- Lst => Before + Index_Type'Base (Count - 1),
- Item => New_Item))
-
- -- Elements located after Before in Container are shifted
-
- and M.Range_Shifted
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => Before,
- Lst => Last_Index (Container)'Old,
- Offset => Count);
-
- procedure Prepend (Container : in out Vector; New_Item : Vector) with
- Global => null,
- Pre => Length (Container) <= Capacity (Container) - Length (New_Item),
- Post =>
- Length (Container) = Length (Container)'Old + Length (New_Item)
-
- -- Elements of New_Item are inserted at the beginning of Container
-
- and M.Range_Equal
- (Left => Model (New_Item),
- Right => Model (Container),
- Fst => Index_Type'First,
- Lst => Last_Index (New_Item))
-
- -- Elements of Container are shifted
-
- and M.Range_Shifted
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => Index_Type'First,
- Lst => Last_Index (Container)'Old,
- Offset => Length (New_Item));
-
- procedure Prepend (Container : in out Vector; New_Item : Element_Type) with
- Global => null,
- Pre => Length (Container) < Capacity (Container),
- Post =>
- Length (Container) = Length (Container)'Old + 1
-
- -- Container now has New_Item at Index_Type'First
-
- and Element (Model (Container), Index_Type'First) = New_Item
-
- -- Elements of Container are shifted by 1
-
- and M.Range_Shifted
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => Index_Type'First,
- Lst => Last_Index (Container)'Old,
- Offset => 1);
-
- procedure Prepend
- (Container : in out Vector;
- New_Item : Element_Type;
- Count : Count_Type)
- with
- Global => null,
- Pre => Length (Container) <= Capacity (Container) - Count,
- Post =>
- Length (Container) = Length (Container)'Old + Count
-
- -- New_Item is inserted Count times at the beginning of Container
-
- and M.Constant_Range
- (Container => Model (Container),
- Fst => Index_Type'First,
- Lst => Index_Type'First + Index_Type'Base (Count - 1),
- Item => New_Item)
-
- -- Elements of Container are shifted
-
- and M.Range_Shifted
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => Index_Type'First,
- Lst => Last_Index (Container)'Old,
- Offset => Count);
-
- procedure Append (Container : in out Vector; New_Item : Vector) with
- Global => null,
- Pre =>
- Length (Container) <= Capacity (Container) - Length (New_Item),
- Post =>
- Length (Container) = Length (Container)'Old + Length (New_Item)
-
- -- The elements of Container are preserved
-
- and Model (Container)'Old <= Model (Container)
-
- -- Elements of New_Item are inserted at the end of Container
-
- and (if Length (New_Item) > 0 then
- M.Range_Shifted
- (Left => Model (New_Item),
- Right => Model (Container),
- Fst => Index_Type'First,
- Lst => Last_Index (New_Item),
- Offset =>
- Count_Type
- (Last_Index (Container)'Old - Index_Type'First + 1)));
-
- procedure Append (Container : in out Vector; New_Item : Element_Type) with
- Global => null,
- Pre => Length (Container) < Capacity (Container),
- Post =>
- Length (Container) = Length (Container)'Old + 1
-
- -- Elements of Container are preserved
-
- and Model (Container)'Old < Model (Container)
-
- -- Container now has New_Item at the end of Container
-
- and Element
- (Model (Container), Last_Index (Container)'Old + 1) = New_Item;
-
- procedure Append
- (Container : in out Vector;
- New_Item : Element_Type;
- Count : Count_Type)
- with
- Global => null,
- Pre => Length (Container) <= Capacity (Container) - Count,
- Post =>
- Length (Container) = Length (Container)'Old + Count
-
- -- Elements of Container are preserved
-
- and Model (Container)'Old <= Model (Container)
-
- -- New_Item is inserted Count times at the end of Container
-
- and (if Count > 0 then
- M.Constant_Range
- (Container => Model (Container),
- Fst => Last_Index (Container)'Old + 1,
- Lst =>
- Last_Index (Container)'Old + Index_Type'Base (Count),
- Item => New_Item));
-
- procedure Delete (Container : in out Vector; Index : Extended_Index) with
- Global => null,
- Pre => Index in First_Index (Container) .. Last_Index (Container),
- Post =>
- Length (Container) = Length (Container)'Old - 1
-
- -- Elements located before Index in Container are preserved
-
- and M.Range_Equal
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => Index_Type'First,
- Lst => Index - 1)
-
- -- Elements located after Index in Container are shifted by 1
-
- and M.Range_Shifted
- (Left => Model (Container),
- Right => Model (Container)'Old,
- Fst => Index,
- Lst => Last_Index (Container),
- Offset => 1);
-
- procedure Delete
- (Container : in out Vector;
- Index : Extended_Index;
- Count : Count_Type)
- with
- Global => null,
- Pre =>
- Index in First_Index (Container) .. Last_Index (Container),
- Post =>
- Length (Container) in
- Length (Container)'Old - Count .. Length (Container)'Old
-
- -- The elements of Container located before Index are preserved.
-
- and M.Range_Equal
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => Index_Type'First,
- Lst => Index - 1),
-
- Contract_Cases =>
-
- -- All the elements after Position have been erased
-
- (Length (Container) - Count <= Count_Type (Index - Index_Type'First) =>
- Length (Container) = Count_Type (Index - Index_Type'First),
-
- others =>
- Length (Container) = Length (Container)'Old - Count
-
- -- Other elements are shifted by Count
-
- and M.Range_Shifted
- (Left => Model (Container),
- Right => Model (Container)'Old,
- Fst => Index,
- Lst => Last_Index (Container),
- Offset => Count));
-
- procedure Delete_First (Container : in out Vector) with
- Global => null,
- Pre => Length (Container) > 0,
- Post =>
- Length (Container) = Length (Container)'Old - 1
-
- -- Elements of Container are shifted by 1
-
- and M.Range_Shifted
- (Left => Model (Container),
- Right => Model (Container)'Old,
- Fst => Index_Type'First,
- Lst => Last_Index (Container),
- Offset => 1);
-
- procedure Delete_First (Container : in out Vector; Count : Count_Type) with
- Global => null,
- Contract_Cases =>
-
- -- All the elements of Container have been erased
-
- (Length (Container) <= Count => Length (Container) = 0,
-
- others =>
- Length (Container) = Length (Container)'Old - Count
-
- -- Elements of Container are shifted by Count
-
- and M.Range_Shifted
- (Left => Model (Container),
- Right => Model (Container)'Old,
- Fst => Index_Type'First,
- Lst => Last_Index (Container),
- Offset => Count));
-
- procedure Delete_Last (Container : in out Vector) with
- Global => null,
- Pre => Length (Container) > 0,
- Post =>
- Length (Container) = Length (Container)'Old - 1
-
- -- Elements of Container are preserved
-
- and Model (Container) < Model (Container)'Old;
-
- procedure Delete_Last (Container : in out Vector; Count : Count_Type) with
- Global => null,
- Contract_Cases =>
-
- -- All the elements after Position have been erased
-
- (Length (Container) <= Count => Length (Container) = 0,
-
- others =>
- Length (Container) = Length (Container)'Old - Count
-
- -- The elements of Container are preserved
-
- and Model (Container) <= Model (Container)'Old);
-
- procedure Reverse_Elements (Container : in out Vector) with
- Global => null,
- Post => M_Elements_Reversed (Model (Container)'Old, Model (Container));
-
- procedure Swap
- (Container : in out Vector;
- I : Index_Type;
- J : Index_Type)
- with
- Global => null,
- Pre =>
- I in First_Index (Container) .. Last_Index (Container)
- and then J in First_Index (Container) .. Last_Index (Container),
- Post =>
- M_Elements_Swapped (Model (Container)'Old, Model (Container), I, J);
-
- function First_Index (Container : Vector) return Index_Type with
- Global => null,
- Post => First_Index'Result = Index_Type'First;
- pragma Annotate (GNATprove, Inline_For_Proof, First_Index);
-
- function First_Element (Container : Vector) return Element_Type with
- Global => null,
- Pre => not Is_Empty (Container),
- Post =>
- First_Element'Result = Element (Model (Container), Index_Type'First);
- pragma Annotate (GNATprove, Inline_For_Proof, First_Element);
-
- function Last_Index (Container : Vector) return Extended_Index with
- Global => null,
- Post => Last_Index'Result = M.Last (Model (Container));
- pragma Annotate (GNATprove, Inline_For_Proof, Last_Index);
-
- function Last_Element (Container : Vector) return Element_Type with
- Global => null,
- Pre => not Is_Empty (Container),
- Post =>
- Last_Element'Result =
- Element (Model (Container), Last_Index (Container));
- pragma Annotate (GNATprove, Inline_For_Proof, Last_Element);
-
- function Find_Index
- (Container : Vector;
- Item : Element_Type;
- Index : Index_Type := Index_Type'First) return Extended_Index
- with
- Global => null,
- Contract_Cases =>
-
- -- If Item is not contained in Container after Index, Find_Index
- -- returns No_Index.
-
- (Index > Last_Index (Container)
- or else not M.Contains
- (Container => Model (Container),
- Fst => Index,
- Lst => Last_Index (Container),
- Item => Item)
- =>
- Find_Index'Result = No_Index,
-
- -- Otherwise, Find_Index returns a valid index greater than Index
-
- others =>
- Find_Index'Result in Index .. Last_Index (Container)
-
- -- The element at this index in Container is Item
-
- and Element (Model (Container), Find_Index'Result) = Item
-
- -- It is the first occurrence of Item after Index in Container
-
- and not M.Contains
- (Container => Model (Container),
- Fst => Index,
- Lst => Find_Index'Result - 1,
- Item => Item));
-
- function Reverse_Find_Index
- (Container : Vector;
- Item : Element_Type;
- Index : Index_Type := Index_Type'Last) return Extended_Index
- with
- Global => null,
- Contract_Cases =>
-
- -- If Item is not contained in Container before Index,
- -- Reverse_Find_Index returns No_Index.
-
- (not M.Contains
- (Container => Model (Container),
- Fst => Index_Type'First,
- Lst => (if Index <= Last_Index (Container) then Index
- else Last_Index (Container)),
- Item => Item)
- =>
- Reverse_Find_Index'Result = No_Index,
-
- -- Otherwise, Reverse_Find_Index returns a valid index smaller than
- -- Index
-
- others =>
- Reverse_Find_Index'Result in Index_Type'First .. Index
- and Reverse_Find_Index'Result <= Last_Index (Container)
-
- -- The element at this index in Container is Item
-
- and Element (Model (Container), Reverse_Find_Index'Result) = Item
-
- -- It is the last occurrence of Item before Index in Container
-
- and not M.Contains
- (Container => Model (Container),
- Fst => Reverse_Find_Index'Result + 1,
- Lst =>
- (if Index <= Last_Index (Container) then
- Index
- else
- Last_Index (Container)),
- Item => Item));
-
- function Contains
- (Container : Vector;
- Item : Element_Type) return Boolean
- with
- Global => null,
- Post =>
- Contains'Result =
- M.Contains
- (Container => Model (Container),
- Fst => Index_Type'First,
- Lst => Last_Index (Container),
- Item => Item);
-
- function Has_Element
- (Container : Vector;
- Position : Extended_Index) return Boolean
- with
- Global => null,
- Post =>
- Has_Element'Result =
- (Position in Index_Type'First .. Last_Index (Container));
- pragma Annotate (GNATprove, Inline_For_Proof, Has_Element);
-
- generic
- with function "<" (Left, Right : Element_Type) return Boolean is <>;
- package Generic_Sorting with SPARK_Mode is
-
- package Formal_Model with Ghost is
-
- function M_Elements_Sorted (Container : M.Sequence) return Boolean
- with
- Global => null,
- Post =>
- M_Elements_Sorted'Result =
- (for all I in Index_Type'First .. M.Last (Container) =>
- (for all J in I .. M.Last (Container) =>
- Element (Container, I) = Element (Container, J)
- or Element (Container, I) < Element (Container, J)));
- pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_Sorted);
-
- end Formal_Model;
- use Formal_Model;
-
- function Is_Sorted (Container : Vector) return Boolean with
- Global => null,
- Post => Is_Sorted'Result = M_Elements_Sorted (Model (Container));
-
- procedure Sort (Container : in out Vector) with
- Global => null,
- Post =>
- Length (Container) = Length (Container)'Old
- and M_Elements_Sorted (Model (Container))
- and M_Elements_Included
- (Left => Model (Container)'Old,
- L_Lst => Last_Index (Container),
- Right => Model (Container),
- R_Lst => Last_Index (Container))
- and M_Elements_Included
- (Left => Model (Container),
- L_Lst => Last_Index (Container),
- Right => Model (Container)'Old,
- R_Lst => Last_Index (Container));
-
- procedure Merge (Target : in out Vector; Source : in out Vector) with
- -- Target and Source should not be aliased
- Global => null,
- Pre => Length (Source) <= Capacity (Target) - Length (Target),
- Post =>
- Length (Target) = Length (Target)'Old + Length (Source)'Old
- and Length (Source) = 0
- and (if M_Elements_Sorted (Model (Target)'Old)
- and M_Elements_Sorted (Model (Source)'Old)
- then
- M_Elements_Sorted (Model (Target)))
- and M_Elements_Included
- (Left => Model (Target)'Old,
- L_Lst => Last_Index (Target)'Old,
- Right => Model (Target),
- R_Lst => Last_Index (Target))
- and M_Elements_Included
- (Left => Model (Source)'Old,
- L_Lst => Last_Index (Source)'Old,
- Right => Model (Target),
- R_Lst => Last_Index (Target))
- and M_Elements_In_Union
- (Model (Target),
- Model (Source)'Old,
- Model (Target)'Old);
- end Generic_Sorting;
-
-private
- pragma SPARK_Mode (Off);
-
- pragma Inline (First_Index);
- pragma Inline (Last_Index);
- pragma Inline (Element);
- pragma Inline (First_Element);
- pragma Inline (Last_Element);
- pragma Inline (Replace_Element);
- pragma Inline (Contains);
-
- -- The implementation method is to instantiate Bounded_Holders to get a
- -- definite type for Element_Type.
-
- package Holders is new Bounded_Holders
- (Element_Type, Max_Size_In_Storage_Elements, "=");
- use Holders;
-
- subtype Array_Index is Capacity_Range range 1 .. Capacity_Range'Last;
- type Elements_Array is array (Array_Index range <>) of aliased Holder;
- function "=" (L, R : Elements_Array) return Boolean is abstract;
-
- type Elements_Array_Ptr is access all Elements_Array;
-
- type Vector (Capacity : Capacity_Range) is limited record
-
- -- In the bounded case, the elements are stored in Elements. In the
- -- unbounded case, the elements are initially stored in Elements, until
- -- we run out of room, then we switch to Elements_Ptr.
-
- Last : Extended_Index := No_Index;
- Elements_Ptr : Elements_Array_Ptr := null;
- Elements : aliased Elements_Array (1 .. Capacity);
- end record;
-
- -- The primary reason Vector is limited is that in the unbounded case, once
- -- Elements_Ptr is in use, assignment statements won't work. "X := Y;" will
- -- cause X and Y to share state; that is, X.Elements_Ptr = Y.Elements_Ptr,
- -- so for example "Append (X, ...);" will modify BOTH X and Y. That would
- -- allow SPARK to "prove" things that are false. We could fix that by
- -- making Vector a controlled type, and override Adjust to make a deep
- -- copy, but finalization is not allowed in SPARK.
- --
- -- Note that (unfortunately) this means that 'Old and 'Loop_Entry are not
- -- allowed on Vectors.
+package Ada.Containers.Formal_Indefinite_Vectors with SPARK_Mode is
- function Empty_Vector return Vector is
- ((Capacity => 0, others => <>));
+ pragma Compile_Time_Error
+ (True,
+ "This package has been moved to the SPARK library shipped with any"
+ & " SPARK release starting with version 23.");
end Ada.Containers.Formal_Indefinite_Vectors;
diff --git a/gcc/ada/libgnat/a-cforma.adb b/gcc/ada/libgnat/a-cforma.adb
deleted file mode 100644
index 38d15e7..0000000
--- a/gcc/ada/libgnat/a-cforma.adb
+++ /dev/null
@@ -1,1239 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT LIBRARY COMPONENTS --
--- --
--- A D A . C O N T A I N E R S . F O R M A L _ O R D E R E D _ M A P S --
--- --
--- B o d y --
--- --
--- Copyright (C) 2010-2022, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
-------------------------------------------------------------------------------
-
-with Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations;
-pragma Elaborate_All
- (Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations);
-
-with Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys;
-pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys);
-
-with Ada.Numerics.Big_Numbers.Big_Integers;
-use Ada.Numerics.Big_Numbers.Big_Integers;
-
-with System; use type System.Address;
-
-package body Ada.Containers.Formal_Ordered_Maps with
- SPARK_Mode => Off
-is
-
- -- Convert Count_Type to Big_Interger
-
- package Conversions is new Signed_Conversions (Int => Count_Type);
-
- function Big (J : Count_Type) return Big_Integer renames
- Conversions.To_Big_Integer;
-
- -----------------------------
- -- Node Access Subprograms --
- -----------------------------
-
- -- These subprograms provide a functional interface to access fields
- -- of a node, and a procedural interface for modifying these values.
-
- function Color
- (Node : Node_Type) return Ada.Containers.Red_Black_Trees.Color_Type;
- pragma Inline (Color);
-
- function Left_Son (Node : Node_Type) return Count_Type;
- pragma Inline (Left_Son);
-
- function Parent (Node : Node_Type) return Count_Type;
- pragma Inline (Parent);
-
- function Right_Son (Node : Node_Type) return Count_Type;
- pragma Inline (Right_Son);
-
- procedure Set_Color
- (Node : in out Node_Type;
- Color : Ada.Containers.Red_Black_Trees.Color_Type);
- pragma Inline (Set_Color);
-
- procedure Set_Left (Node : in out Node_Type; Left : Count_Type);
- pragma Inline (Set_Left);
-
- procedure Set_Right (Node : in out Node_Type; Right : Count_Type);
- pragma Inline (Set_Right);
-
- procedure Set_Parent (Node : in out Node_Type; Parent : Count_Type);
- pragma Inline (Set_Parent);
-
- -----------------------
- -- Local Subprograms --
- -----------------------
-
- -- All need comments ???
-
- generic
- with procedure Set_Element (Node : in out Node_Type);
- procedure Generic_Allocate
- (Tree : in out Tree_Types.Tree_Type'Class;
- Node : out Count_Type);
-
- procedure Free (Tree : in out Map; X : Count_Type);
-
- function Is_Greater_Key_Node
- (Left : Key_Type;
- Right : Node_Type) return Boolean;
- pragma Inline (Is_Greater_Key_Node);
-
- function Is_Less_Key_Node
- (Left : Key_Type;
- Right : Node_Type) return Boolean;
- pragma Inline (Is_Less_Key_Node);
-
- --------------------------
- -- Local Instantiations --
- --------------------------
-
- package Tree_Operations is
- new Red_Black_Trees.Generic_Bounded_Operations
- (Tree_Types => Tree_Types,
- Left => Left_Son,
- Right => Right_Son);
-
- use Tree_Operations;
-
- package Key_Ops is
- new Red_Black_Trees.Generic_Bounded_Keys
- (Tree_Operations => Tree_Operations,
- Key_Type => Key_Type,
- Is_Less_Key_Node => Is_Less_Key_Node,
- Is_Greater_Key_Node => Is_Greater_Key_Node);
-
- ---------
- -- "=" --
- ---------
-
- function "=" (Left, Right : Map) return Boolean is
- Lst : Count_Type;
- Node : Count_Type;
- ENode : Count_Type;
-
- begin
- if Length (Left) /= Length (Right) then
- return False;
- end if;
-
- if Is_Empty (Left) then
- return True;
- end if;
-
- Lst := Next (Left.Content, Last (Left).Node);
-
- Node := First (Left).Node;
- while Node /= Lst loop
- ENode := Find (Right, Left.Content.Nodes (Node).Key).Node;
-
- if ENode = 0 or else
- Left.Content.Nodes (Node).Element /=
- Right.Content.Nodes (ENode).Element
- then
- return False;
- end if;
-
- Node := Next (Left.Content, Node);
- end loop;
-
- return True;
- end "=";
-
- ------------
- -- Assign --
- ------------
-
- procedure Assign (Target : in out Map; Source : Map) is
- procedure Append_Element (Source_Node : Count_Type);
-
- procedure Append_Elements is
- new Tree_Operations.Generic_Iteration (Append_Element);
-
- --------------------
- -- Append_Element --
- --------------------
-
- procedure Append_Element (Source_Node : Count_Type) is
- SN : Node_Type renames Source.Content.Nodes (Source_Node);
-
- procedure Set_Element (Node : in out Node_Type);
- pragma Inline (Set_Element);
-
- function New_Node return Count_Type;
- pragma Inline (New_Node);
-
- procedure Insert_Post is new Key_Ops.Generic_Insert_Post (New_Node);
-
- procedure Unconditional_Insert_Sans_Hint is
- new Key_Ops.Generic_Unconditional_Insert (Insert_Post);
-
- procedure Unconditional_Insert_Avec_Hint is
- new Key_Ops.Generic_Unconditional_Insert_With_Hint
- (Insert_Post,
- Unconditional_Insert_Sans_Hint);
-
- procedure Allocate is new Generic_Allocate (Set_Element);
-
- --------------
- -- New_Node --
- --------------
-
- function New_Node return Count_Type is
- Result : Count_Type;
- begin
- Allocate (Target.Content, Result);
- return Result;
- end New_Node;
-
- -----------------
- -- Set_Element --
- -----------------
-
- procedure Set_Element (Node : in out Node_Type) is
- begin
- Node.Key := SN.Key;
- Node.Element := SN.Element;
- end Set_Element;
-
- Target_Node : Count_Type;
-
- -- Start of processing for Append_Element
-
- begin
- Unconditional_Insert_Avec_Hint
- (Tree => Target.Content,
- Hint => 0,
- Key => SN.Key,
- Node => Target_Node);
- end Append_Element;
-
- -- Start of processing for Assign
-
- begin
- if Target'Address = Source'Address then
- return;
- end if;
-
- if Target.Capacity < Length (Source) then
- raise Storage_Error with "not enough capacity"; -- SE or CE? ???
- end if;
-
- Tree_Operations.Clear_Tree (Target.Content);
- Append_Elements (Source.Content);
- end Assign;
-
- -------------
- -- Ceiling --
- -------------
-
- function Ceiling (Container : Map; Key : Key_Type) return Cursor is
- Node : constant Count_Type := Key_Ops.Ceiling (Container.Content, Key);
-
- begin
- if Node = 0 then
- return No_Element;
- end if;
-
- return (Node => Node);
- end Ceiling;
-
- -----------
- -- Clear --
- -----------
-
- procedure Clear (Container : in out Map) is
- begin
- Tree_Operations.Clear_Tree (Container.Content);
- end Clear;
-
- -----------
- -- Color --
- -----------
-
- function Color (Node : Node_Type) return Color_Type is
- begin
- return Node.Color;
- end Color;
-
- ------------------------
- -- Constant_Reference --
- ------------------------
-
- function Constant_Reference
- (Container : aliased Map;
- Position : Cursor) return not null access constant Element_Type
- is
- begin
- if not Has_Element (Container, Position) then
- raise Constraint_Error with "Position cursor has no element";
- end if;
-
- pragma Assert (Vet (Container.Content, Position.Node),
- "bad cursor in function Constant_Reference");
-
- return Container.Content.Nodes (Position.Node).Element'Access;
- end Constant_Reference;
-
- function Constant_Reference
- (Container : aliased Map;
- Key : Key_Type) return not null access constant Element_Type
- is
- Node : constant Node_Access := Find (Container, Key).Node;
-
- begin
- if Node = 0 then
- raise Constraint_Error with
- "no element available because key not in map";
- end if;
-
- return Container.Content.Nodes (Node).Element'Access;
- end Constant_Reference;
-
- --------------
- -- Contains --
- --------------
-
- function Contains (Container : Map; Key : Key_Type) return Boolean is
- begin
- return Find (Container, Key) /= No_Element;
- end Contains;
-
- ----------
- -- Copy --
- ----------
-
- function Copy (Source : Map; Capacity : Count_Type := 0) return Map is
- Node : Count_Type := 1;
- N : Count_Type;
-
- begin
- if 0 < Capacity and then Capacity < Source.Capacity then
- raise Capacity_Error;
- end if;
-
- return Target : Map (Count_Type'Max (Source.Capacity, Capacity)) do
- if Length (Source) > 0 then
- Target.Content.Length := Source.Content.Length;
- Target.Content.Root := Source.Content.Root;
- Target.Content.First := Source.Content.First;
- Target.Content.Last := Source.Content.Last;
- Target.Content.Free := Source.Content.Free;
-
- while Node <= Source.Capacity loop
- Target.Content.Nodes (Node).Element :=
- Source.Content.Nodes (Node).Element;
- Target.Content.Nodes (Node).Key :=
- Source.Content.Nodes (Node).Key;
- Target.Content.Nodes (Node).Parent :=
- Source.Content.Nodes (Node).Parent;
- Target.Content.Nodes (Node).Left :=
- Source.Content.Nodes (Node).Left;
- Target.Content.Nodes (Node).Right :=
- Source.Content.Nodes (Node).Right;
- Target.Content.Nodes (Node).Color :=
- Source.Content.Nodes (Node).Color;
- Target.Content.Nodes (Node).Has_Element :=
- Source.Content.Nodes (Node).Has_Element;
- Node := Node + 1;
- end loop;
-
- while Node <= Target.Capacity loop
- N := Node;
- Free (Tree => Target, X => N);
- Node := Node + 1;
- end loop;
- end if;
- end return;
- end Copy;
-
- ------------
- -- Delete --
- ------------
-
- procedure Delete (Container : in out Map; Position : in out Cursor) is
- begin
- if not Has_Element (Container, Position) then
- raise Constraint_Error with
- "Position cursor of Delete has no element";
- end if;
-
- pragma Assert (Vet (Container.Content, Position.Node),
- "Position cursor of Delete is bad");
-
- Tree_Operations.Delete_Node_Sans_Free (Container.Content,
- Position.Node);
- Free (Container, Position.Node);
- Position := No_Element;
- end Delete;
-
- procedure Delete (Container : in out Map; Key : Key_Type) is
- X : constant Node_Access := Key_Ops.Find (Container.Content, Key);
-
- begin
- if X = 0 then
- raise Constraint_Error with "key not in map";
- end if;
-
- Tree_Operations.Delete_Node_Sans_Free (Container.Content, X);
- Free (Container, X);
- end Delete;
-
- ------------------
- -- Delete_First --
- ------------------
-
- procedure Delete_First (Container : in out Map) is
- X : constant Node_Access := First (Container).Node;
- begin
- if X /= 0 then
- Tree_Operations.Delete_Node_Sans_Free (Container.Content, X);
- Free (Container, X);
- end if;
- end Delete_First;
-
- -----------------
- -- Delete_Last --
- -----------------
-
- procedure Delete_Last (Container : in out Map) is
- X : constant Node_Access := Last (Container).Node;
- begin
- if X /= 0 then
- Tree_Operations.Delete_Node_Sans_Free (Container.Content, X);
- Free (Container, X);
- end if;
- end Delete_Last;
-
- -------------
- -- Element --
- -------------
-
- function Element (Container : Map; Position : Cursor) return Element_Type is
- begin
- if not Has_Element (Container, Position) then
- raise Constraint_Error with
- "Position cursor of function Element has no element";
- end if;
-
- pragma Assert (Vet (Container.Content, Position.Node),
- "Position cursor of function Element is bad");
-
- return Container.Content.Nodes (Position.Node).Element;
-
- end Element;
-
- function Element (Container : Map; Key : Key_Type) return Element_Type is
- Node : constant Node_Access := Find (Container, Key).Node;
-
- begin
- if Node = 0 then
- raise Constraint_Error with "key not in map";
- end if;
-
- return Container.Content.Nodes (Node).Element;
- end Element;
-
- ---------------------
- -- Equivalent_Keys --
- ---------------------
-
- function Equivalent_Keys (Left, Right : Key_Type) return Boolean is
- begin
- if Left < Right
- or else Right < Left
- then
- return False;
- else
- return True;
- end if;
- end Equivalent_Keys;
-
- -------------
- -- Exclude --
- -------------
-
- procedure Exclude (Container : in out Map; Key : Key_Type) is
- X : constant Node_Access := Key_Ops.Find (Container.Content, Key);
- begin
- if X /= 0 then
- Tree_Operations.Delete_Node_Sans_Free (Container.Content, X);
- Free (Container, X);
- end if;
- end Exclude;
-
- ----------
- -- Find --
- ----------
-
- function Find (Container : Map; Key : Key_Type) return Cursor is
- Node : constant Count_Type := Key_Ops.Find (Container.Content, Key);
-
- begin
- if Node = 0 then
- return No_Element;
- end if;
-
- return (Node => Node);
- end Find;
-
- -----------
- -- First --
- -----------
-
- function First (Container : Map) return Cursor is
- begin
- if Length (Container) = 0 then
- return No_Element;
- end if;
-
- return (Node => Container.Content.First);
- end First;
-
- -------------------
- -- First_Element --
- -------------------
-
- function First_Element (Container : Map) return Element_Type is
- begin
- if Is_Empty (Container) then
- raise Constraint_Error with "map is empty";
- end if;
-
- return Container.Content.Nodes (First (Container).Node).Element;
- end First_Element;
-
- ---------------
- -- First_Key --
- ---------------
-
- function First_Key (Container : Map) return Key_Type is
- begin
- if Is_Empty (Container) then
- raise Constraint_Error with "map is empty";
- end if;
-
- return Container.Content.Nodes (First (Container).Node).Key;
- end First_Key;
-
- -----------
- -- Floor --
- -----------
-
- function Floor (Container : Map; Key : Key_Type) return Cursor is
- Node : constant Count_Type := Key_Ops.Floor (Container.Content, Key);
-
- begin
- if Node = 0 then
- return No_Element;
- end if;
-
- return (Node => Node);
- end Floor;
-
- ------------------
- -- Formal_Model --
- ------------------
-
- package body Formal_Model is
-
- ----------
- -- Find --
- ----------
-
- function Find
- (Container : K.Sequence;
- Key : Key_Type) return Count_Type
- is
- begin
- for I in 1 .. K.Length (Container) loop
- if Equivalent_Keys (Key, K.Get (Container, I)) then
- return I;
- elsif Key < K.Get (Container, I) then
- return 0;
- end if;
- end loop;
- return 0;
- end Find;
-
- -------------------------
- -- K_Bigger_Than_Range --
- -------------------------
-
- function K_Bigger_Than_Range
- (Container : K.Sequence;
- Fst : Positive_Count_Type;
- Lst : Count_Type;
- Key : Key_Type) return Boolean
- is
- begin
- for I in Fst .. Lst loop
- if not (K.Get (Container, I) < Key) then
- return False;
- end if;
- end loop;
- return True;
- end K_Bigger_Than_Range;
-
- ---------------
- -- K_Is_Find --
- ---------------
-
- function K_Is_Find
- (Container : K.Sequence;
- Key : Key_Type;
- Position : Count_Type) return Boolean
- is
- begin
- for I in 1 .. Position - 1 loop
- if Key < K.Get (Container, I) then
- return False;
- end if;
- end loop;
-
- if Position < K.Length (Container) then
- for I in Position + 1 .. K.Length (Container) loop
- if K.Get (Container, I) < Key then
- return False;
- end if;
- end loop;
- end if;
- return True;
- end K_Is_Find;
-
- --------------------------
- -- K_Smaller_Than_Range --
- --------------------------
-
- function K_Smaller_Than_Range
- (Container : K.Sequence;
- Fst : Positive_Count_Type;
- Lst : Count_Type;
- Key : Key_Type) return Boolean
- is
- begin
- for I in Fst .. Lst loop
- if not (Key < K.Get (Container, I)) then
- return False;
- end if;
- end loop;
- return True;
- end K_Smaller_Than_Range;
-
- ----------
- -- Keys --
- ----------
-
- function Keys (Container : Map) return K.Sequence is
- Position : Count_Type := Container.Content.First;
- R : K.Sequence;
-
- begin
- -- Can't use First, Next or Element here, since they depend on models
- -- for their postconditions.
-
- while Position /= 0 loop
- R := K.Add (R, Container.Content.Nodes (Position).Key);
- Position := Tree_Operations.Next (Container.Content, Position);
- end loop;
-
- return R;
- end Keys;
-
- ----------------------------
- -- Lift_Abstraction_Level --
- ----------------------------
-
- procedure Lift_Abstraction_Level (Container : Map) is null;
-
- -----------
- -- Model --
- -----------
-
- function Model (Container : Map) return M.Map is
- Position : Count_Type := Container.Content.First;
- R : M.Map;
-
- begin
- -- Can't use First, Next or Element here, since they depend on models
- -- for their postconditions.
-
- while Position /= 0 loop
- R :=
- M.Add
- (Container => R,
- New_Key => Container.Content.Nodes (Position).Key,
- New_Item => Container.Content.Nodes (Position).Element);
-
- Position := Tree_Operations.Next (Container.Content, Position);
- end loop;
-
- return R;
- end Model;
-
- -------------------------
- -- P_Positions_Shifted --
- -------------------------
-
- function P_Positions_Shifted
- (Small : P.Map;
- Big : P.Map;
- Cut : Positive_Count_Type;
- Count : Count_Type := 1) return Boolean
- is
- begin
- for Cu of Small loop
- if not P.Has_Key (Big, Cu) then
- return False;
- end if;
- end loop;
-
- for Cu of Big loop
- declare
- Pos : constant Positive_Count_Type := P.Get (Big, Cu);
-
- begin
- if Pos < Cut then
- if not P.Has_Key (Small, Cu)
- or else Pos /= P.Get (Small, Cu)
- then
- return False;
- end if;
-
- elsif Pos >= Cut + Count then
- if not P.Has_Key (Small, Cu)
- or else Pos /= P.Get (Small, Cu) + Count
- then
- return False;
- end if;
-
- else
- if P.Has_Key (Small, Cu) then
- return False;
- end if;
- end if;
- end;
- end loop;
-
- return True;
- end P_Positions_Shifted;
-
- ---------------
- -- Positions --
- ---------------
-
- function Positions (Container : Map) return P.Map is
- I : Count_Type := 1;
- Position : Count_Type := Container.Content.First;
- R : P.Map;
-
- begin
- -- Can't use First, Next or Element here, since they depend on models
- -- for their postconditions.
-
- while Position /= 0 loop
- R := P.Add (R, (Node => Position), I);
- pragma Assert (P.Length (R) = Big (I));
- Position := Tree_Operations.Next (Container.Content, Position);
- I := I + 1;
- end loop;
-
- return R;
- end Positions;
-
- end Formal_Model;
-
- ----------
- -- Free --
- ----------
-
- procedure Free
- (Tree : in out Map;
- X : Count_Type)
- is
- begin
- Tree.Content.Nodes (X).Has_Element := False;
- Tree_Operations.Free (Tree.Content, X);
- end Free;
-
- ----------------------
- -- Generic_Allocate --
- ----------------------
-
- procedure Generic_Allocate
- (Tree : in out Tree_Types.Tree_Type'Class;
- Node : out Count_Type)
- is
- procedure Allocate is
- new Tree_Operations.Generic_Allocate (Set_Element);
- begin
- Allocate (Tree, Node);
- Tree.Nodes (Node).Has_Element := True;
- end Generic_Allocate;
-
- -----------------
- -- Has_Element --
- -----------------
-
- function Has_Element (Container : Map; Position : Cursor) return Boolean is
- begin
- if Position.Node = 0 then
- return False;
- end if;
-
- return Container.Content.Nodes (Position.Node).Has_Element;
- end Has_Element;
-
- -------------
- -- Include --
- -------------
-
- procedure Include
- (Container : in out Map;
- Key : Key_Type;
- New_Item : Element_Type)
- is
- Position : Cursor;
- Inserted : Boolean;
-
- begin
- Insert (Container, Key, New_Item, Position, Inserted);
-
- if not Inserted then
- declare
- N : Node_Type renames Container.Content.Nodes (Position.Node);
- begin
- N.Key := Key;
- N.Element := New_Item;
- end;
- end if;
- end Include;
-
- procedure Insert
- (Container : in out Map;
- Key : Key_Type;
- New_Item : Element_Type;
- Position : out Cursor;
- Inserted : out Boolean)
- is
- function New_Node return Node_Access;
- -- Comment ???
-
- procedure Insert_Post is
- new Key_Ops.Generic_Insert_Post (New_Node);
-
- procedure Insert_Sans_Hint is
- new Key_Ops.Generic_Conditional_Insert (Insert_Post);
-
- --------------
- -- New_Node --
- --------------
-
- function New_Node return Node_Access is
- procedure Initialize (Node : in out Node_Type);
- procedure Allocate_Node is new Generic_Allocate (Initialize);
-
- procedure Initialize (Node : in out Node_Type) is
- begin
- Node.Key := Key;
- Node.Element := New_Item;
- end Initialize;
-
- X : Node_Access;
-
- begin
- Allocate_Node (Container.Content, X);
- return X;
- end New_Node;
-
- -- Start of processing for Insert
-
- begin
- Insert_Sans_Hint
- (Container.Content,
- Key,
- Position.Node,
- Inserted);
- end Insert;
-
- procedure Insert
- (Container : in out Map;
- Key : Key_Type;
- New_Item : Element_Type)
- is
- Position : Cursor;
- Inserted : Boolean;
-
- begin
- Insert (Container, Key, New_Item, Position, Inserted);
-
- if not Inserted then
- raise Constraint_Error with "key already in map";
- end if;
- end Insert;
-
- --------------
- -- Is_Empty --
- --------------
-
- function Is_Empty (Container : Map) return Boolean is
- begin
- return Length (Container) = 0;
- end Is_Empty;
-
- -------------------------
- -- Is_Greater_Key_Node --
- -------------------------
-
- function Is_Greater_Key_Node
- (Left : Key_Type;
- Right : Node_Type) return Boolean
- is
- begin
- -- k > node same as node < k
-
- return Right.Key < Left;
- end Is_Greater_Key_Node;
-
- ----------------------
- -- Is_Less_Key_Node --
- ----------------------
-
- function Is_Less_Key_Node
- (Left : Key_Type;
- Right : Node_Type) return Boolean
- is
- begin
- return Left < Right.Key;
- end Is_Less_Key_Node;
-
- ---------
- -- Key --
- ---------
-
- function Key (Container : Map; Position : Cursor) return Key_Type is
- begin
- if not Has_Element (Container, Position) then
- raise Constraint_Error with
- "Position cursor of function Key has no element";
- end if;
-
- pragma Assert (Vet (Container.Content, Position.Node),
- "Position cursor of function Key is bad");
-
- return Container.Content.Nodes (Position.Node).Key;
- end Key;
-
- ----------
- -- Last --
- ----------
-
- function Last (Container : Map) return Cursor is
- begin
- if Length (Container) = 0 then
- return No_Element;
- end if;
-
- return (Node => Container.Content.Last);
- end Last;
-
- ------------------
- -- Last_Element --
- ------------------
-
- function Last_Element (Container : Map) return Element_Type is
- begin
- if Is_Empty (Container) then
- raise Constraint_Error with "map is empty";
- end if;
-
- return Container.Content.Nodes (Last (Container).Node).Element;
- end Last_Element;
-
- --------------
- -- Last_Key --
- --------------
-
- function Last_Key (Container : Map) return Key_Type is
- begin
- if Is_Empty (Container) then
- raise Constraint_Error with "map is empty";
- end if;
-
- return Container.Content.Nodes (Last (Container).Node).Key;
- end Last_Key;
-
- --------------
- -- Left_Son --
- --------------
-
- function Left_Son (Node : Node_Type) return Count_Type is
- begin
- return Node.Left;
- end Left_Son;
-
- ------------
- -- Length --
- ------------
-
- function Length (Container : Map) return Count_Type is
- begin
- return Container.Content.Length;
- end Length;
-
- ----------
- -- Move --
- ----------
-
- procedure Move (Target : in out Map; Source : in out Map) is
- NN : Tree_Types.Nodes_Type renames Source.Content.Nodes;
- X : Node_Access;
-
- begin
- if Target'Address = Source'Address then
- return;
- end if;
-
- if Target.Capacity < Length (Source) then
- raise Constraint_Error with -- ???
- "Source length exceeds Target capacity";
- end if;
-
- Clear (Target);
-
- loop
- X := First (Source).Node;
- exit when X = 0;
-
- -- Here we insert a copy of the source element into the target, and
- -- then delete the element from the source. Another possibility is
- -- that delete it first (and hang onto its index), then insert it.
- -- ???
-
- Insert (Target, NN (X).Key, NN (X).Element); -- optimize???
-
- Tree_Operations.Delete_Node_Sans_Free (Source.Content, X);
- Formal_Ordered_Maps.Free (Source, X);
- end loop;
- end Move;
-
- ----------
- -- Next --
- ----------
-
- procedure Next (Container : Map; Position : in out Cursor) is
- begin
- Position := Next (Container, Position);
- end Next;
-
- function Next (Container : Map; Position : Cursor) return Cursor is
- begin
- if Position = No_Element then
- return No_Element;
- end if;
-
- if not Has_Element (Container, Position) then
- raise Constraint_Error;
- end if;
-
- pragma Assert (Vet (Container.Content, Position.Node),
- "bad cursor in Next");
-
- return (Node => Tree_Operations.Next (Container.Content, Position.Node));
- end Next;
-
- ------------
- -- Parent --
- ------------
-
- function Parent (Node : Node_Type) return Count_Type is
- begin
- return Node.Parent;
- end Parent;
-
- --------------
- -- Previous --
- --------------
-
- procedure Previous (Container : Map; Position : in out Cursor) is
- begin
- Position := Previous (Container, Position);
- end Previous;
-
- function Previous (Container : Map; Position : Cursor) return Cursor is
- begin
- if Position = No_Element then
- return No_Element;
- end if;
-
- if not Has_Element (Container, Position) then
- raise Constraint_Error;
- end if;
-
- pragma Assert (Vet (Container.Content, Position.Node),
- "bad cursor in Previous");
-
- declare
- Node : constant Count_Type :=
- Tree_Operations.Previous (Container.Content, Position.Node);
-
- begin
- if Node = 0 then
- return No_Element;
- end if;
-
- return (Node => Node);
- end;
- end Previous;
-
- --------------
- -- Reference --
- --------------
-
- function Reference
- (Container : not null access Map;
- Position : Cursor) return not null access Element_Type
- is
- begin
- if not Has_Element (Container.all, Position) then
- raise Constraint_Error with "Position cursor has no element";
- end if;
-
- pragma Assert
- (Vet (Container.Content, Position.Node),
- "bad cursor in function Reference");
-
- return Container.Content.Nodes (Position.Node).Element'Access;
- end Reference;
-
- function Reference
- (Container : not null access Map;
- Key : Key_Type) return not null access Element_Type
- is
- Node : constant Count_Type := Find (Container.all, Key).Node;
-
- begin
- if Node = 0 then
- raise Constraint_Error with
- "no element available because key not in map";
- end if;
-
- return Container.Content.Nodes (Node).Element'Access;
- end Reference;
-
- -------------
- -- Replace --
- -------------
-
- procedure Replace
- (Container : in out Map;
- Key : Key_Type;
- New_Item : Element_Type)
- is
- begin
- declare
- Node : constant Node_Access := Key_Ops.Find (Container.Content, Key);
-
- begin
- if Node = 0 then
- raise Constraint_Error with "key not in map";
- end if;
-
- declare
- N : Node_Type renames Container.Content.Nodes (Node);
- begin
- N.Key := Key;
- N.Element := New_Item;
- end;
- end;
- end Replace;
-
- ---------------------
- -- Replace_Element --
- ---------------------
-
- procedure Replace_Element
- (Container : in out Map;
- Position : Cursor;
- New_Item : Element_Type)
- is
- begin
- if not Has_Element (Container, Position) then
- raise Constraint_Error with
- "Position cursor of Replace_Element has no element";
- end if;
-
- pragma Assert (Vet (Container.Content, Position.Node),
- "Position cursor of Replace_Element is bad");
-
- Container.Content.Nodes (Position.Node).Element := New_Item;
- end Replace_Element;
-
- ---------------
- -- Right_Son --
- ---------------
-
- function Right_Son (Node : Node_Type) return Count_Type is
- begin
- return Node.Right;
- end Right_Son;
-
- ---------------
- -- Set_Color --
- ---------------
-
- procedure Set_Color (Node : in out Node_Type; Color : Color_Type) is
- begin
- Node.Color := Color;
- end Set_Color;
-
- --------------
- -- Set_Left --
- --------------
-
- procedure Set_Left (Node : in out Node_Type; Left : Count_Type) is
- begin
- Node.Left := Left;
- end Set_Left;
-
- ----------------
- -- Set_Parent --
- ----------------
-
- procedure Set_Parent (Node : in out Node_Type; Parent : Count_Type) is
- begin
- Node.Parent := Parent;
- end Set_Parent;
-
- ---------------
- -- Set_Right --
- ---------------
-
- procedure Set_Right (Node : in out Node_Type; Right : Count_Type) is
- begin
- Node.Right := Right;
- end Set_Right;
-
-end Ada.Containers.Formal_Ordered_Maps;
diff --git a/gcc/ada/libgnat/a-cforma.ads b/gcc/ada/libgnat/a-cforma.ads
index 7be2eec..21a5d78 100644
--- a/gcc/ada/libgnat/a-cforma.ads
+++ b/gcc/ada/libgnat/a-cforma.ads
@@ -29,1124 +29,12 @@
-- <http://www.gnu.org/licenses/>. --
------------------------------------------------------------------------------
--- This spec is derived from package Ada.Containers.Bounded_Ordered_Maps in
--- the Ada 2012 RM. The modifications are meant to facilitate formal proofs by
--- making it easier to express properties, and by making the specification of
--- this unit compatible with SPARK 2014. Note that the API of this unit may be
--- subject to incompatible changes as SPARK 2014 evolves.
-
--- The modifications are:
-
--- A parameter for the container is added to every function reading the
--- content of a container: Key, Element, Next, Query_Element, Previous,
--- Has_Element, Iterate, Reverse_Iterate. This change is motivated by the
--- need to have cursors which are valid on different containers (typically a
--- container C and its previous version C'Old) for expressing properties,
--- which is not possible if cursors encapsulate an access to the underlying
--- container. The operators "<" and ">" that could not be modified that way
--- have been removed.
-
--- Iteration over maps is done using the Iterable aspect, which is SPARK
--- compatible. "For of" iteration ranges over keys instead of elements.
-
-with Ada.Containers.Functional_Vectors;
-with Ada.Containers.Functional_Maps;
-private with Ada.Containers.Red_Black_Trees;
-
generic
- type Key_Type is private;
- type Element_Type is private;
-
- with function "<" (Left, Right : Key_Type) return Boolean is <>;
- with function "=" (Left, Right : Element_Type) return Boolean is <>;
-
-package Ada.Containers.Formal_Ordered_Maps with
- SPARK_Mode,
- Annotate => (GNATprove, Always_Return)
-is
-
- -- Contracts in this unit are meant for analysis only, not for run-time
- -- checking.
-
- pragma Assertion_Policy (Pre => Ignore);
- pragma Assertion_Policy (Post => Ignore);
- pragma Assertion_Policy (Contract_Cases => Ignore);
- pragma Annotate (CodePeer, Skip_Analysis);
-
- function Equivalent_Keys (Left, Right : Key_Type) return Boolean with
- Global => null,
- Post =>
- Equivalent_Keys'Result = (not (Left < Right) and not (Right < Left));
- pragma Annotate (GNATprove, Inline_For_Proof, Equivalent_Keys);
-
- type Map (Capacity : Count_Type) is private with
- Iterable => (First => First,
- Next => Next,
- Has_Element => Has_Element,
- Element => Key),
- Default_Initial_Condition => Is_Empty (Map);
- pragma Preelaborable_Initialization (Map);
-
- type Cursor is record
- Node : Count_Type;
- end record;
-
- No_Element : constant Cursor := (Node => 0);
-
- Empty_Map : constant Map;
-
- function Length (Container : Map) return Count_Type with
- Global => null,
- Post => Length'Result <= Container.Capacity;
-
- pragma Unevaluated_Use_Of_Old (Allow);
-
- package Formal_Model with Ghost is
- subtype Positive_Count_Type is Count_Type range 1 .. Count_Type'Last;
-
- package M is new Ada.Containers.Functional_Maps
- (Element_Type => Element_Type,
- Key_Type => Key_Type,
- Equivalent_Keys => Equivalent_Keys);
-
- function "="
- (Left : M.Map;
- Right : M.Map) return Boolean renames M."=";
-
- function "<="
- (Left : M.Map;
- Right : M.Map) return Boolean renames M."<=";
-
- package K is new Ada.Containers.Functional_Vectors
- (Element_Type => Key_Type,
- Index_Type => Positive_Count_Type);
-
- function "="
- (Left : K.Sequence;
- Right : K.Sequence) return Boolean renames K."=";
-
- function "<"
- (Left : K.Sequence;
- Right : K.Sequence) return Boolean renames K."<";
-
- function "<="
- (Left : K.Sequence;
- Right : K.Sequence) return Boolean renames K."<=";
-
- function K_Bigger_Than_Range
- (Container : K.Sequence;
- Fst : Positive_Count_Type;
- Lst : Count_Type;
- Key : Key_Type) return Boolean
- with
- Global => null,
- Pre => Lst <= K.Length (Container),
- Post =>
- K_Bigger_Than_Range'Result =
- (for all I in Fst .. Lst => K.Get (Container, I) < Key);
- pragma Annotate (GNATprove, Inline_For_Proof, K_Bigger_Than_Range);
-
- function K_Smaller_Than_Range
- (Container : K.Sequence;
- Fst : Positive_Count_Type;
- Lst : Count_Type;
- Key : Key_Type) return Boolean
- with
- Global => null,
- Pre => Lst <= K.Length (Container),
- Post =>
- K_Smaller_Than_Range'Result =
- (for all I in Fst .. Lst => Key < K.Get (Container, I));
- pragma Annotate (GNATprove, Inline_For_Proof, K_Smaller_Than_Range);
-
- function K_Is_Find
- (Container : K.Sequence;
- Key : Key_Type;
- Position : Count_Type) return Boolean
- with
- Global => null,
- Pre => Position - 1 <= K.Length (Container),
- Post =>
- K_Is_Find'Result =
- ((if Position > 0 then
- K_Bigger_Than_Range (Container, 1, Position - 1, Key))
-
- and
- (if Position < K.Length (Container) then
- K_Smaller_Than_Range
- (Container,
- Position + 1,
- K.Length (Container),
- Key)));
- pragma Annotate (GNATprove, Inline_For_Proof, K_Is_Find);
-
- function Find (Container : K.Sequence; Key : Key_Type) return Count_Type
- -- Search for Key in Container
-
- with
- Global => null,
- Post =>
- (if Find'Result > 0 then
- Find'Result <= K.Length (Container)
- and Equivalent_Keys (Key, K.Get (Container, Find'Result)));
-
- package P is new Ada.Containers.Functional_Maps
- (Key_Type => Cursor,
- Element_Type => Positive_Count_Type,
- Equivalent_Keys => "=",
- Enable_Handling_Of_Equivalence => False);
-
- function "="
- (Left : P.Map;
- Right : P.Map) return Boolean renames P."=";
-
- function "<="
- (Left : P.Map;
- Right : P.Map) return Boolean renames P."<=";
-
- function P_Positions_Shifted
- (Small : P.Map;
- Big : P.Map;
- Cut : Positive_Count_Type;
- Count : Count_Type := 1) return Boolean
- with
- Global => null,
- Post =>
- P_Positions_Shifted'Result =
-
- -- Big contains all cursors of Small
-
- (P.Keys_Included (Small, Big)
-
- -- Cursors located before Cut are not moved, cursors located
- -- after are shifted by Count.
-
- and (for all I of Small =>
- (if P.Get (Small, I) < Cut then
- P.Get (Big, I) = P.Get (Small, I)
- else
- P.Get (Big, I) - Count = P.Get (Small, I)))
-
- -- New cursors of Big (if any) are between Cut and Cut - 1 +
- -- Count.
-
- and (for all I of Big =>
- P.Has_Key (Small, I)
- or P.Get (Big, I) - Count in Cut - Count .. Cut - 1));
-
- function Model (Container : Map) return M.Map with
- -- The high-level model of a map is a map from keys to elements. Neither
- -- cursors nor order of elements are represented in this model. Keys are
- -- modeled up to equivalence.
-
- Ghost,
- Global => null;
-
- function Keys (Container : Map) return K.Sequence with
- -- The Keys sequence represents the underlying list structure of maps
- -- that is used for iteration. It stores the actual values of keys in
- -- the map. It does not model cursors nor elements.
-
- Ghost,
- Global => null,
- Post =>
- K.Length (Keys'Result) = Length (Container)
-
- -- It only contains keys contained in Model
-
- and (for all Key of Keys'Result =>
- M.Has_Key (Model (Container), Key))
-
- -- It contains all the keys contained in Model
-
- and (for all Key of Model (Container) =>
- (Find (Keys'Result, Key) > 0
- and then Equivalent_Keys
- (K.Get (Keys'Result, Find (Keys'Result, Key)),
- Key)))
-
- -- It is sorted in increasing order
-
- and (for all I in 1 .. Length (Container) =>
- Find (Keys'Result, K.Get (Keys'Result, I)) = I
- and K_Is_Find (Keys'Result, K.Get (Keys'Result, I), I));
- pragma Annotate (GNATprove, Iterable_For_Proof, "Model", Keys);
-
- function Positions (Container : Map) return P.Map with
- -- The Positions map is used to model cursors. It only contains valid
- -- cursors and maps them to their position in the container.
-
- Ghost,
- Global => null,
- Post =>
- not P.Has_Key (Positions'Result, No_Element)
-
- -- Positions of cursors are smaller than the container's length.
-
- and then
- (for all I of Positions'Result =>
- P.Get (Positions'Result, I) in 1 .. Length (Container)
-
- -- No two cursors have the same position. Note that we do not
- -- state that there is a cursor in the map for each position, as
- -- it is rarely needed.
-
- and then
- (for all J of Positions'Result =>
- (if P.Get (Positions'Result, I) = P.Get (Positions'Result, J)
- then I = J)));
-
- procedure Lift_Abstraction_Level (Container : Map) with
- -- Lift_Abstraction_Level is a ghost procedure that does nothing but
- -- assume that we can access the same elements by iterating over
- -- positions or cursors.
- -- This information is not generally useful except when switching from
- -- a low-level, cursor-aware view of a container, to a high-level,
- -- position-based view.
-
- Ghost,
- Global => null,
- Post =>
- (for all Key of Keys (Container) =>
- (for some I of Positions (Container) =>
- K.Get (Keys (Container), P.Get (Positions (Container), I)) =
- Key));
-
- function Contains
- (C : M.Map;
- K : Key_Type) return Boolean renames M.Has_Key;
- -- To improve readability of contracts, we rename the function used to
- -- search for a key in the model to Contains.
-
- function Element
- (C : M.Map;
- K : Key_Type) return Element_Type renames M.Get;
- -- To improve readability of contracts, we rename the function used to
- -- access an element in the model to Element.
- end Formal_Model;
- use Formal_Model;
-
- function "=" (Left, Right : Map) return Boolean with
- Global => null,
- Post => "="'Result = (Model (Left) = Model (Right));
-
- function Is_Empty (Container : Map) return Boolean with
- Global => null,
- Post => Is_Empty'Result = (Length (Container) = 0);
-
- procedure Clear (Container : in out Map) with
- Global => null,
- Post => Length (Container) = 0 and M.Is_Empty (Model (Container));
-
- procedure Assign (Target : in out Map; Source : Map) with
- Global => null,
- Pre => Target.Capacity >= Length (Source),
- Post =>
- Model (Target) = Model (Source)
- and Keys (Target) = Keys (Source)
- and Length (Source) = Length (Target);
-
- function Copy (Source : Map; Capacity : Count_Type := 0) return Map with
- Global => null,
- Pre => Capacity = 0 or else Capacity >= Source.Capacity,
- Post =>
- Model (Copy'Result) = Model (Source)
- and Keys (Copy'Result) = Keys (Source)
- and Positions (Copy'Result) = Positions (Source)
- and (if Capacity = 0 then
- Copy'Result.Capacity = Source.Capacity
- else
- Copy'Result.Capacity = Capacity);
-
- function Key (Container : Map; Position : Cursor) return Key_Type with
- Global => null,
- Pre => Has_Element (Container, Position),
- Post =>
- Key'Result =
- K.Get (Keys (Container), P.Get (Positions (Container), Position));
- pragma Annotate (GNATprove, Inline_For_Proof, Key);
-
- function Element
- (Container : Map;
- Position : Cursor) return Element_Type
- with
- Global => null,
- Pre => Has_Element (Container, Position),
- Post =>
- Element'Result = Element (Model (Container), Key (Container, Position));
- pragma Annotate (GNATprove, Inline_For_Proof, Element);
-
- procedure Replace_Element
- (Container : in out Map;
- Position : Cursor;
- New_Item : Element_Type)
- with
- Global => null,
- Pre => Has_Element (Container, Position),
- Post =>
-
- -- Order of keys and cursors is preserved
-
- Keys (Container) = Keys (Container)'Old
- and Positions (Container) = Positions (Container)'Old
-
- -- New_Item is now associated with the key at position Position in
- -- Container.
-
- and Element (Container, Position) = New_Item
-
- -- Elements associated with other keys are preserved
-
- and M.Same_Keys (Model (Container), Model (Container)'Old)
- and M.Elements_Equal_Except
- (Model (Container),
- Model (Container)'Old,
- Key (Container, Position));
-
- function At_End
- (E : not null access constant Map) return not null access constant Map
- is (E)
- with Ghost,
- Annotate => (GNATprove, At_End_Borrow);
-
- function At_End
- (E : access constant Element_Type) return access constant Element_Type
- is (E)
- with Ghost,
- Annotate => (GNATprove, At_End_Borrow);
-
- function Constant_Reference
- (Container : aliased Map;
- Position : Cursor) return not null access constant Element_Type
- with
- Global => null,
- Pre => Has_Element (Container, Position),
- Post =>
- Constant_Reference'Result.all =
- Element (Model (Container), Key (Container, Position));
-
- function Reference
- (Container : not null access Map;
- Position : Cursor) return not null access Element_Type
- with
- Global => null,
- Pre => Has_Element (Container.all, Position),
- Post =>
-
- -- Order of keys and cursors is preserved
-
- Keys (At_End (Container).all) = Keys (Container.all)
- and Positions (At_End (Container).all) = Positions (Container.all)
-
- -- The value designated by the result of Reference is now associated
- -- with the key at position Position in Container.
-
- and Element (At_End (Container).all, Position) =
- At_End (Reference'Result).all
-
- -- Elements associated with other keys are preserved
-
- and M.Same_Keys
- (Model (At_End (Container).all),
- Model (Container.all))
- and M.Elements_Equal_Except
- (Model (At_End (Container).all),
- Model (Container.all),
- Key (At_End (Container).all, Position));
-
- function Constant_Reference
- (Container : aliased Map;
- Key : Key_Type) return not null access constant Element_Type
- with
- Global => null,
- Pre => Contains (Container, Key),
- Post =>
- Constant_Reference'Result.all = Element (Model (Container), Key);
-
- function Reference
- (Container : not null access Map;
- Key : Key_Type) return not null access Element_Type
- with
- Global => null,
- Pre => Contains (Container.all, Key),
- Post =>
-
- -- Order of keys and cursors is preserved
-
- Keys (At_End (Container).all) = Keys (Container.all)
- and Positions (At_End (Container).all) = Positions (Container.all)
-
- -- The value designated by the result of Reference is now associated
- -- with Key in Container.
-
- and Element (Model (At_End (Container).all), Key) =
- At_End (Reference'Result).all
-
- -- Elements associated with other keys are preserved
-
- and M.Same_Keys
- (Model (At_End (Container).all),
- Model (Container.all))
- and M.Elements_Equal_Except
- (Model (At_End (Container).all),
- Model (Container.all),
- Key);
-
- procedure Move (Target : in out Map; Source : in out Map) with
- Global => null,
- Pre => Target.Capacity >= Length (Source),
- Post =>
- Model (Target) = Model (Source)'Old
- and Keys (Target) = Keys (Source)'Old
- and Length (Source)'Old = Length (Target)
- and Length (Source) = 0;
-
- procedure Insert
- (Container : in out Map;
- Key : Key_Type;
- New_Item : Element_Type;
- Position : out Cursor;
- Inserted : out Boolean)
- with
- Global => null,
- Pre =>
- Length (Container) < Container.Capacity or Contains (Container, Key),
- Post =>
- Contains (Container, Key)
- and Has_Element (Container, Position)
- and Equivalent_Keys
- (Formal_Ordered_Maps.Key (Container, Position), Key)
- and K_Is_Find
- (Keys (Container),
- Key,
- P.Get (Positions (Container), Position)),
- Contract_Cases =>
-
- -- If Key is already in Container, it is not modified and Inserted is
- -- set to False.
-
- (Contains (Container, Key) =>
- not Inserted
- and Model (Container) = Model (Container)'Old
- and Keys (Container) = Keys (Container)'Old
- and Positions (Container) = Positions (Container)'Old,
-
- -- Otherwise, Key is inserted in Container and Inserted is set to True
-
- others =>
- Inserted
- and Length (Container) = Length (Container)'Old + 1
-
- -- Key now maps to New_Item
-
- and Formal_Ordered_Maps.Key (Container, Position) = Key
- and Element (Model (Container), Key) = New_Item
-
- -- Other mappings are preserved
-
- and Model (Container)'Old <= Model (Container)
- and M.Keys_Included_Except
- (Model (Container),
- Model (Container)'Old,
- Key)
-
- -- The keys of Container located before Position are preserved
-
- and K.Range_Equal
- (Left => Keys (Container)'Old,
- Right => Keys (Container),
- Fst => 1,
- Lst => P.Get (Positions (Container), Position) - 1)
-
- -- Other keys are shifted by 1
-
- and K.Range_Shifted
- (Left => Keys (Container)'Old,
- Right => Keys (Container),
- Fst => P.Get (Positions (Container), Position),
- Lst => Length (Container)'Old,
- Offset => 1)
-
- -- A new cursor has been inserted at position Position in
- -- Container.
-
- and P_Positions_Shifted
- (Positions (Container)'Old,
- Positions (Container),
- Cut => P.Get (Positions (Container), Position)));
-
- procedure Insert
- (Container : in out Map;
- Key : Key_Type;
- New_Item : Element_Type)
- with
- Global => null,
- Pre =>
- Length (Container) < Container.Capacity
- and then (not Contains (Container, Key)),
- Post =>
- Length (Container) = Length (Container)'Old + 1
- and Contains (Container, Key)
-
- -- Key now maps to New_Item
-
- and K.Get (Keys (Container), Find (Keys (Container), Key)) = Key
- and Element (Model (Container), Key) = New_Item
-
- -- Other mappings are preserved
-
- and Model (Container)'Old <= Model (Container)
- and M.Keys_Included_Except
- (Model (Container),
- Model (Container)'Old,
- Key)
-
- -- The keys of Container located before Key are preserved
-
- and K.Range_Equal
- (Left => Keys (Container)'Old,
- Right => Keys (Container),
- Fst => 1,
- Lst => Find (Keys (Container), Key) - 1)
-
- -- Other keys are shifted by 1
-
- and K.Range_Shifted
- (Left => Keys (Container)'Old,
- Right => Keys (Container),
- Fst => Find (Keys (Container), Key),
- Lst => Length (Container)'Old,
- Offset => 1)
-
- -- A new cursor has been inserted in Container
-
- and P_Positions_Shifted
- (Positions (Container)'Old,
- Positions (Container),
- Cut => Find (Keys (Container), Key));
-
- procedure Include
- (Container : in out Map;
- Key : Key_Type;
- New_Item : Element_Type)
- with
- Global => null,
- Pre =>
- Length (Container) < Container.Capacity or Contains (Container, Key),
- Post =>
- Contains (Container, Key) and Element (Container, Key) = New_Item,
- Contract_Cases =>
-
- -- If Key is already in Container, Key is mapped to New_Item
-
- (Contains (Container, Key) =>
-
- -- Cursors are preserved
-
- Positions (Container) = Positions (Container)'Old
-
- -- The key equivalent to Key in Container is replaced by Key
-
- and K.Get
- (Keys (Container), Find (Keys (Container), Key)) = Key
-
- and K.Equal_Except
- (Keys (Container)'Old,
- Keys (Container),
- Find (Keys (Container), Key))
-
- -- Elements associated with other keys are preserved
-
- and M.Same_Keys (Model (Container), Model (Container)'Old)
- and M.Elements_Equal_Except
- (Model (Container),
- Model (Container)'Old,
- Key),
-
- -- Otherwise, Key is inserted in Container
-
- others =>
- Length (Container) = Length (Container)'Old + 1
-
- -- Other mappings are preserved
-
- and Model (Container)'Old <= Model (Container)
- and M.Keys_Included_Except
- (Model (Container),
- Model (Container)'Old,
- Key)
-
- -- Key is inserted in Container
-
- and K.Get
- (Keys (Container), Find (Keys (Container), Key)) = Key
-
- -- The keys of Container located before Key are preserved
-
- and K.Range_Equal
- (Left => Keys (Container)'Old,
- Right => Keys (Container),
- Fst => 1,
- Lst => Find (Keys (Container), Key) - 1)
-
- -- Other keys are shifted by 1
-
- and K.Range_Shifted
- (Left => Keys (Container)'Old,
- Right => Keys (Container),
- Fst => Find (Keys (Container), Key),
- Lst => Length (Container)'Old,
- Offset => 1)
-
- -- A new cursor has been inserted in Container
-
- and P_Positions_Shifted
- (Positions (Container)'Old,
- Positions (Container),
- Cut => Find (Keys (Container), Key)));
-
- procedure Replace
- (Container : in out Map;
- Key : Key_Type;
- New_Item : Element_Type)
- with
- Global => null,
- Pre => Contains (Container, Key),
- Post =>
-
- -- Cursors are preserved
-
- Positions (Container) = Positions (Container)'Old
-
- -- The key equivalent to Key in Container is replaced by Key
-
- and K.Get (Keys (Container), Find (Keys (Container), Key)) = Key
- and K.Equal_Except
- (Keys (Container)'Old,
- Keys (Container),
- Find (Keys (Container), Key))
-
- -- New_Item is now associated with the Key in Container
-
- and Element (Model (Container), Key) = New_Item
-
- -- Elements associated with other keys are preserved
-
- and M.Same_Keys (Model (Container), Model (Container)'Old)
- and M.Elements_Equal_Except
- (Model (Container),
- Model (Container)'Old,
- Key);
-
- procedure Exclude (Container : in out Map; Key : Key_Type) with
- Global => null,
- Post => not Contains (Container, Key),
- Contract_Cases =>
-
- -- If Key is not in Container, nothing is changed
-
- (not Contains (Container, Key) =>
- Model (Container) = Model (Container)'Old
- and Keys (Container) = Keys (Container)'Old
- and Positions (Container) = Positions (Container)'Old,
-
- -- Otherwise, Key is removed from Container
-
- others =>
- Length (Container) = Length (Container)'Old - 1
-
- -- Other mappings are preserved
-
- and Model (Container) <= Model (Container)'Old
- and M.Keys_Included_Except
- (Model (Container)'Old,
- Model (Container),
- Key)
-
- -- The keys of Container located before Key are preserved
-
- and K.Range_Equal
- (Left => Keys (Container)'Old,
- Right => Keys (Container),
- Fst => 1,
- Lst => Find (Keys (Container), Key)'Old - 1)
-
- -- The keys located after Key are shifted by 1
-
- and K.Range_Shifted
- (Left => Keys (Container),
- Right => Keys (Container)'Old,
- Fst => Find (Keys (Container), Key)'Old,
- Lst => Length (Container),
- Offset => 1)
-
- -- A cursor has been removed from Container
-
- and P_Positions_Shifted
- (Positions (Container),
- Positions (Container)'Old,
- Cut => Find (Keys (Container), Key)'Old));
-
- procedure Delete (Container : in out Map; Key : Key_Type) with
- Global => null,
- Pre => Contains (Container, Key),
- Post =>
- Length (Container) = Length (Container)'Old - 1
-
- -- Key is no longer in Container
-
- and not Contains (Container, Key)
-
- -- Other mappings are preserved
-
- and Model (Container) <= Model (Container)'Old
- and M.Keys_Included_Except
- (Model (Container)'Old,
- Model (Container),
- Key)
-
- -- The keys of Container located before Key are preserved
-
- and K.Range_Equal
- (Left => Keys (Container)'Old,
- Right => Keys (Container),
- Fst => 1,
- Lst => Find (Keys (Container), Key)'Old - 1)
-
- -- The keys located after Key are shifted by 1
-
- and K.Range_Shifted
- (Left => Keys (Container),
- Right => Keys (Container)'Old,
- Fst => Find (Keys (Container), Key)'Old,
- Lst => Length (Container),
- Offset => 1)
-
- -- A cursor has been removed from Container
-
- and P_Positions_Shifted
- (Positions (Container),
- Positions (Container)'Old,
- Cut => Find (Keys (Container), Key)'Old);
-
- procedure Delete (Container : in out Map; Position : in out Cursor) with
- Global => null,
- Depends => (Container =>+ Position, Position => null),
- Pre => Has_Element (Container, Position),
- Post =>
- Position = No_Element
- and Length (Container) = Length (Container)'Old - 1
-
- -- The key at position Position is no longer in Container
-
- and not Contains (Container, Key (Container, Position)'Old)
- and not P.Has_Key (Positions (Container), Position'Old)
-
- -- Other mappings are preserved
-
- and Model (Container) <= Model (Container)'Old
- and M.Keys_Included_Except
- (Model (Container)'Old,
- Model (Container),
- Key (Container, Position)'Old)
-
- -- The keys of Container located before Position are preserved.
-
- and K.Range_Equal
- (Left => Keys (Container)'Old,
- Right => Keys (Container),
- Fst => 1,
- Lst => P.Get (Positions (Container)'Old, Position'Old) - 1)
-
- -- The keys located after Position are shifted by 1
-
- and K.Range_Shifted
- (Left => Keys (Container),
- Right => Keys (Container)'Old,
- Fst => P.Get (Positions (Container)'Old, Position'Old),
- Lst => Length (Container),
- Offset => 1)
-
- -- Position has been removed from Container
-
- and P_Positions_Shifted
- (Positions (Container),
- Positions (Container)'Old,
- Cut => P.Get (Positions (Container)'Old, Position'Old));
-
- procedure Delete_First (Container : in out Map) with
- Global => null,
- Contract_Cases =>
- (Length (Container) = 0 => Length (Container) = 0,
- others =>
- Length (Container) = Length (Container)'Old - 1
-
- -- The first key has been removed from Container
-
- and not Contains (Container, First_Key (Container)'Old)
-
- -- Other mappings are preserved
-
- and Model (Container) <= Model (Container)'Old
- and M.Keys_Included_Except
- (Model (Container)'Old,
- Model (Container),
- First_Key (Container)'Old)
-
- -- Other keys are shifted by 1
-
- and K.Range_Shifted
- (Left => Keys (Container),
- Right => Keys (Container)'Old,
- Fst => 1,
- Lst => Length (Container),
- Offset => 1)
-
- -- First has been removed from Container
-
- and P_Positions_Shifted
- (Positions (Container),
- Positions (Container)'Old,
- Cut => 1));
-
- procedure Delete_Last (Container : in out Map) with
- Global => null,
- Contract_Cases =>
- (Length (Container) = 0 => Length (Container) = 0,
- others =>
- Length (Container) = Length (Container)'Old - 1
-
- -- The last key has been removed from Container
-
- and not Contains (Container, Last_Key (Container)'Old)
-
- -- Other mappings are preserved
-
- and Model (Container) <= Model (Container)'Old
- and M.Keys_Included_Except
- (Model (Container)'Old,
- Model (Container),
- Last_Key (Container)'Old)
-
- -- Others keys of Container are preserved
-
- and K.Range_Equal
- (Left => Keys (Container)'Old,
- Right => Keys (Container),
- Fst => 1,
- Lst => Length (Container))
-
- -- Last cursor has been removed from Container
-
- and Positions (Container) <= Positions (Container)'Old);
-
- function First (Container : Map) return Cursor with
- Global => null,
- Contract_Cases =>
- (Length (Container) = 0 =>
- First'Result = No_Element,
-
- others =>
- Has_Element (Container, First'Result)
- and P.Get (Positions (Container), First'Result) = 1);
-
- function First_Element (Container : Map) return Element_Type with
- Global => null,
- Pre => not Is_Empty (Container),
- Post =>
- First_Element'Result =
- Element (Model (Container), First_Key (Container));
-
- function First_Key (Container : Map) return Key_Type with
- Global => null,
- Pre => not Is_Empty (Container),
- Post =>
- First_Key'Result = K.Get (Keys (Container), 1)
- and K_Smaller_Than_Range
- (Keys (Container), 2, Length (Container), First_Key'Result);
-
- function Last (Container : Map) return Cursor with
- Global => null,
- Contract_Cases =>
- (Length (Container) = 0 =>
- Last'Result = No_Element,
-
- others =>
- Has_Element (Container, Last'Result)
- and P.Get (Positions (Container), Last'Result) =
- Length (Container));
-
- function Last_Element (Container : Map) return Element_Type with
- Global => null,
- Pre => not Is_Empty (Container),
- Post =>
- Last_Element'Result = Element (Model (Container), Last_Key (Container));
-
- function Last_Key (Container : Map) return Key_Type with
- Global => null,
- Pre => not Is_Empty (Container),
- Post =>
- Last_Key'Result = K.Get (Keys (Container), Length (Container))
- and K_Bigger_Than_Range
- (Keys (Container), 1, Length (Container) - 1, Last_Key'Result);
-
- function Next (Container : Map; Position : Cursor) return Cursor with
- Global => null,
- Pre =>
- Has_Element (Container, Position) or else Position = No_Element,
- Contract_Cases =>
- (Position = No_Element
- or else P.Get (Positions (Container), Position) = Length (Container)
- =>
- Next'Result = No_Element,
-
- others =>
- Has_Element (Container, Next'Result)
- and then P.Get (Positions (Container), Next'Result) =
- P.Get (Positions (Container), Position) + 1);
-
- procedure Next (Container : Map; Position : in out Cursor) with
- Global => null,
- Pre =>
- Has_Element (Container, Position) or else Position = No_Element,
- Contract_Cases =>
- (Position = No_Element
- or else P.Get (Positions (Container), Position) = Length (Container)
- =>
- Position = No_Element,
-
- others =>
- Has_Element (Container, Position)
- and then P.Get (Positions (Container), Position) =
- P.Get (Positions (Container), Position'Old) + 1);
-
- function Previous (Container : Map; Position : Cursor) return Cursor with
- Global => null,
- Pre =>
- Has_Element (Container, Position) or else Position = No_Element,
- Contract_Cases =>
- (Position = No_Element
- or else P.Get (Positions (Container), Position) = 1
- =>
- Previous'Result = No_Element,
-
- others =>
- Has_Element (Container, Previous'Result)
- and then P.Get (Positions (Container), Previous'Result) =
- P.Get (Positions (Container), Position) - 1);
-
- procedure Previous (Container : Map; Position : in out Cursor) with
- Global => null,
- Pre =>
- Has_Element (Container, Position) or else Position = No_Element,
- Contract_Cases =>
- (Position = No_Element
- or else P.Get (Positions (Container), Position) = 1
- =>
- Position = No_Element,
-
- others =>
- Has_Element (Container, Position)
- and then P.Get (Positions (Container), Position) =
- P.Get (Positions (Container), Position'Old) - 1);
-
- function Find (Container : Map; Key : Key_Type) return Cursor with
- Global => null,
- Contract_Cases =>
-
- -- If Key is not contained in Container, Find returns No_Element
-
- (not Contains (Model (Container), Key) =>
- not P.Has_Key (Positions (Container), Find'Result)
- and Find'Result = No_Element,
-
- -- Otherwise, Find returns a valid cursor in Container
-
- others =>
- P.Has_Key (Positions (Container), Find'Result)
- and P.Get (Positions (Container), Find'Result) =
- Find (Keys (Container), Key)
-
- -- The key designated by the result of Find is Key
-
- and Equivalent_Keys
- (Formal_Ordered_Maps.Key (Container, Find'Result), Key));
-
- function Element (Container : Map; Key : Key_Type) return Element_Type with
- Global => null,
- Pre => Contains (Container, Key),
- Post => Element'Result = Element (Model (Container), Key);
- pragma Annotate (GNATprove, Inline_For_Proof, Element);
-
- function Floor (Container : Map; Key : Key_Type) return Cursor with
- Global => null,
- Contract_Cases =>
- (Length (Container) = 0 or else Key < First_Key (Container) =>
- Floor'Result = No_Element,
-
- others =>
- Has_Element (Container, Floor'Result)
- and not (Key < K.Get (Keys (Container),
- P.Get (Positions (Container), Floor'Result)))
- and K_Is_Find
- (Keys (Container),
- Key,
- P.Get (Positions (Container), Floor'Result)));
-
- function Ceiling (Container : Map; Key : Key_Type) return Cursor with
- Global => null,
- Contract_Cases =>
- (Length (Container) = 0 or else Last_Key (Container) < Key =>
- Ceiling'Result = No_Element,
- others =>
- Has_Element (Container, Ceiling'Result)
- and not (K.Get
- (Keys (Container),
- P.Get (Positions (Container), Ceiling'Result)) < Key)
- and K_Is_Find
- (Keys (Container),
- Key,
- P.Get (Positions (Container), Ceiling'Result)));
-
- function Contains (Container : Map; Key : Key_Type) return Boolean with
- Global => null,
- Post => Contains'Result = Contains (Model (Container), Key);
- pragma Annotate (GNATprove, Inline_For_Proof, Contains);
-
- function Has_Element (Container : Map; Position : Cursor) return Boolean
- with
- Global => null,
- Post =>
- Has_Element'Result = P.Has_Key (Positions (Container), Position);
- pragma Annotate (GNATprove, Inline_For_Proof, Has_Element);
-
-private
- pragma SPARK_Mode (Off);
-
- pragma Inline (Next);
- pragma Inline (Previous);
-
- subtype Node_Access is Count_Type;
-
- use Red_Black_Trees;
-
- type Node_Type is record
- Has_Element : Boolean := False;
- Parent : Node_Access := 0;
- Left : Node_Access := 0;
- Right : Node_Access := 0;
- Color : Red_Black_Trees.Color_Type := Red;
- Key : Key_Type;
- Element : aliased Element_Type;
- end record;
-
- package Tree_Types is
- new Ada.Containers.Red_Black_Trees.Generic_Bounded_Tree_Types (Node_Type);
-
- type Map (Capacity : Count_Type) is record
- Content : Tree_Types.Tree_Type (Capacity);
- end record;
+package Ada.Containers.Formal_Ordered_Maps with SPARK_Mode is
- Empty_Map : constant Map := (Capacity => 0, others => <>);
+ pragma Compile_Time_Error
+ (True,
+ "This package has been moved to the SPARK library shipped with any"
+ & " SPARK release starting with version 23.");
end Ada.Containers.Formal_Ordered_Maps;
diff --git a/gcc/ada/libgnat/a-cforse.adb b/gcc/ada/libgnat/a-cforse.adb
deleted file mode 100644
index e5cddde..0000000
--- a/gcc/ada/libgnat/a-cforse.adb
+++ /dev/null
@@ -1,1939 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT LIBRARY COMPONENTS --
--- --
--- A D A . C O N T A I N E R S . F O R M A L _ O R D E R E D _ S E T S --
--- --
--- B o d y --
--- --
--- Copyright (C) 2010-2022, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
-------------------------------------------------------------------------------
-
-with Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations;
-pragma Elaborate_All
- (Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations);
-
-with Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys;
-pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys);
-
-with Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations;
-pragma Elaborate_All
- (Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations);
-
-with System; use type System.Address;
-
-package body Ada.Containers.Formal_Ordered_Sets with
- SPARK_Mode => Off
-is
-
- ------------------------------
- -- Access to Fields of Node --
- ------------------------------
-
- -- These subprograms provide functional notation for access to fields
- -- of a node, and procedural notation for modifiying these fields.
-
- function Color (Node : Node_Type) return Red_Black_Trees.Color_Type;
- pragma Inline (Color);
-
- function Left_Son (Node : Node_Type) return Count_Type;
- pragma Inline (Left_Son);
-
- function Parent (Node : Node_Type) return Count_Type;
- pragma Inline (Parent);
-
- function Right_Son (Node : Node_Type) return Count_Type;
- pragma Inline (Right_Son);
-
- procedure Set_Color
- (Node : in out Node_Type;
- Color : Red_Black_Trees.Color_Type);
- pragma Inline (Set_Color);
-
- procedure Set_Left (Node : in out Node_Type; Left : Count_Type);
- pragma Inline (Set_Left);
-
- procedure Set_Right (Node : in out Node_Type; Right : Count_Type);
- pragma Inline (Set_Right);
-
- procedure Set_Parent (Node : in out Node_Type; Parent : Count_Type);
- pragma Inline (Set_Parent);
-
- -----------------------
- -- Local Subprograms --
- -----------------------
-
- -- Comments needed???
-
- procedure Assign
- (Target : in out Tree_Types.Tree_Type;
- Source : Tree_Types.Tree_Type);
-
- generic
- with procedure Set_Element (Node : in out Node_Type);
- procedure Generic_Allocate
- (Tree : in out Tree_Types.Tree_Type'Class;
- Node : out Count_Type);
-
- procedure Free (Tree : in out Set; X : Count_Type);
-
- procedure Insert_Sans_Hint
- (Container : in out Tree_Types.Tree_Type;
- New_Item : Element_Type;
- Node : out Count_Type;
- Inserted : out Boolean);
-
- procedure Insert_With_Hint
- (Dst_Set : in out Tree_Types.Tree_Type;
- Dst_Hint : Count_Type;
- Src_Node : Node_Type;
- Dst_Node : out Count_Type);
-
- function Is_Greater_Element_Node
- (Left : Element_Type;
- Right : Node_Type) return Boolean;
- pragma Inline (Is_Greater_Element_Node);
-
- function Is_Less_Element_Node
- (Left : Element_Type;
- Right : Node_Type) return Boolean;
- pragma Inline (Is_Less_Element_Node);
-
- function Is_Less_Node_Node (L, R : Node_Type) return Boolean;
- pragma Inline (Is_Less_Node_Node);
-
- procedure Replace_Element
- (Tree : in out Set;
- Node : Count_Type;
- Item : Element_Type);
-
- --------------------------
- -- Local Instantiations --
- --------------------------
-
- package Tree_Operations is
- new Red_Black_Trees.Generic_Bounded_Operations
- (Tree_Types,
- Left => Left_Son,
- Right => Right_Son);
-
- use Tree_Operations;
-
- package Element_Keys is
- new Red_Black_Trees.Generic_Bounded_Keys
- (Tree_Operations => Tree_Operations,
- Key_Type => Element_Type,
- Is_Less_Key_Node => Is_Less_Element_Node,
- Is_Greater_Key_Node => Is_Greater_Element_Node);
-
- package Set_Ops is
- new Red_Black_Trees.Generic_Bounded_Set_Operations
- (Tree_Operations => Tree_Operations,
- Set_Type => Tree_Types.Tree_Type,
- Assign => Assign,
- Insert_With_Hint => Insert_With_Hint,
- Is_Less => Is_Less_Node_Node);
-
- ---------
- -- "=" --
- ---------
-
- function "=" (Left, Right : Set) return Boolean is
- Lst : Count_Type;
- Node : Count_Type;
- ENode : Count_Type;
-
- begin
- if Length (Left) /= Length (Right) then
- return False;
- end if;
-
- if Is_Empty (Left) then
- return True;
- end if;
-
- Lst := Next (Left.Content, Last (Left).Node);
-
- Node := First (Left).Node;
- while Node /= Lst loop
- ENode := Find (Right, Left.Content.Nodes (Node).Element).Node;
- if ENode = 0
- or else Left.Content.Nodes (Node).Element /=
- Right.Content.Nodes (ENode).Element
- then
- return False;
- end if;
-
- Node := Next (Left.Content, Node);
- end loop;
-
- return True;
- end "=";
-
- ------------
- -- Assign --
- ------------
-
- procedure Assign
- (Target : in out Tree_Types.Tree_Type;
- Source : Tree_Types.Tree_Type)
- is
- procedure Append_Element (Source_Node : Count_Type);
-
- procedure Append_Elements is
- new Tree_Operations.Generic_Iteration (Append_Element);
-
- --------------------
- -- Append_Element --
- --------------------
-
- procedure Append_Element (Source_Node : Count_Type) is
- SN : Node_Type renames Source.Nodes (Source_Node);
-
- procedure Set_Element (Node : in out Node_Type);
- pragma Inline (Set_Element);
-
- function New_Node return Count_Type;
- pragma Inline (New_Node);
-
- procedure Insert_Post is
- new Element_Keys.Generic_Insert_Post (New_Node);
-
- procedure Unconditional_Insert_Sans_Hint is
- new Element_Keys.Generic_Unconditional_Insert (Insert_Post);
-
- procedure Unconditional_Insert_Avec_Hint is
- new Element_Keys.Generic_Unconditional_Insert_With_Hint
- (Insert_Post,
- Unconditional_Insert_Sans_Hint);
-
- procedure Allocate is new Generic_Allocate (Set_Element);
-
- --------------
- -- New_Node --
- --------------
-
- function New_Node return Count_Type is
- Result : Count_Type;
- begin
- Allocate (Target, Result);
- return Result;
- end New_Node;
-
- -----------------
- -- Set_Element --
- -----------------
-
- procedure Set_Element (Node : in out Node_Type) is
- begin
- Node.Element := SN.Element;
- end Set_Element;
-
- -- Local variables
-
- Target_Node : Count_Type;
-
- -- Start of processing for Append_Element
-
- begin
- Unconditional_Insert_Avec_Hint
- (Tree => Target,
- Hint => 0,
- Key => SN.Element,
- Node => Target_Node);
- end Append_Element;
-
- -- Start of processing for Assign
-
- begin
- if Target'Address = Source'Address then
- return;
- end if;
-
- if Target.Capacity < Source.Length then
- raise Constraint_Error
- with "Target capacity is less than Source length";
- end if;
-
- Tree_Operations.Clear_Tree (Target);
- Append_Elements (Source);
- end Assign;
-
- procedure Assign (Target : in out Set; Source : Set) is
- begin
- Assign (Target.Content, Source.Content);
- end Assign;
-
- -------------
- -- Ceiling --
- -------------
-
- function Ceiling (Container : Set; Item : Element_Type) return Cursor is
- Node : constant Count_Type :=
- Element_Keys.Ceiling (Container.Content, Item);
-
- begin
- if Node = 0 then
- return No_Element;
- end if;
-
- return (Node => Node);
- end Ceiling;
-
- -----------
- -- Clear --
- -----------
-
- procedure Clear (Container : in out Set) is
- begin
- Tree_Operations.Clear_Tree (Container.Content);
- end Clear;
-
- -----------
- -- Color --
- -----------
-
- function Color (Node : Node_Type) return Red_Black_Trees.Color_Type is
- begin
- return Node.Color;
- end Color;
-
- ------------------------
- -- Constant_Reference --
- ------------------------
-
- function Constant_Reference
- (Container : aliased Set;
- Position : Cursor) return not null access constant Element_Type
- is
- begin
- if not Has_Element (Container, Position) then
- raise Constraint_Error with "Position cursor has no element";
- end if;
-
- pragma Assert (Vet (Container.Content, Position.Node),
- "bad cursor in Element");
-
- return Container.Content.Nodes (Position.Node).Element'Access;
- end Constant_Reference;
-
- --------------
- -- Contains --
- --------------
-
- function Contains
- (Container : Set;
- Item : Element_Type) return Boolean
- is
- begin
- return Find (Container, Item) /= No_Element;
- end Contains;
-
- ----------
- -- Copy --
- ----------
-
- function Copy (Source : Set; Capacity : Count_Type := 0) return Set is
- Node : Count_Type;
- N : Count_Type;
- Target : Set (Count_Type'Max (Source.Capacity, Capacity));
-
- begin
- if 0 < Capacity and then Capacity < Source.Capacity then
- raise Capacity_Error;
- end if;
-
- if Length (Source) > 0 then
- Target.Content.Length := Source.Content.Length;
- Target.Content.Root := Source.Content.Root;
- Target.Content.First := Source.Content.First;
- Target.Content.Last := Source.Content.Last;
- Target.Content.Free := Source.Content.Free;
-
- Node := 1;
- while Node <= Source.Capacity loop
- Target.Content.Nodes (Node).Element :=
- Source.Content.Nodes (Node).Element;
- Target.Content.Nodes (Node).Parent :=
- Source.Content.Nodes (Node).Parent;
- Target.Content.Nodes (Node).Left :=
- Source.Content.Nodes (Node).Left;
- Target.Content.Nodes (Node).Right :=
- Source.Content.Nodes (Node).Right;
- Target.Content.Nodes (Node).Color :=
- Source.Content.Nodes (Node).Color;
- Target.Content.Nodes (Node).Has_Element :=
- Source.Content.Nodes (Node).Has_Element;
- Node := Node + 1;
- end loop;
-
- while Node <= Target.Capacity loop
- N := Node;
- Free (Tree => Target, X => N);
- Node := Node + 1;
- end loop;
- end if;
-
- return Target;
- end Copy;
-
- ------------
- -- Delete --
- ------------
-
- procedure Delete (Container : in out Set; Position : in out Cursor) is
- begin
- if not Has_Element (Container, Position) then
- raise Constraint_Error with "Position cursor has no element";
- end if;
-
- pragma Assert (Vet (Container.Content, Position.Node),
- "bad cursor in Delete");
-
- Tree_Operations.Delete_Node_Sans_Free (Container.Content,
- Position.Node);
- Free (Container, Position.Node);
- Position := No_Element;
- end Delete;
-
- procedure Delete (Container : in out Set; Item : Element_Type) is
- X : constant Count_Type := Element_Keys.Find (Container.Content, Item);
-
- begin
- if X = 0 then
- raise Constraint_Error with "attempt to delete element not in set";
- end if;
-
- Tree_Operations.Delete_Node_Sans_Free (Container.Content, X);
- Free (Container, X);
- end Delete;
-
- ------------------
- -- Delete_First --
- ------------------
-
- procedure Delete_First (Container : in out Set) is
- X : constant Count_Type := Container.Content.First;
- begin
- if X /= 0 then
- Tree_Operations.Delete_Node_Sans_Free (Container.Content, X);
- Free (Container, X);
- end if;
- end Delete_First;
-
- -----------------
- -- Delete_Last --
- -----------------
-
- procedure Delete_Last (Container : in out Set) is
- X : constant Count_Type := Container.Content.Last;
- begin
- if X /= 0 then
- Tree_Operations.Delete_Node_Sans_Free (Container.Content, X);
- Free (Container, X);
- end if;
- end Delete_Last;
-
- ----------------
- -- Difference --
- ----------------
-
- procedure Difference (Target : in out Set; Source : Set) is
- begin
- Set_Ops.Set_Difference (Target.Content, Source.Content);
- end Difference;
-
- function Difference (Left, Right : Set) return Set is
- begin
- if Left'Address = Right'Address then
- return Empty_Set;
- end if;
-
- if Length (Left) = 0 then
- return Empty_Set;
- end if;
-
- if Length (Right) = 0 then
- return Copy (Left);
- end if;
-
- return S : Set (Length (Left)) do
- Assign
- (S.Content, Set_Ops.Set_Difference (Left.Content, Right.Content));
- end return;
- end Difference;
-
- -------------
- -- Element --
- -------------
-
- function Element (Container : Set; Position : Cursor) return Element_Type is
- begin
- if not Has_Element (Container, Position) then
- raise Constraint_Error with "Position cursor has no element";
- end if;
-
- pragma Assert (Vet (Container.Content, Position.Node),
- "bad cursor in Element");
-
- return Container.Content.Nodes (Position.Node).Element;
- end Element;
-
- -------------------------
- -- Equivalent_Elements --
- -------------------------
-
- function Equivalent_Elements (Left, Right : Element_Type) return Boolean is
- begin
- if Left < Right
- or else Right < Left
- then
- return False;
- else
- return True;
- end if;
- end Equivalent_Elements;
-
- ---------------------
- -- Equivalent_Sets --
- ---------------------
-
- function Equivalent_Sets (Left, Right : Set) return Boolean is
- function Is_Equivalent_Node_Node
- (L, R : Node_Type) return Boolean;
- pragma Inline (Is_Equivalent_Node_Node);
-
- function Is_Equivalent is
- new Tree_Operations.Generic_Equal (Is_Equivalent_Node_Node);
-
- -----------------------------
- -- Is_Equivalent_Node_Node --
- -----------------------------
-
- function Is_Equivalent_Node_Node (L, R : Node_Type) return Boolean is
- begin
- if L.Element < R.Element then
- return False;
- elsif R.Element < L.Element then
- return False;
- else
- return True;
- end if;
- end Is_Equivalent_Node_Node;
-
- -- Start of processing for Equivalent_Sets
-
- begin
- return Is_Equivalent (Left.Content, Right.Content);
- end Equivalent_Sets;
-
- -------------
- -- Exclude --
- -------------
-
- procedure Exclude (Container : in out Set; Item : Element_Type) is
- X : constant Count_Type := Element_Keys.Find (Container.Content, Item);
- begin
- if X /= 0 then
- Tree_Operations.Delete_Node_Sans_Free (Container.Content, X);
- Free (Container, X);
- end if;
- end Exclude;
-
- ----------
- -- Find --
- ----------
-
- function Find (Container : Set; Item : Element_Type) return Cursor is
- Node : constant Count_Type :=
- Element_Keys.Find (Container.Content, Item);
-
- begin
- if Node = 0 then
- return No_Element;
- end if;
-
- return (Node => Node);
- end Find;
-
- -----------
- -- First --
- -----------
-
- function First (Container : Set) return Cursor is
- begin
- if Length (Container) = 0 then
- return No_Element;
- end if;
-
- return (Node => Container.Content.First);
- end First;
-
- -------------------
- -- First_Element --
- -------------------
-
- function First_Element (Container : Set) return Element_Type is
- Fst : constant Count_Type := First (Container).Node;
- begin
- if Fst = 0 then
- raise Constraint_Error with "set is empty";
- end if;
-
- declare
- N : Tree_Types.Nodes_Type renames Container.Content.Nodes;
- begin
- return N (Fst).Element;
- end;
- end First_Element;
-
- -----------
- -- Floor --
- -----------
-
- function Floor (Container : Set; Item : Element_Type) return Cursor is
- begin
- declare
- Node : constant Count_Type :=
- Element_Keys.Floor (Container.Content, Item);
-
- begin
- if Node = 0 then
- return No_Element;
- end if;
-
- return (Node => Node);
- end;
- end Floor;
-
- ------------------
- -- Formal_Model --
- ------------------
-
- package body Formal_Model is
-
- -------------------------
- -- E_Bigger_Than_Range --
- -------------------------
-
- function E_Bigger_Than_Range
- (Container : E.Sequence;
- Fst : Positive_Count_Type;
- Lst : Count_Type;
- Item : Element_Type) return Boolean
- is
- begin
- for I in Fst .. Lst loop
- if not (E.Get (Container, I) < Item) then
- return False;
- end if;
- end loop;
-
- return True;
- end E_Bigger_Than_Range;
-
- -------------------------
- -- E_Elements_Included --
- -------------------------
-
- function E_Elements_Included
- (Left : E.Sequence;
- Right : E.Sequence) return Boolean
- is
- begin
- for I in 1 .. E.Length (Left) loop
- if not E.Contains (Right, 1, E.Length (Right), E.Get (Left, I))
- then
- return False;
- end if;
- end loop;
-
- return True;
- end E_Elements_Included;
-
- function E_Elements_Included
- (Left : E.Sequence;
- Model : M.Set;
- Right : E.Sequence) return Boolean
- is
- begin
- for I in 1 .. E.Length (Left) loop
- declare
- Item : constant Element_Type := E.Get (Left, I);
- begin
- if M.Contains (Model, Item) then
- if not E.Contains (Right, 1, E.Length (Right), Item) then
- return False;
- end if;
- end if;
- end;
- end loop;
-
- return True;
- end E_Elements_Included;
-
- function E_Elements_Included
- (Container : E.Sequence;
- Model : M.Set;
- Left : E.Sequence;
- Right : E.Sequence) return Boolean
- is
- begin
- for I in 1 .. E.Length (Container) loop
- declare
- Item : constant Element_Type := E.Get (Container, I);
- begin
- if M.Contains (Model, Item) then
- if not E.Contains (Left, 1, E.Length (Left), Item) then
- return False;
- end if;
- else
- if not E.Contains (Right, 1, E.Length (Right), Item) then
- return False;
- end if;
- end if;
- end;
- end loop;
-
- return True;
- end E_Elements_Included;
-
- ---------------
- -- E_Is_Find --
- ---------------
-
- function E_Is_Find
- (Container : E.Sequence;
- Item : Element_Type;
- Position : Count_Type) return Boolean
- is
- begin
- for I in 1 .. Position - 1 loop
- if Item < E.Get (Container, I) then
- return False;
- end if;
- end loop;
-
- if Position < E.Length (Container) then
- for I in Position + 1 .. E.Length (Container) loop
- if E.Get (Container, I) < Item then
- return False;
- end if;
- end loop;
- end if;
-
- return True;
- end E_Is_Find;
-
- --------------------------
- -- E_Smaller_Than_Range --
- --------------------------
-
- function E_Smaller_Than_Range
- (Container : E.Sequence;
- Fst : Positive_Count_Type;
- Lst : Count_Type;
- Item : Element_Type) return Boolean
- is
- begin
- for I in Fst .. Lst loop
- if not (Item < E.Get (Container, I)) then
- return False;
- end if;
- end loop;
-
- return True;
- end E_Smaller_Than_Range;
-
- ----------
- -- Find --
- ----------
-
- function Find
- (Container : E.Sequence;
- Item : Element_Type) return Count_Type
- is
- begin
- for I in 1 .. E.Length (Container) loop
- if Equivalent_Elements (Item, E.Get (Container, I)) then
- return I;
- end if;
- end loop;
-
- return 0;
- end Find;
-
- --------------
- -- Elements --
- --------------
-
- function Elements (Container : Set) return E.Sequence is
- Position : Count_Type := Container.Content.First;
- R : E.Sequence;
-
- begin
- -- Can't use First, Next or Element here, since they depend on models
- -- for their postconditions.
-
- while Position /= 0 loop
- R := E.Add (R, Container.Content.Nodes (Position).Element);
- Position := Tree_Operations.Next (Container.Content, Position);
- end loop;
-
- return R;
- end Elements;
-
- ----------------------------
- -- Lift_Abstraction_Level --
- ----------------------------
-
- procedure Lift_Abstraction_Level (Container : Set) is null;
-
- -----------------------
- -- Mapping_Preserved --
- -----------------------
-
- function Mapping_Preserved
- (E_Left : E.Sequence;
- E_Right : E.Sequence;
- P_Left : P.Map;
- P_Right : P.Map) return Boolean
- is
- begin
- for C of P_Left loop
- if not P.Has_Key (P_Right, C)
- or else P.Get (P_Left, C) > E.Length (E_Left)
- or else P.Get (P_Right, C) > E.Length (E_Right)
- or else E.Get (E_Left, P.Get (P_Left, C)) /=
- E.Get (E_Right, P.Get (P_Right, C))
- then
- return False;
- end if;
- end loop;
-
- return True;
- end Mapping_Preserved;
-
- ------------------------------
- -- Mapping_Preserved_Except --
- ------------------------------
-
- function Mapping_Preserved_Except
- (E_Left : E.Sequence;
- E_Right : E.Sequence;
- P_Left : P.Map;
- P_Right : P.Map;
- Position : Cursor) return Boolean
- is
- begin
- for C of P_Left loop
- if C /= Position
- and (not P.Has_Key (P_Right, C)
- or else P.Get (P_Left, C) > E.Length (E_Left)
- or else P.Get (P_Right, C) > E.Length (E_Right)
- or else E.Get (E_Left, P.Get (P_Left, C)) /=
- E.Get (E_Right, P.Get (P_Right, C)))
- then
- return False;
- end if;
- end loop;
-
- return True;
- end Mapping_Preserved_Except;
-
- -------------------------
- -- P_Positions_Shifted --
- -------------------------
-
- function P_Positions_Shifted
- (Small : P.Map;
- Big : P.Map;
- Cut : Positive_Count_Type;
- Count : Count_Type := 1) return Boolean
- is
- begin
- for Cu of Small loop
- if not P.Has_Key (Big, Cu) then
- return False;
- end if;
- end loop;
-
- for Cu of Big loop
- declare
- Pos : constant Positive_Count_Type := P.Get (Big, Cu);
-
- begin
- if Pos < Cut then
- if not P.Has_Key (Small, Cu)
- or else Pos /= P.Get (Small, Cu)
- then
- return False;
- end if;
-
- elsif Pos >= Cut + Count then
- if not P.Has_Key (Small, Cu)
- or else Pos /= P.Get (Small, Cu) + Count
- then
- return False;
- end if;
-
- else
- if P.Has_Key (Small, Cu) then
- return False;
- end if;
- end if;
- end;
- end loop;
-
- return True;
- end P_Positions_Shifted;
-
- -----------
- -- Model --
- -----------
-
- function Model (Container : Set) return M.Set is
- Position : Count_Type := Container.Content.First;
- R : M.Set;
-
- begin
- -- Can't use First, Next or Element here, since they depend on models
- -- for their postconditions.
-
- while Position /= 0 loop
- R :=
- M.Add
- (Container => R,
- Item => Container.Content.Nodes (Position).Element);
-
- Position := Tree_Operations.Next (Container.Content, Position);
- end loop;
-
- return R;
- end Model;
-
- ---------------
- -- Positions --
- ---------------
-
- function Positions (Container : Set) return P.Map is
- I : Count_Type := 1;
- Position : Count_Type := Container.Content.First;
- R : P.Map;
-
- begin
- -- Can't use First, Next or Element here, since they depend on models
- -- for their postconditions.
-
- while Position /= 0 loop
- R := P.Add (R, (Node => Position), I);
- pragma Assert (P.Length (R) = Big (I));
- Position := Tree_Operations.Next (Container.Content, Position);
- I := I + 1;
- end loop;
-
- return R;
- end Positions;
-
- end Formal_Model;
-
- ----------
- -- Free --
- ----------
-
- procedure Free (Tree : in out Set; X : Count_Type) is
- begin
- Tree.Content.Nodes (X).Has_Element := False;
- Tree_Operations.Free (Tree.Content, X);
- end Free;
-
- ----------------------
- -- Generic_Allocate --
- ----------------------
-
- procedure Generic_Allocate
- (Tree : in out Tree_Types.Tree_Type'Class;
- Node : out Count_Type)
- is
- procedure Allocate is
- new Tree_Operations.Generic_Allocate (Set_Element);
- begin
- Allocate (Tree, Node);
- Tree.Nodes (Node).Has_Element := True;
- end Generic_Allocate;
-
- ------------------
- -- Generic_Keys --
- ------------------
-
- package body Generic_Keys with SPARK_Mode => Off is
-
- -----------------------
- -- Local Subprograms --
- -----------------------
-
- function Is_Greater_Key_Node
- (Left : Key_Type;
- Right : Node_Type) return Boolean;
- pragma Inline (Is_Greater_Key_Node);
-
- function Is_Less_Key_Node
- (Left : Key_Type;
- Right : Node_Type) return Boolean;
- pragma Inline (Is_Less_Key_Node);
-
- --------------------------
- -- Local Instantiations --
- --------------------------
-
- package Key_Keys is
- new Red_Black_Trees.Generic_Bounded_Keys
- (Tree_Operations => Tree_Operations,
- Key_Type => Key_Type,
- Is_Less_Key_Node => Is_Less_Key_Node,
- Is_Greater_Key_Node => Is_Greater_Key_Node);
-
- -------------
- -- Ceiling --
- -------------
-
- function Ceiling (Container : Set; Key : Key_Type) return Cursor is
- Node : constant Count_Type :=
- Key_Keys.Ceiling (Container.Content, Key);
-
- begin
- if Node = 0 then
- return No_Element;
- end if;
-
- return (Node => Node);
- end Ceiling;
-
- --------------
- -- Contains --
- --------------
-
- function Contains (Container : Set; Key : Key_Type) return Boolean is
- begin
- return Find (Container, Key) /= No_Element;
- end Contains;
-
- ------------
- -- Delete --
- ------------
-
- procedure Delete (Container : in out Set; Key : Key_Type) is
- X : constant Count_Type := Key_Keys.Find (Container.Content, Key);
-
- begin
- if X = 0 then
- raise Constraint_Error with "attempt to delete key not in set";
- end if;
-
- Delete_Node_Sans_Free (Container.Content, X);
- Free (Container, X);
- end Delete;
-
- -------------
- -- Element --
- -------------
-
- function Element (Container : Set; Key : Key_Type) return Element_Type is
- Node : constant Count_Type := Key_Keys.Find (Container.Content, Key);
-
- begin
- if Node = 0 then
- raise Constraint_Error with "key not in set";
- end if;
-
- declare
- N : Tree_Types.Nodes_Type renames Container.Content.Nodes;
- begin
- return N (Node).Element;
- end;
- end Element;
-
- ---------------------
- -- Equivalent_Keys --
- ---------------------
-
- function Equivalent_Keys (Left, Right : Key_Type) return Boolean is
- begin
- if Left < Right
- or else Right < Left
- then
- return False;
- else
- return True;
- end if;
- end Equivalent_Keys;
-
- -------------
- -- Exclude --
- -------------
-
- procedure Exclude (Container : in out Set; Key : Key_Type) is
- X : constant Count_Type := Key_Keys.Find (Container.Content, Key);
- begin
- if X /= 0 then
- Delete_Node_Sans_Free (Container.Content, X);
- Free (Container, X);
- end if;
- end Exclude;
-
- ----------
- -- Find --
- ----------
-
- function Find (Container : Set; Key : Key_Type) return Cursor is
- Node : constant Count_Type := Key_Keys.Find (Container.Content, Key);
- begin
- return (if Node = 0 then No_Element else (Node => Node));
- end Find;
-
- -----------
- -- Floor --
- -----------
-
- function Floor (Container : Set; Key : Key_Type) return Cursor is
- Node : constant Count_Type := Key_Keys.Floor (Container.Content, Key);
- begin
- return (if Node = 0 then No_Element else (Node => Node));
- end Floor;
-
- ------------------
- -- Formal_Model --
- ------------------
-
- package body Formal_Model is
-
- -------------------------
- -- E_Bigger_Than_Range --
- -------------------------
-
- function E_Bigger_Than_Range
- (Container : E.Sequence;
- Fst : Positive_Count_Type;
- Lst : Count_Type;
- Key : Key_Type) return Boolean
- is
- begin
- for I in Fst .. Lst loop
- if not (Generic_Keys.Key (E.Get (Container, I)) < Key) then
- return False;
- end if;
- end loop;
- return True;
- end E_Bigger_Than_Range;
-
- ---------------
- -- E_Is_Find --
- ---------------
-
- function E_Is_Find
- (Container : E.Sequence;
- Key : Key_Type;
- Position : Count_Type) return Boolean
- is
- begin
- for I in 1 .. Position - 1 loop
- if Key < Generic_Keys.Key (E.Get (Container, I)) then
- return False;
- end if;
- end loop;
-
- if Position < E.Length (Container) then
- for I in Position + 1 .. E.Length (Container) loop
- if Generic_Keys.Key (E.Get (Container, I)) < Key then
- return False;
- end if;
- end loop;
- end if;
- return True;
- end E_Is_Find;
-
- --------------------------
- -- E_Smaller_Than_Range --
- --------------------------
-
- function E_Smaller_Than_Range
- (Container : E.Sequence;
- Fst : Positive_Count_Type;
- Lst : Count_Type;
- Key : Key_Type) return Boolean
- is
- begin
- for I in Fst .. Lst loop
- if not (Key < Generic_Keys.Key (E.Get (Container, I))) then
- return False;
- end if;
- end loop;
- return True;
- end E_Smaller_Than_Range;
-
- ----------
- -- Find --
- ----------
-
- function Find
- (Container : E.Sequence;
- Key : Key_Type) return Count_Type
- is
- begin
- for I in 1 .. E.Length (Container) loop
- if Equivalent_Keys
- (Key, Generic_Keys.Key (E.Get (Container, I)))
- then
- return I;
- end if;
- end loop;
- return 0;
- end Find;
-
- -----------------------
- -- M_Included_Except --
- -----------------------
-
- function M_Included_Except
- (Left : M.Set;
- Right : M.Set;
- Key : Key_Type) return Boolean
- is
- begin
- for E of Left loop
- if not Contains (Right, E)
- and not Equivalent_Keys (Generic_Keys.Key (E), Key)
- then
- return False;
- end if;
- end loop;
- return True;
- end M_Included_Except;
- end Formal_Model;
-
- -------------------------
- -- Is_Greater_Key_Node --
- -------------------------
-
- function Is_Greater_Key_Node
- (Left : Key_Type;
- Right : Node_Type) return Boolean
- is
- begin
- return Key (Right.Element) < Left;
- end Is_Greater_Key_Node;
-
- ----------------------
- -- Is_Less_Key_Node --
- ----------------------
-
- function Is_Less_Key_Node
- (Left : Key_Type;
- Right : Node_Type) return Boolean
- is
- begin
- return Left < Key (Right.Element);
- end Is_Less_Key_Node;
-
- ---------
- -- Key --
- ---------
-
- function Key (Container : Set; Position : Cursor) return Key_Type is
- begin
- if not Has_Element (Container, Position) then
- raise Constraint_Error with
- "Position cursor has no element";
- end if;
-
- pragma Assert (Vet (Container.Content, Position.Node),
- "bad cursor in Key");
-
- declare
- N : Tree_Types.Nodes_Type renames Container.Content.Nodes;
- begin
- return Key (N (Position.Node).Element);
- end;
- end Key;
-
- -------------
- -- Replace --
- -------------
-
- procedure Replace
- (Container : in out Set;
- Key : Key_Type;
- New_Item : Element_Type)
- is
- Node : constant Count_Type := Key_Keys.Find (Container.Content, Key);
- begin
- if not Has_Element (Container, (Node => Node)) then
- raise Constraint_Error with
- "attempt to replace key not in set";
- else
- Replace_Element (Container, Node, New_Item);
- end if;
- end Replace;
-
- end Generic_Keys;
-
- -----------------
- -- Has_Element --
- -----------------
-
- function Has_Element (Container : Set; Position : Cursor) return Boolean is
- begin
- if Position.Node = 0 then
- return False;
- else
- return Container.Content.Nodes (Position.Node).Has_Element;
- end if;
- end Has_Element;
-
- -------------
- -- Include --
- -------------
-
- procedure Include (Container : in out Set; New_Item : Element_Type) is
- Position : Cursor;
- Inserted : Boolean;
-
- begin
- Insert (Container, New_Item, Position, Inserted);
-
- if not Inserted then
- declare
- N : Tree_Types.Nodes_Type renames Container.Content.Nodes;
- begin
- N (Position.Node).Element := New_Item;
- end;
- end if;
- end Include;
-
- ------------
- -- Insert --
- ------------
-
- procedure Insert
- (Container : in out Set;
- New_Item : Element_Type;
- Position : out Cursor;
- Inserted : out Boolean)
- is
- begin
- Insert_Sans_Hint (Container.Content, New_Item, Position.Node, Inserted);
- end Insert;
-
- procedure Insert
- (Container : in out Set;
- New_Item : Element_Type)
- is
- Position : Cursor;
- Inserted : Boolean;
-
- begin
- Insert (Container, New_Item, Position, Inserted);
-
- if not Inserted then
- raise Constraint_Error with
- "attempt to insert element already in set";
- end if;
- end Insert;
-
- ----------------------
- -- Insert_Sans_Hint --
- ----------------------
-
- procedure Insert_Sans_Hint
- (Container : in out Tree_Types.Tree_Type;
- New_Item : Element_Type;
- Node : out Count_Type;
- Inserted : out Boolean)
- is
- procedure Set_Element (Node : in out Node_Type);
-
- function New_Node return Count_Type;
- pragma Inline (New_Node);
-
- procedure Insert_Post is
- new Element_Keys.Generic_Insert_Post (New_Node);
-
- procedure Conditional_Insert_Sans_Hint is
- new Element_Keys.Generic_Conditional_Insert (Insert_Post);
-
- procedure Allocate is new Generic_Allocate (Set_Element);
-
- --------------
- -- New_Node --
- --------------
-
- function New_Node return Count_Type is
- Result : Count_Type;
- begin
- Allocate (Container, Result);
- return Result;
- end New_Node;
-
- -----------------
- -- Set_Element --
- -----------------
-
- procedure Set_Element (Node : in out Node_Type) is
- begin
- Node.Element := New_Item;
- end Set_Element;
-
- -- Start of processing for Insert_Sans_Hint
-
- begin
- Conditional_Insert_Sans_Hint
- (Container,
- New_Item,
- Node,
- Inserted);
- end Insert_Sans_Hint;
-
- ----------------------
- -- Insert_With_Hint --
- ----------------------
-
- procedure Insert_With_Hint
- (Dst_Set : in out Tree_Types.Tree_Type;
- Dst_Hint : Count_Type;
- Src_Node : Node_Type;
- Dst_Node : out Count_Type)
- is
- Success : Boolean;
-
- procedure Set_Element (Node : in out Node_Type);
-
- function New_Node return Count_Type;
- pragma Inline (New_Node);
-
- procedure Insert_Post is
- new Element_Keys.Generic_Insert_Post (New_Node);
-
- procedure Insert_Sans_Hint is
- new Element_Keys.Generic_Conditional_Insert (Insert_Post);
-
- procedure Local_Insert_With_Hint is
- new Element_Keys.Generic_Conditional_Insert_With_Hint
- (Insert_Post, Insert_Sans_Hint);
-
- procedure Allocate is new Generic_Allocate (Set_Element);
-
- --------------
- -- New_Node --
- --------------
-
- function New_Node return Count_Type is
- Result : Count_Type;
- begin
- Allocate (Dst_Set, Result);
- return Result;
- end New_Node;
-
- -----------------
- -- Set_Element --
- -----------------
-
- procedure Set_Element (Node : in out Node_Type) is
- begin
- Node.Element := Src_Node.Element;
- end Set_Element;
-
- -- Start of processing for Insert_With_Hint
-
- begin
- Local_Insert_With_Hint
- (Dst_Set,
- Dst_Hint,
- Src_Node.Element,
- Dst_Node,
- Success);
- end Insert_With_Hint;
-
- ------------------
- -- Intersection --
- ------------------
-
- procedure Intersection (Target : in out Set; Source : Set) is
- begin
- Set_Ops.Set_Intersection (Target.Content, Source.Content);
- end Intersection;
-
- function Intersection (Left, Right : Set) return Set is
- begin
- if Left'Address = Right'Address then
- return Copy (Left);
- end if;
-
- return S : Set (Count_Type'Min (Length (Left), Length (Right))) do
- Assign (S.Content,
- Set_Ops.Set_Intersection (Left.Content, Right.Content));
- end return;
- end Intersection;
-
- --------------
- -- Is_Empty --
- --------------
-
- function Is_Empty (Container : Set) return Boolean is
- begin
- return Length (Container) = 0;
- end Is_Empty;
-
- -----------------------------
- -- Is_Greater_Element_Node --
- -----------------------------
-
- function Is_Greater_Element_Node
- (Left : Element_Type;
- Right : Node_Type) return Boolean
- is
- begin
- -- Compute e > node same as node < e
-
- return Right.Element < Left;
- end Is_Greater_Element_Node;
-
- --------------------------
- -- Is_Less_Element_Node --
- --------------------------
-
- function Is_Less_Element_Node
- (Left : Element_Type;
- Right : Node_Type) return Boolean
- is
- begin
- return Left < Right.Element;
- end Is_Less_Element_Node;
-
- -----------------------
- -- Is_Less_Node_Node --
- -----------------------
-
- function Is_Less_Node_Node (L, R : Node_Type) return Boolean is
- begin
- return L.Element < R.Element;
- end Is_Less_Node_Node;
-
- ---------------
- -- Is_Subset --
- ---------------
-
- function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is
- begin
- return Set_Ops.Set_Subset (Subset.Content, Of_Set => Of_Set.Content);
- end Is_Subset;
-
- ----------
- -- Last --
- ----------
-
- function Last (Container : Set) return Cursor is
- begin
- return (if Length (Container) = 0
- then No_Element
- else (Node => Container.Content.Last));
- end Last;
-
- ------------------
- -- Last_Element --
- ------------------
-
- function Last_Element (Container : Set) return Element_Type is
- begin
- if Last (Container).Node = 0 then
- raise Constraint_Error with "set is empty";
- end if;
-
- declare
- N : Tree_Types.Nodes_Type renames Container.Content.Nodes;
- begin
- return N (Last (Container).Node).Element;
- end;
- end Last_Element;
-
- --------------
- -- Left_Son --
- --------------
-
- function Left_Son (Node : Node_Type) return Count_Type is
- begin
- return Node.Left;
- end Left_Son;
-
- ------------
- -- Length --
- ------------
-
- function Length (Container : Set) return Count_Type is
- begin
- return Container.Content.Length;
- end Length;
-
- ----------
- -- Move --
- ----------
-
- procedure Move (Target : in out Set; Source : in out Set) is
- N : Tree_Types.Nodes_Type renames Source.Content.Nodes;
- X : Count_Type;
-
- begin
- if Target'Address = Source'Address then
- return;
- end if;
-
- if Target.Capacity < Length (Source) then
- raise Constraint_Error with -- ???
- "Source length exceeds Target capacity";
- end if;
-
- Clear (Target);
-
- loop
- X := Source.Content.First;
- exit when X = 0;
-
- Insert (Target, N (X).Element); -- optimize???
-
- Tree_Operations.Delete_Node_Sans_Free (Source.Content, X);
- Free (Source, X);
- end loop;
- end Move;
-
- ----------
- -- Next --
- ----------
-
- function Next (Container : Set; Position : Cursor) return Cursor is
- begin
- if Position = No_Element then
- return No_Element;
- end if;
-
- if not Has_Element (Container, Position) then
- raise Constraint_Error;
- end if;
-
- pragma Assert (Vet (Container.Content, Position.Node),
- "bad cursor in Next");
- return (Node => Tree_Operations.Next (Container.Content, Position.Node));
- end Next;
-
- procedure Next (Container : Set; Position : in out Cursor) is
- begin
- Position := Next (Container, Position);
- end Next;
-
- -------------
- -- Overlap --
- -------------
-
- function Overlap (Left, Right : Set) return Boolean is
- begin
- return Set_Ops.Set_Overlap (Left.Content, Right.Content);
- end Overlap;
-
- ------------
- -- Parent --
- ------------
-
- function Parent (Node : Node_Type) return Count_Type is
- begin
- return Node.Parent;
- end Parent;
-
- --------------
- -- Previous --
- --------------
-
- function Previous (Container : Set; Position : Cursor) return Cursor is
- begin
- if Position = No_Element then
- return No_Element;
- end if;
-
- if not Has_Element (Container, Position) then
- raise Constraint_Error;
- end if;
-
- pragma Assert (Vet (Container.Content, Position.Node),
- "bad cursor in Previous");
-
- declare
- Node : constant Count_Type :=
- Tree_Operations.Previous (Container.Content, Position.Node);
- begin
- return (if Node = 0 then No_Element else (Node => Node));
- end;
- end Previous;
-
- procedure Previous (Container : Set; Position : in out Cursor) is
- begin
- Position := Previous (Container, Position);
- end Previous;
-
- -------------
- -- Replace --
- -------------
-
- procedure Replace (Container : in out Set; New_Item : Element_Type) is
- Node : constant Count_Type :=
- Element_Keys.Find (Container.Content, New_Item);
-
- begin
- if Node = 0 then
- raise Constraint_Error with
- "attempt to replace element not in set";
- end if;
-
- Container.Content.Nodes (Node).Element := New_Item;
- end Replace;
-
- ---------------------
- -- Replace_Element --
- ---------------------
-
- procedure Replace_Element
- (Tree : in out Set;
- Node : Count_Type;
- Item : Element_Type)
- is
- pragma Assert (Node /= 0);
-
- function New_Node return Count_Type;
- pragma Inline (New_Node);
-
- procedure Local_Insert_Post is
- new Element_Keys.Generic_Insert_Post (New_Node);
-
- procedure Local_Insert_Sans_Hint is
- new Element_Keys.Generic_Conditional_Insert (Local_Insert_Post);
-
- procedure Local_Insert_With_Hint is
- new Element_Keys.Generic_Conditional_Insert_With_Hint
- (Local_Insert_Post,
- Local_Insert_Sans_Hint);
-
- NN : Tree_Types.Nodes_Type renames Tree.Content.Nodes;
-
- --------------
- -- New_Node --
- --------------
-
- function New_Node return Count_Type is
- N : Node_Type renames NN (Node);
- begin
- N.Element := Item;
- N.Color := Red;
- N.Parent := 0;
- N.Right := 0;
- N.Left := 0;
- return Node;
- end New_Node;
-
- Hint : Count_Type;
- Result : Count_Type;
- Inserted : Boolean;
-
- -- Start of processing for Insert
-
- begin
- if Item < NN (Node).Element
- or else NN (Node).Element < Item
- then
- null;
-
- else
- NN (Node).Element := Item;
- return;
- end if;
-
- Hint := Element_Keys.Ceiling (Tree.Content, Item);
-
- if Hint = 0 then
- null;
-
- elsif Item < NN (Hint).Element then
- if Hint = Node then
- NN (Node).Element := Item;
- return;
- end if;
-
- else
- pragma Assert (not (NN (Hint).Element < Item));
- raise Program_Error with "attempt to replace existing element";
- end if;
-
- Tree_Operations.Delete_Node_Sans_Free (Tree.Content, Node);
-
- Local_Insert_With_Hint
- (Tree => Tree.Content,
- Position => Hint,
- Key => Item,
- Node => Result,
- Inserted => Inserted);
-
- pragma Assert (Inserted);
- pragma Assert (Result = Node);
- end Replace_Element;
-
- procedure Replace_Element
- (Container : in out Set;
- Position : Cursor;
- New_Item : Element_Type)
- is
- begin
- if not Has_Element (Container, Position) then
- raise Constraint_Error with
- "Position cursor has no element";
- end if;
-
- pragma Assert (Vet (Container.Content, Position.Node),
- "bad cursor in Replace_Element");
-
- Replace_Element (Container, Position.Node, New_Item);
- end Replace_Element;
-
- ---------------
- -- Right_Son --
- ---------------
-
- function Right_Son (Node : Node_Type) return Count_Type is
- begin
- return Node.Right;
- end Right_Son;
-
- ---------------
- -- Set_Color --
- ---------------
-
- procedure Set_Color
- (Node : in out Node_Type;
- Color : Red_Black_Trees.Color_Type)
- is
- begin
- Node.Color := Color;
- end Set_Color;
-
- --------------
- -- Set_Left --
- --------------
-
- procedure Set_Left (Node : in out Node_Type; Left : Count_Type) is
- begin
- Node.Left := Left;
- end Set_Left;
-
- ----------------
- -- Set_Parent --
- ----------------
-
- procedure Set_Parent (Node : in out Node_Type; Parent : Count_Type) is
- begin
- Node.Parent := Parent;
- end Set_Parent;
-
- ---------------
- -- Set_Right --
- ---------------
-
- procedure Set_Right (Node : in out Node_Type; Right : Count_Type) is
- begin
- Node.Right := Right;
- end Set_Right;
-
- --------------------------
- -- Symmetric_Difference --
- --------------------------
-
- procedure Symmetric_Difference (Target : in out Set; Source : Set) is
- begin
- Set_Ops.Set_Symmetric_Difference (Target.Content, Source.Content);
- end Symmetric_Difference;
-
- function Symmetric_Difference (Left, Right : Set) return Set is
- begin
- if Left'Address = Right'Address then
- return Empty_Set;
- end if;
-
- if Length (Right) = 0 then
- return Copy (Left);
- end if;
-
- if Length (Left) = 0 then
- return Copy (Right);
- end if;
-
- return S : Set (Length (Left) + Length (Right)) do
- Assign
- (S.Content,
- Set_Ops.Set_Symmetric_Difference (Left.Content, Right.Content));
- end return;
- end Symmetric_Difference;
-
- ------------
- -- To_Set --
- ------------
-
- function To_Set (New_Item : Element_Type) return Set is
- Node : Count_Type;
- Inserted : Boolean;
-
- begin
- return S : Set (Capacity => 1) do
- Insert_Sans_Hint (S.Content, New_Item, Node, Inserted);
- pragma Assert (Inserted);
- end return;
- end To_Set;
-
- -----------
- -- Union --
- -----------
-
- procedure Union (Target : in out Set; Source : Set) is
- begin
- Set_Ops.Set_Union (Target.Content, Source.Content);
- end Union;
-
- function Union (Left, Right : Set) return Set is
- begin
- if Left'Address = Right'Address then
- return Copy (Left);
- end if;
-
- if Length (Left) = 0 then
- return Copy (Right);
- end if;
-
- if Length (Right) = 0 then
- return Copy (Left);
- end if;
-
- return S : Set (Length (Left) + Length (Right)) do
- Assign (S, Source => Left);
- Union (S, Right);
- end return;
- end Union;
-
-end Ada.Containers.Formal_Ordered_Sets;
diff --git a/gcc/ada/libgnat/a-cforse.ads b/gcc/ada/libgnat/a-cforse.ads
index ff96d8e..fe5de2b 100644
--- a/gcc/ada/libgnat/a-cforse.ads
+++ b/gcc/ada/libgnat/a-cforse.ads
@@ -29,1785 +29,12 @@
-- <http://www.gnu.org/licenses/>. --
------------------------------------------------------------------------------
--- This spec is derived from package Ada.Containers.Bounded_Ordered_Sets in
--- the Ada 2012 RM. The modifications are meant to facilitate formal proofs by
--- making it easier to express properties, and by making the specification of
--- this unit compatible with SPARK 2014. Note that the API of this unit may be
--- subject to incompatible changes as SPARK 2014 evolves.
-
--- The modifications are:
-
--- A parameter for the container is added to every function reading the
--- content of a container: Key, Element, Next, Query_Element, Previous,
--- Has_Element, Iterate, Reverse_Iterate. This change is motivated by the
--- need to have cursors which are valid on different containers (typically
--- a container C and its previous version C'Old) for expressing properties,
--- which is not possible if cursors encapsulate an access to the underlying
--- container. The operators "<" and ">" that could not be modified that way
--- have been removed.
-
-with Ada.Containers.Functional_Maps;
-with Ada.Containers.Functional_Sets;
-with Ada.Containers.Functional_Vectors;
-with Ada.Numerics.Big_Numbers.Big_Integers;
-use Ada.Numerics.Big_Numbers.Big_Integers;
-private with Ada.Containers.Red_Black_Trees;
-
generic
- type Element_Type is private;
-
- with function "<" (Left, Right : Element_Type) return Boolean is <>;
-
-package Ada.Containers.Formal_Ordered_Sets with
- SPARK_Mode,
- Annotate => (GNATprove, Always_Return)
-is
-
- -- Contracts in this unit are meant for analysis only, not for run-time
- -- checking.
-
- pragma Assertion_Policy (Pre => Ignore);
- pragma Assertion_Policy (Post => Ignore);
- pragma Assertion_Policy (Contract_Cases => Ignore);
- pragma Annotate (CodePeer, Skip_Analysis);
-
- -- Convert Count_Type to Big_Interger
-
- package Conversions is new Signed_Conversions (Int => Count_Type);
-
- function Big (J : Count_Type) return Big_Integer renames
- Conversions.To_Big_Integer;
-
- function Equivalent_Elements (Left, Right : Element_Type) return Boolean
- with
- Global => null,
- Post =>
- Equivalent_Elements'Result =
- (not (Left < Right) and not (Right < Left));
- pragma Annotate (GNATprove, Inline_For_Proof, Equivalent_Elements);
-
- type Set (Capacity : Count_Type) is private with
- Iterable => (First => First,
- Next => Next,
- Has_Element => Has_Element,
- Element => Element),
- Default_Initial_Condition => Is_Empty (Set);
- pragma Preelaborable_Initialization (Set);
-
- type Cursor is record
- Node : Count_Type;
- end record;
-
- No_Element : constant Cursor := (Node => 0);
-
- function Length (Container : Set) return Count_Type with
- Global => null,
- Post => Length'Result <= Container.Capacity;
-
- pragma Unevaluated_Use_Of_Old (Allow);
-
- package Formal_Model with Ghost is
- subtype Positive_Count_Type is Count_Type range 1 .. Count_Type'Last;
-
- package M is new Ada.Containers.Functional_Sets
- (Element_Type => Element_Type,
- Equivalent_Elements => Equivalent_Elements);
-
- function "="
- (Left : M.Set;
- Right : M.Set) return Boolean renames M."=";
-
- function "<="
- (Left : M.Set;
- Right : M.Set) return Boolean renames M."<=";
-
- package E is new Ada.Containers.Functional_Vectors
- (Element_Type => Element_Type,
- Index_Type => Positive_Count_Type);
-
- function "="
- (Left : E.Sequence;
- Right : E.Sequence) return Boolean renames E."=";
-
- function "<"
- (Left : E.Sequence;
- Right : E.Sequence) return Boolean renames E."<";
-
- function "<="
- (Left : E.Sequence;
- Right : E.Sequence) return Boolean renames E."<=";
-
- function E_Bigger_Than_Range
- (Container : E.Sequence;
- Fst : Positive_Count_Type;
- Lst : Count_Type;
- Item : Element_Type) return Boolean
- with
- Global => null,
- Pre => Lst <= E.Length (Container),
- Post =>
- E_Bigger_Than_Range'Result =
- (for all I in Fst .. Lst => E.Get (Container, I) < Item);
- pragma Annotate (GNATprove, Inline_For_Proof, E_Bigger_Than_Range);
-
- function E_Smaller_Than_Range
- (Container : E.Sequence;
- Fst : Positive_Count_Type;
- Lst : Count_Type;
- Item : Element_Type) return Boolean
- with
- Global => null,
- Pre => Lst <= E.Length (Container),
- Post =>
- E_Smaller_Than_Range'Result =
- (for all I in Fst .. Lst => Item < E.Get (Container, I));
- pragma Annotate (GNATprove, Inline_For_Proof, E_Smaller_Than_Range);
-
- function E_Is_Find
- (Container : E.Sequence;
- Item : Element_Type;
- Position : Count_Type) return Boolean
- with
- Global => null,
- Pre => Position - 1 <= E.Length (Container),
- Post =>
- E_Is_Find'Result =
-
- ((if Position > 0 then
- E_Bigger_Than_Range (Container, 1, Position - 1, Item))
-
- and (if Position < E.Length (Container) then
- E_Smaller_Than_Range
- (Container,
- Position + 1,
- E.Length (Container),
- Item)));
- pragma Annotate (GNATprove, Inline_For_Proof, E_Is_Find);
-
- function Find
- (Container : E.Sequence;
- Item : Element_Type) return Count_Type
- -- Search for Item in Container
-
- with
- Global => null,
- Post =>
- (if Find'Result > 0 then
- Find'Result <= E.Length (Container)
- and Equivalent_Elements (Item, E.Get (Container, Find'Result)));
-
- function E_Elements_Included
- (Left : E.Sequence;
- Right : E.Sequence) return Boolean
- -- The elements of Left are contained in Right
-
- with
- Global => null,
- Post =>
- E_Elements_Included'Result =
- (for all I in 1 .. E.Length (Left) =>
- Find (Right, E.Get (Left, I)) > 0
- and then E.Get (Right, Find (Right, E.Get (Left, I))) =
- E.Get (Left, I));
- pragma Annotate (GNATprove, Inline_For_Proof, E_Elements_Included);
-
- function E_Elements_Included
- (Left : E.Sequence;
- Model : M.Set;
- Right : E.Sequence) return Boolean
- -- The elements of Container contained in Model are in Right
-
- with
- Global => null,
- Post =>
- E_Elements_Included'Result =
- (for all I in 1 .. E.Length (Left) =>
- (if M.Contains (Model, E.Get (Left, I)) then
- Find (Right, E.Get (Left, I)) > 0
- and then E.Get (Right, Find (Right, E.Get (Left, I))) =
- E.Get (Left, I)));
- pragma Annotate (GNATprove, Inline_For_Proof, E_Elements_Included);
-
- function E_Elements_Included
- (Container : E.Sequence;
- Model : M.Set;
- Left : E.Sequence;
- Right : E.Sequence) return Boolean
- -- The elements of Container contained in Model are in Left and others
- -- are in Right.
-
- with
- Global => null,
- Post =>
- E_Elements_Included'Result =
- (for all I in 1 .. E.Length (Container) =>
- (if M.Contains (Model, E.Get (Container, I)) then
- Find (Left, E.Get (Container, I)) > 0
- and then E.Get (Left, Find (Left, E.Get (Container, I))) =
- E.Get (Container, I)
- else
- Find (Right, E.Get (Container, I)) > 0
- and then E.Get (Right, Find (Right, E.Get (Container, I))) =
- E.Get (Container, I)));
- pragma Annotate (GNATprove, Inline_For_Proof, E_Elements_Included);
-
- package P is new Ada.Containers.Functional_Maps
- (Key_Type => Cursor,
- Element_Type => Positive_Count_Type,
- Equivalent_Keys => "=",
- Enable_Handling_Of_Equivalence => False);
-
- function "="
- (Left : P.Map;
- Right : P.Map) return Boolean renames P."=";
-
- function "<="
- (Left : P.Map;
- Right : P.Map) return Boolean renames P."<=";
-
- function P_Positions_Shifted
- (Small : P.Map;
- Big : P.Map;
- Cut : Positive_Count_Type;
- Count : Count_Type := 1) return Boolean
- with
- Global => null,
- Post =>
- P_Positions_Shifted'Result =
-
- -- Big contains all cursors of Small
-
- (P.Keys_Included (Small, Big)
-
- -- Cursors located before Cut are not moved, cursors located
- -- after are shifted by Count.
-
- and (for all I of Small =>
- (if P.Get (Small, I) < Cut then
- P.Get (Big, I) = P.Get (Small, I)
- else
- P.Get (Big, I) - Count = P.Get (Small, I)))
-
- -- New cursors of Big (if any) are between Cut and Cut - 1 +
- -- Count.
-
- and (for all I of Big =>
- P.Has_Key (Small, I)
- or P.Get (Big, I) - Count in Cut - Count .. Cut - 1));
-
- function Mapping_Preserved
- (E_Left : E.Sequence;
- E_Right : E.Sequence;
- P_Left : P.Map;
- P_Right : P.Map) return Boolean
- with
- Ghost,
- Global => null,
- Post =>
- (if Mapping_Preserved'Result then
-
- -- Right contains all the cursors of Left
-
- P.Keys_Included (P_Left, P_Right)
-
- -- Right contains all the elements of Left
-
- and E_Elements_Included (E_Left, E_Right)
-
- -- Mappings from cursors to elements induced by E_Left, P_Left
- -- and E_Right, P_Right are the same.
-
- and (for all C of P_Left =>
- E.Get (E_Left, P.Get (P_Left, C)) =
- E.Get (E_Right, P.Get (P_Right, C))));
-
- function Mapping_Preserved_Except
- (E_Left : E.Sequence;
- E_Right : E.Sequence;
- P_Left : P.Map;
- P_Right : P.Map;
- Position : Cursor) return Boolean
- with
- Ghost,
- Global => null,
- Post =>
- (if Mapping_Preserved_Except'Result then
-
- -- Right contains all the cursors of Left
-
- P.Keys_Included (P_Left, P_Right)
-
- -- Mappings from cursors to elements induced by E_Left, P_Left
- -- and E_Right, P_Right are the same except for Position.
-
- and (for all C of P_Left =>
- (if C /= Position then
- E.Get (E_Left, P.Get (P_Left, C)) =
- E.Get (E_Right, P.Get (P_Right, C)))));
-
- function Model (Container : Set) return M.Set with
- -- The high-level model of a set is a set of elements. Neither cursors
- -- nor order of elements are represented in this model. Elements are
- -- modeled up to equivalence.
-
- Ghost,
- Global => null,
- Post => M.Length (Model'Result) = Big (Length (Container));
-
- function Elements (Container : Set) return E.Sequence with
- -- The Elements sequence represents the underlying list structure of
- -- sets that is used for iteration. It stores the actual values of
- -- elements in the set. It does not model cursors.
-
- Ghost,
- Global => null,
- Post =>
- E.Length (Elements'Result) = Length (Container)
-
- -- It only contains keys contained in Model
-
- and (for all Item of Elements'Result =>
- M.Contains (Model (Container), Item))
-
- -- It contains all the elements contained in Model
-
- and (for all Item of Model (Container) =>
- (Find (Elements'Result, Item) > 0
- and then Equivalent_Elements
- (E.Get (Elements'Result, Find (Elements'Result, Item)),
- Item)))
-
- -- It is sorted in increasing order
-
- and (for all I in 1 .. Length (Container) =>
- Find (Elements'Result, E.Get (Elements'Result, I)) = I
- and
- E_Is_Find
- (Elements'Result, E.Get (Elements'Result, I), I));
- pragma Annotate (GNATprove, Iterable_For_Proof, "Model", Elements);
-
- function Positions (Container : Set) return P.Map with
- -- The Positions map is used to model cursors. It only contains valid
- -- cursors and maps them to their position in the container.
-
- Ghost,
- Global => null,
- Post =>
- not P.Has_Key (Positions'Result, No_Element)
-
- -- Positions of cursors are smaller than the container's length
-
- and then
- (for all I of Positions'Result =>
- P.Get (Positions'Result, I) in 1 .. Length (Container)
-
- -- No two cursors have the same position. Note that we do not
- -- state that there is a cursor in the map for each position, as
- -- it is rarely needed.
-
- and then
- (for all J of Positions'Result =>
- (if P.Get (Positions'Result, I) = P.Get (Positions'Result, J)
- then I = J)));
-
- procedure Lift_Abstraction_Level (Container : Set) with
- -- Lift_Abstraction_Level is a ghost procedure that does nothing but
- -- assume that we can access the same elements by iterating over
- -- positions or cursors.
- -- This information is not generally useful except when switching from
- -- a low-level, cursor-aware view of a container, to a high-level,
- -- position-based view.
-
- Ghost,
- Global => null,
- Post =>
- (for all Item of Elements (Container) =>
- (for some I of Positions (Container) =>
- E.Get (Elements (Container), P.Get (Positions (Container), I)) =
- Item));
-
- function Contains
- (C : M.Set;
- K : Element_Type) return Boolean renames M.Contains;
- -- To improve readability of contracts, we rename the function used to
- -- search for an element in the model to Contains.
-
- end Formal_Model;
- use Formal_Model;
-
- Empty_Set : constant Set;
-
- function "=" (Left, Right : Set) return Boolean with
- Global => null,
- Post =>
-
- -- If two sets are equal, they contain the same elements in the same
- -- order.
-
- (if "="'Result then Elements (Left) = Elements (Right)
-
- -- If they are different, then they do not contain the same elements
-
- else
- not E_Elements_Included (Elements (Left), Elements (Right))
- or not E_Elements_Included (Elements (Right), Elements (Left)));
-
- function Equivalent_Sets (Left, Right : Set) return Boolean with
- Global => null,
- Post => Equivalent_Sets'Result = (Model (Left) = Model (Right));
-
- function To_Set (New_Item : Element_Type) return Set with
- Global => null,
- Post =>
- M.Is_Singleton (Model (To_Set'Result), New_Item)
- and Length (To_Set'Result) = 1
- and E.Get (Elements (To_Set'Result), 1) = New_Item;
-
- function Is_Empty (Container : Set) return Boolean with
- Global => null,
- Post => Is_Empty'Result = (Length (Container) = 0);
-
- procedure Clear (Container : in out Set) with
- Global => null,
- Post => Length (Container) = 0 and M.Is_Empty (Model (Container));
-
- procedure Assign (Target : in out Set; Source : Set) with
- Global => null,
- Pre => Target.Capacity >= Length (Source),
- Post =>
- Model (Target) = Model (Source)
- and Elements (Target) = Elements (Source)
- and Length (Target) = Length (Source);
-
- function Copy (Source : Set; Capacity : Count_Type := 0) return Set with
- Global => null,
- Pre => Capacity = 0 or else Capacity >= Source.Capacity,
- Post =>
- Model (Copy'Result) = Model (Source)
- and Elements (Copy'Result) = Elements (Source)
- and Positions (Copy'Result) = Positions (Source)
- and (if Capacity = 0 then
- Copy'Result.Capacity = Source.Capacity
- else
- Copy'Result.Capacity = Capacity);
-
- function Element
- (Container : Set;
- Position : Cursor) return Element_Type
- with
- Global => null,
- Pre => Has_Element (Container, Position),
- Post =>
- Element'Result =
- E.Get (Elements (Container), P.Get (Positions (Container), Position));
- pragma Annotate (GNATprove, Inline_For_Proof, Element);
-
- procedure Replace_Element
- (Container : in out Set;
- Position : Cursor;
- New_Item : Element_Type)
- with
- Global => null,
- Pre => Has_Element (Container, Position),
- Post =>
- Length (Container) = Length (Container)'Old
-
- -- Position now maps to New_Item
-
- and Element (Container, Position) = New_Item
-
- -- New_Item is contained in Container
-
- and Contains (Model (Container), New_Item)
-
- -- Other elements are preserved
-
- and M.Included_Except
- (Model (Container)'Old,
- Model (Container),
- Element (Container, Position)'Old)
- and M.Included_Except
- (Model (Container),
- Model (Container)'Old,
- New_Item)
-
- -- Mapping from cursors to elements is preserved
-
- and Mapping_Preserved_Except
- (E_Left => Elements (Container)'Old,
- E_Right => Elements (Container),
- P_Left => Positions (Container)'Old,
- P_Right => Positions (Container),
- Position => Position)
- and Positions (Container) = Positions (Container)'Old;
-
- function Constant_Reference
- (Container : aliased Set;
- Position : Cursor) return not null access constant Element_Type
- with
- Global => null,
- Pre => Has_Element (Container, Position),
- Post =>
- Constant_Reference'Result.all =
- E.Get (Elements (Container), P.Get (Positions (Container), Position));
-
- procedure Move (Target : in out Set; Source : in out Set) with
- Global => null,
- Pre => Target.Capacity >= Length (Source),
- Post =>
- Model (Target) = Model (Source)'Old
- and Elements (Target) = Elements (Source)'Old
- and Length (Source)'Old = Length (Target)
- and Length (Source) = 0;
-
- procedure Insert
- (Container : in out Set;
- New_Item : Element_Type;
- Position : out Cursor;
- Inserted : out Boolean)
- with
- Global => null,
- Pre =>
- Length (Container) < Container.Capacity
- or Contains (Container, New_Item),
- Post =>
- Contains (Container, New_Item)
- and Has_Element (Container, Position)
- and Equivalent_Elements (Element (Container, Position), New_Item)
- and E_Is_Find
- (Elements (Container),
- New_Item,
- P.Get (Positions (Container), Position)),
- Contract_Cases =>
-
- -- If New_Item is already in Container, it is not modified and Inserted
- -- is set to False.
-
- (Contains (Container, New_Item) =>
- not Inserted
- and Model (Container) = Model (Container)'Old
- and Elements (Container) = Elements (Container)'Old
- and Positions (Container) = Positions (Container)'Old,
-
- -- Otherwise, New_Item is inserted in Container and Inserted is set to
- -- True
-
- others =>
- Inserted
- and Length (Container) = Length (Container)'Old + 1
-
- -- Position now maps to New_Item
-
- and Element (Container, Position) = New_Item
-
- -- Other elements are preserved
-
- and Model (Container)'Old <= Model (Container)
- and M.Included_Except
- (Model (Container),
- Model (Container)'Old,
- New_Item)
-
- -- The elements of Container located before Position are preserved
-
- and E.Range_Equal
- (Left => Elements (Container)'Old,
- Right => Elements (Container),
- Fst => 1,
- Lst => P.Get (Positions (Container), Position) - 1)
-
- -- Other elements are shifted by 1
-
- and E.Range_Shifted
- (Left => Elements (Container)'Old,
- Right => Elements (Container),
- Fst => P.Get (Positions (Container), Position),
- Lst => Length (Container)'Old,
- Offset => 1)
-
- -- A new cursor has been inserted at position Position in
- -- Container.
-
- and P_Positions_Shifted
- (Positions (Container)'Old,
- Positions (Container),
- Cut => P.Get (Positions (Container), Position)));
-
- procedure Insert
- (Container : in out Set;
- New_Item : Element_Type)
- with
- Global => null,
- Pre =>
- Length (Container) < Container.Capacity
- and then (not Contains (Container, New_Item)),
- Post =>
- Length (Container) = Length (Container)'Old + 1
- and Contains (Container, New_Item)
-
- -- New_Item is inserted in the set
-
- and E.Get (Elements (Container),
- Find (Elements (Container), New_Item)) = New_Item
-
- -- Other mappings are preserved
-
- and Model (Container)'Old <= Model (Container)
- and M.Included_Except
- (Model (Container),
- Model (Container)'Old,
- New_Item)
-
- -- The elements of Container located before New_Item are preserved
-
- and E.Range_Equal
- (Left => Elements (Container)'Old,
- Right => Elements (Container),
- Fst => 1,
- Lst => Find (Elements (Container), New_Item) - 1)
-
- -- Other elements are shifted by 1
-
- and E.Range_Shifted
- (Left => Elements (Container)'Old,
- Right => Elements (Container),
- Fst => Find (Elements (Container), New_Item),
- Lst => Length (Container)'Old,
- Offset => 1)
-
- -- A new cursor has been inserted in Container
-
- and P_Positions_Shifted
- (Positions (Container)'Old,
- Positions (Container),
- Cut => Find (Elements (Container), New_Item));
-
- procedure Include
- (Container : in out Set;
- New_Item : Element_Type)
- with
- Global => null,
- Pre =>
- Length (Container) < Container.Capacity
- or Contains (Container, New_Item),
- Post => Contains (Container, New_Item),
- Contract_Cases =>
-
- -- If New_Item is already in Container
-
- (Contains (Container, New_Item) =>
-
- -- Elements are preserved
-
- Model (Container)'Old = Model (Container)
-
- -- Cursors are preserved
-
- and Positions (Container) = Positions (Container)'Old
-
- -- The element equivalent to New_Item in Container is replaced by
- -- New_Item.
-
- and E.Get (Elements (Container),
- Find (Elements (Container), New_Item)) = New_Item
-
- and E.Equal_Except
- (Elements (Container)'Old,
- Elements (Container),
- Find (Elements (Container), New_Item)),
-
- -- Otherwise, New_Item is inserted in Container
-
- others =>
- Length (Container) = Length (Container)'Old + 1
-
- -- Other elements are preserved
-
- and Model (Container)'Old <= Model (Container)
- and M.Included_Except
- (Model (Container),
- Model (Container)'Old,
- New_Item)
-
- -- New_Item is inserted in Container
-
- and E.Get (Elements (Container),
- Find (Elements (Container), New_Item)) = New_Item
-
- -- The Elements of Container located before New_Item are preserved
-
- and E.Range_Equal
- (Left => Elements (Container)'Old,
- Right => Elements (Container),
- Fst => 1,
- Lst => Find (Elements (Container), New_Item) - 1)
-
- -- Other Elements are shifted by 1
-
- and E.Range_Shifted
- (Left => Elements (Container)'Old,
- Right => Elements (Container),
- Fst => Find (Elements (Container), New_Item),
- Lst => Length (Container)'Old,
- Offset => 1)
-
- -- A new cursor has been inserted in Container
-
- and P_Positions_Shifted
- (Positions (Container)'Old,
- Positions (Container),
- Cut => Find (Elements (Container), New_Item)));
-
- procedure Replace
- (Container : in out Set;
- New_Item : Element_Type)
- with
- Global => null,
- Pre => Contains (Container, New_Item),
- Post =>
-
- -- Elements are preserved
-
- Model (Container)'Old = Model (Container)
-
- -- Cursors are preserved
-
- and Positions (Container) = Positions (Container)'Old
-
- -- The element equivalent to New_Item in Container is replaced by
- -- New_Item.
-
- and E.Get (Elements (Container),
- Find (Elements (Container), New_Item)) = New_Item
- and E.Equal_Except
- (Elements (Container)'Old,
- Elements (Container),
- Find (Elements (Container), New_Item));
-
- procedure Exclude
- (Container : in out Set;
- Item : Element_Type)
- with
- Global => null,
- Post => not Contains (Container, Item),
- Contract_Cases =>
-
- -- If Item is not in Container, nothing is changed
-
- (not Contains (Container, Item) =>
- Model (Container) = Model (Container)'Old
- and Elements (Container) = Elements (Container)'Old
- and Positions (Container) = Positions (Container)'Old,
-
- -- Otherwise, Item is removed from Container
-
- others =>
- Length (Container) = Length (Container)'Old - 1
-
- -- Other elements are preserved
-
- and Model (Container) <= Model (Container)'Old
- and M.Included_Except
- (Model (Container)'Old,
- Model (Container),
- Item)
-
- -- The elements of Container located before Item are preserved
-
- and E.Range_Equal
- (Left => Elements (Container)'Old,
- Right => Elements (Container),
- Fst => 1,
- Lst => Find (Elements (Container), Item)'Old - 1)
-
- -- The elements located after Item are shifted by 1
-
- and E.Range_Shifted
- (Left => Elements (Container),
- Right => Elements (Container)'Old,
- Fst => Find (Elements (Container), Item)'Old,
- Lst => Length (Container),
- Offset => 1)
-
- -- A cursor has been removed from Container
-
- and P_Positions_Shifted
- (Positions (Container),
- Positions (Container)'Old,
- Cut => Find (Elements (Container), Item)'Old));
-
- procedure Delete
- (Container : in out Set;
- Item : Element_Type)
- with
- Global => null,
- Pre => Contains (Container, Item),
- Post =>
- Length (Container) = Length (Container)'Old - 1
-
- -- Item is no longer in Container
-
- and not Contains (Container, Item)
-
- -- Other elements are preserved
-
- and Model (Container) <= Model (Container)'Old
- and M.Included_Except
- (Model (Container)'Old,
- Model (Container),
- Item)
-
- -- The elements of Container located before Item are preserved
-
- and E.Range_Equal
- (Left => Elements (Container)'Old,
- Right => Elements (Container),
- Fst => 1,
- Lst => Find (Elements (Container), Item)'Old - 1)
-
- -- The elements located after Item are shifted by 1
-
- and E.Range_Shifted
- (Left => Elements (Container),
- Right => Elements (Container)'Old,
- Fst => Find (Elements (Container), Item)'Old,
- Lst => Length (Container),
- Offset => 1)
-
- -- A cursor has been removed from Container
-
- and P_Positions_Shifted
- (Positions (Container),
- Positions (Container)'Old,
- Cut => Find (Elements (Container), Item)'Old);
-
- procedure Delete
- (Container : in out Set;
- Position : in out Cursor)
- with
- Global => null,
- Depends => (Container =>+ Position, Position => null),
- Pre => Has_Element (Container, Position),
- Post =>
- Position = No_Element
- and Length (Container) = Length (Container)'Old - 1
-
- -- The element at position Position is no longer in Container
-
- and not Contains (Container, Element (Container, Position)'Old)
- and not P.Has_Key (Positions (Container), Position'Old)
-
- -- Other elements are preserved
-
- and Model (Container) <= Model (Container)'Old
- and M.Included_Except
- (Model (Container)'Old,
- Model (Container),
- Element (Container, Position)'Old)
-
- -- The elements of Container located before Position are preserved.
-
- and E.Range_Equal
- (Left => Elements (Container)'Old,
- Right => Elements (Container),
- Fst => 1,
- Lst => P.Get (Positions (Container)'Old, Position'Old) - 1)
-
- -- The elements located after Position are shifted by 1
-
- and E.Range_Shifted
- (Left => Elements (Container),
- Right => Elements (Container)'Old,
- Fst => P.Get (Positions (Container)'Old, Position'Old),
- Lst => Length (Container),
- Offset => 1)
-
- -- Position has been removed from Container
-
- and P_Positions_Shifted
- (Positions (Container),
- Positions (Container)'Old,
- Cut => P.Get (Positions (Container)'Old, Position'Old));
-
- procedure Delete_First (Container : in out Set) with
- Global => null,
- Contract_Cases =>
- (Length (Container) = 0 => Length (Container) = 0,
- others =>
- Length (Container) = Length (Container)'Old - 1
-
- -- The first element has been removed from Container
-
- and not Contains (Container, First_Element (Container)'Old)
-
- -- Other elements are preserved
-
- and Model (Container) <= Model (Container)'Old
- and M.Included_Except
- (Model (Container)'Old,
- Model (Container),
- First_Element (Container)'Old)
-
- -- Other elements are shifted by 1
-
- and E.Range_Shifted
- (Left => Elements (Container),
- Right => Elements (Container)'Old,
- Fst => 1,
- Lst => Length (Container),
- Offset => 1)
-
- -- First has been removed from Container
-
- and P_Positions_Shifted
- (Positions (Container),
- Positions (Container)'Old,
- Cut => 1));
-
- procedure Delete_Last (Container : in out Set) with
- Global => null,
- Contract_Cases =>
- (Length (Container) = 0 => Length (Container) = 0,
- others =>
- Length (Container) = Length (Container)'Old - 1
-
- -- The last element has been removed from Container
-
- and not Contains (Container, Last_Element (Container)'Old)
-
- -- Other elements are preserved
-
- and Model (Container) <= Model (Container)'Old
- and M.Included_Except
- (Model (Container)'Old,
- Model (Container),
- Last_Element (Container)'Old)
-
- -- Others elements of Container are preserved
-
- and E.Range_Equal
- (Left => Elements (Container)'Old,
- Right => Elements (Container),
- Fst => 1,
- Lst => Length (Container))
-
- -- Last cursor has been removed from Container
-
- and Positions (Container) <= Positions (Container)'Old);
-
- procedure Union (Target : in out Set; Source : Set) with
- Global => null,
- Pre =>
- Length (Source) - Length (Target and Source) <=
- Target.Capacity - Length (Target),
- Post =>
- Big (Length (Target)) = Big (Length (Target)'Old)
- - M.Num_Overlaps (Model (Target)'Old, Model (Source))
- + Big (Length (Source))
-
- -- Elements already in Target are still in Target
-
- and Model (Target)'Old <= Model (Target)
-
- -- Elements of Source are included in Target
-
- and Model (Source) <= Model (Target)
-
- -- Elements of Target come from either Source or Target
-
- and
- M.Included_In_Union
- (Model (Target), Model (Source), Model (Target)'Old)
-
- -- Actual value of elements come from either Left or Right
-
- and
- E_Elements_Included
- (Elements (Target),
- Model (Target)'Old,
- Elements (Target)'Old,
- Elements (Source))
- and
- E_Elements_Included
- (Elements (Target)'Old, Model (Target)'Old, Elements (Target))
- and
- E_Elements_Included
- (Elements (Source),
- Model (Target)'Old,
- Elements (Source),
- Elements (Target))
-
- -- Mapping from cursors of Target to elements is preserved
-
- and Mapping_Preserved
- (E_Left => Elements (Target)'Old,
- E_Right => Elements (Target),
- P_Left => Positions (Target)'Old,
- P_Right => Positions (Target));
-
- function Union (Left, Right : Set) return Set with
- Global => null,
- Pre => Length (Left) <= Count_Type'Last - Length (Right),
- Post =>
- Big (Length (Union'Result)) = Big (Length (Left))
- - M.Num_Overlaps (Model (Left), Model (Right))
- + Big (Length (Right))
-
- -- Elements of Left and Right are in the result of Union
-
- and Model (Left) <= Model (Union'Result)
- and Model (Right) <= Model (Union'Result)
-
- -- Elements of the result of union come from either Left or Right
-
- and
- M.Included_In_Union
- (Model (Union'Result), Model (Left), Model (Right))
-
- -- Actual value of elements come from either Left or Right
-
- and
- E_Elements_Included
- (Elements (Union'Result),
- Model (Left),
- Elements (Left),
- Elements (Right))
- and
- E_Elements_Included
- (Elements (Left), Model (Left), Elements (Union'Result))
- and
- E_Elements_Included
- (Elements (Right),
- Model (Left),
- Elements (Right),
- Elements (Union'Result));
-
- function "or" (Left, Right : Set) return Set renames Union;
-
- procedure Intersection (Target : in out Set; Source : Set) with
- Global => null,
- Post =>
- Big (Length (Target)) =
- M.Num_Overlaps (Model (Target)'Old, Model (Source))
-
- -- Elements of Target were already in Target
-
- and Model (Target) <= Model (Target)'Old
-
- -- Elements of Target are in Source
-
- and Model (Target) <= Model (Source)
-
- -- Elements both in Source and Target are in the intersection
-
- and
- M.Includes_Intersection
- (Model (Target), Model (Source), Model (Target)'Old)
-
- -- Actual value of elements of Target is preserved
-
- and E_Elements_Included (Elements (Target), Elements (Target)'Old)
- and
- E_Elements_Included
- (Elements (Target)'Old, Model (Source), Elements (Target))
-
- -- Mapping from cursors of Target to elements is preserved
-
- and Mapping_Preserved
- (E_Left => Elements (Target),
- E_Right => Elements (Target)'Old,
- P_Left => Positions (Target),
- P_Right => Positions (Target)'Old);
-
- function Intersection (Left, Right : Set) return Set with
- Global => null,
- Post =>
- Big (Length (Intersection'Result)) =
- M.Num_Overlaps (Model (Left), Model (Right))
-
- -- Elements in the result of Intersection are in Left and Right
-
- and Model (Intersection'Result) <= Model (Left)
- and Model (Intersection'Result) <= Model (Right)
-
- -- Elements both in Left and Right are in the result of Intersection
-
- and
- M.Includes_Intersection
- (Model (Intersection'Result), Model (Left), Model (Right))
-
- -- Actual value of elements come from Left
-
- and
- E_Elements_Included
- (Elements (Intersection'Result), Elements (Left))
- and
- E_Elements_Included
- (Elements (Left), Model (Right), Elements (Intersection'Result));
-
- function "and" (Left, Right : Set) return Set renames Intersection;
-
- procedure Difference (Target : in out Set; Source : Set) with
- Global => null,
- Post =>
- Big (Length (Target)) = Big (Length (Target)'Old) -
- M.Num_Overlaps (Model (Target)'Old, Model (Source))
-
- -- Elements of Target were already in Target
-
- and Model (Target) <= Model (Target)'Old
-
- -- Elements of Target are not in Source
-
- and M.No_Overlap (Model (Target), Model (Source))
-
- -- Elements in Target but not in Source are in the difference
-
- and
- M.Included_In_Union
- (Model (Target)'Old, Model (Target), Model (Source))
-
- -- Actual value of elements of Target is preserved
-
- and E_Elements_Included (Elements (Target), Elements (Target)'Old)
- and
- E_Elements_Included
- (Elements (Target)'Old, Model (Target), Elements (Target))
-
- -- Mapping from cursors of Target to elements is preserved
-
- and Mapping_Preserved
- (E_Left => Elements (Target),
- E_Right => Elements (Target)'Old,
- P_Left => Positions (Target),
- P_Right => Positions (Target)'Old);
-
- function Difference (Left, Right : Set) return Set with
- Global => null,
- Post =>
- Big (Length (Difference'Result)) = Big (Length (Left)) -
- M.Num_Overlaps (Model (Left), Model (Right))
-
- -- Elements of the result of Difference are in Left
-
- and Model (Difference'Result) <= Model (Left)
-
- -- Elements of the result of Difference are in Right
-
- and M.No_Overlap (Model (Difference'Result), Model (Right))
-
- -- Elements in Left but not in Right are in the difference
-
- and
- M.Included_In_Union
- (Model (Left), Model (Difference'Result), Model (Right))
-
- -- Actual value of elements come from Left
-
- and
- E_Elements_Included (Elements (Difference'Result), Elements (Left))
- and
- E_Elements_Included
- (Elements (Left),
- Model (Difference'Result),
- Elements (Difference'Result));
-
- function "-" (Left, Right : Set) return Set renames Difference;
-
- procedure Symmetric_Difference (Target : in out Set; Source : Set) with
- Global => null,
- Pre =>
- Length (Source) - Length (Target and Source) <=
- Target.Capacity - Length (Target) + Length (Target and Source),
- Post =>
- Big (Length (Target)) = Big (Length (Target)'Old) -
- 2 * M.Num_Overlaps (Model (Target)'Old, Model (Source)) +
- Big (Length (Source))
-
- -- Elements of the difference were not both in Source and in Target
-
- and M.Not_In_Both (Model (Target), Model (Target)'Old, Model (Source))
-
- -- Elements in Target but not in Source are in the difference
-
- and
- M.Included_In_Union
- (Model (Target)'Old, Model (Target), Model (Source))
-
- -- Elements in Source but not in Target are in the difference
-
- and
- M.Included_In_Union
- (Model (Source), Model (Target), Model (Target)'Old)
-
- -- Actual value of elements come from either Left or Right
-
- and
- E_Elements_Included
- (Elements (Target),
- Model (Target)'Old,
- Elements (Target)'Old,
- Elements (Source))
- and
- E_Elements_Included
- (Elements (Target)'Old, Model (Target), Elements (Target))
- and
- E_Elements_Included
- (Elements (Source), Model (Target), Elements (Target));
-
- function Symmetric_Difference (Left, Right : Set) return Set with
- Global => null,
- Pre => Length (Left) <= Count_Type'Last - Length (Right),
- Post =>
- Big (Length (Symmetric_Difference'Result)) = Big (Length (Left)) -
- 2 * M.Num_Overlaps (Model (Left), Model (Right)) +
- Big (Length (Right))
-
- -- Elements of the difference were not both in Left and Right
-
- and
- M.Not_In_Both
- (Model (Symmetric_Difference'Result), Model (Left), Model (Right))
-
- -- Elements in Left but not in Right are in the difference
-
- and
- M.Included_In_Union
- (Model (Left), Model (Symmetric_Difference'Result), Model (Right))
-
- -- Elements in Right but not in Left are in the difference
-
- and
- M.Included_In_Union
- (Model (Right), Model (Symmetric_Difference'Result), Model (Left))
-
- -- Actual value of elements come from either Left or Right
-
- and
- E_Elements_Included
- (Elements (Symmetric_Difference'Result),
- Model (Left),
- Elements (Left),
- Elements (Right))
- and
- E_Elements_Included
- (Elements (Left),
- Model (Symmetric_Difference'Result),
- Elements (Symmetric_Difference'Result))
- and
- E_Elements_Included
- (Elements (Right),
- Model (Symmetric_Difference'Result),
- Elements (Symmetric_Difference'Result));
-
- function "xor" (Left, Right : Set) return Set
- renames Symmetric_Difference;
-
- function Overlap (Left, Right : Set) return Boolean with
- Global => null,
- Post =>
- Overlap'Result = not (M.No_Overlap (Model (Left), Model (Right)));
-
- function Is_Subset (Subset : Set; Of_Set : Set) return Boolean with
- Global => null,
- Post => Is_Subset'Result = (Model (Subset) <= Model (Of_Set));
-
- function First (Container : Set) return Cursor with
- Global => null,
- Contract_Cases =>
- (Length (Container) = 0 =>
- First'Result = No_Element,
-
- others =>
- Has_Element (Container, First'Result)
- and P.Get (Positions (Container), First'Result) = 1);
-
- function First_Element (Container : Set) return Element_Type with
- Global => null,
- Pre => not Is_Empty (Container),
- Post =>
- First_Element'Result = E.Get (Elements (Container), 1)
- and E_Smaller_Than_Range
- (Elements (Container),
- 2,
- Length (Container),
- First_Element'Result);
-
- function Last (Container : Set) return Cursor with
- Global => null,
- Contract_Cases =>
- (Length (Container) = 0 =>
- Last'Result = No_Element,
-
- others =>
- Has_Element (Container, Last'Result)
- and P.Get (Positions (Container), Last'Result) =
- Length (Container));
-
- function Last_Element (Container : Set) return Element_Type with
- Global => null,
- Pre => not Is_Empty (Container),
- Post =>
- Last_Element'Result = E.Get (Elements (Container), Length (Container))
- and E_Bigger_Than_Range
- (Elements (Container),
- 1,
- Length (Container) - 1,
- Last_Element'Result);
-
- function Next (Container : Set; Position : Cursor) return Cursor with
- Global => null,
- Pre =>
- Has_Element (Container, Position) or else Position = No_Element,
- Contract_Cases =>
- (Position = No_Element
- or else P.Get (Positions (Container), Position) = Length (Container)
- =>
- Next'Result = No_Element,
-
- others =>
- Has_Element (Container, Next'Result)
- and then P.Get (Positions (Container), Next'Result) =
- P.Get (Positions (Container), Position) + 1);
-
- procedure Next (Container : Set; Position : in out Cursor) with
- Global => null,
- Pre =>
- Has_Element (Container, Position) or else Position = No_Element,
- Contract_Cases =>
- (Position = No_Element
- or else P.Get (Positions (Container), Position) = Length (Container)
- =>
- Position = No_Element,
-
- others =>
- Has_Element (Container, Position)
- and then P.Get (Positions (Container), Position) =
- P.Get (Positions (Container), Position'Old) + 1);
-
- function Previous (Container : Set; Position : Cursor) return Cursor with
- Global => null,
- Pre =>
- Has_Element (Container, Position) or else Position = No_Element,
- Contract_Cases =>
- (Position = No_Element
- or else P.Get (Positions (Container), Position) = 1
- =>
- Previous'Result = No_Element,
-
- others =>
- Has_Element (Container, Previous'Result)
- and then P.Get (Positions (Container), Previous'Result) =
- P.Get (Positions (Container), Position) - 1);
-
- procedure Previous (Container : Set; Position : in out Cursor) with
- Global => null,
- Pre =>
- Has_Element (Container, Position) or else Position = No_Element,
- Contract_Cases =>
- (Position = No_Element
- or else P.Get (Positions (Container), Position) = 1
- =>
- Position = No_Element,
-
- others =>
- Has_Element (Container, Position)
- and then P.Get (Positions (Container), Position) =
- P.Get (Positions (Container), Position'Old) - 1);
-
- function Find (Container : Set; Item : Element_Type) return Cursor with
- Global => null,
- Contract_Cases =>
-
- -- If Item is not contained in Container, Find returns No_Element
-
- (not Contains (Model (Container), Item) =>
- not P.Has_Key (Positions (Container), Find'Result)
- and Find'Result = No_Element,
-
- -- Otherwise, Find returns a valid cursor in Container
-
- others =>
- P.Has_Key (Positions (Container), Find'Result)
- and P.Get (Positions (Container), Find'Result) =
- Find (Elements (Container), Item)
-
- -- The element designated by the result of Find is Item
-
- and Equivalent_Elements
- (Element (Container, Find'Result), Item));
-
- function Floor (Container : Set; Item : Element_Type) return Cursor with
- Global => null,
- Contract_Cases =>
- (Length (Container) = 0 or else Item < First_Element (Container) =>
- Floor'Result = No_Element,
- others =>
- Has_Element (Container, Floor'Result)
- and
- not (Item < E.Get (Elements (Container),
- P.Get (Positions (Container), Floor'Result)))
- and E_Is_Find
- (Elements (Container),
- Item,
- P.Get (Positions (Container), Floor'Result)));
-
- function Ceiling (Container : Set; Item : Element_Type) return Cursor with
- Global => null,
- Contract_Cases =>
- (Length (Container) = 0 or else Last_Element (Container) < Item =>
- Ceiling'Result = No_Element,
- others =>
- Has_Element (Container, Ceiling'Result)
- and
- not (E.Get (Elements (Container),
- P.Get (Positions (Container), Ceiling'Result)) <
- Item)
- and E_Is_Find
- (Elements (Container),
- Item,
- P.Get (Positions (Container), Ceiling'Result)));
-
- function Contains (Container : Set; Item : Element_Type) return Boolean with
- Global => null,
- Post => Contains'Result = Contains (Model (Container), Item);
- pragma Annotate (GNATprove, Inline_For_Proof, Contains);
-
- function Has_Element (Container : Set; Position : Cursor) return Boolean
- with
- Global => null,
- Post =>
- Has_Element'Result = P.Has_Key (Positions (Container), Position);
- pragma Annotate (GNATprove, Inline_For_Proof, Has_Element);
-
- generic
- type Key_Type (<>) is private;
-
- with function Key (Element : Element_Type) return Key_Type;
-
- with function "<" (Left, Right : Key_Type) return Boolean is <>;
-
- package Generic_Keys with SPARK_Mode is
-
- function Equivalent_Keys (Left, Right : Key_Type) return Boolean with
- Global => null,
- Post =>
- Equivalent_Keys'Result = (not (Left < Right) and not (Right < Left));
- pragma Annotate (GNATprove, Inline_For_Proof, Equivalent_Keys);
-
- package Formal_Model with Ghost is
- function E_Bigger_Than_Range
- (Container : E.Sequence;
- Fst : Positive_Count_Type;
- Lst : Count_Type;
- Key : Key_Type) return Boolean
- with
- Global => null,
- Pre => Lst <= E.Length (Container),
- Post =>
- E_Bigger_Than_Range'Result =
- (for all I in Fst .. Lst =>
- Generic_Keys.Key (E.Get (Container, I)) < Key);
- pragma Annotate (GNATprove, Inline_For_Proof, E_Bigger_Than_Range);
-
- function E_Smaller_Than_Range
- (Container : E.Sequence;
- Fst : Positive_Count_Type;
- Lst : Count_Type;
- Key : Key_Type) return Boolean
- with
- Global => null,
- Pre => Lst <= E.Length (Container),
- Post =>
- E_Smaller_Than_Range'Result =
- (for all I in Fst .. Lst =>
- Key < Generic_Keys.Key (E.Get (Container, I)));
- pragma Annotate (GNATprove, Inline_For_Proof, E_Smaller_Than_Range);
-
- function E_Is_Find
- (Container : E.Sequence;
- Key : Key_Type;
- Position : Count_Type) return Boolean
- with
- Global => null,
- Pre => Position - 1 <= E.Length (Container),
- Post =>
- E_Is_Find'Result =
-
- ((if Position > 0 then
- E_Bigger_Than_Range (Container, 1, Position - 1, Key))
-
- and (if Position < E.Length (Container) then
- E_Smaller_Than_Range
- (Container,
- Position + 1,
- E.Length (Container),
- Key)));
- pragma Annotate (GNATprove, Inline_For_Proof, E_Is_Find);
-
- function Find
- (Container : E.Sequence;
- Key : Key_Type) return Count_Type
- -- Search for Key in Container
-
- with
- Global => null,
- Post =>
- (if Find'Result > 0 then
- Find'Result <= E.Length (Container)
- and Equivalent_Keys
- (Key, Generic_Keys.Key (E.Get (Container, Find'Result)))
- and E_Is_Find (Container, Key, Find'Result));
-
- function M_Included_Except
- (Left : M.Set;
- Right : M.Set;
- Key : Key_Type) return Boolean
- with
- Global => null,
- Post =>
- M_Included_Except'Result =
- (for all E of Left =>
- Contains (Right, E)
- or Equivalent_Keys (Generic_Keys.Key (E), Key));
- end Formal_Model;
- use Formal_Model;
-
- function Key (Container : Set; Position : Cursor) return Key_Type with
- Global => null,
- Post => Key'Result = Key (Element (Container, Position));
- pragma Annotate (GNATprove, Inline_For_Proof, Key);
-
- function Element (Container : Set; Key : Key_Type) return Element_Type
- with
- Global => null,
- Pre => Contains (Container, Key),
- Post =>
- Element'Result = Element (Container, Find (Container, Key));
- pragma Annotate (GNATprove, Inline_For_Proof, Element);
-
- procedure Replace
- (Container : in out Set;
- Key : Key_Type;
- New_Item : Element_Type)
- with
- Global => null,
- Pre => Contains (Container, Key),
- Post =>
- Length (Container) = Length (Container)'Old
-
- -- Key now maps to New_Item
-
- and Element (Container, Key) = New_Item
-
- -- New_Item is contained in Container
-
- and Contains (Model (Container), New_Item)
-
- -- Other elements are preserved
-
- and M_Included_Except
- (Model (Container)'Old,
- Model (Container),
- Key)
- and M.Included_Except
- (Model (Container),
- Model (Container)'Old,
- New_Item)
-
- -- Mapping from cursors to elements is preserved
-
- and Mapping_Preserved_Except
- (E_Left => Elements (Container)'Old,
- E_Right => Elements (Container),
- P_Left => Positions (Container)'Old,
- P_Right => Positions (Container),
- Position => Find (Container, Key))
- and Positions (Container) = Positions (Container)'Old;
-
- procedure Exclude (Container : in out Set; Key : Key_Type) with
- Global => null,
- Post => not Contains (Container, Key),
- Contract_Cases =>
-
- -- If Key is not in Container, nothing is changed
-
- (not Contains (Container, Key) =>
- Model (Container) = Model (Container)'Old
- and Elements (Container) = Elements (Container)'Old
- and Positions (Container) = Positions (Container)'Old,
-
- -- Otherwise, Key is removed from Container
-
- others =>
- Length (Container) = Length (Container)'Old - 1
-
- -- Other elements are preserved
-
- and Model (Container) <= Model (Container)'Old
- and M_Included_Except
- (Model (Container)'Old,
- Model (Container),
- Key)
-
- -- The elements of Container located before Key are preserved
-
- and E.Range_Equal
- (Left => Elements (Container)'Old,
- Right => Elements (Container),
- Fst => 1,
- Lst => Find (Elements (Container), Key)'Old - 1)
-
- -- The elements located after Key are shifted by 1
-
- and E.Range_Shifted
- (Left => Elements (Container),
- Right => Elements (Container)'Old,
- Fst => Find (Elements (Container), Key)'Old,
- Lst => Length (Container),
- Offset => 1)
-
- -- A cursor has been removed from Container
-
- and P_Positions_Shifted
- (Positions (Container),
- Positions (Container)'Old,
- Cut => Find (Elements (Container), Key)'Old));
-
- procedure Delete (Container : in out Set; Key : Key_Type) with
- Global => null,
- Pre => Contains (Container, Key),
- Post =>
- Length (Container) = Length (Container)'Old - 1
-
- -- Key is no longer in Container
-
- and not Contains (Container, Key)
-
- -- Other elements are preserved
-
- and Model (Container) <= Model (Container)'Old
- and M_Included_Except
- (Model (Container)'Old,
- Model (Container),
- Key)
-
- -- The elements of Container located before Key are preserved
-
- and E.Range_Equal
- (Left => Elements (Container)'Old,
- Right => Elements (Container),
- Fst => 1,
- Lst => Find (Elements (Container), Key)'Old - 1)
-
- -- The elements located after Key are shifted by 1
-
- and E.Range_Shifted
- (Left => Elements (Container),
- Right => Elements (Container)'Old,
- Fst => Find (Elements (Container), Key)'Old,
- Lst => Length (Container),
- Offset => 1)
-
- -- A cursor has been removed from Container
-
- and P_Positions_Shifted
- (Positions (Container),
- Positions (Container)'Old,
- Cut => Find (Elements (Container), Key)'Old);
-
- function Find (Container : Set; Key : Key_Type) return Cursor with
- Global => null,
- Contract_Cases =>
-
- -- If Key is not contained in Container, Find returns No_Element
-
- ((for all E of Model (Container) =>
- not Equivalent_Keys (Key, Generic_Keys.Key (E))) =>
- not P.Has_Key (Positions (Container), Find'Result)
- and Find'Result = No_Element,
-
- -- Otherwise, Find returns a valid cursor in Container
-
- others =>
- P.Has_Key (Positions (Container), Find'Result)
- and P.Get (Positions (Container), Find'Result) =
- Find (Elements (Container), Key)
-
- -- The element designated by the result of Find is Key
-
- and Equivalent_Keys
- (Generic_Keys.Key (Element (Container, Find'Result)), Key));
-
- function Floor (Container : Set; Key : Key_Type) return Cursor with
- Global => null,
- Contract_Cases =>
- (Length (Container) = 0
- or else Key < Generic_Keys.Key (First_Element (Container)) =>
- Floor'Result = No_Element,
- others =>
- Has_Element (Container, Floor'Result)
- and
- not (Key <
- Generic_Keys.Key
- (E.Get (Elements (Container),
- P.Get (Positions (Container), Floor'Result))))
- and E_Is_Find
- (Elements (Container),
- Key,
- P.Get (Positions (Container), Floor'Result)));
-
- function Ceiling (Container : Set; Key : Key_Type) return Cursor with
- Global => null,
- Contract_Cases =>
- (Length (Container) = 0
- or else Generic_Keys.Key (Last_Element (Container)) < Key =>
- Ceiling'Result = No_Element,
- others =>
- Has_Element (Container, Ceiling'Result)
- and
- not (Generic_Keys.Key
- (E.Get (Elements (Container),
- P.Get (Positions (Container), Ceiling'Result)))
- < Key)
- and E_Is_Find
- (Elements (Container),
- Key,
- P.Get (Positions (Container), Ceiling'Result)));
-
- function Contains (Container : Set; Key : Key_Type) return Boolean with
- Global => null,
- Post =>
- Contains'Result =
- (for some E of Model (Container) =>
- Equivalent_Keys (Key, Generic_Keys.Key (E)));
-
- end Generic_Keys;
-
-private
- pragma SPARK_Mode (Off);
-
- pragma Inline (Next);
- pragma Inline (Previous);
-
- type Node_Type is record
- Has_Element : Boolean := False;
- Parent : Count_Type := 0;
- Left : Count_Type := 0;
- Right : Count_Type := 0;
- Color : Red_Black_Trees.Color_Type;
- Element : aliased Element_Type;
- end record;
-
- package Tree_Types is
- new Red_Black_Trees.Generic_Bounded_Tree_Types (Node_Type);
-
- type Set (Capacity : Count_Type) is record
- Content : Tree_Types.Tree_Type (Capacity);
- end record;
-
- use Red_Black_Trees;
+package Ada.Containers.Formal_Ordered_Sets with SPARK_Mode is
- Empty_Set : constant Set := (Capacity => 0, others => <>);
+ pragma Compile_Time_Error
+ (True,
+ "This package has been moved to the SPARK library shipped with any"
+ & " SPARK release starting with version 23.");
end Ada.Containers.Formal_Ordered_Sets;
diff --git a/gcc/ada/libgnat/a-cofove.adb b/gcc/ada/libgnat/a-cofove.adb
deleted file mode 100644
index c921184..0000000
--- a/gcc/ada/libgnat/a-cofove.adb
+++ /dev/null
@@ -1,1311 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT LIBRARY COMPONENTS --
--- --
--- A D A . C O N T A I N E R S . F O R M A L _ V E C T O R S --
--- --
--- B o d y --
--- --
--- Copyright (C) 2010-2022, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
-------------------------------------------------------------------------------
-
-with Ada.Containers.Generic_Array_Sort;
-
-with System; use type System.Address;
-
-package body Ada.Containers.Formal_Vectors with
- SPARK_Mode => Off
-is
-
- subtype Int is Long_Long_Integer;
-
- function To_Array_Index (Index : Index_Type'Base) return Count_Type'Base;
-
- procedure Insert_Space
- (Container : in out Vector;
- Before : Extended_Index;
- Count : Count_Type := 1);
-
- ---------
- -- "=" --
- ---------
-
- function "=" (Left : Vector; Right : Vector) return Boolean is
- begin
- if Left'Address = Right'Address then
- return True;
- end if;
-
- if Length (Left) /= Length (Right) then
- return False;
- end if;
-
- for J in 1 .. Length (Left) loop
- if Left.Elements (J) /= Right.Elements (J) then
- return False;
- end if;
- end loop;
-
- return True;
- end "=";
-
- ------------
- -- Append --
- ------------
-
- procedure Append (Container : in out Vector; New_Item : Vector) is
- begin
- if Is_Empty (New_Item) then
- return;
- end if;
-
- if Container.Last >= Index_Type'Last then
- raise Constraint_Error with "vector is already at its maximum length";
- end if;
-
- Insert (Container, Container.Last + 1, New_Item);
- end Append;
-
- procedure Append (Container : in out Vector; New_Item : Element_Type) is
- begin
- Append (Container, New_Item, 1);
- end Append;
-
- procedure Append
- (Container : in out Vector;
- New_Item : Element_Type;
- Count : Count_Type)
- is
- begin
- if Count = 0 then
- return;
- end if;
-
- if Container.Last >= Index_Type'Last then
- raise Constraint_Error with "vector is already at its maximum length";
- end if;
-
- Insert (Container, Container.Last + 1, New_Item, Count);
- end Append;
-
- ------------
- -- Assign --
- ------------
-
- procedure Assign (Target : in out Vector; Source : Vector) is
- LS : constant Capacity_Range := Length (Source);
-
- begin
- if Target'Address = Source'Address then
- return;
- end if;
-
- if Target.Capacity < LS then
- raise Constraint_Error;
- end if;
-
- Clear (Target);
- Append (Target, Source);
- end Assign;
-
- --------------
- -- Capacity --
- --------------
-
- function Capacity (Container : Vector) return Capacity_Range is
- begin
- return Container.Capacity;
- end Capacity;
-
- -----------
- -- Clear --
- -----------
-
- procedure Clear (Container : in out Vector) is
- begin
- Container.Last := No_Index;
- end Clear;
-
- ------------------------
- -- Constant_Reference --
- ------------------------
-
- function Constant_Reference
- (Container : aliased Vector;
- Index : Index_Type) return not null access constant Element_Type
- is
- begin
- if Index > Container.Last then
- raise Constraint_Error with "Index is out of range";
- end if;
-
- return Container.Elements (To_Array_Index (Index))'Access;
- end Constant_Reference;
-
- --------------
- -- Contains --
- --------------
-
- function Contains
- (Container : Vector;
- Item : Element_Type) return Boolean
- is
- begin
- return Find_Index (Container, Item) /= No_Index;
- end Contains;
-
- ----------
- -- Copy --
- ----------
-
- function Copy
- (Source : Vector;
- Capacity : Capacity_Range := 0) return Vector
- is
- LS : constant Capacity_Range := Length (Source);
- C : Capacity_Range;
-
- begin
- if Capacity = 0 then
- C := LS;
- elsif Capacity >= LS then
- C := Capacity;
- else
- raise Capacity_Error with "Capacity too small";
- end if;
-
- return Target : Vector (C) do
- Target.Elements (1 .. LS) := Source.Elements (1 .. LS);
- Target.Last := Source.Last;
- end return;
- end Copy;
-
- ------------
- -- Delete --
- ------------
-
- procedure Delete (Container : in out Vector; Index : Extended_Index) is
- begin
- Delete (Container, Index, 1);
- end Delete;
-
- procedure Delete
- (Container : in out Vector;
- Index : Extended_Index;
- Count : Count_Type)
- is
- Old_Last : constant Index_Type'Base := Container.Last;
- Old_Len : constant Count_Type := Length (Container);
- New_Last : Index_Type'Base;
- Count2 : Count_Type'Base; -- count of items from Index to Old_Last
- Off : Count_Type'Base; -- Index expressed as offset from IT'First
-
- begin
- -- Delete removes items from the vector, the number of which is the
- -- minimum of the specified Count and the items (if any) that exist from
- -- Index to Container.Last. There are no constraints on the specified
- -- value of Count (it can be larger than what's available at this
- -- position in the vector, for example), but there are constraints on
- -- the allowed values of the Index.
-
- -- As a precondition on the generic actual Index_Type, the base type
- -- must include Index_Type'Pred (Index_Type'First); this is the value
- -- that Container.Last assumes when the vector is empty. However, we do
- -- not allow that as the value for Index when specifying which items
- -- should be deleted, so we must manually check. (That the user is
- -- allowed to specify the value at all here is a consequence of the
- -- declaration of the Extended_Index subtype, which includes the values
- -- in the base range that immediately precede and immediately follow the
- -- values in the Index_Type.)
-
- if Index < Index_Type'First then
- raise Constraint_Error with "Index is out of range (too small)";
- end if;
-
- -- We do allow a value greater than Container.Last to be specified as
- -- the Index, but only if it's immediately greater. This allows the
- -- corner case of deleting no items from the back end of the vector to
- -- be treated as a no-op. (It is assumed that specifying an index value
- -- greater than Last + 1 indicates some deeper flaw in the caller's
- -- algorithm, so that case is treated as a proper error.)
-
- if Index > Old_Last then
- if Index > Old_Last + 1 then
- raise Constraint_Error with "Index is out of range (too large)";
- end if;
-
- return;
- end if;
-
- if Count = 0 then
- return;
- end if;
-
- -- We first calculate what's available for deletion starting at
- -- Index. Here and elsewhere we use the wider of Index_Type'Base and
- -- Count_Type'Base as the type for intermediate values. (See function
- -- Length for more information.)
-
- if Count_Type'Base'Last >= Index_Type'Pos (Index_Type'Base'Last) then
- Count2 := Count_Type'Base (Old_Last) - Count_Type'Base (Index) + 1;
- else
- Count2 := Count_Type'Base (Old_Last - Index + 1);
- end if;
-
- -- If more elements are requested (Count) for deletion than are
- -- available (Count2) for deletion beginning at Index, then everything
- -- from Index is deleted. There are no elements to slide down, and so
- -- all we need to do is set the value of Container.Last.
-
- if Count >= Count2 then
- Container.Last := Index - 1;
- return;
- end if;
-
- -- There are some elements aren't being deleted (the requested count was
- -- less than the available count), so we must slide them down to Index.
- -- We first calculate the index values of the respective array slices,
- -- using the wider of Index_Type'Base and Count_Type'Base as the type
- -- for intermediate calculations.
-
- if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
- Off := Count_Type'Base (Index - Index_Type'First);
- New_Last := Old_Last - Index_Type'Base (Count);
- else
- Off := Count_Type'Base (Index) - Count_Type'Base (Index_Type'First);
- New_Last := Index_Type'Base (Count_Type'Base (Old_Last) - Count);
- end if;
-
- -- The array index values for each slice have already been determined,
- -- so we just slide down to Index the elements that weren't deleted.
-
- declare
- EA : Elements_Array renames Container.Elements;
- Idx : constant Count_Type := EA'First + Off;
- begin
- EA (Idx .. Old_Len - Count) := EA (Idx + Count .. Old_Len);
- Container.Last := New_Last;
- end;
- end Delete;
-
- ------------------
- -- Delete_First --
- ------------------
-
- procedure Delete_First (Container : in out Vector) is
- begin
- Delete_First (Container, 1);
- end Delete_First;
-
- procedure Delete_First (Container : in out Vector; Count : Count_Type) is
- begin
- if Count = 0 then
- return;
-
- elsif Count >= Length (Container) then
- Clear (Container);
- return;
-
- else
- Delete (Container, Index_Type'First, Count);
- end if;
- end Delete_First;
-
- -----------------
- -- Delete_Last --
- -----------------
-
- procedure Delete_Last (Container : in out Vector) is
- begin
- Delete_Last (Container, 1);
- end Delete_Last;
-
- procedure Delete_Last (Container : in out Vector; Count : Count_Type) is
- begin
- if Count = 0 then
- return;
- end if;
-
- -- There is no restriction on how large Count can be when deleting
- -- items. If it is equal or greater than the current length, then this
- -- is equivalent to clearing the vector. (In particular, there's no need
- -- for us to actually calculate the new value for Last.)
-
- -- If the requested count is less than the current length, then we must
- -- calculate the new value for Last. For the type we use the widest of
- -- Index_Type'Base and Count_Type'Base for the intermediate values of
- -- our calculation. (See the comments in Length for more information.)
-
- if Count >= Length (Container) then
- Container.Last := No_Index;
-
- elsif Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
- Container.Last := Container.Last - Index_Type'Base (Count);
-
- else
- Container.Last :=
- Index_Type'Base (Count_Type'Base (Container.Last) - Count);
- end if;
- end Delete_Last;
-
- -------------
- -- Element --
- -------------
-
- function Element
- (Container : Vector;
- Index : Extended_Index) return Element_Type
- is
- begin
- if Index > Container.Last then
- raise Constraint_Error with "Index is out of range";
- end if;
-
- declare
- II : constant Int'Base := Int (Index) - Int (No_Index);
- I : constant Capacity_Range := Capacity_Range (II);
- begin
- return Container.Elements (I);
- end;
- end Element;
-
- ----------------
- -- Find_Index --
- ----------------
-
- function Find_Index
- (Container : Vector;
- Item : Element_Type;
- Index : Index_Type := Index_Type'First) return Extended_Index
- is
- K : Count_Type;
- Last : constant Extended_Index := Last_Index (Container);
-
- begin
- K := Capacity_Range (Int (Index) - Int (No_Index));
- for Indx in Index .. Last loop
- if Container.Elements (K) = Item then
- return Indx;
- end if;
-
- K := K + 1;
- end loop;
-
- return No_Index;
- end Find_Index;
-
- -------------------
- -- First_Element --
- -------------------
-
- function First_Element (Container : Vector) return Element_Type is
- begin
- if Is_Empty (Container) then
- raise Constraint_Error with "Container is empty";
- else
- return Container.Elements (1);
- end if;
- end First_Element;
-
- -----------------
- -- First_Index --
- -----------------
-
- function First_Index (Container : Vector) return Index_Type is
- pragma Unreferenced (Container);
- begin
- return Index_Type'First;
- end First_Index;
-
- ------------------
- -- Formal_Model --
- ------------------
-
- package body Formal_Model is
-
- -------------------------
- -- M_Elements_In_Union --
- -------------------------
-
- function M_Elements_In_Union
- (Container : M.Sequence;
- Left : M.Sequence;
- Right : M.Sequence) return Boolean
- is
- Elem : Element_Type;
-
- begin
- for Index in Index_Type'First .. M.Last (Container) loop
- Elem := Element (Container, Index);
-
- if not M.Contains (Left, Index_Type'First, M.Last (Left), Elem)
- and then
- not M.Contains (Right, Index_Type'First, M.Last (Right), Elem)
- then
- return False;
- end if;
- end loop;
-
- return True;
- end M_Elements_In_Union;
-
- -------------------------
- -- M_Elements_Included --
- -------------------------
-
- function M_Elements_Included
- (Left : M.Sequence;
- L_Fst : Index_Type := Index_Type'First;
- L_Lst : Extended_Index;
- Right : M.Sequence;
- R_Fst : Index_Type := Index_Type'First;
- R_Lst : Extended_Index) return Boolean
- is
- begin
- for I in L_Fst .. L_Lst loop
- declare
- Found : Boolean := False;
- J : Extended_Index := R_Fst - 1;
-
- begin
- while not Found and J < R_Lst loop
- J := J + 1;
- if Element (Left, I) = Element (Right, J) then
- Found := True;
- end if;
- end loop;
-
- if not Found then
- return False;
- end if;
- end;
- end loop;
-
- return True;
- end M_Elements_Included;
-
- -------------------------
- -- M_Elements_Reversed --
- -------------------------
-
- function M_Elements_Reversed
- (Left : M.Sequence;
- Right : M.Sequence) return Boolean
- is
- L : constant Index_Type := M.Last (Left);
-
- begin
- if L /= M.Last (Right) then
- return False;
- end if;
-
- for I in Index_Type'First .. L loop
- if Element (Left, I) /= Element (Right, L - I + 1)
- then
- return False;
- end if;
- end loop;
-
- return True;
- end M_Elements_Reversed;
-
- ------------------------
- -- M_Elements_Swapped --
- ------------------------
-
- function M_Elements_Swapped
- (Left : M.Sequence;
- Right : M.Sequence;
- X : Index_Type;
- Y : Index_Type) return Boolean
- is
- begin
- if M.Length (Left) /= M.Length (Right)
- or else Element (Left, X) /= Element (Right, Y)
- or else Element (Left, Y) /= Element (Right, X)
- then
- return False;
- end if;
-
- for I in Index_Type'First .. M.Last (Left) loop
- if I /= X and then I /= Y
- and then Element (Left, I) /= Element (Right, I)
- then
- return False;
- end if;
- end loop;
-
- return True;
- end M_Elements_Swapped;
-
- -----------
- -- Model --
- -----------
-
- function Model (Container : Vector) return M.Sequence is
- R : M.Sequence;
-
- begin
- for Position in 1 .. Length (Container) loop
- R := M.Add (R, Container.Elements (Position));
- end loop;
-
- return R;
- end Model;
-
- end Formal_Model;
-
- ---------------------
- -- Generic_Sorting --
- ---------------------
-
- package body Generic_Sorting with SPARK_Mode => Off is
-
- ------------------
- -- Formal_Model --
- ------------------
-
- package body Formal_Model is
-
- -----------------------
- -- M_Elements_Sorted --
- -----------------------
-
- function M_Elements_Sorted (Container : M.Sequence) return Boolean is
- begin
- if M.Length (Container) = 0 then
- return True;
- end if;
-
- declare
- E1 : Element_Type := Element (Container, Index_Type'First);
-
- begin
- for I in Index_Type'First + 1 .. M.Last (Container) loop
- declare
- E2 : constant Element_Type := Element (Container, I);
-
- begin
- if E2 < E1 then
- return False;
- end if;
-
- E1 := E2;
- end;
- end loop;
- end;
-
- return True;
- end M_Elements_Sorted;
-
- end Formal_Model;
-
- ---------------
- -- Is_Sorted --
- ---------------
-
- function Is_Sorted (Container : Vector) return Boolean is
- L : constant Capacity_Range := Length (Container);
-
- begin
- for J in 1 .. L - 1 loop
- if Container.Elements (J + 1) <
- Container.Elements (J)
- then
- return False;
- end if;
- end loop;
-
- return True;
- end Is_Sorted;
-
- ----------
- -- Sort --
- ----------
-
- procedure Sort (Container : in out Vector) is
- procedure Sort is
- new Generic_Array_Sort
- (Index_Type => Array_Index,
- Element_Type => Element_Type,
- Array_Type => Elements_Array,
- "<" => "<");
-
- Len : constant Capacity_Range := Length (Container);
-
- begin
- if Container.Last <= Index_Type'First then
- return;
- else
- Sort (Container.Elements (1 .. Len));
- end if;
- end Sort;
-
- -----------
- -- Merge --
- -----------
-
- procedure Merge (Target : in out Vector; Source : in out Vector) is
- I : Count_Type;
- J : Count_Type;
-
- begin
- if Target'Address = Source'Address then
- raise Program_Error with "Target and Source denote same container";
- end if;
-
- if Length (Source) = 0 then
- return;
- end if;
-
- if Length (Target) = 0 then
- Move (Target => Target, Source => Source);
- return;
- end if;
-
- I := Length (Target);
-
- declare
- New_Length : constant Count_Type := I + Length (Source);
-
- begin
- if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
- Target.Last := No_Index + Index_Type'Base (New_Length);
-
- else
- Target.Last :=
- Index_Type'Base (Count_Type'Base (No_Index) + New_Length);
- end if;
- end;
-
- declare
- TA : Elements_Array renames Target.Elements;
- SA : Elements_Array renames Source.Elements;
-
- begin
- J := Length (Target);
- while Length (Source) /= 0 loop
- if I = 0 then
- TA (1 .. J) := SA (1 .. Length (Source));
- Source.Last := No_Index;
- exit;
- end if;
-
- if SA (Length (Source)) < TA (I) then
- TA (J) := TA (I);
- I := I - 1;
-
- else
- TA (J) := SA (Length (Source));
- Source.Last := Source.Last - 1;
- end if;
-
- J := J - 1;
- end loop;
- end;
- end Merge;
-
- end Generic_Sorting;
-
- -----------------
- -- Has_Element --
- -----------------
-
- function Has_Element
- (Container : Vector;
- Position : Extended_Index) return Boolean
- is
- begin
- return Position in First_Index (Container) .. Last_Index (Container);
- end Has_Element;
-
- ------------
- -- Insert --
- ------------
-
- procedure Insert
- (Container : in out Vector;
- Before : Extended_Index;
- New_Item : Element_Type)
- is
- begin
- Insert (Container, Before, New_Item, 1);
- end Insert;
-
- procedure Insert
- (Container : in out Vector;
- Before : Extended_Index;
- New_Item : Element_Type;
- Count : Count_Type)
- is
- J : Count_Type'Base; -- scratch
-
- begin
- -- Use Insert_Space to create the "hole" (the destination slice)
-
- Insert_Space (Container, Before, Count);
-
- J := To_Array_Index (Before);
-
- Container.Elements (J .. J - 1 + Count) := [others => New_Item];
- end Insert;
-
- procedure Insert
- (Container : in out Vector;
- Before : Extended_Index;
- New_Item : Vector)
- is
- N : constant Count_Type := Length (New_Item);
- B : Count_Type; -- index Before converted to Count_Type
-
- begin
- if Container'Address = New_Item'Address then
- raise Program_Error with
- "Container and New_Item denote same container";
- end if;
-
- -- Use Insert_Space to create the "hole" (the destination slice) into
- -- which we copy the source items.
-
- Insert_Space (Container, Before, Count => N);
-
- if N = 0 then
-
- -- There's nothing else to do here (vetting of parameters was
- -- performed already in Insert_Space), so we simply return.
-
- return;
- end if;
-
- B := To_Array_Index (Before);
-
- Container.Elements (B .. B + N - 1) := New_Item.Elements (1 .. N);
- end Insert;
-
- ------------------
- -- Insert_Space --
- ------------------
-
- procedure Insert_Space
- (Container : in out Vector;
- Before : Extended_Index;
- Count : Count_Type := 1)
- is
- Old_Length : constant Count_Type := Length (Container);
-
- Max_Length : Count_Type'Base; -- determined from range of Index_Type
- New_Length : Count_Type'Base; -- sum of current length and Count
-
- Index : Index_Type'Base; -- scratch for intermediate values
- J : Count_Type'Base; -- scratch
-
- begin
- -- As a precondition on the generic actual Index_Type, the base type
- -- must include Index_Type'Pred (Index_Type'First); this is the value
- -- that Container.Last assumes when the vector is empty. However, we do
- -- not allow that as the value for Index when specifying where the new
- -- items should be inserted, so we must manually check. (That the user
- -- is allowed to specify the value at all here is a consequence of the
- -- declaration of the Extended_Index subtype, which includes the values
- -- in the base range that immediately precede and immediately follow the
- -- values in the Index_Type.)
-
- if Before < Index_Type'First then
- raise Constraint_Error with
- "Before index is out of range (too small)";
- end if;
-
- -- We do allow a value greater than Container.Last to be specified as
- -- the Index, but only if it's immediately greater. This allows for the
- -- case of appending items to the back end of the vector. (It is assumed
- -- that specifying an index value greater than Last + 1 indicates some
- -- deeper flaw in the caller's algorithm, so that case is treated as a
- -- proper error.)
-
- if Before > Container.Last
- and then Before - 1 > Container.Last
- then
- raise Constraint_Error with
- "Before index is out of range (too large)";
- end if;
-
- -- We treat inserting 0 items into the container as a no-op, so we
- -- simply return.
-
- if Count = 0 then
- return;
- end if;
-
- -- There are two constraints we need to satisfy. The first constraint is
- -- that a container cannot have more than Count_Type'Last elements, so
- -- we must check the sum of the current length and the insertion count.
- -- Note that the value cannot be simply added because the result may
- -- overflow.
-
- if Old_Length > Count_Type'Last - Count then
- raise Constraint_Error with "Count is out of range";
- end if;
-
- -- It is now safe compute the length of the new vector, without fear of
- -- overflow.
-
- New_Length := Old_Length + Count;
-
- -- The second constraint is that the new Last index value cannot exceed
- -- Index_Type'Last. In each branch below, we calculate the maximum
- -- length (computed from the range of values in Index_Type), and then
- -- compare the new length to the maximum length. If the new length is
- -- acceptable, then we compute the new last index from that.
-
- if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
-
- -- We have to handle the case when there might be more values in the
- -- range of Index_Type than in the range of Count_Type.
-
- if Index_Type'First <= 0 then
-
- -- We know that No_Index (the same as Index_Type'First - 1) is
- -- less than 0, so it is safe to compute the following sum without
- -- fear of overflow.
-
- Index := No_Index + Index_Type'Base (Count_Type'Last);
-
- if Index <= Index_Type'Last then
-
- -- We have determined that range of Index_Type has at least as
- -- many values as in Count_Type, so Count_Type'Last is the
- -- maximum number of items that are allowed.
-
- Max_Length := Count_Type'Last;
-
- else
- -- The range of Index_Type has fewer values than in Count_Type,
- -- so the maximum number of items is computed from the range of
- -- the Index_Type.
-
- Max_Length := Count_Type'Base (Index_Type'Last - No_Index);
- end if;
-
- else
- -- No_Index is equal or greater than 0, so we can safely compute
- -- the difference without fear of overflow (which we would have to
- -- worry about if No_Index were less than 0, but that case is
- -- handled above).
-
- if Index_Type'Last - No_Index >= Count_Type'Pos (Count_Type'Last)
- then
- -- We have determined that range of Index_Type has at least as
- -- many values as in Count_Type, so Count_Type'Last is the
- -- maximum number of items that are allowed.
-
- Max_Length := Count_Type'Last;
-
- else
- -- The range of Index_Type has fewer values than in Count_Type,
- -- so the maximum number of items is computed from the range of
- -- the Index_Type.
-
- Max_Length := Count_Type'Base (Index_Type'Last - No_Index);
- end if;
- end if;
-
- elsif Index_Type'First <= 0 then
-
- -- We know that No_Index (the same as Index_Type'First - 1) is less
- -- than 0, so it is safe to compute the following sum without fear of
- -- overflow.
-
- J := Count_Type'Base (No_Index) + Count_Type'Last;
-
- if J <= Count_Type'Base (Index_Type'Last) then
-
- -- We have determined that range of Index_Type has at least as
- -- many values as in Count_Type, so Count_Type'Last is the maximum
- -- number of items that are allowed.
-
- Max_Length := Count_Type'Last;
-
- else
- -- The range of Index_Type has fewer values than Count_Type does,
- -- so the maximum number of items is computed from the range of
- -- the Index_Type.
-
- Max_Length :=
- Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index);
- end if;
-
- else
- -- No_Index is equal or greater than 0, so we can safely compute the
- -- difference without fear of overflow (which we would have to worry
- -- about if No_Index were less than 0, but that case is handled
- -- above).
-
- Max_Length :=
- Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index);
- end if;
-
- -- We have just computed the maximum length (number of items). We must
- -- now compare the requested length to the maximum length, as we do not
- -- allow a vector expand beyond the maximum (because that would create
- -- an internal array with a last index value greater than
- -- Index_Type'Last, with no way to index those elements).
-
- if New_Length > Max_Length then
- raise Constraint_Error with "Count is out of range";
-
- -- Raise Capacity_Error if the new length exceeds the container's
- -- capacity.
-
- elsif New_Length > Container.Capacity then
- raise Capacity_Error with "New length is larger than capacity";
- end if;
-
- J := To_Array_Index (Before);
-
- declare
- EA : Elements_Array renames Container.Elements;
-
- begin
- if Before <= Container.Last then
-
- -- The new items are being inserted before some existing
- -- elements, so we must slide the existing elements up to their
- -- new home.
-
- EA (J + Count .. New_Length) := EA (J .. Old_Length);
- end if;
- end;
-
- if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
- Container.Last := No_Index + Index_Type'Base (New_Length);
-
- else
- Container.Last :=
- Index_Type'Base (Count_Type'Base (No_Index) + New_Length);
- end if;
- end Insert_Space;
-
- --------------
- -- Is_Empty --
- --------------
-
- function Is_Empty (Container : Vector) return Boolean is
- begin
- return Last_Index (Container) < Index_Type'First;
- end Is_Empty;
-
- ------------------
- -- Last_Element --
- ------------------
-
- function Last_Element (Container : Vector) return Element_Type is
- begin
- if Is_Empty (Container) then
- raise Constraint_Error with "Container is empty";
- else
- return Container.Elements (Length (Container));
- end if;
- end Last_Element;
-
- ----------------
- -- Last_Index --
- ----------------
-
- function Last_Index (Container : Vector) return Extended_Index is
- begin
- return Container.Last;
- end Last_Index;
-
- ------------
- -- Length --
- ------------
-
- function Length (Container : Vector) return Capacity_Range is
- L : constant Int := Int (Container.Last);
- F : constant Int := Int (Index_Type'First);
- N : constant Int'Base := L - F + 1;
-
- begin
- return Capacity_Range (N);
- end Length;
-
- ----------
- -- Move --
- ----------
-
- procedure Move (Target : in out Vector; Source : in out Vector) is
- LS : constant Capacity_Range := Length (Source);
-
- begin
- if Target'Address = Source'Address then
- return;
- end if;
-
- if Target.Capacity < LS then
- raise Constraint_Error;
- end if;
-
- Clear (Target);
- Append (Target, Source);
- Clear (Source);
- end Move;
-
- ------------
- -- Prepend --
- ------------
-
- procedure Prepend (Container : in out Vector; New_Item : Vector) is
- begin
- Insert (Container, Index_Type'First, New_Item);
- end Prepend;
-
- procedure Prepend (Container : in out Vector; New_Item : Element_Type) is
- begin
- Prepend (Container, New_Item, 1);
- end Prepend;
-
- procedure Prepend
- (Container : in out Vector;
- New_Item : Element_Type;
- Count : Count_Type)
- is
- begin
- Insert (Container, Index_Type'First, New_Item, Count);
- end Prepend;
-
- ---------------------
- -- Replace_Element --
- ---------------------
-
- procedure Replace_Element
- (Container : in out Vector;
- Index : Index_Type;
- New_Item : Element_Type)
- is
- begin
- if Index > Container.Last then
- raise Constraint_Error with "Index is out of range";
- end if;
-
- declare
- II : constant Int'Base := Int (Index) - Int (No_Index);
- I : constant Capacity_Range := Capacity_Range (II);
-
- begin
- Container.Elements (I) := New_Item;
- end;
- end Replace_Element;
-
- ---------------
- -- Reference --
- ---------------
-
- function Reference
- (Container : not null access Vector;
- Index : Index_Type) return not null access Element_Type
- is
- begin
- if Index > Container.Last then
- raise Constraint_Error with "Index is out of range";
- end if;
-
- return Container.Elements (To_Array_Index (Index))'Access;
- end Reference;
-
- ----------------------
- -- Reserve_Capacity --
- ----------------------
-
- procedure Reserve_Capacity
- (Container : in out Vector;
- Capacity : Capacity_Range)
- is
- begin
- if Capacity > Container.Capacity then
- raise Capacity_Error with "Capacity is out of range";
- end if;
- end Reserve_Capacity;
-
- ----------------------
- -- Reverse_Elements --
- ----------------------
-
- procedure Reverse_Elements (Container : in out Vector) is
- begin
- if Length (Container) <= 1 then
- return;
- end if;
-
- declare
- I, J : Capacity_Range;
- E : Elements_Array renames
- Container.Elements (1 .. Length (Container));
-
- begin
- I := 1;
- J := Length (Container);
- while I < J loop
- declare
- EI : constant Element_Type := E (I);
-
- begin
- E (I) := E (J);
- E (J) := EI;
- end;
-
- I := I + 1;
- J := J - 1;
- end loop;
- end;
- end Reverse_Elements;
-
- ------------------------
- -- Reverse_Find_Index --
- ------------------------
-
- function Reverse_Find_Index
- (Container : Vector;
- Item : Element_Type;
- Index : Index_Type := Index_Type'Last) return Extended_Index
- is
- Last : Index_Type'Base;
- K : Count_Type'Base;
-
- begin
- if Index > Last_Index (Container) then
- Last := Last_Index (Container);
- else
- Last := Index;
- end if;
-
- K := Capacity_Range (Int (Last) - Int (No_Index));
- for Indx in reverse Index_Type'First .. Last loop
- if Container.Elements (K) = Item then
- return Indx;
- end if;
-
- K := K - 1;
- end loop;
-
- return No_Index;
- end Reverse_Find_Index;
-
- ----------
- -- Swap --
- ----------
-
- procedure Swap
- (Container : in out Vector;
- I : Index_Type;
- J : Index_Type)
- is
- begin
- if I > Container.Last then
- raise Constraint_Error with "I index is out of range";
- end if;
-
- if J > Container.Last then
- raise Constraint_Error with "J index is out of range";
- end if;
-
- if I = J then
- return;
- end if;
-
- declare
- II : constant Int'Base := Int (I) - Int (No_Index);
- JJ : constant Int'Base := Int (J) - Int (No_Index);
-
- EI : Element_Type renames Container.Elements (Capacity_Range (II));
- EJ : Element_Type renames Container.Elements (Capacity_Range (JJ));
-
- EI_Copy : constant Element_Type := EI;
-
- begin
- EI := EJ;
- EJ := EI_Copy;
- end;
- end Swap;
-
- --------------------
- -- To_Array_Index --
- --------------------
-
- function To_Array_Index (Index : Index_Type'Base) return Count_Type'Base is
- Offset : Count_Type'Base;
-
- begin
- -- We know that
- -- Index >= Index_Type'First
- -- hence we also know that
- -- Index - Index_Type'First >= 0
-
- -- The issue is that even though 0 is guaranteed to be a value in
- -- the type Index_Type'Base, there's no guarantee that the difference
- -- is a value in that type. To prevent overflow we use the wider
- -- of Count_Type'Base and Index_Type'Base to perform intermediate
- -- calculations.
-
- if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
- Offset := Count_Type'Base (Index - Index_Type'First);
-
- else
- Offset :=
- Count_Type'Base (Index) - Count_Type'Base (Index_Type'First);
- end if;
-
- -- The array index subtype for all container element arrays always
- -- starts with 1.
-
- return 1 + Offset;
- end To_Array_Index;
-
- ---------------
- -- To_Vector --
- ---------------
-
- function To_Vector
- (New_Item : Element_Type;
- Length : Capacity_Range) return Vector
- is
- begin
- if Length = 0 then
- return Empty_Vector;
- end if;
-
- declare
- First : constant Int := Int (Index_Type'First);
- Last_As_Int : constant Int'Base := First + Int (Length) - 1;
- Last : Index_Type;
-
- begin
- if Last_As_Int > Index_Type'Pos (Index_Type'Last) then
- raise Constraint_Error with "Length is out of range"; -- ???
- end if;
-
- Last := Index_Type (Last_As_Int);
-
- return
- (Capacity => Length,
- Last => Last,
- Elements => [others => New_Item]);
- end;
- end To_Vector;
-
-end Ada.Containers.Formal_Vectors;
diff --git a/gcc/ada/libgnat/a-cofove.ads b/gcc/ada/libgnat/a-cofove.ads
index 6413375..fb9301f 100644
--- a/gcc/ada/libgnat/a-cofove.ads
+++ b/gcc/ada/libgnat/a-cofove.ads
@@ -29,954 +29,12 @@
-- <http://www.gnu.org/licenses/>. --
------------------------------------------------------------------------------
--- This spec is derived from package Ada.Containers.Bounded_Vectors in the Ada
--- 2012 RM. The modifications are meant to facilitate formal proofs by making
--- it easier to express properties, and by making the specification of this
--- unit compatible with SPARK 2014. Note that the API of this unit may be
--- subject to incompatible changes as SPARK 2014 evolves.
-
-with Ada.Containers.Functional_Vectors;
-
generic
- type Index_Type is range <>;
- type Element_Type is private;
- with function "=" (Left, Right : Element_Type) return Boolean is <>;
-
-package Ada.Containers.Formal_Vectors with
- SPARK_Mode
-is
- pragma Annotate (GNATprove, Always_Return, Formal_Vectors);
-
- -- Contracts in this unit are meant for analysis only, not for run-time
- -- checking.
-
- pragma Assertion_Policy (Pre => Ignore);
- pragma Assertion_Policy (Post => Ignore);
- pragma Assertion_Policy (Contract_Cases => Ignore);
- pragma Annotate (CodePeer, Skip_Analysis);
-
- subtype Extended_Index is Index_Type'Base
- range Index_Type'First - 1 ..
- Index_Type'Min (Index_Type'Base'Last - 1, Index_Type'Last) + 1;
-
- No_Index : constant Extended_Index := Extended_Index'First;
-
- Last_Count : constant Count_Type :=
- (if Index_Type'Last < Index_Type'First then
- 0
- elsif Index_Type'Last < -1
- or else Index_Type'Pos (Index_Type'First) >
- Index_Type'Pos (Index_Type'Last) - Count_Type'Last
- then
- Index_Type'Pos (Index_Type'Last) -
- Index_Type'Pos (Index_Type'First) + 1
- else
- Count_Type'Last);
- -- Maximal capacity of any vector. It is the minimum of the size of the
- -- index range and the last possible Count_Type.
-
- subtype Capacity_Range is Count_Type range 0 .. Last_Count;
-
- type Vector (Capacity : Capacity_Range) is private with
- Default_Initial_Condition => Is_Empty (Vector),
- Iterable => (First => Iter_First,
- Has_Element => Iter_Has_Element,
- Next => Iter_Next,
- Element => Element);
-
- function Length (Container : Vector) return Capacity_Range with
- Global => null,
- Post => Length'Result <= Capacity (Container);
-
- pragma Unevaluated_Use_Of_Old (Allow);
-
- package Formal_Model with Ghost is
-
- package M is new Ada.Containers.Functional_Vectors
- (Index_Type => Index_Type,
- Element_Type => Element_Type);
-
- function "="
- (Left : M.Sequence;
- Right : M.Sequence) return Boolean renames M."=";
-
- function "<"
- (Left : M.Sequence;
- Right : M.Sequence) return Boolean renames M."<";
-
- function "<="
- (Left : M.Sequence;
- Right : M.Sequence) return Boolean renames M."<=";
-
- function M_Elements_In_Union
- (Container : M.Sequence;
- Left : M.Sequence;
- Right : M.Sequence) return Boolean
- -- The elements of Container are contained in either Left or Right
- with
- Global => null,
- Post =>
- M_Elements_In_Union'Result =
- (for all I in Index_Type'First .. M.Last (Container) =>
- (for some J in Index_Type'First .. M.Last (Left) =>
- Element (Container, I) = Element (Left, J))
- or (for some J in Index_Type'First .. M.Last (Right) =>
- Element (Container, I) = Element (Right, J)));
- pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_In_Union);
-
- function M_Elements_Included
- (Left : M.Sequence;
- L_Fst : Index_Type := Index_Type'First;
- L_Lst : Extended_Index;
- Right : M.Sequence;
- R_Fst : Index_Type := Index_Type'First;
- R_Lst : Extended_Index) return Boolean
- -- The elements of the slice from L_Fst to L_Lst in Left are contained
- -- in the slide from R_Fst to R_Lst in Right.
- with
- Global => null,
- Pre => L_Lst <= M.Last (Left) and R_Lst <= M.Last (Right),
- Post =>
- M_Elements_Included'Result =
- (for all I in L_Fst .. L_Lst =>
- (for some J in R_Fst .. R_Lst =>
- Element (Left, I) = Element (Right, J)));
- pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_Included);
-
- function M_Elements_Reversed
- (Left : M.Sequence;
- Right : M.Sequence) return Boolean
- -- Right is Left in reverse order
- with
- Global => null,
- Post =>
- M_Elements_Reversed'Result =
- (M.Length (Left) = M.Length (Right)
- and (for all I in Index_Type'First .. M.Last (Left) =>
- Element (Left, I) =
- Element (Right, M.Last (Left) - I + 1))
- and (for all I in Index_Type'First .. M.Last (Right) =>
- Element (Right, I) =
- Element (Left, M.Last (Left) - I + 1)));
- pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_Reversed);
-
- function M_Elements_Swapped
- (Left : M.Sequence;
- Right : M.Sequence;
- X : Index_Type;
- Y : Index_Type) return Boolean
- -- Elements stored at X and Y are reversed in Left and Right
- with
- Global => null,
- Pre => X <= M.Last (Left) and Y <= M.Last (Left),
- Post =>
- M_Elements_Swapped'Result =
- (M.Length (Left) = M.Length (Right)
- and Element (Left, X) = Element (Right, Y)
- and Element (Left, Y) = Element (Right, X)
- and M.Equal_Except (Left, Right, X, Y));
- pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_Swapped);
-
- function Model (Container : Vector) return M.Sequence with
- -- The high-level model of a vector is a sequence of elements. The
- -- sequence really is similar to the vector itself. However, it is not
- -- limited which allows usage of 'Old and 'Loop_Entry attributes.
-
- Ghost,
- Global => null,
- Post => M.Length (Model'Result) = Length (Container);
- pragma Annotate (GNATprove, Iterable_For_Proof, "Model", Model);
-
- function Element
- (S : M.Sequence;
- I : Index_Type) return Element_Type renames M.Get;
- -- To improve readability of contracts, we rename the function used to
- -- access an element in the model to Element.
-
- end Formal_Model;
- use Formal_Model;
-
- function Empty_Vector return Vector with
- Global => null,
- Post => Length (Empty_Vector'Result) = 0;
-
- function "=" (Left, Right : Vector) return Boolean with
- Global => null,
- Post => "="'Result = (Model (Left) = Model (Right));
-
- function To_Vector
- (New_Item : Element_Type;
- Length : Capacity_Range) return Vector
- with
- Global => null,
- Post =>
- Formal_Vectors.Length (To_Vector'Result) = Length
- and M.Constant_Range
- (Container => Model (To_Vector'Result),
- Fst => Index_Type'First,
- Lst => Last_Index (To_Vector'Result),
- Item => New_Item);
-
- function Capacity (Container : Vector) return Capacity_Range with
- Global => null,
- Post =>
- Capacity'Result = Container.Capacity;
- pragma Annotate (GNATprove, Inline_For_Proof, Capacity);
-
- procedure Reserve_Capacity
- (Container : in out Vector;
- Capacity : Capacity_Range)
- with
- Global => null,
- Pre => Capacity <= Container.Capacity,
- Post => Model (Container) = Model (Container)'Old;
-
- function Is_Empty (Container : Vector) return Boolean with
- Global => null,
- Post => Is_Empty'Result = (Length (Container) = 0);
-
- procedure Clear (Container : in out Vector) with
- Global => null,
- Post => Length (Container) = 0;
-
- procedure Assign (Target : in out Vector; Source : Vector) with
- Global => null,
- Pre => Length (Source) <= Target.Capacity,
- Post => Model (Target) = Model (Source);
-
- function Copy
- (Source : Vector;
- Capacity : Capacity_Range := 0) return Vector
- with
- Global => null,
- Pre => (Capacity = 0 or Length (Source) <= Capacity),
- Post =>
- Model (Copy'Result) = Model (Source)
- and (if Capacity = 0 then
- Copy'Result.Capacity = Length (Source)
- else
- Copy'Result.Capacity = Capacity);
-
- procedure Move (Target : in out Vector; Source : in out Vector)
- with
- Global => null,
- Pre => Length (Source) <= Capacity (Target),
- Post => Model (Target) = Model (Source)'Old and Length (Source) = 0;
-
- function Element
- (Container : Vector;
- Index : Extended_Index) return Element_Type
- with
- Global => null,
- Pre => Index in First_Index (Container) .. Last_Index (Container),
- Post => Element'Result = Element (Model (Container), Index);
- pragma Annotate (GNATprove, Inline_For_Proof, Element);
-
- procedure Replace_Element
- (Container : in out Vector;
- Index : Index_Type;
- New_Item : Element_Type)
- with
- Global => null,
- Pre => Index in First_Index (Container) .. Last_Index (Container),
- Post =>
- Length (Container) = Length (Container)'Old
-
- -- Container now has New_Item at index Index
-
- and Element (Model (Container), Index) = New_Item
-
- -- All other elements are preserved
-
- and M.Equal_Except
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Position => Index);
-
- function At_End (E : access constant Vector) return access constant Vector
- is (E)
- with Ghost,
- Annotate => (GNATprove, At_End_Borrow);
-
- function At_End
- (E : access constant Element_Type) return access constant Element_Type
- is (E)
- with Ghost,
- Annotate => (GNATprove, At_End_Borrow);
-
- function Constant_Reference
- (Container : aliased Vector;
- Index : Index_Type) return not null access constant Element_Type
- with
- Global => null,
- Pre => Index in First_Index (Container) .. Last_Index (Container),
- Post =>
- Constant_Reference'Result.all = Element (Model (Container), Index);
-
- function Reference
- (Container : not null access Vector;
- Index : Index_Type) return not null access Element_Type
- with
- Global => null,
- Pre =>
- Index in First_Index (Container.all) .. Last_Index (Container.all),
- Post =>
- Length (Container.all) = Length (At_End (Container).all)
-
- -- Container will have Result.all at index Index
-
- and At_End (Reference'Result).all =
- Element (Model (At_End (Container).all), Index)
-
- -- All other elements are preserved
-
- and M.Equal_Except
- (Left => Model (Container.all),
- Right => Model (At_End (Container).all),
- Position => Index);
-
- procedure Insert
- (Container : in out Vector;
- Before : Extended_Index;
- New_Item : Vector)
- with
- Global => null,
- Pre =>
- Length (Container) <= Capacity (Container) - Length (New_Item)
- and (Before in Index_Type'First .. Last_Index (Container)
- or (Before /= No_Index
- and then Before - 1 = Last_Index (Container))),
- Post =>
- Length (Container) = Length (Container)'Old + Length (New_Item)
-
- -- Elements located before Before in Container are preserved
-
- and M.Range_Equal
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => Index_Type'First,
- Lst => Before - 1)
-
- -- Elements of New_Item are inserted at position Before
-
- and (if Length (New_Item) > 0 then
- M.Range_Shifted
- (Left => Model (New_Item),
- Right => Model (Container),
- Fst => Index_Type'First,
- Lst => Last_Index (New_Item),
- Offset => Count_Type (Before - Index_Type'First)))
-
- -- Elements located after Before in Container are shifted
-
- and M.Range_Shifted
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => Before,
- Lst => Last_Index (Container)'Old,
- Offset => Length (New_Item));
-
- procedure Insert
- (Container : in out Vector;
- Before : Extended_Index;
- New_Item : Element_Type)
- with
- Global => null,
- Pre =>
- Length (Container) < Capacity (Container)
- and then (Before in Index_Type'First .. Last_Index (Container) + 1),
- Post =>
- Length (Container) = Length (Container)'Old + 1
-
- -- Elements located before Before in Container are preserved
-
- and M.Range_Equal
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => Index_Type'First,
- Lst => Before - 1)
-
- -- Container now has New_Item at index Before
-
- and Element (Model (Container), Before) = New_Item
-
- -- Elements located after Before in Container are shifted by 1
-
- and M.Range_Shifted
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => Before,
- Lst => Last_Index (Container)'Old,
- Offset => 1);
-
- procedure Insert
- (Container : in out Vector;
- Before : Extended_Index;
- New_Item : Element_Type;
- Count : Count_Type)
- with
- Global => null,
- Pre =>
- Length (Container) <= Capacity (Container) - Count
- and (Before in Index_Type'First .. Last_Index (Container)
- or (Before /= No_Index
- and then Before - 1 = Last_Index (Container))),
- Post =>
- Length (Container) = Length (Container)'Old + Count
-
- -- Elements located before Before in Container are preserved
-
- and M.Range_Equal
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => Index_Type'First,
- Lst => Before - 1)
-
- -- New_Item is inserted Count times at position Before
-
- and (if Count > 0 then
- M.Constant_Range
- (Container => Model (Container),
- Fst => Before,
- Lst => Before + Index_Type'Base (Count - 1),
- Item => New_Item))
-
- -- Elements located after Before in Container are shifted
-
- and M.Range_Shifted
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => Before,
- Lst => Last_Index (Container)'Old,
- Offset => Count);
-
- procedure Prepend (Container : in out Vector; New_Item : Vector) with
- Global => null,
- Pre => Length (Container) <= Capacity (Container) - Length (New_Item),
- Post =>
- Length (Container) = Length (Container)'Old + Length (New_Item)
-
- -- Elements of New_Item are inserted at the beginning of Container
-
- and M.Range_Equal
- (Left => Model (New_Item),
- Right => Model (Container),
- Fst => Index_Type'First,
- Lst => Last_Index (New_Item))
-
- -- Elements of Container are shifted
-
- and M.Range_Shifted
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => Index_Type'First,
- Lst => Last_Index (Container)'Old,
- Offset => Length (New_Item));
-
- procedure Prepend (Container : in out Vector; New_Item : Element_Type) with
- Global => null,
- Pre => Length (Container) < Capacity (Container),
- Post =>
- Length (Container) = Length (Container)'Old + 1
-
- -- Container now has New_Item at Index_Type'First
-
- and Element (Model (Container), Index_Type'First) = New_Item
-
- -- Elements of Container are shifted by 1
-
- and M.Range_Shifted
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => Index_Type'First,
- Lst => Last_Index (Container)'Old,
- Offset => 1);
-
- procedure Prepend
- (Container : in out Vector;
- New_Item : Element_Type;
- Count : Count_Type)
- with
- Global => null,
- Pre => Length (Container) <= Capacity (Container) - Count,
- Post =>
- Length (Container) = Length (Container)'Old + Count
-
- -- New_Item is inserted Count times at the beginning of Container
-
- and M.Constant_Range
- (Container => Model (Container),
- Fst => Index_Type'First,
- Lst => Index_Type'First + Index_Type'Base (Count - 1),
- Item => New_Item)
-
- -- Elements of Container are shifted
-
- and M.Range_Shifted
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => Index_Type'First,
- Lst => Last_Index (Container)'Old,
- Offset => Count);
-
- procedure Append (Container : in out Vector; New_Item : Vector) with
- Global => null,
- Pre =>
- Length (Container) <= Capacity (Container) - Length (New_Item),
- Post =>
- Length (Container) = Length (Container)'Old + Length (New_Item)
-
- -- The elements of Container are preserved
-
- and Model (Container)'Old <= Model (Container)
-
- -- Elements of New_Item are inserted at the end of Container
-
- and (if Length (New_Item) > 0 then
- M.Range_Shifted
- (Left => Model (New_Item),
- Right => Model (Container),
- Fst => Index_Type'First,
- Lst => Last_Index (New_Item),
- Offset =>
- Count_Type
- (Last_Index (Container)'Old - Index_Type'First + 1)));
-
- procedure Append (Container : in out Vector; New_Item : Element_Type) with
- Global => null,
- Pre => Length (Container) < Capacity (Container),
- Post =>
- Length (Container) = Length (Container)'Old + 1
-
- -- Elements of Container are preserved
-
- and Model (Container)'Old < Model (Container)
-
- -- Container now has New_Item at the end of Container
-
- and Element
- (Model (Container), Last_Index (Container)'Old + 1) = New_Item;
-
- procedure Append
- (Container : in out Vector;
- New_Item : Element_Type;
- Count : Count_Type)
- with
- Global => null,
- Pre => Length (Container) <= Capacity (Container) - Count,
- Post =>
- Length (Container) = Length (Container)'Old + Count
-
- -- Elements of Container are preserved
-
- and Model (Container)'Old <= Model (Container)
-
- -- New_Item is inserted Count times at the end of Container
-
- and (if Count > 0 then
- M.Constant_Range
- (Container => Model (Container),
- Fst => Last_Index (Container)'Old + 1,
- Lst =>
- Last_Index (Container)'Old + Index_Type'Base (Count),
- Item => New_Item));
-
- procedure Delete (Container : in out Vector; Index : Extended_Index) with
- Global => null,
- Pre => Index in First_Index (Container) .. Last_Index (Container),
- Post =>
- Length (Container) = Length (Container)'Old - 1
-
- -- Elements located before Index in Container are preserved
-
- and M.Range_Equal
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => Index_Type'First,
- Lst => Index - 1)
-
- -- Elements located after Index in Container are shifted by 1
-
- and M.Range_Shifted
- (Left => Model (Container),
- Right => Model (Container)'Old,
- Fst => Index,
- Lst => Last_Index (Container),
- Offset => 1);
-
- procedure Delete
- (Container : in out Vector;
- Index : Extended_Index;
- Count : Count_Type)
- with
- Global => null,
- Pre =>
- Index in First_Index (Container) .. Last_Index (Container),
- Post =>
- Length (Container) in
- Length (Container)'Old - Count .. Length (Container)'Old
-
- -- The elements of Container located before Index are preserved.
-
- and M.Range_Equal
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => Index_Type'First,
- Lst => Index - 1),
-
- Contract_Cases =>
-
- -- All the elements after Position have been erased
-
- (Length (Container) - Count <= Count_Type (Index - Index_Type'First) =>
- Length (Container) = Count_Type (Index - Index_Type'First),
-
- others =>
- Length (Container) = Length (Container)'Old - Count
-
- -- Other elements are shifted by Count
-
- and M.Range_Shifted
- (Left => Model (Container),
- Right => Model (Container)'Old,
- Fst => Index,
- Lst => Last_Index (Container),
- Offset => Count));
-
- procedure Delete_First (Container : in out Vector) with
- Global => null,
- Pre => Length (Container) > 0,
- Post =>
- Length (Container) = Length (Container)'Old - 1
-
- -- Elements of Container are shifted by 1
-
- and M.Range_Shifted
- (Left => Model (Container),
- Right => Model (Container)'Old,
- Fst => Index_Type'First,
- Lst => Last_Index (Container),
- Offset => 1);
-
- procedure Delete_First (Container : in out Vector; Count : Count_Type) with
- Global => null,
- Contract_Cases =>
-
- -- All the elements of Container have been erased
-
- (Length (Container) <= Count => Length (Container) = 0,
-
- others =>
- Length (Container) = Length (Container)'Old - Count
-
- -- Elements of Container are shifted by Count
-
- and M.Range_Shifted
- (Left => Model (Container),
- Right => Model (Container)'Old,
- Fst => Index_Type'First,
- Lst => Last_Index (Container),
- Offset => Count));
-
- procedure Delete_Last (Container : in out Vector) with
- Global => null,
- Pre => Length (Container) > 0,
- Post =>
- Length (Container) = Length (Container)'Old - 1
-
- -- Elements of Container are preserved
-
- and Model (Container) < Model (Container)'Old;
-
- procedure Delete_Last (Container : in out Vector; Count : Count_Type) with
- Global => null,
- Contract_Cases =>
-
- -- All the elements after Position have been erased
-
- (Length (Container) <= Count => Length (Container) = 0,
-
- others =>
- Length (Container) = Length (Container)'Old - Count
-
- -- The elements of Container are preserved
-
- and Model (Container) <= Model (Container)'Old);
-
- procedure Reverse_Elements (Container : in out Vector) with
- Global => null,
- Post => M_Elements_Reversed (Model (Container)'Old, Model (Container));
-
- procedure Swap
- (Container : in out Vector;
- I : Index_Type;
- J : Index_Type)
- with
- Global => null,
- Pre =>
- I in First_Index (Container) .. Last_Index (Container)
- and then J in First_Index (Container) .. Last_Index (Container),
- Post =>
- M_Elements_Swapped (Model (Container)'Old, Model (Container), I, J);
-
- function First_Index (Container : Vector) return Index_Type with
- Global => null,
- Post => First_Index'Result = Index_Type'First;
- pragma Annotate (GNATprove, Inline_For_Proof, First_Index);
-
- function First_Element (Container : Vector) return Element_Type with
- Global => null,
- Pre => not Is_Empty (Container),
- Post =>
- First_Element'Result = Element (Model (Container), Index_Type'First);
- pragma Annotate (GNATprove, Inline_For_Proof, First_Element);
-
- function Last_Index (Container : Vector) return Extended_Index with
- Global => null,
- Post => Last_Index'Result = M.Last (Model (Container));
- pragma Annotate (GNATprove, Inline_For_Proof, Last_Index);
-
- function Last_Element (Container : Vector) return Element_Type with
- Global => null,
- Pre => not Is_Empty (Container),
- Post =>
- Last_Element'Result =
- Element (Model (Container), Last_Index (Container));
- pragma Annotate (GNATprove, Inline_For_Proof, Last_Element);
-
- function Find_Index
- (Container : Vector;
- Item : Element_Type;
- Index : Index_Type := Index_Type'First) return Extended_Index
- with
- Global => null,
- Contract_Cases =>
-
- -- If Item is not contained in Container after Index, Find_Index
- -- returns No_Index.
-
- (Index > Last_Index (Container)
- or else not M.Contains
- (Container => Model (Container),
- Fst => Index,
- Lst => Last_Index (Container),
- Item => Item)
- =>
- Find_Index'Result = No_Index,
-
- -- Otherwise, Find_Index returns a valid index greater than Index
-
- others =>
- Find_Index'Result in Index .. Last_Index (Container)
-
- -- The element at this index in Container is Item
-
- and Element (Model (Container), Find_Index'Result) = Item
-
- -- It is the first occurrence of Item after Index in Container
-
- and not M.Contains
- (Container => Model (Container),
- Fst => Index,
- Lst => Find_Index'Result - 1,
- Item => Item));
-
- function Reverse_Find_Index
- (Container : Vector;
- Item : Element_Type;
- Index : Index_Type := Index_Type'Last) return Extended_Index
- with
- Global => null,
- Contract_Cases =>
-
- -- If Item is not contained in Container before Index,
- -- Reverse_Find_Index returns No_Index.
-
- (not M.Contains
- (Container => Model (Container),
- Fst => Index_Type'First,
- Lst => (if Index <= Last_Index (Container) then Index
- else Last_Index (Container)),
- Item => Item)
- =>
- Reverse_Find_Index'Result = No_Index,
-
- -- Otherwise, Reverse_Find_Index returns a valid index smaller than
- -- Index
-
- others =>
- Reverse_Find_Index'Result in Index_Type'First .. Index
- and Reverse_Find_Index'Result <= Last_Index (Container)
-
- -- The element at this index in Container is Item
-
- and Element (Model (Container), Reverse_Find_Index'Result) = Item
-
- -- It is the last occurrence of Item before Index in Container
-
- and not M.Contains
- (Container => Model (Container),
- Fst => Reverse_Find_Index'Result + 1,
- Lst =>
- (if Index <= Last_Index (Container) then
- Index
- else
- Last_Index (Container)),
- Item => Item));
-
- function Contains
- (Container : Vector;
- Item : Element_Type) return Boolean
- with
- Global => null,
- Post =>
- Contains'Result =
- M.Contains
- (Container => Model (Container),
- Fst => Index_Type'First,
- Lst => Last_Index (Container),
- Item => Item);
-
- function Has_Element
- (Container : Vector;
- Position : Extended_Index) return Boolean
- with
- Global => null,
- Post =>
- Has_Element'Result =
- (Position in Index_Type'First .. Last_Index (Container));
- pragma Annotate (GNATprove, Inline_For_Proof, Has_Element);
-
- generic
- with function "<" (Left, Right : Element_Type) return Boolean is <>;
- package Generic_Sorting with SPARK_Mode is
-
- package Formal_Model with Ghost is
-
- function M_Elements_Sorted (Container : M.Sequence) return Boolean
- with
- Global => null,
- Post =>
- M_Elements_Sorted'Result =
- (for all I in Index_Type'First .. M.Last (Container) =>
- (for all J in I .. M.Last (Container) =>
- Element (Container, I) = Element (Container, J)
- or Element (Container, I) < Element (Container, J)));
- pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_Sorted);
-
- end Formal_Model;
- use Formal_Model;
-
- function Is_Sorted (Container : Vector) return Boolean with
- Global => null,
- Post => Is_Sorted'Result = M_Elements_Sorted (Model (Container));
-
- procedure Sort (Container : in out Vector) with
- Global => null,
- Post =>
- Length (Container) = Length (Container)'Old
- and M_Elements_Sorted (Model (Container))
- and M_Elements_Included
- (Left => Model (Container)'Old,
- L_Lst => Last_Index (Container),
- Right => Model (Container),
- R_Lst => Last_Index (Container))
- and M_Elements_Included
- (Left => Model (Container),
- L_Lst => Last_Index (Container),
- Right => Model (Container)'Old,
- R_Lst => Last_Index (Container));
-
- procedure Merge (Target : in out Vector; Source : in out Vector) with
- -- Target and Source should not be aliased
- Global => null,
- Pre => Length (Source) <= Capacity (Target) - Length (Target),
- Post =>
- Length (Target) = Length (Target)'Old + Length (Source)'Old
- and Length (Source) = 0
- and (if M_Elements_Sorted (Model (Target)'Old)
- and M_Elements_Sorted (Model (Source)'Old)
- then
- M_Elements_Sorted (Model (Target)))
- and M_Elements_Included
- (Left => Model (Target)'Old,
- L_Lst => Last_Index (Target)'Old,
- Right => Model (Target),
- R_Lst => Last_Index (Target))
- and M_Elements_Included
- (Left => Model (Source)'Old,
- L_Lst => Last_Index (Source)'Old,
- Right => Model (Target),
- R_Lst => Last_Index (Target))
- and M_Elements_In_Union
- (Model (Target),
- Model (Source)'Old,
- Model (Target)'Old);
- end Generic_Sorting;
-
- ---------------------------
- -- Iteration Primitives --
- ---------------------------
-
- function Iter_First (Container : Vector) return Extended_Index with
- Global => null;
-
- function Iter_Has_Element
- (Container : Vector;
- Position : Extended_Index) return Boolean
- with
- Global => null,
- Post =>
- Iter_Has_Element'Result =
- (Position in Index_Type'First .. Last_Index (Container));
- pragma Annotate (GNATprove, Inline_For_Proof, Iter_Has_Element);
-
- function Iter_Next
- (Container : Vector;
- Position : Extended_Index) return Extended_Index
- with
- Global => null,
- Pre => Iter_Has_Element (Container, Position);
-
-private
- pragma SPARK_Mode (Off);
-
- pragma Inline (First_Index);
- pragma Inline (Last_Index);
- pragma Inline (Element);
- pragma Inline (First_Element);
- pragma Inline (Last_Element);
- pragma Inline (Replace_Element);
- pragma Inline (Contains);
-
- subtype Array_Index is Capacity_Range range 1 .. Capacity_Range'Last;
- type Elements_Array is array (Array_Index range <>) of aliased Element_Type;
- function "=" (L, R : Elements_Array) return Boolean is abstract;
-
- type Vector (Capacity : Capacity_Range) is record
- Last : Extended_Index := No_Index;
- Elements : Elements_Array (1 .. Capacity);
- end record;
-
- function Empty_Vector return Vector is
- ((Capacity => 0, others => <>));
-
- function Iter_First (Container : Vector) return Extended_Index is
- (Index_Type'First);
-
- function Iter_Next
- (Container : Vector;
- Position : Extended_Index) return Extended_Index
- is
- (if Position = Extended_Index'Last then
- Extended_Index'First
- else
- Extended_Index'Succ (Position));
+package Ada.Containers.Formal_Vectors with SPARK_Mode is
- function Iter_Has_Element
- (Container : Vector;
- Position : Extended_Index) return Boolean
- is
- (Position in Index_Type'First .. Container.Last);
+ pragma Compile_Time_Error
+ (True,
+ "This package has been moved to the SPARK library shipped with any"
+ & " SPARK release starting with version 23.");
end Ada.Containers.Formal_Vectors;
diff --git a/gcc/ada/libgnat/a-cofuba.adb b/gcc/ada/libgnat/a-cofuba.adb
deleted file mode 100644
index 68cf2ae..0000000
--- a/gcc/ada/libgnat/a-cofuba.adb
+++ /dev/null
@@ -1,432 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT LIBRARY COMPONENTS --
--- --
--- ADA.CONTAINERS.FUNCTIONAL_BASE --
--- --
--- B o d y --
--- --
--- Copyright (C) 2016-2022, Free Software Foundation, Inc. --
--- --
--- This specification is derived from the Ada Reference Manual for use with --
--- GNAT. The copyright notice above, and the license provisions that follow --
--- apply solely to the contents of the part following the private keyword. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
-------------------------------------------------------------------------------
-
-pragma Ada_2012;
-with Ada.Unchecked_Deallocation;
-
-package body Ada.Containers.Functional_Base with SPARK_Mode => Off is
-
- function To_Count (Idx : Extended_Index) return Count_Type is
- (Count_Type
- (Extended_Index'Pos (Idx) -
- Extended_Index'Pos (Extended_Index'First)));
-
- function To_Index (Position : Count_Type) return Extended_Index is
- (Extended_Index'Val
- (Position + Extended_Index'Pos (Extended_Index'First)));
- -- Conversion functions between Index_Type and Count_Type
-
- function Find (C : Container; E : access Element_Type) return Count_Type;
- -- Search a container C for an element equal to E.all, returning the
- -- position in the underlying array.
-
- procedure Resize (Base : Array_Base_Access);
- -- Resize the underlying array if needed so that it can contain one more
- -- element.
-
- function Elements (C : Container) return Element_Array_Access is
- (C.Controlled_Base.Base.Elements)
- with
- Global => null,
- Pre =>
- C.Controlled_Base.Base /= null
- and then C.Controlled_Base.Base.Elements /= null;
-
- function Get
- (C_E : Element_Array_Access;
- I : Count_Type)
- return Element_Access
- is
- (C_E (I).Ref.E_Access)
- with
- Global => null,
- Pre => C_E /= null and then C_E (I).Ref /= null;
-
- ---------
- -- "=" --
- ---------
-
- function "=" (C1 : Container; C2 : Container) return Boolean is
- begin
- if C1.Length /= C2.Length then
- return False;
- end if;
- for I in 1 .. C1.Length loop
- if Get (Elements (C1), I).all /= Get (Elements (C2), I).all then
- return False;
- end if;
- end loop;
-
- return True;
- end "=";
-
- ----------
- -- "<=" --
- ----------
-
- function "<=" (C1 : Container; C2 : Container) return Boolean is
- begin
- for I in 1 .. C1.Length loop
- if Find (C2, Get (Elements (C1), I)) = 0 then
- return False;
- end if;
- end loop;
-
- return True;
- end "<=";
-
- ---------
- -- Add --
- ---------
-
- function Add
- (C : Container;
- I : Index_Type;
- E : Element_Type) return Container
- is
- C_B : Array_Base_Access renames C.Controlled_Base.Base;
- begin
- if To_Count (I) = C.Length + 1 and then C.Length = C_B.Max_Length then
- Resize (C_B);
- C_B.Max_Length := C_B.Max_Length + 1;
- C_B.Elements (C_B.Max_Length) := Element_Init (E);
-
- return Container'(Length => C_B.Max_Length,
- Controlled_Base => C.Controlled_Base);
- else
- declare
- A : constant Array_Base_Controlled_Access :=
- Content_Init (C.Length);
- P : Count_Type := 0;
- begin
- A.Base.Max_Length := C.Length + 1;
- for J in 1 .. C.Length + 1 loop
- if J /= To_Count (I) then
- P := P + 1;
- A.Base.Elements (J) := C_B.Elements (P);
- else
- A.Base.Elements (J) := Element_Init (E);
- end if;
- end loop;
-
- return Container'(Length => A.Base.Max_Length,
- Controlled_Base => A);
- end;
- end if;
- end Add;
-
- ------------
- -- Adjust --
- ------------
-
- procedure Adjust (Controlled_Base : in out Array_Base_Controlled_Access) is
- C_B : Array_Base_Access renames Controlled_Base.Base;
- begin
- if C_B /= null then
- C_B.Reference_Count := C_B.Reference_Count + 1;
- end if;
- end Adjust;
-
- procedure Adjust (Ctrl_E : in out Controlled_Element_Access) is
- begin
- if Ctrl_E.Ref /= null then
- Ctrl_E.Ref.Reference_Count := Ctrl_E.Ref.Reference_Count + 1;
- end if;
- end Adjust;
-
- ------------------
- -- Content_Init --
- ------------------
-
- function Content_Init
- (L : Count_Type := 0) return Array_Base_Controlled_Access
- is
- Max_Init : constant Count_Type := 100;
- Size : constant Count_Type :=
- (if L < Count_Type'Last - Max_Init then L + Max_Init
- else Count_Type'Last);
-
- -- The Access in the array will be initialized to null
-
- Elements : constant Element_Array_Access :=
- new Element_Array'(1 .. Size => <>);
- B : constant Array_Base_Access :=
- new Array_Base'(Reference_Count => 1,
- Max_Length => 0,
- Elements => Elements);
- begin
- return (Ada.Finalization.Controlled with Base => B);
- end Content_Init;
-
- ------------------
- -- Element_Init --
- ------------------
-
- function Element_Init (E : Element_Type) return Controlled_Element_Access
- is
- Refcounted_E : constant Refcounted_Element_Access :=
- new Refcounted_Element'(Reference_Count => 1,
- E_Access => new Element_Type'(E));
- begin
- return (Ada.Finalization.Controlled with Ref => Refcounted_E);
- end Element_Init;
-
- --------------
- -- Finalize --
- --------------
-
- procedure Finalize (Controlled_Base : in out Array_Base_Controlled_Access)
- is
- procedure Unchecked_Free_Base is new Ada.Unchecked_Deallocation
- (Object => Array_Base,
- Name => Array_Base_Access);
- procedure Unchecked_Free_Array is new Ada.Unchecked_Deallocation
- (Object => Element_Array,
- Name => Element_Array_Access);
-
- C_B : Array_Base_Access renames Controlled_Base.Base;
- begin
- if C_B /= null then
- C_B.Reference_Count := C_B.Reference_Count - 1;
- if C_B.Reference_Count = 0 then
- Unchecked_Free_Array (Controlled_Base.Base.Elements);
- Unchecked_Free_Base (Controlled_Base.Base);
- end if;
- C_B := null;
- end if;
- end Finalize;
-
- procedure Finalize (Ctrl_E : in out Controlled_Element_Access) is
- procedure Unchecked_Free_Ref is new Ada.Unchecked_Deallocation
- (Object => Refcounted_Element,
- Name => Refcounted_Element_Access);
-
- procedure Unchecked_Free_Element is new Ada.Unchecked_Deallocation
- (Object => Element_Type,
- Name => Element_Access);
-
- begin
- if Ctrl_E.Ref /= null then
- Ctrl_E.Ref.Reference_Count := Ctrl_E.Ref.Reference_Count - 1;
- if Ctrl_E.Ref.Reference_Count = 0 then
- Unchecked_Free_Element (Ctrl_E.Ref.E_Access);
- Unchecked_Free_Ref (Ctrl_E.Ref);
- end if;
- Ctrl_E.Ref := null;
- end if;
- end Finalize;
-
- ----------
- -- Find --
- ----------
-
- function Find (C : Container; E : access Element_Type) return Count_Type is
- begin
- for I in 1 .. C.Length loop
- if Get (Elements (C), I).all = E.all then
- return I;
- end if;
- end loop;
-
- return 0;
- end Find;
-
- function Find (C : Container; E : Element_Type) return Extended_Index is
- (To_Index (Find (C, E'Unrestricted_Access)));
-
- ---------
- -- Get --
- ---------
-
- function Get (C : Container; I : Index_Type) return Element_Type is
- (Get (Elements (C), To_Count (I)).all);
-
- ------------------
- -- Intersection --
- ------------------
-
- function Intersection (C1 : Container; C2 : Container) return Container is
- L : constant Count_Type := Num_Overlaps (C1, C2);
- A : constant Array_Base_Controlled_Access := Content_Init (L);
- P : Count_Type := 0;
-
- begin
- A.Base.Max_Length := L;
- for I in 1 .. C1.Length loop
- if Find (C2, Get (Elements (C1), I)) > 0 then
- P := P + 1;
- A.Base.Elements (P) := Elements (C1) (I);
- end if;
- end loop;
-
- return Container'(Length => P, Controlled_Base => A);
- end Intersection;
-
- ------------
- -- Length --
- ------------
-
- function Length (C : Container) return Count_Type is (C.Length);
- ---------------------
- -- Num_Overlaps --
- ---------------------
-
- function Num_Overlaps (C1 : Container; C2 : Container) return Count_Type is
- P : Count_Type := 0;
-
- begin
- for I in 1 .. C1.Length loop
- if Find (C2, Get (Elements (C1), I)) > 0 then
- P := P + 1;
- end if;
- end loop;
-
- return P;
- end Num_Overlaps;
-
- ------------
- -- Remove --
- ------------
-
- function Remove (C : Container; I : Index_Type) return Container is
- begin
- if To_Count (I) = C.Length then
- return Container'(Length => C.Length - 1,
- Controlled_Base => C.Controlled_Base);
- else
- declare
- A : constant Array_Base_Controlled_Access
- := Content_Init (C.Length - 1);
- P : Count_Type := 0;
- begin
- A.Base.Max_Length := C.Length - 1;
- for J in 1 .. C.Length loop
- if J /= To_Count (I) then
- P := P + 1;
- A.Base.Elements (P) := Elements (C) (J);
- end if;
- end loop;
-
- return Container'(Length => C.Length - 1, Controlled_Base => A);
- end;
- end if;
- end Remove;
-
- ------------
- -- Resize --
- ------------
-
- procedure Resize (Base : Array_Base_Access) is
- begin
- if Base.Max_Length < Base.Elements'Length then
- return;
- end if;
-
- pragma Assert (Base.Max_Length = Base.Elements'Length);
-
- if Base.Max_Length = Count_Type'Last then
- raise Constraint_Error;
- end if;
-
- declare
- procedure Finalize is new Ada.Unchecked_Deallocation
- (Object => Element_Array,
- Name => Element_Array_Access_Base);
-
- New_Length : constant Positive_Count_Type :=
- (if Base.Max_Length > Count_Type'Last / 2 then Count_Type'Last
- else 2 * Base.Max_Length);
- Elements : constant Element_Array_Access :=
- new Element_Array (1 .. New_Length);
- Old_Elmts : Element_Array_Access_Base := Base.Elements;
- begin
- Elements (1 .. Base.Max_Length) := Base.Elements.all;
- Base.Elements := Elements;
- Finalize (Old_Elmts);
- end;
- end Resize;
-
- ---------
- -- Set --
- ---------
-
- function Set
- (C : Container;
- I : Index_Type;
- E : Element_Type) return Container
- is
- Result : constant Container :=
- Container'(Length => C.Length,
- Controlled_Base => Content_Init (C.Length));
- R_Base : Array_Base_Access renames Result.Controlled_Base.Base;
-
- begin
- R_Base.Max_Length := C.Length;
- R_Base.Elements (1 .. C.Length) := Elements (C) (1 .. C.Length);
- R_Base.Elements (To_Count (I)) := Element_Init (E);
- return Result;
- end Set;
-
- -----------
- -- Union --
- -----------
-
- function Union (C1 : Container; C2 : Container) return Container is
- N : constant Count_Type := Num_Overlaps (C1, C2);
-
- begin
- -- if C2 is completely included in C1 then return C1
-
- if N = Length (C2) then
- return C1;
- end if;
-
- -- else loop through C2 to find the remaining elements
-
- declare
- L : constant Count_Type := Length (C1) - N + Length (C2);
- A : constant Array_Base_Controlled_Access := Content_Init (L);
- P : Count_Type := Length (C1);
- begin
- A.Base.Max_Length := L;
- A.Base.Elements (1 .. C1.Length) := Elements (C1) (1 .. C1.Length);
- for I in 1 .. C2.Length loop
- if Find (C1, Get (Elements (C2), I)) = 0 then
- P := P + 1;
- A.Base.Elements (P) := Elements (C2) (I);
- end if;
- end loop;
-
- return Container'(Length => L, Controlled_Base => A);
- end;
- end Union;
-
-end Ada.Containers.Functional_Base;
diff --git a/gcc/ada/libgnat/a-cofuba.ads b/gcc/ada/libgnat/a-cofuba.ads
deleted file mode 100644
index 8a99a43..0000000
--- a/gcc/ada/libgnat/a-cofuba.ads
+++ /dev/null
@@ -1,198 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT LIBRARY COMPONENTS --
--- --
--- ADA.CONTAINERS.FUNCTIONAL_BASE --
--- --
--- S p e c --
--- --
--- Copyright (C) 2016-2022, Free Software Foundation, Inc. --
--- --
--- This specification is derived from the Ada Reference Manual for use with --
--- GNAT. The copyright notice above, and the license provisions that follow --
--- apply solely to the contents of the part following the private keyword. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
-------------------------------------------------------------------------------
--- Functional containers are neither controlled nor limited. This is safe, as
--- no primitives are provided to modify them.
--- Memory allocated inside functional containers is never reclaimed.
-
-pragma Ada_2012;
-
--- To allow reference counting on the base container
-
-private with Ada.Finalization;
-
-private generic
- type Index_Type is (<>);
- -- To avoid Constraint_Error being raised at run time, Index_Type'Base
- -- should have at least one more element at the low end than Index_Type.
-
- type Element_Type (<>) is private;
- with function "=" (Left, Right : Element_Type) return Boolean is <>;
-
-package Ada.Containers.Functional_Base with SPARK_Mode => Off is
-
- subtype Extended_Index is Index_Type'Base range
- Index_Type'Pred (Index_Type'First) .. Index_Type'Last;
-
- type Container is private;
-
- function "=" (C1 : Container; C2 : Container) return Boolean;
- -- Return True if C1 and C2 contain the same elements at the same position
-
- function Length (C : Container) return Count_Type;
- -- Number of elements stored in C
-
- function Get (C : Container; I : Index_Type) return Element_Type;
- -- Access to the element at index I in C
-
- function Set
- (C : Container;
- I : Index_Type;
- E : Element_Type) return Container;
- -- Return a new container which is equal to C except for the element at
- -- index I, which is set to E.
-
- function Add
- (C : Container;
- I : Index_Type;
- E : Element_Type) return Container;
- -- Return a new container that is C with E inserted at index I
-
- function Remove (C : Container; I : Index_Type) return Container;
- -- Return a new container that is C without the element at index I
-
- function Find (C : Container; E : Element_Type) return Extended_Index;
- -- Return the first index for which the element stored in C is I. If there
- -- are no such indexes, return Extended_Index'First.
-
- --------------------
- -- Set Operations --
- --------------------
-
- function "<=" (C1 : Container; C2 : Container) return Boolean;
- -- Return True if every element of C1 is in C2
-
- function Num_Overlaps (C1 : Container; C2 : Container) return Count_Type;
- -- Return the number of elements that are in both C1 and C2
-
- function Union (C1 : Container; C2 : Container) return Container;
- -- Return a container which is C1 plus all the elements of C2 that are not
- -- in C1.
-
- function Intersection (C1 : Container; C2 : Container) return Container;
- -- Return a container which is C1 minus all the elements that are also in
- -- C2.
-
-private
-
- -- Theoretically, each operation on a functional container implies the
- -- creation of a new container i.e. the copy of the array itself and all
- -- the elements in it. In the implementation, most of these copies are
- -- avoided by sharing between the containers.
- --
- -- A container stores its last used index. So, when adding an
- -- element at the end of the container, the exact same array can be reused.
- -- As a functionnal container cannot be modifed once created, there is no
- -- risk of unwanted modifications.
- --
- -- _1_2_3_
- -- S : end => [1, 2, 3]
- -- |
- -- |1|2|3|4|.|.|
- -- |
- -- Add (S, 4, 4) : end => [1, 2, 3, 4]
- --
- -- The elements are also shared between containers as much as possible. For
- -- example, when something is added in the middle, the array is changed but
- -- the elementes are reused.
- --
- -- _1_2_3_4_
- -- S : |1|2|3|4| => [1, 2, 3, 4]
- -- | \ \ \
- -- Add (S, 2, 5) : |1|5|2|3|4| => [1, 5, 2, 3, 4]
- --
- -- To make this sharing possible, both the elements and the arrays are
- -- stored inside dynamically allocated access types which shall be
- -- deallocated when they are no longer used. The memory is managed using
- -- reference counting both at the array and at the element level.
-
- subtype Positive_Count_Type is Count_Type range 1 .. Count_Type'Last;
-
- type Reference_Count_Type is new Natural;
-
- type Element_Access is access all Element_Type;
-
- type Refcounted_Element is record
- Reference_Count : Reference_Count_Type;
- E_Access : Element_Access;
- end record;
-
- type Refcounted_Element_Access is access Refcounted_Element;
-
- type Controlled_Element_Access is new Ada.Finalization.Controlled
- with record
- Ref : Refcounted_Element_Access := null;
- end record;
-
- function Element_Init (E : Element_Type) return Controlled_Element_Access;
- -- Use to initialize a refcounted element
-
- type Element_Array is
- array (Positive_Count_Type range <>) of Controlled_Element_Access;
-
- type Element_Array_Access_Base is access Element_Array;
-
- subtype Element_Array_Access is Element_Array_Access_Base;
-
- type Array_Base is record
- Reference_Count : Reference_Count_Type;
- Max_Length : Count_Type;
- Elements : Element_Array_Access;
- end record;
-
- type Array_Base_Access is access Array_Base;
-
- type Array_Base_Controlled_Access is new Ada.Finalization.Controlled
- with record
- Base : Array_Base_Access;
- end record;
-
- overriding procedure Adjust
- (Controlled_Base : in out Array_Base_Controlled_Access);
-
- overriding procedure Finalize
- (Controlled_Base : in out Array_Base_Controlled_Access);
-
- overriding procedure Adjust
- (Ctrl_E : in out Controlled_Element_Access);
-
- overriding procedure Finalize
- (Ctrl_E : in out Controlled_Element_Access);
-
- function Content_Init (L : Count_Type := 0)
- return Array_Base_Controlled_Access;
- -- Used to initialize the content of an array base with length L
-
- type Container is record
- Length : Count_Type := 0;
- Controlled_Base : Array_Base_Controlled_Access := Content_Init;
- end record;
-
-end Ada.Containers.Functional_Base;
diff --git a/gcc/ada/libgnat/a-cofuma.adb b/gcc/ada/libgnat/a-cofuma.adb
deleted file mode 100644
index f83b4d8..0000000
--- a/gcc/ada/libgnat/a-cofuma.adb
+++ /dev/null
@@ -1,306 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT LIBRARY COMPONENTS --
--- --
--- ADA.CONTAINERS.FUNCTIONAL_MAPS --
--- --
--- B o d y --
--- --
--- Copyright (C) 2016-2022, Free Software Foundation, Inc. --
--- --
--- This specification is derived from the Ada Reference Manual for use with --
--- GNAT. The copyright notice above, and the license provisions that follow --
--- apply solely to the contents of the part following the private keyword. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
-------------------------------------------------------------------------------
-
-pragma Ada_2012;
-package body Ada.Containers.Functional_Maps with SPARK_Mode => Off is
- use Key_Containers;
- use Element_Containers;
-
- package Conversions is new Signed_Conversions (Int => Count_Type);
- use Conversions;
-
- ---------
- -- "=" --
- ---------
-
- function "=" (Left : Map; Right : Map) return Boolean is
- (Left.Keys <= Right.Keys and Right <= Left);
-
- ----------
- -- "<=" --
- ----------
-
- function "<=" (Left : Map; Right : Map) return Boolean is
- I2 : Count_Type;
-
- begin
- for I1 in 1 .. Length (Left.Keys) loop
- I2 := Find (Right.Keys, Get (Left.Keys, I1));
- if I2 = 0
- or else Get (Right.Elements, I2) /= Get (Left.Elements, I1)
- then
- return False;
- end if;
- end loop;
- return True;
- end "<=";
-
- ---------
- -- Add --
- ---------
-
- function Add
- (Container : Map;
- New_Key : Key_Type;
- New_Item : Element_Type) return Map
- is
- begin
- return
- (Keys =>
- Add (Container.Keys, Length (Container.Keys) + 1, New_Key),
- Elements =>
- Add
- (Container.Elements, Length (Container.Elements) + 1, New_Item));
- end Add;
-
- ---------------------------
- -- Elements_Equal_Except --
- ---------------------------
-
- function Elements_Equal_Except
- (Left : Map;
- Right : Map;
- New_Key : Key_Type) return Boolean
- is
- begin
- for J in 1 .. Length (Left.Keys) loop
- declare
- K : constant Key_Type := Get (Left.Keys, J);
- begin
- if not Equivalent_Keys (K, New_Key)
- and then
- (Find (Right.Keys, K) = 0
- or else Get (Right.Elements, Find (Right.Keys, K)) /=
- Get (Left.Elements, J))
- then
- return False;
- end if;
- end;
- end loop;
- return True;
- end Elements_Equal_Except;
-
- function Elements_Equal_Except
- (Left : Map;
- Right : Map;
- X : Key_Type;
- Y : Key_Type) return Boolean
- is
- begin
- for J in 1 .. Length (Left.Keys) loop
- declare
- K : constant Key_Type := Get (Left.Keys, J);
- begin
- if not Equivalent_Keys (K, X)
- and then not Equivalent_Keys (K, Y)
- and then
- (Find (Right.Keys, K) = 0
- or else Get (Right.Elements, Find (Right.Keys, K)) /=
- Get (Left.Elements, J))
- then
- return False;
- end if;
- end;
- end loop;
- return True;
- end Elements_Equal_Except;
-
- ---------------
- -- Empty_Map --
- ---------------
-
- function Empty_Map return Map is
- ((others => <>));
-
- ---------
- -- Get --
- ---------
-
- function Get (Container : Map; Key : Key_Type) return Element_Type is
- begin
- return Get (Container.Elements, Find (Container.Keys, Key));
- end Get;
-
- -------------
- -- Has_Key --
- -------------
-
- function Has_Key (Container : Map; Key : Key_Type) return Boolean is
- begin
- return Find (Container.Keys, Key) > 0;
- end Has_Key;
-
- -----------------
- -- Has_Witness --
- -----------------
-
- function Has_Witness
- (Container : Map;
- Witness : Count_Type) return Boolean
- is
- (Witness in 1 .. Length (Container.Keys));
-
- --------------
- -- Is_Empty --
- --------------
-
- function Is_Empty (Container : Map) return Boolean is
- begin
- return Length (Container.Keys) = 0;
- end Is_Empty;
-
- -------------------
- -- Keys_Included --
- -------------------
-
- function Keys_Included (Left : Map; Right : Map) return Boolean is
- begin
- for J in 1 .. Length (Left.Keys) loop
- declare
- K : constant Key_Type := Get (Left.Keys, J);
- begin
- if Find (Right.Keys, K) = 0 then
- return False;
- end if;
- end;
- end loop;
-
- return True;
- end Keys_Included;
-
- --------------------------
- -- Keys_Included_Except --
- --------------------------
-
- function Keys_Included_Except
- (Left : Map;
- Right : Map;
- New_Key : Key_Type) return Boolean
- is
- begin
- for J in 1 .. Length (Left.Keys) loop
- declare
- K : constant Key_Type := Get (Left.Keys, J);
- begin
- if not Equivalent_Keys (K, New_Key)
- and then Find (Right.Keys, K) = 0
- then
- return False;
- end if;
- end;
- end loop;
-
- return True;
- end Keys_Included_Except;
-
- function Keys_Included_Except
- (Left : Map;
- Right : Map;
- X : Key_Type;
- Y : Key_Type) return Boolean
- is
- begin
- for J in 1 .. Length (Left.Keys) loop
- declare
- K : constant Key_Type := Get (Left.Keys, J);
- begin
- if not Equivalent_Keys (K, X)
- and then not Equivalent_Keys (K, Y)
- and then Find (Right.Keys, K) = 0
- then
- return False;
- end if;
- end;
- end loop;
-
- return True;
- end Keys_Included_Except;
-
- ------------
- -- Length --
- ------------
-
- function Length (Container : Map) return Big_Natural is
- begin
- return To_Big_Integer (Length (Container.Elements));
- end Length;
-
- ------------
- -- Remove --
- ------------
-
- function Remove (Container : Map; Key : Key_Type) return Map is
- J : constant Extended_Index := Find (Container.Keys, Key);
- begin
- return
- (Keys => Remove (Container.Keys, J),
- Elements => Remove (Container.Elements, J));
- end Remove;
-
- ---------------
- -- Same_Keys --
- ---------------
-
- function Same_Keys (Left : Map; Right : Map) return Boolean is
- (Keys_Included (Left, Right)
- and Keys_Included (Left => Right, Right => Left));
-
- ---------
- -- Set --
- ---------
-
- function Set
- (Container : Map;
- Key : Key_Type;
- New_Item : Element_Type) return Map
- is
- (Keys => Container.Keys,
- Elements =>
- Set (Container.Elements, Find (Container.Keys, Key), New_Item));
-
- -----------
- -- W_Get --
- -----------
-
- function W_Get
- (Container : Map;
- Witness : Count_Type) return Element_Type
- is
- (Get (Container.Elements, Witness));
-
- -------------
- -- Witness --
- -------------
-
- function Witness (Container : Map; Key : Key_Type) return Count_Type is
- (Find (Container.Keys, Key));
-
-end Ada.Containers.Functional_Maps;
diff --git a/gcc/ada/libgnat/a-cofuma.ads b/gcc/ada/libgnat/a-cofuma.ads
index f863cdc..9b4863a 100644
--- a/gcc/ada/libgnat/a-cofuma.ads
+++ b/gcc/ada/libgnat/a-cofuma.ads
@@ -29,368 +29,12 @@
-- <http://www.gnu.org/licenses/>. --
------------------------------------------------------------------------------
-pragma Ada_2012;
-private with Ada.Containers.Functional_Base;
-
-with Ada.Numerics.Big_Numbers.Big_Integers;
-use Ada.Numerics.Big_Numbers.Big_Integers;
-
generic
- type Key_Type (<>) is private;
- type Element_Type (<>) is private;
-
- with function Equivalent_Keys
- (Left : Key_Type;
- Right : Key_Type) return Boolean is "=";
- with function "=" (Left, Right : Element_Type) return Boolean is <>;
-
- Enable_Handling_Of_Equivalence : Boolean := True;
- -- This constant should only be set to False when no particular handling
- -- of equivalence over keys is needed, that is, Equivalent_Keys defines a
- -- key uniquely.
-
-package Ada.Containers.Functional_Maps with
- SPARK_Mode,
- Annotate => (GNATprove, Always_Return)
-is
-
- type Map is private with
- Default_Initial_Condition => Is_Empty (Map) and Length (Map) = 0,
- Iterable => (First => Iter_First,
- Next => Iter_Next,
- Has_Element => Iter_Has_Element,
- Element => Iter_Element);
- -- Maps are empty when default initialized.
- -- "For in" quantification over maps should not be used.
- -- "For of" quantification over maps iterates over keys.
- -- Note that, for proof, "for of" quantification is understood modulo
- -- equivalence (the range of quantification comprises all the keys that are
- -- equivalent to any key of the map).
-
- -----------------------
- -- Basic operations --
- -----------------------
-
- -- Maps are axiomatized using Has_Key and Get, encoding respectively the
- -- presence of a key in a map and an accessor to elements associated with
- -- its keys. The length of a map is also added to protect Add against
- -- overflows but it is not actually modeled.
-
- function Has_Key (Container : Map; Key : Key_Type) return Boolean with
- -- Return True if Key is present in Container
-
- Global => null,
- Post =>
- (if Enable_Handling_Of_Equivalence then
-
- -- Has_Key returns the same result on all equivalent keys
-
- (if (for some K of Container => Equivalent_Keys (K, Key)) then
- Has_Key'Result));
-
- function Get (Container : Map; Key : Key_Type) return Element_Type with
- -- Return the element associated with Key in Container
-
- Global => null,
- Pre => Has_Key (Container, Key),
- Post =>
- (if Enable_Handling_Of_Equivalence then
-
- -- Get returns the same result on all equivalent keys
-
- Get'Result = W_Get (Container, Witness (Container, Key))
- and (for all K of Container =>
- (Equivalent_Keys (K, Key) =
- (Witness (Container, Key) = Witness (Container, K)))));
-
- function Length (Container : Map) return Big_Natural with
- Global => null;
- -- Return the number of mappings in Container
-
- ------------------------
- -- Property Functions --
- ------------------------
-
- function "<=" (Left : Map; Right : Map) return Boolean with
- -- Map inclusion
-
- Global => null,
- Post =>
- "<="'Result =
- (for all Key of Left =>
- Has_Key (Right, Key) and then Get (Right, Key) = Get (Left, Key));
-
- function "=" (Left : Map; Right : Map) return Boolean with
- -- Extensional equality over maps
-
- Global => null,
- Post =>
- "="'Result =
- ((for all Key of Left =>
- Has_Key (Right, Key)
- and then Get (Right, Key) = Get (Left, Key))
- and (for all Key of Right => Has_Key (Left, Key)));
-
- pragma Warnings (Off, "unused variable ""Key""");
- function Is_Empty (Container : Map) return Boolean with
- -- A map is empty if it contains no key
-
- Global => null,
- Post => Is_Empty'Result = (for all Key of Container => False);
- pragma Warnings (On, "unused variable ""Key""");
-
- function Keys_Included (Left : Map; Right : Map) return Boolean
- -- Returns True if every Key of Left is in Right
-
- with
- Global => null,
- Post =>
- Keys_Included'Result = (for all Key of Left => Has_Key (Right, Key));
-
- function Same_Keys (Left : Map; Right : Map) return Boolean
- -- Returns True if Left and Right have the same keys
-
- with
- Global => null,
- Post =>
- Same_Keys'Result =
- (Keys_Included (Left, Right)
- and Keys_Included (Left => Right, Right => Left));
- pragma Annotate (GNATprove, Inline_For_Proof, Same_Keys);
-
- function Keys_Included_Except
- (Left : Map;
- Right : Map;
- New_Key : Key_Type) return Boolean
- -- Returns True if Left contains only keys of Right and possibly New_Key
-
- with
- Global => null,
- Post =>
- Keys_Included_Except'Result =
- (for all Key of Left =>
- (if not Equivalent_Keys (Key, New_Key) then
- Has_Key (Right, Key)));
-
- function Keys_Included_Except
- (Left : Map;
- Right : Map;
- X : Key_Type;
- Y : Key_Type) return Boolean
- -- Returns True if Left contains only keys of Right and possibly X and Y
-
- with
- Global => null,
- Post =>
- Keys_Included_Except'Result =
- (for all Key of Left =>
- (if not Equivalent_Keys (Key, X)
- and not Equivalent_Keys (Key, Y)
- then
- Has_Key (Right, Key)));
-
- function Elements_Equal_Except
- (Left : Map;
- Right : Map;
- New_Key : Key_Type) return Boolean
- -- Returns True if all the keys of Left are mapped to the same elements in
- -- Left and Right except New_Key.
-
- with
- Global => null,
- Post =>
- Elements_Equal_Except'Result =
- (for all Key of Left =>
- (if not Equivalent_Keys (Key, New_Key) then
- Has_Key (Right, Key)
- and then Get (Left, Key) = Get (Right, Key)));
-
- function Elements_Equal_Except
- (Left : Map;
- Right : Map;
- X : Key_Type;
- Y : Key_Type) return Boolean
- -- Returns True if all the keys of Left are mapped to the same elements in
- -- Left and Right except X and Y.
-
- with
- Global => null,
- Post =>
- Elements_Equal_Except'Result =
- (for all Key of Left =>
- (if not Equivalent_Keys (Key, X)
- and not Equivalent_Keys (Key, Y)
- then
- Has_Key (Right, Key)
- and then Get (Left, Key) = Get (Right, Key)));
-
- ----------------------------
- -- Construction Functions --
- ----------------------------
-
- -- For better efficiency of both proofs and execution, avoid using
- -- construction functions in annotations and rather use property functions.
-
- function Add
- (Container : Map;
- New_Key : Key_Type;
- New_Item : Element_Type) return Map
- -- Returns Container augmented with the mapping Key -> New_Item
-
- with
- Global => null,
- Pre => not Has_Key (Container, New_Key),
- Post =>
- Length (Container) + 1 = Length (Add'Result)
- and Has_Key (Add'Result, New_Key)
- and Get (Add'Result, New_Key) = New_Item
- and Container <= Add'Result
- and Keys_Included_Except (Add'Result, Container, New_Key);
-
- function Empty_Map return Map with
- -- Return an empty Map
-
- Global => null,
- Post =>
- Length (Empty_Map'Result) = 0
- and Is_Empty (Empty_Map'Result);
-
- function Remove
- (Container : Map;
- Key : Key_Type) return Map
- -- Returns Container without any mapping for Key
-
- with
- Global => null,
- Pre => Has_Key (Container, Key),
- Post =>
- Length (Container) = Length (Remove'Result) + 1
- and not Has_Key (Remove'Result, Key)
- and Remove'Result <= Container
- and Keys_Included_Except (Container, Remove'Result, Key);
-
- function Set
- (Container : Map;
- Key : Key_Type;
- New_Item : Element_Type) return Map
- -- Returns Container, where the element associated with Key has been
- -- replaced by New_Item.
-
- with
- Global => null,
- Pre => Has_Key (Container, Key),
- Post =>
- Length (Container) = Length (Set'Result)
- and Get (Set'Result, Key) = New_Item
- and Same_Keys (Container, Set'Result)
- and Elements_Equal_Except (Container, Set'Result, Key);
-
- ------------------------------
- -- Handling of Equivalence --
- ------------------------------
-
- -- These functions are used to specify that Get returns the same value on
- -- equivalent keys. They should not be used directly in user code.
-
- function Has_Witness (Container : Map; Witness : Count_Type) return Boolean
- with
- Ghost,
- Global => null;
- -- Returns True if there is a key with witness Witness in Container
-
- function Witness (Container : Map; Key : Key_Type) return Count_Type with
- -- Returns the witness of Key in Container
-
- Ghost,
- Global => null,
- Pre => Has_Key (Container, Key),
- Post => Has_Witness (Container, Witness'Result);
-
- function W_Get (Container : Map; Witness : Count_Type) return Element_Type
- with
- -- Returns the element associated with a witness in Container
-
- Ghost,
- Global => null,
- Pre => Has_Witness (Container, Witness);
-
- function Copy_Key (Key : Key_Type) return Key_Type is (Key);
- function Copy_Element (Item : Element_Type) return Element_Type is (Item);
- -- Elements and Keys of maps are copied by numerous primitives in this
- -- package. This function causes GNATprove to verify that such a copy is
- -- valid (in particular, it does not break the ownership policy of SPARK,
- -- i.e. it does not contain pointers that could be used to alias mutable
- -- data).
-
- ---------------------------
- -- Iteration Primitives --
- ---------------------------
-
- type Private_Key is private;
-
- function Iter_First (Container : Map) return Private_Key with
- Global => null;
-
- function Iter_Has_Element
- (Container : Map;
- Key : Private_Key) return Boolean
- with
- Global => null;
-
- function Iter_Next (Container : Map; Key : Private_Key) return Private_Key
- with
- Global => null,
- Pre => Iter_Has_Element (Container, Key);
-
- function Iter_Element (Container : Map; Key : Private_Key) return Key_Type
- with
- Global => null,
- Pre => Iter_Has_Element (Container, Key);
- pragma Annotate (GNATprove, Iterable_For_Proof, "Contains", Has_Key);
-
-private
-
- pragma SPARK_Mode (Off);
-
- function "="
- (Left : Key_Type;
- Right : Key_Type) return Boolean renames Equivalent_Keys;
-
- subtype Positive_Count_Type is Count_Type range 1 .. Count_Type'Last;
-
- package Element_Containers is new Ada.Containers.Functional_Base
- (Element_Type => Element_Type,
- Index_Type => Positive_Count_Type);
-
- package Key_Containers is new Ada.Containers.Functional_Base
- (Element_Type => Key_Type,
- Index_Type => Positive_Count_Type);
-
- type Map is record
- Keys : Key_Containers.Container;
- Elements : Element_Containers.Container;
- end record;
-
- type Private_Key is new Count_Type;
-
- function Iter_First (Container : Map) return Private_Key is (1);
-
- function Iter_Has_Element
- (Container : Map;
- Key : Private_Key) return Boolean
- is
- (Count_Type (Key) in 1 .. Key_Containers.Length (Container.Keys));
-
- function Iter_Next
- (Container : Map;
- Key : Private_Key) return Private_Key
- is
- (if Key = Private_Key'Last then 0 else Key + 1);
+package Ada.Containers.Functional_Maps with SPARK_Mode is
- function Iter_Element
- (Container : Map;
- Key : Private_Key) return Key_Type
- is
- (Key_Containers.Get (Container.Keys, Count_Type (Key)));
+ pragma Compile_Time_Error
+ (True,
+ "This package has been moved to the SPARK library shipped with any"
+ & " SPARK release starting with version 23.");
end Ada.Containers.Functional_Maps;
diff --git a/gcc/ada/libgnat/a-cofuse.adb b/gcc/ada/libgnat/a-cofuse.adb
deleted file mode 100644
index bbb3f7e..0000000
--- a/gcc/ada/libgnat/a-cofuse.adb
+++ /dev/null
@@ -1,184 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT LIBRARY COMPONENTS --
--- --
--- ADA.CONTAINERS.FUNCTIONAL_SETS --
--- --
--- B o d y --
--- --
--- Copyright (C) 2016-2022, Free Software Foundation, Inc. --
--- --
--- This specification is derived from the Ada Reference Manual for use with --
--- GNAT. The copyright notice above, and the license provisions that follow --
--- apply solely to the contents of the part following the private keyword. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
-------------------------------------------------------------------------------
-
-pragma Ada_2012;
-
-package body Ada.Containers.Functional_Sets with SPARK_Mode => Off is
- use Containers;
-
- package Conversions is new Signed_Conversions (Int => Count_Type);
- use Conversions;
-
- ---------
- -- "=" --
- ---------
-
- function "=" (Left : Set; Right : Set) return Boolean is
- (Left.Content <= Right.Content and Right.Content <= Left.Content);
-
- ----------
- -- "<=" --
- ----------
-
- function "<=" (Left : Set; Right : Set) return Boolean is
- (Left.Content <= Right.Content);
-
- ---------
- -- Add --
- ---------
-
- function Add (Container : Set; Item : Element_Type) return Set is
- (Content =>
- Add (Container.Content, Length (Container.Content) + 1, Item));
-
- --------------
- -- Contains --
- --------------
-
- function Contains (Container : Set; Item : Element_Type) return Boolean is
- (Find (Container.Content, Item) > 0);
-
- ---------------
- -- Empty_Set --
- ---------------
-
- function Empty_Set return Set is
- ((others => <>));
-
- ---------------------
- -- Included_Except --
- ---------------------
-
- function Included_Except
- (Left : Set;
- Right : Set;
- Item : Element_Type) return Boolean
- is
- (for all E of Left =>
- Equivalent_Elements (E, Item) or Contains (Right, E));
-
- -----------------------
- -- Included_In_Union --
- -----------------------
-
- function Included_In_Union
- (Container : Set;
- Left : Set;
- Right : Set) return Boolean
- is
- (for all Item of Container =>
- Contains (Left, Item) or Contains (Right, Item));
-
- ---------------------------
- -- Includes_Intersection --
- ---------------------------
-
- function Includes_Intersection
- (Container : Set;
- Left : Set;
- Right : Set) return Boolean
- is
- (for all Item of Left =>
- (if Contains (Right, Item) then Contains (Container, Item)));
-
- ------------------
- -- Intersection --
- ------------------
-
- function Intersection (Left : Set; Right : Set) return Set is
- (Content => Intersection (Left.Content, Right.Content));
-
- --------------
- -- Is_Empty --
- --------------
-
- function Is_Empty (Container : Set) return Boolean is
- (Length (Container.Content) = 0);
-
- ------------------
- -- Is_Singleton --
- ------------------
-
- function Is_Singleton
- (Container : Set;
- New_Item : Element_Type) return Boolean
- is
- (Length (Container.Content) = 1
- and New_Item = Get (Container.Content, 1));
-
- ------------
- -- Length --
- ------------
-
- function Length (Container : Set) return Big_Natural is
- (To_Big_Integer (Length (Container.Content)));
-
- -----------------
- -- Not_In_Both --
- -----------------
-
- function Not_In_Both
- (Container : Set;
- Left : Set;
- Right : Set) return Boolean
- is
- (for all Item of Container =>
- not Contains (Right, Item) or not Contains (Left, Item));
-
- ----------------
- -- No_Overlap --
- ----------------
-
- function No_Overlap (Left : Set; Right : Set) return Boolean is
- (Num_Overlaps (Left.Content, Right.Content) = 0);
-
- ------------------
- -- Num_Overlaps --
- ------------------
-
- function Num_Overlaps (Left : Set; Right : Set) return Big_Natural is
- (To_Big_Integer (Num_Overlaps (Left.Content, Right.Content)));
-
- ------------
- -- Remove --
- ------------
-
- function Remove (Container : Set; Item : Element_Type) return Set is
- (Content => Remove (Container.Content, Find (Container.Content, Item)));
-
- -----------
- -- Union --
- -----------
-
- function Union (Left : Set; Right : Set) return Set is
- (Content => Union (Left.Content, Right.Content));
-
-end Ada.Containers.Functional_Sets;
diff --git a/gcc/ada/libgnat/a-cofuse.ads b/gcc/ada/libgnat/a-cofuse.ads
index ce52f61..9c57ba1 100644
--- a/gcc/ada/libgnat/a-cofuse.ads
+++ b/gcc/ada/libgnat/a-cofuse.ads
@@ -29,308 +29,12 @@
-- <http://www.gnu.org/licenses/>. --
------------------------------------------------------------------------------
-pragma Ada_2012;
-private with Ada.Containers.Functional_Base;
-
-with Ada.Numerics.Big_Numbers.Big_Integers;
-use Ada.Numerics.Big_Numbers.Big_Integers;
-
generic
- type Element_Type (<>) is private;
-
- with function Equivalent_Elements
- (Left : Element_Type;
- Right : Element_Type) return Boolean is "=";
-
- Enable_Handling_Of_Equivalence : Boolean := True;
- -- This constant should only be set to False when no particular handling
- -- of equivalence over elements is needed, that is, Equivalent_Elements
- -- defines an element uniquely.
-
-package Ada.Containers.Functional_Sets with
- SPARK_Mode,
- Annotate => (GNATprove, Always_Return)
-is
-
- type Set is private with
- Default_Initial_Condition => Is_Empty (Set),
- Iterable => (First => Iter_First,
- Next => Iter_Next,
- Has_Element => Iter_Has_Element,
- Element => Iter_Element);
- -- Sets are empty when default initialized.
- -- "For in" quantification over sets should not be used.
- -- "For of" quantification over sets iterates over elements.
- -- Note that, for proof, "for of" quantification is understood modulo
- -- equivalence (the range of quantification comprises all the elements that
- -- are equivalent to any element of the set).
-
- -----------------------
- -- Basic operations --
- -----------------------
-
- -- Sets are axiomatized using Contains, which encodes whether an element is
- -- contained in a set. The length of a set is also added to protect Add
- -- against overflows but it is not actually modeled.
-
- function Contains (Container : Set; Item : Element_Type) return Boolean with
- -- Return True if Item is contained in Container
-
- Global => null,
- Post =>
- (if Enable_Handling_Of_Equivalence then
-
- -- Contains returns the same result on all equivalent elements
-
- (if (for some E of Container => Equivalent_Elements (E, Item)) then
- Contains'Result));
-
- function Length (Container : Set) return Big_Natural with
- Global => null;
- -- Return the number of elements in Container
-
- ------------------------
- -- Property Functions --
- ------------------------
-
- function "<=" (Left : Set; Right : Set) return Boolean with
- -- Set inclusion
-
- Global => null,
- Post => "<="'Result = (for all Item of Left => Contains (Right, Item));
-
- function "=" (Left : Set; Right : Set) return Boolean with
- -- Extensional equality over sets
-
- Global => null,
- Post => "="'Result = (Left <= Right and Right <= Left);
-
- pragma Warnings (Off, "unused variable ""Item""");
- function Is_Empty (Container : Set) return Boolean with
- -- A set is empty if it contains no element
-
- Global => null,
- Post =>
- Is_Empty'Result = (for all Item of Container => False)
- and Is_Empty'Result = (Length (Container) = 0);
- pragma Warnings (On, "unused variable ""Item""");
-
- function Included_Except
- (Left : Set;
- Right : Set;
- Item : Element_Type) return Boolean
- -- Return True if Left contains only elements of Right except possibly
- -- Item.
-
- with
- Global => null,
- Post =>
- Included_Except'Result =
- (for all E of Left =>
- Contains (Right, E) or Equivalent_Elements (E, Item));
-
- function Includes_Intersection
- (Container : Set;
- Left : Set;
- Right : Set) return Boolean
- with
- -- Return True if every element of the intersection of Left and Right is
- -- in Container.
-
- Global => null,
- Post =>
- Includes_Intersection'Result =
- (for all Item of Left =>
- (if Contains (Right, Item) then Contains (Container, Item)));
-
- function Included_In_Union
- (Container : Set;
- Left : Set;
- Right : Set) return Boolean
- with
- -- Return True if every element of Container is the union of Left and Right
-
- Global => null,
- Post =>
- Included_In_Union'Result =
- (for all Item of Container =>
- Contains (Left, Item) or Contains (Right, Item));
-
- function Is_Singleton
- (Container : Set;
- New_Item : Element_Type) return Boolean
- with
- -- Return True Container only contains New_Item
-
- Global => null,
- Post =>
- Is_Singleton'Result =
- (for all Item of Container => Equivalent_Elements (Item, New_Item));
-
- function Not_In_Both
- (Container : Set;
- Left : Set;
- Right : Set) return Boolean
- -- Return True if there are no elements in Container that are in Left and
- -- Right.
-
- with
- Global => null,
- Post =>
- Not_In_Both'Result =
- (for all Item of Container =>
- not Contains (Left, Item) or not Contains (Right, Item));
-
- function No_Overlap (Left : Set; Right : Set) return Boolean with
- -- Return True if there are no equivalent elements in Left and Right
-
- Global => null,
- Post =>
- No_Overlap'Result =
- (for all Item of Left => not Contains (Right, Item));
-
- function Num_Overlaps (Left : Set; Right : Set) return Big_Natural with
- -- Number of elements that are both in Left and Right
-
- Global => null,
- Post =>
- Num_Overlaps'Result = Length (Intersection (Left, Right))
- and (if Left <= Right then Num_Overlaps'Result = Length (Left)
- else Num_Overlaps'Result < Length (Left))
- and (if Right <= Left then Num_Overlaps'Result = Length (Right)
- else Num_Overlaps'Result < Length (Right))
- and (Num_Overlaps'Result = 0) = No_Overlap (Left, Right);
-
- ----------------------------
- -- Construction Functions --
- ----------------------------
-
- -- For better efficiency of both proofs and execution, avoid using
- -- construction functions in annotations and rather use property functions.
-
- function Add (Container : Set; Item : Element_Type) return Set with
- -- Return a new set containing all the elements of Container plus E
-
- Global => null,
- Pre => not Contains (Container, Item),
- Post =>
- Length (Add'Result) = Length (Container) + 1
- and Contains (Add'Result, Item)
- and Container <= Add'Result
- and Included_Except (Add'Result, Container, Item);
-
- function Empty_Set return Set with
- -- Return a new empty set
-
- Global => null,
- Post => Is_Empty (Empty_Set'Result);
-
- function Remove (Container : Set; Item : Element_Type) return Set with
- -- Return a new set containing all the elements of Container except E
-
- Global => null,
- Pre => Contains (Container, Item),
- Post =>
- Length (Remove'Result) = Length (Container) - 1
- and not Contains (Remove'Result, Item)
- and Remove'Result <= Container
- and Included_Except (Container, Remove'Result, Item);
-
- function Intersection (Left : Set; Right : Set) return Set with
- -- Returns the intersection of Left and Right
-
- Global => null,
- Post =>
- Intersection'Result <= Left
- and Intersection'Result <= Right
- and Includes_Intersection (Intersection'Result, Left, Right);
-
- function Union (Left : Set; Right : Set) return Set with
- -- Returns the union of Left and Right
-
- Global => null,
- Post =>
- Length (Union'Result) =
- Length (Left) - Num_Overlaps (Left, Right) + Length (Right)
- and Left <= Union'Result
- and Right <= Union'Result
- and Included_In_Union (Union'Result, Left, Right);
-
- function Copy_Element (Item : Element_Type) return Element_Type is (Item);
- -- Elements of containers are copied by numerous primitives in this
- -- package. This function causes GNATprove to verify that such a copy is
- -- valid (in particular, it does not break the ownership policy of SPARK,
- -- i.e. it does not contain pointers that could be used to alias mutable
- -- data).
-
- ---------------------------
- -- Iteration Primitives --
- ---------------------------
-
- type Private_Key is private;
-
- function Iter_First (Container : Set) return Private_Key with
- Global => null;
-
- function Iter_Has_Element
- (Container : Set;
- Key : Private_Key) return Boolean
- with
- Global => null;
-
- function Iter_Next
- (Container : Set;
- Key : Private_Key) return Private_Key
- with
- Global => null,
- Pre => Iter_Has_Element (Container, Key);
-
- function Iter_Element
- (Container : Set;
- Key : Private_Key) return Element_Type
- with
- Global => null,
- Pre => Iter_Has_Element (Container, Key);
- pragma Annotate (GNATprove, Iterable_For_Proof, "Contains", Contains);
-
-private
-
- pragma SPARK_Mode (Off);
-
- subtype Positive_Count_Type is Count_Type range 1 .. Count_Type'Last;
-
- function "="
- (Left : Element_Type;
- Right : Element_Type) return Boolean renames Equivalent_Elements;
-
- package Containers is new Ada.Containers.Functional_Base
- (Element_Type => Element_Type,
- Index_Type => Positive_Count_Type);
-
- type Set is record
- Content : Containers.Container;
- end record;
-
- type Private_Key is new Count_Type;
-
- function Iter_First (Container : Set) return Private_Key is (1);
-
- function Iter_Has_Element
- (Container : Set;
- Key : Private_Key) return Boolean
- is
- (Count_Type (Key) in 1 .. Containers.Length (Container.Content));
-
- function Iter_Next
- (Container : Set;
- Key : Private_Key) return Private_Key
- is
- (if Key = Private_Key'Last then 0 else Key + 1);
+package Ada.Containers.Functional_Sets with SPARK_Mode is
- function Iter_Element
- (Container : Set;
- Key : Private_Key) return Element_Type
- is
- (Containers.Get (Container.Content, Count_Type (Key)));
+ pragma Compile_Time_Error
+ (True,
+ "This package has been moved to the SPARK library shipped with any"
+ & " SPARK release starting with version 23.");
end Ada.Containers.Functional_Sets;
diff --git a/gcc/ada/libgnat/a-cofuve.adb b/gcc/ada/libgnat/a-cofuve.adb
deleted file mode 100644
index 0d91da5..0000000
--- a/gcc/ada/libgnat/a-cofuve.adb
+++ /dev/null
@@ -1,262 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT LIBRARY COMPONENTS --
--- --
--- ADA.CONTAINERS.FUNCTIONAL_VECTORS --
--- --
--- B o d y --
--- --
--- Copyright (C) 2016-2022, Free Software Foundation, Inc. --
--- --
--- This specification is derived from the Ada Reference Manual for use with --
--- GNAT. The copyright notice above, and the license provisions that follow --
--- apply solely to the contents of the part following the private keyword. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
-------------------------------------------------------------------------------
-
-pragma Ada_2012;
-package body Ada.Containers.Functional_Vectors with SPARK_Mode => Off is
- use Containers;
-
- ---------
- -- "<" --
- ---------
-
- function "<" (Left : Sequence; Right : Sequence) return Boolean is
- (Length (Left.Content) < Length (Right.Content)
- and then (for all I in Index_Type'First .. Last (Left) =>
- Get (Left.Content, I) = Get (Right.Content, I)));
-
- ----------
- -- "<=" --
- ----------
-
- function "<=" (Left : Sequence; Right : Sequence) return Boolean is
- (Length (Left.Content) <= Length (Right.Content)
- and then (for all I in Index_Type'First .. Last (Left) =>
- Get (Left.Content, I) = Get (Right.Content, I)));
-
- ---------
- -- "=" --
- ---------
-
- function "=" (Left : Sequence; Right : Sequence) return Boolean is
- (Left.Content = Right.Content);
-
- ---------
- -- Add --
- ---------
-
- function Add
- (Container : Sequence;
- New_Item : Element_Type) return Sequence
- is
- (Content =>
- Add (Container.Content,
- Index_Type'Val (Index_Type'Pos (Index_Type'First) +
- Length (Container.Content)),
- New_Item));
-
- function Add
- (Container : Sequence;
- Position : Index_Type;
- New_Item : Element_Type) return Sequence
- is
- (Content => Add (Container.Content, Position, New_Item));
-
- --------------------
- -- Constant_Range --
- --------------------
-
- function Constant_Range
- (Container : Sequence;
- Fst : Index_Type;
- Lst : Extended_Index;
- Item : Element_Type) return Boolean is
- begin
- for I in Fst .. Lst loop
- if Get (Container.Content, I) /= Item then
- return False;
- end if;
- end loop;
-
- return True;
- end Constant_Range;
-
- --------------
- -- Contains --
- --------------
-
- function Contains
- (Container : Sequence;
- Fst : Index_Type;
- Lst : Extended_Index;
- Item : Element_Type) return Boolean
- is
- begin
- for I in Fst .. Lst loop
- if Get (Container.Content, I) = Item then
- return True;
- end if;
- end loop;
-
- return False;
- end Contains;
-
- --------------------
- -- Empty_Sequence --
- --------------------
-
- function Empty_Sequence return Sequence is
- ((others => <>));
-
- ------------------
- -- Equal_Except --
- ------------------
-
- function Equal_Except
- (Left : Sequence;
- Right : Sequence;
- Position : Index_Type) return Boolean
- is
- begin
- if Length (Left.Content) /= Length (Right.Content) then
- return False;
- end if;
-
- for I in Index_Type'First .. Last (Left) loop
- if I /= Position
- and then Get (Left.Content, I) /= Get (Right.Content, I)
- then
- return False;
- end if;
- end loop;
-
- return True;
- end Equal_Except;
-
- function Equal_Except
- (Left : Sequence;
- Right : Sequence;
- X : Index_Type;
- Y : Index_Type) return Boolean
- is
- begin
- if Length (Left.Content) /= Length (Right.Content) then
- return False;
- end if;
-
- for I in Index_Type'First .. Last (Left) loop
- if I /= X and then I /= Y
- and then Get (Left.Content, I) /= Get (Right.Content, I)
- then
- return False;
- end if;
- end loop;
-
- return True;
- end Equal_Except;
-
- ---------
- -- Get --
- ---------
-
- function Get (Container : Sequence;
- Position : Extended_Index) return Element_Type
- is
- (Get (Container.Content, Position));
-
- ----------
- -- Last --
- ----------
-
- function Last (Container : Sequence) return Extended_Index is
- (Index_Type'Val
- ((Index_Type'Pos (Index_Type'First) - 1) + Length (Container)));
-
- ------------
- -- Length --
- ------------
-
- function Length (Container : Sequence) return Count_Type is
- (Length (Container.Content));
-
- -----------------
- -- Range_Equal --
- -----------------
-
- function Range_Equal
- (Left : Sequence;
- Right : Sequence;
- Fst : Index_Type;
- Lst : Extended_Index) return Boolean
- is
- begin
- for I in Fst .. Lst loop
- if Get (Left, I) /= Get (Right, I) then
- return False;
- end if;
- end loop;
-
- return True;
- end Range_Equal;
-
- -------------------
- -- Range_Shifted --
- -------------------
-
- function Range_Shifted
- (Left : Sequence;
- Right : Sequence;
- Fst : Index_Type;
- Lst : Extended_Index;
- Offset : Count_Type'Base) return Boolean
- is
- begin
- for I in Fst .. Lst loop
- if Get (Left, I) /=
- Get (Right, Index_Type'Val (Index_Type'Pos (I) + Offset))
- then
- return False;
- end if;
- end loop;
- return True;
- end Range_Shifted;
-
- ------------
- -- Remove --
- ------------
-
- function Remove
- (Container : Sequence;
- Position : Index_Type) return Sequence
- is
- (Content => Remove (Container.Content, Position));
-
- ---------
- -- Set --
- ---------
-
- function Set
- (Container : Sequence;
- Position : Index_Type;
- New_Item : Element_Type) return Sequence
- is
- (Content => Set (Container.Content, Position, New_Item));
-
-end Ada.Containers.Functional_Vectors;
diff --git a/gcc/ada/libgnat/a-cofuve.ads b/gcc/ada/libgnat/a-cofuve.ads
index 8622221..da0611e 100644
--- a/gcc/ada/libgnat/a-cofuve.ads
+++ b/gcc/ada/libgnat/a-cofuve.ads
@@ -29,383 +29,12 @@
-- <http://www.gnu.org/licenses/>. --
------------------------------------------------------------------------------
-pragma Ada_2012;
-private with Ada.Containers.Functional_Base;
-
generic
- type Index_Type is (<>);
- -- To avoid Constraint_Error being raised at run time, Index_Type'Base
- -- should have at least one more element at the low end than Index_Type.
-
- type Element_Type (<>) is private;
- with function "=" (Left, Right : Element_Type) return Boolean is <>;
-
-package Ada.Containers.Functional_Vectors with
- SPARK_Mode,
- Annotate => (GNATprove, Always_Return)
-is
-
- subtype Extended_Index is Index_Type'Base range
- Index_Type'Pred (Index_Type'First) .. Index_Type'Last;
- -- Index_Type with one more element at the low end of the range.
- -- This type is never used but it forces GNATprove to check that there is
- -- room for one more element at the low end of Index_Type.
-
- type Sequence is private
- with Default_Initial_Condition => Length (Sequence) = 0,
- Iterable => (First => Iter_First,
- Has_Element => Iter_Has_Element,
- Next => Iter_Next,
- Element => Get);
- -- Sequences are empty when default initialized.
- -- Quantification over sequences can be done using the regular
- -- quantification over its range or directly on its elements with "for of".
-
- -----------------------
- -- Basic operations --
- -----------------------
-
- -- Sequences are axiomatized using Length and Get, providing respectively
- -- the length of a sequence and an accessor to its Nth element:
-
- function Length (Container : Sequence) return Count_Type with
- -- Length of a sequence
-
- Global => null,
- Post =>
- (Index_Type'Pos (Index_Type'First) - 1) + Length'Result <=
- Index_Type'Pos (Index_Type'Last);
-
- function Get
- (Container : Sequence;
- Position : Extended_Index) return Element_Type
- -- Access the Element at position Position in Container
-
- with
- Global => null,
- Pre => Position in Index_Type'First .. Last (Container);
-
- function Last (Container : Sequence) return Extended_Index with
- -- Last index of a sequence
-
- Global => null,
- Post =>
- Last'Result =
- Index_Type'Val ((Index_Type'Pos (Index_Type'First) - 1) +
- Length (Container));
- pragma Annotate (GNATprove, Inline_For_Proof, Last);
-
- function First return Extended_Index is (Index_Type'First) with
- Global => null;
- -- First index of a sequence
-
- ------------------------
- -- Property Functions --
- ------------------------
-
- function "=" (Left : Sequence; Right : Sequence) return Boolean with
- -- Extensional equality over sequences
-
- Global => null,
- Post =>
- "="'Result =
- (Length (Left) = Length (Right)
- and then (for all N in Index_Type'First .. Last (Left) =>
- Get (Left, N) = Get (Right, N)));
- pragma Annotate (GNATprove, Inline_For_Proof, "=");
-
- function "<" (Left : Sequence; Right : Sequence) return Boolean with
- -- Left is a strict subsequence of Right
-
- Global => null,
- Post =>
- "<"'Result =
- (Length (Left) < Length (Right)
- and then (for all N in Index_Type'First .. Last (Left) =>
- Get (Left, N) = Get (Right, N)));
- pragma Annotate (GNATprove, Inline_For_Proof, "<");
-
- function "<=" (Left : Sequence; Right : Sequence) return Boolean with
- -- Left is a subsequence of Right
-
- Global => null,
- Post =>
- "<="'Result =
- (Length (Left) <= Length (Right)
- and then (for all N in Index_Type'First .. Last (Left) =>
- Get (Left, N) = Get (Right, N)));
- pragma Annotate (GNATprove, Inline_For_Proof, "<=");
-
- function Contains
- (Container : Sequence;
- Fst : Index_Type;
- Lst : Extended_Index;
- Item : Element_Type) return Boolean
- -- Returns True if Item occurs in the range from Fst to Lst of Container
-
- with
- Global => null,
- Pre => Lst <= Last (Container),
- Post =>
- Contains'Result =
- (for some I in Fst .. Lst => Get (Container, I) = Item);
- pragma Annotate (GNATprove, Inline_For_Proof, Contains);
-
- function Constant_Range
- (Container : Sequence;
- Fst : Index_Type;
- Lst : Extended_Index;
- Item : Element_Type) return Boolean
- -- Returns True if every element of the range from Fst to Lst of Container
- -- is equal to Item.
-
- with
- Global => null,
- Pre => Lst <= Last (Container),
- Post =>
- Constant_Range'Result =
- (for all I in Fst .. Lst => Get (Container, I) = Item);
- pragma Annotate (GNATprove, Inline_For_Proof, Constant_Range);
-
- function Equal_Except
- (Left : Sequence;
- Right : Sequence;
- Position : Index_Type) return Boolean
- -- Returns True is Left and Right are the same except at position Position
-
- with
- Global => null,
- Pre => Position <= Last (Left),
- Post =>
- Equal_Except'Result =
- (Length (Left) = Length (Right)
- and then (for all I in Index_Type'First .. Last (Left) =>
- (if I /= Position then Get (Left, I) = Get (Right, I))));
- pragma Annotate (GNATprove, Inline_For_Proof, Equal_Except);
-
- function Equal_Except
- (Left : Sequence;
- Right : Sequence;
- X : Index_Type;
- Y : Index_Type) return Boolean
- -- Returns True is Left and Right are the same except at positions X and Y
-
- with
- Global => null,
- Pre => X <= Last (Left) and Y <= Last (Left),
- Post =>
- Equal_Except'Result =
- (Length (Left) = Length (Right)
- and then (for all I in Index_Type'First .. Last (Left) =>
- (if I /= X and I /= Y then
- Get (Left, I) = Get (Right, I))));
- pragma Annotate (GNATprove, Inline_For_Proof, Equal_Except);
-
- function Range_Equal
- (Left : Sequence;
- Right : Sequence;
- Fst : Index_Type;
- Lst : Extended_Index) return Boolean
- -- Returns True if the ranges from Fst to Lst contain the same elements in
- -- Left and Right.
-
- with
- Global => null,
- Pre => Lst <= Last (Left) and Lst <= Last (Right),
- Post =>
- Range_Equal'Result =
- (for all I in Fst .. Lst => Get (Left, I) = Get (Right, I));
- pragma Annotate (GNATprove, Inline_For_Proof, Range_Equal);
-
- function Range_Shifted
- (Left : Sequence;
- Right : Sequence;
- Fst : Index_Type;
- Lst : Extended_Index;
- Offset : Count_Type'Base) return Boolean
- -- Returns True if the range from Fst to Lst in Left contains the same
- -- elements as the range from Fst + Offset to Lst + Offset in Right.
-
- with
- Global => null,
- Pre =>
- Lst <= Last (Left)
- and then
- (if Offset < 0 then
- Index_Type'Pos (Index_Type'Base'First) - Offset <=
- Index_Type'Pos (Index_Type'First))
- and then
- (if Fst <= Lst then
- Offset in
- Index_Type'Pos (Index_Type'First) - Index_Type'Pos (Fst) ..
- (Index_Type'Pos (Index_Type'First) - 1) + Length (Right) -
- Index_Type'Pos (Lst)),
- Post =>
- Range_Shifted'Result =
- ((for all I in Fst .. Lst =>
- Get (Left, I) =
- Get (Right, Index_Type'Val (Index_Type'Pos (I) + Offset)))
- and
- (for all I in Index_Type'Val (Index_Type'Pos (Fst) + Offset) ..
- Index_Type'Val (Index_Type'Pos (Lst) + Offset)
- =>
- Get (Left, Index_Type'Val (Index_Type'Pos (I) - Offset)) =
- Get (Right, I)));
- pragma Annotate (GNATprove, Inline_For_Proof, Range_Shifted);
-
- ----------------------------
- -- Construction Functions --
- ----------------------------
-
- -- For better efficiency of both proofs and execution, avoid using
- -- construction functions in annotations and rather use property functions.
-
- function Set
- (Container : Sequence;
- Position : Index_Type;
- New_Item : Element_Type) return Sequence
- -- Returns a new sequence which contains the same elements as Container
- -- except for the one at position Position which is replaced by New_Item.
-
- with
- Global => null,
- Pre => Position in Index_Type'First .. Last (Container),
- Post =>
- Get (Set'Result, Position) = New_Item
- and then Equal_Except (Container, Set'Result, Position);
-
- function Add (Container : Sequence; New_Item : Element_Type) return Sequence
- -- Returns a new sequence which contains the same elements as Container
- -- plus New_Item at the end.
-
- with
- Global => null,
- Pre =>
- Length (Container) < Count_Type'Last
- and then Last (Container) < Index_Type'Last,
- Post =>
- Length (Add'Result) = Length (Container) + 1
- and then Get (Add'Result, Last (Add'Result)) = New_Item
- and then Container <= Add'Result;
-
- function Add
- (Container : Sequence;
- Position : Index_Type;
- New_Item : Element_Type) return Sequence
- with
- -- Returns a new sequence which contains the same elements as Container
- -- except that New_Item has been inserted at position Position.
-
- Global => null,
- Pre =>
- Length (Container) < Count_Type'Last
- and then Last (Container) < Index_Type'Last
- and then Position <= Extended_Index'Succ (Last (Container)),
- Post =>
- Length (Add'Result) = Length (Container) + 1
- and then Get (Add'Result, Position) = New_Item
- and then Range_Equal
- (Left => Container,
- Right => Add'Result,
- Fst => Index_Type'First,
- Lst => Index_Type'Pred (Position))
- and then Range_Shifted
- (Left => Container,
- Right => Add'Result,
- Fst => Position,
- Lst => Last (Container),
- Offset => 1);
-
- function Remove
- (Container : Sequence;
- Position : Index_Type) return Sequence
- -- Returns a new sequence which contains the same elements as Container
- -- except that the element at position Position has been removed.
-
- with
- Global => null,
- Pre => Position in Index_Type'First .. Last (Container),
- Post =>
- Length (Remove'Result) = Length (Container) - 1
- and then Range_Equal
- (Left => Container,
- Right => Remove'Result,
- Fst => Index_Type'First,
- Lst => Index_Type'Pred (Position))
- and then Range_Shifted
- (Left => Remove'Result,
- Right => Container,
- Fst => Position,
- Lst => Last (Remove'Result),
- Offset => 1);
-
- function Copy_Element (Item : Element_Type) return Element_Type is (Item);
- -- Elements of containers are copied by numerous primitives in this
- -- package. This function causes GNATprove to verify that such a copy is
- -- valid (in particular, it does not break the ownership policy of SPARK,
- -- i.e. it does not contain pointers that could be used to alias mutable
- -- data).
-
- function Empty_Sequence return Sequence with
- -- Return an empty Sequence
-
- Global => null,
- Post => Length (Empty_Sequence'Result) = 0;
-
- ---------------------------
- -- Iteration Primitives --
- ---------------------------
-
- function Iter_First (Container : Sequence) return Extended_Index with
- Global => null;
-
- function Iter_Has_Element
- (Container : Sequence;
- Position : Extended_Index) return Boolean
- with
- Global => null,
- Post =>
- Iter_Has_Element'Result =
- (Position in Index_Type'First .. Last (Container));
- pragma Annotate (GNATprove, Inline_For_Proof, Iter_Has_Element);
-
- function Iter_Next
- (Container : Sequence;
- Position : Extended_Index) return Extended_Index
- with
- Global => null,
- Pre => Iter_Has_Element (Container, Position);
-
-private
-
- pragma SPARK_Mode (Off);
-
- package Containers is new Ada.Containers.Functional_Base
- (Index_Type => Index_Type,
- Element_Type => Element_Type);
-
- type Sequence is record
- Content : Containers.Container;
- end record;
-
- function Iter_First (Container : Sequence) return Extended_Index is
- (Index_Type'First);
-
- function Iter_Next
- (Container : Sequence;
- Position : Extended_Index) return Extended_Index
- is
- (if Position = Extended_Index'Last then
- Extended_Index'First
- else
- Extended_Index'Succ (Position));
+package Ada.Containers.Functional_Vectors with SPARK_Mode is
- function Iter_Has_Element
- (Container : Sequence;
- Position : Extended_Index) return Boolean
- is
- (Position in Index_Type'First ..
- (Index_Type'Val
- ((Index_Type'Pos (Index_Type'First) - 1) + Length (Container))));
+ pragma Compile_Time_Error
+ (True,
+ "This package has been moved to the SPARK library shipped with any"
+ & " SPARK release starting with version 23.");
end Ada.Containers.Functional_Vectors;
diff --git a/gcc/ada/libgnat/a-coorse.ads b/gcc/ada/libgnat/a-coorse.ads
index 8888a8c..fed41ec 100644
--- a/gcc/ada/libgnat/a-coorse.ads
+++ b/gcc/ada/libgnat/a-coorse.ads
@@ -57,9 +57,9 @@ is
type Set is tagged private
with Constant_Indexing => Constant_Reference,
Default_Iterator => Iterate,
- Iterator_Element => Element_Type;
- -- Aggregate => (Empty => Empty,
- -- Add_Unnamed => Include);
+ Iterator_Element => Element_Type,
+ Aggregate => (Empty => Empty,
+ Add_Unnamed => Include);
pragma Preelaborable_Initialization (Set);
diff --git a/gcc/ada/libgnat/a-strsup.adb b/gcc/ada/libgnat/a-strsup.adb
index e301564..831a18e 100644
--- a/gcc/ada/libgnat/a-strsup.adb
+++ b/gcc/ada/libgnat/a-strsup.adb
@@ -1651,10 +1651,9 @@ package body Ada.Strings.Superbounded with SPARK_Mode is
raise Index_Error;
end if;
- if High >= Low then
- Result.Data (1 .. High - Low + 1) := Source.Data (Low .. High);
- Result.Current_Length := High - Low + 1;
- end if;
+ Result.Current_Length := (if Low > High then 0 else High - Low + 1);
+ Result.Data (1 .. Result.Current_Length) :=
+ Source.Data (Low .. High);
end return;
end Super_Slice;
@@ -1671,12 +1670,8 @@ package body Ada.Strings.Superbounded with SPARK_Mode is
raise Index_Error;
end if;
- if High >= Low then
- Target.Data (1 .. High - Low + 1) := Source.Data (Low .. High);
- Target.Current_Length := High - Low + 1;
- else
- Target.Current_Length := 0;
- end if;
+ Target.Current_Length := (if Low > High then 0 else High - Low + 1);
+ Target.Data (1 .. Target.Current_Length) := Source.Data (Low .. High);
end Super_Slice;
----------------
diff --git a/gcc/ada/libgnat/a-stwisu.adb b/gcc/ada/libgnat/a-stwisu.adb
index a615ff3..d325676 100644
--- a/gcc/ada/libgnat/a-stwisu.adb
+++ b/gcc/ada/libgnat/a-stwisu.adb
@@ -1497,7 +1497,7 @@ package body Ada.Strings.Wide_Superbounded is
raise Index_Error;
end if;
- Result.Current_Length := High - Low + 1;
+ Result.Current_Length := (if Low > High then 0 else High - Low + 1);
Result.Data (1 .. Result.Current_Length) := Source.Data (Low .. High);
end return;
end Super_Slice;
@@ -1513,10 +1513,10 @@ package body Ada.Strings.Wide_Superbounded is
or else High > Source.Current_Length
then
raise Index_Error;
- else
- Target.Current_Length := High - Low + 1;
- Target.Data (1 .. Target.Current_Length) := Source.Data (Low .. High);
end if;
+
+ Target.Current_Length := (if Low > High then 0 else High - Low + 1);
+ Target.Data (1 .. Target.Current_Length) := Source.Data (Low .. High);
end Super_Slice;
----------------
diff --git a/gcc/ada/libgnat/a-stzsup.adb b/gcc/ada/libgnat/a-stzsup.adb
index d973993..6153bbe 100644
--- a/gcc/ada/libgnat/a-stzsup.adb
+++ b/gcc/ada/libgnat/a-stzsup.adb
@@ -1498,11 +1498,11 @@ package body Ada.Strings.Wide_Wide_Superbounded is
or else High > Source.Current_Length
then
raise Index_Error;
- else
- Result.Current_Length := High - Low + 1;
- Result.Data (1 .. Result.Current_Length) :=
- Source.Data (Low .. High);
end if;
+
+ Result.Current_Length := (if Low > High then 0 else High - Low + 1);
+ Result.Data (1 .. Result.Current_Length) :=
+ Source.Data (Low .. High);
end return;
end Super_Slice;
@@ -1517,10 +1517,10 @@ package body Ada.Strings.Wide_Wide_Superbounded is
or else High > Source.Current_Length
then
raise Index_Error;
- else
- Target.Current_Length := High - Low + 1;
- Target.Data (1 .. Target.Current_Length) := Source.Data (Low .. High);
end if;
+
+ Target.Current_Length := (if Low > High then 0 else High - Low + 1);
+ Target.Data (1 .. Target.Current_Length) := Source.Data (Low .. High);
end Super_Slice;
----------------
diff --git a/gcc/ada/libgnat/s-imagei.adb b/gcc/ada/libgnat/s-imagei.adb
index 8997e3c..c467777 100644
--- a/gcc/ada/libgnat/s-imagei.adb
+++ b/gcc/ada/libgnat/s-imagei.adb
@@ -177,6 +177,8 @@ package body System.Image_I is
begin
if V >= 0 then
+ pragma Annotate (CodePeer, False_Positive, "test always false",
+ "V can be positive");
S (1) := ' ';
P := 1;
pragma Assert (P < S'Last);
diff --git a/gcc/ada/libgnat/s-maccod.ads b/gcc/ada/libgnat/s-maccod.ads
index c3abf07..df7c7df 100644
--- a/gcc/ada/libgnat/s-maccod.ads
+++ b/gcc/ada/libgnat/s-maccod.ads
@@ -33,7 +33,9 @@
-- operations, and also for machine code statements. See GNAT documentation
-- for full details.
-package System.Machine_Code is
+package System.Machine_Code
+ with SPARK_Mode => Off
+is
pragma No_Elaboration_Code_All;
pragma Pure;
diff --git a/gcc/ada/libgnat/s-powflt.ads b/gcc/ada/libgnat/s-powflt.ads
index bf5d66f..24e22c9 100644
--- a/gcc/ada/libgnat/s-powflt.ads
+++ b/gcc/ada/libgnat/s-powflt.ads
@@ -29,17 +29,41 @@
-- --
------------------------------------------------------------------------------
--- This package provides a powers of ten table used for real conversions
+-- This package provides tables of powers used for real conversions
package System.Powten_Flt is
pragma Pure;
Maxpow_Exact : constant := 10;
- -- Largest power of ten exactly representable with Float. It is equal to
+ -- Largest power of five exactly representable with Float. It is equal to
-- floor (M * log 2 / log 5), when M is the size of the mantissa (24).
+ -- It also works for any number of the form 5*(2**N) and in particular 10.
Maxpow : constant := Maxpow_Exact * 2;
- -- Largest power of ten exactly representable with a double Float
+ -- Largest power of five exactly representable with double Float
+
+ Powfive : constant array (0 .. Maxpow, 1 .. 2) of Float :=
+ [00 => [5.0**00, 0.0],
+ 01 => [5.0**01, 0.0],
+ 02 => [5.0**02, 0.0],
+ 03 => [5.0**03, 0.0],
+ 04 => [5.0**04, 0.0],
+ 05 => [5.0**05, 0.0],
+ 06 => [5.0**06, 0.0],
+ 07 => [5.0**07, 0.0],
+ 08 => [5.0**08, 0.0],
+ 09 => [5.0**09, 0.0],
+ 10 => [5.0**10, 0.0],
+ 11 => [5.0**11, 5.0**11 - Float'Machine (5.0**11)],
+ 12 => [5.0**12, 5.0**12 - Float'Machine (5.0**12)],
+ 13 => [5.0**13, 5.0**13 - Float'Machine (5.0**13)],
+ 14 => [5.0**14, 5.0**14 - Float'Machine (5.0**14)],
+ 15 => [5.0**15, 5.0**15 - Float'Machine (5.0**15)],
+ 16 => [5.0**16, 5.0**16 - Float'Machine (5.0**16)],
+ 17 => [5.0**17, 5.0**17 - Float'Machine (5.0**17)],
+ 18 => [5.0**18, 5.0**18 - Float'Machine (5.0**18)],
+ 19 => [5.0**19, 5.0**19 - Float'Machine (5.0**19)],
+ 20 => [5.0**20, 5.0**20 - Float'Machine (5.0**20)]];
Powten : constant array (0 .. Maxpow, 1 .. 2) of Float :=
[00 => [1.0E+00, 0.0],
diff --git a/gcc/ada/libgnat/s-powlfl.ads b/gcc/ada/libgnat/s-powlfl.ads
index a8612db..a627c0c 100644
--- a/gcc/ada/libgnat/s-powlfl.ads
+++ b/gcc/ada/libgnat/s-powlfl.ads
@@ -29,17 +29,74 @@
-- --
------------------------------------------------------------------------------
--- This package provides a powers of ten table used for real conversions
+-- This package provides tables of powers used for real conversions
package System.Powten_LFlt is
pragma Pure;
Maxpow_Exact : constant := 22;
- -- Largest power of ten exactly representable with Long_Float. It is equal
+ -- Largest power of five exactly representable with Long_Float. It is equal
-- to floor (M * log 2 / log 5), when M is the size of the mantissa (53).
+ -- It also works for any number of the form 5*(2**N) and in particular 10.
Maxpow : constant := Maxpow_Exact * 2;
- -- Largest power of ten exactly representable with a double Long_Float
+ -- Largest power of five exactly representable with double Long_Float
+
+ Powfive : constant array (0 .. Maxpow, 1 .. 2) of Long_Float :=
+ [00 => [5.0**00, 0.0],
+ 01 => [5.0**01, 0.0],
+ 02 => [5.0**02, 0.0],
+ 03 => [5.0**03, 0.0],
+ 04 => [5.0**04, 0.0],
+ 05 => [5.0**05, 0.0],
+ 06 => [5.0**06, 0.0],
+ 07 => [5.0**07, 0.0],
+ 08 => [5.0**08, 0.0],
+ 09 => [5.0**09, 0.0],
+ 10 => [5.0**10, 0.0],
+ 11 => [5.0**11, 0.0],
+ 12 => [5.0**12, 0.0],
+ 13 => [5.0**13, 0.0],
+ 14 => [5.0**14, 0.0],
+ 15 => [5.0**15, 0.0],
+ 16 => [5.0**16, 0.0],
+ 17 => [5.0**17, 0.0],
+ 18 => [5.0**18, 0.0],
+ 19 => [5.0**19, 0.0],
+ 20 => [5.0**20, 0.0],
+ 21 => [5.0**21, 0.0],
+ 22 => [5.0**22, 0.0],
+ 23 => [5.0**23, 5.0**23 - Long_Float'Machine (5.0**23)],
+ 24 => [5.0**24, 5.0**24 - Long_Float'Machine (5.0**24)],
+ 25 => [5.0**25, 5.0**25 - Long_Float'Machine (5.0**25)],
+ 26 => [5.0**26, 5.0**26 - Long_Float'Machine (5.0**26)],
+ 27 => [5.0**27, 5.0**27 - Long_Float'Machine (5.0**27)],
+ 28 => [5.0**28, 5.0**28 - Long_Float'Machine (5.0**28)],
+ 29 => [5.0**29, 5.0**29 - Long_Float'Machine (5.0**29)],
+ 30 => [5.0**30, 5.0**30 - Long_Float'Machine (5.0**30)],
+ 31 => [5.0**31, 5.0**31 - Long_Float'Machine (5.0**31)],
+ 32 => [5.0**32, 5.0**32 - Long_Float'Machine (5.0**32)],
+ 33 => [5.0**33, 5.0**33 - Long_Float'Machine (5.0**33)],
+ 34 => [5.0**34, 5.0**34 - Long_Float'Machine (5.0**34)],
+ 35 => [5.0**35, 5.0**35 - Long_Float'Machine (5.0**35)],
+ 36 => [5.0**36, 5.0**36 - Long_Float'Machine (5.0**36)],
+ 37 => [5.0**37, 5.0**37 - Long_Float'Machine (5.0**37)],
+ 38 => [5.0**38, 5.0**38 - Long_Float'Machine (5.0**38)],
+ 39 => [5.0**39, 5.0**39 - Long_Float'Machine (5.0**39)],
+ 40 => [5.0**40, 5.0**40 - Long_Float'Machine (5.0**40)],
+ 41 => [5.0**41, 5.0**41 - Long_Float'Machine (5.0**41)],
+ 42 => [5.0**42, 5.0**42 - Long_Float'Machine (5.0**42)],
+ 43 => [5.0**43, 5.0**43 - Long_Float'Machine (5.0**43)],
+ 44 => [5.0**44, 5.0**44 - Long_Float'Machine (5.0**44)]];
+
+ Powfive_100 : constant array (1 .. 2) of Long_Float :=
+ [5.0**100, 5.0**100 - Long_Float'Machine (5.0**100)];
+
+ Powfive_200 : constant array (1 .. 2) of Long_Float :=
+ [5.0**200, 5.0**200 - Long_Float'Machine (5.0**200)];
+
+ Powfive_300 : constant array (1 .. 2) of Long_Float :=
+ [5.0**300, 5.0**300 - Long_Float'Machine (5.0**300)];
Powten : constant array (0 .. Maxpow, 1 .. 2) of Long_Float :=
[00 => [1.0E+00, 0.0],
diff --git a/gcc/ada/libgnat/s-powllf.ads b/gcc/ada/libgnat/s-powllf.ads
index 0640ea4..4b5f1ae 100644
--- a/gcc/ada/libgnat/s-powllf.ads
+++ b/gcc/ada/libgnat/s-powllf.ads
@@ -29,19 +29,86 @@
-- --
------------------------------------------------------------------------------
--- This package provides a powers of ten table used for real conversions
+-- This package provides tables of powers used for real conversions
package System.Powten_LLF is
pragma Pure;
Maxpow_Exact : constant :=
(if Long_Long_Float'Machine_Mantissa = 64 then 27 else 22);
- -- Largest power of ten exactly representable with Long_Long_Float. It is
+ -- Largest power of five exactly representable with Long_Long_Float. It is
-- equal to floor (M * log 2 / log 5), when M is the size of the mantissa
-- assumed to be either 64 for IEEE Extended or 53 for IEEE Double.
+ -- It also works for any number of the form 5*(2**N) and in particular 10.
Maxpow : constant := Maxpow_Exact * 2;
- -- Largest power of ten exactly representable with a double Long_Long_Float
+ -- Largest power of five exactly representable with double Long_Long_Float
+
+ Powfive : constant array (0 .. 54, 1 .. 2) of Long_Long_Float :=
+ [00 => [5.0**00, 0.0],
+ 01 => [5.0**01, 0.0],
+ 02 => [5.0**02, 0.0],
+ 03 => [5.0**03, 0.0],
+ 04 => [5.0**04, 0.0],
+ 05 => [5.0**05, 0.0],
+ 06 => [5.0**06, 0.0],
+ 07 => [5.0**07, 0.0],
+ 08 => [5.0**08, 0.0],
+ 09 => [5.0**09, 0.0],
+ 10 => [5.0**10, 0.0],
+ 11 => [5.0**11, 0.0],
+ 12 => [5.0**12, 0.0],
+ 13 => [5.0**13, 0.0],
+ 14 => [5.0**14, 0.0],
+ 15 => [5.0**15, 0.0],
+ 16 => [5.0**16, 0.0],
+ 17 => [5.0**17, 0.0],
+ 18 => [5.0**18, 0.0],
+ 19 => [5.0**19, 0.0],
+ 20 => [5.0**20, 0.0],
+ 21 => [5.0**21, 0.0],
+ 22 => [5.0**22, 0.0],
+ 23 => [5.0**23, 5.0**23 - Long_Long_Float'Machine (5.0**23)],
+ 24 => [5.0**24, 5.0**24 - Long_Long_Float'Machine (5.0**24)],
+ 25 => [5.0**25, 5.0**25 - Long_Long_Float'Machine (5.0**25)],
+ 26 => [5.0**26, 5.0**26 - Long_Long_Float'Machine (5.0**26)],
+ 27 => [5.0**27, 5.0**27 - Long_Long_Float'Machine (5.0**27)],
+ 28 => [5.0**28, 5.0**28 - Long_Long_Float'Machine (5.0**28)],
+ 29 => [5.0**29, 5.0**29 - Long_Long_Float'Machine (5.0**29)],
+ 30 => [5.0**30, 5.0**30 - Long_Long_Float'Machine (5.0**30)],
+ 31 => [5.0**31, 5.0**31 - Long_Long_Float'Machine (5.0**31)],
+ 32 => [5.0**32, 5.0**32 - Long_Long_Float'Machine (5.0**32)],
+ 33 => [5.0**33, 5.0**33 - Long_Long_Float'Machine (5.0**33)],
+ 34 => [5.0**34, 5.0**34 - Long_Long_Float'Machine (5.0**34)],
+ 35 => [5.0**35, 5.0**35 - Long_Long_Float'Machine (5.0**35)],
+ 36 => [5.0**36, 5.0**36 - Long_Long_Float'Machine (5.0**36)],
+ 37 => [5.0**37, 5.0**37 - Long_Long_Float'Machine (5.0**37)],
+ 38 => [5.0**38, 5.0**38 - Long_Long_Float'Machine (5.0**38)],
+ 39 => [5.0**39, 5.0**39 - Long_Long_Float'Machine (5.0**39)],
+ 40 => [5.0**40, 5.0**40 - Long_Long_Float'Machine (5.0**40)],
+ 41 => [5.0**41, 5.0**41 - Long_Long_Float'Machine (5.0**41)],
+ 42 => [5.0**42, 5.0**42 - Long_Long_Float'Machine (5.0**42)],
+ 43 => [5.0**43, 5.0**43 - Long_Long_Float'Machine (5.0**43)],
+ 44 => [5.0**44, 5.0**44 - Long_Long_Float'Machine (5.0**44)],
+ 45 => [5.0**45, 5.0**45 - Long_Long_Float'Machine (5.0**45)],
+ 46 => [5.0**46, 5.0**46 - Long_Long_Float'Machine (5.0**46)],
+ 47 => [5.0**47, 5.0**47 - Long_Long_Float'Machine (5.0**47)],
+ 48 => [5.0**48, 5.0**48 - Long_Long_Float'Machine (5.0**48)],
+ 49 => [5.0**49, 5.0**49 - Long_Long_Float'Machine (5.0**49)],
+ 50 => [5.0**50, 5.0**50 - Long_Long_Float'Machine (5.0**50)],
+ 51 => [5.0**51, 5.0**51 - Long_Long_Float'Machine (5.0**51)],
+ 52 => [5.0**52, 5.0**52 - Long_Long_Float'Machine (5.0**52)],
+ 53 => [5.0**53, 5.0**53 - Long_Long_Float'Machine (5.0**53)],
+ 54 => [5.0**54, 5.0**54 - Long_Long_Float'Machine (5.0**54)]];
+
+ Powfive_100 : constant array (1 .. 2) of Long_Long_Float :=
+ [5.0**100, 5.0**100 - Long_Long_Float'Machine (5.0**100)];
+
+ Powfive_200 : constant array (1 .. 2) of Long_Long_Float :=
+ [5.0**200, 5.0**200 - Long_Long_Float'Machine (5.0**200)];
+
+ Powfive_300 : constant array (1 .. 2) of Long_Long_Float :=
+ [5.0**300, 5.0**300 - Long_Long_Float'Machine (5.0**300)];
Powten : constant array (0 .. 54, 1 .. 2) of Long_Long_Float :=
[00 => [1.0E+00, 0.0],
diff --git a/gcc/ada/libgnat/s-valflt.ads b/gcc/ada/libgnat/s-valflt.ads
index 788dd8a..cc8f583 100644
--- a/gcc/ada/libgnat/s-valflt.ads
+++ b/gcc/ada/libgnat/s-valflt.ads
@@ -42,7 +42,10 @@ package System.Val_Flt is
package Impl is new Val_Real
(Float,
System.Powten_Flt.Maxpow,
- System.Powten_Flt.Powten'Address,
+ System.Powten_Flt.Powfive'Address,
+ System.Null_Address,
+ System.Null_Address,
+ System.Null_Address,
Unsigned_Types.Unsigned);
function Scan_Float
diff --git a/gcc/ada/libgnat/s-vallfl.ads b/gcc/ada/libgnat/s-vallfl.ads
index cd894cd..12be755 100644
--- a/gcc/ada/libgnat/s-vallfl.ads
+++ b/gcc/ada/libgnat/s-vallfl.ads
@@ -42,7 +42,10 @@ package System.Val_LFlt is
package Impl is new Val_Real
(Long_Float,
System.Powten_LFlt.Maxpow,
- System.Powten_LFlt.Powten'Address,
+ System.Powten_LFlt.Powfive'Address,
+ System.Powten_LFlt.Powfive_100'Address,
+ System.Powten_LFlt.Powfive_200'Address,
+ System.Powten_LFlt.Powfive_300'Address,
Unsigned_Types.Long_Long_Unsigned);
function Scan_Long_Float
diff --git a/gcc/ada/libgnat/s-valllf.ads b/gcc/ada/libgnat/s-valllf.ads
index 959a27d..80566c3 100644
--- a/gcc/ada/libgnat/s-valllf.ads
+++ b/gcc/ada/libgnat/s-valllf.ads
@@ -42,7 +42,10 @@ package System.Val_LLF is
package Impl is new Val_Real
(Long_Long_Float,
System.Powten_LLF.Maxpow,
- System.Powten_LLF.Powten'Address,
+ System.Powten_LLF.Powfive'Address,
+ System.Powten_LLF.Powfive_100'Address,
+ System.Powten_LLF.Powfive_200'Address,
+ System.Powten_LLF.Powfive_300'Address,
System.Unsigned_Types.Long_Long_Unsigned);
function Scan_Long_Long_Float
diff --git a/gcc/ada/libgnat/s-valrea.adb b/gcc/ada/libgnat/s-valrea.adb
index c9e5505..079c48b 100644
--- a/gcc/ada/libgnat/s-valrea.adb
+++ b/gcc/ada/libgnat/s-valrea.adb
@@ -43,18 +43,13 @@ package body System.Val_Real is
pragma Assert (Num'Machine_Mantissa <= Uns'Size);
-- We need an unsigned type large enough to represent the mantissa
- Need_Extra : constant Boolean := Num'Machine_Mantissa > Uns'Size - 4;
- -- If the mantissa of the floating-point type is almost as large as the
- -- unsigned type, we do not have enough space for an extra digit in the
- -- unsigned type so we handle the extra digit separately, at the cost of
- -- a bit more work in Integer_to_Real.
+ Is_Large_Type : constant Boolean := Num'Machine_Mantissa >= 53;
+ -- True if the floating-point type is at least IEEE Double
- Precision_Limit : constant Uns :=
- (if Need_Extra then 2**Num'Machine_Mantissa - 1 else 2**Uns'Size - 1);
- -- If we handle the extra digit separately, we use the precision of the
- -- floating-point type so that the conversion is exact.
+ Precision_Limit : constant Uns := 2**Num'Machine_Mantissa - 1;
+ -- See below for the rationale
- package Impl is new Value_R (Uns, Precision_Limit, Round => Need_Extra);
+ package Impl is new Value_R (Uns, 2, Precision_Limit, Round => False);
subtype Base_T is Unsigned range 2 .. 16;
@@ -64,18 +59,21 @@ package body System.Val_Real is
Maxexp32 : constant array (Base_T) of Positive :=
[2 => 127, 3 => 80, 4 => 63, 5 => 55, 6 => 49,
- 7 => 45, 8 => 42, 9 => 40, 10 => 38, 11 => 37,
+ 7 => 45, 8 => 42, 9 => 40, 10 => 55, 11 => 37,
12 => 35, 13 => 34, 14 => 33, 15 => 32, 16 => 31];
+ -- The actual value for 10 is 38 but we also use scaling for 10
Maxexp64 : constant array (Base_T) of Positive :=
[2 => 1023, 3 => 646, 4 => 511, 5 => 441, 6 => 396,
- 7 => 364, 8 => 341, 9 => 323, 10 => 308, 11 => 296,
+ 7 => 364, 8 => 341, 9 => 323, 10 => 441, 11 => 296,
12 => 285, 13 => 276, 14 => 268, 15 => 262, 16 => 255];
+ -- The actual value for 10 is 308 but we also use scaling for 10
Maxexp80 : constant array (Base_T) of Positive :=
[2 => 16383, 3 => 10337, 4 => 8191, 5 => 7056, 6 => 6338,
- 7 => 5836, 8 => 5461, 9 => 5168, 10 => 4932, 11 => 4736,
+ 7 => 5836, 8 => 5461, 9 => 5168, 10 => 7056, 11 => 4736,
12 => 4570, 13 => 4427, 14 => 4303, 15 => 4193, 16 => 4095];
+ -- The actual value for 10 is 4932 but we also use scaling for 10
package Double_Real is new System.Double_Real (Num);
use type Double_Real.Double_T;
@@ -83,17 +81,28 @@ package body System.Val_Real is
subtype Double_T is Double_Real.Double_T;
-- The double floating-point type
+ function Exact_Log2 (N : Unsigned) return Positive is
+ (case N is
+ when 2 => 1,
+ when 4 => 2,
+ when 8 => 3,
+ when 16 => 4,
+ when others => raise Program_Error);
+ -- Return the exponent of a power of 2
+
function Integer_to_Real
(Str : String;
- Val : Uns;
+ Val : Impl.Value_Array;
Base : Unsigned;
- Scale : Integer;
- Extra : Unsigned;
+ Scale : Impl.Scale_Array;
Minus : Boolean) return Num;
-- Convert the real value from integer to real representation
- function Large_Powten (Exp : Natural) return Double_T;
- -- Return 10.0**Exp as a double number, where Exp > Maxpow
+ function Large_Powfive (Exp : Natural) return Double_T;
+ -- Return 5.0**Exp as a double number, where Exp > Maxpow
+
+ function Large_Powfive (Exp : Natural; S : out Natural) return Double_T;
+ -- Return Num'Scaling (5.0**Exp, -S) as a double number where Exp > Maxexp
---------------------
-- Integer_to_Real --
@@ -101,10 +110,9 @@ package body System.Val_Real is
function Integer_to_Real
(Str : String;
- Val : Uns;
+ Val : Impl.Value_Array;
Base : Unsigned;
- Scale : Integer;
- Extra : Unsigned;
+ Scale : Impl.Scale_Array;
Minus : Boolean) return Num
is
pragma Assert (Base in 2 .. 16);
@@ -120,9 +128,9 @@ package body System.Val_Real is
else raise Program_Error);
-- Maximum exponent of the base that can fit in Num
- R_Val : Num;
D_Val : Double_T;
- S : Integer := Scale;
+ R_Val : Num;
+ S : Integer;
begin
-- We call the floating-point processor reset routine so we can be sure
@@ -134,82 +142,78 @@ package body System.Val_Real is
System.Float_Control.Reset;
end if;
- -- Take into account the extra digit, i.e. do the two computations
-
- -- (1) R_Val := R_Val * Num (B) + Num (Extra)
- -- (2) S := S - 1
+ -- First convert the integer mantissa into a double real. The conversion
+ -- of each part is exact, given the precision limit we used above. Then,
+ -- if the contribution of the low part might be nonnull, scale the high
+ -- part appropriately and add the low part to the result.
- -- In the first, the three operands are exact, so using an FMA would
- -- be ideal, but we are most likely running on the x87 FPU, hence we
- -- may not have one. That is why we turn the multiplication into an
- -- iterated addition with exact error handling, so that we can do a
- -- single rounding at the end.
+ if Val (2) = 0 then
+ D_Val := Double_Real.To_Double (Num (Val (1)));
+ S := Scale (1);
- if Need_Extra and then Extra > 0 then
+ else
declare
- B : Unsigned := Base;
- Acc : Num := 0.0;
- Err : Num := 0.0;
- Fac : Num := Num (Val);
- DS : Double_T;
+ V1 : constant Num := Num (Val (1));
+ V2 : constant Num := Num (Val (2));
+
+ DS : Positive;
begin
- loop
- -- If B is odd, add one factor. Note that the accumulator is
- -- never larger than the factor at this point (it is in fact
- -- never larger than the factor minus the initial value).
-
- if B rem 2 /= 0 then
- if Acc = 0.0 then
- Acc := Fac;
- else
- DS := Double_Real.Quick_Two_Sum (Fac, Acc);
- Acc := DS.Hi;
- Err := Err + DS.Lo;
- end if;
- exit when B = 1;
- end if;
+ DS := Scale (1) - Scale (2);
- -- Now B is (morally) even, halve it and double the factor,
- -- which is always an exact operation.
+ case Base is
+ -- If the base is a power of two, we use the efficient Scaling
+ -- attribute up to an amount worth a double mantissa.
- B := B / 2;
- Fac := Fac * 2.0;
- end loop;
+ when 2 | 4 | 8 | 16 =>
+ declare
+ L : constant Positive := Exact_Log2 (Base);
- -- Add Extra to the error, which are both small integers
+ begin
+ if DS <= 2 * Num'Machine_Mantissa / L then
+ DS := DS * L;
+ D_Val :=
+ Double_Real.Quick_Two_Sum (Num'Scaling (V1, DS), V2);
+ S := Scale (2);
- D_Val := Double_Real.Quick_Two_Sum (Acc, Err + Num (Extra));
+ else
+ D_Val := Double_Real.To_Double (V1);
+ S := Scale (1);
+ end if;
+ end;
- S := S - 1;
- end;
+ -- If the base is 10, we also scale up to an amount worth a
+ -- double mantissa.
- -- Or else, if the Extra digit is zero, do the exact conversion
+ when 10 =>
+ declare
+ Powfive : constant array (0 .. Maxpow) of Double_T;
+ pragma Import (Ada, Powfive);
+ for Powfive'Address use Powfive_Address;
- elsif Need_Extra then
- D_Val := Double_Real.To_Double (Num (Val));
+ begin
+ if DS <= Maxpow then
+ D_Val := Powfive (DS) * Num'Scaling (V1, DS) + V2;
+ S := Scale (2);
- -- Otherwise, the value contains more bits than the mantissa so do the
- -- conversion in two steps.
+ else
+ D_Val := Double_Real.To_Double (V1);
+ S := Scale (1);
+ end if;
+ end;
- else
- declare
- Mask : constant Uns := 2**(Uns'Size - Num'Machine_Mantissa) - 1;
- Hi : constant Uns := Val and not Mask;
- Lo : constant Uns := Val and Mask;
+ -- Inaccurate implementation for other bases
- begin
- if Hi = 0 then
- D_Val := Double_Real.To_Double (Num (Lo));
- else
- D_Val := Double_Real.Quick_Two_Sum (Num (Hi), Num (Lo));
- end if;
+ when others =>
+ D_Val := Double_Real.To_Double (V1);
+ S := Scale (1);
+ end case;
end;
end if;
-- Compute the final value by applying the scaling, if any
- if Val = 0 or else S = 0 then
+ if (Val (1) = 0 and then Val (2) = 0) or else S = 0 then
R_Val := Double_Real.To_Single (D_Val);
else
@@ -218,67 +222,58 @@ package body System.Val_Real is
-- attribute with an overflow check, if it is not 2, to catch
-- ludicrous exponents that would result in an infinity or zero.
- when 2 =>
- R_Val := Num'Scaling (Double_Real.To_Single (D_Val), S);
-
- when 4 =>
- if Integer'First / 2 <= S and then S <= Integer'Last / 2 then
- S := S * 2;
- end if;
-
- R_Val := Num'Scaling (Double_Real.To_Single (D_Val), S);
-
- when 8 =>
- if Integer'First / 3 <= S and then S <= Integer'Last / 3 then
- S := S * 3;
- end if;
-
- R_Val := Num'Scaling (Double_Real.To_Single (D_Val), S);
-
- when 16 =>
- if Integer'First / 4 <= S and then S <= Integer'Last / 4 then
- S := S * 4;
- end if;
+ when 2 | 4 | 8 | 16 =>
+ declare
+ L : constant Positive := Exact_Log2 (Base);
- R_Val := Num'Scaling (Double_Real.To_Single (D_Val), S);
+ begin
+ if Integer'First / L <= S and then S <= Integer'Last / L then
+ S := S * L;
+ end if;
- -- If the base is 10, use a double implementation for the sake
- -- of accuracy, to be removed when exponentiation is improved.
+ R_Val := Num'Scaling (Double_Real.To_Single (D_Val), S);
+ end;
- -- When the exponent is positive, we can do the computation
- -- directly because, if the exponentiation overflows, then
- -- the final value overflows as well. But when the exponent
- -- is negative, we may need to do it in two steps to avoid
- -- an artificial underflow.
+ -- If the base is 10, we use a double implementation for the sake
+ -- of accuracy combining powers of 5 and scaling attribute. Using
+ -- this combination is better than using powers of 10 only because
+ -- the Large_Powfive function may overflow only if the final value
+ -- will also either overflow or underflow, thus making it possible
+ -- to use a single division for the case of negative powers of 10.
when 10 =>
declare
- Powten : constant array (0 .. Maxpow) of Double_T;
- pragma Import (Ada, Powten);
- for Powten'Address use Powten_Address;
+ Powfive : constant array (0 .. Maxpow) of Double_T;
+ pragma Import (Ada, Powfive);
+ for Powfive'Address use Powfive_Address;
+
+ RS : Natural;
begin
if S > 0 then
if S <= Maxpow then
- D_Val := D_Val * Powten (S);
+ D_Val := D_Val * Powfive (S);
else
- D_Val := D_Val * Large_Powten (S);
+ D_Val := D_Val * Large_Powfive (S);
end if;
else
- if S < -Maxexp then
- D_Val := D_Val / Large_Powten (Maxexp);
- S := S + Maxexp;
- end if;
-
if S >= -Maxpow then
- D_Val := D_Val / Powten (-S);
+ D_Val := D_Val / Powfive (-S);
+
+ -- For small types, typically IEEE Single, the trick
+ -- described above does not fully work.
+
+ elsif not Is_Large_Type and then S < -Maxexp then
+ D_Val := D_Val / Large_Powfive (-S, RS);
+ S := S - RS;
+
else
- D_Val := D_Val / Large_Powten (-S);
+ D_Val := D_Val / Large_Powfive (-S);
end if;
end if;
- R_Val := Double_Real.To_Single (D_Val);
+ R_Val := Num'Scaling (Double_Real.To_Single (D_Val), S);
end;
-- Implementation for other bases with exponentiation
@@ -320,14 +315,26 @@ package body System.Val_Real is
when Constraint_Error => Bad_Value (Str);
end Integer_to_Real;
- ------------------
- -- Large_Powten --
- ------------------
+ -------------------
+ -- Large_Powfive --
+ -------------------
+
+ function Large_Powfive (Exp : Natural) return Double_T is
+ Powfive : constant array (0 .. Maxpow) of Double_T;
+ pragma Import (Ada, Powfive);
+ for Powfive'Address use Powfive_Address;
+
+ Powfive_100 : constant Double_T;
+ pragma Import (Ada, Powfive_100);
+ for Powfive_100'Address use Powfive_100_Address;
+
+ Powfive_200 : constant Double_T;
+ pragma Import (Ada, Powfive_200);
+ for Powfive_200'Address use Powfive_200_Address;
- function Large_Powten (Exp : Natural) return Double_T is
- Powten : constant array (0 .. Maxpow) of Double_T;
- pragma Import (Ada, Powten);
- for Powten'Address use Powten_Address;
+ Powfive_300 : constant Double_T;
+ pragma Import (Ada, Powfive_300);
+ for Powfive_300'Address use Powfive_300_Address;
R : Double_T;
E : Natural;
@@ -335,18 +342,80 @@ package body System.Val_Real is
begin
pragma Assert (Exp > Maxpow);
- R := Powten (Maxpow);
+ if Is_Large_Type and then Exp >= 300 then
+ R := Powfive_300;
+ E := Exp - 300;
+
+ elsif Is_Large_Type and then Exp >= 200 then
+ R := Powfive_200;
+ E := Exp - 200;
+
+ elsif Is_Large_Type and then Exp >= 100 then
+ R := Powfive_100;
+ E := Exp - 100;
+
+ else
+ R := Powfive (Maxpow);
+ E := Exp - Maxpow;
+ end if;
+
+ while E > Maxpow loop
+ R := R * Powfive (Maxpow);
+ E := E - Maxpow;
+ end loop;
+
+ R := R * Powfive (E);
+
+ return R;
+ end Large_Powfive;
+
+ function Large_Powfive (Exp : Natural; S : out Natural) return Double_T is
+ Maxexp : constant Positive :=
+ (if Num'Size = 32 then Maxexp32 (5)
+ elsif Num'Size = 64 then Maxexp64 (5)
+ elsif Num'Machine_Mantissa = 64 then Maxexp80 (5)
+ else raise Program_Error);
+ -- Maximum exponent of 5 that can fit in Num
+
+ Powfive : constant array (0 .. Maxpow) of Double_T;
+ pragma Import (Ada, Powfive);
+ for Powfive'Address use Powfive_Address;
+
+ R : Double_T;
+ E : Natural;
+
+ begin
+ pragma Assert (Exp > Maxexp);
+
+ pragma Warnings (Off, "-gnatw.a");
+ pragma Assert (not Is_Large_Type);
+ pragma Warnings (On, "-gnatw.a");
+
+ R := Powfive (Maxpow);
E := Exp - Maxpow;
+ -- If the exponent is not too large, then scale down the result so that
+ -- its final value does not overflow but, if it's too large, then do not
+ -- bother doing it since overflow is just fine. The scaling factor is -3
+ -- for every power of 5 above the maximum, in other words division by 8.
+
+ if Exp - Maxexp <= Maxpow then
+ S := 3 * (Exp - Maxexp);
+ R.Hi := Num'Scaling (R.Hi, -S);
+ R.Lo := Num'Scaling (R.Lo, -S);
+ else
+ S := 0;
+ end if;
+
while E > Maxpow loop
- R := R * Powten (Maxpow);
+ R := R * Powfive (Maxpow);
E := E - Maxpow;
end loop;
- R := R * Powten (E);
+ R := R * Powfive (E);
return R;
- end Large_Powten;
+ end Large_Powfive;
---------------
-- Scan_Real --
@@ -358,15 +427,15 @@ package body System.Val_Real is
Max : Integer) return Num
is
Base : Unsigned;
- Scale : Integer;
+ Scale : Impl.Scale_Array;
Extra : Unsigned;
Minus : Boolean;
- Val : Uns;
+ Val : Impl.Value_Array;
begin
Val := Impl.Scan_Raw_Real (Str, Ptr, Max, Base, Scale, Extra, Minus);
- return Integer_to_Real (Str, Val, Base, Scale, Extra, Minus);
+ return Integer_to_Real (Str, Val, Base, Scale, Minus);
end Scan_Real;
----------------
@@ -375,15 +444,15 @@ package body System.Val_Real is
function Value_Real (Str : String) return Num is
Base : Unsigned;
- Scale : Integer;
+ Scale : Impl.Scale_Array;
Extra : Unsigned;
Minus : Boolean;
- Val : Uns;
+ Val : Impl.Value_Array;
begin
Val := Impl.Value_Raw_Real (Str, Base, Scale, Extra, Minus);
- return Integer_to_Real (Str, Val, Base, Scale, Extra, Minus);
+ return Integer_to_Real (Str, Val, Base, Scale, Minus);
end Value_Real;
end System.Val_Real;
diff --git a/gcc/ada/libgnat/s-valrea.ads b/gcc/ada/libgnat/s-valrea.ads
index 1d55fc9..89be8d7 100644
--- a/gcc/ada/libgnat/s-valrea.ads
+++ b/gcc/ada/libgnat/s-valrea.ads
@@ -38,7 +38,13 @@ generic
Maxpow : Positive;
- Powten_Address : System.Address;
+ Powfive_Address : System.Address;
+
+ Powfive_100_Address : System.Address;
+
+ Powfive_200_Address : System.Address;
+
+ Powfive_300_Address : System.Address;
type Uns is mod <>;
diff --git a/gcc/ada/libgnat/s-valued.adb b/gcc/ada/libgnat/s-valued.adb
index c4a78a2..92e9140 100644
--- a/gcc/ada/libgnat/s-valued.adb
+++ b/gcc/ada/libgnat/s-valued.adb
@@ -38,7 +38,7 @@ package body System.Value_D is
pragma Assert (Int'Size <= Uns'Size);
-- We need an unsigned type large enough to represent the mantissa
- package Impl is new Value_R (Uns, 2**(Int'Size - 1), Round => False);
+ 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
function Integer_to_Decimal
@@ -229,16 +229,16 @@ package body System.Value_D is
Max : Integer;
Scale : Integer) return Int
is
- Base : Unsigned;
- ScaleB : Integer;
- Extra : Unsigned;
- Minus : Boolean;
- Val : Uns;
+ Base : Unsigned;
+ Scl : Impl.Scale_Array;
+ Extra : Unsigned;
+ Minus : Boolean;
+ Val : Impl.Value_Array;
begin
- Val := Impl.Scan_Raw_Real (Str, Ptr, Max, Base, ScaleB, Extra, Minus);
+ Val := Impl.Scan_Raw_Real (Str, Ptr, Max, Base, Scl, Extra, Minus);
- return Integer_to_Decimal (Str, Val, Base, ScaleB, Minus, Scale);
+ return Integer_to_Decimal (Str, Val (1), Base, Scl (1), Minus, Scale);
end Scan_Decimal;
-------------------
@@ -246,16 +246,16 @@ package body System.Value_D is
-------------------
function Value_Decimal (Str : String; Scale : Integer) return Int is
- Base : Unsigned;
- ScaleB : Integer;
- Extra : Unsigned;
- Minus : Boolean;
- Val : Uns;
+ Base : Unsigned;
+ Scl : Impl.Scale_Array;
+ Extra : Unsigned;
+ Minus : Boolean;
+ Val : Impl.Value_Array;
begin
- Val := Impl.Value_Raw_Real (Str, Base, ScaleB, Extra, Minus);
+ Val := Impl.Value_Raw_Real (Str, Base, Scl, Extra, Minus);
- return Integer_to_Decimal (Str, Val, Base, ScaleB, Minus, Scale);
+ return Integer_to_Decimal (Str, Val (1), Base, Scl (1), 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 e252a28..1b9d18e 100644
--- a/gcc/ada/libgnat/s-valuef.adb
+++ b/gcc/ada/libgnat/s-valuef.adb
@@ -46,7 +46,7 @@ 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, 2**(Int'Size - 1), Round => True);
+ package Impl is new Value_R (Uns, 1, 2**(Int'Size - 1), Round => True);
-- We use the Extra digit for ordinary fixed-point types
function Integer_To_Fixed
@@ -332,16 +332,17 @@ package body System.Value_F is
Num : Int;
Den : Int) return Int
is
- Base : Unsigned;
- ScaleB : Integer;
- Extra : Unsigned;
- Minus : Boolean;
- Val : Uns;
+ Base : Unsigned;
+ Scl : Impl.Scale_Array;
+ Extra : Unsigned;
+ Minus : Boolean;
+ Val : Impl.Value_Array;
begin
- Val := Impl.Scan_Raw_Real (Str, Ptr, Max, Base, ScaleB, Extra, Minus);
+ Val := Impl.Scan_Raw_Real (Str, Ptr, Max, Base, Scl, Extra, Minus);
- return Integer_To_Fixed (Str, Val, Base, ScaleB, Extra, Minus, Num, Den);
+ return
+ Integer_To_Fixed (Str, Val (1), Base, Scl (1), Extra, Minus, Num, Den);
end Scan_Fixed;
-----------------
@@ -353,16 +354,17 @@ package body System.Value_F is
Num : Int;
Den : Int) return Int
is
- Base : Unsigned;
- ScaleB : Integer;
- Extra : Unsigned;
- Minus : Boolean;
- Val : Uns;
+ Base : Unsigned;
+ Scl : Impl.Scale_Array;
+ Extra : Unsigned;
+ Minus : Boolean;
+ Val : Impl.Value_Array;
begin
- Val := Impl.Value_Raw_Real (Str, Base, ScaleB, Extra, Minus);
+ Val := Impl.Value_Raw_Real (Str, Base, Scl, Extra, Minus);
- return Integer_To_Fixed (Str, Val, Base, ScaleB, Extra, Minus, Num, Den);
+ return
+ Integer_To_Fixed (Str, Val (1), Base, Scl (1), Extra, Minus, Num, Den);
end Value_Fixed;
end System.Value_F;
diff --git a/gcc/ada/libgnat/s-valuer.adb b/gcc/ada/libgnat/s-valuer.adb
index fc91660..c55444a 100644
--- a/gcc/ada/libgnat/s-valuer.adb
+++ b/gcc/ada/libgnat/s-valuer.adb
@@ -44,22 +44,23 @@ package body System.Value_R is
procedure Round_Extra
(Digit : Char_As_Digit;
+ Base : Unsigned;
Value : in out Uns;
Scale : in out Integer;
- Extra : in out Char_As_Digit;
- Base : Unsigned);
+ 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;
Max : Integer;
- Value : in out Uns;
- Scale : in out Integer;
- Extra : in out Char_As_Digit;
- Base_Violation : in out Boolean;
Base : Unsigned;
- Base_Specified : Boolean);
+ Base_Specified : Boolean;
+ Value : in out Value_Array;
+ Scale : in out Scale_Array;
+ N : in out Positive;
+ Extra : in out Char_As_Digit;
+ Base_Violation : in out Boolean);
-- Scan the decimal part of a real (i.e. after decimal separator)
--
-- The string parsed is Str (Index .. Max) and after the call Index will
@@ -77,12 +78,13 @@ package body System.Value_R is
(Str : String;
Index : in out Integer;
Max : Integer;
- Value : out Uns;
- Scale : out Integer;
- Extra : out Char_As_Digit;
- Base_Violation : in out Boolean;
Base : Unsigned;
- Base_Specified : Boolean);
+ Base_Specified : Boolean;
+ Value : out Value_Array;
+ Scale : out Scale_Array;
+ N : out Positive;
+ Extra : out Char_As_Digit;
+ Base_Violation : in out Boolean);
-- Scan the integral part of a real (i.e. before decimal separator)
--
-- The string parsed is Str (Index .. Max) and after the call Index will
@@ -123,10 +125,10 @@ package body System.Value_R is
procedure Round_Extra
(Digit : Char_As_Digit;
+ Base : Unsigned;
Value : in out Uns;
Scale : in out Integer;
- Extra : in out Char_As_Digit;
- Base : Unsigned)
+ Extra : in out Char_As_Digit)
is
pragma Assert (Base in 2 .. 16);
@@ -145,7 +147,7 @@ package body System.Value_R is
Extra := Char_As_Digit (Value mod B);
Value := Value / B;
Scale := Scale + 1;
- Round_Extra (Digit, Value, Scale, Extra, Base);
+ Round_Extra (Digit, Base, Value, Scale, Extra);
else
Extra := 0;
@@ -166,12 +168,13 @@ package body System.Value_R is
(Str : String;
Index : in out Integer;
Max : Integer;
- Value : in out Uns;
- Scale : in out Integer;
- Extra : in out Char_As_Digit;
- Base_Violation : in out Boolean;
Base : Unsigned;
- Base_Specified : Boolean)
+ Base_Specified : Boolean;
+ Value : in out Value_Array;
+ Scale : in out Scale_Array;
+ N : in out Positive;
+ Extra : in out Char_As_Digit;
+ Base_Violation : in out Boolean)
is
pragma Assert (Base in 2 .. 16);
@@ -205,7 +208,7 @@ package body System.Value_R is
-- If initial Scale is not 0 then it means that Precision_Limit was
-- reached during scanning of the integral part.
- if Scale > 0 then
+ if Scale (Data_Index'Last) > 0 then
Precision_Limit_Reached := True;
else
Extra := 0;
@@ -247,7 +250,7 @@ package body System.Value_R is
if Precision_Limit_Reached then
if Round and then Precision_Limit_Just_Reached then
- Round_Extra (Digit, Value, Scale, Extra, Base);
+ Round_Extra (Digit, Base, Value (N), Scale (N), Extra);
Precision_Limit_Just_Reached := False;
end if;
@@ -258,19 +261,24 @@ package body System.Value_R is
Trailing_Zeros := Trailing_Zeros + 1;
else
- -- Handle accumulated zeros.
+ -- Handle accumulated zeros
for J in 1 .. Trailing_Zeros loop
- if Value <= UmaxB then
- Value := Value * Uns (Base);
- Scale := Scale - 1;
+ if Value (N) <= UmaxB then
+ Value (N) := Value (N) * Uns (Base);
+ Scale (N) := Scale (N) - 1;
+
+ elsif Parts > 1 and then N < Data_Index'Last then
+ N := N + 1;
+ Scale (N) := Scale (N - 1) - 1;
else
Extra := 0;
Precision_Limit_Reached := True;
if Round and then J = Trailing_Zeros then
- Round_Extra (Digit, Value, Scale, Extra, Base);
+ Round_Extra (Digit, Base, Value (N), Scale (N), Extra);
end if;
+
exit;
end if;
end loop;
@@ -281,7 +289,7 @@ package body System.Value_R is
-- Handle current non zero digit
- Temp := Value * Uns (Base) + Uns (Digit);
+ Temp := Value (N) * Uns (Base) + Uns (Digit);
-- Precision_Limit_Reached may have been set above
@@ -292,15 +300,20 @@ package body System.Value_R is
-- account that Temp may wrap around when Precision_Limit is
-- equal to the largest integer.
- elsif Value <= Umax
- or else (Value <= UmaxB
+ elsif Value (N) <= Umax
+ or else (Value (N) <= UmaxB
and then ((Precision_Limit < Uns'Last
and then Temp <= Precision_Limit)
or else (Precision_Limit = Uns'Last
and then Temp >= Uns (Base))))
then
- Value := Temp;
- Scale := Scale - 1;
+ Value (N) := Temp;
+ Scale (N) := Scale (N) - 1;
+
+ elsif Parts > 1 and then N < Data_Index'Last then
+ N := N + 1;
+ Value (N) := Uns (Digit);
+ Scale (N) := Scale (N - 1) - 1;
else
Extra := Digit;
@@ -352,12 +365,13 @@ package body System.Value_R is
(Str : String;
Index : in out Integer;
Max : Integer;
- Value : out Uns;
- Scale : out Integer;
- Extra : out Char_As_Digit;
- Base_Violation : in out Boolean;
Base : Unsigned;
- Base_Specified : Boolean)
+ Base_Specified : Boolean;
+ Value : out Value_Array;
+ Scale : out Scale_Array;
+ N : out Positive;
+ Extra : out Char_As_Digit;
+ Base_Violation : in out Boolean)
is
pragma Assert (Base in 2 .. 16);
@@ -382,10 +396,11 @@ package body System.Value_R is
-- Temporary
begin
- -- Initialize Value, Scale and Extra
+ -- Initialize N, Value, Scale and Extra
- Value := 0;
- Scale := 0;
+ N := 1;
+ Value := (others => 0);
+ Scale := (others => 0);
Extra := 0;
Precision_Limit_Reached := False;
@@ -422,28 +437,32 @@ package body System.Value_R is
-- should continue only to assess the validity of the string.
if Precision_Limit_Reached then
- Scale := Scale + 1;
+ Scale (N) := Scale (N) + 1;
if Round and then Precision_Limit_Just_Reached then
- Round_Extra (Digit, Value, Scale, Extra, Base);
+ Round_Extra (Digit, Base, Value (N), Scale (N), Extra);
Precision_Limit_Just_Reached := False;
end if;
else
- Temp := Value * Uns (Base) + Uns (Digit);
+ Temp := Value (N) * Uns (Base) + Uns (Digit);
-- Check if Temp is larger than Precision_Limit, taking into
-- account that Temp may wrap around when Precision_Limit is
-- equal to the largest integer.
- if Value <= Umax
- or else (Value <= UmaxB
+ if Value (N) <= Umax
+ or else (Value (N) <= UmaxB
and then ((Precision_Limit < Uns'Last
and then Temp <= Precision_Limit)
or else (Precision_Limit = Uns'Last
and then Temp >= Uns (Base))))
then
- Value := Temp;
+ Value (N) := Temp;
+
+ elsif Parts > 1 and then N < Data_Index'Last then
+ N := N + 1;
+ Value (N) := Uns (Digit);
else
Extra := Digit;
@@ -451,10 +470,16 @@ package body System.Value_R is
if Round then
Precision_Limit_Just_Reached := True;
end if;
- Scale := Scale + 1;
+ Scale (N) := Scale (N) + 1;
end if;
end if;
+ -- Every parsed digit also scales the previous parts
+
+ for J in 1 .. N - 1 loop
+ Scale (J) := Scale (J) + 1;
+ end loop;
+
-- Look for the next character
Index := Index + 1;
@@ -492,9 +517,9 @@ package body System.Value_R is
Ptr : not null access Integer;
Max : Integer;
Base : out Unsigned;
- Scale : out Integer;
+ Scale : out Scale_Array;
Extra : out Unsigned;
- Minus : out Boolean) return Uns
+ Minus : out Boolean) return Value_Array
is
pragma Assert (Max <= Str'Last);
@@ -509,8 +534,11 @@ 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.
+ N : Positive;
+ -- Index number of the current part
+
Expon : Integer;
- -- Exponent as an Integer
+ -- Exponent as an integer
Index : Integer;
-- Local copy of string pointer
@@ -518,8 +546,8 @@ package body System.Value_R is
Start : Positive;
-- Index of the first non-blank character
- Value : Uns;
- -- Mantissa as an Integer
+ Value : Value_Array;
+ -- Mantissa as an array of integers
begin
-- The default base is 10
@@ -554,8 +582,8 @@ package body System.Value_R is
-- part or the base to use.
Scan_Integral_Digits
- (Str, Index, Max, Value, Scale, Char_As_Digit (Extra),
- Base_Violation, Base, Base_Specified => False);
+ (Str, Index, Max, Base, False, Value, Scale, N,
+ Char_As_Digit (Extra), Base_Violation);
-- A dot is allowed only if followed by a digit (RM 3.5(47))
@@ -565,8 +593,9 @@ package body System.Value_R is
then
After_Point := True;
Index := Index + 1;
- Value := 0;
- Scale := 0;
+ N := 1;
+ Value := (others => 0);
+ Scale := (others => 0);
Extra := 0;
else
@@ -582,8 +611,8 @@ package body System.Value_R is
then
Base_Char := Str (Index);
- if Value in 2 .. 16 then
- Base := Unsigned (Value);
+ if N = 1 and then Value (1) in 2 .. 16 then
+ Base := Unsigned (Value (1));
else
Base_Violation := True;
Base := 16;
@@ -597,7 +626,7 @@ package body System.Value_R is
then
After_Point := True;
Index := Index + 1;
- Value := 0;
+ Value := (others => 0);
end if;
end if;
@@ -609,8 +638,8 @@ package body System.Value_R is
end if;
Scan_Integral_Digits
- (Str, Index, Max, Value, Scale, Char_As_Digit (Extra),
- Base_Violation, Base, Base_Specified => Base_Char /= ASCII.NUL);
+ (Str, Index, Max, Base, Base_Char /= ASCII.NUL, Value, Scale,
+ N, Char_As_Digit (Extra), Base_Violation);
end if;
-- Do we have a dot?
@@ -636,8 +665,8 @@ package body System.Value_R is
pragma Assert (Index <= Max);
Scan_Decimal_Digits
- (Str, Index, Max, Value, Scale, Char_As_Digit (Extra),
- Base_Violation, Base, Base_Specified => Base_Char /= ASCII.NUL);
+ (Str, Index, Max, Base, Base_Char /= ASCII.NUL, Value, Scale,
+ N, Char_As_Digit (Extra), Base_Violation);
end if;
-- If an explicit base was specified ensure that the delimiter is found
@@ -660,9 +689,15 @@ package body System.Value_R is
-- Handle very large exponents like Scan_Exponent
if Expon < Integer'First / 10 or else Expon > Integer'Last / 10 then
- Scale := Expon;
+ Scale (1) := Expon;
+ for J in 2 .. Data_Index'Last loop
+ Value (J) := 0;
+ end loop;
+
else
- Scale := Scale + Expon;
+ for J in Data_Index'Range loop
+ Scale (J) := Scale (J) + Expon;
+ end loop;
end if;
-- Here is where we check for a bad based number
@@ -672,7 +707,6 @@ package body System.Value_R is
else
return Value;
end if;
-
end Scan_Raw_Real;
--------------------
@@ -682,10 +716,13 @@ package body System.Value_R is
function Value_Raw_Real
(Str : String;
Base : out Unsigned;
- Scale : out Integer;
+ Scale : out Scale_Array;
Extra : out Unsigned;
- Minus : out Boolean) return Uns
+ Minus : out Boolean) return Value_Array
is
+ P : aliased Integer;
+ V : Value_Array;
+
begin
-- We have to special case Str'Last = Positive'Last because the normal
-- circuit ends up setting P to Str'Last + 1 which is out of bounds. We
@@ -697,20 +734,15 @@ package body System.Value_R is
begin
return Value_Raw_Real (NT (Str), Base, Scale, Extra, Minus);
end;
+ end if;
- -- Normal case where Str'Last < Positive'Last
+ -- Normal case
- else
- declare
- V : Uns;
- P : aliased Integer := Str'First;
- begin
- V := Scan_Raw_Real
- (Str, P'Access, Str'Last, Base, Scale, Extra, Minus);
- Scan_Trailing_Blanks (Str, P);
- return V;
- end;
- end if;
+ P := Str'First;
+ V := Scan_Raw_Real (Str, P'Access, Str'Last, Base, Scale, Extra, Minus);
+ Scan_Trailing_Blanks (Str, P);
+
+ return V;
end Value_Raw_Real;
end System.Value_R;
diff --git a/gcc/ada/libgnat/s-valuer.ads b/gcc/ada/libgnat/s-valuer.ads
index 3279090..d9d168e 100644
--- a/gcc/ada/libgnat/s-valuer.ads
+++ b/gcc/ada/libgnat/s-valuer.ads
@@ -37,22 +37,37 @@ with System.Unsigned_Types; use System.Unsigned_Types;
generic
type Uns is mod <>;
+ -- Modular type used for the value
+
+ Parts : Positive;
+ -- Number of Uns parts in the value
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;
+ subtype Data_Index is Positive range 1 .. Parts;
+ -- The type indexing the value
+
+ type Scale_Array is array (Data_Index) of Integer;
+ -- The scale for each part of the value
+
+ type Value_Array is array (Data_Index) of Uns;
+ -- The value split into parts
+
function Scan_Raw_Real
(Str : String;
Ptr : not null access Integer;
Max : Integer;
Base : out Unsigned;
- Scale : out Integer;
+ Scale : out Scale_Array;
Extra : out Unsigned;
- Minus : out Boolean) return Uns;
+ 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
@@ -64,9 +79,13 @@ package System.Value_R is
-- parameters are set; if Val is the result of the call, then the real
-- represented by the literal is equal to
--
- -- (Val * Base + Extra) * (Base ** (Scale - 1))
+ -- (Val (1) * Base + Extra) * (Base ** (Scale (1) - 1))
+ --
+ -- when Parts = 1 and
+ --
+ -- Sum [Val (N) * (Base ** Scale (N)), N in 1 .. Parts]
--
- -- with the negative sign if Minus is true.
+ -- when Parts > 1, with the negative sign if Minus is true.
--
-- If no valid real is found, then Ptr.all points either to an initial
-- non-blank character, or to Max + 1 if the field is all spaces and the
@@ -91,9 +110,9 @@ package System.Value_R is
function Value_Raw_Real
(Str : String;
Base : out Unsigned;
- Scale : out Integer;
+ Scale : out Scale_Array;
Extra : out Unsigned;
- Minus : out Boolean) return Uns;
+ 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/system-qnx-arm.ads b/gcc/ada/libgnat/system-qnx-arm.ads
index 749384f..038fe6c 100644
--- a/gcc/ada/libgnat/system-qnx-arm.ads
+++ b/gcc/ada/libgnat/system-qnx-arm.ads
@@ -142,7 +142,7 @@ private
Stack_Check_Probes : constant Boolean := True;
Stack_Check_Limits : constant Boolean := False;
Support_Aggregates : constant Boolean := True;
- Support_Atomic_Primitives : constant Boolean := True;
+ Support_Atomic_Primitives : constant Boolean := False;
Support_Composite_Assign : constant Boolean := True;
Support_Composite_Compare : constant Boolean := True;
Support_Long_Shifts : constant Boolean := True;
diff --git a/gcc/ada/libgnat/system-vxworks7-aarch64-rtp-smp.ads b/gcc/ada/libgnat/system-vxworks7-aarch64-rtp-smp.ads
index 46b740e..ae67cd0 100644
--- a/gcc/ada/libgnat/system-vxworks7-aarch64-rtp-smp.ads
+++ b/gcc/ada/libgnat/system-vxworks7-aarch64-rtp-smp.ads
@@ -151,7 +151,7 @@ private
Stack_Check_Probes : constant Boolean := True;
Stack_Check_Limits : constant Boolean := False;
Support_Aggregates : constant Boolean := True;
- Support_Atomic_Primitives : constant Boolean := True;
+ Support_Atomic_Primitives : constant Boolean := False;
Support_Composite_Assign : constant Boolean := True;
Support_Composite_Compare : constant Boolean := True;
Support_Long_Shifts : constant Boolean := True;
diff --git a/gcc/ada/libgnat/system-vxworks7-aarch64.ads b/gcc/ada/libgnat/system-vxworks7-aarch64.ads
index 1aba15b..a943ecd 100644
--- a/gcc/ada/libgnat/system-vxworks7-aarch64.ads
+++ b/gcc/ada/libgnat/system-vxworks7-aarch64.ads
@@ -148,7 +148,7 @@ private
Stack_Check_Probes : constant Boolean := True;
Stack_Check_Limits : constant Boolean := False;
Support_Aggregates : constant Boolean := True;
- Support_Atomic_Primitives : constant Boolean := True;
+ Support_Atomic_Primitives : constant Boolean := False;
Support_Composite_Assign : constant Boolean := True;
Support_Composite_Compare : constant Boolean := True;
Support_Long_Shifts : constant Boolean := True;
diff --git a/gcc/ada/libgnat/system-vxworks7-arm-rtp-smp.ads b/gcc/ada/libgnat/system-vxworks7-arm-rtp-smp.ads
index e81348e..49e6e7a 100644
--- a/gcc/ada/libgnat/system-vxworks7-arm-rtp-smp.ads
+++ b/gcc/ada/libgnat/system-vxworks7-arm-rtp-smp.ads
@@ -148,7 +148,7 @@ private
Stack_Check_Probes : constant Boolean := True;
Stack_Check_Limits : constant Boolean := False;
Support_Aggregates : constant Boolean := True;
- Support_Atomic_Primitives : constant Boolean := True;
+ Support_Atomic_Primitives : constant Boolean := False;
Support_Composite_Assign : constant Boolean := True;
Support_Composite_Compare : constant Boolean := True;
Support_Long_Shifts : constant Boolean := True;
diff --git a/gcc/ada/libgnat/system-vxworks7-arm.ads b/gcc/ada/libgnat/system-vxworks7-arm.ads
index 4ced0f1..6d3218f4 100644
--- a/gcc/ada/libgnat/system-vxworks7-arm.ads
+++ b/gcc/ada/libgnat/system-vxworks7-arm.ads
@@ -146,7 +146,7 @@ private
Stack_Check_Probes : constant Boolean := True;
Stack_Check_Limits : constant Boolean := False;
Support_Aggregates : constant Boolean := True;
- Support_Atomic_Primitives : constant Boolean := True;
+ Support_Atomic_Primitives : constant Boolean := False;
Support_Composite_Assign : constant Boolean := True;
Support_Composite_Compare : constant Boolean := True;
Support_Long_Shifts : constant Boolean := True;
diff --git a/gcc/ada/libgnat/system-vxworks7-x86-kernel.ads b/gcc/ada/libgnat/system-vxworks7-x86-kernel.ads
index 42ae983..e34c22a 100644
--- a/gcc/ada/libgnat/system-vxworks7-x86-kernel.ads
+++ b/gcc/ada/libgnat/system-vxworks7-x86-kernel.ads
@@ -146,7 +146,7 @@ private
Stack_Check_Probes : constant Boolean := True;
Stack_Check_Limits : constant Boolean := False;
Support_Aggregates : constant Boolean := True;
- Support_Atomic_Primitives : constant Boolean := True;
+ Support_Atomic_Primitives : constant Boolean := False;
Support_Composite_Assign : constant Boolean := True;
Support_Composite_Compare : constant Boolean := True;
Support_Long_Shifts : constant Boolean := True;
diff --git a/gcc/ada/libgnat/system-vxworks7-x86-rtp-smp.ads b/gcc/ada/libgnat/system-vxworks7-x86-rtp-smp.ads
index 47dd3ae..68ca423 100644
--- a/gcc/ada/libgnat/system-vxworks7-x86-rtp-smp.ads
+++ b/gcc/ada/libgnat/system-vxworks7-x86-rtp-smp.ads
@@ -149,7 +149,7 @@ private
Stack_Check_Probes : constant Boolean := True;
Stack_Check_Limits : constant Boolean := False;
Support_Aggregates : constant Boolean := True;
- Support_Atomic_Primitives : constant Boolean := True;
+ Support_Atomic_Primitives : constant Boolean := False;
Support_Composite_Assign : constant Boolean := True;
Support_Composite_Compare : constant Boolean := True;
Support_Long_Shifts : constant Boolean := True;
diff --git a/gcc/ada/libgnat/system-vxworks7-x86_64-kernel.ads b/gcc/ada/libgnat/system-vxworks7-x86_64-kernel.ads
index 7931241..6504a02 100644
--- a/gcc/ada/libgnat/system-vxworks7-x86_64-kernel.ads
+++ b/gcc/ada/libgnat/system-vxworks7-x86_64-kernel.ads
@@ -146,7 +146,7 @@ private
Stack_Check_Probes : constant Boolean := True;
Stack_Check_Limits : constant Boolean := False;
Support_Aggregates : constant Boolean := True;
- Support_Atomic_Primitives : constant Boolean := True;
+ Support_Atomic_Primitives : constant Boolean := False;
Support_Composite_Assign : constant Boolean := True;
Support_Composite_Compare : constant Boolean := True;
Support_Long_Shifts : constant Boolean := True;
diff --git a/gcc/ada/libgnat/system-vxworks7-x86_64-rtp-smp.ads b/gcc/ada/libgnat/system-vxworks7-x86_64-rtp-smp.ads
index 3c98b4c..ffcc78f 100644
--- a/gcc/ada/libgnat/system-vxworks7-x86_64-rtp-smp.ads
+++ b/gcc/ada/libgnat/system-vxworks7-x86_64-rtp-smp.ads
@@ -149,7 +149,7 @@ private
Stack_Check_Probes : constant Boolean := True;
Stack_Check_Limits : constant Boolean := False;
Support_Aggregates : constant Boolean := True;
- Support_Atomic_Primitives : constant Boolean := True;
+ Support_Atomic_Primitives : constant Boolean := False;
Support_Composite_Assign : constant Boolean := True;
Support_Composite_Compare : constant Boolean := True;
Support_Long_Shifts : constant Boolean := True;
diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads
index 19a8b41..8f903ca 100644
--- a/gcc/ada/opt.ads
+++ b/gcc/ada/opt.ads
@@ -544,6 +544,13 @@ package Opt is
-- Set to True to enable CUDA host expansion:
-- - Removal of CUDA_Global and CUDA_Device symbols
-- - Generation of kernel registration code in packages
+ -- - Binder invokes device elaboration/finalization code
+
+ Enable_CUDA_Device_Expansion : Boolean := False;
+ -- GNATBIND
+ -- Set to True to enable CUDA device (as opposed to host) expansion:
+ -- - Binder generates elaboration/finalization code that can be
+ -- invoked from corresponding binder-generated host-side code.
Error_Msg_Line_Length : Nat := 0;
-- GNAT
diff --git a/gcc/ada/par-ch10.adb b/gcc/ada/par-ch10.adb
index 613be37..70fd7ad 100644
--- a/gcc/ada/par-ch10.adb
+++ b/gcc/ada/par-ch10.adb
@@ -279,10 +279,7 @@ package body Ch10 is
Set_Private_Present (Comp_Unit_Node, True);
end if;
- elsif Token = Tok_Procedure
- or else Token = Tok_Function
- or else Token = Tok_Generic
- then
+ elsif Token in Tok_Procedure | Tok_Function | Tok_Generic then
Set_Private_Present (Comp_Unit_Node, True);
end if;
end if;
@@ -300,8 +297,7 @@ package body Ch10 is
-- Allow task and protected for nice error recovery purposes
- exit when Token = Tok_Task
- or else Token = Tok_Protected;
+ exit when Token in Tok_Task | Tok_Protected;
if Token = Tok_With then
Error_Msg_SC ("misplaced WITH");
@@ -376,10 +372,7 @@ package body Ch10 is
elsif Token = Tok_Separate then
Set_Unit (Comp_Unit_Node, P_Subunit);
- elsif Token = Tok_Function
- or else Token = Tok_Not
- or else Token = Tok_Overriding
- or else Token = Tok_Procedure
+ elsif Token in Tok_Function | Tok_Not | Tok_Overriding | Tok_Procedure
then
Set_Unit (Comp_Unit_Node, P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Pexp));
@@ -392,10 +385,7 @@ package body Ch10 is
if SIS_Entry_Active then
- if Token = Tok_Begin
- or else Token = Tok_Identifier
- or else Token in Token_Class_Deckn
- then
+ if Token in Tok_Begin | Tok_Identifier | Token_Class_Deckn then
Push_Scope_Stack;
Scopes (Scope.Last).Etyp := E_Name;
Scopes (Scope.Last).Sloc := SIS_Sloc;
@@ -947,10 +937,7 @@ package body Ch10 is
Save_Scan_State (Scan_State);
Scan; -- past comma
- if Token in Token_Class_Cunit
- or else Token = Tok_Use
- or else Token = Tok_Pragma
- then
+ if Token in Token_Class_Cunit | Tok_Use | Tok_Pragma then
Restore_Scan_State (Scan_State);
exit;
end if;
@@ -1047,11 +1034,7 @@ package body Ch10 is
Ignore (Tok_Semicolon);
- if Token = Tok_Function
- or else Token = Tok_Not
- or else Token = Tok_Overriding
- or else Token = Tok_Procedure
- then
+ if Token in Tok_Function | Tok_Not | Tok_Overriding | Tok_Procedure then
Body_Node := P_Subprogram (Pf_Pbod_Pexp);
elsif Token = Tok_Package then
diff --git a/gcc/ada/par-ch12.adb b/gcc/ada/par-ch12.adb
index fc76ad4..0f124f0 100644
--- a/gcc/ada/par-ch12.adb
+++ b/gcc/ada/par-ch12.adb
@@ -114,10 +114,7 @@ package body Ch12 is
-- Check for generic renaming declaration case
- if Token = Tok_Package
- or else Token = Tok_Function
- or else Token = Tok_Procedure
- then
+ if Token in Tok_Package | Tok_Function | Tok_Procedure then
Ren_Token := Token;
Scan; -- scan past PACKAGE, FUNCTION or PROCEDURE
diff --git a/gcc/ada/par-ch13.adb b/gcc/ada/par-ch13.adb
index ca925d0..62e5807 100644
--- a/gcc/ada/par-ch13.adb
+++ b/gcc/ada/par-ch13.adb
@@ -336,7 +336,7 @@ package body Ch13 is
-- Check for a missing aspect definition. Aspects with optional
-- definitions are not considered.
- if Token = Tok_Comma or else Token = Tok_Semicolon then
+ if Token in Tok_Comma | Tok_Semicolon then
if not Opt then
Error_Msg_Node_1 := Identifier (Aspect);
Error_Msg_AP ("aspect& requires an aspect definition");
@@ -367,7 +367,7 @@ package body Ch13 is
-- aspect Depends, Global, Refined_Depends, Refined_Global
-- or Refined_State lacks enclosing parentheses.
- if Token /= Tok_Left_Paren and then Token /= Tok_Null then
+ if Token not in Tok_Left_Paren | Tok_Null then
-- [Refined_]Depends
@@ -571,7 +571,7 @@ package body Ch13 is
-- Attempt to detect ' or => following a potential aspect
-- mark.
- if Token = Tok_Apostrophe or else Token = Tok_Arrow then
+ if Token in Tok_Apostrophe | Tok_Arrow then
Restore_Scan_State (Scan_State);
Error_Msg_AP -- CODEFIX
("|missing "",""");
@@ -603,7 +603,7 @@ package body Ch13 is
-- Attempt to detect ' or => following potential aspect mark
- if Token = Tok_Apostrophe or else Token = Tok_Arrow then
+ if Token in Tok_Apostrophe | Tok_Arrow then
Restore_Scan_State (Scan_State);
Error_Msg_SC -- CODEFIX
("|"";"" should be "",""");
diff --git a/gcc/ada/par-ch3.adb b/gcc/ada/par-ch3.adb
index 82df4cf..5684839 100644
--- a/gcc/ada/par-ch3.adb
+++ b/gcc/ada/par-ch3.adb
@@ -145,10 +145,7 @@ package body Ch3 is
-- Here if := or something that we will take as equivalent
- elsif Token = Tok_Colon_Equal
- or else Token = Tok_Equal
- or else Token = Tok_Is
- then
+ elsif Token in Tok_Colon_Equal | Tok_Equal | Tok_Is then
null;
-- Another possibility. If we have a literal followed by a semicolon,
@@ -400,9 +397,7 @@ package body Ch3 is
-- Ada 2005 (AI-419): AARM 3.4 (2/2)
if (Ada_Version < Ada_2005 and then Token = Tok_Limited)
- or else Token = Tok_Private
- or else Token = Tok_Record
- or else Token = Tok_Null
+ or else Token in Tok_Private | Tok_Record | Tok_Null
then
Error_Msg_AP ("TAGGED expected");
end if;
@@ -610,7 +605,7 @@ package body Ch3 is
-- LIMITED RECORD or LIMITED NULL RECORD
- if Token = Tok_Record or else Token = Tok_Null then
+ if Token in Tok_Record | Tok_Null then
if Ada_Version = Ada_83 then
Error_Msg_SP
("(Ada 83) limited record declaration not allowed!");
@@ -1005,7 +1000,7 @@ package body Ch3 is
Type_Node : Node_Id;
begin
- if Token = Tok_Identifier or else Token = Tok_Operator_Symbol then
+ if Token in Tok_Identifier | Tok_Operator_Symbol then
Type_Node := P_Subtype_Mark;
return P_Subtype_Indication (Type_Node, Not_Null_Present);
@@ -2095,10 +2090,7 @@ package body Ch3 is
-- OK, not an aspect specification, so continue test for extension
- elsif Token = Tok_With
- or else Token = Tok_Record
- or else Token = Tok_Null
- then
+ elsif Token in Tok_With | Tok_Record | Tok_Null then
T_With; -- past WITH or give error message
if Token = Tok_Limited then
@@ -2279,7 +2271,7 @@ package body Ch3 is
-- Check for error of DIGITS or DELTA after a subtype mark
- elsif Token = Tok_Digits or else Token = Tok_Delta then
+ elsif Token in Tok_Digits | Tok_Delta then
Error_Msg_SC
("accuracy definition not allowed in membership test");
Scan; -- past DIGITS or DELTA
@@ -2850,7 +2842,7 @@ package body Ch3 is
Error_Msg_GNAT_Extension ("fixed-lower-bound array", Token_Ptr);
end if;
- exit when Token = Tok_Right_Paren or else Token = Tok_Of;
+ exit when Token in Tok_Right_Paren | Tok_Of;
T_Comma;
end loop;
@@ -2865,7 +2857,7 @@ package body Ch3 is
-- constrained_array_definition, which will be processed further below.
elsif Prev_Token = Tok_Range
- and then Token /= Tok_Right_Paren and then Token /= Tok_Comma
+ and then Token not in Tok_Right_Paren | Tok_Comma
then
-- If we have an expression followed by "..", then scan farther
-- and check for "<>" to see if we have a fixed-lower-bound range.
@@ -2920,7 +2912,7 @@ package body Ch3 is
("fixed-lower-bound array", Token_Ptr);
end if;
- exit when Token = Tok_Right_Paren or else Token = Tok_Of;
+ exit when Token in Tok_Right_Paren | Tok_Of;
T_Comma;
end loop;
@@ -3382,7 +3374,7 @@ package body Ch3 is
Save_Scan_State (Scan_State); -- at Id
Scan; -- past Id
- if Token = Tok_Arrow or else Token = Tok_Vertical_Bar then
+ if Token in Tok_Arrow | Tok_Vertical_Bar then
Restore_Scan_State (Scan_State); -- to Id
Append (P_Discriminant_Association, Constr_List);
goto Loop_Continue;
@@ -3644,7 +3636,7 @@ package body Ch3 is
-- If we have an END or WHEN now, everything is fine, otherwise we
-- complain about the null, ignore it, and scan for more components.
- if Token = Tok_End or else Token = Tok_When then
+ if Token in Tok_End | Tok_When then
Set_Null_Present (Component_List_Node, True);
return Component_List_Node;
else
@@ -3657,13 +3649,11 @@ package body Ch3 is
P_Pragmas_Opt (Decls_List);
if Token /= Tok_Case then
- Component_Scan_Loop : loop
+ loop
P_Component_Items (Decls_List);
P_Pragmas_Opt (Decls_List);
- exit Component_Scan_Loop when Token = Tok_End
- or else Token = Tok_Case
- or else Token = Tok_When;
+ exit when Token in Tok_End | Tok_Case | Tok_When;
-- We are done if we do not have an identifier. However, if we
-- have a misspelled reserved identifier that is in a column to
@@ -3679,7 +3669,7 @@ package body Ch3 is
Save_Scan_State (Scan_State); -- at reserved id
Scan; -- possible reserved id
- if Token = Tok_Comma or else Token = Tok_Colon then
+ if Token in Tok_Comma | Tok_Colon then
Restore_Scan_State (Scan_State);
Scan_Reserved_Identifier (Force_Msg => True);
@@ -3688,16 +3678,16 @@ package body Ch3 is
else
Restore_Scan_State (Scan_State);
- exit Component_Scan_Loop;
+ exit;
end if;
-- Non-identifier that definitely was not reserved id
else
- exit Component_Scan_Loop;
+ exit;
end if;
end if;
- end loop Component_Scan_Loop;
+ end loop;
end if;
if Token = Tok_Case then
@@ -3948,10 +3938,7 @@ package body Ch3 is
loop
P_Pragmas_Opt (Variants_List);
- if Token /= Tok_When
- and then Token /= Tok_If
- and then Token /= Tok_Others
- then
+ if Token not in Tok_When | Tok_If | Tok_Others then
exit when Check_End;
end if;
@@ -4267,14 +4254,12 @@ package body Ch3 is
Saved_State : Saved_Scan_State;
begin
- if Token = Tok_Identifier or else Token = Tok_Operator_Symbol then
+ if Token in Tok_Identifier | Tok_Operator_Symbol then
Save_Scan_State (Saved_State);
Scan; -- past possible junk subprogram name
- if Token = Tok_Left_Paren or else Token = Tok_Semicolon then
+ if Token in Tok_Left_Paren | Tok_Semicolon then
Error_Msg_SP ("unexpected subprogram name ignored");
- return;
-
else
Restore_Scan_State (Saved_State);
end if;
@@ -4327,7 +4312,7 @@ package body Ch3 is
if Prot_Flag then
Scan; -- past PROTECTED
- if Token /= Tok_Procedure and then Token /= Tok_Function then
+ if Token not in Tok_Procedure | Tok_Function then
Error_Msg_SC -- CODEFIX
("FUNCTION or PROCEDURE expected");
end if;
@@ -4402,7 +4387,7 @@ package body Ch3 is
Set_Null_Exclusion_Present (Type_Def_Node, Not_Null_Present);
Set_Null_Excluding_Subtype (Type_Def_Node, Not_Null_Subtype);
- if Token = Tok_All or else Token = Tok_Constant then
+ if Token in Tok_All | Tok_Constant then
if Ada_Version = Ada_83 then
Error_Msg_SC ("(Ada 83) access modifier not allowed!");
end if;
@@ -4472,10 +4457,7 @@ package body Ch3 is
-- Ada 2005 (AI-254): Access_To_Subprogram_Definition
- if Token = Tok_Protected
- or else Token = Tok_Procedure
- or else Token = Tok_Function
- then
+ if Token in Tok_Protected | Tok_Procedure | Tok_Function then
Error_Msg_Ada_2005_Extension ("access-to-subprogram");
Subp_Node := P_Access_Type_Definition (Header_Already_Parsed => True);
@@ -4629,7 +4611,6 @@ package body Ch3 is
end if;
Done := True;
- return;
else
Append (P_Representation_Clause, Decls);
end if;
@@ -4873,10 +4854,9 @@ package body Ch3 is
-- If reserved identifier not followed by colon or comma, then
-- this is most likely an assignment statement to the bad id.
- if Token /= Tok_Colon and then Token /= Tok_Comma then
+ if Token not in Tok_Colon | Tok_Comma then
Restore_Scan_State (Scan_State);
Statement_When_Declaration_Expected (Decls, Done, In_Spec);
- return;
-- Otherwise we have a declaration of the bad id
@@ -4892,7 +4872,6 @@ package body Ch3 is
else
Statement_When_Declaration_Expected (Decls, Done, In_Spec);
- return;
end if;
-- The token RETURN may well also signal a missing BEGIN situation,
@@ -4941,7 +4920,7 @@ package body Ch3 is
Save_Scan_State (Scan_State);
Scan; -- past the token
- if Token /= Tok_Colon and then Token /= Tok_Comma then
+ if Token not in Tok_Colon | Tok_Comma then
Restore_Scan_State (Scan_State);
Set_Declaration_Expected;
raise Error_Resync;
diff --git a/gcc/ada/par-ch4.adb b/gcc/ada/par-ch4.adb
index 9a00d7b..0dc6c8a 100644
--- a/gcc/ada/par-ch4.adb
+++ b/gcc/ada/par-ch4.adb
@@ -225,9 +225,7 @@ package body Ch4 is
-- If it looks like start of expression, complain and scan expression
- if Token in Token_Class_Literal
- or else Token = Tok_Left_Paren
- then
+ if Token in Token_Class_Literal | Tok_Left_Paren then
Error_Msg_SC ("name expected");
return P_Expression;
@@ -303,7 +301,7 @@ package body Ch4 is
-- The treatment for the range attribute is similar (we do not
-- consider x'range to be a name in this grammar).
- elsif Token = Tok_Left_Paren or else Token = Tok_Range then
+ elsif Token in Tok_Left_Paren | Tok_Range then
Restore_Scan_State (Scan_State); -- to apostrophe
Expr_Form := EF_Simple_Name;
return Name_Node;
@@ -334,446 +332,449 @@ package body Ch4 is
<<Scan_Name_Extension>>
- -- Character literal used as name cannot be extended. Also this
- -- cannot be a call, since the name for a call must be a designator.
- -- Return in these cases, or if there is no name extension
+ -- Character literal used as name cannot be extended. Also this
+ -- cannot be a call, since the name for a call must be a designator.
+ -- Return in these cases, or if there is no name extension
- if Token not in Token_Class_Namext
- or else Prev_Token = Tok_Char_Literal
- then
- Expr_Form := EF_Name;
- return Name_Node;
- end if;
+ if Token not in Token_Class_Namext
+ or else Prev_Token = Tok_Char_Literal
+ then
+ Expr_Form := EF_Name;
+ return Name_Node;
+ end if;
-- Merge here when we know there is a name extension
<<Scan_Name_Extension_OK>>
- if Token = Tok_Left_Paren then
+ case Token is
+ when Tok_Left_Paren =>
Scan; -- past left paren
goto Scan_Name_Extension_Left_Paren;
- elsif Token = Tok_Apostrophe then
+ when Tok_Apostrophe =>
Save_Scan_State (Scan_State); -- at apostrophe
Scan; -- past apostrophe
goto Scan_Name_Extension_Apostrophe;
- else -- Token = Tok_Dot
+ when Tok_Dot =>
Save_Scan_State (Scan_State); -- at dot
Scan; -- past dot
goto Scan_Name_Extension_Dot;
- end if;
+
+ when others => raise Program_Error;
+ end case;
-- Case of name extended by dot (selection), dot is already skipped
-- and the scan state at the point of the dot is saved in Scan_State.
<<Scan_Name_Extension_Dot>>
- -- Explicit dereference case
+ -- Explicit dereference case
- if Token = Tok_All then
- Prefix_Node := Name_Node;
- Name_Node := New_Node (N_Explicit_Dereference, Token_Ptr);
- Set_Prefix (Name_Node, Prefix_Node);
- Scan; -- past ALL
- goto Scan_Name_Extension;
+ if Token = Tok_All then
+ Prefix_Node := Name_Node;
+ Name_Node := New_Node (N_Explicit_Dereference, Token_Ptr);
+ Set_Prefix (Name_Node, Prefix_Node);
+ Scan; -- past ALL
+ goto Scan_Name_Extension;
-- Selected component case
- elsif Token in Token_Class_Name then
- Prefix_Node := Name_Node;
- Name_Node := New_Node (N_Selected_Component, Prev_Token_Ptr);
- Set_Prefix (Name_Node, Prefix_Node);
- Set_Selector_Name (Name_Node, Token_Node);
- Scan; -- past selector
- goto Scan_Name_Extension;
+ elsif Token in Token_Class_Name then
+ Prefix_Node := Name_Node;
+ Name_Node := New_Node (N_Selected_Component, Prev_Token_Ptr);
+ Set_Prefix (Name_Node, Prefix_Node);
+ Set_Selector_Name (Name_Node, Token_Node);
+ Scan; -- past selector
+ goto Scan_Name_Extension;
-- Reserved identifier as selector
- elsif Is_Reserved_Identifier then
- Scan_Reserved_Identifier (Force_Msg => False);
- Prefix_Node := Name_Node;
- Name_Node := New_Node (N_Selected_Component, Prev_Token_Ptr);
- Set_Prefix (Name_Node, Prefix_Node);
- Set_Selector_Name (Name_Node, Token_Node);
- Scan; -- past identifier used as selector
- goto Scan_Name_Extension;
+ elsif Is_Reserved_Identifier then
+ Scan_Reserved_Identifier (Force_Msg => False);
+ Prefix_Node := Name_Node;
+ Name_Node := New_Node (N_Selected_Component, Prev_Token_Ptr);
+ Set_Prefix (Name_Node, Prefix_Node);
+ Set_Selector_Name (Name_Node, Token_Node);
+ Scan; -- past identifier used as selector
+ goto Scan_Name_Extension;
-- If dot is at end of line and followed by nothing legal,
-- then assume end of name and quit (dot will be taken as
-- an incorrect form of some other punctuation by our caller).
- elsif Token_Is_At_Start_Of_Line then
- Restore_Scan_State (Scan_State);
- return Name_Node;
+ elsif Token_Is_At_Start_Of_Line then
+ Restore_Scan_State (Scan_State);
+ return Name_Node;
-- Here if nothing legal after the dot
- else
- Error_Msg_AP ("selector expected");
- raise Error_Resync;
- end if;
+ else
+ Error_Msg_AP ("selector expected");
+ raise Error_Resync;
+ end if;
-- Here for an apostrophe as name extension. The scan position at the
-- apostrophe has already been saved, and the apostrophe scanned out.
<<Scan_Name_Extension_Apostrophe>>
- Scan_Apostrophe : declare
- function Apostrophe_Should_Be_Semicolon return Boolean;
- -- Checks for case where apostrophe should probably be
- -- a semicolon, and if so, gives appropriate message,
- -- resets the scan pointer to the apostrophe, changes
- -- the current token to Tok_Semicolon, and returns True.
- -- Otherwise returns False.
-
- ------------------------------------
- -- Apostrophe_Should_Be_Semicolon --
- ------------------------------------
-
- function Apostrophe_Should_Be_Semicolon return Boolean is
- begin
- if Token_Is_At_Start_Of_Line then
- Restore_Scan_State (Scan_State); -- to apostrophe
- Error_Msg_SC ("|""''"" should be "";""");
- Token := Tok_Semicolon;
- return True;
- else
- return False;
- end if;
- end Apostrophe_Should_Be_Semicolon;
+ Scan_Apostrophe : declare
+ function Apostrophe_Should_Be_Semicolon return Boolean;
+ -- Checks for case where apostrophe should probably be
+ -- a semicolon, and if so, gives appropriate message,
+ -- resets the scan pointer to the apostrophe, changes
+ -- the current token to Tok_Semicolon, and returns True.
+ -- Otherwise returns False.
- -- Start of processing for Scan_Apostrophe
+ ------------------------------------
+ -- Apostrophe_Should_Be_Semicolon --
+ ------------------------------------
+ function Apostrophe_Should_Be_Semicolon return Boolean is
begin
- -- Check for qualified expression case in Ada 2012 mode
+ if Token_Is_At_Start_Of_Line then
+ Restore_Scan_State (Scan_State); -- to apostrophe
+ Error_Msg_SC ("|""''"" should be "";""");
+ Token := Tok_Semicolon;
+ return True;
+ else
+ return False;
+ end if;
+ end Apostrophe_Should_Be_Semicolon;
- if Ada_Version >= Ada_2012
- and then Token in Tok_Left_Paren | Tok_Left_Bracket
- then
- Name_Node := P_Qualified_Expression (Name_Node);
- goto Scan_Name_Extension;
+ -- Start of processing for Scan_Apostrophe
- -- If range attribute after apostrophe, then return with Token
- -- pointing to the apostrophe. Note that in this case the prefix
- -- need not be a simple name (cases like A.all'range). Similarly
- -- if there is a left paren after the apostrophe, then we also
- -- return with Token pointing to the apostrophe (this is the
- -- aggregate case, or some error case).
+ begin
+ -- Check for qualified expression case in Ada 2012 mode
- elsif Token = Tok_Range or else Token = Tok_Left_Paren then
- Restore_Scan_State (Scan_State); -- to apostrophe
- Expr_Form := EF_Name;
- return Name_Node;
+ if Ada_Version >= Ada_2012
+ and then Token in Tok_Left_Paren | Tok_Left_Bracket
+ then
+ Name_Node := P_Qualified_Expression (Name_Node);
+ goto Scan_Name_Extension;
- -- Here for cases where attribute designator is an identifier
+ -- If range attribute after apostrophe, then return with Token
+ -- pointing to the apostrophe. Note that in this case the prefix
+ -- need not be a simple name (cases like A.all'range). Similarly
+ -- if there is a left paren after the apostrophe, then we also
+ -- return with Token pointing to the apostrophe (this is the
+ -- aggregate case, or some error case).
- elsif Token = Tok_Identifier then
- Attr_Name := Token_Name;
+ elsif Token in Tok_Range | Tok_Left_Paren then
+ Restore_Scan_State (Scan_State); -- to apostrophe
+ Expr_Form := EF_Name;
+ return Name_Node;
- if not Is_Attribute_Name (Attr_Name) then
- if Apostrophe_Should_Be_Semicolon then
- Expr_Form := EF_Name;
- return Name_Node;
+ -- Here for cases where attribute designator is an identifier
- -- Here for a bad attribute name
+ elsif Token = Tok_Identifier then
+ Attr_Name := Token_Name;
- else
- Signal_Bad_Attribute;
- Scan; -- past bad identifier
+ if not Is_Attribute_Name (Attr_Name) then
+ if Apostrophe_Should_Be_Semicolon then
+ Expr_Form := EF_Name;
+ return Name_Node;
- if Token = Tok_Left_Paren then
- Scan; -- past left paren
+ -- Here for a bad attribute name
- loop
- Discard_Junk_Node (P_Expression_If_OK);
- exit when not Comma_Present;
- end loop;
+ else
+ Signal_Bad_Attribute;
+ Scan; -- past bad identifier
- T_Right_Paren;
- end if;
+ if Token = Tok_Left_Paren then
+ Scan; -- past left paren
- return Error;
+ loop
+ Discard_Junk_Node (P_Expression_If_OK);
+ exit when not Comma_Present;
+ end loop;
+
+ T_Right_Paren;
end if;
- end if;
- if Style_Check then
- Style.Check_Attribute_Name (False);
+ return Error;
end if;
+ end if;
- -- Here for case of attribute designator is not an identifier
+ if Style_Check then
+ Style.Check_Attribute_Name (False);
+ end if;
- else
- if Token = Tok_Delta then
- Attr_Name := Name_Delta;
+ -- Here for case of attribute designator is not an identifier
- elsif Token = Tok_Digits then
- Attr_Name := Name_Digits;
+ else
+ if Token = Tok_Delta then
+ Attr_Name := Name_Delta;
- elsif Token = Tok_Access then
- Attr_Name := Name_Access;
+ elsif Token = Tok_Digits then
+ Attr_Name := Name_Digits;
- elsif Token = Tok_Mod and then Ada_Version >= Ada_95 then
- Attr_Name := Name_Mod;
+ elsif Token = Tok_Access then
+ Attr_Name := Name_Access;
- elsif Apostrophe_Should_Be_Semicolon then
- Expr_Form := EF_Name;
- return Name_Node;
+ elsif Token = Tok_Mod and then Ada_Version >= Ada_95 then
+ Attr_Name := Name_Mod;
- else
- Error_Msg_AP ("attribute designator expected");
- raise Error_Resync;
- end if;
+ elsif Apostrophe_Should_Be_Semicolon then
+ Expr_Form := EF_Name;
+ return Name_Node;
- if Style_Check then
- Style.Check_Attribute_Name (True);
- end if;
+ else
+ Error_Msg_AP ("attribute designator expected");
+ raise Error_Resync;
end if;
- -- We come here with an OK attribute scanned, and corresponding
- -- Attribute identifier node stored in Ident_Node.
+ if Style_Check then
+ Style.Check_Attribute_Name (True);
+ end if;
+ end if;
- Prefix_Node := Name_Node;
- Name_Node := New_Node (N_Attribute_Reference, Prev_Token_Ptr);
- Scan; -- past attribute designator
- Set_Prefix (Name_Node, Prefix_Node);
- Set_Attribute_Name (Name_Node, Attr_Name);
+ -- We come here with an OK attribute scanned, and corresponding
+ -- Attribute identifier node stored in Ident_Node.
- -- Scan attribute arguments/designator. We skip this if we know
- -- that the attribute cannot have an argument (see documentation
- -- of Is_Parameterless_Attribute for further details).
+ Prefix_Node := Name_Node;
+ Name_Node := New_Node (N_Attribute_Reference, Prev_Token_Ptr);
+ Scan; -- past attribute designator
+ Set_Prefix (Name_Node, Prefix_Node);
+ Set_Attribute_Name (Name_Node, Attr_Name);
- if Token = Tok_Left_Paren
- and then not
- Is_Parameterless_Attribute (Get_Attribute_Id (Attr_Name))
- then
- -- Attribute Update contains an array or record association
- -- list which provides new values for various components or
- -- elements. The list is parsed as an aggregate, and we get
- -- better error handling by knowing that in the parser.
+ -- Scan attribute arguments/designator. We skip this if we know
+ -- that the attribute cannot have an argument (see documentation
+ -- of Is_Parameterless_Attribute for further details).
- if Attr_Name = Name_Update then
- Set_Expressions (Name_Node, New_List);
- Append (P_Aggregate, Expressions (Name_Node));
+ if Token = Tok_Left_Paren
+ and then not
+ Is_Parameterless_Attribute (Get_Attribute_Id (Attr_Name))
+ then
+ -- Attribute Update contains an array or record association
+ -- list which provides new values for various components or
+ -- elements. The list is parsed as an aggregate, and we get
+ -- better error handling by knowing that in the parser.
- -- All other cases of parsing attribute arguments
+ if Attr_Name = Name_Update then
+ Set_Expressions (Name_Node, New_List);
+ Append (P_Aggregate, Expressions (Name_Node));
- else
- Set_Expressions (Name_Node, New_List);
- Scan; -- past left paren
-
- loop
- declare
- Expr : constant Node_Id := P_Expression_If_OK;
- Rnam : Node_Id;
-
- begin
- -- Case of => for named notation
-
- if Token = Tok_Arrow then
-
- -- Named notation allowed only for the special
- -- case of System'Restriction_Set (No_Dependence =>
- -- unit_NAME), in which case construct a parameter
- -- assocation node and append to the arguments.
-
- if Attr_Name = Name_Restriction_Set
- and then Nkind (Expr) = N_Identifier
- and then Chars (Expr) = Name_No_Dependence
- then
- Scan; -- past arrow
- Rnam := P_Name;
- 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
- Error_Msg_SC
- ("named parameters not permitted "
- & "for attributes");
- Scan; -- past junk arrow
- end if;
-
- -- Here for normal case (not => for named parameter)
+ -- All other cases of parsing attribute arguments
+
+ else
+ Set_Expressions (Name_Node, New_List);
+ Scan; -- past left paren
+
+ loop
+ declare
+ Expr : constant Node_Id := P_Expression_If_OK;
+ Rnam : Node_Id;
+
+ begin
+ -- Case of => for named notation
+
+ if Token = Tok_Arrow then
+
+ -- Named notation allowed only for the special
+ -- case of System'Restriction_Set (No_Dependence =>
+ -- unit_NAME), in which case construct a parameter
+ -- assocation node and append to the arguments.
+
+ if Attr_Name = Name_Restriction_Set
+ and then Nkind (Expr) = N_Identifier
+ and then Chars (Expr) = Name_No_Dependence
+ then
+ Scan; -- past arrow
+ Rnam := P_Name;
+ 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
- -- Special handling for 'Image in Ada 2012, where
- -- the attribute can be parameterless and its value
- -- can be the prefix of a slice. Rewrite name as a
- -- slice, Expr is its low bound.
-
- if Token = Tok_Dot_Dot
- and then Attr_Name = Name_Image
- and then Ada_Version >= Ada_2012
- then
- Set_Expressions (Name_Node, No_List);
- Prefix_Node := Name_Node;
- Name_Node :=
- New_Node (N_Slice, Sloc (Prefix_Node));
- Set_Prefix (Name_Node, Prefix_Node);
- Range_Node := New_Node (N_Range, Token_Ptr);
- Set_Low_Bound (Range_Node, Expr);
- Scan; -- past ..
- Expr_Node := P_Expression;
- Check_Simple_Expression (Expr_Node);
- Set_High_Bound (Range_Node, Expr_Node);
- Set_Discrete_Range (Name_Node, Range_Node);
- T_Right_Paren;
-
- goto Scan_Name_Extension;
-
- else
- Append (Expr, Expressions (Name_Node));
- exit when not Comma_Present;
- end if;
+ Error_Msg_SC
+ ("named parameters not permitted "
+ & "for attributes");
+ Scan; -- past junk arrow
end if;
- end;
- end loop;
- T_Right_Paren;
- end if;
+ -- Here for normal case (not => for named parameter)
+
+ else
+ -- Special handling for 'Image in Ada 2012, where
+ -- the attribute can be parameterless and its value
+ -- can be the prefix of a slice. Rewrite name as a
+ -- slice, Expr is its low bound.
+
+ if Token = Tok_Dot_Dot
+ and then Attr_Name = Name_Image
+ and then Ada_Version >= Ada_2012
+ then
+ Set_Expressions (Name_Node, No_List);
+ Prefix_Node := Name_Node;
+ Name_Node :=
+ New_Node (N_Slice, Sloc (Prefix_Node));
+ Set_Prefix (Name_Node, Prefix_Node);
+ Range_Node := New_Node (N_Range, Token_Ptr);
+ Set_Low_Bound (Range_Node, Expr);
+ Scan; -- past ..
+ Expr_Node := P_Expression;
+ Check_Simple_Expression (Expr_Node);
+ Set_High_Bound (Range_Node, Expr_Node);
+ Set_Discrete_Range (Name_Node, Range_Node);
+ T_Right_Paren;
+
+ goto Scan_Name_Extension;
+
+ else
+ Append (Expr, Expressions (Name_Node));
+ exit when not Comma_Present;
+ end if;
+ end if;
+ end;
+ end loop;
+
+ T_Right_Paren;
end if;
+ end if;
- goto Scan_Name_Extension;
- end Scan_Apostrophe;
+ goto Scan_Name_Extension;
+ end Scan_Apostrophe;
-- Here for left parenthesis extending name (left paren skipped)
<<Scan_Name_Extension_Left_Paren>>
- -- We now have to scan through a list of items, terminated by a
- -- right parenthesis. The scan is handled by a finite state
- -- machine. The possibilities are:
+ -- We now have to scan through a list of items, terminated by a
+ -- right parenthesis. The scan is handled by a finite state
+ -- machine. The possibilities are:
- -- (discrete_range)
+ -- (discrete_range)
- -- This is a slice. This case is handled in LP_State_Init
+ -- This is a slice. This case is handled in LP_State_Init
- -- (expression, expression, ..)
+ -- (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 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.
- -- Note: if and case expressions (without an extra level of
- -- parentheses) are permitted in this context).
+ -- Note: if and case expressions (without an extra level of
+ -- parentheses) are permitted in this context).
- -- (..., identifier => expression , ...)
+ -- (..., identifier => expression , ...)
- -- If there is at least one occurrence of identifier => (but
- -- none of the other cases apply), then we have a call.
+ -- If there is at least one occurrence of identifier => (but
+ -- none of the other cases apply), then we have a call.
- -- Test for Id => case
+ -- Test for Id => case
- if Token = Tok_Identifier then
- Save_Scan_State (Scan_State); -- at Id
- Scan; -- past Id
+ if Token = Tok_Identifier then
+ Save_Scan_State (Scan_State); -- at Id
+ Scan; -- past Id
- -- Test for => (allow := as an error substitute)
+ -- Test for => (allow := as an error substitute)
- if Token = Tok_Arrow or else Token = Tok_Colon_Equal then
- Restore_Scan_State (Scan_State); -- to Id
- Arg_List := New_List;
- goto LP_State_Call;
+ if Token in Tok_Arrow | Tok_Colon_Equal then
+ Restore_Scan_State (Scan_State); -- to Id
+ Arg_List := New_List;
+ goto LP_State_Call;
- else
- Restore_Scan_State (Scan_State); -- to Id
- end if;
+ else
+ Restore_Scan_State (Scan_State); -- to Id
end if;
+ end if;
- -- Here we have an expression after all
-
- Expr_Node := P_Expression_Or_Range_Attribute_If_OK;
+ -- Here we have an expression after all
- -- Check cases of discrete range for a slice
+ Expr_Node := P_Expression_Or_Range_Attribute_If_OK;
- -- First possibility: Range_Attribute_Reference
+ -- Check cases of discrete range for a slice
- if Expr_Form = EF_Range_Attr then
- Range_Node := Expr_Node;
+ -- First possibility: Range_Attribute_Reference
- -- Second possibility: Simple_expression .. Simple_expression
+ if Expr_Form = EF_Range_Attr then
+ Range_Node := Expr_Node;
- elsif Token = Tok_Dot_Dot then
- Check_Simple_Expression (Expr_Node);
- Range_Node := New_Node (N_Range, Token_Ptr);
- Set_Low_Bound (Range_Node, Expr_Node);
- Scan; -- past ..
- Expr_Node := P_Expression;
- Check_Simple_Expression (Expr_Node);
- Set_High_Bound (Range_Node, Expr_Node);
+ -- Second possibility: Simple_expression .. Simple_expression
- -- Third possibility: Type_name range Range
+ elsif Token = Tok_Dot_Dot then
+ Check_Simple_Expression (Expr_Node);
+ Range_Node := New_Node (N_Range, Token_Ptr);
+ Set_Low_Bound (Range_Node, Expr_Node);
+ Scan; -- past ..
+ Expr_Node := P_Expression;
+ Check_Simple_Expression (Expr_Node);
+ Set_High_Bound (Range_Node, Expr_Node);
- elsif Token = Tok_Range then
- if Expr_Form /= EF_Simple_Name then
- Error_Msg_SC ("subtype mark must precede RANGE");
- raise Error_Resync;
- end if;
+ -- Third possibility: Type_name range Range
- Range_Node := P_Subtype_Indication (Expr_Node);
+ elsif Token = Tok_Range then
+ if Expr_Form /= EF_Simple_Name then
+ Error_Msg_SC ("subtype mark must precede RANGE");
+ raise Error_Resync;
+ end if;
- -- Otherwise we just have an expression. It is true that we might
- -- have a subtype mark without a range constraint but this case
- -- is syntactically indistinguishable from the expression case.
+ Range_Node := P_Subtype_Indication (Expr_Node);
- else
- Arg_List := New_List;
- goto LP_State_Expr;
- end if;
+ -- Otherwise we just have an expression. It is true that we might
+ -- have a subtype mark without a range constraint but this case
+ -- is syntactically indistinguishable from the expression case.
- -- Fall through here with unmistakable Discrete range scanned,
- -- which means that we definitely have the case of a slice. The
- -- Discrete range is in Range_Node.
+ else
+ Arg_List := New_List;
+ goto LP_State_Expr;
+ end if;
- if Token = Tok_Comma then
- Error_Msg_SC ("slice cannot have more than one dimension");
- raise Error_Resync;
+ -- Fall through here with unmistakable Discrete range scanned,
+ -- which means that we definitely have the case of a slice. The
+ -- Discrete range is in Range_Node.
- elsif Token /= Tok_Right_Paren then
- if Token = Tok_Arrow then
+ if Token = Tok_Comma then
+ Error_Msg_SC ("slice cannot have more than one dimension");
+ raise Error_Resync;
- -- This may be an aggregate that is missing a qualification
+ elsif Token /= Tok_Right_Paren then
+ if Token = Tok_Arrow then
- Error_Msg_SC
- ("context of aggregate must be a qualified expression");
- raise Error_Resync;
+ -- This may be an aggregate that is missing a qualification
- else
- T_Right_Paren;
- raise Error_Resync;
- end if;
+ Error_Msg_SC
+ ("context of aggregate must be a qualified expression");
+ raise Error_Resync;
else
- Scan; -- past right paren
- Prefix_Node := Name_Node;
- Name_Node := New_Node (N_Slice, Sloc (Prefix_Node));
- Set_Prefix (Name_Node, Prefix_Node);
- Set_Discrete_Range (Name_Node, Range_Node);
+ T_Right_Paren;
+ raise Error_Resync;
+ end if;
+
+ else
+ Scan; -- past right paren
+ Prefix_Node := Name_Node;
+ Name_Node := New_Node (N_Slice, Sloc (Prefix_Node));
+ Set_Prefix (Name_Node, Prefix_Node);
+ Set_Discrete_Range (Name_Node, Range_Node);
- -- An operator node is legal as a prefix to other names,
- -- but not for a slice.
+ -- An operator node is legal as a prefix to other names,
+ -- but not for a slice.
- if Nkind (Prefix_Node) = N_Operator_Symbol then
- Error_Msg_N ("illegal prefix for slice", Prefix_Node);
- end if;
+ if Nkind (Prefix_Node) = N_Operator_Symbol then
+ Error_Msg_N ("illegal prefix for slice", Prefix_Node);
+ end if;
- -- If we have a name extension, go scan it
+ -- If we have a name extension, go scan it
- if Token in Token_Class_Namext then
- goto Scan_Name_Extension_OK;
+ if Token in Token_Class_Namext then
+ goto Scan_Name_Extension_OK;
- -- Otherwise return (a slice is a name, but is not a call)
+ -- Otherwise return (a slice is a name, but is not a call)
- else
- Expr_Form := EF_Name;
- return Name_Node;
- end if;
+ else
+ Expr_Form := EF_Name;
+ return Name_Node;
end if;
+ end if;
-- In LP_State_Expr, we have scanned one or more expressions, and
-- so we have a call or an indexed component which is a name. On
@@ -781,48 +782,48 @@ package body Ch4 is
-- Arg_List contains the list of expressions encountered so far
<<LP_State_Expr>>
- Append (Expr_Node, Arg_List);
+ Append (Expr_Node, Arg_List);
- if Token = Tok_Arrow then
- Error_Msg
- ("expect identifier in parameter association", Sloc (Expr_Node));
- Scan; -- past arrow
+ if Token = Tok_Arrow then
+ Error_Msg
+ ("expect identifier in parameter association", Sloc (Expr_Node));
+ Scan; -- past arrow
- elsif not Comma_Present then
- T_Right_Paren;
+ elsif not Comma_Present then
+ T_Right_Paren;
- Prefix_Node := Name_Node;
- Name_Node := New_Node (N_Indexed_Component, Sloc (Prefix_Node));
- Set_Prefix (Name_Node, Prefix_Node);
- Set_Expressions (Name_Node, Arg_List);
+ Prefix_Node := Name_Node;
+ Name_Node := New_Node (N_Indexed_Component, Sloc (Prefix_Node));
+ Set_Prefix (Name_Node, Prefix_Node);
+ Set_Expressions (Name_Node, Arg_List);
- goto Scan_Name_Extension;
- end if;
+ goto Scan_Name_Extension;
+ end if;
- -- Comma present (and scanned out), test for identifier => case
- -- Test for identifier => case
+ -- Comma present (and scanned out), test for identifier => case
+ -- Test for identifier => case
- if Token = Tok_Identifier then
- Save_Scan_State (Scan_State); -- at Id
- Scan; -- past Id
+ if Token = Tok_Identifier then
+ Save_Scan_State (Scan_State); -- at Id
+ Scan; -- past Id
- -- Test for => (allow := as error substitute)
+ -- Test for => (allow := as error substitute)
- if Token = Tok_Arrow or else Token = Tok_Colon_Equal then
- Restore_Scan_State (Scan_State); -- to Id
- goto LP_State_Call;
+ if Token in Tok_Arrow | Tok_Colon_Equal then
+ Restore_Scan_State (Scan_State); -- to Id
+ goto LP_State_Call;
- -- Otherwise it's just an expression after all, so backup
+ -- Otherwise it's just an expression after all, so backup
- else
- Restore_Scan_State (Scan_State); -- to Id
- end if;
+ else
+ Restore_Scan_State (Scan_State); -- to Id
end if;
+ end if;
- -- Here we have an expression after all, so stay in this state
+ -- Here we have an expression after all, so stay in this state
- Expr_Node := P_Expression_If_OK;
- goto LP_State_Expr;
+ Expr_Node := P_Expression_If_OK;
+ goto LP_State_Expr;
-- LP_State_Call corresponds to the situation in which at least one
-- instance of Id => Expression has been encountered, so we know that
@@ -832,78 +833,78 @@ package body Ch4 is
<<LP_State_Call>>
- -- Test for case of Id => Expression (named parameter)
+ -- Test for case of Id => Expression (named parameter)
- if Token = Tok_Identifier then
- Save_Scan_State (Scan_State); -- at Id
- Ident_Node := Token_Node;
- Scan; -- past Id
+ if Token = Tok_Identifier then
+ Save_Scan_State (Scan_State); -- at Id
+ Ident_Node := Token_Node;
+ Scan; -- past Id
- -- Deal with => (allow := as incorrect substitute)
+ -- Deal with => (allow := as incorrect substitute)
- if Token = Tok_Arrow or else Token = Tok_Colon_Equal then
- Arg_Node := New_Node (N_Parameter_Association, Prev_Token_Ptr);
- Set_Selector_Name (Arg_Node, Ident_Node);
- T_Arrow;
- Set_Explicit_Actual_Parameter (Arg_Node, P_Expression);
- Append (Arg_Node, Arg_List);
+ if Token in Tok_Arrow | Tok_Colon_Equal then
+ Arg_Node := New_Node (N_Parameter_Association, Prev_Token_Ptr);
+ Set_Selector_Name (Arg_Node, Ident_Node);
+ T_Arrow;
+ Set_Explicit_Actual_Parameter (Arg_Node, P_Expression);
+ Append (Arg_Node, Arg_List);
- -- If a comma follows, go back and scan next entry
+ -- If a comma follows, go back and scan next entry
- if Comma_Present then
- goto LP_State_Call;
+ if Comma_Present then
+ goto LP_State_Call;
- -- Otherwise we have the end of a call
+ -- Otherwise we have the end of a call
- else
- Prefix_Node := Name_Node;
- Name_Node := New_Node (N_Function_Call, Sloc (Prefix_Node));
- Set_Name (Name_Node, Prefix_Node);
- Set_Parameter_Associations (Name_Node, Arg_List);
- T_Right_Paren;
+ else
+ Prefix_Node := Name_Node;
+ Name_Node := New_Node (N_Function_Call, Sloc (Prefix_Node));
+ Set_Name (Name_Node, Prefix_Node);
+ Set_Parameter_Associations (Name_Node, Arg_List);
+ T_Right_Paren;
- if Token in Token_Class_Namext then
- goto Scan_Name_Extension_OK;
+ if Token in Token_Class_Namext then
+ goto Scan_Name_Extension_OK;
- -- This is a case of a call which cannot be a name
+ -- This is a case of a call which cannot be a name
- else
- Expr_Form := EF_Name;
- return Name_Node;
- end if;
+ else
+ Expr_Form := EF_Name;
+ return Name_Node;
end if;
+ end if;
- -- Not named parameter: Id started an expression after all
+ -- Not named parameter: Id started an expression after all
- else
- Restore_Scan_State (Scan_State); -- to Id
- end if;
+ else
+ Restore_Scan_State (Scan_State); -- to Id
end if;
+ end if;
- -- Here if entry did not start with Id => which means that it
- -- is a positional parameter, which is not allowed, since we
- -- have seen at least one named parameter already.
+ -- Here if entry did not start with Id => which means that it
+ -- is a positional parameter, which is not allowed, since we
+ -- have seen at least one named parameter already.
- Error_Msg_SC
- ("positional parameter association " &
- "not allowed after named one");
+ Error_Msg_SC
+ ("positional parameter association " &
+ "not allowed after named one");
- Expr_Node := P_Expression_If_OK;
+ Expr_Node := P_Expression_If_OK;
- -- Leaving the '>' in an association is not unusual, so suggest
- -- a possible fix.
+ -- Leaving the '>' in an association is not unusual, so suggest
+ -- a possible fix.
- if Nkind (Expr_Node) = N_Op_Eq then
- Error_Msg_N ("\maybe `='>` was intended", Expr_Node);
- end if;
+ if Nkind (Expr_Node) = N_Op_Eq then
+ Error_Msg_N ("\maybe `='>` was intended", Expr_Node);
+ end if;
- -- We go back to scanning out expressions, so that we do not get
- -- multiple error messages when several positional parameters
- -- follow a named parameter.
+ -- We go back to scanning out expressions, so that we do not get
+ -- multiple error messages when several positional parameters
+ -- follow a named parameter.
- goto LP_State_Expr;
+ goto LP_State_Expr;
- -- End of treatment for name extensions starting with left paren
+ -- End of treatment for name extensions starting with left paren
-- End of loop through name extensions
@@ -1384,7 +1385,7 @@ package body Ch4 is
begin
Save_Scan_State (Scan_State);
Scan; -- past FOR
- Maybe := Token = Tok_All or else Token = Tok_Some;
+ Maybe := Token in Tok_All | Tok_Some;
Restore_Scan_State (Scan_State); -- to FOR
return Maybe;
end Is_Quantified_Expression;
@@ -1609,11 +1610,8 @@ package body Ch4 is
then
Append_New (Expr_Node, Assoc_List);
- elsif Token = Tok_Comma
- or else Token = Tok_Right_Paren
- or else Token = Tok_Others
- or else Token in Token_Class_Lit_Or_Name
- or else Token = Tok_Semicolon
+ elsif Token in Tok_Comma | Tok_Right_Paren | Tok_Others
+ | Token_Class_Lit_Or_Name | Tok_Semicolon
then
if Present (Assoc_List) then
Error_Msg_BC -- CODEFIX
@@ -1945,7 +1943,7 @@ package body Ch4 is
-- Check for case of errant comma or semicolon
- if Token = Tok_Comma or else Token = Tok_Semicolon then
+ if Token in Tok_Comma | Tok_Semicolon then
declare
Com : constant Boolean := Token = Tok_Comma;
Scan_State : Saved_Scan_State;
@@ -1959,7 +1957,7 @@ package body Ch4 is
-- do not deal with AND/OR because those cases get mixed up
-- with the select alternatives case.
- if Token = Tok_And or else Token = Tok_Or then
+ if Token in Tok_And | Tok_Or then
Logop := P_Logical_Operator;
Restore_Scan_State (Scan_State); -- to comma/semicolon
@@ -2008,11 +2006,7 @@ package body Ch4 is
begin
-- Case of conditional, case or quantified expression
- if Token = Tok_Case
- or else Token = Tok_If
- or else Token = Tok_For
- or else Token = Tok_Declare
- then
+ if Token in Tok_Case | Tok_If | Tok_For | Tok_Declare then
return P_Unparen_Cond_Expr_Etc;
-- Normal case, not case/conditional/quantified expression
@@ -2121,11 +2115,7 @@ package body Ch4 is
begin
-- Case of conditional, case or quantified expression
- if Token = Tok_Case
- or else Token = Tok_If
- or else Token = Tok_For
- or else Token = Tok_Declare
- then
+ if Token in Tok_Case | Tok_If | Tok_For | Tok_Declare then
return P_Unparen_Cond_Expr_Etc;
-- Normal case, not one of the above expression types
@@ -2967,7 +2957,7 @@ package body Ch4 is
Save_Scan_State (Scan_State);
Scan; -- past FOR
- if Token = Tok_All or else Token = Tok_Some then
+ if Token in Tok_All | Tok_Some then
Restore_Scan_State (Scan_State); -- To FOR
Node1 := P_Quantified_Expression;
@@ -3638,7 +3628,7 @@ package body Ch4 is
Save_Scan_State (State);
Scan; -- past semicolon
- if Token = Tok_Else or else Token = Tok_Elsif then
+ if Token in Tok_Else | Tok_Elsif then
Error_Msg_SP -- CODEFIX
("|extra "";"" ignored");
@@ -3837,7 +3827,7 @@ package body Ch4 is
Save_Scan_State (Scan_State);
Scan; -- past FOR
- if Token = Tok_All or else Token = Tok_Some then
+ if Token in Tok_All | Tok_Some then
Restore_Scan_State (Scan_State);
Result := P_Quantified_Expression;
diff --git a/gcc/ada/par-ch5.adb b/gcc/ada/par-ch5.adb
index 1be3ef8..60b52bf 100644
--- a/gcc/ada/par-ch5.adb
+++ b/gcc/ada/par-ch5.adb
@@ -103,21 +103,11 @@ package body Ch5 is
-- | LOOP_STATEMENT | BLOCK_STATEMENT
-- | ACCEPT_STATEMENT | SELECT_STATEMENT
- -- This procedure scans a sequence of statements. The caller sets SS_Flags
- -- to indicate acceptable termination conditions for the sequence:
-
- -- SS_Flags.Eftm Terminate on ELSIF
- -- SS_Flags.Eltm Terminate on ELSE
- -- SS_Flags.Extm Terminate on EXCEPTION
- -- SS_Flags.Ortm Terminate on OR
- -- SS_Flags.Tatm Terminate on THEN ABORT (Token = ABORT on return)
- -- SS_Flags.Whtm Terminate on WHEN
- -- SS_Flags.Unco Unconditional terminate after scanning one statement
-
- -- In addition, the scan is always terminated by encountering END or the
- -- end of file (EOF) condition. If one of the six above terminators is
- -- encountered with the corresponding SS_Flags flag not set, then the
- -- action taken is as follows:
+ -- This procedure scans a sequence of statements. SS_Flags indicates
+ -- termination conditions for the sequence. In addition, the sequence is
+ -- always terminated by encountering END or end of file. If one of the six
+ -- above terminators is encountered with the corresponding SS_Flags flag
+ -- not set, then the action taken is as follows:
-- If the keyword occurs to the left of the expected column of the end
-- for the current sequence (as recorded in the current end context),
@@ -131,7 +121,8 @@ package body Ch5 is
-- Note that the first action means that control can return to the caller
-- with Token set to a terminator other than one of those specified by the
- -- SS parameter. The caller should treat such a case as equivalent to END.
+ -- SS_Flags parameter. The caller should treat such a case as equivalent to
+ -- END.
-- In addition, the flag SS_Flags.Sreq is set to True to indicate that at
-- least one real statement (other than a pragma) is required in the
@@ -147,14 +138,14 @@ package body Ch5 is
function P_Sequence_Of_Statements
(SS_Flags : SS_Rec; Handled : Boolean := False) return List_Id
is
- Statement_Required : Boolean;
+ Statement_Required : Boolean := SS_Flags.Sreq;
-- This flag indicates if a subsequent statement (other than a pragma)
-- is required. It is initialized from the Sreq flag, and modified as
-- statements are scanned (a statement turns it off, and a label turns
-- it back on again since a statement must follow a label).
-- Note : this final requirement is lifted in Ada 2012.
- Statement_Seen : Boolean;
+ Statement_Seen : Boolean := False;
-- In Ada 2012, a label can end a sequence of statements, but the
-- sequence cannot contain only labels. This flag is set whenever a
-- label is encountered, to enforce this rule at the end of a sequence.
@@ -162,7 +153,7 @@ package body Ch5 is
Scan_State_Label : Saved_Scan_State;
Scan_State : Saved_Scan_State;
- Statement_List : List_Id;
+ Statement_List : constant List_Id := New_List;
Block_Label : Name_Id;
Id_Node : Node_Id;
Name_Node : Node_Id;
@@ -215,13 +206,7 @@ package body Ch5 is
and then Statement_Seen)
or else All_Pragmas)
then
- declare
- Null_Stm : constant Node_Id :=
- Make_Null_Statement (Token_Ptr);
- begin
- Set_Comes_From_Source (Null_Stm, False);
- Append_To (Statement_List, Null_Stm);
- end;
+ null;
-- If not Ada 2012, or not special case above, and no declaration
-- seen (as allowed in Ada 2020), give error message.
@@ -236,10 +221,6 @@ package body Ch5 is
-- Start of processing for P_Sequence_Of_Statements
begin
- Statement_List := New_List;
- Statement_Required := SS_Flags.Sreq;
- Statement_Seen := False;
-
-- In Ada 2022, we allow declarative items to be mixed with
-- statements. The loop below alternates between calling
-- P_Declarative_Items to parse zero or more declarative items,
@@ -270,7 +251,7 @@ package body Ch5 is
end if;
end;
- begin
+ begin -- handle Error_Resync
if Style_Check then
Style.Check_Indentation;
end if;
@@ -290,18 +271,13 @@ package body Ch5 is
-- with the exception of the cases tested for below.
(Token = Tok_Semicolon
- and then Prev_Token /= Tok_Return
- and then Prev_Token /= Tok_Null
- and then Prev_Token /= Tok_Raise
- and then Prev_Token /= Tok_End
- and then Prev_Token /= Tok_Exit)
+ and then Prev_Token not in
+ Tok_Return | Tok_Null | Tok_Raise | Tok_End | Tok_Exit)
-- If followed by colon, colon-equal, or dot, then we
-- definitely have an identifier (could not be reserved)
- or else Token = Tok_Colon
- or else Token = Tok_Colon_Equal
- or else Token = Tok_Dot
+ or else Token in Tok_Colon | Tok_Colon_Equal | Tok_Dot
-- Left paren means we have an identifier except for those
-- reserved words that can legitimately be followed by a
@@ -309,14 +285,9 @@ package body Ch5 is
or else
(Token = Tok_Left_Paren
- and then Prev_Token /= Tok_Case
- and then Prev_Token /= Tok_Delay
- and then Prev_Token /= Tok_If
- and then Prev_Token /= Tok_Elsif
- and then Prev_Token /= Tok_Return
- and then Prev_Token /= Tok_When
- and then Prev_Token /= Tok_While
- and then Prev_Token /= Tok_Separate)
+ and then Prev_Token not in
+ Tok_Case | Tok_Delay | Tok_If | Tok_Elsif | Tok_Return |
+ Tok_When | Tok_While | Tok_Separate)
then
-- Here we have an apparent reserved identifier and the
-- token past it is appropriate to this usage (and would
@@ -704,11 +675,12 @@ package body Ch5 is
-- instance of an incorrectly spelled keyword. If so, we
-- do nothing. The Bad_Spelling_Of will have reset Token
-- to the appropriate keyword, so the next time round the
- -- loop we will process the modified token. Note that we
- -- check for ELSIF before ELSE here. That's not accidental.
- -- We don't want to identify a misspelling of ELSE as
- -- ELSIF, and in particular we do not want to treat ELSEIF
- -- as ELSE IF.
+ -- loop we will process the modified token.
+ --
+ -- Note that we check for ELSIF before ELSE here, because
+ -- we don't want to identify a misspelling of ELSE as ELSIF,
+ -- and in particular we do not want to treat ELSEIF as
+ -- ELSE IF.
else
Restore_Scan_State (Scan_State_Label); -- to identifier
@@ -1452,7 +1424,7 @@ package body Ch5 is
-- If we have a WHEN or OTHERS, then that's fine keep going. Note
-- that it is a semantic check to ensure the proper use of OTHERS
- if Token = Tok_When or else Token = Tok_Others then
+ if Token in Tok_When | Tok_Others then
Append (P_Case_Statement_Alternative, Alternatives_List);
-- If we have an END, then probably we are at the end of the case
@@ -1764,7 +1736,7 @@ package body Ch5 is
-- expression it is an iterator specification. Ambiguity is resolved
-- during analysis of the loop parameter specification.
- if Token = Tok_Of or else Token = Tok_Colon then
+ if Token in Tok_Of | Tok_Colon then
Error_Msg_Ada_2012_Feature ("iterator", Token_Ptr);
return P_Iterator_Specification (ID_Node);
end if;
@@ -2272,9 +2244,7 @@ package body Ch5 is
-- END, EOF, or a token which starts declarations.
elsif Parent_Nkind = N_Package_Body
- and then (Token = Tok_End
- or else Token = Tok_EOF
- or else Token in Token_Class_Declk)
+ and then (Token in Tok_End | Tok_EOF | Token_Class_Declk)
then
Set_Null_HSS (Parent);
@@ -2384,7 +2354,7 @@ package body Ch5 is
TF_Then;
end loop;
- if Token = Tok_And or else Token = Tok_Or then
+ if Token in Tok_And | Tok_Or then
Error_Msg_SC ("unexpected logical operator");
Scan; -- past logical operator
diff --git a/gcc/ada/par-ch6.adb b/gcc/ada/par-ch6.adb
index 95fa937..4f06297 100644
--- a/gcc/ada/par-ch6.adb
+++ b/gcc/ada/par-ch6.adb
@@ -180,21 +180,6 @@ package body Ch6 is
-- FUNCTION SPECIFICATION IS (EXPRESSION)
-- [ASPECT_SPECIFICATIONS];
- -- The value in Pf_Flags indicates which of these possible declarations
- -- is acceptable to the caller:
-
- -- Pf_Flags.Decl Set if declaration OK
- -- Pf_Flags.Gins Set if generic instantiation OK
- -- Pf_Flags.Pbod Set if proper body OK
- -- Pf_Flags.Rnam Set if renaming declaration OK
- -- Pf_Flags.Stub Set if body stub OK
- -- Pf_Flags.Pexp Set if expression function OK
-
- -- If an inappropriate form is encountered, it is scanned out but an
- -- error message indicating that it is appearing in an inappropriate
- -- context is issued. The only possible values for Pf_Flags are those
- -- defined as constants in the Par package.
-
-- The caller has checked that the initial token is FUNCTION, PROCEDURE,
-- NOT or OVERRIDING.
@@ -316,7 +301,7 @@ package body Ch6 is
then
Error_Msg_SC ("overriding indicator not allowed here!");
- elsif Token /= Tok_Function and then Token /= Tok_Procedure then
+ elsif Token not in Tok_Function | Tok_Procedure then
Error_Msg_SC -- CODEFIX
("FUNCTION or PROCEDURE expected!");
end if;
@@ -737,22 +722,15 @@ package body Ch6 is
-- or a pragma, then we definitely have a subprogram body.
-- This is a common case, so worth testing first.
- if Token = Tok_Begin
- or else Token in Token_Class_Declk
- or else Token = Tok_Pragma
- then
+ if Token in Tok_Begin | Token_Class_Declk | Tok_Pragma then
return False;
-- Test for tokens which could only start an expression and
-- thus signal the case of a expression function.
- elsif Token in Token_Class_Literal
- or else Token in Token_Class_Unary_Addop
- or else Token = Tok_Left_Paren
- or else Token = Tok_Abs
- or else Token = Tok_Null
- or else Token = Tok_New
- or else Token = Tok_Not
+ elsif Token in
+ Token_Class_Literal | Token_Class_Unary_Addop |
+ Tok_Left_Paren | Tok_Abs | Tok_Null | Tok_New | Tok_Not
then
null;
@@ -1161,9 +1139,8 @@ package body Ch6 is
Save_Scan_State (Scan_State);
Scan; -- past dot
- if Token = Tok_Identifier
- or else Token = Tok_Operator_Symbol
- or else Token = Tok_String_Literal
+ if Token in
+ Tok_Identifier | Tok_Operator_Symbol | Tok_String_Literal
then
return True;
@@ -1180,8 +1157,7 @@ package body Ch6 is
Ident_Node := Token_Node;
Scan; -- past initial token
- if Prev_Token = Tok_Operator_Symbol
- or else Prev_Token = Tok_String_Literal
+ if Prev_Token in Tok_Operator_Symbol | Tok_String_Literal
or else not Real_Dot
then
return Ident_Node;
@@ -1216,7 +1192,7 @@ package body Ch6 is
exception
when Error_Resync =>
- while Token = Tok_Dot or else Token = Tok_Identifier loop
+ while Token in Tok_Dot | Tok_Identifier loop
Scan;
end loop;
@@ -1327,7 +1303,7 @@ package body Ch6 is
exception
when Error_Resync =>
- while Token = Tok_Dot or else Token = Tok_Identifier loop
+ while Token in Tok_Dot | Tok_Identifier loop
Scan;
end loop;
@@ -1462,10 +1438,8 @@ package body Ch6 is
-- and on a right paren, e.g. Parms (X Y), and also
-- on an assignment symbol, e.g. Parms (X Y := ..)
- if Token = Tok_Semicolon
- or else Token = Tok_Right_Paren
- or else Token = Tok_EOF
- or else Token = Tok_Colon_Equal
+ if Token in Tok_Semicolon | Tok_Right_Paren |
+ Tok_EOF | Tok_Colon_Equal
then
Restore_Scan_State (Scan_State);
exit Ident_Loop;
@@ -1474,9 +1448,7 @@ package body Ch6 is
-- comma, e.g. Parms (A B : ...). Also assume a missing
-- comma if we hit another comma, e.g. Parms (A B, C ..)
- elsif Token = Tok_Colon
- or else Token = Tok_Comma
- then
+ elsif Token in Tok_Colon | Tok_Comma then
Restore_Scan_State (Scan_State);
exit Look_Ahead;
end if;
@@ -1551,7 +1523,7 @@ package body Ch6 is
-- Case of IN or OUT present
else
- if Token = Tok_In or else Token = Tok_Out then
+ if Token in Tok_In | Tok_Out then
if Not_Null_Present then
Error_Msg
("`NOT NULL` can only be used with `ACCESS`",
@@ -1627,7 +1599,7 @@ package body Ch6 is
-- If we have RETURN or IS after the semicolon, then assume
-- that semicolon should have been a right parenthesis and exit
- if Token = Tok_Is or else Token = Tok_Return then
+ if Token in Tok_Is | Tok_Return then
Error_Msg_SP -- CODEFIX
("|"";"" should be "")""");
exit Specification_Loop;
diff --git a/gcc/ada/par-ch7.adb b/gcc/ada/par-ch7.adb
index 71046e2..07c910a 100644
--- a/gcc/ada/par-ch7.adb
+++ b/gcc/ada/par-ch7.adb
@@ -71,21 +71,6 @@ package body Ch7 is
-- new generic_package_NAME [GENERIC_ACTUAL_PART]
-- [ASPECT_SPECIFICATIONS];
- -- The value in Pf_Flags indicates which of these possible declarations
- -- is acceptable to the caller:
-
- -- Pf_Flags.Spcn Set if specification OK
- -- Pf_Flags.Decl Set if declaration OK
- -- Pf_Flags.Gins Set if generic instantiation OK
- -- Pf_Flags.Pbod Set if proper body OK
- -- Pf_Flags.Rnam Set if renaming declaration OK
- -- Pf_Flags.Stub Set if body stub OK
-
- -- If an inappropriate form is encountered, it is scanned out but an error
- -- message indicating that it is appearing in an inappropriate context is
- -- issued. The only possible settings for Pf_Flags are those defined as
- -- constants in package Par.
-
-- Note: in all contexts where a package specification is required, there
-- is a terminating semicolon. This semicolon is scanned out in the case
-- where Pf_Flags is set to Pf_Spcn, even though it is not strictly part
diff --git a/gcc/ada/par-ch8.adb b/gcc/ada/par-ch8.adb
index 67dce14..6e9139c 100644
--- a/gcc/ada/par-ch8.adb
+++ b/gcc/ada/par-ch8.adb
@@ -94,7 +94,7 @@ package body Ch8 is
begin
Scan; -- past USE
- if Token = Tok_Type or else Token = Tok_All then
+ if Token in Tok_Type | Tok_All then
P_Use_Type_Clause (Item_List);
else
P_Use_Package_Clause (Item_List);
diff --git a/gcc/ada/par-ch9.adb b/gcc/ada/par-ch9.adb
index 7d4ea62..310494e 100644
--- a/gcc/ada/par-ch9.adb
+++ b/gcc/ada/par-ch9.adb
@@ -343,10 +343,7 @@ package body Ch9 is
-- Ada 2005 (AI-397): Reserved words NOT and OVERRIDING may begin an
-- entry declaration.
- elsif Token = Tok_Entry
- or else Token = Tok_Not
- or else Token = Tok_Overriding
- then
+ elsif Token in Tok_Entry | Tok_Not | Tok_Overriding then
Append (P_Entry_Declaration, Items);
elsif Token = Tok_For then
@@ -760,7 +757,7 @@ package body Ch9 is
Set_Must_Override (Decl, Is_Overriding);
Set_Must_Not_Override (Decl, Not_Overriding);
- elsif Token = Tok_Function or else Token = Tok_Procedure then
+ elsif Token in Tok_Function | Tok_Procedure then
Decl := P_Subprogram (Pf_Decl_Pexp);
Set_Must_Override (Specification (Decl), Is_Overriding);
@@ -987,7 +984,7 @@ package body Ch9 is
-- If comma or colon after Id, must be Formal_Part
- if Token = Tok_Comma or else Token = Tok_Colon then
+ if Token in Tok_Comma | Tok_Colon then
Restore_Scan_State (Scan_State); -- to Id
Set_Parameter_Specifications (Decl_Node, P_Formal_Part);
@@ -1095,7 +1092,7 @@ package body Ch9 is
-- If identifier followed by comma or colon, must be Formal_Part
- if Token = Tok_Comma or else Token = Tok_Colon then
+ if Token in Tok_Comma | Tok_Colon then
Restore_Scan_State (Scan_State); -- to left paren
Set_Parameter_Specifications (Accept_Node, P_Parameter_Profile);
diff --git a/gcc/ada/par-endh.adb b/gcc/ada/par-endh.adb
index 212d451..15b21cd 100644
--- a/gcc/ada/par-endh.adb
+++ b/gcc/ada/par-endh.adb
@@ -242,7 +242,7 @@ package body Endh is
-- FOR or WHILE allowed (signalling error) to substitute for LOOP
-- if on the same line as the END.
- elsif (Token = Tok_For or else Token = Tok_While)
+ elsif Token in Tok_For | Tok_While
and then not Token_Is_At_Start_Of_Line
then
Scan; -- past FOR or WHILE
@@ -445,8 +445,7 @@ package body Endh is
-- incorrect. Same thing for a period in place of a semicolon.
elsif Token_Is_At_Start_Of_Line
- or else Token = Tok_Colon
- or else Token = Tok_Dot
+ or else Token in Tok_Colon | Tok_Dot
then
T_Semicolon;
@@ -480,10 +479,8 @@ package body Endh is
-- on the same line as the END
while not Token_Is_At_Start_Of_Line
- and then Prev_Token /= Tok_Record
- and then Prev_Token /= Tok_Semicolon
- and then Token /= Tok_End
- and then Token /= Tok_EOF
+ and then Prev_Token not in Tok_Record | Tok_Semicolon
+ and then Token not in Tok_End | Tok_EOF
loop
Scan; -- past junk
end loop;
@@ -625,9 +622,8 @@ package body Endh is
return;
end if;
- if Token /= Tok_Identifier
- and then Token /= Tok_Operator_Symbol
- and then Token /= Tok_String_Literal
+ if Token not in
+ Tok_Identifier | Tok_Operator_Symbol | Tok_String_Literal
then
exit;
end if;
@@ -655,9 +651,7 @@ package body Endh is
-- if there is no line end at the end of the last line of the file)
else
- while Token /= Tok_End
- and then Token /= Tok_EOF
- and then Token /= Tok_Semicolon
+ while Token not in Tok_End | Tok_EOF | Tok_Semicolon
and then not Token_Is_At_Start_Of_Line
loop
Scan; -- past junk token on same line
@@ -1157,9 +1151,7 @@ package body Endh is
Scan; -- past END
- if Token = Tok_Identifier
- or else Token = Tok_Operator_Symbol
- then
+ if Token in Tok_Identifier | Tok_Operator_Symbol then
Nxt_Labl := P_Designator;
-- We only consider it an error if the label is a match
diff --git a/gcc/ada/par-sync.adb b/gcc/ada/par-sync.adb
index 7a3da8e..570d229 100644
--- a/gcc/ada/par-sync.adb
+++ b/gcc/ada/par-sync.adb
@@ -58,9 +58,7 @@ package body Sync is
begin
Resync_Init;
- while Token not in Token_Class_Cunit
- and then Token /= Tok_EOF
- loop
+ while Token not in Token_Class_Cunit | Tok_EOF loop
Scan;
end loop;
@@ -92,9 +90,7 @@ package body Sync is
or else (Paren_Count = 0
and then
- (Token = Tok_Comma
- or else Token = Tok_Right_Paren
- or else Token = Tok_Vertical_Bar))
+ Token in Tok_Comma | Tok_Right_Paren | Tok_Vertical_Bar)
then
-- A special check: if we stop on the ELSE of OR ELSE or the
-- THEN of AND THEN, keep going, because this is not really an
@@ -232,7 +228,7 @@ package body Sync is
-- in this category only if it does NOT appear after WITH.
elsif Token in Token_Class_After_SM
- and then (Token /= Tok_Private or else Prev_Token /= Tok_With)
+ and then (Token /= Tok_Private or else Prev_Token /= Tok_With)
then
exit;
@@ -274,7 +270,7 @@ package body Sync is
-- Done if we are at THEN or LOOP
- elsif Token = Tok_Then or else Token = Tok_Loop then
+ elsif Token in Tok_Then | Tok_Loop then
exit;
-- Otherwise keep going
@@ -316,10 +312,7 @@ package body Sync is
Paren_Count := 0;
loop
- if Token = Tok_EOF
- or else Token = Tok_Semicolon
- or else Token = Tok_Is
- or else Token in Token_Class_After_SM
+ if Token in Tok_EOF | Tok_Semicolon | Tok_Is | Token_Class_After_SM
then
exit;
@@ -386,10 +379,7 @@ package body Sync is
loop
-- Done if at semicolon, WHEN or IS
- if Token = Tok_Semicolon
- or else Token = Tok_When
- or else Token = Tok_Is
- then
+ if Token in Tok_Semicolon | Tok_When | Tok_Is then
exit;
-- Otherwise keep going
diff --git a/gcc/ada/par-tchk.adb b/gcc/ada/par-tchk.adb
index 6a62d70..3989cd2 100644
--- a/gcc/ada/par-tchk.adb
+++ b/gcc/ada/par-tchk.adb
@@ -567,8 +567,7 @@ package body Tchk is
loop
if Prev_Token_Ptr < Current_Line_Start
- or else Token = Tok_Semicolon
- or else Token = Tok_EOF
+ or else Token in Tok_Semicolon | Tok_EOF
then
Restore_Scan_State (Scan_State); -- to where we were
return;
@@ -597,10 +596,7 @@ package body Tchk is
-- Allow OF or => or = in place of IS (with error message)
- elsif Token = Tok_Of
- or else Token = Tok_Arrow
- or else Token = Tok_Equal
- then
+ elsif Token in Tok_Of | Tok_Arrow | Tok_Equal then
T_Is; -- give missing IS message and skip bad token
else
@@ -609,8 +605,7 @@ package body Tchk is
loop
if Prev_Token_Ptr < Current_Line_Start
- or else Token = Tok_Semicolon
- or else Token = Tok_EOF
+ or else Token in Tok_Semicolon | Tok_EOF
then
Restore_Scan_State (Scan_State); -- to where we were
return;
@@ -618,10 +613,7 @@ package body Tchk is
Scan; -- continue search
- if Token = Tok_Is
- or else Token = Tok_Of
- or else Token = Tok_Arrow
- then
+ if Token in Tok_Is | Tok_Of | Tok_Arrow then
Scan; -- past IS or OF or =>
return;
end if;
@@ -642,7 +634,7 @@ package body Tchk is
-- Allow DO or THEN in place of LOOP
- elsif Token = Tok_Then or else Token = Tok_Do then
+ elsif Token in Tok_Then | Tok_Do then
T_Loop; -- give missing LOOP message
else
@@ -651,8 +643,7 @@ package body Tchk is
loop
if Prev_Token_Ptr < Current_Line_Start
- or else Token = Tok_Semicolon
- or else Token = Tok_EOF
+ or else Token in Tok_Semicolon | Tok_EOF
then
Restore_Scan_State (Scan_State); -- to where we were
return;
@@ -660,7 +651,7 @@ package body Tchk is
Scan; -- continue search
- if Token = Tok_Loop or else Token = Tok_Then then
+ if Token in Tok_Loop | Tok_Then then
Scan; -- past loop or then (message already generated)
return;
end if;
@@ -686,8 +677,7 @@ package body Tchk is
loop
if Prev_Token_Ptr < Current_Line_Start
- or else Token = Tok_Semicolon
- or else Token = Tok_EOF
+ or else Token in Tok_Semicolon | Tok_EOF
then
Restore_Scan_State (Scan_State); -- to where we were
return;
@@ -752,8 +742,7 @@ package body Tchk is
loop
if Prev_Token_Ptr < Current_Line_Start
- or else Token = Tok_EOF
- or else Token = Tok_End
+ or else Token in Tok_EOF | Tok_End
then
Restore_Scan_State (Scan_State); -- to where we were
return;
@@ -789,8 +778,7 @@ package body Tchk is
loop
if Prev_Token_Ptr < Current_Line_Start
- or else Token = Tok_Semicolon
- or else Token = Tok_EOF
+ or else Token in Tok_Semicolon | Tok_EOF
then
Restore_Scan_State (Scan_State); -- to where we were
return;
@@ -823,8 +811,7 @@ package body Tchk is
loop
if Prev_Token_Ptr < Current_Line_Start
- or else Token = Tok_Semicolon
- or else Token = Tok_EOF
+ or else Token in Tok_Semicolon | Tok_EOF
then
Restore_Scan_State (Scan_State); -- to where we were
return;
diff --git a/gcc/ada/par-util.adb b/gcc/ada/par-util.adb
index 3f1247a..0387418 100644
--- a/gcc/ada/par-util.adb
+++ b/gcc/ada/par-util.adb
@@ -336,7 +336,7 @@ package body Util is
-- probably the semicolon did end the list. Indeed that is
-- certainly the only single error correction possible here.
- if Token = Tok_Semicolon or else Token = Tok_EOF then
+ if Token in Tok_Semicolon | Tok_EOF then
Restore_Scan_State (Scan_State);
return False;
@@ -521,44 +521,34 @@ package body Util is
raise Program_Error;
when C_Comma_Right_Paren =>
- OK_Next_Tok :=
- Token = Tok_Comma or else Token = Tok_Right_Paren;
+ OK_Next_Tok := Token in Tok_Comma | Tok_Right_Paren;
when C_Comma_Colon =>
- OK_Next_Tok :=
- Token = Tok_Comma or else Token = Tok_Colon;
+ OK_Next_Tok := Token in Tok_Comma | Tok_Colon;
when C_Do =>
- OK_Next_Tok :=
- Token = Tok_Do;
+ OK_Next_Tok := Token = Tok_Do;
when C_Dot =>
- OK_Next_Tok :=
- Token = Tok_Dot;
+ OK_Next_Tok := Token = Tok_Dot;
when C_Greater_Greater =>
- OK_Next_Tok :=
- Token = Tok_Greater_Greater;
+ OK_Next_Tok := Token = Tok_Greater_Greater;
when C_In =>
- OK_Next_Tok :=
- Token = Tok_In;
+ OK_Next_Tok := Token = Tok_In;
when C_Is =>
- OK_Next_Tok :=
- Token = Tok_Is;
+ OK_Next_Tok := Token = Tok_Is;
when C_Left_Paren_Semicolon =>
- OK_Next_Tok :=
- Token = Tok_Left_Paren or else Token = Tok_Semicolon;
+ OK_Next_Tok := Token in Tok_Left_Paren | Tok_Semicolon;
when C_Use =>
- OK_Next_Tok :=
- Token = Tok_Use;
+ OK_Next_Tok := Token = Tok_Use;
when C_Vertical_Bar_Arrow =>
- OK_Next_Tok :=
- Token = Tok_Vertical_Bar or else Token = Tok_Arrow;
+ OK_Next_Tok := Token in Tok_Vertical_Bar | Tok_Arrow;
end case;
Restore_Scan_State (Scan_State);
@@ -802,7 +792,7 @@ package body Util is
function Token_Is_At_Start_Of_Line return Boolean is
begin
- return (Token_Ptr = First_Non_Blank_Location or else Token = Tok_EOF);
+ return Token_Ptr = First_Non_Blank_Location or else Token = Tok_EOF;
end Token_Is_At_Start_Of_Line;
-----------------------------------
diff --git a/gcc/ada/par.adb b/gcc/ada/par.adb
index b6ffdae..01e3c4b 100644
--- a/gcc/ada/par.adb
+++ b/gcc/ada/par.adb
@@ -361,36 +361,29 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is
Expr_Form : Expr_Form_Type;
- -- The following type is used for calls to P_Subprogram, P_Package, P_Task,
- -- P_Protected to indicate which of several possibilities is acceptable.
+ -- The following type is used by P_Subprogram, P_Package, to indicate which
+ -- of several possibilities is acceptable.
type Pf_Rec is record
- Spcn : Boolean; -- True if specification OK
- Decl : Boolean; -- True if declaration OK
- Gins : Boolean; -- True if generic instantiation OK
- Pbod : Boolean; -- True if proper body OK
- Rnam : Boolean; -- True if renaming declaration OK
- Stub : Boolean; -- True if body stub OK
- Pexp : Boolean; -- True if parameterized expression OK
- Fil2 : Boolean; -- Filler to fill to 8 bits
+ Spcn : Boolean; -- True if specification OK
+ Decl : Boolean; -- True if declaration OK
+ Gins : Boolean; -- True if generic instantiation OK
+ Pbod : Boolean; -- True if proper body OK
+ Rnam : Boolean; -- True if renaming declaration OK
+ Stub : Boolean; -- True if body stub OK
+ Pexp : Boolean; -- True if parameterized expression OK
end record;
pragma Pack (Pf_Rec);
function T return Boolean renames True;
function F return Boolean renames False;
- Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp : constant Pf_Rec :=
- Pf_Rec'(F, T, T, T, T, T, T, F);
- Pf_Decl_Pexp : constant Pf_Rec :=
- Pf_Rec'(F, T, F, F, F, F, T, F);
- Pf_Decl_Gins_Pbod_Rnam_Pexp : constant Pf_Rec :=
- Pf_Rec'(F, T, T, T, T, F, T, F);
- Pf_Decl_Pbod_Pexp : constant Pf_Rec :=
- Pf_Rec'(F, T, F, T, F, F, T, F);
- Pf_Pbod_Pexp : constant Pf_Rec :=
- Pf_Rec'(F, F, F, T, F, F, T, F);
- Pf_Spcn : constant Pf_Rec :=
- Pf_Rec'(T, F, F, F, F, F, F, F);
+ Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp : constant Pf_Rec := (F, T, T, T, T, T, T);
+ Pf_Decl_Pexp : constant Pf_Rec := (F, T, F, F, F, F, T);
+ Pf_Decl_Gins_Pbod_Rnam_Pexp : constant Pf_Rec := (F, T, T, T, T, F, T);
+ Pf_Decl_Pbod_Pexp : constant Pf_Rec := (F, T, F, T, F, F, T);
+ Pf_Pbod_Pexp : constant Pf_Rec := (F, F, F, T, F, F, T);
+ Pf_Spcn : constant Pf_Rec := (T, F, F, F, F, F, F);
-- The above are the only allowed values of Pf_Rec arguments
type SS_Rec is record
@@ -405,15 +398,15 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is
end record;
pragma Pack (SS_Rec);
- SS_Eftm_Eltm_Sreq : constant SS_Rec := SS_Rec'(T, T, F, F, T, F, F, F);
- SS_Eltm_Ortm_Tatm : constant SS_Rec := SS_Rec'(F, T, F, T, F, T, F, F);
- SS_Extm_Sreq : constant SS_Rec := SS_Rec'(F, F, T, F, T, F, F, F);
- SS_None : constant SS_Rec := SS_Rec'(F, F, F, F, F, F, F, F);
- SS_Ortm_Sreq : constant SS_Rec := SS_Rec'(F, F, F, T, T, F, F, F);
- SS_Sreq : constant SS_Rec := SS_Rec'(F, F, F, F, T, F, F, F);
- SS_Sreq_Whtm : constant SS_Rec := SS_Rec'(F, F, F, F, T, F, T, F);
- SS_Whtm : constant SS_Rec := SS_Rec'(F, F, F, F, F, F, T, F);
- SS_Unco : constant SS_Rec := SS_Rec'(F, F, F, F, F, F, F, T);
+ SS_Eftm_Eltm_Sreq : constant SS_Rec := (T, T, F, F, T, F, F, F);
+ SS_Eltm_Ortm_Tatm : constant SS_Rec := (F, T, F, T, F, T, F, F);
+ SS_Extm_Sreq : constant SS_Rec := (F, F, T, F, T, F, F, F);
+ SS_None : constant SS_Rec := (F, F, F, F, F, F, F, F);
+ SS_Ortm_Sreq : constant SS_Rec := (F, F, F, T, T, F, F, F);
+ SS_Sreq : constant SS_Rec := (F, F, F, F, T, F, F, F);
+ SS_Sreq_Whtm : constant SS_Rec := (F, F, F, F, T, F, T, F);
+ SS_Whtm : constant SS_Rec := (F, F, F, F, F, F, T, F);
+ SS_Unco : constant SS_Rec := (F, F, F, F, F, F, F, T);
Goto_List : Elist_Id;
-- List of goto nodes appearing in the current compilation. Used to
@@ -882,9 +875,9 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is
function P_Sequence_Of_Statements
(SS_Flags : SS_Rec; Handled : Boolean := False) return List_Id;
- -- The argument indicates the acceptable termination tokens.
- -- See body in Par.Ch5 for details of the use of this parameter.
- -- Handled is true if we are parsing a handled sequence of statements.
+ -- SS_Flags indicates the acceptable termination tokens; see body for
+ -- details. Handled is true if we are parsing a handled sequence of
+ -- statements.
procedure Parse_Decls_Begin_End (Parent : Node_Id);
-- Parses declarations and handled statement sequence, setting
diff --git a/gcc/ada/prep.adb b/gcc/ada/prep.adb
index b67fe8d..6731bae 100644
--- a/gcc/ada/prep.adb
+++ b/gcc/ada/prep.adb
@@ -461,11 +461,8 @@ package body Prep is
-- Handle relational operator
- elsif Token = Tok_Equal
- or else Token = Tok_Less
- or else Token = Tok_Less_Equal
- or else Token = Tok_Greater
- or else Token = Tok_Greater_Equal
+ elsif Token in Tok_Equal | Tok_Less | Tok_Less_Equal |
+ Tok_Greater | Tok_Greater_Equal
then
Relop := Token;
Scan.all;
@@ -771,9 +768,7 @@ package body Prep is
begin
-- Scan until we get an end of line or we reach the end of the buffer
- while Token /= Tok_End_Of_Line
- and then Token /= Tok_EOF
- loop
+ while Token not in Tok_End_Of_Line | Tok_EOF loop
Scan.all;
end loop;
end Go_To_End_Of_Line;
@@ -1042,7 +1037,7 @@ package body Prep is
Scan.all;
- if Token /= Tok_End_Of_Line and then Token /= Tok_EOF then
+ if Token not in Tok_End_Of_Line | Tok_EOF then
Error_Msg ("extraneous text in definition", Token_Ptr);
goto Cleanup;
end if;
@@ -1056,12 +1051,12 @@ package body Prep is
Scan.all;
- if Token /= Tok_End_Of_Line and then Token /= Tok_EOF then
+ if Token not in Tok_End_Of_Line | Tok_EOF then
Error_Msg ("extraneous text in definition", Token_Ptr);
goto Cleanup;
end if;
- elsif Token = Tok_End_Of_Line or else Token = Tok_EOF then
+ elsif Token in Tok_End_Of_Line | Tok_EOF then
Data := (Symbol => Symbol_Name,
Original => Original_Name,
On_The_Command_Line => False,
@@ -1093,7 +1088,7 @@ package body Prep is
Scan.all;
- if Token /= Tok_End_Of_Line and then Token /= Tok_EOF then
+ if Token not in Tok_End_Of_Line | Tok_EOF then
Error_Msg ("extraneous text in definition", Token_Ptr);
goto Cleanup;
end if;
@@ -1144,7 +1139,7 @@ package body Prep is
<<Cleanup>>
Set_Ignore_Errors (To => True);
- while Token /= Tok_End_Of_Line and then Token /= Tok_EOF loop
+ while Token not in Tok_End_Of_Line | Tok_EOF loop
Scan.all;
end loop;
@@ -1261,9 +1256,7 @@ package body Prep is
-- It is an error to have trailing characters after
-- the condition or "then".
- if Token /= Tok_End_Of_Line
- and then Token /= Tok_EOF
- then
+ if Token not in Tok_End_Of_Line | Tok_EOF then
Error_Msg
("extraneous text on preprocessor line",
Token_Ptr);
@@ -1318,9 +1311,7 @@ package body Prep is
-- It is an error to have trailing characters after the
-- condition or "then".
- if Token /= Tok_End_Of_Line
- and then Token /= Tok_EOF
- then
+ if Token not in Tok_End_Of_Line | Tok_EOF then
Error_Msg
("extraneous text on preprocessor line",
Token_Ptr);
@@ -1384,9 +1375,7 @@ package body Prep is
-- Error of character present after "#else"
- if Token /= Tok_End_Of_Line
- and then Token /= Tok_EOF
- then
+ if Token not in Tok_End_Of_Line | Tok_EOF then
Error_Msg
("extraneous text on preprocessor line",
Token_Ptr);
@@ -1427,9 +1416,7 @@ package body Prep is
-- Error of character present after "#end if;"
- if Token /= Tok_End_Of_Line
- and then Token /= Tok_EOF
- then
+ if Token not in Tok_End_Of_Line | Tok_EOF then
Error_Msg
("extraneous text on preprocessor line",
Token_Ptr);
@@ -1496,9 +1483,7 @@ package body Prep is
Go_To_End_Of_Line;
else
- while Token /= Tok_End_Of_Line
- and then Token /= Tok_EOF
- loop
+ while Token not in Tok_End_Of_Line | Tok_EOF loop
if Token = Tok_Special
and then Special_Character = '$'
then
@@ -1564,7 +1549,7 @@ package body Prep is
end if;
end if;
- pragma Assert (Token = Tok_End_Of_Line or else Token = Tok_EOF);
+ pragma Assert (Token in Tok_End_Of_Line | Tok_EOF);
-- At this point, the token is either end of line or EOF. The line to
-- possibly output stops just before the token.
diff --git a/gcc/ada/prepcomp.adb b/gcc/ada/prepcomp.adb
index 3cd2959..a1fe025 100644
--- a/gcc/ada/prepcomp.adb
+++ b/gcc/ada/prepcomp.adb
@@ -311,7 +311,7 @@ package body Prepcomp is
-- Check the switches that may follow
- while Token /= Tok_End_Of_Line and then Token /= Tok_EOF loop
+ while Token not in Tok_End_Of_Line | Tok_EOF loop
if Token /= Tok_Minus then
Error_Msg -- CODEFIX
("`'-` expected", Token_Ptr);
@@ -755,7 +755,7 @@ package body Prepcomp is
begin
Set_Ignore_Errors (To => True);
- while Token /= Tok_End_Of_Line and then Token /= Tok_EOF loop
+ while Token not in Tok_End_Of_Line | Tok_EOF loop
Scan;
end loop;
diff --git a/gcc/ada/scng.adb b/gcc/ada/scng.adb
index f5fc020..b6698a6 100644
--- a/gcc/ada/scng.adb
+++ b/gcc/ada/scng.adb
@@ -1747,15 +1747,9 @@ package body Scng is
-- In Ada 2022, a target name (i.e. @) is a valid prefix of an
-- attribute, and functions like a name.
- if Prev_Token = Tok_All
- or else Prev_Token = Tok_At_Sign
- or else Prev_Token = Tok_Delta
- or else Prev_Token = Tok_Digits
- or else Prev_Token = Tok_Identifier
- or else Prev_Token = Tok_Project
- or else Prev_Token = Tok_Right_Paren
- or else Prev_Token = Tok_Right_Bracket
- or else Prev_Token in Token_Class_Literal
+ if Prev_Token in Tok_All | Tok_At_Sign | Tok_Delta | Tok_Digits |
+ Tok_Identifier | Tok_Project | Tok_Right_Paren |
+ Tok_Right_Bracket | Token_Class_Literal
then
Token := Tok_Apostrophe;
diff --git a/gcc/ada/sem.ads b/gcc/ada/sem.ads
index fa3e9bf..5c7633b 100644
--- a/gcc/ada/sem.ads
+++ b/gcc/ada/sem.ads
@@ -32,7 +32,7 @@
-- Analysis implements the bulk of semantic analysis such as
-- name analysis and type resolution for declarations,
--- instructions and expressions. The main routine
+-- statements, and expressions. The main routine
-- driving this process is procedure Analyze given below.
-- This analysis phase is really a bottom up pass that is
-- achieved during the recursive traversal performed by the
@@ -46,26 +46,25 @@
-- completed during analysis (because of overloading
-- ambiguities). Specifically, after completing the bottom
-- up pass carried out during analysis for expressions, the
--- Resolve routine (see the spec of sem_res for more info)
+-- Resolve routine (see the spec of Sem_Res for more info)
-- is called to perform a top down resolution with
-- recursive calls to itself to resolve operands.
--- Expansion if we are not generating code this phase is a no-op.
+-- Expansion If we are not generating code this phase is a no-op.
-- Otherwise this phase expands, i.e. transforms, original
--- declaration, expressions or instructions into simpler
--- structures that can be handled by the back-end. This
--- phase is also in charge of generating code which is
--- implicit in the original source (for instance for
--- default initializations, controlled types, etc.)
--- There are two separate instances where expansion is
+-- source constructs into simpler constructs that can be
+-- handled by the back-end. This phase is also in charge of
+-- generating code which is implicit in the original source
+-- (for instance for default initializations, controlled types,
+-- etc.) There are two separate instances where expansion is
-- invoked. For declarations and instructions, expansion is
--- invoked just after analysis since no resolution needs
--- to be performed. For expressions, expansion is done just
--- after resolution. In both cases expansion is done from the
--- bottom up just before the end of Analyze for instructions
--- and declarations or the call to Resolve for expressions.
--- The main routine driving expansion is Expand.
--- See the spec of Expander for more details.
+-- invoked just after analysis since no resolution needs to be
+-- performed. For expressions, expansion is done just after
+-- resolution. In both cases expansion is done from the bottom
+-- up just before the end of Analyze for instructions and
+-- declarations or the call to Resolve for expressions. The
+-- main routine driving expansion is Expand. See the spec of
+-- Expander for more details.
-- To summarize, in normal code generation mode we recursively traverse the
-- abstract syntax tree top-down performing semantic analysis bottom
@@ -110,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 Analyze_Spec_Expression.
+-- special analysis is called Preanalyze_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
@@ -134,7 +133,7 @@
-- of the expression cannot be obtained at the point of declaration, only at
-- the point of use.
--- Generally our model is to combine analysis resolution and expansion, but
+-- Generally our model is to combine analysis, resolution, and expansion, but
-- this is the one case where this model falls down. Here is how we patch
-- it up without causing too much distortion to our basic model.
@@ -175,7 +174,7 @@
-- children is performed before expansion of the parent does not work if the
-- code generated for the children by the expander needs to be evaluated
-- repeatedly (for instance in the above aggregate "new Thing (Function_Call)"
--- needs to be called 100 times.)
+-- needs to be called 100 times).
-- The reason this mechanism does not work is that the expanded code for the
-- children is typically inserted above the parent and thus when the parent
diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb
index 258e4ad..5db1fce 100644
--- a/gcc/ada/sem_aggr.adb
+++ b/gcc/ada/sem_aggr.adb
@@ -1987,6 +1987,11 @@ package body Sem_Aggr is
while Present (Assoc) loop
if Nkind (Assoc) = N_Iterated_Component_Association then
Resolve_Iterated_Component_Association (Assoc, Index_Typ);
+
+ elsif Nkind (Assoc) /= N_Component_Association then
+ Error_Msg_N
+ ("invalid component association for aggregate", Assoc);
+ return Failure;
end if;
Choice := First (Choice_List (Assoc));
diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb
index 93bb6f4..0c88be7 100644
--- a/gcc/ada/sem_attr.adb
+++ b/gcc/ada/sem_attr.adb
@@ -1430,12 +1430,11 @@ package body Sem_Attr is
Placement_Error;
end if;
- -- 'Old attribute reference ok in a _Postconditions procedure
+ -- 'Old attribute reference ok in a _Wrapped_Statements procedure
elsif Nkind (Prag) = N_Subprogram_Body
- and then not Comes_From_Source (Prag)
- and then Nkind (Corresponding_Spec (Prag)) = N_Defining_Identifier
- and then Chars (Corresponding_Spec (Prag)) = Name_uPostconditions
+ and then Ekind (Defining_Entity (Prag)) in Subprogram_Kind
+ and then Present (Wrapped_Statements (Defining_Entity (Prag)))
then
null;
@@ -1450,18 +1449,18 @@ package body Sem_Attr is
if Nkind (Prag) = N_Aspect_Specification then
Subp_Decl := Parent (Prag);
elsif Nkind (Prag) = N_Subprogram_Body then
- declare
- Enclosing_Scope : constant Node_Id :=
- Scope (Corresponding_Spec (Prag));
- begin
- pragma Assert (Postconditions_Proc (Enclosing_Scope)
- = Corresponding_Spec (Prag));
- Subp_Decl := Parent (Parent (Enclosing_Scope));
- end;
+ Subp_Decl := Prag;
else
Subp_Decl := Find_Related_Declaration_Or_Body (Prag);
end if;
+ -- 'Old objects appear in block statements as part of the expansion
+ -- of contract wrappers.
+
+ if Nkind (Subp_Decl) = N_Block_Statement then
+ Subp_Decl := Parent (Parent (Subp_Decl));
+ end if;
+
-- The aspect or pragma where the attribute resides should be
-- associated with a subprogram declaration or a body. If this is not
-- the case, then the aspect or pragma is illegal. Return as analysis
@@ -1506,7 +1505,7 @@ package body Sem_Attr is
if Modify_Tree_For_C
and then Chars (Spec_Id) = Name_uParent
- and then Chars (Scope (Spec_Id)) = Name_uPostconditions
+ and then Chars (Scope (Spec_Id)) = Name_uWrapped_Statements
then
-- This situation occurs only when analyzing the body-to-inline
@@ -1750,7 +1749,7 @@ package body Sem_Attr is
if Is_Entry_Wrapper (Spec_Id) then
Legal := True;
- elsif Chars (Spec_Id) = Name_uPostconditions
+ elsif Chars (Spec_Id) = Name_uWrapped_Statements
and then Is_Entry_Wrapper (Scope (Spec_Id))
then
Spec_Id := Scope (Spec_Id);
@@ -4697,19 +4696,6 @@ package body Sem_Attr is
Set_Etype (N, Standard_Boolean);
- ---------------
- -- Lock_Free --
- ---------------
-
- when Attribute_Lock_Free =>
- Check_E0;
- Set_Etype (N, Standard_Boolean);
-
- if not Is_Protected_Type (P_Type) then
- Error_Attr_P
- ("prefix of % attribute must be a protected object");
- end if;
-
----------------
-- Loop_Entry --
----------------
@@ -5894,13 +5880,13 @@ package body Sem_Attr is
Error_Attr ("prefix of % attribute must be a function", P);
end if;
- -- Attribute 'Result is part of a _Postconditions procedure. There is
+ -- Attribute 'Result is part of postconditions expansion. There is
-- no need to perform the semantic checks below as they were already
-- verified when the attribute was analyzed in its original context.
-- Instead, rewrite the attribute as a reference to formal parameter
- -- _Result of the _Postconditions procedure.
+ -- _Result of the _Wrapped_Statements procedure.
- if Chars (Spec_Id) = Name_uPostconditions
+ if Chars (Spec_Id) = Name_uWrapped_Statements
or else
(In_Inlined_C_Postcondition
and then Nkind (Parent (Spec_Id)) = N_Block_Statement)
@@ -7413,10 +7399,19 @@ package body Sem_Attr is
if Comes_From_Source (N) then
Check_Object_Reference (P);
+ -- Attribute 'Valid_Scalars is illegal on unchecked union types
+ -- regardles of the privacy, because it is not always guaranteed
+ -- that the components are retrievable based on whether the
+ -- discriminants are inferable.
+
+ if Has_Unchecked_Union (Validated_View (P_Type)) then
+ Error_Attr_P
+ ("attribute % not allowed for Unchecked_Union type");
+
-- Do not emit any diagnostics related to private types to avoid
-- disclosing the structure of the type.
- if Is_Private_Type (P_Type) then
+ elsif Is_Private_Type (P_Type) then
-- Attribute 'Valid_Scalars is not supported on private tagged
-- types due to a code generation issue. Is_Visible_Component
@@ -7446,15 +7441,6 @@ package body Sem_Attr is
("??attribute % always True, no scalars to check", P);
Set_Boolean_Result (N, True);
end if;
-
- -- Attribute 'Valid_Scalars is illegal on unchecked union types
- -- because it is not always guaranteed that the components are
- -- retrievable based on whether the discriminants are inferable
-
- if Has_Unchecked_Union (P_Type) then
- Error_Attr_P
- ("attribute % not allowed for Unchecked_Union type");
- end if;
end if;
end if;
@@ -8338,15 +8324,6 @@ package body Sem_Attr is
return;
- -- For Lock_Free, we apply the attribute to the type of the object.
- -- This is allowed since we have already verified that the type is a
- -- protected type.
-
- elsif Id = Attribute_Lock_Free then
- P_Entity := Etype (P);
-
- -- No other attributes for objects are folded
-
else
Check_Expressions;
return;
@@ -8476,7 +8453,6 @@ package body Sem_Attr is
Id = Attribute_Has_Access_Values or else
Id = Attribute_Has_Discriminants or else
Id = Attribute_Has_Tagged_Values or else
- Id = Attribute_Lock_Free or else
Id = Attribute_Preelaborable_Initialization or else
Id = Attribute_Type_Class or else
Id = Attribute_Unconstrained_Array or else
@@ -8595,7 +8571,7 @@ package body Sem_Attr is
-- only the First, Last and Length attributes are possibly static.
-- Atomic_Always_Lock_Free, Definite, Descriptor_Size, Has_Access_Values
- -- Has_Discriminants, Has_Tagged_Values, Lock_Free, Type_Class, and
+ -- Has_Discriminants, Has_Tagged_Values, Type_Class, and
-- Unconstrained_Array are again exceptions, because they apply as well
-- to unconstrained types.
@@ -8614,7 +8590,6 @@ package body Sem_Attr is
Id = Attribute_Has_Access_Values or else
Id = Attribute_Has_Discriminants or else
Id = Attribute_Has_Tagged_Values or else
- Id = Attribute_Lock_Free or else
Id = Attribute_Preelaborable_Initialization or else
Id = Attribute_Type_Class or else
Id = Attribute_Unconstrained_Array or else
@@ -9315,24 +9290,6 @@ package body Sem_Attr is
True);
end if;
- ---------------
- -- Lock_Free --
- ---------------
-
- when Attribute_Lock_Free => Lock_Free : declare
- V : constant Entity_Id := Boolean_Literals (Uses_Lock_Free (P_Type));
-
- begin
- Rewrite (N, New_Occurrence_Of (V, Loc));
-
- -- Analyze and resolve as boolean. Note that this attribute is a
- -- static attribute in GNAT.
-
- Analyze_And_Resolve (N, Standard_Boolean);
- Static := True;
- Set_Is_Static_Expression (N);
- end Lock_Free;
-
----------
-- Last --
----------
diff --git a/gcc/ada/sem_case.adb b/gcc/ada/sem_case.adb
index 0bb358a..2810d3e 100644
--- a/gcc/ada/sem_case.adb
+++ b/gcc/ada/sem_case.adb
@@ -106,6 +106,14 @@ package body Sem_Case is
package Composite_Case_Ops is
+ Simplified_Composite_Coverage_Rules : constant Boolean := True;
+ -- Indicates that, as a temporary stopgap, we implement
+ -- simpler coverage-checking rules when casing on a
+ -- composite selector:
+ -- 1) Require that an Others choice must be given, regardless
+ -- of whether all possible values are covered explicitly.
+ -- 2) No legality checks regarding overlapping choices.
+
function Box_Value_Required (Subtyp : Entity_Id) return Boolean;
-- If result is True, then the only allowed value (in a choice
-- aggregate) for a component of this (sub)type is a box. This rule
@@ -263,7 +271,6 @@ package body Sem_Case is
type Bound_Values is array (Positive range <>) of Node_Id;
end Choice_Analysis;
-
end Composite_Case_Ops;
procedure Expand_Others_Choice
@@ -2526,6 +2533,14 @@ package body Sem_Case is
for P in Part_Id loop
Insert_Representative (Component_Bounds (P).Low, P);
end loop;
+
+ if Simplified_Composite_Coverage_Rules then
+ -- Omit other representative values to avoid capacity
+ -- problems building data structures only used in
+ -- compile-time checks that will not be performed.
+ return Result;
+ end if;
+
for C of Choices_Bounds loop
if not C.Is_Others then
for P in Part_Id loop
@@ -3368,8 +3383,6 @@ package body Sem_Case is
--------------------------------
procedure Check_Case_Pattern_Choices is
- -- ??? Need to Free/Finalize value sets allocated here.
-
package Ops is new Composite_Case_Ops.Choice_Analysis
(Case_Statement => N);
use Ops;
@@ -3394,8 +3407,14 @@ package body Sem_Case is
Covered : Value_Set := Empty;
-- The union of all alternatives seen so far
-
begin
+ if Composite_Case_Ops.Simplified_Composite_Coverage_Rules then
+ if not (for some Choice of Info => Choice.Is_Others) then
+ Error_Msg_N ("others choice required", N);
+ end if;
+ return;
+ end if;
+
for Choice of Info loop
if Choice.Is_Others then
Others_Seen := True;
diff --git a/gcc/ada/sem_ch11.adb b/gcc/ada/sem_ch11.adb
index a15fd09..339edd3 100644
--- a/gcc/ada/sem_ch11.adb
+++ b/gcc/ada/sem_ch11.adb
@@ -49,7 +49,6 @@ with Sem_Warn; use Sem_Warn;
with Sinfo; use Sinfo;
with Sinfo.Nodes; use Sinfo.Nodes;
with Sinfo.Utils; use Sinfo.Utils;
-with Snames; use Snames;
with Stand; use Stand;
package body Sem_Ch11 is
@@ -431,12 +430,10 @@ package body Sem_Ch11 is
-- If the current scope is a subprogram, entry or task body or declare
-- block then this is the right place to check for hanging useless
- -- assignments from the statement sequence. Skip this in the body of a
- -- postcondition, since in that case there are no source references.
+ -- assignments from the statement sequence.
- if (Is_Subprogram_Or_Entry (Current_Scope)
- and then Chars (Current_Scope) /= Name_uPostconditions)
- or else Ekind (Current_Scope) in E_Block | E_Task_Type
+ if Is_Subprogram_Or_Entry (Current_Scope)
+ or else Ekind (Current_Scope) in E_Block | E_Task_Type
then
Warn_On_Useless_Assignments (Current_Scope);
end if;
diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb
index 4d1644b..54b10dd 100644
--- a/gcc/ada/sem_ch13.adb
+++ b/gcc/ada/sem_ch13.adb
@@ -2293,7 +2293,7 @@ package body Sem_Ch13 is
then
Error_Msg_Name_1 := Nam;
Error_Msg_N
- ("expression of aspect %" &
+ ("expression of aspect % " &
"must be static", Aspect);
end if;
@@ -6959,6 +6959,7 @@ package body Sem_Ch13 is
if Nkind (Expr) /= N_Aggregate then
Error_Msg_N ("aspect Iterable must be an aggregate", Expr);
+ return;
end if;
declare
@@ -6969,7 +6970,9 @@ package body Sem_Ch13 is
while Present (Assoc) loop
Analyze (Expression (Assoc));
- if not Is_Entity_Name (Expression (Assoc)) then
+ if not Is_Entity_Name (Expression (Assoc))
+ or else Ekind (Entity (Expression (Assoc))) /= E_Function
+ then
Error_Msg_N ("value must be a function", Assoc);
end if;
@@ -15875,22 +15878,34 @@ package body Sem_Ch13 is
Ent := Entity (N);
F1 := First_Formal (Ent);
+ F2 := Next_Formal (F1);
- if Nam in Name_First | Name_Last then
+ if Nam = Name_First then
- -- First or Last (Container) => Cursor
+ -- First (Container) => Cursor
if Etype (Ent) /= Cursor then
Error_Msg_N ("primitive for First must yield a cursor", N);
+ elsif Present (F2) then
+ Error_Msg_N ("no match for First iterable primitive", N);
+ end if;
+
+ elsif Nam = Name_Last then
+
+ -- Last (Container) => Cursor
+
+ if Etype (Ent) /= Cursor then
+ Error_Msg_N ("primitive for Last must yield a cursor", N);
+ elsif Present (F2) then
+ Error_Msg_N ("no match for Last iterable primitive", N);
end if;
elsif Nam = Name_Next then
-- Next (Container, Cursor) => Cursor
- F2 := Next_Formal (F1);
-
- if Etype (F2) /= Cursor
+ if No (F2)
+ or else Etype (F2) /= Cursor
or else Etype (Ent) /= Cursor
or else Present (Next_Formal (F2))
then
@@ -15901,9 +15916,8 @@ package body Sem_Ch13 is
-- Previous (Container, Cursor) => Cursor
- F2 := Next_Formal (F1);
-
- if Etype (F2) /= Cursor
+ if No (F2)
+ or else Etype (F2) /= Cursor
or else Etype (Ent) /= Cursor
or else Present (Next_Formal (F2))
then
@@ -15914,9 +15928,8 @@ package body Sem_Ch13 is
-- Has_Element (Container, Cursor) => Boolean
- F2 := Next_Formal (F1);
-
- if Etype (F2) /= Cursor
+ if No (F2)
+ or else Etype (F2) /= Cursor
or else Etype (Ent) /= Standard_Boolean
or else Present (Next_Formal (F2))
then
@@ -15924,7 +15937,8 @@ package body Sem_Ch13 is
end if;
elsif Nam = Name_Element then
- F2 := Next_Formal (F1);
+
+ -- Element (Container, Cursor) => Element_Type;
if No (F2)
or else Etype (F2) /= Cursor
@@ -17084,34 +17098,41 @@ package body Sem_Ch13 is
------------------------------
procedure Validate_Iterable_Aspect (Typ : Entity_Id; ASN : Node_Id) is
+ Aggr : constant Node_Id := Expression (ASN);
Assoc : Node_Id;
Expr : Node_Id;
Prim : Node_Id;
- Cursor : constant Entity_Id := Get_Cursor_Type (ASN, Typ);
+ Cursor : Entity_Id;
- First_Id : Entity_Id;
- Last_Id : Entity_Id;
- Next_Id : Entity_Id;
- Has_Element_Id : Entity_Id;
- Element_Id : Entity_Id;
+ First_Id : Entity_Id := Empty;
+ Last_Id : Entity_Id := Empty;
+ Next_Id : Entity_Id := Empty;
+ Has_Element_Id : Entity_Id := Empty;
+ Element_Id : Entity_Id := Empty;
begin
+ if Nkind (Aggr) /= N_Aggregate then
+ Error_Msg_N ("aspect Iterable must be an aggregate", Aggr);
+ return;
+ end if;
+
+ Cursor := Get_Cursor_Type (ASN, Typ);
+
-- If previous error aspect is unusable
if Cursor = Any_Type then
return;
end if;
- First_Id := Empty;
- Last_Id := Empty;
- Next_Id := Empty;
- Has_Element_Id := Empty;
- Element_Id := Empty;
+ if not Is_Empty_List (Expressions (Aggr)) then
+ Error_Msg_N
+ ("illegal positional association", First (Expressions (Aggr)));
+ end if;
-- Each expression must resolve to a function with the proper signature
- Assoc := First (Component_Associations (Expression (ASN)));
+ Assoc := First (Component_Associations (Aggr));
while Present (Assoc) loop
Expr := Expression (Assoc);
Analyze (Expr);
diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb
index ed2f621..ceaf66b 100644
--- a/gcc/ada/sem_ch4.adb
+++ b/gcc/ada/sem_ch4.adb
@@ -4798,7 +4798,7 @@ package body Sem_Ch4 is
Name : constant Node_Id := Prefix (N);
Sel : constant Node_Id := Selector_Name (N);
Act_Decl : Node_Id;
- Comp : Entity_Id;
+ Comp : Entity_Id := Empty;
Has_Candidate : Boolean := False;
Hidden_Comp : Entity_Id;
In_Scope : Boolean;
@@ -4814,6 +4814,14 @@ package body Sem_Ch4 is
Is_Single_Concurrent_Object : Boolean;
-- Set True if the prefix is a single task or a single protected object
+ function Constraint_Has_Unprefixed_Discriminant_Reference
+ (Typ : Entity_Id) return Boolean;
+ -- Given a subtype that is subject to a discriminant-dependent
+ -- constraint, returns True if any of the values of the constraint
+ -- (i.e., any of the index values for an index constraint, any of
+ -- the discriminant values for a discriminant constraint)
+ -- are unprefixed discriminant names.
+
procedure Find_Component_In_Instance (Rec : Entity_Id);
-- In an instance, a component of a private extension may not be visible
-- while it was visible in the generic. Search candidate scope for a
@@ -4842,6 +4850,56 @@ package body Sem_Ch4 is
-- _Procedure, and collect all its interpretations (since it may be an
-- overloaded interface primitive); otherwise return False.
+ ------------------------------------------------------
+ -- Constraint_Has_Unprefixed_Discriminant_Reference --
+ ------------------------------------------------------
+
+ function Constraint_Has_Unprefixed_Discriminant_Reference
+ (Typ : Entity_Id) return Boolean
+ is
+
+ function Is_Discriminant_Name (N : Node_Id) return Boolean is
+ ((Nkind (N) = N_Identifier)
+ and then (Ekind (Entity (N)) = E_Discriminant));
+ begin
+ if Is_Array_Type (Typ) then
+ declare
+ Index : Node_Id := First_Index (Typ);
+ Rng : Node_Id;
+ begin
+ while Present (Index) loop
+ Rng := Index;
+ if Nkind (Rng) = N_Subtype_Indication then
+ Rng := Range_Expression (Constraint (Rng));
+ end if;
+
+ if Nkind (Rng) = N_Range then
+ if Is_Discriminant_Name (Low_Bound (Rng))
+ or else Is_Discriminant_Name (High_Bound (Rng))
+ then
+ return True;
+ end if;
+ end if;
+
+ Next_Index (Index);
+ end loop;
+ end;
+ else
+ declare
+ Elmt : Elmt_Id := First_Elmt (Discriminant_Constraint (Typ));
+ begin
+ while Present (Elmt) loop
+ if Is_Discriminant_Name (Node (Elmt)) then
+ return True;
+ end if;
+ Next_Elmt (Elmt);
+ end loop;
+ end;
+ end if;
+
+ return False;
+ end Constraint_Has_Unprefixed_Discriminant_Reference;
+
--------------------------------
-- Find_Component_In_Instance --
--------------------------------
@@ -5129,7 +5187,16 @@ package body Sem_Ch4 is
and then not Is_Derived_Type (Prefix_Type)
and then Is_Entity_Name (Name);
- Comp := First_Entity (Type_To_Use);
+ -- Avoid initializing Comp if that initialization is not needed
+ -- (and, more importantly, if the call to First_Entity could fail).
+
+ if Has_Discriminants (Type_To_Use)
+ or else Is_Record_Type (Type_To_Use)
+ or else Is_Private_Type (Type_To_Use)
+ or else Is_Concurrent_Type (Type_To_Use)
+ then
+ Comp := First_Entity (Type_To_Use);
+ end if;
-- If the selector has an original discriminant, the node appears in
-- an instance. Replace the discriminant with the corresponding one
@@ -5289,6 +5356,33 @@ package body Sem_Ch4 is
end;
end if;
+ -- If Etype (Comp) is an access type whose designated subtype
+ -- is constrained by an unprefixed discriminant value,
+ -- then ideally we would build a new subtype with an
+ -- appropriately prefixed discriminant value and use that
+ -- instead, as is done in Build_Actual_Subtype_Of_Component.
+ -- That turns out to be difficult in this context (with
+ -- Full_Analysis = False, we could be processing a selected
+ -- component that occurs in a Postcondition pragma;
+ -- PPC pragmas are odd because they can contain references
+ -- to formal parameters that occur outside the subprogram).
+ -- So instead we punt on building a new subtype and we
+ -- use the base type instead. This might introduce
+ -- correctness problems if N were the target of an
+ -- assignment (because a required check might be omitted);
+ -- fortunately, that's impossible because a reference to the
+ -- current instance of a type does not denote a variable view
+ -- when the reference occurs within an aspect_specification.
+ -- GNAT's Precondition and Postcondition pragmas follow the
+ -- same rules as a Pre or Post aspect_specification.
+
+ elsif Has_Discriminant_Dependent_Constraint (Comp)
+ and then Ekind (Etype (Comp)) = E_Access_Subtype
+ and then Constraint_Has_Unprefixed_Discriminant_Reference
+ (Designated_Type (Etype (Comp)))
+ then
+ Set_Etype (N, Base_Type (Etype (Comp)));
+
-- If Full_Analysis not enabled, just set the Etype
else
diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index 7240129..0459058 100644
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -1911,15 +1911,19 @@ package body Sem_Ch6 is
Analyze_Aspects_On_Subprogram_Body_Or_Stub (N);
end if;
- Analyze_Declarations (Declarations (N));
- Check_Completion;
-
- -- Process the contract of the subprogram body after all declarations
- -- have been analyzed. This ensures that any contract-related pragmas
- -- are available through the N_Contract node of the body.
+ -- Process the contract of the subprogram body after analyzing all
+ -- the contract-related pragmas within the declarations.
+ Analyze_Pragmas_In_Declarations (Body_Id);
Analyze_Entry_Or_Subprogram_Body_Contract (Body_Id);
+ -- Continue on with analyzing the declarations and statements once
+ -- contract expansion is done and we are done expanding contract
+ -- related wrappers.
+
+ Analyze_Declarations (Declarations (N));
+ Check_Completion;
+
Analyze (Handled_Statement_Sequence (N));
Save_Global_References (Original_Node (N));
@@ -2032,7 +2036,7 @@ package body Sem_Ch6 is
end loop;
-- Determine whether the null procedure may be a completion of a generic
- -- suprogram, in which case we use the new null body as the completion
+ -- subprogram, in which case we use the new null body as the completion
-- and set minimal semantic information on the original declaration,
-- which is rewritten as a null statement.
@@ -2895,7 +2899,6 @@ package body Sem_Ch6 is
Conformant : Boolean;
Desig_View : Entity_Id := Empty;
Exch_Views : Elist_Id := No_Elist;
- HSS : Node_Id;
Mask_Types : Elist_Id := No_Elist;
Prot_Typ : Entity_Id := Empty;
Spec_Decl : Node_Id := Empty;
@@ -3530,6 +3533,8 @@ package body Sem_Ch6 is
--------------------------
procedure Check_Missing_Return is
+ HSS : constant Node_Id := Handled_Statement_Sequence (N);
+
Id : Entity_Id;
Missing_Ret : Boolean;
@@ -3968,18 +3973,9 @@ package body Sem_Ch6 is
-- Move relevant pragmas to the spec
- elsif Pragma_Name_Unmapped (Decl) in Name_Depends
- | Name_Ghost
- | Name_Global
- | Name_Pre
- | Name_Precondition
- | Name_Post
- | Name_Refined_Depends
- | Name_Refined_Global
- | Name_Refined_Post
- | Name_Inline
- | Name_Pure_Function
- | Name_Volatile_Function
+ elsif
+ Pragma_Significant_To_Subprograms
+ (Get_Pragma_Id (Decl))
then
Remove (Decl);
Insert_After (Insert_Nod, Decl);
@@ -4223,7 +4219,6 @@ package body Sem_Ch6 is
Analyze_Generic_Subprogram_Body (N, Spec_Id);
if Nkind (N) = N_Subprogram_Body then
- HSS := Handled_Statement_Sequence (N);
Check_Missing_Return;
end if;
@@ -5157,9 +5152,27 @@ package body Sem_Ch6 is
end;
end if;
- -- Now we can go on to analyze the body
+ -- Ada 2012 (AI05-0151): Incomplete types coming from a limited context
+ -- may now appear in parameter and result profiles. Since the analysis
+ -- of a subprogram body may use the parameter and result profile of the
+ -- spec, swap any limited views with their non-limited counterpart.
+
+ if Ada_Version >= Ada_2012 and then Present (Spec_Id) then
+ Exch_Views := Exchange_Limited_Views (Spec_Id);
+ end if;
+
+ -- Analyze any aspect specifications that appear on the subprogram body
+
+ if Has_Aspects (N) then
+ Analyze_Aspects_On_Subprogram_Body_Or_Stub (N);
+ end if;
+
+ -- Process the contract of the subprogram body after analyzing all the
+ -- contract-related pragmas within the declarations.
+
+ Analyze_Pragmas_In_Declarations (Body_Id);
+ Analyze_Entry_Or_Subprogram_Body_Contract (Body_Id);
- HSS := Handled_Statement_Sequence (N);
Set_Actual_Subtypes (N, Current_Scope);
-- Add a declaration for the Protection object, renaming declarations
@@ -5180,15 +5193,6 @@ package body Sem_Ch6 is
(Sloc (N), Spec_Id, Prot_Typ, N, Declarations (N));
end if;
- -- Ada 2012 (AI05-0151): Incomplete types coming from a limited context
- -- may now appear in parameter and result profiles. Since the analysis
- -- of a subprogram body may use the parameter and result profile of the
- -- spec, swap any limited views with their non-limited counterpart.
-
- if Ada_Version >= Ada_2012 and then Present (Spec_Id) then
- Exch_Views := Exchange_Limited_Views (Spec_Id);
- end if;
-
-- If the return type is an anonymous access type whose designated type
-- is the limited view of a class-wide type and the non-limited view is
-- available, update the return type accordingly.
@@ -5225,12 +5229,6 @@ package body Sem_Ch6 is
end;
end if;
- -- Analyze any aspect specifications that appear on the subprogram body
-
- if Has_Aspects (N) then
- Analyze_Aspects_On_Subprogram_Body_Or_Stub (N);
- end if;
-
Analyze_Declarations (Declarations (N));
-- Verify that the SPARK_Mode of the body agrees with that of its spec
@@ -5269,17 +5267,11 @@ package body Sem_Ch6 is
end if;
end if;
- -- A subprogram body freezes its own contract. Analyze the contract
- -- after the declarations of the body have been processed as pragmas
- -- are now chained on the contract of the subprogram body.
-
- Analyze_Entry_Or_Subprogram_Body_Contract (Body_Id);
-
-- Check completion, and analyze the statements
Check_Completion;
Inspect_Deferred_Constant_Completion (Declarations (N));
- Analyze (HSS);
+ Analyze (Handled_Statement_Sequence (N));
-- Add the generated minimum accessibility objects to the subprogram
-- body's list of declarations after analysis of the statements and
@@ -5296,7 +5288,8 @@ package body Sem_Ch6 is
-- Deal with end of scope processing for the body
- Process_End_Label (HSS, 't', Current_Scope);
+ Process_End_Label
+ (Handled_Statement_Sequence (N), 't', Current_Scope);
Update_Use_Clause_Chain;
End_Scope;
@@ -5409,17 +5402,9 @@ package body Sem_Ch6 is
-- we have a special test to set X as apparently assigned to suppress
-- the warning.
- -- If X above is controlled, we need to use First_Real_Statement to skip
- -- generated finalization-related code. Otherwise (First_Real_Statement
- -- is Empty), we just get the first statement.
-
declare
- Stm : Node_Id := First_Real_Statement (HSS);
+ Stm : Node_Id := First (Statements (Handled_Statement_Sequence (N)));
begin
- if No (Stm) then
- Stm := First (Statements (HSS));
- end if;
-
-- Skip call markers installed by the ABE mechanism, labels, and
-- Push_xxx_Error_Label to find the first real statement.
@@ -5519,12 +5504,22 @@ package body Sem_Ch6 is
-- Check references of the subprogram spec when we are dealing with
-- an expression function due to it having a generated body.
- -- Otherwise, we simply check the formals of the subprogram body.
if Present (Spec_Id)
and then Is_Expression_Function (Spec_Id)
then
Check_References (Spec_Id);
+
+ -- Skip the check for subprograms generated for protected subprograms
+ -- because it is also done for the protected subprograms themselves.
+
+ elsif Present (Spec_Id)
+ and then Present (Protected_Subprogram (Spec_Id))
+ then
+ null;
+
+ -- Otherwise, we simply check the formals of the subprogram body.
+
else
Check_References (Body_Id);
end if;
diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb
index 2f8f01b..cae0f23 100644
--- a/gcc/ada/sem_ch9.adb
+++ b/gcc/ada/sem_ch9.adb
@@ -27,7 +27,6 @@ with Aspects; use Aspects;
with Atree; use Atree;
with Checks; use Checks;
with Contracts; use Contracts;
-with Debug; use Debug;
with Einfo; use Einfo;
with Einfo.Entities; use Einfo.Entities;
with Einfo.Utils; use Einfo.Utils;
@@ -65,6 +64,7 @@ with Sinfo; use Sinfo;
with Sinfo.Nodes; use Sinfo.Nodes;
with Sinfo.Utils; use Sinfo.Utils;
with Style;
+with Targparm; use Targparm;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
@@ -140,14 +140,6 @@ package body Sem_Ch9 is
pragma Assert
(Nkind (N) in N_Protected_Type_Declaration | N_Protected_Body);
- -- The lock-free implementation is currently enabled through a debug
- -- flag. When Lock_Free_Given is True, an aspect Lock_Free forces the
- -- lock-free implementation. In that case, the debug flag is not needed.
-
- if not Lock_Free_Given and then not Debug_Flag_9 then
- return False;
- end if;
-
-- Get the number of errors detected by the compiler so far
if Lock_Free_Given then
@@ -215,6 +207,27 @@ package body Sem_Ch9 is
Next (Par);
end loop;
end;
+
+ elsif Nkind (Decl) = N_Subprogram_Declaration
+ and then
+ Nkind (Specification (Decl)) = N_Function_Specification
+ and then
+ Nkind (Result_Definition (Specification (Decl)))
+ in N_Has_Entity
+ and then
+ Needs_Secondary_Stack
+ (Entity (Result_Definition (Specification (Decl))))
+ then
+ if Lock_Free_Given then
+ -- Message text is imprecise; "unconstrained" is
+ -- similar to "needs secondary stack" but not identical.
+ Error_Msg_N
+ ("unconstrained function result subtype not allowed "
+ & "when Lock_Free given",
+ Decl);
+ else
+ return False;
+ end if;
end if;
-- Examine private declarations after visible declarations
@@ -254,11 +267,6 @@ package body Sem_Ch9 is
function Satisfies_Lock_Free_Requirements
(Sub_Body : Node_Id) return Boolean
is
- Is_Procedure : constant Boolean :=
- Ekind (Corresponding_Spec (Sub_Body)) =
- E_Procedure;
- -- Indicates if Sub_Body is a procedure body
-
Comp : Entity_Id := Empty;
-- Track the current component which the body references
@@ -338,222 +346,220 @@ package body Sem_Ch9 is
-- Start of processing for Check_Node
begin
- if Is_Procedure then
- -- Allocators restricted
-
- if Kind = N_Allocator then
- if Lock_Free_Given then
- Error_Msg_N ("allocator not allowed", N);
- return Skip;
- end if;
+ -- Allocators restricted
- return Abandon;
+ if Kind = N_Allocator then
+ if Lock_Free_Given then
+ Error_Msg_N ("allocator not allowed", N);
+ return Skip;
+ end if;
- -- Aspects Address, Export and Import restricted
+ return Abandon;
- elsif Kind = N_Aspect_Specification then
- declare
- Asp_Name : constant Name_Id :=
- Chars (Identifier (N));
- Asp_Id : constant Aspect_Id :=
- Get_Aspect_Id (Asp_Name);
+ -- Aspects Address, Export and Import restricted
- begin
- if Asp_Id = Aspect_Address or else
- Asp_Id = Aspect_Export or else
- Asp_Id = Aspect_Import
- then
- Error_Msg_Name_1 := Asp_Name;
+ elsif Kind = N_Aspect_Specification then
+ declare
+ Asp_Name : constant Name_Id :=
+ Chars (Identifier (N));
+ Asp_Id : constant Aspect_Id :=
+ Get_Aspect_Id (Asp_Name);
- if Lock_Free_Given then
- Error_Msg_N ("aspect% not allowed", N);
- return Skip;
- end if;
+ begin
+ if Asp_Id = Aspect_Address or else
+ Asp_Id = Aspect_Export or else
+ Asp_Id = Aspect_Import
+ then
+ Error_Msg_Name_1 := Asp_Name;
- return Abandon;
+ if Lock_Free_Given then
+ Error_Msg_N ("aspect% not allowed", N);
+ return Skip;
end if;
- end;
- -- Address attribute definition clause restricted
+ return Abandon;
+ end if;
+ end;
- elsif Kind = N_Attribute_Definition_Clause
- and then Get_Attribute_Id (Chars (N)) =
- Attribute_Address
- then
- Error_Msg_Name_1 := Chars (N);
+ -- Address attribute definition clause restricted
- if Lock_Free_Given then
- if From_Aspect_Specification (N) then
- Error_Msg_N ("aspect% not allowed", N);
- else
- Error_Msg_N ("% clause not allowed", N);
- end if;
+ elsif Kind = N_Attribute_Definition_Clause
+ and then Get_Attribute_Id (Chars (N)) =
+ Attribute_Address
+ then
+ Error_Msg_Name_1 := Chars (N);
- return Skip;
+ if Lock_Free_Given then
+ if From_Aspect_Specification (N) then
+ Error_Msg_N ("aspect% not allowed", N);
+ else
+ Error_Msg_N ("% clause not allowed", N);
end if;
- return Abandon;
+ return Skip;
+ end if;
- -- Non-static Attribute references that don't denote a
- -- static function restricted.
+ return Abandon;
- elsif Kind = N_Attribute_Reference
- and then not Is_OK_Static_Expression (N)
- and then not Is_Static_Function (N)
- then
- if Lock_Free_Given then
- Error_Msg_N
- ("non-static attribute reference not allowed", N);
- return Skip;
- end if;
+ -- Non-static Attribute references that don't denote a
+ -- static function restricted.
- return Abandon;
+ elsif Kind = N_Attribute_Reference
+ and then not Is_OK_Static_Expression (N)
+ and then not Is_Static_Function (N)
+ then
+ if Lock_Free_Given then
+ Error_Msg_N
+ ("non-static attribute reference not allowed", N);
+ return Skip;
+ end if;
- -- Delay statements restricted
+ return Abandon;
- elsif Kind in N_Delay_Statement then
- if Lock_Free_Given then
- Error_Msg_N ("delay not allowed", N);
- return Skip;
- end if;
+ -- Delay statements restricted
- return Abandon;
+ elsif Kind in N_Delay_Statement then
+ if Lock_Free_Given then
+ Error_Msg_N ("delay not allowed", N);
+ return Skip;
+ end if;
- -- Dereferences of access values restricted
+ return Abandon;
- elsif Kind = N_Explicit_Dereference
- or else (Kind = N_Selected_Component
- and then Is_Access_Type (Etype (Prefix (N))))
- then
- if Lock_Free_Given then
- Error_Msg_N
- ("dereference of access value not allowed", N);
- return Skip;
- end if;
+ -- Dereferences of access values restricted
- return Abandon;
+ elsif Kind = N_Explicit_Dereference
+ or else (Kind = N_Selected_Component
+ and then Is_Access_Type (Etype (Prefix (N))))
+ then
+ if Lock_Free_Given then
+ Error_Msg_N
+ ("dereference of access value not allowed", N);
+ return Skip;
+ end if;
- -- Non-static function calls restricted
+ return Abandon;
- elsif Kind = N_Function_Call
- and then not Is_OK_Static_Expression (N)
- then
- if Lock_Free_Given then
- Error_Msg_N
- ("non-static function call not allowed", N);
- return Skip;
- end if;
+ -- Non-static function calls restricted
- return Abandon;
+ elsif Kind = N_Function_Call
+ and then not Is_OK_Static_Expression (N)
+ then
+ if Lock_Free_Given then
+ Error_Msg_N
+ ("non-static function call not allowed", N);
+ return Skip;
+ end if;
- -- Goto statements restricted
+ return Abandon;
- elsif Kind = N_Goto_Statement then
- if Lock_Free_Given then
- Error_Msg_N ("goto statement not allowed", N);
- return Skip;
- end if;
+ -- Goto statements restricted
- return Abandon;
+ elsif Kind = N_Goto_Statement then
+ if Lock_Free_Given then
+ Error_Msg_N ("goto statement not allowed", N);
+ return Skip;
+ end if;
- -- References
+ return Abandon;
- elsif Kind = N_Identifier
- and then Present (Entity (N))
- then
- declare
- Id : constant Entity_Id := Entity (N);
- Sub_Id : constant Entity_Id :=
- Corresponding_Spec (Sub_Body);
+ -- References
- begin
- -- Prohibit references to non-constant entities
- -- outside the protected subprogram scope.
-
- if Ekind (Id) in Assignable_Kind
- and then not
- Scope_Within_Or_Same (Scope (Id), Sub_Id)
- and then not
- Scope_Within_Or_Same
- (Scope (Id),
- Protected_Body_Subprogram (Sub_Id))
- then
- if Lock_Free_Given then
- Error_Msg_NE
- ("reference to global variable& not " &
- "allowed", N, Id);
- return Skip;
- end if;
+ elsif Kind = N_Identifier
+ and then Present (Entity (N))
+ then
+ declare
+ Id : constant Entity_Id := Entity (N);
+ Sub_Id : constant Entity_Id :=
+ Corresponding_Spec (Sub_Body);
- return Abandon;
+ begin
+ -- Prohibit references to non-constant entities
+ -- outside the protected subprogram scope.
+
+ if Ekind (Id) in Assignable_Kind
+ and then not
+ Scope_Within_Or_Same (Scope (Id), Sub_Id)
+ and then not
+ Scope_Within_Or_Same
+ (Scope (Id),
+ Protected_Body_Subprogram (Sub_Id))
+ then
+ if Lock_Free_Given then
+ Error_Msg_NE
+ ("reference to global variable& not " &
+ "allowed", N, Id);
+ return Skip;
end if;
- end;
-
- -- Loop statements restricted
- elsif Kind = N_Loop_Statement then
- if Lock_Free_Given then
- Error_Msg_N ("loop not allowed", N);
- return Skip;
+ return Abandon;
end if;
+ end;
- return Abandon;
+ -- Loop statements restricted
- -- Pragmas Export and Import restricted
+ elsif Kind = N_Loop_Statement then
+ if Lock_Free_Given then
+ Error_Msg_N ("loop not allowed", N);
+ return Skip;
+ end if;
- elsif Kind = N_Pragma then
- declare
- Prag_Name : constant Name_Id :=
- Pragma_Name (N);
- Prag_Id : constant Pragma_Id :=
- Get_Pragma_Id (Prag_Name);
+ return Abandon;
- begin
- if Prag_Id = Pragma_Export
- or else Prag_Id = Pragma_Import
- then
- Error_Msg_Name_1 := Prag_Name;
+ -- Pragmas Export and Import restricted
- if Lock_Free_Given then
- if From_Aspect_Specification (N) then
- Error_Msg_N ("aspect% not allowed", N);
- else
- Error_Msg_N ("pragma% not allowed", N);
- end if;
+ elsif Kind = N_Pragma then
+ declare
+ Prag_Name : constant Name_Id :=
+ Pragma_Name (N);
+ Prag_Id : constant Pragma_Id :=
+ Get_Pragma_Id (Prag_Name);
+
+ begin
+ if Prag_Id = Pragma_Export
+ or else Prag_Id = Pragma_Import
+ then
+ Error_Msg_Name_1 := Prag_Name;
- return Skip;
+ if Lock_Free_Given then
+ if From_Aspect_Specification (N) then
+ Error_Msg_N ("aspect% not allowed", N);
+ else
+ Error_Msg_N ("pragma% not allowed", N);
end if;
- return Abandon;
+ return Skip;
end if;
- end;
- -- Procedure call statements restricted
-
- elsif Kind = N_Procedure_Call_Statement then
- if Lock_Free_Given then
- Error_Msg_N ("procedure call not allowed", N);
- return Skip;
+ return Abandon;
end if;
+ end;
- return Abandon;
+ -- Procedure call statements restricted
- -- Quantified expression restricted. Note that we have
- -- to check the original node as well, since at this
- -- stage, it may have been rewritten.
+ elsif Kind = N_Procedure_Call_Statement then
+ if Lock_Free_Given then
+ Error_Msg_N ("procedure call not allowed", N);
+ return Skip;
+ end if;
- elsif Kind = N_Quantified_Expression
- or else
- Nkind (Original_Node (N)) = N_Quantified_Expression
- then
- if Lock_Free_Given then
- Error_Msg_N
- ("quantified expression not allowed", N);
- return Skip;
- end if;
+ return Abandon;
- return Abandon;
+ -- Quantified expression restricted. Note that we have
+ -- to check the original node as well, since at this
+ -- stage, it may have been rewritten.
+
+ elsif Kind = N_Quantified_Expression
+ or else
+ Nkind (Original_Node (N)) = N_Quantified_Expression
+ then
+ if Lock_Free_Given then
+ Error_Msg_N
+ ("quantified expression not allowed", N);
+ return Skip;
end if;
+
+ return Abandon;
end if;
-- A protected subprogram (function or procedure) may
@@ -644,6 +650,35 @@ package body Sem_Ch9 is
-- Start of processing for Satisfies_Lock_Free_Requirements
begin
+ if not Support_Atomic_Primitives_On_Target then
+ if Lock_Free_Given then
+ Error_Msg_N
+ ("Lock_Free aspect requires target support for "
+ & "atomic primitives", N);
+ end if;
+ return False;
+ end if;
+
+ -- Deal with case where Ceiling_Locking locking policy is
+ -- in effect.
+
+ if Locking_Policy = 'C' then
+ if Lock_Free_Given then
+ -- Explicit Lock_Free aspect spec overrides
+ -- Ceiling_Locking so we generate a warning.
+
+ Error_Msg_N
+ ("Lock_Free aspect specification overrides "
+ & "Ceiling_Locking locking policy??", N);
+ else
+ -- If Ceiling_Locking locking policy is in effect, then
+ -- Lock_Free can be explicitly specified but it is
+ -- never the default.
+
+ return False;
+ end if;
+ end if;
+
-- Get the number of errors detected by the compiler so far
if Lock_Free_Given then
diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb
index b8e3fb6..f912f8b 100644
--- a/gcc/ada/sem_elab.adb
+++ b/gcc/ada/sem_elab.adb
@@ -1809,11 +1809,6 @@ package body Sem_Elab is
-- Determine whether arbitrary entity Id denotes a partial invariant
-- procedure.
- function Is_Postconditions_Proc (Id : Entity_Id) return Boolean;
- pragma Inline (Is_Postconditions_Proc);
- -- Determine whether arbitrary entity Id denotes internally generated
- -- routine _Postconditions.
-
function Is_Preelaborated_Unit (Id : Entity_Id) return Boolean;
pragma Inline (Is_Preelaborated_Unit);
-- Determine whether arbitrary entity Id denotes a unit which is subject
@@ -2481,14 +2476,6 @@ package body Sem_Elab is
elsif Is_Partial_Invariant_Proc (Subp_Id) then
null;
- -- _Postconditions
-
- elsif Is_Postconditions_Proc (Subp_Id) then
- Output_Verification_Call
- (Pred => "postconditions",
- Id => Find_Enclosing_Scope (Call),
- Id_Kind => "subprogram");
-
-- Subprograms must come last because some of the previous cases fall
-- under this category.
@@ -6638,14 +6625,6 @@ package body Sem_Elab is
elsif Is_Partial_Invariant_Proc (Subp_Id) then
null;
- -- _Postconditions
-
- elsif Is_Postconditions_Proc (Subp_Id) then
- Info_Verification_Call
- (Pred => "postconditions",
- Id => Find_Enclosing_Scope (Call),
- Id_Kind => "subprogram");
-
-- Subprograms must come last because some of the previous cases
-- fall under this category.
@@ -13091,10 +13070,6 @@ package body Sem_Elab is
(Extra : out Entity_Id;
Kind : out Invocation_Kind)
is
- Targ_Rep : constant Target_Rep_Id :=
- Target_Representation_Of (Targ_Id, In_State);
- Spec_Decl : constant Node_Id := Spec_Declaration (Targ_Rep);
-
begin
-- Accept within a task body
@@ -13180,12 +13155,6 @@ package body Sem_Elab is
Extra := First_Formal_Type (Targ_Id);
Kind := Invariant_Verification;
- -- Postcondition verification
-
- elsif Is_Postconditions_Proc (Targ_Id) then
- Extra := Find_Enclosing_Scope (Spec_Decl);
- Kind := Postcondition_Verification;
-
-- Protected entry call
elsif Is_Protected_Entry (Targ_Id) then
@@ -14454,8 +14423,7 @@ package body Sem_Elab is
Is_Default_Initial_Condition_Proc (Id)
or else Is_Initial_Condition_Proc (Id)
or else Is_Invariant_Proc (Id)
- or else Is_Partial_Invariant_Proc (Id)
- or else Is_Postconditions_Proc (Id);
+ or else Is_Partial_Invariant_Proc (Id);
end Is_Assertion_Pragma_Target;
----------------------------
@@ -14497,7 +14465,6 @@ package body Sem_Elab is
Is_Accept_Alternative_Proc (Id)
or else Is_Finalizer_Proc (Id)
or else Is_Partial_Invariant_Proc (Id)
- or else Is_Postconditions_Proc (Id)
or else Is_TSS (Id, TSS_Deep_Adjust)
or else Is_TSS (Id, TSS_Deep_Finalize)
or else Is_TSS (Id, TSS_Deep_Initialize);
@@ -14653,18 +14620,6 @@ package body Sem_Elab is
and then Is_Partial_Invariant_Procedure (Id);
end Is_Partial_Invariant_Proc;
- ----------------------------
- -- Is_Postconditions_Proc --
- ----------------------------
-
- function Is_Postconditions_Proc (Id : Entity_Id) return Boolean is
- begin
- -- To qualify, the entity must denote a _Postconditions procedure
-
- return
- Ekind (Id) = E_Procedure and then Chars (Id) = Name_uPostconditions;
- end Is_Postconditions_Proc;
-
---------------------------
-- Is_Preelaborated_Unit --
---------------------------
@@ -17482,7 +17437,7 @@ package body Sem_Elab is
if Nkind (N) = N_Procedure_Call_Statement
and then Is_Entity_Name (Name (N))
- and then Chars (Entity (Name (N))) = Name_uPostconditions
+ and then Chars (Entity (Name (N))) = Name_uWrapped_Statements
then
return;
end if;
diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
index df3d348..77ff68e 100644
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -5548,6 +5548,14 @@ package body Sem_Prag is
then
OK := True;
+ -- Special case for postconditions wrappers
+
+ elsif Ekind (Scop) in Subprogram_Kind
+ and then Present (Wrapped_Statements (Scop))
+ and then Wrapped_Statements (Scop) = Current_Scope
+ then
+ OK := True;
+
-- Default case, just check that the pragma occurs in the scope
-- of the entity denoted by the name.
@@ -9430,8 +9438,8 @@ package body Sem_Prag is
-- If the pragma comes from an aspect specification, there
-- must be an Import aspect specified as well. In the rare
- -- case where Import is set to False, the suprogram needs to
- -- have a local completion.
+ -- case where Import is set to False, the subprogram needs
+ -- to have a local completion.
declare
Imp_Aspect : constant Node_Id :=
@@ -20139,7 +20147,7 @@ package body Sem_Prag is
end loop;
-- If entity in not in current scope it may be the enclosing
- -- suprogram body to which the aspect applies.
+ -- subprogram body to which the aspect applies.
if not Found then
if Entity (Id) = Current_Scope
@@ -23168,7 +23176,7 @@ package body Sem_Prag is
-- SPARK_Mode --
----------------
- -- pragma SPARK_Mode [(On | Off)];
+ -- pragma SPARK_Mode [(Auto | On | Off)];
when Pragma_SPARK_Mode => Do_SPARK_Mode : declare
Mode_Id : SPARK_Mode_Type;
@@ -23654,7 +23662,7 @@ package body Sem_Prag is
-- Check the legality of the mode (no argument = ON)
if Arg_Count = 1 then
- Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
+ Check_Arg_Is_One_Of (Arg1, Name_Auto, Name_On, Name_Off);
Mode := Chars (Get_Pragma_Arg (Arg1));
else
Mode := Name_On;
@@ -23705,6 +23713,15 @@ package body Sem_Prag is
-- the pragma resides to find a potential construct.
else
+ -- An explicit mode of Auto is only allowed as a configuration
+ -- pragma. Escape "pragma" to avoid replacement with "aspect".
+
+ if Mode_Id = None then
+ Error_Pragma_Arg
+ ("only configuration 'p'r'a'g'm'a% can have value &",
+ Arg1);
+ end if;
+
Stmt := Prev (N);
while Present (Stmt) loop
@@ -26138,12 +26155,9 @@ package body Sem_Prag is
if Class_Present (N) then
-- Verify that a class-wide condition is legal, i.e. the operation is
- -- a primitive of a tagged type. Note that a generic subprogram is
- -- not a primitive operation.
-
- Disp_Typ := Find_Dispatching_Type (Spec_Id);
+ -- a primitive of a tagged type.
- if No (Disp_Typ) or else Is_Generic_Subprogram (Spec_Id) then
+ if not Is_Dispatching_Operation (Spec_Id) then
Error_Msg_Name_1 := Original_Aspect_Pragma_Name (N);
if From_Aspect_Specification (N) then
@@ -26162,6 +26176,7 @@ package body Sem_Prag is
-- Remaining semantic checks require a full tree traversal
else
+ Disp_Typ := Find_Dispatching_Type (Spec_Id);
Check_Class_Wide_Condition (Expr);
end if;
@@ -31157,23 +31172,26 @@ package body Sem_Prag is
end if;
end Get_Base_Subprogram;
- -----------------------
+ -------------------------
-- Get_SPARK_Mode_Type --
- -----------------------
+ -------------------------
function Get_SPARK_Mode_Type (N : Name_Id) return SPARK_Mode_Type is
begin
- if N = Name_On then
- return On;
- elsif N = Name_Off then
- return Off;
+ case N is
+ when Name_Auto =>
+ return None;
+ when Name_On =>
+ return On;
+ when Name_Off =>
+ return Off;
- -- Any other argument is illegal. Assume that no SPARK mode applies to
- -- avoid potential cascaded errors.
+ -- Any other argument is illegal. Assume that no SPARK mode applies
+ -- to avoid potential cascaded errors.
- else
- return None;
- end if;
+ when others =>
+ return None;
+ end case;
end Get_SPARK_Mode_Type;
------------------------------------
@@ -32238,10 +32256,10 @@ package body Sem_Prag is
then
return;
- -- Do not process internally generated routine _Postconditions
+ -- Do not process internally generated routine _Wrapped_Statements
elsif Ekind (Body_Id) = E_Procedure
- and then Chars (Body_Id) = Name_uPostconditions
+ and then Chars (Body_Id) = Name_uWrapped_Statements
then
return;
end if;
diff --git a/gcc/ada/sem_prag.ads b/gcc/ada/sem_prag.ads
index e8a65ce..619f841 100644
--- a/gcc/ada/sem_prag.ads
+++ b/gcc/ada/sem_prag.ads
@@ -156,6 +156,9 @@ package Sem_Prag is
Pragma_Type_Invariant_Class => True,
others => False);
+ -- Should to following constant arrays be renamed to better suit their
+ -- use as a predicate (e.g. Is_Pragma_*) ???
+
-- The following table lists all the implementation-defined pragmas that
-- should apply to the anonymous object produced by the analysis of a
-- single protected or task type. The table should be synchronized with
@@ -200,6 +203,32 @@ package Sem_Prag is
Pragma_Warnings => False,
others => True);
+ -- The following table lists all pragmas which are relevant to the analysis
+ -- of subprogram bodies.
+
+ Pragma_Significant_To_Subprograms : constant array (Pragma_Id) of Boolean :=
+ (Pragma_Contract_Cases => True,
+ Pragma_Depends => True,
+ Pragma_Ghost => True,
+ Pragma_Global => True,
+ Pragma_Inline => True,
+ Pragma_Inline_Always => True,
+ Pragma_Post => True,
+ Pragma_Post_Class => True,
+ Pragma_Postcondition => True,
+ Pragma_Pre => True,
+ Pragma_Pre_Class => True,
+ Pragma_Precondition => True,
+ Pragma_Pure => True,
+ Pragma_Pure_Function => True,
+ Pragma_Refined_Depends => True,
+ Pragma_Refined_Global => True,
+ Pragma_Refined_Post => True,
+ Pragma_Refined_State => True,
+ Pragma_Volatile => True,
+ Pragma_Volatile_Function => True,
+ others => False);
+
-----------------
-- Subprograms --
-----------------
diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index f618467..7675070 100644
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -8412,6 +8412,7 @@ package body Sem_Res is
if Is_Entry (Nam)
and then Present (Contract_Wrapper (Nam))
and then Current_Scope /= Contract_Wrapper (Nam)
+ and then Current_Scope /= Wrapped_Statements (Contract_Wrapper (Nam))
then
-- Note the entity being called before rewriting the call, so that
-- it appears used at this point.
@@ -8876,6 +8877,20 @@ package body Sem_Res is
end if;
else
+
+ -- For Ada 2022, check for user-defined literals when the type has
+ -- the appropriate aspect.
+
+ if Has_Applicable_User_Defined_Literal (L, Etype (R)) then
+ Resolve (L, Etype (R));
+ Set_Etype (N, Standard_Boolean);
+ end if;
+
+ if Has_Applicable_User_Defined_Literal (R, Etype (L)) then
+ Resolve (R, Etype (L));
+ Set_Etype (N, Standard_Boolean);
+ end if;
+
-- Deal with other error cases
if T = Any_String or else
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index ecfb49a..b0babeb 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -316,8 +316,20 @@ package body Sem_Util is
-- Ignore transient scopes made during expansion
if Comes_From_Source (Node_Par) then
- return
- Scope_Depth (Encl_Scop) + Master_Lvl_Modifier;
+ -- Note that in some rare cases the scope depth may not be
+ -- set, for example, when we are in the middle of analyzing
+ -- a type and the enclosing scope is said type. So, instead,
+ -- continue to move up the parent chain since the scope
+ -- depth of the type's parent is the same as that of the
+ -- type.
+
+ if not Scope_Depth_Set (Encl_Scop) then
+ pragma Assert (Nkind (Parent (Encl_Scop))
+ = N_Full_Type_Declaration);
+ else
+ return
+ Scope_Depth (Encl_Scop) + Master_Lvl_Modifier;
+ end if;
end if;
-- For a return statement within a function, return
@@ -597,6 +609,7 @@ package body Sem_Util is
-- Anonymous access types
elsif Nkind (Pre) in N_Has_Entity
+ and then Ekind (Entity (Pre)) not in Subprogram_Kind
and then Present (Get_Dynamic_Accessibility (Entity (Pre)))
and then Level = Dynamic_Level
then
@@ -6691,8 +6704,6 @@ package body Sem_Util is
Wmsg : Boolean;
Eloc : Source_Ptr;
- -- Start of processing for Compile_Time_Constraint_Error
-
begin
-- If this is a warning, convert it into an error if we are in code
-- subject to SPARK_Mode being set On, unless Warn is True to force a
@@ -7184,7 +7195,51 @@ package body Sem_Util is
Typ : constant Entity_Id := Find_Dispatching_Type (Ancestor_Op);
Elmt : Elmt_Id;
Subp : Entity_Id;
- Prim : Entity_Id;
+
+ function Profile_Matches_Ancestor (S : Entity_Id) return Boolean;
+ -- Returns True if subprogram S has the proper profile for an
+ -- overriding of Ancestor_Op (that is, corresponding formals either
+ -- have the same type, or are corresponding controlling formals,
+ -- and similarly for result types).
+
+ ------------------------------
+ -- Profile_Matches_Ancestor --
+ ------------------------------
+
+ function Profile_Matches_Ancestor (S : Entity_Id) return Boolean is
+ F1 : Entity_Id := First_Formal (Ancestor_Op);
+ F2 : Entity_Id := First_Formal (S);
+
+ begin
+ if Ekind (Ancestor_Op) /= Ekind (S) then
+ return False;
+ end if;
+
+ -- ??? This should probably account for anonymous access formals,
+ -- but the parent function (Corresponding_Primitive_Op) is currently
+ -- only called for user-defined literal functions, which can't have
+ -- such formals. But if this is ever used in a more general context
+ -- it should be extended to handle such formals (and result types).
+
+ while Present (F1) and then Present (F2) loop
+ if Etype (F1) = Etype (F2)
+ or else Is_Ancestor (Typ, Etype (F2))
+ then
+ Next_Formal (F1);
+ Next_Formal (F2);
+ else
+ return False;
+ end if;
+ end loop;
+
+ return No (F1)
+ and then No (F2)
+ and then (Etype (Ancestor_Op) = Etype (S)
+ or else Is_Ancestor (Typ, Etype (S)));
+ end Profile_Matches_Ancestor;
+
+ -- Start of processing for Corresponding_Primitive_Op
+
begin
pragma Assert (Is_Dispatching_Operation (Ancestor_Op));
pragma Assert (Is_Ancestor (Typ, Descendant_Type)
@@ -7195,12 +7250,12 @@ package body Sem_Util is
while Present (Elmt) loop
Subp := Node (Elmt);
- -- For regular primitives we only need to traverse the chain of
- -- ancestors when the name matches the name of Ancestor_Op, but
- -- for predefined dispatching operations we cannot rely on the
- -- name of the primitive to identify a candidate since their name
- -- is internally built adding a suffix to the name of the tagged
- -- type.
+ -- For regular primitives we need to check the profile against
+ -- the ancestor when the name matches the name of Ancestor_Op,
+ -- but for predefined dispatching operations we cannot rely on
+ -- the name of the primitive to identify a candidate since their
+ -- name is internally built by adding a suffix to the name of the
+ -- tagged type.
if Chars (Subp) = Chars (Ancestor_Op)
or else Is_Predefined_Dispatching_Operation (Subp)
@@ -7216,26 +7271,10 @@ package body Sem_Util is
return Alias (Subp);
end if;
- -- Traverse the chain of ancestors searching for Ancestor_Op.
- -- Overridden primitives have attribute Overridden_Operation;
- -- inherited primitives have attribute Alias.
-
- else
- Prim := Subp;
-
- while Present (Overridden_Operation (Prim))
- or else Present (Alias (Prim))
- loop
- if Present (Overridden_Operation (Prim)) then
- Prim := Overridden_Operation (Prim);
- else
- Prim := Alias (Prim);
- end if;
+ -- Otherwise, return subprogram when profile matches its ancestor
- if Prim = Ancestor_Op then
- return Subp;
- end if;
- end loop;
+ elsif Profile_Matches_Ancestor (Subp) then
+ return Subp;
end if;
end if;
@@ -10894,7 +10933,7 @@ package body Sem_Util is
-- First.
Assoc := First (Component_Associations (Expression (Aspect)));
- First_Op := Any_Id;
+ First_Op := Any_Id;
while Present (Assoc) loop
if Chars (First (Choices (Assoc))) = Name_First then
First_Op := Expression (Assoc);
@@ -14096,9 +14135,10 @@ package body Sem_Util is
if Subp_Nam = Name_uFinalizer then
return False;
- -- _Postconditions procedure
+ -- _Wrapped_Statements procedure which gets generated as part of the
+ -- expansion of postconditions.
- elsif Subp_Nam = Name_uPostconditions then
+ elsif Subp_Nam = Name_uWrapped_Statements then
return False;
-- Predicate function
@@ -21622,8 +21662,22 @@ package body Sem_Util is
N_String_Literal => Aspect_String_Literal);
begin
- return Nkind (N) in N_Numeric_Or_String_Literal
- and then Present (Find_Aspect (Typ, Literal_Aspect_Map (Nkind (N))));
+ -- Return True when N is either a literal or a named number and the
+ -- type has the appropriate user-defined literal aspect.
+
+ return (Nkind (N) in N_Numeric_Or_String_Literal
+ and then Present (Find_Aspect (Typ, Literal_Aspect_Map (Nkind (N)))))
+ or else
+ (Is_Entity_Name (N)
+ and then Present (Entity (N))
+ and then
+ ((Ekind (Entity (N)) = E_Named_Integer
+ and then
+ Present (Find_Aspect (Typ, Aspect_Integer_Literal)))
+ or else
+ (Ekind (Entity (N)) = E_Named_Real
+ and then
+ Present (Find_Aspect (Typ, Aspect_Real_Literal)))));
end Is_User_Defined_Literal;
--------------------------------------
@@ -22900,6 +22954,7 @@ package body Sem_Util is
| N_Function_Call
| N_Raise_Statement
| N_Raise_xxx_Error
+ | N_Raise_Expression
then
Result := True;
return Abandon;
@@ -24049,13 +24104,6 @@ package body Sem_Util is
pragma Inline (Update_CFS_Sloc);
-- Update the Comes_From_Source and Sloc attributes of node or entity N
- procedure Update_First_Real_Statement
- (Old_HSS : Node_Id;
- New_HSS : Node_Id);
- pragma Inline (Update_First_Real_Statement);
- -- Update semantic attribute First_Real_Statement of handled sequence of
- -- statements New_HSS based on handled sequence of statements Old_HSS.
-
procedure Update_Named_Associations
(Old_Call : Node_Id;
New_Call : Node_Id);
@@ -24570,14 +24618,6 @@ package body Sem_Util is
Set_Renamed_Object_Of_Possibly_Void
(Defining_Entity (Result), Name (Result));
- -- Update the First_Real_Statement attribute of a replicated
- -- handled sequence of statements.
-
- elsif Nkind (N) = N_Handled_Sequence_Of_Statements then
- Update_First_Real_Statement
- (Old_HSS => N,
- New_HSS => Result);
-
-- Update the Chars attribute of identifiers
elsif Nkind (N) = N_Identifier then
@@ -24680,39 +24720,6 @@ package body Sem_Util is
end if;
end Update_CFS_Sloc;
- ---------------------------------
- -- Update_First_Real_Statement --
- ---------------------------------
-
- procedure Update_First_Real_Statement
- (Old_HSS : Node_Id;
- New_HSS : Node_Id)
- is
- Old_First_Stmt : constant Node_Id := First_Real_Statement (Old_HSS);
-
- New_Stmt : Node_Id;
- Old_Stmt : Node_Id;
-
- begin
- -- Recreate the First_Real_Statement attribute of a handled sequence
- -- of statements by traversing the statement lists of both sequences
- -- in parallel.
-
- if Present (Old_First_Stmt) then
- New_Stmt := First (Statements (New_HSS));
- Old_Stmt := First (Statements (Old_HSS));
- while Present (Old_Stmt) and then Old_Stmt /= Old_First_Stmt loop
- Next (New_Stmt);
- Next (Old_Stmt);
- end loop;
-
- pragma Assert (Present (New_Stmt));
- pragma Assert (Present (Old_Stmt));
-
- Set_First_Real_Statement (New_HSS, New_Stmt);
- end if;
- end Update_First_Real_Statement;
-
-------------------------------
-- Update_Named_Associations --
-------------------------------
@@ -25424,8 +25431,8 @@ package body Sem_Util is
-- * Semantic fields of entities such as Etype and Scope must be
-- updated to reference the proper replicated entities.
- -- * Semantic fields of nodes such as First_Real_Statement must be
- -- updated to reference the proper replicated nodes.
+ -- * Some semantic fields of nodes must be updated to reference
+ -- the proper replicated nodes.
-- Finally, quantified expressions contain an implicit declaration for
-- the bound variable. Given that quantified expressions appearing
@@ -28020,8 +28027,18 @@ package body Sem_Util is
E : Entity_Id) return Boolean
is
Subp_Alias : constant Entity_Id := Alias (S);
+ Subp : Entity_Id := E;
begin
- return S = E or else (Present (Subp_Alias) and then Subp_Alias = E);
+ -- During expansion of subprograms with postconditions the original
+ -- subprogram's declarations and statements get wrapped into a local
+ -- _Wrapped_Statements subprogram.
+
+ if Chars (Subp) = Name_uWrapped_Statements then
+ Subp := Enclosing_Subprogram (Subp);
+ end if;
+
+ return S = Subp
+ or else (Present (Subp_Alias) and then Subp_Alias = Subp);
end Same_Or_Aliased_Subprograms;
---------------
@@ -32469,7 +32486,7 @@ package body Sem_Util is
and then Ekind (Scope (T))
in E_Entry | E_Entry_Family | E_Function | E_Procedure
and then
- (Present (Postconditions_Proc (Scope (T)))
+ (Present (Wrapped_Statements (Scope (T)))
or else Present (Contract (Scope (T))))
then
-- ??? Should define a flag for this. We could incorrectly
diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads
index 9f909e0..132c2b8 100644
--- a/gcc/ada/sem_util.ads
+++ b/gcc/ada/sem_util.ads
@@ -2500,7 +2500,9 @@ package Sem_Util is
(N : Node_Id;
Typ : Entity_Id) return Boolean;
pragma Inline (Is_User_Defined_Literal);
- -- Determine whether N is a user-defined literal for Typ
+ -- Determine whether N is a user-defined literal for Typ, including
+ -- the case where N denotes a named number of the appropriate kind
+ -- when Typ has an Integer_Literal or Real_Literal aspect.
function Is_Validation_Variable_Reference (N : Node_Id) return Boolean;
-- Determine whether N denotes a reference to a variable which captures the
@@ -2743,7 +2745,6 @@ package Sem_Util is
-- fields are recreated after the replication takes place.
--
-- First_Named_Actual
- -- First_Real_Statement
-- Next_Named_Actual
--
-- If applicable, the Etype field (if any) is updated to refer to a
diff --git a/gcc/ada/sinfo-utils.ads b/gcc/ada/sinfo-utils.ads
index 78b2d0e..3f25034 100644
--- a/gcc/ada/sinfo-utils.ads
+++ b/gcc/ada/sinfo-utils.ads
@@ -54,6 +54,12 @@ package Sinfo.Utils is
-- Miscellaneous Tree Access Subprograms --
-------------------------------------------
+ function First_Real_Statement -- ????
+ (Ignored : N_Handled_Sequence_Of_Statements_Id) return Node_Id is (Empty);
+ -- The First_Real_Statement field is going away, but it is referenced in
+ -- codepeer and gnat-llvm. This is a temporary version, always returning
+ -- Empty, to ease the transition.
+
function End_Location (N : Node_Id) return Source_Ptr;
-- N is an N_If_Statement or N_Case_Statement node, and this function
-- returns the location of the IF token in the END IF sequence by
diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads
index fddfc72..53880c5 100644
--- a/gcc/ada/sinfo.ads
+++ b/gcc/ada/sinfo.ads
@@ -82,6 +82,12 @@ package Sinfo is
-- for this purpose, so e.g. in X := (if A then B else C);
-- Paren_Count for the right side will be 1.
+ -- Comes_From_Check_Or_Contract
+ -- This flag is present in all N_If_Statement nodes and
+ -- gets set when an N_If_Statement is generated as part of
+ -- the expansion of a Check, Assert, or contract-related
+ -- pragma.
+
-- Comes_From_Source
-- This flag is present in all nodes. It is set if the
-- node is built by the scanner or parser, and clear if
@@ -891,9 +897,12 @@ package Sinfo is
-- required for the corresponding reference or modification.
-- At_End_Proc
- -- This field is present in an N_Handled_Sequence_Of_Statements node.
+ -- This field is present in N_Handled_Sequence_Of_Statements,
+ -- N_Package_Body, N_Subprogram_Body, N_Task_Body, N_Block_Statement,
+ -- and N_Entry_Body.
-- It contains an identifier reference for the cleanup procedure to be
- -- called. See description of this node for further details.
+ -- called. See description of N_Handled_Sequence_Of_Statements node
+ -- for further details.
-- Backwards_OK
-- A flag present in the N_Assignment_Statement node. It is used only
@@ -1307,15 +1316,6 @@ package Sinfo is
-- named associations). Note: this field points to the explicit actual
-- parameter itself, not the N_Parameter_Association node (its parent).
- -- First_Real_Statement
- -- Present in N_Handled_Sequence_Of_Statements node. Normally set to
- -- Empty. Used only when declarations are moved into the statement part
- -- of a construct as a result of wrapping an AT END handler that is
- -- required to cover the declarations. In this case, this field is used
- -- to remember the location in the statements list of the first real
- -- statement, i.e. the statement that used to be first in the statement
- -- list before the declarations were prepended.
-
-- First_Subtype_Link
-- Present in N_Freeze_Entity node for an anonymous base type that is
-- implicitly created by the declaration of a first subtype. It points
@@ -5167,6 +5167,7 @@ package Sinfo is
-- Is_Finalization_Wrapper
-- Is_Initialization_Block
-- Is_Task_Master
+ -- At_End_Proc (set to Empty if no clean up procedure)
-------------------------
-- 5.7 Exit Statement --
@@ -5686,6 +5687,7 @@ package Sinfo is
-- Handled_Statement_Sequence (set to Empty if no HSS present)
-- Corresponding_Spec
-- Was_Originally_Stub
+ -- At_End_Proc (set to Empty if no clean up procedure)
-- Note: if a source level package does not contain a handled sequence
-- of statements, then the parser supplies a dummy one with a null
@@ -6164,6 +6166,7 @@ package Sinfo is
-- Declarations
-- Handled_Statement_Sequence
-- Activation_Chain_Entity
+ -- At_End_Proc (set to Empty if no clean up procedure)
-----------------------------------
-- 9.5.2 Entry Body Formal Part --
@@ -6715,6 +6718,7 @@ package Sinfo is
-- Corresponding_Spec_Of_Stub
-- Library_Unit points to the subunit
-- Corresponding_Body
+ -- At_End_Proc (set to Empty if no clean up procedure)
-------------------------------
-- 10.1.3 Package Body Stub --
@@ -6745,6 +6749,7 @@ package Sinfo is
-- Corresponding_Spec_Of_Stub
-- Library_Unit points to the subunit
-- Corresponding_Body
+ -- At_End_Proc (set to Empty if no clean up procedure)
---------------------------------
-- 10.1.3 Protected Body Stub --
@@ -6830,6 +6835,11 @@ package Sinfo is
-- declarations. The big difference is that the cleanup actions occur
-- on either a normal or an abnormal exit from the statement sequence.
+ -- At_End_Proc is also a field of various nodes that can contain
+ -- both Declarations and Handled_Statement_Sequence, such as subprogram
+ -- bodies and block statements. In that case, the At_End_Proc
+ -- protects the Declarations as well as the Handled_Statement_Sequence.
+
-- Note: the list of Exception_Handlers can contain pragmas as well
-- as actual handlers. In practice these pragmas can only occur at
-- the start of the list, since any pragmas occurring later on will
@@ -6856,7 +6866,6 @@ package Sinfo is
-- End_Label (set to Empty if expander generated)
-- Exception_Handlers (set to No_List if none present)
-- At_End_Proc (set to Empty if no clean up procedure)
- -- First_Real_Statement
-- Note: A Handled_Sequence_Of_Statements can contain both
-- Exception_Handlers and an At_End_Proc.
diff --git a/gcc/ada/snames.adb-tmpl b/gcc/ada/snames.adb-tmpl
index 8701ea9..9b087e6 100644
--- a/gcc/ada/snames.adb-tmpl
+++ b/gcc/ada/snames.adb-tmpl
@@ -256,8 +256,6 @@ package body Snames is
return Pragma_Interface;
when Name_Interrupt_Priority =>
return Pragma_Interrupt_Priority;
- when Name_Lock_Free =>
- return Pragma_Lock_Free;
when Name_Preelaborable_Initialization =>
return Pragma_Preelaborable_Initialization;
when Name_Priority =>
@@ -489,7 +487,6 @@ package body Snames is
or else N = Name_Fast_Math
or else N = Name_Interface
or else N = Name_Interrupt_Priority
- or else N = Name_Lock_Free
or else N = Name_Preelaborable_Initialization
or else N = Name_Priority
or else N = Name_Secondary_Stack_Size
diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl
index 6a16da1..8f71ad9 100644
--- a/gcc/ada/snames.ads-tmpl
+++ b/gcc/ada/snames.ads-tmpl
@@ -190,7 +190,6 @@ package Snames is
Name_uMaster : constant Name_Id := N + $;
Name_uObject : constant Name_Id := N + $;
Name_uPost : constant Name_Id := N + $;
- Name_uPostconditions : constant Name_Id := N + $;
Name_uPostcond_Enabled : constant Name_Id := N + $;
Name_uPre : constant Name_Id := N + $;
Name_uPriority : constant Name_Id := N + $;
@@ -208,6 +207,7 @@ package Snames is
Name_uTask_Name : constant Name_Id := N + $;
Name_uType_Invariant : constant Name_Id := N + $;
Name_uVariants : constant Name_Id := N + $;
+ Name_uWrapped_Statements : constant Name_Id := N + $;
-- Names of predefined primitives used in the expansion of dispatching
-- requeue and select statements, Abort, 'Callable and 'Terminated.
@@ -600,12 +600,7 @@ package Snames is
Name_Linker_Options : constant Name_Id := N + $;
Name_Linker_Section : constant Name_Id := N + $; -- GNAT
Name_List : constant Name_Id := N + $;
-
- -- Note: Lock_Free is not in this list because its name matches the name of
- -- the corresponding attribute. However, it is included in the definition
- -- of the type Pragma_Id and the functions Get_Pragma_Id and Is_Pragma_Name
- -- correctly recognize and process Lock_Free. Lock_Free is a GNAT pragma.
-
+ Name_Lock_Free : constant Name_Id := N + $; -- GNAT
Name_Loop_Invariant : constant Name_Id := N + $; -- GNAT
Name_Loop_Optimize : constant Name_Id := N + $; -- GNAT
Name_Loop_Variant : constant Name_Id := N + $; -- GNAT
@@ -787,6 +782,7 @@ package Snames is
Name_Assertion : constant Name_Id := N + $;
Name_Assertions : constant Name_Id := N + $;
Name_Attribute_Name : constant Name_Id := N + $;
+ Name_Auto : constant Name_Id := N + $;
Name_Body_File_Name : constant Name_Id := N + $;
Name_Boolean_Entry_Barriers : constant Name_Id := N + $;
Name_By_Any : constant Name_Id := N + $;
@@ -978,7 +974,6 @@ package Snames is
Name_Leading_Part : constant Name_Id := N + $;
Name_Length : constant Name_Id := N + $;
Name_Library_Level : constant Name_Id := N + $; -- GNAT
- Name_Lock_Free : constant Name_Id := N + $; -- GNAT
Name_Loop_Entry : constant Name_Id := N + $; -- GNAT
Name_Machine_Emax : constant Name_Id := N + $;
Name_Machine_Emin : constant Name_Id := N + $;
@@ -1503,7 +1498,6 @@ package Snames is
Attribute_Leading_Part,
Attribute_Length,
Attribute_Library_Level,
- Attribute_Lock_Free,
Attribute_Loop_Entry,
Attribute_Machine_Emax,
Attribute_Machine_Emin,
@@ -1889,6 +1883,7 @@ package Snames is
Pragma_Linker_Options,
Pragma_Linker_Section,
Pragma_List,
+ Pragma_Lock_Free,
Pragma_Loop_Invariant,
Pragma_Loop_Optimize,
Pragma_Loop_Variant,
@@ -1981,7 +1976,6 @@ package Snames is
Pragma_Fast_Math,
Pragma_Interface,
Pragma_Interrupt_Priority,
- Pragma_Lock_Free,
Pragma_Preelaborable_Initialization,
Pragma_Priority,
Pragma_Secondary_Stack_Size,
@@ -2073,10 +2067,10 @@ package Snames is
function Is_Pragma_Name (N : Name_Id) return Boolean;
-- Test to see if the name N is the name of a recognized pragma. Note
-- that pragmas CPU, Dispatching_Domain, Fast_Math, Interrupt_Priority,
- -- Lock_Free, Priority, Storage_Size, and Storage_Unit are recognized
- -- as pragmas by this function even though their names are separate from
- -- the other pragma names. For this reason, clients should always use
- -- this function, rather than do range tests on Name_Id values.
+ -- Priority, Storage_Size, and Storage_Unit are recognized as pragmas by
+ -- this function even though their names are separate from the other
+ -- pragma names. For this reason, clients should always use this function,
+ -- rather than do range tests on Name_Id values.
function Is_Configuration_Pragma_Name (N : Name_Id) return Boolean;
-- Test to see if the name N is the name of a recognized configuration
diff --git a/gcc/ada/sprint.adb b/gcc/ada/sprint.adb
index 243d67a..0f292c8 100644
--- a/gcc/ada/sprint.adb
+++ b/gcc/ada/sprint.adb
@@ -199,6 +199,9 @@ package body Sprint is
-- For the case of Semicolon False, no semicolon is removed or output, and
-- all the aspects are printed on a single line.
+ procedure Sprint_At_End_Proc (Node : Node_Id);
+ -- Print At_End_Proc attribute if present
+
procedure Sprint_Bar_List (List : List_Id);
-- Print the given list with items separated by vertical bars
@@ -750,6 +753,22 @@ package body Sprint is
end if;
end Sprint_Aspect_Specifications;
+ ------------------------
+ -- Sprint_At_End_Proc --
+ ------------------------
+
+ procedure Sprint_At_End_Proc (Node : Node_Id) is
+ begin
+ if Present (At_End_Proc (Node)) then
+ Write_Indent_Str ("at end");
+ Indent_Begin;
+ Write_Indent;
+ Sprint_Node (At_End_Proc (Node));
+ Write_Char (';');
+ Indent_End;
+ end if;
+ end Sprint_At_End_Proc;
+
---------------------
-- Sprint_Bar_List --
---------------------
@@ -1226,6 +1245,7 @@ package body Sprint is
end if;
Write_Char (';');
+ Sprint_At_End_Proc (Node);
when N_Call_Marker =>
null;
@@ -1646,6 +1666,7 @@ package body Sprint is
Write_Indent_Str ("end ");
Write_Id (Defining_Identifier (Node));
Write_Char (';');
+ Sprint_At_End_Proc (Node);
when N_Entry_Body_Formal_Part =>
if Present (Entry_Index_Specification (Node)) then
@@ -2164,14 +2185,7 @@ package body Sprint is
Indent_End;
end if;
- if Present (At_End_Proc (Node)) then
- Write_Indent_Str ("at end");
- Indent_Begin;
- Write_Indent;
- Sprint_Node (At_End_Proc (Node));
- Write_Char (';');
- Indent_End;
- end if;
+ Sprint_At_End_Proc (Node);
when N_Identifier =>
Set_Debug_Sloc;
@@ -2699,6 +2713,7 @@ package body Sprint is
Sprint_End_Label
(Handled_Statement_Sequence (Node), Defining_Unit_Name (Node));
Write_Char (';');
+ Sprint_At_End_Proc (Node);
when N_Package_Body_Stub =>
Write_Indent_Str_Sloc ("package body ");
@@ -3326,6 +3341,7 @@ package body Sprint is
(Handled_Statement_Sequence (Node),
Defining_Unit_Name (Specification (Node)));
Write_Char (';');
+ Sprint_At_End_Proc (Node);
if Is_List_Member (Node)
and then Present (Next (Node))
@@ -3398,6 +3414,7 @@ package body Sprint is
Sprint_End_Label
(Handled_Statement_Sequence (Node), Defining_Identifier (Node));
Write_Char (';');
+ Sprint_At_End_Proc (Node);
when N_Task_Body_Stub =>
Write_Indent_Str_Sloc ("task body ");
diff --git a/gcc/ada/switch-b.adb b/gcc/ada/switch-b.adb
index a543ad9..c40cb97 100644
--- a/gcc/ada/switch-b.adb
+++ b/gcc/ada/switch-b.adb
@@ -158,9 +158,18 @@ package body Switch.B is
elsif Underscore then
Set_Underscored_Debug_Flag (C);
+
if Debug_Flag_Underscore_C then
Enable_CUDA_Expansion := True;
end if;
+ if Debug_Flag_Underscore_D then
+ Enable_CUDA_Device_Expansion := True;
+ end if;
+ if Enable_CUDA_Expansion and Enable_CUDA_Device_Expansion
+ then
+ Bad_Switch (Switch_Chars);
+ end if;
+
Underscore := False;
-- letter
diff --git a/gcc/ada/uintp.adb b/gcc/ada/uintp.adb
index 921c1d2..248298a 100644
--- a/gcc/ada/uintp.adb
+++ b/gcc/ada/uintp.adb
@@ -300,11 +300,9 @@ package body Uintp is
function Better_In_Hex return Boolean is
T16 : constant Valid_Uint := Uint_2**Int'(16);
- A : Valid_Uint;
+ A : Valid_Uint := UI_Abs (Input);
begin
- A := UI_Abs (Input);
-
-- Small values up to 2**16 can always be in decimal
if A < T16 then