diff options
| author | Ian Lance Taylor <iant@golang.org> | 2022-09-22 06:29:20 -0700 |
|---|---|---|
| committer | Ian Lance Taylor <iant@golang.org> | 2022-09-22 06:29:20 -0700 |
| commit | 795cffe109e28b248a54b8ee583cbae48368c2a7 (patch) | |
| tree | 0c12b075c51c0d5097f26953835ae540d9f2f501 /gcc/ada | |
| parent | 9f62ed218fa656607740b386c0caa03e65dcd283 (diff) | |
| parent | f35be1268c996d993ab0b4ff329734d467474445 (diff) | |
| download | gcc-795cffe109e28b248a54b8ee583cbae48368c2a7.zip gcc-795cffe109e28b248a54b8ee583cbae48368c2a7.tar.gz gcc-795cffe109e28b248a54b8ee583cbae48368c2a7.tar.bz2 | |
Merge from trunk revision f35be1268c996d993ab0b4ff329734d467474445.
Diffstat (limited to 'gcc/ada')
184 files changed, 9570 insertions, 34434 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 2469db4..fe048b8 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,1275 @@ +2022-09-20 Martin Liska <mliska@suse.cz> + + * exp_ch6.adb: Replace "the the" with "the". + * sem_ch6.adb: Likewise. + * sem_disp.ads: Likewise. + +2022-09-15 Richard Biener <rguenther@suse.de> + + * gcc-interface/trans.cc (gigi): Do not initialize void_list_node. + +2022-09-12 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/decl.cc (gnat_to_gnu_entity): Relax assertion when + front-end unnesting is enabled. + +2022-09-12 Justin Squirek <squirek@adacore.com> + + * sem_util.adb + (Innermost_Master_Scope_Depth): Detect and handle case where scope + depth is not set on an enclosing scope. + +2022-09-12 Steve Baird <baird@adacore.com> + + * bindgen.adb: When the binder is invoked for the host, generate a + "with CUDA.Internal;" with clause. + +2022-09-12 Piotr Trojanek <trojanek@adacore.com> + + * doc/gnat_rm/implementation_defined_pragmas.rst + (Pragma Unreferenced): Sync description with + Sem_Warn.Has_Junk_Name routine. + * gnat_rm.texi: Regenerate. + * gnat_ugn.texi: Regenerate. + +2022-09-12 Piotr Trojanek <trojanek@adacore.com> + + * sem_attr.adb (Analyze_Attribute [Valid_Scalars]): Move check for + unchecked union before checks for private and public types. + +2022-09-12 Steve Baird <baird@adacore.com> + + * bindgen.adb: When the binder is invoked for the host, it + declares imported subprograms corresponding to the Adainit and + Adafinal routines on the device. Declare string constants and + expression functions for the Ada source names and the link names + of these routines. Generate these subprogram declarations (and + accompanying Import pragmas) in Gen_CUDA_Defs. Generate + CUDA_Execute pragmas to call these subprograms from the host in + Gen_Adafinal and Gen_CUDA_Init. When the binder is invoked for the + device, include a CUDA_Global aspect declaration in the + declarations of Adainit and Adafinal and use the aforementioned + link names in the Export pragmas generated for those two routines. + * debug.adb: Update comments about "d_c" and "d_d" switches. + * opt.ads: Declare new Boolean variable, + Enable_CUDA_Device_Expansion. This complements the existing + Enable_CUDA_Expansion variable, which is used to enable host-side + CUDA expansion. The new variable enables device-side CUDA + expansion. It is currently never set during compilation; it is + only set via a binder switch. + * switch-b.adb + (scan_debug_switches): Add new use of the "-d_d" binder switch. + The new switch and the variable Opt.Enabled_CUDA_Device_Expansion + follow the existing pattern of the "-d_c" switch and the variable + Opt.Enabled_CUDA_Expansion. Flag error if both "-d_c" and "-d_d" + are specified. + +2022-09-12 Eric Botcazou <ebotcazou@adacore.com> + + * contracts.adb (uild_Subprogram_Contract_Wrapper): Remove useless + local variable. In the case of a function, replace the extended + return statement by a block statement declaring a renaming of the + call to the local subprogram after removing side effects manually. + (Expand_Subprogram_Contract): Adjust description accordingly. + * exp_ch6.adb (Expand_Ctrl_Function_Call): Rewrite obsolete + comment and do not apply the transformation twice. + * sem_attr.adb (Analyze_Attribute_Old_Result): Now expect a block + statement instead of an extended return statement. + +2022-09-12 Piotr Trojanek <trojanek@adacore.com> + + * erroutc.adb (Set_Msg_Insertion_Name): Special-case printing with + acronyms. + +2022-09-12 Yannick Moy <moy@adacore.com> + + * libgnat/s-imagei.adb (Image_Integer): Add justification. + +2022-09-12 Piotr Trojanek <trojanek@adacore.com> + + * sem_prag.adb (Get_SPARK_Mode_Type): Fix header box; replace + chained IF with a CASE statement. + +2022-09-12 Yannick Moy <moy@adacore.com> + + * sem_prag.adb (Analyze_Pragma): Accept SPARK_Mode=>Auto as + configuration pragma. + (Get_SPARK_Mode): Make the value for Auto explicit. + * snames.ads-tmpl (Name_Auto): Add name. + +2022-09-12 Joffrey Huguet <huguet@adacore.com> + + * doc/gnat_rm/the_gnat_library.rst: Remove paragraphs about SPARK + containers. + * gnat_rm.texi, gnat_ugn.texi: Regenerate. + +2022-09-12 Yannick Moy <moy@adacore.com> + + * libgnat/s-maccod.ads: Mark package as SPARK_Mode Off. + +2022-09-12 Eric Botcazou <ebotcazou@adacore.com> + + * fe.h (Unnest_Subprogram_Mode): Declare. + +2022-09-12 Steve Baird <baird@adacore.com> + + * contracts.adb + (Analyze_Package_Contract): Do not analyze the contract of a + temporary package created just to check conformance of an actual + package. + +2022-09-12 Joffrey Huguet <huguet@adacore.com> + + * Makefile.rtl: Remove SPARK containers filenames. + * impunit.adb: Remove SPARK containers packages names. + * libgnat/a-cfdlli.adb, libgnat/a-cfdlli.ads: Remove content and + add pragma Compile_Time_Error with suitable message. + * libgnat/a-cfhama.adb, libgnat/a-cfhama.ads: Likewise. + * libgnat/a-cfhase.adb, libgnat/a-cfhase.ads: Likewise. + * libgnat/a-cfidll.adb, libgnat/a-cfidll.ads: Likewise. + * libgnat/a-cfinse.adb, libgnat/a-cfinse.ads: Likewise. + * libgnat/a-cfinve.adb, libgnat/a-cfinve.ads: Likewise. + * libgnat/a-cforma.adb, libgnat/a-cforma.ads: Likewise. + * libgnat/a-cforse.adb, libgnat/a-cforse.ads: Likewise. + * libgnat/a-cofove.adb, libgnat/a-cofove.ads: Likewise. + * libgnat/a-cofuma.adb, libgnat/a-cofuma.ads: Likewise. + * libgnat/a-cofuse.adb, libgnat/a-cofuse.ads: Likewise. + * libgnat/a-cofuve.adb, libgnat/a-cofuve.ads: Likewise. + * libgnat/a-cofuba.adb, libgnat/a-cofuba.ads: Remove package. + +2022-09-12 Piotr Trojanek <trojanek@adacore.com> + + * exp_attr.adb (Expand_N_Attribute_Reference [Attribute_Old]): + Adapt to object declaration being rewritten into object renaming. + +2022-09-12 Justin Squirek <squirek@adacore.com> + + * contracts.adb, contracts.ads + (Analyze_Pragmas_In_Declarations): Added to aid in the new + expansion model so that pragmas relating to contracts can get + processed early before the rest of the subprogram containing them. + (Build_Subprogram_Contract_Wrapper): Created to do the majority of + expansion for postconditions. It builds a local wrapper with the + statements and declarations within a given subprogram. + (Is_Prologue_Renaming): Moved out from Process_Preconditions to be + used generally within the contracts package. + (Build_Entry_Contract_Wrapper): Moved from exp_ch7. + (Expand_Subprogram_Contract): Add new local variable Decls to + store expanded declarations needed for evaluation of contracts. + Call new wrapper building procedure and modify comments to match + new expansion model. + (Get_Postcond_Enabled): Deleted. + (Get_Result_Object_For_Postcond): Deleted. + (Get_Return_Success_For_Postcond): Deleted. + (Process_Contract_Cases): Add new parameter to store declarations. + (Process_Postconditions): Add new parameter to store declarations. + (Process_Preconditions): Add new parameter to store declarations. + Add code to move entry-call prologue renamings + * einfo.ads: Document new field Wrapped_Statements and modify + comment for Postconditions_Proc. + * exp_attr.adb + (Analyze_Attribute): Modify expansion of the 'Old attribute to + recognize new expansion model and use Wrapped_Statements instead + of Postconditions_Proc. + * exp_ch6.adb + (Add_Return): Remove special expansion for postconditions. + (Expand_Call): Modify condition checking for calls to access + subprogram wrappers to handle new expansion models. + (Expand_Call_Helper): Remove special expansion for postconditions. + (Expand_Non_Function_Return): Remove special expansion for + postconditions. + (Expand_Simple_Function_Return): Remove special expansion for + postconditions. + * exp_ch7.adb + (Build_Finalizer): Deleted, but replaced by code in + Build_Finalizer_Helper + (Build_Finalizer_Helper): Renamed to Build_Finalizer, and special + handling of 'Old objects removed. + * exp_ch9.adb + (Build_Contract_Wrapper): Renamed and moved to contracts package. + * exp_prag.adb + (Expand_Pragma_Contract_Cases): Delay analysis of contracts since + they now instead get analyzed as part of the wrapper generation + instead of after analysis of their corresponding subprogram's + body. + (Expand_Pragma_Check): Label expanded if-statements which come + from the expansion of assertion statements as + Comes_From_Check_Or_Contract. + * freeze.adb + (Freeze_Entity): Add special case to avoid freezing when a freeze + node gets generated as part of the expansion of a postcondition + check. + * gen_il-gen-gen_nodes.adb: Add new flag + Comes_From_Check_Or_Contract. + * gen_il-fields.ads: Add new field Wrapped_Statements. Add new + flag Comes_From_Check_Or_Contract. + * gen_il-gen-gen_entities.adb: Add new field Wrapped_Statements. + * ghost.adb + (Is_OK_Declaration): Replace Name_uPostconditions with + Name_uWrapped_Statements. + (Is_OK_Statement): Simplify condition due to the loss of + Original_Node as a result of the new expansion model of contracts + and use new flag Comes_From_Check_Or_Contract in its place. + * inline.adb + (Declare_Postconditions_Result): Replace Name_uPostconditions with + Name_uWrapped_Statements. + (Expand_Inlined_Call): Replace Name_uPostconditions with + Name_uWrapped_Statements. + * lib.adb, lib.ads + (ipu): Created to aid in debugging. + * lib-xref.adb + (Generate_References): Remove special handling for postcondition + procedures. + * sem_attr.adb + (Analyze_Attribute_Old_Result): Add new context in which 'Old can + appear due to the changes in expansion. Replace + Name_uPostconditions with Name_uWrapped_Statements. + (Result): Replace Name_uPostconditions with + Name_uWrapped_Statements. + * sem_ch11.adb + (Analyze_Handled_Statements): Remove check to exclude warnings on + useless assignments within postcondition procedures since + postconditions no longer get isolated into separate subprograms. + * sem_ch6.adb + (Analyze_Generic_Subprogram_Body): Modify expansion of generic + subprogram bodies so that contracts (and their associated pragmas) + get analyzed first. + (Analyze_Subprogram_Body_Helper): Remove global HSS variable due + to the HSS of the body potentially changing during the expansion + of contracts. In cases where it was used instead directly call + Handled_Statement_Sequence. Modify expansion of subprogram bodies + so that contracts (and their associated pragmas) get analyzed + first. + (Check_Missing_Return): Create local HSS variable instead of using + a global one. + (Move_Pragmas): Use new pragma table instead of an explicit list. + * sem_elab.adb + (Is_Postconditions_Proc): Deleted since the new scheme of + expansion no longer divides postcondition checks to a separate + subprogram and so cannot be easily identified (similar to + pre-condition checks). + (Info_Call): Remove info printing for _Postconditions subprograms. + (Is_Assertion_Pragma_Target): Remove check for postconditions + procedure + (Is_Bridge_Target): Remove check for postconditions procedure. + (Get_Invocation_Attributes): Remove unneeded local variables and + check for postconditions procedure. + (Output_Call): Remove info printing for _Postconditions + subprograms. + * sem_prag.adb, sem_prag.ads: Add new Pragma table for pragmas + significant to subprograms, along with tech-debt comment. + (Check_Arg_Is_Local_Name): Modified to recognize the new + _Wrapped_Statements internal subprogram and the new expansion + model. + (Relocate_Pragmas_To_Body): Replace Name_uPostconditions with + Name_uWrapped_Statements. + * sem_res.adb + (Resolve_Entry_Call): Add conditional to detect both contract + based wrappers of entries, but also wrappers generated as part of + general contract expansion (e.g. local postconditions + subprograms). + * sem_util.adb + (Accessibility_Level): Verify 'Access is not taken based on a + component of a function result. + (Has_Significant_Contracts): Replace Name_uPostconditions with + Name_uWrapped_Statements. + (Same_Or_Aliased_Subprogram): Add conditional to detect and obtain + the original subprogram based on the new concept of + "postcondition" wrappers. + * sinfo.ads: Add documentation for new flag + Comes_From_Check_Or_Contract. + * snames.ads-tmpl: Remove Name_uPostconditions and add + Name_uWrapped_Statements + +2022-09-12 Eric Botcazou <ebotcazou@adacore.com> + + * exp_unst.adb (Unnest_Subprograms.Search_Subprograms): Skip the + subprogram bodies that are not to be unnested. + +2022-09-12 Steve Baird <baird@adacore.com> + + * sem_aggr.adb + (Resolve_Array_Aggregate): Generate an appropriate error message + in the case where an error in the source code leads to an + N_Iterated_Element_Association node in a bad context. + +2022-09-12 Steve Baird <baird@adacore.com> + + * sem_ch4.adb + (Analyze_Selected_Component): Initialize the local variable Comp + to avoid having CodePeer generate an uninitialized variable + warning. + +2022-09-12 Steve Baird <baird@adacore.com> + + * sem_ch4.adb + (Analyze_Selected_Component): Avoid initializing the local + variable Comp if the variable is not going to be subsequently + referenced. This is a correctness issue because the call to + First_Entity can fail. + +2022-09-12 Steve Baird <baird@adacore.com> + + * sem_ch9.adb + (Satisfies_Lock_Free_Requirements): If Ceiling_Locking locking + policy has been specified, then either return False (if Lock_Free + was not explicitly specified) or generate a warning that ceiling + locking will not be implemented for this protected unit (if + Lock_Free was explicitly specified). Generate an error message (in + addition to returning False) if an explicit Lock_Free aspect + specification is rejected because atomic primitives are not + supported on the given target. + * doc/gnat_rm/implementation_defined_pragmas.rst: Clarify that the + Lock_Free aspect for a protected unit takes precedence over the + Ceiling_Locking locking policy in the case where both apply. + * gnat_rm.texi: Regenerate. + +2022-09-12 Eric Botcazou <ebotcazou@adacore.com> + + * exp_ch9.adb (Build_Protected_Spec): Tidy up and propagate the + Comes_From_Source flag onto the new formal parameters. + * sem_ch6.adb (Analyze_Subprogram_Body_Helper): Do not check + references for subprograms generated for protected subprograms. + +2022-09-12 Gary Dismukes <dismukes@adacore.com> + + * sem_res.adb + (Resolve_Equality_Op): Add handling for equality ops with + user-defined literal operands. + * sem_util.ads + (Is_User_Defined_Literal): Update spec comment to indicate + inclusion of named number cases. + * sem_util.adb + (Corresponding_Primitive_Op): Rather than following the chain of + ancestor subprograms via Alias and Overridden_Operation links, we + check for matching profiles between primitive subprograms of the + descendant type and the ancestor subprogram (by calling a new + nested function Profile_Matches_Ancestor). This prevents the + compiler from hanging due to circular linkages via those fields + that can occur between inherited and overriding subprograms + (which might indicate a latent bug, but one that may be rather + delicate to resolve). + (Profile_Matches_Ancestor): New nested subprogram to compare the + profile of a primitive subprogram with the profile of a candidate + ancestor subprogram. + (Is_User_Defined_Literal): Also return True in cases where the + node N denotes a named number (E_Name_Integer and E_Named_Real). + +2022-09-12 Steve Baird <baird@adacore.com> + + * debug.adb: remove a comment. + +2022-09-12 Bob Duff <duff@adacore.com> + + * checks.adb + (Selected_Length_Checks): In the message for an aggregate that has + too few or too many elements, add "!!" to make sure the warning + gets printed in with'ed units. Note that we have to put "!!" + before the "??", because Compile_Time_Constraint_Error detects + warnings by comparing the last character of the message with '?' + (which is bit dubious, but we're not changing that here). + (Length_Mismatch_Info_Message): Use Unat for some things that + can't be negative. Specify Decimal instead of Auto in calls to + UI_Image. + * sem_util.adb + (Compile_Time_Constraint_Error): Minor. + * uintp.adb + (Image_Uint): It's always better to initialize objects on their + declaration. + +2022-09-12 Patrick Bernardi <bernardi@adacore.com> + + * libgnat/system-vxworks7-x86_64-kernel.ads: Set + Support_Atomic_Primitives to false. + * libgnat/system-vxworks7-x86_64-rtp-smp.ads: Ditto. + +2022-09-12 Patrick Bernardi <bernardi@adacore.com> + + * libgnat/system-qnx-arm.ads: Set Support_Atomic_Primitives to + false. + * libgnat/system-vxworks7-aarch64.ads: Ditto. + * libgnat/system-vxworks7-aarch64-rtp-smp.ads: Ditto. + * libgnat/system-vxworks7-arm.ads: Ditto. + * libgnat/system-vxworks7-arm-rtp-smp.ads: Ditto. + * libgnat/system-vxworks7-x86-kernel.ads: Ditto. + * libgnat/system-vxworks7-x86-rtp-smp.ads: Ditto. + +2022-09-12 Bob Duff <duff@adacore.com> + + * par-tchk.adb, par-util.adb, prep.adb, prepcomp.adb, scng.adb: + Use "in" instead of chains of "=" connected with "or else". + Likewise for "not in", "/=", "and then". Misc cleanup. + * par-ch10.adb, par-ch12.adb, par-ch13.adb, par-ch4.adb: Likewise. + * par-ch8.adb, par-ch9.adb, par-endh.adb, par-sync.adb: Likewise. + * par.adb + (Pf_Rec): Remove filler, which was added August 25, 1993 to get + around a compiler limitation that no longer exists. Minor cleanup. + Remove useless qualfications. + * par-ch3.adb: Remove redundant return statements. + (Component_Scan_Loop): Remove loop name; there are no nested + loops, so it's unnecessary and possibly misleading, and it causes + too-long lines. + * par-ch5.adb: DRY: Remove comments that repeat the comments in + par.adb. + (P_Sequence_Of_Statements): It is better to initialize things on + the declaration. And constants are better than variables. + (Test_Statement_Required): Remove unnecessary insertion of a null + statement. + * par-ch6.adb, par-ch7.adb: DRY: Remove comments that repeat the + comments in par.adb. + +2022-09-12 Javier Miranda <miranda@adacore.com> + + Revert: + 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 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 + DEBUGGER_REGNO. + +2022-09-05 Piotr Trojanek <trojanek@adacore.com> + + * exp_aggr.adb (Check_Bounds): Move code and comment related to + check for null array aggregate from Resolve_Null_Array_Aggregate. + * sem_aggr.ads (Is_Null_Aggregate): Move spec from unit body. + * sem_aggr.adb (Resolve_Null_Array_Aggregate): Move check to + expansion. + +2022-09-05 Piotr Trojanek <trojanek@adacore.com> + + * sem_aggr.adb + (Array_Aggr_Subtype): Bypass call to Collect_Aggr_Bound with + dedicated code for null array aggregates. + (Resolve_Array_Aggregate): Remove special handling of null array + aggregates. + (Resolve_Array_Aggregate): Create bounds, but let + Array_Aggr_Subtype create itype entities. + +2022-09-05 Piotr Trojanek <trojanek@adacore.com> + + * sem_aggr.adb (Resolve_Null_Array_Aggregate): Insert check as a + Raise_Constraint_Error node and not an If_Statement. + +2022-09-05 Piotr Trojanek <trojanek@adacore.com> + + * sem_aggr.adb + (Resolve_Container_Aggregate): Style cleanup. + (Resolve_Record_Aggregate): Remove redundant guard. + +2022-09-05 Piotr Trojanek <trojanek@adacore.com> + + * exp_util.ads (Entry_Names_OK): Remove spec. + * exp_util.adb (Entry_Names_OK): Remove body. + +2022-09-05 Steve Baird <baird@adacore.com> + + * libgnat/a-coinve.adb, libgnat/a-convec.adb + (Append): If the Append that takes an Element and a Count is + called with Count = 1, then call the Append that does not take a + Count parameter; otherwise call the code that handles the general + case. Move the special case detection/handling code that was + formerly in that version of Append into the version that does not + take a Count parameter, so that now both versions get the + performance benefit. + +2022-09-05 Piotr Trojanek <trojanek@adacore.com> + + * sem_aggr.adb (Resolve_Null_Array_Aggregate): Create internal + type for the aggregate as an itype. + +2022-09-05 Piotr Trojanek <trojanek@adacore.com> + + * sem_util.ads (Itype_Has_Declaration): Remove spec. + * sem_util.adb (Itype_Has_Declaration): Remove body. + +2022-09-05 Steve Baird <baird@adacore.com> + + * exp_ch3.adb + (Expand_N_Object_Declaration): In deciding whether to emit a DIC + check, we were previously testing the Has_Init_Expression flag. + Continue to test that flag as before, but add a test for the + syntactic presence of an initial value in the object declaration. + This new test would not supersede the old test in the case where + an explicit initial value has been eliminated as part of some tree + transformation. + +2022-09-05 Piotr Trojanek <trojanek@adacore.com> + + * sem_ch13.adb (Validate_Unchecked_Conversions): Use + Has_Warnings_Off. + * sem_elab.adb (Check_Internal_Call_Continue): Likewise. + +2022-09-05 Eric Botcazou <ebotcazou@adacore.com> + + * libgnat/s-valuer.adb (Scan_Decimal_Digits): Consistently avoid + initializing local variables. + (Scan_Integral_Digits): Likewise. + (Scan_Raw_Real): Likewise and add a couple of comments. + +2022-09-05 Eric Botcazou <ebotcazou@adacore.com> + + * sem_ch13.adb (Freeze_Entity_Checks): Build predicate functions + only after checking the variant part of a record type, if any. + +2022-09-05 Piotr Trojanek <trojanek@adacore.com> + + * exp_aggr.adb + (Two_Pass_Aggregate_Expansion): Expand into implicit rather than + ordinary loops, to detect violations of restriction + No_Implicit_Loops. + (Generate_Loop): Likewise for delta array aggregates. + +2022-09-05 Piotr Trojanek <trojanek@adacore.com> + + * exp_aggr.adb (Two_Pass_Aggregate_Expansion): Expand iterated + component association with an unanalyzed copy of iterated + expression. The previous code worked only because the expanded + loop used both an analyzed copy of the iterator_specification and + an analyzed copy of the iterated expression. Now the iterated + expression is reanalyzed in the context of the expanded loop. + * par-ch4.adb (Build_Iterated_Component_Association): Don't set + defining identifier when iterator specification is present. + * sem_aggr.adb (Resolve_Iterated_Association): Pick index name + from the iterator specification. + * sem_elab.adb (Traverse_Potential_Scenario): Handle iterated + element association just like iterated component association. Not + strictly part of this fix, but still worth for the completeness. + * sem_res.adb (Resolve): Pick index name from the iterator + specification, when present. + * sem_util.adb (Traverse_More): For completeness, just like the + change in Traverse_Potential_Scenario. + * sinfo.ads + (ITERATED_COMPONENT_ASSOCIATION): Fix and complete description. + (ITERATED_ELEMENT_ASSOCIATION): Likewise. + +2022-09-05 Bob Duff <duff@adacore.com> + + * sem_ch6.adb + (Analyze_Subprogram_Body_Helper): Use First_Real_Statement to deal + with this case. Note that First_Real_Statement is likely to be + removed as part of this ticket, so this is a temporary fix. + +2022-09-05 Arnaud Charlet <charlet@adacore.com> + + * ali.adb (Scan_ALI): Special case i-c*.ali when setting + Sec_Stack_Used. + +2022-09-05 Bob Duff <duff@adacore.com> + + * par-ch5.adb + (P_Sequence_Of_Statements): Call Error_Msg_GNAT_Extension to give + the error message. + +2022-09-05 Piotr Trojanek <trojanek@adacore.com> + + * sem_aggr.adb (Resolve_Iterated_Component_Association): Split + processing of cases with and without iterator specification; reuse + analysis of iterator specification; improve diagnostics for + premature usage of iterator index in discrete choices. + +2022-09-05 Piotr Trojanek <trojanek@adacore.com> + + * sem_ch5.adb (Check_Subtype_Definition): Remove redundant call to + Present; style cleanup. + +2022-09-05 Piotr Trojanek <trojanek@adacore.com> + + * sem_aggr.adb (Resolve_Array_Aggregate): Change an inconsistent + use of False into its local equivalent Failure. + +2022-09-05 Piotr Trojanek <trojanek@adacore.com> + + * sem_aggr.adb (Resolve_Iterated_Component_Association): Change + generic name Ent to a more intuitive Scop; rename Remove_Ref to + Remove_Reference, so it can be instantiated as a traversal routine + with plural name. + +2022-09-05 Piotr Trojanek <trojanek@adacore.com> + + * sem_ch4.adb + (Is_Empty_Range): Move error reporting to the caller. + (Analyze_Qualified_Expression): Move error reporting from Is_Empty_Range; + add matching call to End_Scope before rewriting and returning. + +2022-09-05 Arnaud Charlet <charlet@adacore.com> + + * bindgen.adb (Gen_Elab_Calls): Check for Check_Elaboration_Flags. + * bindusg.adb (Display): Add -k. + * opt.ads (Check_Elaboration_Flags): New. + * switch-b.adb (Scan_Binder_Switches): Add processing of -k. + * doc/gnat_ugn/building_executable_programs_with_gnat.rst: Add + documentation for -k and -K. + * gnat_ugn.texi: Regenerate. + +2022-09-05 Arnaud Charlet <charlet@adacore.com> + + * treepr.adb: Remove local To_Lower and use the procedure + version instead. + +2022-09-05 Eric Botcazou <ebotcazou@adacore.com> + + * aspects.ads (Delaying Evaluation of Aspect): Fix typos. + * exp_ch3.adb (Freeze_Type): Do not generate Invariant and DIC + procedures for internal types. + * exp_util.adb (Build_DIC_Procedure_Body): Adjust comment. + * freeze.adb (Freeze_Entity): Call Inherit_Delayed_Rep_Aspects for + subtypes and derived types only after the base or parent type has + been frozen. Remove useless freezing for first subtype. + (Freeze_Fixed_Point_Type): Call Inherit_Delayed_Rep_Aspects too. + * layout.adb (Set_Elem_Alignment): Deal with private types. + * sem_ch3.adb (Build_Derived_Enumeration_Type): Build the implicit + base as an itype and do not insert its declaration in the tree. + (Build_Derived_Numeric_Type): Do not freeze the implicit base. + (Derived_Standard_Character): Likewise. + (Constrain_Enumeration): Inherit the chain of representation items + instead of replacing it. + * sem_ch13.ads (Inherit_Aspects_At_Freeze_Point): Add ??? comment. + (Inherit_Delayed_Rep_Aspects): Declare. + * sem_ch13.adb (Analyze_Aspects_At_Freeze_Point): Do not invoke + Inherit_Delayed_Rep_Aspects. + (Inherit_Aspects_At_Freeze_Point): Deal with private types. + (Inherit_Delayed_Rep_Aspects): Move to library level. + +2022-09-05 Piotr Trojanek <trojanek@adacore.com> + + * einfo-utils.adb (Number_Entries): Refine type of a local variable. + * exp_attr.adb (Expand_N_Attribute_Reference): Rename Conctyp to + Prottyp; refactor repeated calls to New_Occurrence_Of; replace + Number_Entries with Has_Entries. + * exp_ch5.adb (Expand_N_Assignment_Statement): Likewise; remove Subprg + variable (apparently copy-pasted from expansion of the attribute). + +2022-09-05 Piotr Trojanek <trojanek@adacore.com> + + * exp_attr.adb (Expand_N_Attribute_Reference): Fix detection of the + enclosing protected type and of the enclosing protected subprogram. + * exp_ch5.adb (Expand_N_Assignment_Statement): Likewise. + +2022-09-05 Piotr Trojanek <trojanek@adacore.com> + + * freeze.adb (Freeze_Itype): Remove excessive guard. + * sem_ch5.adb (Analyze_Loop_Parameter_Specification): Likewise. + +2022-09-05 Piotr Trojanek <trojanek@adacore.com> + + * sprint.adb (Sprint_Node_Actual): Handle iterator_specification within + iterated_component_association and iterator_filter within + iterator_specification. + +2022-09-05 Arnaud Charlet <charlet@adacore.com> + + * doc/gnat_ugn/gnat_and_program_execution.rst: Fix rest syntax + * gnat_ugn.texi: Regenerate. + +2022-09-02 Eric Botcazou <ebotcazou@adacore.com> + + * exp_util.adb (Expand_Subtype_From_Expr): Be prepared for + rewritten aggregates as expressions. + +2022-09-02 Gary Dismukes <dismukes@adacore.com> + + * exp_ch6.adb (Expand_Simple_Function_Return) Bypass creation of an actual + subtype and unchecked conversion to that subtype when the underlying type + of the expression has discriminants without defaults. + +2022-09-02 Eric Botcazou <ebotcazou@adacore.com> + + * exp_util.adb (Expand_Subtype_From_Expr): Check for the presence + of the Is_Constr_Subt_For_U_Nominal flag instead of the absence + of the Is_Constr_Subt_For_UN_Aliased flag on the subtype of the + expression of an object declaration before reusing this subtype. + * sem_ch3.adb (Analyze_Object_Declaration): Do not incorrectly + set the Is_Constr_Subt_For_UN_Aliased flag on the actual subtype + of an array with definite nominal subtype. Remove useless test. + +2022-09-02 Eric Botcazou <ebotcazou@adacore.com> + + * doc/gnat_rm/standard_and_implementation_defined_restrictions.rst + (No_Dependence): Cite implicit dependences on the runtime library. + * gnat_rm.texi, gnat_ugn.texi: Regenerate. + +2022-09-02 Claire Dross <dross@adacore.com> + + * libgnat/a-strmap.adb: Add variants to simple and while loops. + * libgnat/a-strsea.adb: Idem. + +2022-09-02 Claire Dross <dross@adacore.com> + + * libgnat/s-expmod.adb (Lemma_Add_Mod): Add new lemma to factor + out a complex sub-proof. + (Exp_Modular): Add assertion to help proof. + +2022-09-02 Claire Dross <dross@adacore.com> + + * libgnat/s-widthu.adb (Lemma_Euclidean): Lemma to prove the + relation between the quotient/remainder of a division. + +2022-09-02 Yannick Moy <moy@adacore.com> + + * libgnat/s-aridou.adb: Add or rework ghost code. + * libgnat/s-aridou.ads: Add Big_Positive subtype. + +2022-09-02 Eric Botcazou <ebotcazou@adacore.com> + + * doc/gnat_ugn/gnat_and_program_execution.rst + (Non-Symbolic Traceback): Update section. + * gnat_rm.texi, gnat_ugn.texi, gnat-style.texi: Regenerate. + +2022-09-02 Claire Dross <dross@adacore.com> + + * libgnat/a-nbnbig.ads: Add Always_Return annotation. + * libgnat/s-vaispe.ads: New ghost unit for the specification of + System.Value_I. Restore proofs. + * libgnat/s-vauspe.ads: New ghost unit for the specification of + System.Value_U. Restore proofs. + * libgnat/s-valuei.adb: The specification only subprograms are + moved to System.Value_I_Spec. Restore proofs. + * libgnat/s-valueu.adb: The specification only subprograms are + moved to System.Value_U_Spec. Restore proofs. + * libgnat/s-valuti.ads + (Uns_Params): Generic unit used to bundle together the + specification functions of System.Value_U_Spec. + (Int_Params): Generic unit used to bundle together the + specification functions of System.Value_I_Spec. + * libgnat/s-imagef.adb: It is now possible to instantiate the + appropriate specification units instead of creating imported ghost + subprograms. + * libgnat/s-imagei.adb: Update to refactoring of specifications + and fix proofs. + * libgnat/s-imageu.adb: Likewise. + * libgnat/s-imgint.ads: Ghost parameters are grouped together in a + package now. + * libgnat/s-imglli.ads: Likewise. + * libgnat/s-imgllu.ads: Likewise. + * libgnat/s-imgllli.ads: Likewise. + * libgnat/s-imglllu.ads: Likewise. + * libgnat/s-imguns.ads: Likewise. + * libgnat/s-vallli.ads: Likewise. + * libgnat/s-valllli.ads: Likewise. + * libgnat/s-imagei.ads: Likewise. + * libgnat/s-imageu.ads: Likewise. + * libgnat/s-vaispe.adb: Likewise. + * libgnat/s-valint.ads: Likewise. + * libgnat/s-valuei.ads: Likewise. + * libgnat/s-valueu.ads: Likewise. + * libgnat/s-vauspe.adb: Likewise. + 2022-07-13 Eric Botcazou <ebotcazou@adacore.com> * gcc-interface/trans.cc (gnat_to_gnu) <N_Assignment_Statement>: Fix 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/ali.adb b/gcc/ada/ali.adb index bcc8822..3febd48 100644 --- a/gcc/ada/ali.adb +++ b/gcc/ada/ali.adb @@ -2079,15 +2079,24 @@ package body ALI is -- Processing for SS elsif C = 'S' then - -- Special case: a-tags.ali by itself should not set + -- Special case: a-tags/i-c* by themselves should not set -- Sec_Stack_Used, only if other code uses the secondary -- stack should we set this flag. This ensures that we do -- not bring the secondary stack unnecessarily when using - -- Ada.Tags and not actually using the secondary stack. + -- one of these packages and not actually using the + -- secondary stack. - if Get_Name_String (F) /= "a-tags.ali" then - Opt.Sec_Stack_Used := True; - end if; + declare + File : constant String := Get_Name_String (F); + begin + if File /= "a-tags.ali" + and then File /= "i-c.ali" + and then File /= "i-cstrin.ali" + and then File /= "i-cpoint.ali" + then + Opt.Sec_Stack_Used := True; + end if; + end; -- Invalid switch starting with S diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads index 6559cda..2edb608 100644 --- a/gcc/ada/aspects.ads +++ b/gcc/ada/aspects.ads @@ -822,11 +822,11 @@ package Aspects is -- set on the parent type if it has delayed representation aspects. This -- flag Has_Delayed_Rep_Aspects indicates that if we derive from this type -- we have to worry about making sure we inherit any delayed aspects. The - -- second flag is set on a derived type: May_Have_Inherited_Rep_Aspects + -- second flag is set on a derived type: May_Inherit_Delayed_Rep_Aspects -- is set if the parent type has Has_Delayed_Rep_Aspects set. - -- When we freeze a derived type, if the May_Have_Inherited_Rep_Aspects - -- flag is set, then we call Freeze.Inherit_Delayed_Rep_Aspects when + -- When we freeze a derived type, if the May_Inherit_Delayed_Rep_Aspects + -- flag is set, then we call Sem_Ch13.Inherit_Delayed_Rep_Aspects when -- the derived type is frozen, which deals with the necessary copying of -- information from the parent type, which must be frozen at that point -- (since freezing the derived type first freezes the parent type). diff --git a/gcc/ada/bindgen.adb b/gcc/ada/bindgen.adb index c70268d..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; -------------------------- @@ -1544,6 +1583,7 @@ package body Bindgen is Check_Elab_Flag := Units.Table (Unum_Spec).Set_Elab_Entity + and then Check_Elaboration_Flags and then not CodePeer_Mode and then (Force_Checking_Of_Elaboration_Flags or Interface_Library_Unit @@ -2512,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); @@ -2601,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. @@ -2614,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/bindusg.adb b/gcc/ada/bindusg.adb index bfab985..3f99bae 100644 --- a/gcc/ada/bindusg.adb +++ b/gcc/ada/bindusg.adb @@ -156,6 +156,11 @@ package body Bindusg is (" -I- Don't look for sources & library files in default " & "directory"); + -- Line for -k switch + + Write_Line + (" -k Disable checking of elaboration flags"); + -- Line for -K switch Write_Line 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/standard_and_implementation_defined_restrictions.rst b/gcc/ada/doc/gnat_rm/standard_and_implementation_defined_restrictions.rst index 9ca4057..f8e2a58 100644 --- a/gcc/ada/doc/gnat_rm/standard_and_implementation_defined_restrictions.rst +++ b/gcc/ada/doc/gnat_rm/standard_and_implementation_defined_restrictions.rst @@ -184,7 +184,9 @@ No_Dependence .. index:: No_Dependence [RM 13.12.1] This restriction ensures at compile time that there are no -dependences on a library unit. +dependences on a library unit. For GNAT, this includes implicit implementation +dependences on units of the runtime library that are created by the compiler +to support specific constructs of the language. No_Direct_Boolean_Operators --------------------------- 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 5442d55..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) @@ -6534,6 +6541,22 @@ be presented in subsequent sections. ALI file named in the ``gnatbind`` command line. + .. index:: -k (gnatbind) + +:switch:`-k` + Disable checking of elaboration flags. When using :switch:`-n` + either explicitly or implicitly, :switch:`-F` is also implied, + unless :switch:`-k` is used. This switch should be used with care + and you should ensure manually that elaboration routines are not called + twice unintentionally. + + + .. index:: -K (gnatbind) + +:switch:`-K` + Give list of linker options specified for link. + + .. index:: -l (gnatbind) :switch:`-l` diff --git a/gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst b/gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst index c514678..0d78e43 100644 --- a/gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst +++ b/gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst @@ -756,12 +756,14 @@ for a complete list of supported platforms. .. rubric:: Tracebacks From an Unhandled Exception A runtime non-symbolic traceback is a list of addresses of call instructions. -To enable this feature you must use the :switch:`-E` -``gnatbind`` option. With this option a stack traceback is stored as part -of exception information. You can retrieve this information using the -``addr2line`` tool. +To enable this feature you must use the :switch:`-E` ``gnatbind`` option. With +this option a stack traceback is stored as part of exception information. -Here is a simple example: +You can translate this information using the ``addr2line`` tool, provided that +the program is compiled with debugging options (see :ref:`Switches_for_gcc`) +and linked at a fixed position with :switch:`-no-pie`. + +Here is a simple example with ``gnatmake``: .. code-block:: ada @@ -783,94 +785,110 @@ Here is a simple example: :: - $ gnatmake stb -bargs -E + $ gnatmake stb -g -bargs -E -largs -no-pie $ stb - Execution terminated by unhandled exception - Exception name: CONSTRAINT_ERROR - Message: stb.adb:5 + Execution of stb terminated by unhandled exception + raised CONSTRAINT_ERROR : stb.adb:5 explicit raise + Load address: 0x400000 Call stack traceback locations: 0x401373 0x40138b 0x40139c 0x401335 0x4011c4 0x4011f1 0x77e892a4 As we see the traceback lists a sequence of addresses for the unhandled exception ``CONSTRAINT_ERROR`` raised in procedure P1. It is easy to guess that this exception come from procedure P1. To translate these -addresses into the source lines where the calls appear, the -``addr2line`` tool, described below, is invaluable. The use of this tool -requires the program to be compiled with debug information. +addresses into the source lines where the calls appear, the ``addr2line`` +tool needs to be invoked like this: :: - $ gnatmake -g stb -bargs -E - $ stb - - Execution terminated by unhandled exception - Exception name: CONSTRAINT_ERROR - Message: stb.adb:5 - Call stack traceback locations: - 0x401373 0x40138b 0x40139c 0x401335 0x4011c4 0x4011f1 0x77e892a4 - - $ addr2line --exe=stb 0x401373 0x40138b 0x40139c 0x401335 0x4011c4 + $ addr2line -e stb 0x401373 0x40138b 0x40139c 0x401335 0x4011c4 0x4011f1 0x77e892a4 - 00401373 at d:/stb/stb.adb:5 - 0040138B at d:/stb/stb.adb:10 - 0040139C at d:/stb/stb.adb:14 - 00401335 at d:/stb/b~stb.adb:104 - 004011C4 at /build/.../crt1.c:200 - 004011F1 at /build/.../crt1.c:222 - 77E892A4 in ?? at ??:0 + d:/stb/stb.adb:5 + d:/stb/stb.adb:10 + d:/stb/stb.adb:14 + d:/stb/b~stb.adb:197 + crtexe.c:? + crtexe.c:? + ??:0 The ``addr2line`` tool has several other useful options: - ======================== ======================================================== - :samp:`--functions` to get the function name corresponding to any location - :samp:`--demangle=gnat` to use the gnat decoding mode for the function names. - Note that for binutils version 2.9.x the option is - simply :samp:`--demangle`. - ======================== ======================================================== + ========================= ==================================================== + :samp:`-a --addresses` to show the addresses alongside the line numbers + :samp:`-f --functions` to get the function name corresponding to a location + :samp:`-p --pretty-print` to print all the information on a single line + :samp:`--demangle=gnat` to use the GNAT decoding mode for the function names + ========================= ==================================================== :: - $ addr2line --exe=stb --functions --demangle=gnat 0x401373 0x40138b - 0x40139c 0x401335 0x4011c4 0x4011f1 + $ addr2line -e stb -a -f -p --demangle=gnat 0x401373 0x40138b + 0x40139c 0x401335 0x4011c4 0x4011f1 0x77e892a4 + + 0x00401373: stb.p1 at d:/stb/stb.adb:5 + 0x0040138B: stb.p2 at d:/stb/stb.adb:10 + 0x0040139C: stb at d:/stb/stb.adb:14 + 0x00401335: main at d:/stb/b~stb.adb:197 + 0x004011c4: ?? at crtexe.c:? + 0x004011f1: ?? at crtexe.c:? + 0x77e892a4: ?? ??:0 - 00401373 in stb.p1 at d:/stb/stb.adb:5 - 0040138B in stb.p2 at d:/stb/stb.adb:10 - 0040139C in stb at d:/stb/stb.adb:14 - 00401335 in main at d:/stb/b~stb.adb:104 - 004011C4 in <__mingw_CRTStartup> at /build/.../crt1.c:200 - 004011F1 in <mainCRTStartup> at /build/.../crt1.c:222 -From this traceback we can see that the exception was raised in -:file:`stb.adb` at line 5, which was reached from a procedure call in -:file:`stb.adb` at line 10, and so on. The :file:`b~std.adb` is the binder file, -which contains the call to the main program. -:ref:`Running_gnatbind`. The remaining entries are assorted runtime routines, -and the output will vary from platform to platform. +From this traceback we can see that the exception was raised in :file:`stb.adb` +at line 5, which was reached from a procedure call in :file:`stb.adb` at line +10, and so on. The :file:`b~std.adb` is the binder file, which contains the +call to the main program. :ref:`Running_gnatbind`. The remaining entries are +assorted runtime routines and the output will vary from platform to platform. It is also possible to use ``GDB`` with these traceback addresses to debug the program. For example, we can break at a given code location, as reported -in the stack traceback: - - :: +in the stack traceback:: $ gdb -nw stb -Furthermore, this feature is not implemented inside Windows DLL. Only -the non-symbolic traceback is reported in this case. - - :: - (gdb) break *0x401373 Breakpoint 1 at 0x401373: file stb.adb, line 5. -It is important to note that the stack traceback addresses -do not change when debug information is included. This is particularly useful -because it makes it possible to release software without debug information (to -minimize object size), get a field report that includes a stack traceback -whenever an internal bug occurs, and then be able to retrieve the sequence -of calls with the same program compiled with debug information. +It is important to note that the stack traceback addresses do not change when +debug information is included. This is particularly useful because it makes it +possible to release software without debug information (to minimize object +size), get a field report that includes a stack traceback whenever an internal +bug occurs, and then be able to retrieve the sequence of calls with the same +program compiled with debug information. + +However the ``addr2line`` tool does not work with Position-Independent Code +(PIC), the historical example being Windows DLLs, which nowadays encompasses +Position-Independent Executables (PIE) on recent Windows versions. + +In order to translate addresses into the source lines with Position-Independent +Executables on recent Windows versions, in other words without using the switch +:switch:`-no-pie` during linking, you need to use the ``gnatsymbolize`` tool +with :switch:`--load` instead of the ``addr2line`` tool. The main difference +is that you need to copy the Load Address output in the traceback ahead of the +sequence of addresses. And the default mode of ``gnatsymbolize`` is equivalent +to that of ``addr2line`` with the above switches, so none of them is needed:: + + $ gnatmake stb -g -bargs -E + $ stb + + Execution of stb terminated by unhandled exception + raised CONSTRAINT_ERROR : stb.adb:5 explicit raise + Load address: 0x400000 + Call stack traceback locations: + 0x401373 0x40138b 0x40139c 0x401335 0x4011c4 0x4011f1 0x77e892a4 + + $ gnatsymbolize --load stb 0x400000 0x401373 0x40138b 0x40139c 0x401335 + 0x4011c4 0x4011f1 0x77e892a4 + + 0x00401373 Stb.P1 at stb.adb:5 + 0x0040138B Stb.P2 at stb.adb:10 + 0x0040139C Stb at stb.adb:14 + 0x00401335 Main at b~stb.adb:197 + 0x004011c4 __tmainCRTStartup at ??? + 0x004011f1 mainCRTStartup at ??? + 0x77e892a4 ??? at ??? .. rubric:: Tracebacks From Exception Occurrences @@ -914,25 +932,24 @@ This program will output: $ stb - Exception name: CONSTRAINT_ERROR - Message: stb.adb:12 + raised CONSTRAINT_ERROR : stb.adb:12 range check failed + Load address: 0x400000 Call stack traceback locations: 0x4015e4 0x401633 0x401644 0x401461 0x4011c4 0x4011f1 0x77e892a4 .. rubric:: Tracebacks From Anywhere in a Program -It is also possible to retrieve a stack traceback from anywhere in a -program. For this you need to -use the ``GNAT.Traceback`` API. This package includes a procedure called -``Call_Chain`` that computes a complete stack traceback, as well as useful -display procedures described below. It is not necessary to use the -:switch:`-E` ``gnatbind`` option in this case, because the stack traceback mechanism -is invoked explicitly. +It is also possible to retrieve a stack traceback from anywhere in a program. +For this you need to use the ``GNAT.Traceback`` API. This package includes a +procedure called ``Call_Chain`` that computes a complete stack traceback, as +well as useful display procedures described below. It is not necessary to use +the :switch:`-E` ``gnatbind`` option in this case, because the stack traceback +mechanism is invoked explicitly. -In the following example we compute a traceback at a specific location in -the program, and we display it using ``GNAT.Debug_Utilities.Image`` to -convert addresses to strings: +In the following example we compute a traceback at a specific location in the +program, and we display it using ``GNAT.Debug_Utilities.Image`` to convert +addresses to strings: .. code-block:: ada @@ -976,16 +993,16 @@ convert addresses to strings: :: - $ gnatmake -g stb + $ gnatmake stb -g $ stb In STB.P1 : 16#0040_F1E4# 16#0040_14F2# 16#0040_170B# 16#0040_171C# 16#0040_1461# 16#0040_11C4# 16#0040_11F1# 16#77E8_92A4# -You can then get further information by invoking the ``addr2line`` -tool as described earlier (note that the hexadecimal addresses -need to be specified in C format, with a leading '0x'). +You can then get further information by invoking the ``addr2line`` tool or +the ``gnatsymbolize`` tool as described earlier (note that the hexadecimal +addresses need to be specified in C format, with a leading '0x'). .. index:: traceback, symbolic @@ -3716,12 +3733,13 @@ execution of this erroneous program: allocation and deallocation routines. This is done by linking with the :file:`libgmem.a` library. For correct symbolic backtrace information, the user program should also both be compiled with debugging options - (see :ref:`Switches_for_gcc`) and be linked at a fixed position. For - example to build :file:`my_program` with ``gnatmake``: + (see :ref:`Switches_for_gcc`) and be linked at a fixed position with + :switch:`-no-pie`. For example to build :file:`my_program` with + ``gnatmake``: :: - $ gnatmake -g my_program -largs -lgmem -no-pie + $ gnatmake my_program -g -largs -lgmem -no-pie As library :file:`libgmem.a` contains an alternate body for package ``System.Memory``, :file:`s-memory.adb` should not be compiled and linked diff --git a/gcc/ada/einfo-utils.adb b/gcc/ada/einfo-utils.adb index 27531f4..b7c9bdc 100644 --- a/gcc/ada/einfo-utils.adb +++ b/gcc/ada/einfo-utils.adb @@ -2081,7 +2081,7 @@ package body Einfo.Utils is -------------------- function Number_Entries (Id : E) return Nat is - N : Int; + N : Nat; Ent : Entity_Id; begin 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_aggr.adb b/gcc/ada/exp_aggr.adb index 4493f0f..1857055 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -5734,7 +5734,8 @@ package body Exp_Aggr is procedure Check_Bounds (Aggr_Bounds_Node, Index_Bounds_Node : Node_Id); -- Checks that the bounds of Aggr_Bounds are within the bounds defined - -- by Index_Bounds. + -- by Index_Bounds. For null array aggregate (Ada 2022) check that the + -- aggregate bounds define a null range. procedure Check_Same_Aggr_Bounds (Sub_Aggr : Node_Id; Dim : Pos); -- Checks that in a multidimensional array aggregate all subaggregates @@ -5850,6 +5851,22 @@ package body Exp_Aggr is Cond : Node_Id := Empty; begin + -- For a null array aggregate check that high bound (i.e., low + -- bound predecessor) exists. Fail if low bound is low bound of + -- base subtype (in all cases, including modular). + + if Is_Null_Aggregate (N) then + Insert_Action (N, + Make_Raise_Constraint_Error (Loc, + Condition => + Make_Op_Eq (Loc, + New_Copy_Tree (Aggr_Bounds.First), + New_Copy_Tree + (Type_Low_Bound (Base_Type (Etype (Ind_Bounds.First))))), + Reason => CE_Range_Check_Failed)); + return; + end if; + -- Generate the following test: -- [constraint_error when @@ -6430,7 +6447,7 @@ package body Exp_Aggr is Left_Opnd => New_Occurrence_Of (Size_Id, Loc), Right_Opnd => Make_Integer_Literal (Loc, 1))); - One_Loop := Make_Loop_Statement (Loc, + One_Loop := Make_Implicit_Loop_Statement (N, Iteration_Scheme => Make_Iteration_Scheme (Loc, Iterator_Specification => New_Copy_Tree (Iter)), @@ -6536,7 +6553,7 @@ package body Exp_Aggr is Prefix => New_Occurrence_Of (TmpE, Loc), Expressions => New_List (New_Occurrence_Of (Index_Id, Loc))), - Expression => New_Copy_Tree (Expression (Assoc))); + Expression => Copy_Separate_Tree (Expression (Assoc))); -- Advance index position for insertion. @@ -6562,7 +6579,7 @@ package body Exp_Aggr is Attribute_Name => Name_Last)), Then_Statements => New_List (Incr)); - One_Loop := Make_Loop_Statement (Loc, + One_Loop := Make_Implicit_Loop_Statement (N, Iteration_Scheme => Make_Iteration_Scheme (Loc, Iterator_Specification => Copy_Separate_Tree (Iter)), @@ -7500,11 +7517,11 @@ package body Exp_Aggr is -- Iterated_Component_Association. - Loop_Id := - Make_Defining_Identifier (Loc, - Chars => Chars (Defining_Identifier (Comp))); - if Present (Iterator_Specification (Comp)) then + Loop_Id := + Make_Defining_Identifier (Loc, + Chars => Chars (Defining_Identifier + (Iterator_Specification (Comp)))); L_Iteration_Scheme := Make_Iteration_Scheme (Loc, Iterator_Specification => Iterator_Specification (Comp)); @@ -7513,6 +7530,9 @@ package body Exp_Aggr is -- Loop_Parameter_Specification is parsed with a choice list. -- where the range is the first (and only) choice. + Loop_Id := + Make_Defining_Identifier (Loc, + Chars => Chars (Defining_Identifier (Comp))); L_Range := Relocate_Node (First (Discrete_Choices (Comp))); L_Iteration_Scheme := @@ -7997,7 +8017,7 @@ package body Exp_Aggr is end if; return - Make_Loop_Statement (Loc, + Make_Implicit_Loop_Statement (C, Iteration_Scheme => Make_Iteration_Scheme (Sl, Loop_Parameter_Specification => diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index ad75453..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)); @@ -5667,33 +5680,35 @@ package body Exp_Attr is -- which is illegal, because of the lack of aliasing. when Attribute_Priority => Priority : declare - Call : Node_Id; - Conctyp : Entity_Id; - New_Itype : Entity_Id; - Object_Parm : Node_Id; - Subprg : Entity_Id; - RT_Subprg_Name : Node_Id; + Call : Node_Id; + New_Itype : Entity_Id; + Object_Parm : Node_Id; + Prottyp : Entity_Id; + RT_Subprg : RE_Id; + Subprg : Entity_Id; begin - -- Look for the enclosing concurrent type + -- Look for the enclosing protected type - Conctyp := Current_Scope; - while not Is_Concurrent_Type (Conctyp) loop - Conctyp := Scope (Conctyp); + Prottyp := Current_Scope; + while not Is_Protected_Type (Prottyp) loop + Prottyp := Scope (Prottyp); end loop; - pragma Assert (Is_Protected_Type (Conctyp)); + pragma Assert (Is_Protected_Type (Prottyp)); -- Generate the actual of the call Subprg := Current_Scope; - while not Present (Protected_Body_Subprogram (Subprg)) loop + while not (Is_Subprogram_Or_Entry (Subprg) + and then Present (Protected_Body_Subprogram (Subprg))) + loop Subprg := Scope (Subprg); end loop; -- Use of 'Priority inside protected entries and barriers (in both -- cases the type of the first formal of their expanded subprogram - -- is Address) + -- is Address). if Etype (First_Entity (Protected_Body_Subprogram (Subprg))) = RTE (RE_Address) @@ -5708,7 +5723,7 @@ package body Exp_Attr is New_Itype := Create_Itype (E_Access_Type, N); Set_Etype (New_Itype, New_Itype); Set_Directly_Designated_Type (New_Itype, - Corresponding_Record_Type (Conctyp)); + Corresponding_Record_Type (Prottyp)); Freeze_Itype (New_Itype, N); -- Generate: @@ -5743,15 +5758,16 @@ package body Exp_Attr is -- Select the appropriate run-time subprogram - if Number_Entries (Conctyp) = 0 then - RT_Subprg_Name := New_Occurrence_Of (RTE (RE_Get_Ceiling), Loc); + if Has_Entries (Prottyp) then + RT_Subprg := RO_PE_Get_Ceiling; else - RT_Subprg_Name := New_Occurrence_Of (RTE (RO_PE_Get_Ceiling), Loc); + RT_Subprg := RE_Get_Ceiling; end if; Call := Make_Function_Call (Loc, - Name => RT_Subprg_Name, + Name => + New_Occurrence_Of (RTE (RT_Subprg), Loc), Parameter_Associations => New_List (Object_Parm)); Rewrite (N, Call); @@ -7099,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 @@ -7146,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 @@ -7182,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. @@ -7458,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; @@ -7943,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_ch3.adb b/gcc/ada/exp_ch3.adb index 38552ef..0d82691 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -7850,6 +7850,7 @@ package body Exp_Ch3 is and then Present (DIC_Procedure (Typ)) and then not Has_Null_Body (DIC_Procedure (Typ)) and then not Has_Init_Expression (N) + and then No (Expr) and then not Is_Imported (Def_Id) then declare @@ -9182,9 +9183,12 @@ package body Exp_Ch3 is -- the runtime verification of all invariants that pertain to the type. -- This includes invariants on the partial and full view, inherited -- class-wide invariants from parent types or interfaces, and invariants - -- on array elements or record components. + -- on array elements or record components. But skip internal types. - if Is_Interface (Def_Id) then + if Is_Itype (Def_Id) then + null; + + elsif Is_Interface (Def_Id) then -- Interfaces are treated as the partial view of a private type in -- order to achieve uniformity with the general case. As a result, an 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_ch5.adb b/gcc/ada/exp_ch5.adb index 9a2a110..2e14c97 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -2392,11 +2392,10 @@ package body Exp_Ch5 is if Ada_Version >= Ada_2005 then declare - Call : Node_Id; - Conctyp : Entity_Id; - Ent : Entity_Id; - Subprg : Entity_Id; - RT_Subprg_Name : Node_Id; + Call : Node_Id; + Ent : Entity_Id; + Prottyp : Entity_Id; + RT_Subprg : RE_Id; begin -- Handle chains of renamings @@ -2416,35 +2415,27 @@ package body Exp_Ch5 is if Is_Expanded_Priority_Attribute (Ent) then - -- Look for the enclosing concurrent type + -- Look for the enclosing protected type - Conctyp := Current_Scope; - while not Is_Concurrent_Type (Conctyp) loop - Conctyp := Scope (Conctyp); + Prottyp := Current_Scope; + while not Is_Protected_Type (Prottyp) loop + Prottyp := Scope (Prottyp); end loop; - pragma Assert (Is_Protected_Type (Conctyp)); - - -- Generate the first actual of the call - - Subprg := Current_Scope; - while not Present (Protected_Body_Subprogram (Subprg)) loop - Subprg := Scope (Subprg); - end loop; + pragma Assert (Is_Protected_Type (Prottyp)); -- Select the appropriate run-time call - if Number_Entries (Conctyp) = 0 then - RT_Subprg_Name := - New_Occurrence_Of (RTE (RE_Set_Ceiling), Loc); + if Has_Entries (Prottyp) then + RT_Subprg := RO_PE_Set_Ceiling; else - RT_Subprg_Name := - New_Occurrence_Of (RTE (RO_PE_Set_Ceiling), Loc); + RT_Subprg := RE_Set_Ceiling; end if; Call := Make_Procedure_Call_Statement (Loc, - Name => RT_Subprg_Name, + Name => + New_Occurrence_Of (RTE (RT_Subprg), Loc), Parameter_Associations => New_List ( New_Copy_Tree (First (Parameter_Associations (Ent))), Relocate_Node (Expression (N)))); diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index fad130d..ce1a752 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) @@ -6632,7 +6560,7 @@ package body Exp_Ch6 is begin if not Exp_Is_Function_Call - and then Has_Discriminants (Ubt) + and then Has_Defaulted_Discriminants (Ubt) and then not Is_Constrained (Ubt) and then not Has_Unchecked_Union (Ubt) then @@ -6654,7 +6582,7 @@ package body Exp_Ch6 is -- but optimize the case where the result is a function call that -- also needs finalization. In this case the result can directly be - -- allocated on the the return stack of the caller and no further + -- allocated on the return stack of the caller and no further -- processing is required. if Present (Utyp) @@ -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 3286bf6..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); @@ -2042,7 +2043,7 @@ package body Exp_Util is elsif Is_Underlying_Full_View (Work_Typ) then return; - -- Use the first subtype when dealing with various base types + -- Use the first subtype when dealing with implicit base types elsif Is_Itype (Work_Typ) then Work_Typ := First_Subtype (Work_Typ); @@ -5187,19 +5188,6 @@ package body Exp_Util is end if; end Ensure_Defined; - -------------------- - -- Entry_Names_OK -- - -------------------- - - function Entry_Names_OK return Boolean is - begin - return - not Restricted_Profile - and then not Global_Discard_Names - and then not Restriction_Active (No_Implicit_Heap_Allocations) - and then not Restriction_Active (No_Local_Allocators); - end Entry_Names_OK; - ------------------- -- Evaluate_Name -- ------------------- @@ -5732,14 +5720,17 @@ package body Exp_Util is then if Is_Itype (Exp_Typ) - -- If Exp_Typ was created for a previous declaration whose nominal - -- subtype is unconstrained, and that declaration is aliased, - -- we need to generate a new subtype, because otherwise the - -- Is_Constr_Subt_For_U_Nominal flag will be set on the wrong - -- subtype, causing failure to detect non-statically-matching - -- subtypes on 'Access of the previously-declared object. - - and then not Is_Constr_Subt_For_UN_Aliased (Exp_Typ) + -- When this is for an object declaration, the caller may want to + -- set Is_Constr_Subt_For_U_Nominal on the subtype, so we must make + -- sure that either the subtype has been built for the expression, + -- typically for an aggregate, or the flag is already set on it; + -- otherwise it could end up being set on the nominal constrained + -- subtype of an object and thus later cause the failure to detect + -- non-statically-matching subtypes on 'Access of this object. + + and then (Nkind (N) /= N_Object_Declaration + or else Nkind (Original_Node (Exp)) = N_Aggregate + or else Is_Constr_Subt_For_U_Nominal (Exp_Typ)) then -- Within an initialization procedure, a selected component -- denotes a component of the enclosing record, and it appears as diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index d854672..a21fb8b 100644 --- a/gcc/ada/exp_util.ads +++ b/gcc/ada/exp_util.ads @@ -509,11 +509,6 @@ package Exp_Util is -- used to ensure that an Itype is properly defined outside a conditional -- construct when it is referenced in more than one branch. - function Entry_Names_OK return Boolean; - -- Determine whether it is appropriate to dynamically allocate strings - -- which represent entry [family member] names. These strings are created - -- by the compiler and used by GDB. - procedure Evaluate_Name (Nam : Node_Id); -- Remove all side effects from a name which appears as part of an object -- renaming declaration. Similarly to Force_Evaluation, it removes the 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 382e5b4..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; @@ -6366,9 +6392,7 @@ package body Freeze is end; end if; - if Has_Delayed_Aspects (E) - or else May_Inherit_Delayed_Rep_Aspects (E) - then + if Has_Delayed_Aspects (E) then Analyze_Aspects_At_Freeze_Point (E); end if; @@ -6799,18 +6823,25 @@ package body Freeze is -- A subtype inherits all the type-related representation aspects -- from its parents (RM 13.1(8)). + if May_Inherit_Delayed_Rep_Aspects (E) then + Inherit_Delayed_Rep_Aspects (E); + end if; + Inherit_Aspects_At_Freeze_Point (E); -- For a derived type, freeze its parent type first (RM 13.14(15)) elsif Is_Derived_Type (E) then Freeze_And_Append (Etype (E), N, Result); - Freeze_And_Append (First_Subtype (Etype (E)), N, Result); -- A derived type inherits each type-related representation aspect -- of its parent type that was directly specified before the -- declaration of the derived type (RM 13.1(15)). + if May_Inherit_Delayed_Rep_Aspects (E) then + Inherit_Delayed_Rep_Aspects (E); + end if; + Inherit_Aspects_At_Freeze_Point (E); end if; @@ -8325,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; @@ -9089,6 +9120,11 @@ package body Freeze is Set_Has_Delayed_Aspects (Ftyp, False); end if; + if May_Inherit_Delayed_Rep_Aspects (Ftyp) then + Inherit_Delayed_Rep_Aspects (Ftyp); + Set_May_Inherit_Delayed_Rep_Aspects (Ftyp, False); + end if; + -- Inherit the Small value from the first subtype in any case if Typ /= Ftyp then @@ -9653,9 +9689,7 @@ package body Freeze is Set_Has_Delayed_Freeze (T); L := Freeze_Entity (T, N); - if Is_Non_Empty_List (L) then - Insert_Actions (N, L); - end if; + Insert_Actions (N, L); end Freeze_Itype; -------------------------- 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..2d93947 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); @@ -413,7 +413,6 @@ gigi (Node_Id gnat_root, save_gnu_tree (gnat_literal, t, false); /* Declare the building blocks of function nodes. */ - void_list_node = build_tree_list (NULL_TREE, void_type_node); void_ftype = build_function_type_list (void_type_node, NULL_TREE); ptr_void_ftype = build_pointer_type (void_ftype); @@ -1088,6 +1087,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 +1116,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 +1137,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 +1195,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 +3795,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 +3978,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 +5359,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 +5399,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 +5416,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 +5510,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 +5600,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 +5620,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 +5690,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 +6890,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 +6954,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 +6970,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 +7393,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 +7636,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 +7652,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 +7702,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 +8004,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 +9232,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 +9250,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 +9260,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 +9334,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 +9348,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 +9790,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 +10426,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 +10446,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-style.texi b/gcc/ada/gnat-style.texi index cbc11ac..f3b1c29 100644 --- a/gcc/ada/gnat-style.texi +++ b/gcc/ada/gnat-style.texi @@ -3,7 +3,7 @@ @setfilename gnat-style.info @documentencoding UTF-8 @ifinfo -@*Generated by Sphinx 4.3.1.@* +@*Generated by Sphinx 5.1.1.@* @end ifinfo @settitle GNAT Coding Style A Guide for GNAT Developers @defindex ge @@ -15,13 +15,11 @@ * gnat-style: (gnat-style.info). gnat-style @end direntry -@definfoenclose strong,`,' -@definfoenclose emph,`,' @c %**end of header @copying @quotation -GNAT Coding Style: A Guide for GNAT Developers , Jan 03, 2022 +GNAT Coding Style: A Guide for GNAT Developers , Aug 25, 2022 AdaCore @@ -255,7 +253,7 @@ When declarations are commented with ‘hanging’ comments, i.e. comments after the declaration, there is no blank line before the comment, and if it is absolutely necessary to have blank lines within the comments, e.g. to make paragraph separations within a single comment, -these blank lines @emph{do} have a @code{--} (unlike the +these blank lines `do' have a @code{--} (unlike the normal rule, which is to use entirely blank lines for separating comment paragraphs). The comment starts at same level of indentation as code it is commenting. @@ -304,12 +302,12 @@ Other_Id := 6; -- Second comment @end example @item -Short comments that fit on a single line are @emph{not} ended with a +Short comments that fit on a single line are `not' ended with a period. Comments taking more than a line are punctuated in the normal manner. @item -Comments should focus on @emph{why} instead of @emph{what}. +Comments should focus on `why' instead of `what'. Descriptions of what subprograms do go with the specification. @item @@ -319,7 +317,7 @@ depend on the names of things. The names are supplementary, not sufficient, as comments. @item -@emph{Do not} put two spaces after periods in comments. +`Do not' put two spaces after periods in comments. @end itemize @node Declarations and Types,Expressions and Names,Lexical Elements,Top @@ -958,7 +956,7 @@ Copyright 2000, 2001, 2002, 2007, 2008 Free Software Foundation, Inc Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. -@strong{Preamble} +`Preamble' The purpose of this License is to make a manual, textbook, or other functional and useful document “free” in the sense of freedom: to @@ -981,23 +979,23 @@ it can be used for any textual work, regardless of subject matter or whether it is published as a printed book. We recommend this License principally for works whose purpose is instruction or reference. -@strong{1. APPLICABILITY AND DEFINITIONS} +`1. APPLICABILITY AND DEFINITIONS' This License applies to any manual or other work, in any medium, that contains a notice placed by the copyright holder saying it can be distributed under the terms of this License. Such a notice grants a world-wide, royalty-free license, unlimited in duration, to use that -work under the conditions stated herein. The @strong{Document}, below, +work under the conditions stated herein. The `Document', below, refers to any such manual or work. Any member of the public is a -licensee, and is addressed as “@strong{you}”. You accept the license if you +licensee, and is addressed as “`you'”. You accept the license if you copy, modify or distribute the work in a way requiring permission under copyright law. -A “@strong{Modified Version}” of the Document means any work containing the +A “`Modified Version'” of the Document means any work containing the Document or a portion of it, either copied verbatim, or with modifications and/or translated into another language. -A “@strong{Secondary Section}” is a named appendix or a front-matter section of +A “`Secondary Section'” is a named appendix or a front-matter section of the Document that deals exclusively with the relationship of the publishers or authors of the Document to the Document’s overall subject (or to related matters) and contains nothing that could fall directly @@ -1008,7 +1006,7 @@ connection with the subject or with related matters, or of legal, commercial, philosophical, ethical or political position regarding them. -The “@strong{Invariant Sections}” are certain Secondary Sections whose titles +The “`Invariant Sections'” are certain Secondary Sections whose titles are designated, as being those of Invariant Sections, in the notice that says that the Document is released under this License. If a section does not fit the above definition of Secondary then it is not @@ -1016,12 +1014,12 @@ allowed to be designated as Invariant. The Document may contain zero Invariant Sections. If the Document does not identify any Invariant Sections then there are none. -The “@strong{Cover Texts}” are certain short passages of text that are listed, +The “`Cover Texts'” are certain short passages of text that are listed, as Front-Cover Texts or Back-Cover Texts, in the notice that says that the Document is released under this License. A Front-Cover Text may be at most 5 words, and a Back-Cover Text may be at most 25 words. -A “@strong{Transparent}” copy of the Document means a machine-readable copy, +A “`Transparent'” copy of the Document means a machine-readable copy, represented in a format whose specification is available to the general public, that is suitable for revising the document straightforwardly with generic text editors or (for images composed of @@ -1032,7 +1030,7 @@ to text formatters. A copy made in an otherwise Transparent file format whose markup, or absence of markup, has been arranged to thwart or discourage subsequent modification by readers is not Transparent. An image format is not Transparent if used for any substantial amount -of text. A copy that is not “Transparent” is called @strong{Opaque}. +of text. A copy that is not “Transparent” is called `Opaque'. Examples of suitable formats for Transparent copies include plain ASCII without markup, Texinfo input format, LaTeX input format, SGML @@ -1045,22 +1043,22 @@ processing tools are not generally available, and the machine-generated HTML, PostScript or PDF produced by some word processors for output purposes only. -The “@strong{Title Page}” means, for a printed book, the title page itself, +The “`Title Page'” means, for a printed book, the title page itself, plus such following pages as are needed to hold, legibly, the material this License requires to appear in the title page. For works in formats which do not have any title page as such, “Title Page” means the text near the most prominent appearance of the work’s title, preceding the beginning of the body of the text. -The “@strong{publisher}” means any person or entity that distributes +The “`publisher'” means any person or entity that distributes copies of the Document to the public. -A section “@strong{Entitled XYZ}” means a named subunit of the Document whose +A section “`Entitled XYZ'” means a named subunit of the Document whose title either is precisely XYZ or contains XYZ in parentheses following text that translates XYZ in another language. (Here XYZ stands for a -specific section name mentioned below, such as “@strong{Acknowledgements}”, -“@strong{Dedications}”, “@strong{Endorsements}”, or “@strong{History}”.) -To “@strong{Preserve the Title}” +specific section name mentioned below, such as “`Acknowledgements'”, +“`Dedications'”, “`Endorsements'”, or “`History'”.) +To “`Preserve the Title'” of such a section when you modify the Document means that it remains a section “Entitled XYZ” according to this definition. @@ -1071,7 +1069,7 @@ License, but only as regards disclaiming warranties: any other implication that these Warranty Disclaimers may have is void and has no effect on the meaning of this License. -@strong{2. VERBATIM COPYING} +`2. VERBATIM COPYING' You may copy and distribute the Document in any medium, either commercially or noncommercially, provided that this License, the @@ -1086,7 +1084,7 @@ number of copies you must also follow the conditions in section 3. You may also lend copies, under the same conditions stated above, and you may publicly display copies. -@strong{3. COPYING IN QUANTITY} +`3. COPYING IN QUANTITY' If you publish printed copies (or copies in media that commonly have printed covers) of the Document, numbering more than 100, and the @@ -1123,7 +1121,7 @@ It is requested, but not required, that you contact the authors of the Document well before redistributing any large number of copies, to give them a chance to provide you with an updated version of the Document. -@strong{4. MODIFICATIONS} +`4. MODIFICATIONS' You may copy and distribute a Modified Version of the Document under the conditions of sections 2 and 3 above, provided that you release @@ -1240,7 +1238,7 @@ The author(s) and publisher(s) of the Document do not by this License give permission to use their names for publicity for or to assert or imply endorsement of any Modified Version. -@strong{5. COMBINING DOCUMENTS} +`5. COMBINING DOCUMENTS' You may combine the Document with other documents released under this License, under the terms defined in section 4 above for modified @@ -1264,7 +1262,7 @@ in the various original documents, forming one section Entitled and any sections Entitled “Dedications”. You must delete all sections Entitled “Endorsements”. -@strong{6. COLLECTIONS OF DOCUMENTS} +`6. COLLECTIONS OF DOCUMENTS' You may make a collection consisting of the Document and other documents released under this License, and replace the individual copies of this @@ -1277,7 +1275,7 @@ it individually under this License, provided you insert a copy of this License into the extracted document, and follow this License in all other respects regarding verbatim copying of that document. -@strong{7. AGGREGATION WITH INDEPENDENT WORKS} +`7. AGGREGATION WITH INDEPENDENT WORKS' A compilation of the Document or its derivatives with other separate and independent documents or works, in or on a volume of a storage or @@ -1296,7 +1294,7 @@ electronic equivalent of covers if the Document is in electronic form. Otherwise they must appear on printed covers that bracket the whole aggregate. -@strong{8. TRANSLATION} +`8. TRANSLATION' Translation is considered a kind of modification, so you may distribute translations of the Document under the terms of section 4. @@ -1316,7 +1314,7 @@ If a section in the Document is Entitled “Acknowledgements”, its Title (section 1) will typically require changing the actual title. -@strong{9. TERMINATION} +`9. TERMINATION' You may not copy, modify, sublicense, or distribute the Document except as expressly provided under this License. Any attempt @@ -1343,7 +1341,7 @@ this License. If your rights have been terminated and not permanently reinstated, receipt of a copy of some or all of the same material does not give you any rights to use it. -@strong{10. FUTURE REVISIONS OF THIS LICENSE} +`10. FUTURE REVISIONS OF THIS LICENSE' The Free Software Foundation may publish new, revised versions of the GNU Free Documentation License from time to time. Such new @@ -1364,7 +1362,7 @@ License can be used, that proxy’s public statement of acceptance of a version permanently authorizes you to choose that version for the Document. -@strong{11. RELICENSING} +`11. RELICENSING' “Massive Multiauthor Collaboration Site” (or “MMC Site”) means any World Wide Web server that publishes copyrightable works and also @@ -1393,7 +1391,7 @@ The operator of an MMC Site may republish an MMC contained in the site under CC-BY-SA on the same site at any time before August 1, 2009, provided the MMC is eligible for relicensing. -@strong{ADDENDUM: How to use this License for your documents} +`ADDENDUM: How to use this License for your documents' To use this License in a document you have written, include a copy of the License in the document and put the following copyright and diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index 1ffc146..cdf8605 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -3,7 +3,7 @@ @setfilename gnat_rm.info @documentencoding UTF-8 @ifinfo -@*Generated by Sphinx 4.3.1.@* +@*Generated by Sphinx 5.1.1.@* @end ifinfo @settitle GNAT Reference Manual @defindex ge @@ -15,13 +15,11 @@ * gnat_rm: (gnat_rm.info). gnat_rm @end direntry -@definfoenclose strong,`,' -@definfoenclose emph,`,' @c %**end of header @copying @quotation -GNAT Reference Manual , Jul 11, 2022 +GNAT Reference Manual , Sep 09, 2022 AdaCore @@ -48,7 +46,7 @@ Copyright @copyright{} 2008-2022, Free Software Foundation @c %**start of body @anchor{gnat_rm doc}@anchor{0} -@emph{GNAT, The GNU Ada Development Environment} +`GNAT, The GNU Ada Development Environment' @include gcc-common.texi @@ -400,7 +398,6 @@ Implementation Defined Attributes * Attribute Iterable:: * Attribute Large:: * Attribute Library_Level:: -* Attribute Lock_Free:: * Attribute Loop_Entry:: * Attribute Machine_Size:: * Attribute Mantissa:: @@ -696,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. @@ -943,7 +929,7 @@ invoked in Ada 83 compatibility mode. By default, GNAT assumes Ada 2012, but you can override with a compiler switch to explicitly specify the language version. -(Please refer to the @emph{GNAT User’s Guide} for details on these switches.) +(Please refer to the `GNAT User’s Guide' for details on these switches.) Throughout this manual, references to ‘Ada’ without a year suffix apply to all the Ada versions of the language. @@ -1109,7 +1095,7 @@ and @code{classes}. @code{Variables} @item -@emph{Emphasis} +`Emphasis' @item [optional information or parameters] @@ -1784,7 +1770,7 @@ type of the expression is either @code{Standard.Boolean}, or any type derived from this standard type. Assert checks can be either checked or ignored. By default they are ignored. -They will be checked if either the command line switch @emph{-gnata} is +They will be checked if either the command line switch `-gnata' is used, or if an @code{Assertion_Policy} or @code{Check_Policy} pragma is used to enable @code{Assert_Checks}. @@ -1906,10 +1892,10 @@ If the policy is @code{CHECK}, then assertions are enabled, i.e. the corresponding pragma or aspect is activated. If the policy is @code{IGNORE}, then assertions are ignored, i.e. the corresponding pragma or aspect is deactivated. -This pragma overrides the effect of the @emph{-gnata} switch on the +This pragma overrides the effect of the `-gnata' switch on the command line. If the policy is @code{SUPPRESSIBLE}, then assertions are enabled by default, -however, if the @emph{-gnatp} switch is specified all assertions are ignored. +however, if the `-gnatp' switch is specified all assertions are ignored. The implementation defined policy @code{DISABLE} is like @code{IGNORE} except that it completely disables semantic @@ -2143,7 +2129,7 @@ be independently controlled. The identifier @code{Assertion} is special, it refers to the normal set of pragma @code{Assert} statements. Checks introduced by this pragma are normally deactivated by default. They can -be activated either by the command line option @emph{-gnata}, which turns on +be activated either by the command line option `-gnata', which turns on all checks, or individually controlled using pragma @code{Check_Policy}. The identifiers @code{Assertions} and @code{Statement_Assertions} are not @@ -2166,7 +2152,7 @@ pragma Check_Float_Overflow; In Ada, the predefined floating-point types (@code{Short_Float}, @code{Float}, @code{Long_Float}, @code{Long_Long_Float}) are -defined to be @emph{unconstrained}. This means that even though each +defined to be `unconstrained'. This means that even though each has a well-defined base range, an operation that delivers a result outside this base range is not required to raise an exception. This implementation permission accommodates the notion @@ -2205,7 +2191,7 @@ will be generated. The @code{Constraint_Error} exception is raised if the result is out of range. This mode can also be set by use of the compiler -switch @emph{-gnateF}. +switch `-gnateF'. @node Pragma Check_Name,Pragma Check_Policy,Pragma Check_Float_Overflow,Implementation Defined Pragmas @anchor{gnat_rm/implementation_defined_pragmas pragma-check-name}@anchor{37} @@ -2315,7 +2301,7 @@ is given, then subsequent @code{Check} pragmas whose first argument is also The check policy is @code{OFF} to turn off corresponding checks, and @code{ON} to turn on corresponding checks. The default for a set of checks for which no @code{Check_Policy} is given is @code{OFF} unless the compiler switch -@emph{-gnata} is given, which turns on all checks by default. +`-gnata' is given, which turns on all checks by default. The check policy settings @code{CHECK} and @code{IGNORE} are recognized as synonyms for @code{ON} and @code{OFF}. These synonyms are provided for @@ -2414,7 +2400,7 @@ pragma Compile_Time_Warning @end example Same as pragma Compile_Time_Error, except a warning is issued instead -of an error message. If switch @emph{-gnatw_C} is used, a warning is only issued +of an error message. If switch `-gnatw_C' is used, a warning is only issued if the value of the expression is known to be True at compile time, not when the value of the expression is not known at compile time. Note that if this pragma is used in a package that @@ -2427,7 +2413,7 @@ of formal parameters are tested, and warnings given appropriately. Another use with a first parameter of True is to warn a client about use of a package, for example that it is not fully implemented. -In previous versions of the compiler, combining @emph{-gnatwe} with +In previous versions of the compiler, combining `-gnatwe' with Compile_Time_Warning resulted in a fatal error. Now the compiler always emits a warning. You can use @ref{3b,,Pragma Compile_Time_Error} to force the generation of an error. @@ -2507,7 +2493,7 @@ The meaning of the @code{Form} argument is as follows: @table @asis -@item @emph{Component_Size} +@item `Component_Size' Aligns scalar components and subcomponents of the array or record type on boundaries appropriate to their inherent size (naturally @@ -2519,7 +2505,7 @@ machines except the VAX. @geindex Component_Size_4 (in pragma Component_Alignment) -@item @emph{Component_Size_4} +@item `Component_Size_4' Naturally aligns components with a size of four or fewer bytes. Components that are larger than 4 bytes are placed on the next @@ -2527,7 +2513,7 @@ bytes. Components that are larger than 4 bytes are placed on the next @geindex Storage_Unit (in pragma Component_Alignment) -@item @emph{Storage_Unit} +@item `Storage_Unit' Specifies that array or record components are byte aligned, i.e., aligned on boundaries determined by the value of the constant @@ -2535,7 +2521,7 @@ aligned on boundaries determined by the value of the constant @geindex Default (in pragma Component_Alignment) -@item @emph{Default} +@item `Default' Specifies that array or record components are aligned on default boundaries, appropriate to the underlying hardware or operating system or @@ -2757,16 +2743,16 @@ must be of one of the following forms: @itemize * @item -@strong{function} @code{Fname} @strong{return} T` +`function' @code{Fname} `return' T` @item -@strong{function} @code{Fname} @strong{return} T’Class +`function' @code{Fname} `return' T’Class @item -@strong{function} @code{Fname} (…) @strong{return} T` +`function' @code{Fname} (…) `return' T` @item -@strong{function} @code{Fname} (…) @strong{return} T’Class +`function' @code{Fname} (…) `return' T’Class @end itemize where @code{T} is a limited record type imported from C++ with pragma @@ -2890,7 +2876,7 @@ semantics of the pragma is exactly equivalent to the procedure call statement corresponding to the argument with a terminating semicolon. Pragmas are permitted in sequences of declarations, so you can use pragma @code{Debug} to intersperse calls to debug procedures in the middle of declarations. Debug -pragmas can be enabled either by use of the command line switch @emph{-gnata} +pragmas can be enabled either by use of the command line switch `-gnata' or by use of the pragma @code{Check_Policy} with a first argument of @code{Debug}. @@ -2968,8 +2954,8 @@ package DSSO1 is end DSSO1; @end example -In this example record types with names starting with @emph{L} have @cite{Low_Order_First} scalar -storage order, and record types with names starting with @emph{H} have @code{High_Order_First}. +In this example record types with names starting with `L' have @cite{Low_Order_First} scalar +storage order, and record types with names starting with `H' have @code{High_Order_First}. Note that in the case of @code{H4a}, the order is not inherited from the parent type. Only an explicitly set @code{Scalar_Storage_Order} gets inherited on type derivation. @@ -3134,8 +3120,8 @@ pragma Elaboration_Checks (Dynamic | Static); This is a configuration pragma which specifies the elaboration model to be used during compilation. For more information on the elaboration models of -GNAT, consult the chapter on elaboration order handling in the @emph{GNAT User’s -Guide}. +GNAT, consult the chapter on elaboration order handling in the `GNAT User’s +Guide'. The pragma may appear in the following contexts: @@ -3582,14 +3568,14 @@ the Ada RM. However, other implementations, notably the DEC Ada 83 implementation, provide many extensions to package @code{System}. For each such implementation accommodated by this pragma, GNAT provides a -package @code{Aux_@emph{xxx}}, e.g., @code{Aux_DEC} for the DEC Ada 83 +package @code{Aux_@var{xxx}}, e.g., @code{Aux_DEC} for the DEC Ada 83 implementation, which provides the required additional definitions. You can use this package in two ways. You can @code{with} it in the normal way and access entities either by selection or using a @code{use} clause. In this case no special processing is required. However, if existing code contains references such as -@code{System.@emph{xxx}} where @emph{xxx} is an entity in the extended +@code{System.@var{xxx}} where `xxx' is an entity in the extended definitions provided in package @code{System}, you may use this pragma to extend visibility in @code{System} in a non-standard way that provides greater compatibility with the existing code. Pragma @@ -3597,8 +3583,8 @@ provides greater compatibility with the existing code. Pragma the name of the package containing the extended definition (e.g., @code{Aux_DEC} for the DEC Ada case). A unit compiled under control of this pragma will be processed using special visibility -processing that looks in package @code{System.Aux_@emph{xxx}} where -@code{Aux_@emph{xxx}} is the pragma argument for any entity referenced in +processing that looks in package @code{System.Aux_@var{xxx}} where +@code{Aux_@var{xxx}} is the pragma argument for any entity referenced in package @code{System}, but not found in package @code{System}. You can use this pragma either to access a predefined @code{System} @@ -3606,7 +3592,7 @@ extension supplied with the compiler, for example @code{Aux_DEC} or you can construct your own extension unit following the above definition. Note that such a package is a child of @code{System} and thus is considered part of the implementation. -To compile it you will have to use the @emph{-gnatg} switch +To compile it you will have to use the `-gnatg' switch for compiling System units, as explained in the GNAT User’s Guide. @@ -3627,7 +3613,7 @@ pragma Extensions_Allowed (On | Off); This configuration pragma enables or disables the implementation extension mode (the use of Off as a parameter cancels the effect -of the @emph{-gnatX} command switch). +of the `-gnatX' command switch). In extension mode, the latest version of the Ada language is implemented (currently Ada 2022), and in addition a number @@ -3719,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 @@ -4033,7 +4020,7 @@ following operations are affected: @table @asis -@item @emph{Complex Multiplication} +@item `Complex Multiplication' The normal simple formula for complex multiplication can result in intermediate overflows for numbers near the end of the range. The Ada standard requires that @@ -4657,7 +4644,7 @@ program. Note that pragma @code{Initialize_Scalars} is particularly useful in conjunction with the enhanced validity checking that is now provided in GNAT, which checks for invalid values under more conditions. Using this feature (see description -of the @emph{-gnatV} flag in the GNAT User’s Guide) in conjunction with pragma +of the `-gnatV' flag in the GNAT User’s Guide) in conjunction with pragma @code{Initialize_Scalars} provides a powerful new tool to assist in the detection of problems caused by uninitialized variables. @@ -4708,7 +4695,7 @@ pragma Inline_Always (NAME [, NAME]); Similar to pragma @code{Inline} except that inlining is unconditional. Inline_Always instructs the compiler to inline every direct call to the subprogram or else to emit a compilation error, independently of any -option, in particular @emph{-gnatn} or @emph{-gnatN} or the optimization level. +option, in particular `-gnatn' or `-gnatN' or the optimization level. It is an error to take the address or access of @code{NAME}. It is also an error to apply this pragma to a primitive operation of a tagged type. Thanks to such restrictions, the compiler is allowed to remove the out-of-line body of @code{NAME}. @@ -5275,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 @@ -5367,7 +5360,7 @@ unrolling, but there is no guarantee that the loop will be vectorized. These hints do not remove the need to pass the appropriate switches to the compiler in order to enable the relevant optimizations, that is to say -@emph{-funroll-loops} for unrolling and @emph{-ftree-vectorize} for +`-funroll-loops' for unrolling and `-ftree-vectorize' for vectorization. @node Pragma Loop_Variant,Pragma Machine_Attribute,Pragma Loop_Optimize,Implementation Defined Pragmas @@ -5433,10 +5426,10 @@ pragma Machine_Attribute ( Machine-dependent attributes can be specified for types and/or declarations. This pragma is semantically equivalent to -@code{__attribute__((@emph{attribute_name}))} (if @code{info} is not -specified) or @code{__attribute__((@emph{attribute_name(info})))} -or @code{__attribute__((@emph{attribute_name(info,...})))} in GNU C, -where @emph{attribute_name} is recognized by the compiler middle-end +@code{__attribute__((@var{attribute_name}))} (if @code{info} is not +specified) or @code{__attribute__((@var{attribute_name(info})))} +or @code{__attribute__((@var{attribute_name(info,...})))} in GNU C, +where `attribute_name' is recognized by the compiler middle-end or the @code{TARGET_ATTRIBUTE_TABLE} machine specific macro. Note that a string literal for the optional parameter @code{info} or the following ones is transformed by default into an identifier, @@ -5621,8 +5614,8 @@ pragma No_Inline (NAME @{, NAME@}); This pragma suppresses inlining for the callable entity or the instances of the generic subprogram designated by @code{NAME}, including inlining that results from the use of pragma @code{Inline}. This pragma is always active, -in particular it is not subject to the use of option @emph{-gnatn} or -@emph{-gnatN}. It is illegal to specify both pragma @code{No_Inline} and +in particular it is not subject to the use of option `-gnatn' or +`-gnatN'. It is illegal to specify both pragma @code{No_Inline} and pragma @code{Inline_Always} for the same @code{NAME}. @node Pragma No_Return,Pragma No_Strict_Aliasing,Pragma No_Inline,Implementation Defined Pragmas @@ -5732,28 +5725,28 @@ are as follows: @table @asis -@item @emph{Standard.Character} +@item `Standard.Character' Objects whose root type is Standard.Character are initialized to Character’Last unless the subtype range excludes NUL (in which case NUL is used). This choice will always generate an invalid value if one exists. -@item @emph{Standard.Wide_Character} +@item `Standard.Wide_Character' Objects whose root type is Standard.Wide_Character are initialized to Wide_Character’Last unless the subtype range excludes NUL (in which case NUL is used). This choice will always generate an invalid value if one exists. -@item @emph{Standard.Wide_Wide_Character} +@item `Standard.Wide_Wide_Character' Objects whose root type is Standard.Wide_Wide_Character are initialized to the invalid value 16#FFFF_FFFF# unless the subtype range excludes NUL (in which case NUL is used). This choice will always generate an invalid value if one exists. -@item @emph{Integer types} +@item `Integer types' Objects of an integer type are treated differently depending on whether negative values are present in the subtype. If no negative values are @@ -5768,26 +5761,26 @@ is in the subtype, and the largest positive number is not, in which case the largest positive value is used. This choice will always generate an invalid value if one exists. -@item @emph{Floating-Point Types} +@item `Floating-Point Types' Objects of all floating-point types are initialized to all 1-bits. For standard IEEE format, this corresponds to a NaN (not a number) which is indeed an invalid value. -@item @emph{Fixed-Point Types} +@item `Fixed-Point Types' Objects of all fixed-point types are treated as described above for integers, with the rules applying to the underlying integer value used to represent the fixed-point value. -@item @emph{Modular types} +@item `Modular types' Objects of a modular type are initialized to all one bits, except in the special case where zero is excluded from the subtype, in which case all zero bits are used. This choice will always generate an invalid value if one exists. -@item @emph{Enumeration types} +@item `Enumeration types' Objects of an enumeration type are initialized to all one-bits, i.e., to the value @code{2 ** typ'Size - 1} unless the subtype excludes the literal @@ -6001,7 +5994,7 @@ specifies a set of possible colors, and the order is unimportant. For unordered enumeration types, it is generally a good idea if clients avoid comparisons (other than equality or inequality) and -explicit ranges. (A @emph{client} is a unit where the type is referenced, +explicit ranges. (A `client' is a unit where the type is referenced, other than the unit where the type is declared, its body, and its subunits.) For example, if code buried in some client says: @@ -6044,7 +6037,7 @@ if D in Mon .. Fri then ... if D < Wed then ... @end example -The pragma @emph{Ordered} is provided to mark enumeration types that +The pragma `Ordered' is provided to mark enumeration types that are conceptually ordered, alerting the reader that clients may depend on the ordering. GNAT provides a pragma to mark enumerations as ordered rather than one to mark them as unordered, since in our experience, @@ -6056,7 +6049,7 @@ are considered to be ordered types, so each is declared with a pragma @code{Ordered} in package @code{Standard}. Normally pragma @code{Ordered} serves only as documentation and a guide for -coding standards, but GNAT provides a warning switch @emph{-gnatw.u} that +coding standards, but GNAT provides a warning switch `-gnatw.u' that requests warnings for inappropriate uses (comparisons and explicit subranges) for unordered types. If this switch is used, then any enumeration type not marked with pragma @code{Ordered} will be considered @@ -6067,7 +6060,7 @@ template can be instantiated for both cases), so we never generate warnings for the case of generic enumerated types. For additional information please refer to the description of the -@emph{-gnatw.u} switch in the GNAT User’s Guide. +`-gnatw.u' switch in the GNAT User’s Guide. @node Pragma Overflow_Mode,Pragma Overriding_Renamings,Pragma Ordered,Implementation Defined Pragmas @anchor{gnat_rm/implementation_defined_pragmas pragma-overflow-mode}@anchor{af} @@ -6298,7 +6291,7 @@ referenced in the postcondition expressions. The postconditions are collected and automatically tested just before any return (implicit or explicit) in the subprogram body. A postcondition is only recognized if postconditions are active -at the time the pragma is encountered. The compiler switch @emph{gnata} +at the time the pragma is encountered. The compiler switch `gnata' turns on all postconditions by default, and pragma @code{Check_Policy} with an identifier of @code{Postcondition} can also be used to control whether postconditions are active. @@ -7430,22 +7423,22 @@ run with various special switches as follows: @itemize * @item -@emph{Where compiler-generated run-time checks remain} +`Where compiler-generated run-time checks remain' -The switch @emph{-gnatGL} +The switch `-gnatGL' may be used to list the expanded code in pseudo-Ada form. Runtime checks show up in the listing either as explicit checks or operators marked with @{@} to indicate a check is present. @item -@emph{An identification of known exceptions at compile time} +`An identification of known exceptions at compile time' -If the program is compiled with @emph{-gnatwa}, +If the program is compiled with `-gnatwa', the compiler warning messages will indicate all cases where the compiler detects that an exception is certain to occur at run time. @item -@emph{Possible reads of uninitialized variables} +`Possible reads of uninitialized variables' The compiler warns of many such cases, but its output is incomplete. @end itemize @@ -7459,29 +7452,29 @@ possible points at which uninitialized data may be read. @itemize * @item -@emph{Where run-time support routines are implicitly invoked} +`Where run-time support routines are implicitly invoked' -In the output from @emph{-gnatGL}, +In the output from `-gnatGL', run-time calls are explicitly listed as calls to the relevant run-time routine. @item -@emph{Object code listing} +`Object code listing' -This may be obtained either by using the @emph{-S} switch, +This may be obtained either by using the `-S' switch, or the objdump utility. @item -@emph{Constructs known to be erroneous at compile time} +`Constructs known to be erroneous at compile time' -These are identified by warnings issued by the compiler (use @emph{-gnatwa}). +These are identified by warnings issued by the compiler (use `-gnatwa'). @item -@emph{Stack usage information} +`Stack usage information' Static stack usage data (maximum per-subprogram) can be obtained via the -@emph{-fstack-usage} switch to the compiler. -Dynamic stack usage data (per task) can be obtained via the @emph{-u} switch +`-fstack-usage' switch to the compiler. +Dynamic stack usage data (per task) can be obtained via the `-u' switch to gnatbind @end itemize @@ -7490,21 +7483,21 @@ to gnatbind @itemize * @item -@emph{Object code listing of entire partition} +`Object code listing of entire partition' -This can be obtained by compiling the partition with @emph{-S}, +This can be obtained by compiling the partition with `-S', or by applying objdump to all the object files that are part of the partition. @item -@emph{A description of the run-time model} +`A description of the run-time model' The full sources of the run-time are available, and the documentation of these routines describes how these run-time routines interface to the underlying operating system facilities. @item -@emph{Control and data-flow information} +`Control and data-flow information' @end itemize @@ -7810,7 +7803,7 @@ the pragma line (for use in error messages and debugging information). @code{string_literal} is a static string constant that specifies the file name to be used in error messages and debugging information. This is most notably used for the output of @code{gnatchop} -with the @emph{-r} switch, to make sure that the original unchopped +with the `-r' switch, to make sure that the original unchopped source file is the one referred to. The second argument must be a string literal, it cannot be a static @@ -8023,7 +8016,7 @@ the @code{gnat.adc} file). The form with a string literal specifies which style options are to be activated. These are additive, so they apply in addition to any previously set style check options. The codes for the options are the same as those -used in the @emph{-gnaty} switch to @emph{gcc} or @emph{gnatmake}. +used in the `-gnaty' switch to `gcc' or `gnatmake'. For example the following two methods can be used to enable layout checking: @@ -8664,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. @@ -8909,7 +8902,7 @@ The form with a string literal specifies which validity options are to be activated. The validity checks are first set to include only the default reference manual settings, and then a string of letters in the string specifies the exact set of options required. The form of this string -is exactly as described for the @emph{-gnatVx} compiler switch (see the +is exactly as described for the `-gnatVx' compiler switch (see the GNAT User’s Guide for details). For example the following two methods can be used to enable validity checking for mode @code{in} and @code{in out} subprogram parameters: @@ -9033,8 +9026,8 @@ message string (it is not necessary to put an asterisk at the start and the end of the message, since this is implied). Another possibility for the static_string_EXPRESSION which works whether -or not error tags are enabled (@emph{-gnatw.d}) is to use a single -@emph{-gnatw} tag string, enclosed in brackets, +or not error tags are enabled (`-gnatw.d') is to use a single +`-gnatw' tag string, enclosed in brackets, as shown in the example below, to treat one category of warnings as errors. Note that if you want to treat multiple categories of warnings as errors, you can use multiple pragma Warning_As_Error. @@ -9042,7 +9035,7 @@ you can use multiple pragma Warning_As_Error. The above use of patterns to match the message applies only to warning messages generated by the front end. This pragma can also be applied to warnings provided by the back end and mentioned in @ref{11a,,Pragma Warnings}. -By using a single full @emph{-Wxxx} switch in the pragma, such warnings +By using a single full `-Wxxx' switch in the pragma, such warnings can also be treated as errors. The pragma can appear either in a global configuration pragma file @@ -9055,7 +9048,7 @@ pragma Warning_As_Error ("[-gnatwj]"); which will treat all obsolescent feature warnings as errors, the following program compiles as shown (compile options here are -@emph{-gnatwa.d -gnatl -gnatj55}). +`-gnatwa.d -gnatl -gnatj55'). @example 1. pragma Warning_As_Error ("*never assigned*"); @@ -9116,7 +9109,7 @@ expression (which does not exist in Ada 83). Note if the second argument of @code{DETAILS} is a @code{local_NAME} then the second form is always understood. If the intention is to use the fourth form, then you can write @code{NAME & ""} to force the -intepretation as a @emph{static_string_EXPRESSION}. +intepretation as a `static_string_EXPRESSION'. Note: if the first argument is a valid @code{TOOL_NAME}, it will be interpreted that way. The use of the @code{TOOL_NAME} argument is relevant only to users @@ -9164,9 +9157,9 @@ The warnings controlled by the @code{-gnatw} switch are generated by the front end of the compiler. The GCC back end can provide additional warnings and they are controlled by the @code{-W} switch. Such warnings can be identified by the appearance of a string of the form @code{[-W@{xxx@}]} in the -message which designates the @code{-W@emph{xxx}} switch that controls the message. -The form with a single @emph{static_string_EXPRESSION} argument also works for these -warnings, but the string must be a single full @code{-W@emph{xxx}} switch in this +message which designates the @code{-W`xxx'} switch that controls the message. +The form with a single `static_string_EXPRESSION' argument also works for these +warnings, but the string must be a single full @code{-W`xxx'} switch in this case. The above reference lists a few examples of these additional warnings. The specified warnings will be in effect until the end of the program @@ -9179,7 +9172,7 @@ also be used as a configuration pragma. The fourth form, with an @code{On|Off} parameter and a string, is used to control individual messages, based on their text. The string argument is a pattern that is used to match against the text of individual -warning messages (not including the initial “warning: ” tag). +warning messages (not including the initial “warning: “ tag). The pattern may contain asterisks, which match zero or more characters in the message. For example, you can use @@ -9196,7 +9189,7 @@ the end of the message, since this is implied). The above use of patterns to match the message applies only to warning messages generated by the front end. This form of the pragma with a string argument can also be used to control warnings provided by the back end and -mentioned above. By using a single full @code{-W@emph{xxx}} switch in the pragma, +mentioned above. By using a single full @code{-W`xxx'} switch in the pragma, such warnings can be turned on and off. There are two ways to use the pragma in this form. The OFF form can be used @@ -9214,7 +9207,7 @@ pragma Warnings (On, Pattern); @end example In this usage, the pattern string must match in the Off and On -pragmas, and (if @emph{-gnatw.w} is given) at least one matching +pragmas, and (if `-gnatw.w' is given) at least one matching warning must be suppressed. Note: if the ON form is not found, then the effect of the OFF form extends @@ -9471,15 +9464,15 @@ corresponding to @ref{29,,pragma Annotate}. @table @asis -@item @emph{Annotate => ID} +@item `Annotate => ID' Equivalent to @code{pragma Annotate (ID, Entity => Name);} -@item @emph{Annotate => (ID)} +@item `Annotate => (ID)' Equivalent to @code{pragma Annotate (ID, Entity => Name);} -@item @emph{Annotate => (ID ,ID @{, ARG@})} +@item `Annotate => (ID ,ID @{, ARG@})' Equivalent to @code{pragma Annotate (ID, ID @{, ARG@}, Entity => Name);} @end table @@ -9776,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 @@ -10263,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:: @@ -10396,7 +10392,7 @@ supported by the target for the given type. @code{obj'Bit}, where @code{obj} is any object, yields the bit offset within the storage unit (byte) that contains the first bit of storage allocated for the object. The value of this attribute is of the -type @emph{universal_integer} and is always a nonnegative number smaller +type `universal_integer' and is always a nonnegative number smaller than @code{System.Storage_Unit}. For an object that is a variable or a constant allocated in a register, @@ -10428,7 +10424,7 @@ and implementation of the @code{Bit} attribute. of the fields of the record type, yields the bit offset within the record contains the first bit of storage allocated for the object. The value of this attribute is of the -type @emph{universal_integer}. The value depends only on the field +type `universal_integer'. The value depends only on the field @code{C} and is independent of the alignment of the containing record @code{R}. @@ -10775,7 +10771,7 @@ prefix) yields a static Boolean value that is True if pragma The prefix of attribute @code{Finalization_Size} must be an object or a non-class-wide type. This attribute returns the size of any hidden data reserved by the compiler to handle finalization-related actions. The type of -the attribute is @emph{universal_integer}. +the attribute is `universal_integer'. @code{Finalization_Size} yields a value of zero for a type with no controlled parts, an object whose type has no controlled parts, or an object of a @@ -10975,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 @@ -11001,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 @@ -11045,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 @@ -11055,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 @@ -11068,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 @@ -11084,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 @@ -11095,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 @@ -11110,23 +11096,23 @@ the target. The result is a static constant. @code{func'Mechanism_Code} yields an integer code for the mechanism used for the result of function @code{func}, and @code{subprog'Mechanism_Code (n)} yields the mechanism -used for formal parameter number @emph{n} (a static integer value, with 1 +used for formal parameter number `n' (a static integer value, with 1 meaning the first parameter) of subprogram @code{subprog}. The code returned is: @table @asis -@item @emph{1} +@item `1' by copy (value) -@item @emph{2} +@item `2' 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 @@ -11151,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 @@ -11221,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 @@ -11236,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 @@ -11252,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 @@ -11274,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 @@ -11287,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 @@ -11357,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 @@ -11370,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 @@ -11383,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 @@ -11396,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 @@ -11409,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 @@ -11520,7 +11506,7 @@ the native ordering of the target, but this default can be overridden using pragma @code{Default_Scalar_Storage_Order}. If a component of @code{T} is itself of a record or array type, the specfied -@code{Scalar_Storage_Order} does @emph{not} apply to that nested type: an explicit +@code{Scalar_Storage_Order} does `not' apply to that nested type: an explicit attribute definition clause must be provided for the component type as well if desired. @@ -11572,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 @@ -11624,7 +11610,7 @@ the primitive @code{Allocate} procedure for type @code{SSP}, passing @code{S'Simple_Storage_Pool} as the pool parameter. The detailed semantics of such allocators is the same as those defined for allocators in section 13.11 of the @cite{Ada Reference Manual}, with the term -@emph{simple storage pool} substituted for @emph{storage pool}. +`simple storage pool' substituted for `storage pool'. If an access type @code{S} has a specified simple storage pool of type @code{SSP}, then a call to an instance of the @code{Ada.Unchecked_Deallocation} @@ -11632,10 +11618,10 @@ for that access type invokes the primitive @code{Deallocate} procedure for type @code{SSP}, passing @code{S'Simple_Storage_Pool} as the pool parameter. The detailed semantics of such unchecked deallocations is the same as defined in section 13.11.2 of the Ada Reference Manual, except that the -term @emph{simple storage pool} is substituted for @emph{storage pool}. +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 @@ -11651,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 @@ -11664,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 @@ -11677,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 @@ -11687,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 @@ -11711,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 @@ -11728,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 @@ -11741,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 @@ -11764,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 @@ -11774,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 @@ -11804,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 @@ -11816,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 @@ -11826,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 @@ -11840,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 @@ -11868,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 @@ -12055,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 @@ -12136,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 @@ -12148,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 @@ -12182,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 @@ -12202,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 @@ -12216,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 @@ -12228,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 @@ -12239,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 @@ -12268,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 @@ -12359,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 @@ -12371,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 @@ -12383,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 @@ -12404,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 @@ -12415,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 @@ -12424,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 @@ -12435,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 @@ -12448,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 @@ -12461,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 @@ -12471,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 @@ -12482,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 @@ -12492,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 @@ -12502,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 @@ -12512,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 @@ -12522,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 @@ -12532,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 @@ -12542,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 @@ -12559,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 @@ -12569,17 +12555,19 @@ 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 @geindex No_Dependence [RM 13.12.1] This restriction ensures at compile time that there are no -dependences on a library unit. +dependences on a library unit. For GNAT, this includes implicit implementation +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 @@ -13923,7 +13911,7 @@ Explanation @item -@emph{Abort_Defer} +`Abort_Defer' @tab @@ -13931,7 +13919,7 @@ Affects semantics @item -@emph{Ada_83} +`Ada_83' @tab @@ -13939,7 +13927,7 @@ Affects legality @item -@emph{Assert} +`Assert' @tab @@ -13947,7 +13935,7 @@ Affects semantics @item -@emph{CPP_Class} +`CPP_Class' @tab @@ -13955,7 +13943,7 @@ Affects semantics @item -@emph{CPP_Constructor} +`CPP_Constructor' @tab @@ -13963,7 +13951,7 @@ Affects semantics @item -@emph{Debug} +`Debug' @tab @@ -13971,7 +13959,7 @@ Affects semantics @item -@emph{Interface_Name} +`Interface_Name' @tab @@ -13979,7 +13967,7 @@ Affects semantics @item -@emph{Machine_Attribute} +`Machine_Attribute' @tab @@ -13987,7 +13975,7 @@ Affects semantics @item -@emph{Unimplemented_Unit} +`Unimplemented_Unit' @tab @@ -13995,7 +13983,7 @@ Affects legality @item -@emph{Unchecked_Union} +`Unchecked_Union' @tab @@ -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 @@ -14160,7 +14148,7 @@ is a software rather than a hardware format. row-major order, consistent with the notation used for multidimensional array aggregates (see 4.3.3). However, if a pragma @code{Convention} (@code{Fortran}, …) applies to a multidimensional array type, then -column-major order should be used instead (see B.5, @emph{Interfacing with Fortran}).” +column-major order should be used instead (see B.5, `Interfacing with Fortran').” @end quotation Followed. @@ -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 @@ -14321,7 +14309,7 @@ The recommended level of support pragma @code{Pack} is: For a packed record type, the components should be packed as tightly as possible subject to the Sizes of the component subtypes, and subject to -any @emph{record_representation_clause} that applies to the type; the +any `record_representation_clause' that applies to the type; the implementation may, but need not, reorder components or cross aligned word boundaries to improve the packing. A component whose @code{Size} is greater than the word size may be allocated an integral number of words.” @@ -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,14 +14560,14 @@ 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 @quotation “The recommended level of support for -@emph{record_representation_clause}s is: +`record_representation_clause's is: An implementation should support storage places that can be extracted with a load, mask, shift sequence of machine code, and set with a load, @@ -14620,7 +14608,7 @@ clause for the tag field. @quotation -“An implementation need not support a @emph{component_clause} for a +“An implementation need not support a `component_clause' for a component of an extension part if the storage place is not after the storage places of all components of the parent type, whether or not those storage places had been specified.” @@ -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} @@ -15006,10 +14994,10 @@ packages. @quotation -“For each supported convention @emph{L} other than @code{Intrinsic}, an +“For each supported convention `L' other than @code{Intrinsic}, an implementation should support @code{Import} and @code{Export} pragmas -for objects of @emph{L}-compatible types and for subprograms, and pragma -@cite{Convention} for @emph{L}-eligible types and for subprograms, +for objects of `L'-compatible types and for subprograms, and pragma +@cite{Convention} for `L'-eligible types and for subprograms, presuming the other language has corresponding features. Pragma @code{Convention} need not be supported for scalar types.” @end quotation @@ -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,16 +15464,16 @@ 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 @quotation -“Even though the @emph{abort_statement} is included in the list of +“Even though the `abort_statement' is included in the list of potentially blocking operations (see 9.5.1), it is recommended that this statement be implemented in a way that never requires the task executing -the @emph{abort_statement} to block.” +the `abort_statement' to block.” @end quotation Followed. @@ -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 @@ -15841,7 +15829,7 @@ There are no variations from the standard. interactions. See 1.1.3(10).” @end itemize -Any @emph{code_statement} can potentially cause external interactions. +Any `code_statement' can potentially cause external interactions. @itemize * @@ -15882,8 +15870,8 @@ length. See 2.2(15).” The maximum line length is 255 characters and the maximum length of a lexical element is also 255 characters. This is the default setting -if not overridden by the use of compiler switch @emph{-gnaty} (which -sets the maximum to 79) or @emph{-gnatyMnn} which allows the maximum +if not overridden by the use of compiler switch `-gnaty' (which +sets the maximum to 79) or `-gnatyMnn' which allows the maximum line length to be specified to be any value up to 32767. The maximum length of a lexical element is the same as the maximum line length. @@ -15941,7 +15929,7 @@ Representation @item -@emph{Short_Short_Integer} +`Short_Short_Integer' @tab @@ -15949,7 +15937,7 @@ Representation @item -@emph{Short_Integer} +`Short_Integer' @tab @@ -15957,7 +15945,7 @@ Representation @item -@emph{Integer} +`Integer' @tab @@ -15965,7 +15953,7 @@ Representation @item -@emph{Long_Integer} +`Long_Integer' @tab @@ -15975,7 +15963,7 @@ depending on the C definition of long) @item -@emph{Long_Long_Integer} +`Long_Long_Integer' @tab @@ -15983,7 +15971,7 @@ depending on the C definition of long) @item -@emph{Long_Long_Long_Integer} +`Long_Long_Long_Integer' @tab @@ -16044,7 +16032,7 @@ Representation @item -@emph{Short_Float} +`Short_Float' @tab @@ -16052,7 +16040,7 @@ IEEE Binary32 (Single) @item -@emph{Float} +`Float' @tab @@ -16060,7 +16048,7 @@ IEEE Binary32 (Single) @item -@emph{Long_Float} +`Long_Float' @tab @@ -16068,7 +16056,7 @@ IEEE Binary64 (Double) @item -@emph{Long_Long_Float} +`Long_Long_Float' @tab @@ -16129,10 +16117,10 @@ small must lie in 1.0E-38 .. 1.0E+38 and the digits in 1 .. 38. @item “The result of @code{Tags.Expanded_Name} for types declared -within an unnamed @emph{block_statement}. See 3.9(10).” +within an unnamed `block_statement'. See 3.9(10).” @end itemize -Block numbers of the form @code{B@emph{nnn}}, where @emph{nnn} is a +Block numbers of the form @code{B@var{nnn}}, where `nnn' is a decimal integer are allocated. @@ -16233,7 +16221,7 @@ Difficult to characterize. “Any extensions of the Default_Initial_Condition aspect. See 7.3.3(11).” @end itemize -SPARK allows specifying @emph{null} as the Default_Initial_Condition +SPARK allows specifying `null' as the Default_Initial_Condition aspect of a type. See the SPARK reference manual for further details. @@ -16281,8 +16269,8 @@ setting for local time, as accessed by the C library function @itemize * @item -“Any limit on @emph{delay_until_statements} of -@emph{select_statements}. See 9.6(29).” +“Any limit on `delay_until_statements' of +`select_statements'. See 9.6(29).” @end itemize There are no such limits. @@ -16314,7 +16302,7 @@ There are no implementation-defined conflict check policies. @end itemize A compilation is represented by a sequence of files presented to the -compiler in a single invocation of the @emph{gcc} command. +compiler in a single invocation of the `gcc' command. @itemize * @@ -16358,11 +16346,11 @@ mentioned in the context clause of one of the needed Ada units. If the partition contains no main program, or if the main program is in a language other than Ada, then GNAT -provides the binder options @emph{-z} and @emph{-n} respectively, and in +provides the binder options `-z' and `-n' respectively, and in this case a list of units can be explicitly supplied to the binder for inclusion in the partition (all units needed by these units will also be included automatically). For full details on the use of these -options, refer to @emph{GNAT Make Program gnatmake} in the +options, refer to `GNAT Make Program gnatmake' in the @cite{GNAT User’s Guide}. @@ -16393,7 +16381,7 @@ corresponding @code{ALI} file as the input parameter to the binder. @itemize * @item -“The order of elaboration of @emph{library_items}. See 10.2(18).” +“The order of elaboration of `library_items'. See 10.2(18).” @end itemize The first constraint on ordering is that it meets the requirements of @@ -16465,11 +16453,11 @@ been passed by the program. @item “The result of @code{Exceptions.Exception_Name} for types -declared within an unnamed @emph{block_statement}. See 11.4.1(12).” +declared within an unnamed `block_statement'. See 11.4.1(12).” @end itemize -Blocks have implementation defined names of the form @code{B@emph{nnn}} -where @emph{nnn} is an integer. +Blocks have implementation defined names of the form @code{B@var{nnn}} +where `nnn' is an integer. @itemize * @@ -16735,7 +16723,7 @@ See the definition of package System.Storage_Elements in @code{s-stoele.ads}. @item “The contents of the visible part of package @code{System.Machine_Code}, -and the meaning of @emph{code_statements}. See 13.8(7).” +and the meaning of `code_statements'. See 13.8(7).” @end itemize See the definition and documentation in file @code{s-maccod.ads}. @@ -16969,7 +16957,7 @@ of the state vector. Annex is not supported. See A.5.3(72).” @end itemize -Running the compiler with @emph{-gnatS} to produce a listing of package +Running the compiler with `-gnatS' to produce a listing of package @code{Standard} displays the values of these attributes. @@ -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 * @@ -17145,7 +17133,7 @@ Interpretation @item -@emph{Ada} +`Ada' @tab @@ -17153,7 +17141,7 @@ Ada @item -@emph{Ada_Pass_By_Copy} +`Ada_Pass_By_Copy' @tab @@ -17163,7 +17151,7 @@ with this convention to be passed by copy. @item -@emph{Ada_Pass_By_Reference} +`Ada_Pass_By_Reference' @tab @@ -17173,7 +17161,7 @@ with this convention to be passed by reference. @item -@emph{Assembler} +`Assembler' @tab @@ -17181,7 +17169,7 @@ Assembly language @item -@emph{Asm} +`Asm' @tab @@ -17189,7 +17177,7 @@ Synonym for Assembler @item -@emph{Assembly} +`Assembly' @tab @@ -17197,7 +17185,7 @@ Synonym for Assembler @item -@emph{C} +`C' @tab @@ -17205,7 +17193,7 @@ C @item -@emph{C_Pass_By_Copy} +`C_Pass_By_Copy' @tab @@ -17214,7 +17202,7 @@ is to be passed by copy rather than reference. @item -@emph{COBOL} +`COBOL' @tab @@ -17222,7 +17210,7 @@ COBOL @item -@emph{C_Plus_Plus (or CPP)} +`C_Plus_Plus (or CPP)' @tab @@ -17230,7 +17218,7 @@ C++ @item -@emph{Default} +`Default' @tab @@ -17238,7 +17226,7 @@ Treated the same as C @item -@emph{External} +`External' @tab @@ -17246,7 +17234,7 @@ Treated the same as C @item -@emph{Fortran} +`Fortran' @tab @@ -17254,7 +17242,7 @@ Fortran @item -@emph{Intrinsic} +`Intrinsic' @tab @@ -17263,7 +17251,7 @@ separate section on Intrinsic Subprograms. @item -@emph{Stdcall} +`Stdcall' @tab @@ -17274,7 +17262,7 @@ exit. This pragma cannot be applied to a dispatching call. @item -@emph{DLL} +`DLL' @tab @@ -17282,7 +17270,7 @@ Synonym for Stdcall @item -@emph{Win32} +`Win32' @tab @@ -17290,7 +17278,7 @@ Synonym for Stdcall @item -@emph{Stubbed} +`Stubbed' @tab @@ -17403,7 +17391,7 @@ Ada @item -@emph{Floating} +`Floating' @tab @@ -17411,7 +17399,7 @@ Float @item -@emph{Long_Floating} +`Long_Floating' @tab @@ -17419,7 +17407,7 @@ Float @item -@emph{Binary} +`Binary' @tab @@ -17427,7 +17415,7 @@ Integer @item -@emph{Long_Binary} +`Long_Binary' @tab @@ -17435,7 +17423,7 @@ Long_Long_Integer @item -@emph{Decimal_Element} +`Decimal_Element' @tab @@ -17443,7 +17431,7 @@ Character @item -@emph{COBOL_Character} +`COBOL_Character' @tab @@ -17540,12 +17528,12 @@ attribute. See C.7.1(7).” The result of this attribute is a string that identifies the object or component that denotes a given task. If a variable @code{Var} -has a task type, the image for this task will have the form @code{Var_@emph{XXXXXXXX}}, -where the suffix @emph{XXXXXXXX} +has a task type, the image for this task will have the form @code{Var_@var{XXXXXXXX}}, +where the suffix `XXXXXXXX' is the hexadecimal representation of the virtual address of the corresponding task control block. If the variable is an array of tasks, the image of each task will have the form of an indexed component indicating the position of a -given task in the array, e.g., @code{Group(5)_@emph{XXXXXXX}}. If the task is a +given task in the array, e.g., @code{Group(5)_@var{XXXXXXX}}. If the task is a component of a record, the image of the task will have the form of a selected component. These rules are fully recursive, so that the image of a task that is a subcomponent of a composite object corresponds to the expression that @@ -17648,7 +17636,7 @@ The value is 10 milliseconds. @itemize * @item -“Implementation-defined @emph{policy_identifiers} allowed +“Implementation-defined `policy_identifiers' allowed in a pragma @code{Locking_Policy}. See D.3(4).” @end itemize @@ -17900,7 +17888,7 @@ Value @item -@emph{Max_Scale} +`Max_Scale' @tab @@ -17908,7 +17896,7 @@ Value @item -@emph{Min_Scale} +`Min_Scale' @tab @@ -17916,7 +17904,7 @@ Value @item -@emph{Min_Delta} +`Min_Delta' @tab @@ -17924,7 +17912,7 @@ Value @item -@emph{Max_Delta} +`Max_Delta' @tab @@ -17932,7 +17920,7 @@ Value @item -@emph{Max_Decimal_Digits} +`Max_Decimal_Digits' @tab @@ -18024,7 +18012,7 @@ result type is @code{False}. See G.2.1(13).” Infinite and NaN values are produced as dictated by the IEEE floating-point standard. Note that on machines that are not fully compliant with the IEEE -floating-point standard, such as Alpha, the @emph{-mieee} compiler flag +floating-point standard, such as Alpha, the `-mieee' compiler flag must be used for achieving IEEE conforming behavior (although at the cost of a significant performance penalty), so infinite and NaN values are properly generated. @@ -18057,7 +18045,7 @@ is converted to the target type. @itemize * @item -“Conditions on a @emph{universal_real} operand of a fixed +“Conditions on a `universal_real' operand of a fixed point multiplication or division for which the result shall be in the perfect result set. See G.2.3(22).” @end 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 @@ -18476,13 +18464,13 @@ The default alignment values are as follows: @itemize * @item -@emph{Elementary Types}. +`Elementary Types'. 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 @@ -18493,7 +18481,7 @@ than 8, in which case objects of type @code{Long_Float} will be maximally aligned. @item -@emph{Arrays}. +`Arrays'. For arrays, the alignment is equal to the alignment of the component type for the normal case where no packing or component size is given. If the @@ -18506,7 +18494,7 @@ will be as described for elementary types, e.g. a packed array of length 31 bits will have an object size of four bytes, and an alignment of 4. @item -@emph{Records}. +`Records'. For the normal unpacked case, the alignment of a record is equal to the maximum alignment of any of its components. For tagged records, this @@ -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 @@ -18690,7 +18678,7 @@ Then @code{Default_Stack_Size} can be defined in a global package, and modified as required. Any tasks requiring stack sizes different from the default can have an appropriate alternative reference in the pragma. -You can also use the @emph{-d} binder switch to modify the default stack +You can also use the `-d' binder switch to modify the default stack size. For access types, the @code{Storage_Size} clause specifies the maximum @@ -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 @@ -18950,7 +18938,7 @@ discrete types are as follows: @item The @code{Object_Size} for base subtypes reflect the natural hardware -size in bits (run the compiler with @emph{-gnatS} to find those values +size in bits (run the compiler with `-gnatS' to find those values for numeric types). Enumeration types and fixed-point base subtypes have 8, 16, 32, or 64 bits for this size, depending on the range of values to be stored. @@ -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,14 +19604,14 @@ 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 @geindex Pragma Pack (for arrays) Pragma @code{Pack} applied to an array has an effect that depends upon whether the -component type is @emph{packable}. For a component type to be @emph{packable}, it must +component type is `packable'. For a component type to be `packable', it must be one of the following cases: @@ -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 @@ -19744,8 +19732,8 @@ since in this case the programmer intention is clear. Pragma @code{Pack} applied to a record will pack the components to reduce wasted space from alignment gaps and by reducing the amount of space -taken by components. We distinguish between @emph{packable} components and -@emph{non-packable} components. +taken by components. We distinguish between `packable' components and +`non-packable' components. Components of the following types are considered packable: @@ -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 @@ -19994,7 +19982,7 @@ be in the range: 0 .. System.Max_Binary_Modulus; @end example -A @emph{confirming} representation clause is one in which the values range +A `confirming' representation clause is one in which the values range from 0 in sequence, i.e., a clause that confirms the default representation for an enumeration type. Such a confirming representation @@ -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 @@ -20436,7 +20424,7 @@ There are four exceptions to this general rule: @itemize * @item -@emph{Convention Fortran and array subtypes}. +`Convention Fortran and array subtypes'. If pragma Convention Fortran is specified for an array subtype, then in accordance with the implementation advice in section 3.6.2(11) of the @@ -20444,7 +20432,7 @@ Ada Reference Manual, the array will be stored in a Fortran-compatible column-major manner, instead of the normal default row-major order. @item -@emph{Convention C and enumeration types} +`Convention C and enumeration types' GNAT normally stores enumeration types in 8, 16, or 32 bits as required to accommodate all values of the type. For example, for the enumeration @@ -20470,7 +20458,7 @@ warning in this situation. The warning can be suppressed by giving an explicit size clause specifying the desired size. @item -@emph{Convention C/Fortran and Boolean types} +`Convention C/Fortran and Boolean types' In C, the usual convention for boolean values, that is values used for conditions, is that zero represents false, and nonzero values represent @@ -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 @@ -20594,7 +20582,7 @@ fields placed? The section on pragma @code{Pack} in this chapter can be used to answer the second question, but it is often easier to just see what the compiler does. -For this purpose, GNAT provides the option @emph{-gnatR}. If you compile +For this purpose, GNAT provides the option `-gnatR'. If you compile with this option, then the compiler will output information on the actual representations chosen, in a format similar to source representation clauses. For example, if we compile the package: @@ -20643,7 +20631,7 @@ package q is end q; @end example -using the switch @emph{-gnatR} we obtain the following output: +using the switch `-gnatR' we obtain the following output: @example Representation information for unit q @@ -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 @@ -20753,56 +20741,56 @@ the unit is not implemented. @table @asis -@item @code{Ada} @emph{(A.2)} +@item @code{Ada} `(A.2)' This is a parent package for all the standard library packages. It is usually included implicitly in your program, and itself contains no useful data or routines. -@item @code{Ada.Assertions} @emph{(11.4.2)} +@item @code{Ada.Assertions} `(11.4.2)' @code{Assertions} provides the @code{Assert} subprograms, and also the declaration of the @code{Assertion_Error} exception. -@item @code{Ada.Asynchronous_Task_Control} @emph{(D.11)} +@item @code{Ada.Asynchronous_Task_Control} `(D.11)' @code{Asynchronous_Task_Control} provides low level facilities for task synchronization. It is typically not implemented. See package spec for details. -@item @code{Ada.Calendar} @emph{(9.6)} +@item @code{Ada.Calendar} `(9.6)' @code{Calendar} provides time of day access, and routines for manipulating times and durations. -@item @code{Ada.Calendar.Arithmetic} @emph{(9.6.1)} +@item @code{Ada.Calendar.Arithmetic} `(9.6.1)' This package provides additional arithmetic operations for @code{Calendar}. -@item @code{Ada.Calendar.Formatting} @emph{(9.6.1)} +@item @code{Ada.Calendar.Formatting} `(9.6.1)' This package provides formatting operations for @code{Calendar}. -@item @code{Ada.Calendar.Time_Zones} @emph{(9.6.1)} +@item @code{Ada.Calendar.Time_Zones} `(9.6.1)' This package provides additional @code{Calendar} facilities for handling time zones. -@item @code{Ada.Characters} @emph{(A.3.1)} +@item @code{Ada.Characters} `(A.3.1)' This is a dummy parent package that contains no useful entities -@item @code{Ada.Characters.Conversions} @emph{(A.3.2)} +@item @code{Ada.Characters.Conversions} `(A.3.2)' This package provides character conversion functions. -@item @code{Ada.Characters.Handling} @emph{(A.3.2)} +@item @code{Ada.Characters.Handling} `(A.3.2)' This package provides some basic character handling capabilities, including classification functions for classes of characters (e.g., test for letters, or digits). -@item @code{Ada.Characters.Latin_1} @emph{(A.3.3)} +@item @code{Ada.Characters.Latin_1} `(A.3.3)' This package includes a complete set of definitions of the characters that appear in type CHARACTER. It is useful for writing programs that @@ -20812,194 +20800,194 @@ the definition of @code{UC_E_Acute} in this package. Then your program will print in an understandable manner even if your environment does not support these extended characters. -@item @code{Ada.Command_Line} @emph{(A.15)} +@item @code{Ada.Command_Line} `(A.15)' This package provides access to the command line parameters and the name of the current program (analogous to the use of @code{argc} and @code{argv} in C), and also allows the exit status for the program to be set in a system-independent manner. -@item @code{Ada.Complex_Text_IO} @emph{(G.1.3)} +@item @code{Ada.Complex_Text_IO} `(G.1.3)' This package provides text input and output of complex numbers. -@item @code{Ada.Containers} @emph{(A.18.1)} +@item @code{Ada.Containers} `(A.18.1)' A top level package providing a few basic definitions used by all the following specific child packages that provide specific kinds of containers. @end table -@code{Ada.Containers.Bounded_Priority_Queues} @emph{(A.18.31)} +@code{Ada.Containers.Bounded_Priority_Queues} `(A.18.31)' -@code{Ada.Containers.Bounded_Synchronized_Queues} @emph{(A.18.29)} +@code{Ada.Containers.Bounded_Synchronized_Queues} `(A.18.29)' -@code{Ada.Containers.Doubly_Linked_Lists} @emph{(A.18.3)} +@code{Ada.Containers.Doubly_Linked_Lists} `(A.18.3)' -@code{Ada.Containers.Generic_Array_Sort} @emph{(A.18.26)} +@code{Ada.Containers.Generic_Array_Sort} `(A.18.26)' -@code{Ada.Containers.Generic_Constrained_Array_Sort} @emph{(A.18.26)} +@code{Ada.Containers.Generic_Constrained_Array_Sort} `(A.18.26)' -@code{Ada.Containers.Generic_Sort} @emph{(A.18.26)} +@code{Ada.Containers.Generic_Sort} `(A.18.26)' -@code{Ada.Containers.Hashed_Maps} @emph{(A.18.5)} +@code{Ada.Containers.Hashed_Maps} `(A.18.5)' -@code{Ada.Containers.Hashed_Sets} @emph{(A.18.8)} +@code{Ada.Containers.Hashed_Sets} `(A.18.8)' -@code{Ada.Containers.Indefinite_Doubly_Linked_Lists} @emph{(A.18.12)} +@code{Ada.Containers.Indefinite_Doubly_Linked_Lists} `(A.18.12)' -@code{Ada.Containers.Indefinite_Hashed_Maps} @emph{(A.18.13)} +@code{Ada.Containers.Indefinite_Hashed_Maps} `(A.18.13)' -@code{Ada.Containers.Indefinite_Hashed_Sets} @emph{(A.18.15)} +@code{Ada.Containers.Indefinite_Hashed_Sets} `(A.18.15)' -@code{Ada.Containers.Indefinite_Holders} @emph{(A.18.18)} +@code{Ada.Containers.Indefinite_Holders} `(A.18.18)' -@code{Ada.Containers.Indefinite_Multiway_Trees} @emph{(A.18.17)} +@code{Ada.Containers.Indefinite_Multiway_Trees} `(A.18.17)' -@code{Ada.Containers.Indefinite_Ordered_Maps} @emph{(A.18.14)} +@code{Ada.Containers.Indefinite_Ordered_Maps} `(A.18.14)' -@code{Ada.Containers.Indefinite_Ordered_Sets} @emph{(A.18.16)} +@code{Ada.Containers.Indefinite_Ordered_Sets} `(A.18.16)' -@code{Ada.Containers.Indefinite_Vectors} @emph{(A.18.11)} +@code{Ada.Containers.Indefinite_Vectors} `(A.18.11)' -@code{Ada.Containers.Multiway_Trees} @emph{(A.18.10)} +@code{Ada.Containers.Multiway_Trees} `(A.18.10)' -@code{Ada.Containers.Ordered_Maps} @emph{(A.18.6)} +@code{Ada.Containers.Ordered_Maps} `(A.18.6)' -@code{Ada.Containers.Ordered_Sets} @emph{(A.18.9)} +@code{Ada.Containers.Ordered_Sets} `(A.18.9)' -@code{Ada.Containers.Synchronized_Queue_Interfaces} @emph{(A.18.27)} +@code{Ada.Containers.Synchronized_Queue_Interfaces} `(A.18.27)' -@code{Ada.Containers.Unbounded_Priority_Queues} @emph{(A.18.30)} +@code{Ada.Containers.Unbounded_Priority_Queues} `(A.18.30)' -@code{Ada.Containers.Unbounded_Synchronized_Queues} @emph{(A.18.28)} +@code{Ada.Containers.Unbounded_Synchronized_Queues} `(A.18.28)' -@code{Ada.Containers.Vectors} @emph{(A.18.2)} +@code{Ada.Containers.Vectors} `(A.18.2)' @table @asis -@item @code{Ada.Directories} @emph{(A.16)} +@item @code{Ada.Directories} `(A.16)' This package provides operations on directories. -@item @code{Ada.Directories.Hierarchical_File_Names} @emph{(A.16.1)} +@item @code{Ada.Directories.Hierarchical_File_Names} `(A.16.1)' This package provides additional directory operations handling hiearchical file names. -@item @code{Ada.Directories.Information} @emph{(A.16)} +@item @code{Ada.Directories.Information} `(A.16)' This is an implementation defined package for additional directory operations, which is not implemented in GNAT. -@item @code{Ada.Decimal} @emph{(F.2)} +@item @code{Ada.Decimal} `(F.2)' This package provides constants describing the range of decimal numbers implemented, and also a decimal divide routine (analogous to the COBOL verb DIVIDE … GIVING … REMAINDER …) -@item @code{Ada.Direct_IO} @emph{(A.8.4)} +@item @code{Ada.Direct_IO} `(A.8.4)' This package provides input-output using a model of a set of records of fixed-length, containing an arbitrary definite Ada type, indexed by an integer record number. -@item @code{Ada.Dispatching} @emph{(D.2.1)} +@item @code{Ada.Dispatching} `(D.2.1)' A parent package containing definitions for task dispatching operations. -@item @code{Ada.Dispatching.EDF} @emph{(D.2.6)} +@item @code{Ada.Dispatching.EDF} `(D.2.6)' Not implemented in GNAT. -@item @code{Ada.Dispatching.Non_Preemptive} @emph{(D.2.4)} +@item @code{Ada.Dispatching.Non_Preemptive} `(D.2.4)' Not implemented in GNAT. -@item @code{Ada.Dispatching.Round_Robin} @emph{(D.2.5)} +@item @code{Ada.Dispatching.Round_Robin} `(D.2.5)' Not implemented in GNAT. -@item @code{Ada.Dynamic_Priorities} @emph{(D.5)} +@item @code{Ada.Dynamic_Priorities} `(D.5)' This package allows the priorities of a task to be adjusted dynamically as the task is running. -@item @code{Ada.Environment_Variables} @emph{(A.17)} +@item @code{Ada.Environment_Variables} `(A.17)' This package provides facilities for accessing environment variables. -@item @code{Ada.Exceptions} @emph{(11.4.1)} +@item @code{Ada.Exceptions} `(11.4.1)' This package provides additional information on exceptions, and also contains facilities for treating exceptions as data objects, and raising exceptions with associated messages. -@item @code{Ada.Execution_Time} @emph{(D.14)} +@item @code{Ada.Execution_Time} `(D.14)' This package provides CPU clock functionalities. It is not implemented on all targets (see package spec for details). -@item @code{Ada.Execution_Time.Group_Budgets} @emph{(D.14.2)} +@item @code{Ada.Execution_Time.Group_Budgets} `(D.14.2)' Not implemented in GNAT. -@item @code{Ada.Execution_Time.Timers} @emph{(D.14.1)’} +@item @code{Ada.Execution_Time.Timers} `(D.14.1)’' Not implemented in GNAT. -@item @code{Ada.Finalization} @emph{(7.6)} +@item @code{Ada.Finalization} `(7.6)' This package contains the declarations and subprograms to support the use of controlled types, providing for automatic initialization and finalization (analogous to the constructors and destructors of C++). -@item @code{Ada.Float_Text_IO} @emph{(A.10.9)} +@item @code{Ada.Float_Text_IO} `(A.10.9)' A library level instantiation of Text_IO.Float_IO for type Float. -@item @code{Ada.Float_Wide_Text_IO} @emph{(A.10.9)} +@item @code{Ada.Float_Wide_Text_IO} `(A.10.9)' A library level instantiation of Wide_Text_IO.Float_IO for type Float. -@item @code{Ada.Float_Wide_Wide_Text_IO} @emph{(A.10.9)} +@item @code{Ada.Float_Wide_Wide_Text_IO} `(A.10.9)' A library level instantiation of Wide_Wide_Text_IO.Float_IO for type Float. -@item @code{Ada.Integer_Text_IO} @emph{(A.10.9)} +@item @code{Ada.Integer_Text_IO} `(A.10.9)' A library level instantiation of Text_IO.Integer_IO for type Integer. -@item @code{Ada.Integer_Wide_Text_IO} @emph{(A.10.9)} +@item @code{Ada.Integer_Wide_Text_IO} `(A.10.9)' A library level instantiation of Wide_Text_IO.Integer_IO for type Integer. -@item @code{Ada.Integer_Wide_Wide_Text_IO} @emph{(A.10.9)} +@item @code{Ada.Integer_Wide_Wide_Text_IO} `(A.10.9)' A library level instantiation of Wide_Wide_Text_IO.Integer_IO for type Integer. -@item @code{Ada.Interrupts} @emph{(C.3.2)} +@item @code{Ada.Interrupts} `(C.3.2)' This package provides facilities for interfacing to interrupts, which includes the set of signals or conditions that can be raised and recognized as interrupts. -@item @code{Ada.Interrupts.Names} @emph{(C.3.2)} +@item @code{Ada.Interrupts.Names} `(C.3.2)' This package provides the set of interrupt names (actually signal or condition names) that can be handled by GNAT. -@item @code{Ada.IO_Exceptions} @emph{(A.13)} +@item @code{Ada.IO_Exceptions} `(A.13)' This package defines the set of exceptions that can be raised by use of the standard IO packages. -@item @code{Ada.Iterator_Interfaces} @emph{(5.5.1)} +@item @code{Ada.Iterator_Interfaces} `(5.5.1)' This package provides a generic interface to generalized iterators. -@item @code{Ada.Locales} @emph{(A.19)} +@item @code{Ada.Locales} `(A.19)' This package provides declarations providing information (Language and Country) about the current locale. @@ -21011,7 +20999,7 @@ throughout the numerics packages. Note that the constants pi and e are defined here, and it is better to use these definitions than rolling your own. -@item @code{Ada.Numerics.Complex_Arrays} @emph{(G.3.2)} +@item @code{Ada.Numerics.Complex_Arrays} `(G.3.2)' Provides operations on arrays of complex numbers. @@ -21118,15 +21106,15 @@ The following predefined instantiations of this package exist @code{Ada.Numerics.Long_Elementary_Functions} @end itemize -@item @code{Ada.Numerics.Generic_Real_Arrays} @emph{(G.3.1)} +@item @code{Ada.Numerics.Generic_Real_Arrays} `(G.3.1)' Generic operations on arrays of reals -@item @code{Ada.Numerics.Real_Arrays} @emph{(G.3.1)} +@item @code{Ada.Numerics.Real_Arrays} `(G.3.1)' Preinstantiation of Ada.Numerics.Generic_Real_Arrays (Float). -@item @code{Ada.Real_Time} @emph{(D.8)} +@item @code{Ada.Real_Time} `(D.8)' This package provides facilities similar to those of @code{Calendar}, but operating with a finer clock suitable for real time control. Note that @@ -21135,29 +21123,29 @@ guarantees this behavior, but of course if the external clock on which the GNAT runtime depends is deliberately reset by some external event, then such a backward jump may occur. -@item @code{Ada.Real_Time.Timing_Events} @emph{(D.15)} +@item @code{Ada.Real_Time.Timing_Events} `(D.15)' Not implemented in GNAT. -@item @code{Ada.Sequential_IO} @emph{(A.8.1)} +@item @code{Ada.Sequential_IO} `(A.8.1)' This package provides input-output facilities for sequential files, which can contain a sequence of values of a single type, which can be any Ada type, including indefinite (unconstrained) types. -@item @code{Ada.Storage_IO} @emph{(A.9)} +@item @code{Ada.Storage_IO} `(A.9)' This package provides a facility for mapping arbitrary Ada types to and from a storage buffer. It is primarily intended for the creation of new IO packages. -@item @code{Ada.Streams} @emph{(13.13.1)} +@item @code{Ada.Streams} `(13.13.1)' This is a generic package that provides the basic support for the concept of streams as used by the stream attributes (@code{Input}, @code{Output}, @code{Read} and @code{Write}). -@item @code{Ada.Streams.Stream_IO} @emph{(A.12.1)} +@item @code{Ada.Streams.Stream_IO} `(A.12.1)' This package is a specialization of the type @code{Streams} defined in package @code{Streams} together with a set of operations providing @@ -21165,76 +21153,76 @@ Stream_IO capability. The Stream_IO model permits both random and sequential access to a file which can contain an arbitrary set of values of one or more Ada types. -@item @code{Ada.Strings} @emph{(A.4.1)} +@item @code{Ada.Strings} `(A.4.1)' This package provides some basic constants used by the string handling packages. -@item @code{Ada.Strings.Bounded} @emph{(A.4.4)} +@item @code{Ada.Strings.Bounded} `(A.4.4)' This package provides facilities for handling variable length strings. The bounded model requires a maximum length. It is thus somewhat more limited than the unbounded model, but avoids the use of dynamic allocation or finalization. -@item @code{Ada.Strings.Bounded.Equal_Case_Insensitive} @emph{(A.4.10)} +@item @code{Ada.Strings.Bounded.Equal_Case_Insensitive} `(A.4.10)' Provides case-insensitive comparisons of bounded strings -@item @code{Ada.Strings.Bounded.Hash} @emph{(A.4.9)} +@item @code{Ada.Strings.Bounded.Hash} `(A.4.9)' This package provides a generic hash function for bounded strings -@item @code{Ada.Strings.Bounded.Hash_Case_Insensitive} @emph{(A.4.9)} +@item @code{Ada.Strings.Bounded.Hash_Case_Insensitive} `(A.4.9)' This package provides a generic hash function for bounded strings that converts the string to be hashed to lower case. -@item @code{Ada.Strings.Bounded.Less_Case_Insensitive} @emph{(A.4.10)} +@item @code{Ada.Strings.Bounded.Less_Case_Insensitive} `(A.4.10)' This package provides a comparison function for bounded strings that works in a case insensitive manner by converting to lower case before the comparison. -@item @code{Ada.Strings.Fixed} @emph{(A.4.3)} +@item @code{Ada.Strings.Fixed} `(A.4.3)' This package provides facilities for handling fixed length strings. -@item @code{Ada.Strings.Fixed.Equal_Case_Insensitive} @emph{(A.4.10)} +@item @code{Ada.Strings.Fixed.Equal_Case_Insensitive} `(A.4.10)' This package provides an equality function for fixed strings that compares the strings after converting both to lower case. -@item @code{Ada.Strings.Fixed.Hash_Case_Insensitive} @emph{(A.4.9)} +@item @code{Ada.Strings.Fixed.Hash_Case_Insensitive} `(A.4.9)' This package provides a case insensitive hash function for fixed strings that converts the string to lower case before computing the hash. -@item @code{Ada.Strings.Fixed.Less_Case_Insensitive} @emph{(A.4.10)} +@item @code{Ada.Strings.Fixed.Less_Case_Insensitive} `(A.4.10)' This package provides a comparison function for fixed strings that works in a case insensitive manner by converting to lower case before the comparison. -@item @code{Ada.Strings.Hash} @emph{(A.4.9)} +@item @code{Ada.Strings.Hash} `(A.4.9)' This package provides a hash function for strings. -@item @code{Ada.Strings.Hash_Case_Insensitive} @emph{(A.4.9)} +@item @code{Ada.Strings.Hash_Case_Insensitive} `(A.4.9)' This package provides a hash function for strings that is case insensitive. The string is converted to lower case before computing the hash. -@item @code{Ada.Strings.Less_Case_Insensitive} @emph{(A.4.10)} +@item @code{Ada.Strings.Less_Case_Insensitive} `(A.4.10)' This package provides a comparison function for\strings that works in a case insensitive manner by converting to lower case before the comparison. -@item @code{Ada.Strings.Maps} @emph{(A.4.2)} +@item @code{Ada.Strings.Maps} `(A.4.2)' This package provides facilities for handling character mappings and arbitrarily defined subsets of characters. For instance it is useful in defining specialized translation tables. -@item @code{Ada.Strings.Maps.Constants} @emph{(A.4.6)} +@item @code{Ada.Strings.Maps.Constants} `(A.4.6)' This package provides a standard set of predefined mappings and predefined character sets. For example, the standard upper to lower case @@ -21244,62 +21232,62 @@ characters, including extended characters like E with an acute accent, into account. You should use the mappings in this package (rather than adding 32 yourself) to do case mappings. -@item @code{Ada.Strings.Unbounded} @emph{(A.4.5)} +@item @code{Ada.Strings.Unbounded} `(A.4.5)' This package provides facilities for handling variable length strings. The unbounded model allows arbitrary length strings, but requires the use of dynamic allocation and finalization. -@item @code{Ada.Strings.Unbounded.Equal_Case_Insensitive} @emph{(A.4.10)} +@item @code{Ada.Strings.Unbounded.Equal_Case_Insensitive} `(A.4.10)' Provides case-insensitive comparisons of unbounded strings -@item @code{Ada.Strings.Unbounded.Hash} @emph{(A.4.9)} +@item @code{Ada.Strings.Unbounded.Hash} `(A.4.9)' This package provides a generic hash function for unbounded strings -@item @code{Ada.Strings.Unbounded.Hash_Case_Insensitive} @emph{(A.4.9)} +@item @code{Ada.Strings.Unbounded.Hash_Case_Insensitive} `(A.4.9)' This package provides a generic hash function for unbounded strings that converts the string to be hashed to lower case. -@item @code{Ada.Strings.Unbounded.Less_Case_Insensitive} @emph{(A.4.10)} +@item @code{Ada.Strings.Unbounded.Less_Case_Insensitive} `(A.4.10)' This package provides a comparison function for unbounded strings that works in a case insensitive manner by converting to lower case before the comparison. -@item @code{Ada.Strings.UTF_Encoding} @emph{(A.4.11)} +@item @code{Ada.Strings.UTF_Encoding} `(A.4.11)' This package provides basic definitions for dealing with UTF-encoded strings. -@item @code{Ada.Strings.UTF_Encoding.Conversions} @emph{(A.4.11)} +@item @code{Ada.Strings.UTF_Encoding.Conversions} `(A.4.11)' This package provides conversion functions for UTF-encoded strings. @end table -@code{Ada.Strings.UTF_Encoding.Strings} @emph{(A.4.11)} +@code{Ada.Strings.UTF_Encoding.Strings} `(A.4.11)' -@code{Ada.Strings.UTF_Encoding.Wide_Strings} @emph{(A.4.11)} +@code{Ada.Strings.UTF_Encoding.Wide_Strings} `(A.4.11)' @table @asis -@item @code{Ada.Strings.UTF_Encoding.Wide_Wide_Strings} @emph{(A.4.11)} +@item @code{Ada.Strings.UTF_Encoding.Wide_Wide_Strings} `(A.4.11)' These packages provide facilities for handling UTF encodings for Strings, Wide_Strings and Wide_Wide_Strings. @end table -@code{Ada.Strings.Wide_Bounded} @emph{(A.4.7)} +@code{Ada.Strings.Wide_Bounded} `(A.4.7)' -@code{Ada.Strings.Wide_Fixed} @emph{(A.4.7)} +@code{Ada.Strings.Wide_Fixed} `(A.4.7)' -@code{Ada.Strings.Wide_Maps} @emph{(A.4.7)} +@code{Ada.Strings.Wide_Maps} `(A.4.7)' @table @asis -@item @code{Ada.Strings.Wide_Unbounded} @emph{(A.4.7)} +@item @code{Ada.Strings.Wide_Unbounded} `(A.4.7)' These packages provide analogous capabilities to the corresponding packages without @code{Wide_} in the name, but operate with the types @@ -21307,33 +21295,33 @@ packages without @code{Wide_} in the name, but operate with the types and @code{Character}. Versions of all the child packages are available. @end table -@code{Ada.Strings.Wide_Wide_Bounded} @emph{(A.4.7)} +@code{Ada.Strings.Wide_Wide_Bounded} `(A.4.7)' -@code{Ada.Strings.Wide_Wide_Fixed} @emph{(A.4.7)} +@code{Ada.Strings.Wide_Wide_Fixed} `(A.4.7)' -@code{Ada.Strings.Wide_Wide_Maps} @emph{(A.4.7)} +@code{Ada.Strings.Wide_Wide_Maps} `(A.4.7)' @table @asis -@item @code{Ada.Strings.Wide_Wide_Unbounded} @emph{(A.4.7)} +@item @code{Ada.Strings.Wide_Wide_Unbounded} `(A.4.7)' These packages provide analogous capabilities to the corresponding packages without @code{Wide_} in the name, but operate with the types @code{Wide_Wide_String} and @code{Wide_Wide_Character} instead of @code{String} and @code{Character}. -@item @code{Ada.Synchronous_Barriers} @emph{(D.10.1)} +@item @code{Ada.Synchronous_Barriers} `(D.10.1)' This package provides facilities for synchronizing tasks at a low level with barriers. -@item @code{Ada.Synchronous_Task_Control} @emph{(D.10)} +@item @code{Ada.Synchronous_Task_Control} `(D.10)' This package provides some standard facilities for controlling task communication in a synchronous manner. -@item @code{Ada.Synchronous_Task_Control.EDF} @emph{(D.10)} +@item @code{Ada.Synchronous_Task_Control.EDF} `(D.10)' Not implemented in GNAT. @@ -21342,21 +21330,21 @@ Not implemented in GNAT. This package contains definitions for manipulation of the tags of tagged values. -@item @code{Ada.Tags.Generic_Dispatching_Constructor} @emph{(3.9)} +@item @code{Ada.Tags.Generic_Dispatching_Constructor} `(3.9)' This package provides a way of constructing tagged class-wide values given only the tag value. -@item @code{Ada.Task_Attributes} @emph{(C.7.2)} +@item @code{Ada.Task_Attributes} `(C.7.2)' This package provides the capability of associating arbitrary task-specific data with separate tasks. -@item @code{Ada.Task_Identifification} @emph{(C.7.1)} +@item @code{Ada.Task_Identifification} `(C.7.1)' This package provides capabilities for task identification. -@item @code{Ada.Task_Termination} @emph{(C.7.3)} +@item @code{Ada.Task_Termination} `(C.7.3)' This package provides control over task termination. @@ -21520,12 +21508,12 @@ unchecked conversion nor Ada.Address_To_Access_Conversions should be used in conjunction with pointers to unconstrained objects, since the bounds information cannot be handled correctly in this case. -@item @code{Ada.Unchecked_Deallocation} @emph{(13.11.2)} +@item @code{Ada.Unchecked_Deallocation} `(13.11.2)' This generic package allows explicit freeing of storage previously allocated by use of an allocator. -@item @code{Ada.Wide_Text_IO} @emph{(A.11)} +@item @code{Ada.Wide_Text_IO} `(A.11)' This package is similar to @code{Ada.Text_IO}, except that the external file supports wide character representations, and the internal types are @@ -21533,7 +21521,7 @@ file supports wide character representations, and the internal types are and @code{String}. The corresponding set of nested packages and child packages are defined. -@item @code{Ada.Wide_Wide_Text_IO} @emph{(A.11)} +@item @code{Ada.Wide_Wide_Text_IO} `(A.11)' This package is similar to @code{Ada.Text_IO}, except that the external file supports wide character representations, and the internal types are @@ -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 @@ -22070,7 +22058,7 @@ Encoding @item -@emph{h} +`h' @tab @@ -22078,7 +22066,7 @@ Hex ESC encoding @item -@emph{u} +`u' @tab @@ -22086,7 +22074,7 @@ Upper half encoding @item -@emph{s} +`s' @tab @@ -22094,7 +22082,7 @@ Shift-JIS encoding @item -@emph{e} +`e' @tab @@ -22102,7 +22090,7 @@ EUC Encoding @item -@emph{8} +`8' @tab @@ -22110,7 +22098,7 @@ UTF-8 encoding @item -@emph{b} +`b' @tab @@ -22133,7 +22121,7 @@ being brackets encoding if no coding method was specified with -gnatW). @table @asis -@item @emph{Hex Coding} +@item `Hex Coding' In this encoding, a wide character is represented by a five character sequence: @@ -22156,7 +22144,7 @@ example, ESC A345 is used to represent the wide character with code @table @asis -@item @emph{Upper Half Coding} +@item `Upper Half Coding' The wide character with encoding 16#abcd#, where the upper bit is on (i.e., a is in the range 8-F) is represented as two bytes 16#ab# and @@ -22164,7 +22152,7 @@ The wide character with encoding 16#abcd#, where the upper bit is on not required to be in the upper half. This method can be also used for shift-JIS or EUC where the internal coding matches the external coding. -@item @emph{Shift JIS Coding} +@item `Shift JIS Coding' A wide character is represented by a two character sequence 16#ab# and 16#cd#, with the restrictions described for upper half encoding as @@ -22173,7 +22161,7 @@ character according to the standard algorithm for Shift-JIS conversion. Only characters defined in the JIS code set table can be used with this encoding method. -@item @emph{EUC Coding} +@item `EUC Coding' A wide character is represented by a two character sequence 16#ab# and 16#cd#, with both characters being in the upper half. The internal @@ -22181,7 +22169,7 @@ character code is the corresponding JIS character according to the EUC encoding algorithm. Only characters defined in the JIS code set table can be used with this encoding method. -@item @emph{UTF-8 Coding} +@item `UTF-8 Coding' A wide character is represented using UCS Transformation Format 8 (UTF-8) as defined in Annex R of ISO @@ -22211,7 +22199,7 @@ will all invalid UTF-8 sequences.) @table @asis -@item @emph{Brackets Coding} +@item `Brackets Coding' In this encoding, a wide character is represented by the following eight character sequence: @@ -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 @@ -22352,7 +22340,7 @@ Encoding @item -@emph{h} +`h' @tab @@ -22360,7 +22348,7 @@ Hex ESC encoding @item -@emph{u} +`u' @tab @@ -22368,7 +22356,7 @@ Upper half encoding @item -@emph{s} +`s' @tab @@ -22376,7 +22364,7 @@ Shift-JIS encoding @item -@emph{e} +`e' @tab @@ -22384,7 +22372,7 @@ EUC Encoding @item -@emph{8} +`8' @tab @@ -22392,7 +22380,7 @@ UTF-8 encoding @item -@emph{b} +`b' @tab @@ -22415,7 +22403,7 @@ being brackets encoding if no coding method was specified with -gnatW). @table @asis -@item @emph{UTF-8 Coding} +@item `UTF-8 Coding' A wide character is represented using UCS Transformation Format 8 (UTF-8) as defined in Annex R of ISO @@ -22443,7 +22431,7 @@ characters. @table @asis -@item @emph{Brackets Coding} +@item `Brackets Coding' In this encoding, a wide wide character is represented by the following eight character sequence if is in wide character range @@ -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 @@ -22673,11 +22661,11 @@ variable. And if not set @code{utf8} is assumed. @table @asis -@item @emph{CP_ACP} +@item `CP_ACP' The current system Windows ANSI code page. -@item @emph{CP_UTF8} +@item `CP_UTF8' UTF-8 encoding @end table @@ -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 @@ -22700,19 +22688,19 @@ The possible values are those supported on Windows: @table @asis -@item @emph{TEXT} +@item `TEXT' Translated text mode -@item @emph{WTEXT} +@item `WTEXT' Translated unicode encoding -@item @emph{U16TEXT} +@item `U16TEXT' Unicode 16-bit encoding -@item @emph{U8TEXT} +@item `U8TEXT' Unicode 8-bit encoding @end table @@ -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 @@ -22741,11 +22729,11 @@ using the mode shown in the following table: @tab -@strong{OPEN} +`OPEN' @tab -@strong{CREATE} +`CREATE' @item @@ -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}) @@ -24176,12 +23934,12 @@ C @code{timeval} format. This package implements the CRC-32 algorithm. For a full description of this algorithm see -@emph{Computation of Cyclic Redundancy Checks via Table Look-Up}, +`Computation of Cyclic Redundancy Checks via Table Look-Up', @cite{Communications of the ACM}, Vol. 31 No. 8, pp. 1008-1013, 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++ @@ -25846,7 +25604,7 @@ See @ref{7,,Implementation Defined Pragmas}, for more details. @table @asis -@item @code{pragma CPP_Class ([Entity =>] @emph{LOCAL_NAME})} +@item @code{pragma CPP_Class ([Entity =>] @var{LOCAL_NAME})} The argument denotes an entity in the current declarative region that is declared as a tagged or untagged record type. It indicates that the type @@ -25857,7 +25615,7 @@ Note: Pragma @code{CPP_Class} is currently obsolete. It is supported for backward compatibility but its functionality is available using pragma @code{Import} with @code{Convention} = @code{CPP}. -@item @code{pragma CPP_Constructor ([Entity =>] @emph{LOCAL_NAME})} +@item @code{pragma CPP_Constructor ([Entity =>] @var{LOCAL_NAME})} This pragma identifies an imported function (imported in the usual way with pragma @code{Import}) as corresponding to a C++ constructor. @@ -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 @@ -25941,37 +25699,37 @@ GNAT implements all of these annexes: @table @asis -@item @emph{Systems Programming (Annex C)} +@item `Systems Programming (Annex C)' The Systems Programming Annex is fully implemented. -@item @emph{Real-Time Systems (Annex D)} +@item `Real-Time Systems (Annex D)' The Real-Time Systems Annex is fully implemented. -@item @emph{Distributed Systems (Annex E)} +@item `Distributed Systems (Annex E)' Stub generation is fully implemented in the GNAT compiler. In addition, a complete compatible PCS is available as part of the GLADE system, a separate product. When the two products are used in conjunction, this annex is fully implemented. -@item @emph{Information Systems (Annex F)} +@item `Information Systems (Annex F)' The Information Systems annex is fully implemented. -@item @emph{Numerics (Annex G)} +@item `Numerics (Annex G)' The Numerics Annex is fully implemented. -@item @emph{Safety and Security / High-Integrity Systems (Annex H)} +@item `Safety and Security / High-Integrity Systems (Annex H)' The Safety and Security Annex (termed the High-Integrity Systems Annex in Ada 2005) is fully implemented. @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 @@ -26079,7 +25837,7 @@ No support is provided for GNU C’s symbolic names for input parameters. If there are no input operands, this argument may either be omitted, or explicitly given as @code{No_Input_Operands}. The fourth argument, not present in the above example, is a list of register names, called the -@emph{clobber} argument. This argument, if given, must be a static string +`clobber' argument. This argument, if given, must be a static string expression, and is a space or comma separated list of names of registers that must be considered destroyed as a result of the @code{Asm} call. If this argument is the null string (the default value), then the code @@ -26088,7 +25846,7 @@ In addition to registers, the special clobbers @code{memory} and @code{cc} as described in the GNU C docs are both supported. The fifth argument, not present in the above example, called the -@emph{volatile} argument, is by default @code{False}. It can be set to +`volatile' argument, is by default @code{False}. It can be set to the literal value @code{True} to indicate to the code generator that all optimizations with respect to the instruction specified should be suppressed, and in particular an instruction that has outputs @@ -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 @@ -26259,13 +26017,13 @@ scheduling policy states: @quotation -@emph{When the active priority of a ready task that is not running +`When the active priority of a ready task that is not running changes, or the setting of its base priority takes effect, the task is removed from the ready queue for its old active priority and is added at the tail of the ready queue for its new active priority, except in the case where the active priority is lowered due to the loss of inherited priority, in which case the task is -added at the head of the ready queue for its new active priority.} +added at the head of the ready queue for its new active priority.' @end quotation While most kernels do put tasks at the end of the priority queue when @@ -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 @@ -26354,7 +26112,7 @@ extensive usage as follows: @table @asis -@item @emph{Communication between separate programs} +@item `Communication between separate programs' This allows separate programs to access the data in passive partitions, using protected objects for synchronization where @@ -26364,7 +26122,7 @@ running on different machines with different architectures (e.g., different endianness) to communicate via the data in a passive partition. -@item @emph{Persistence between program runs} +@item `Persistence between program runs' The data in a passive package can persist from one run of a program to another, so that a later program sees the final @@ -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 @@ -26618,7 +26376,7 @@ end T; Word : Rec; @end example -Such an object is said to be @emph{unconstrained}. +Such an object is said to be `unconstrained'. The discriminant of the object can be modified by a full assignment to the object, as long as it preserves the relation between the value of the discriminant, and the value of the components @@ -26671,7 +26429,7 @@ index type of ‘reasonable’ range so that unconstrained objects are not too large. One final wrinkle: if the object is declared to be @code{aliased}, or if it is -created in the heap by means of an allocator, then it is @emph{not} +created in the heap by means of an allocator, then it is `not' unconstrained: it is constrained by the default values of the discriminants, and those values cannot be modified by full assignment. This is because in the presence of @@ -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 @@ -26714,20 +26472,20 @@ perform this check by default). Strict conformance to the Ada Reference Manual can be achieved by adding two compiler options for dynamic checks for access-before-elaboration on subprogram -calls and generic instantiations (@emph{-gnatE}), and stack overflow checking -(@emph{-fstack-check}). +calls and generic instantiations (`-gnatE'), and stack overflow checking +(`-fstack-check'). Note that the result of a floating point arithmetic operation in overflow and invalid situations, when the @code{Machine_Overflows} attribute of the result type is @code{False}, is to generate IEEE NaN and infinite values. This is the case for machines compliant with the IEEE floating-point standard, but on machines that are not fully compliant with this standard, such as Alpha, the -@emph{-mieee} compiler flag must be used for achieving IEEE confirming +`-mieee' compiler flag must be used for achieving IEEE confirming 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 @@ -26744,7 +26502,7 @@ infinite and NaN values are properly generated. This chapter contains a complete list of Ada 2012 features that have been implemented. Generally, these features are only -available if the @emph{-gnat12} (Ada 2012 features enabled) option is set, +available if the `-gnat12' (Ada 2012 features enabled) option is set, which is the default behavior, or if the configuration pragma @code{Ada_2012} is used. @@ -26776,7 +26534,7 @@ A complete description of the AIs may be found in @itemize * @item -@emph{AI-0176 Quantified expressions (2010-09-29)} +`AI-0176 Quantified expressions (2010-09-29)' Both universally and existentially quantified expressions are implemented. They use the new syntax for iterators proposed in AI05-139-2, as well as @@ -26791,9 +26549,9 @@ RM References: 1.01.04 (12) 2.09 (2/2) 4.04 (7) 4.05.09 (0) @itemize * @item -@emph{AI-0079 Allow other_format characters in source (2010-07-10)} +`AI-0079 Allow other_format characters in source (2010-07-10)' -Wide characters in the unicode category @emph{other_format} are now allowed in +Wide characters in the unicode category `other_format' are now allowed in source programs between tokens, but not within a token such as an identifier. RM References: 2.01 (4/2) 2.02 (7) @@ -26805,9 +26563,9 @@ RM References: 2.01 (4/2) 2.02 (7) @itemize * @item -@emph{AI-0091 Do not allow other_format in identifiers (0000-00-00)} +`AI-0091 Do not allow other_format in identifiers (0000-00-00)' -Wide characters in the unicode category @emph{other_format} are not permitted +Wide characters in the unicode category `other_format' are not permitted within an identifier, since this can be a security problem. The error message for this case has been improved to be more specific, but GNAT has never allowed such characters to appear in identifiers. @@ -26821,7 +26579,7 @@ RM References: 2.03 (3.1/2) 2.03 (4/2) 2.03 (5/2) 2.03 (5.1/2) 2.03 (5. @itemize * @item -@emph{AI-0100 Placement of pragmas (2010-07-01)} +`AI-0100 Placement of pragmas (2010-07-01)' This AI is an earlier version of AI-163. It simplifies the rules for legal placement of pragmas. In the case of lists that allow pragmas, if @@ -26836,7 +26594,7 @@ RM References: 2.08 (7) @itemize * @item -@emph{AI-0163 Pragmas in place of null (2010-07-01)} +`AI-0163 Pragmas in place of null (2010-07-01)' A statement sequence may be composed entirely of pragmas. It is no longer necessary to add a dummy @code{null} statement to make the sequence legal. @@ -26850,7 +26608,7 @@ RM References: 2.08 (7) 2.08 (16) @itemize * @item -@emph{AI-0080 ‘View of’ not needed if clear from context (0000-00-00)} +`AI-0080 ‘View of’ not needed if clear from context (0000-00-00)' This is an editorial change only, described as non-testable in the AI. @@ -26863,7 +26621,7 @@ RM References: 3.01 (7) @itemize * @item -@emph{AI-0183 Aspect specifications (2010-08-16)} +`AI-0183 Aspect specifications (2010-08-16)' Aspect specifications have been fully implemented except for pre and post- conditions, and type invariants, which have their own separate AI’s. All @@ -27221,7 +26979,7 @@ RM References: 3.02.01 (3) 3.02.02 (2) 3.03.01 (2/2) 3.08 (6) @itemize * @item -@emph{AI-0128 Inequality is a primitive operation (0000-00-00)} +`AI-0128 Inequality is a primitive operation (0000-00-00)' If an equality operator (“=”) is declared for a type, then the implicitly declared inequality operator (“/=”) is a primitive operation of the type. @@ -27237,7 +26995,7 @@ RM References: 3.02.03 (6) 6.06 (6) @itemize * @item -@emph{AI-0003 Qualified expressions as names (2010-07-11)} +`AI-0003 Qualified expressions as names (2010-07-11)' In Ada 2012, a qualified expression is considered to be syntactically a name, meaning that constructs such as @code{A'(F(X)).B} are now legal. This is @@ -27253,7 +27011,7 @@ RM References: 3.03 (11) 3.03 (21) 4.01 (2) 4.04 (7) 4.07 (3) @itemize * @item -@emph{AI-0120 Constant instance of protected object (0000-00-00)} +`AI-0120 Constant instance of protected object (0000-00-00)' This is an RM editorial change only. The section that lists objects that are constant failed to include the current instance of a protected object @@ -27269,7 +27027,7 @@ RM References: 3.03 (21) @itemize * @item -@emph{AI-0008 General access to constrained objects (0000-00-00)} +`AI-0008 General access to constrained objects (0000-00-00)' The wording in the RM implied that if you have a general access to a constrained object, it could be used to modify the discriminants. This was @@ -27285,7 +27043,7 @@ RM References: 3.03 (23) 3.10.02 (26/2) 4.01 (9) 6.04.01 (17) 8.05.01 ( @itemize * @item -@emph{AI-0093 Additional rules use immutably limited (0000-00-00)} +`AI-0093 Additional rules use immutably limited (0000-00-00)' This is an editorial change only, to make more widespread use of the Ada 2012 ‘immutably limited’. @@ -27299,7 +27057,7 @@ RM References: 3.03 (23.4/3) @itemize * @item -@emph{AI-0096 Deriving from formal private types (2010-07-20)} +`AI-0096 Deriving from formal private types (2010-07-20)' In general it is illegal for a type derived from a formal limited type to be nonlimited. This AI makes an exception to this rule: derivation is legal @@ -27316,7 +27074,7 @@ RM References: 3.04 (5.1/2) 6.02 (7) @itemize * @item -@emph{AI-0181 Soft hyphen is a non-graphic character (2010-07-23)} +`AI-0181 Soft hyphen is a non-graphic character (2010-07-23)' From Ada 2005 on, soft hyphen is considered a non-graphic character, which means that it has a special name (@code{SOFT_HYPHEN}) in conjunction with the @@ -27333,7 +27091,7 @@ RM References: 3.05.02 (2/2) A.01 (35/2) A.03.03 (21) @itemize * @item -@emph{AI-0182 Additional forms for} @code{Character'Value} @emph{(0000-00-00)} +`AI-0182 Additional forms for' @code{Character'Value} `(0000-00-00)' This AI allows @code{Character'Value} to accept the string @code{'?'} where @code{?} is any character including non-graphic control characters. GNAT has @@ -27351,7 +27109,7 @@ RM References: 3.05 (56/2) @itemize * @item -@emph{AI-0214 Defaulted discriminants for limited tagged (2010-10-01)} +`AI-0214 Defaulted discriminants for limited tagged (2010-10-01)' Ada 2012 relaxes the restriction that forbids discriminants of tagged types to have default expressions by allowing them when the type is limited. It @@ -27367,7 +27125,7 @@ RM References: 3.07 (9.1/2) 3.07.02 (3) @itemize * @item -@emph{AI-0102 Some implicit conversions are illegal (0000-00-00)} +`AI-0102 Some implicit conversions are illegal (0000-00-00)' It is illegal to assign an anonymous access constant to an anonymous access variable. The RM did not have a clear rule to prevent this, but GNAT has @@ -27382,7 +27140,7 @@ RM References: 3.07 (16) 3.07.01 (9) 6.04.01 (6) 8.06 (27/2) @itemize * @item -@emph{AI-0158 Generalizing membership tests (2010-09-16)} +`AI-0158 Generalizing membership tests (2010-09-16)' This AI extends the syntax of membership tests to simplify complex conditions that can be expressed as membership in a subset of values of any type. It @@ -27398,7 +27156,7 @@ RM References: 3.08.01 (5) 4.04 (3) 4.05.02 (3) 4.05.02 (5) 4.05.02 (27 @itemize * @item -@emph{AI-0173 Testing if tags represent abstract types (2010-07-03)} +`AI-0173 Testing if tags represent abstract types (2010-07-03)' The function @code{Ada.Tags.Type_Is_Abstract} returns @code{True} if invoked with the tag of an abstract type, and @code{False} otherwise. @@ -27412,7 +27170,7 @@ RM References: 3.09 (7.4/2) 3.09 (12.4/2) @itemize * @item -@emph{AI-0076 function with controlling result (0000-00-00)} +`AI-0076 function with controlling result (0000-00-00)' This is an editorial change only. The RM defines calls with controlling results, but uses the term ‘function with controlling result’ without an @@ -27427,7 +27185,7 @@ RM References: 3.09.02 (2/2) @itemize * @item -@emph{AI-0126 Dispatching with no declared operation (0000-00-00)} +`AI-0126 Dispatching with no declared operation (0000-00-00)' This AI clarifies dispatching rules, and simply confirms that dispatching executes the operation of the parent type when there is no explicitly or @@ -27443,7 +27201,7 @@ RM References: 3.09.02 (20/2) 3.09.02 (20.1/2) 3.09.02 (20.2/2) @itemize * @item -@emph{AI-0097 Treatment of abstract null extension (2010-07-19)} +`AI-0097 Treatment of abstract null extension (2010-07-19)' The RM as written implied that in some cases it was possible to create an object of an abstract type, by having an abstract extension inherit a non- @@ -27459,7 +27217,7 @@ RM References: 3.09.03 (4/2) @itemize * @item -@emph{AI-0203 Extended return cannot be abstract (0000-00-00)} +`AI-0203 Extended return cannot be abstract (0000-00-00)' A return_subtype_indication cannot denote an abstract subtype. GNAT has never permitted such usage. @@ -27473,7 +27231,7 @@ RM References: 3.09.03 (8/3) @itemize * @item -@emph{AI-0198 Inheriting abstract operators (0000-00-00)} +`AI-0198 Inheriting abstract operators (0000-00-00)' This AI resolves a conflict between two rules involving inherited abstract operations and predefined operators. If a derived numeric type inherits @@ -27489,7 +27247,7 @@ RM References: 3.09.03 (4/3) @itemize * @item -@emph{AI-0073 Functions returning abstract types (2010-07-10)} +`AI-0073 Functions returning abstract types (2010-07-10)' This AI covers a number of issues regarding returning abstract types. In particular generic functions cannot have abstract result types or access @@ -27507,7 +27265,7 @@ RM References: 3.09.03 (8) 3.09.03 (10) 6.05 (8/2) @itemize * @item -@emph{AI-0070 Elaboration of interface types (0000-00-00)} +`AI-0070 Elaboration of interface types (0000-00-00)' This is an editorial change only, there are no testable consequences short of checking for the absence of generated code for an interface declaration. @@ -27521,7 +27279,7 @@ RM References: 3.09.04 (18/2) @itemize * @item -@emph{AI-0208 Characteristics of incomplete views (0000-00-00)} +`AI-0208 Characteristics of incomplete views (0000-00-00)' The wording in the Ada 2005 RM concerning characteristics of incomplete views was incorrect and implied that some programs intended to be legal were now @@ -27537,7 +27295,7 @@ RM References: 3.10.01 (2.4/2) 3.10.01 (2.6/2) @itemize * @item -@emph{AI-0162 Incomplete type completed by partial view (2010-09-15)} +`AI-0162 Incomplete type completed by partial view (2010-09-15)' Incomplete types are made more useful by allowing them to be completed by private types and private extensions. @@ -27551,7 +27309,7 @@ RM References: 3.10.01 (2.5/2) 3.10.01 (2.6/2) 3.10.01 (3) 3.10.01 (4/2) @itemize * @item -@emph{AI-0098 Anonymous subprogram access restrictions (0000-00-00)} +`AI-0098 Anonymous subprogram access restrictions (0000-00-00)' An unintentional omission in the RM implied some inconsistent restrictions on the use of anonymous access to subprogram values. These restrictions were not @@ -27566,7 +27324,7 @@ RM References: 3.10.01 (6) 3.10.01 (9.2/2) @itemize * @item -@emph{AI-0199 Aggregate with anonymous access components (2010-07-14)} +`AI-0199 Aggregate with anonymous access components (2010-07-14)' A choice list in a record aggregate can include several components of (distinct) anonymous access types as long as they have matching designated @@ -27581,7 +27339,7 @@ RM References: 4.03.01 (16) @itemize * @item -@emph{AI-0220 Needed components for aggregates (0000-00-00)} +`AI-0220 Needed components for aggregates (0000-00-00)' This AI addresses a wording problem in the RM that appears to permit some complex cases of aggregates with nonstatic discriminants. GNAT has always @@ -27596,7 +27354,7 @@ RM References: 4.03.01 (17) @itemize * @item -@emph{AI-0147 Conditional expressions (2009-03-29)} +`AI-0147 Conditional expressions (2009-03-29)' Conditional expressions are permitted. The form of such an expression is: @@ -27605,10 +27363,10 @@ Conditional expressions are permitted. The form of such an expression is: @end example The parentheses can be omitted in contexts where parentheses are present -anyway, such as subprogram arguments and pragma arguments. If the @strong{else} -clause is omitted, @strong{else} @emph{True} is assumed; +anyway, such as subprogram arguments and pragma arguments. If the `else' +clause is omitted, `else' `True' is assumed; thus @code{(if A then B)} is a way to conveniently represent -@emph{(A implies B)} in standard logic. +`(A implies B)' in standard logic. RM References: 4.03.03 (15) 4.04 (1) 4.04 (7) 4.05.07 (0) 4.07 (2) 4.07 (3) 4.09 (12) 4.09 (33) 5.03 (3) 5.03 (4) 7.05 (2.1/2) @@ -27620,7 +27378,7 @@ RM References: 4.03.03 (15) 4.04 (1) 4.04 (7) 4.05.07 (0) 4.07 (2) @itemize * @item -@emph{AI-0037 Out-of-range box associations in aggregate (0000-00-00)} +`AI-0037 Out-of-range box associations in aggregate (0000-00-00)' This AI confirms that an association of the form @code{Indx => <>} in an array aggregate must raise @code{Constraint_Error} if @code{Indx} @@ -27637,7 +27395,7 @@ RM References: 4.03.03 (29) @itemize * @item -@emph{AI-0123 Composability of equality (2010-04-13)} +`AI-0123 Composability of equality (2010-04-13)' Equality of untagged record composes, so that the predefined equality for a composite type that includes a component of some untagged record type @@ -27663,7 +27421,7 @@ RM References: 4.05.02 (9.7/2) 4.05.02 (14) 4.05.02 (15) 4.05.02 (24) @itemize * @item -@emph{AI-0088 The value of exponentiation (0000-00-00)} +`AI-0088 The value of exponentiation (0000-00-00)' This AI clarifies the equivalence rule given for the dynamic semantics of exponentiation: the value of the operation can be obtained by repeated @@ -27680,7 +27438,7 @@ RM References: 4.05.06 (11) @itemize * @item -@emph{AI-0188 Case expressions (2010-01-09)} +`AI-0188 Case expressions (2010-01-09)' Case expressions are permitted. This allows use of constructs such as: @@ -27697,11 +27455,11 @@ RM References: 4.05.07 (0) 4.05.08 (0) 4.09 (12) 4.09 (33) @itemize * @item -@emph{AI-0104 Null exclusion and uninitialized allocator (2010-07-15)} +`AI-0104 Null exclusion and uninitialized allocator (2010-07-15)' The assignment @code{Ptr := new not null Some_Ptr;} will raise @code{Constraint_Error} because the default value of the allocated object is -@strong{null}. This useless construct is illegal in Ada 2012. +`null'. This useless construct is illegal in Ada 2012. RM References: 4.08 (2) @end itemize @@ -27712,7 +27470,7 @@ RM References: 4.08 (2) @itemize * @item -@emph{AI-0157 Allocation/Deallocation from empty pool (2010-07-11)} +`AI-0157 Allocation/Deallocation from empty pool (2010-07-11)' Allocation and Deallocation from an empty storage pool (i.e. allocation or deallocation of a pointer for which a static storage size clause of zero @@ -27728,7 +27486,7 @@ RM References: 4.08 (5.3/2) 13.11.02 (4) 13.11.02 (17) @itemize * @item -@emph{AI-0179 Statement not required after label (2010-04-10)} +`AI-0179 Statement not required after label (2010-04-10)' It is not necessary to have a statement following a label, so a label can appear at the end of a statement sequence without the need for putting a @@ -27744,7 +27502,7 @@ RM References: 5.01 (2) @itemize * @item -@emph{AI-0139-2 Syntactic sugar for iterators (2010-09-29)} +`AI-0139-2 Syntactic sugar for iterators (2010-09-29)' The new syntax for iterating over arrays and containers is now implemented. Iteration over containers is for now limited to read-only iterators. Only @@ -27759,7 +27517,7 @@ RM References: 5.05 @itemize * @item -@emph{AI-0134 Profiles must match for full conformance (0000-00-00)} +`AI-0134 Profiles must match for full conformance (0000-00-00)' For full conformance, the profiles of anonymous-access-to-subprogram parameters must match. GNAT has always enforced this rule. @@ -27773,7 +27531,7 @@ RM References: 6.03.01 (18) @itemize * @item -@emph{AI-0207 Mode conformance and access constant (0000-00-00)} +`AI-0207 Mode conformance and access constant (0000-00-00)' This AI confirms that access_to_constant indication must match for mode conformance. This was implemented in GNAT when the qualifier was originally @@ -27788,7 +27546,7 @@ RM References: 6.03.01 (16/2) @itemize * @item -@emph{AI-0046 Null exclusion match for full conformance (2010-07-17)} +`AI-0046 Null exclusion match for full conformance (2010-07-17)' For full conformance, in the case of access parameters, the null exclusion must match (either both or neither must have @code{not null}). @@ -27802,7 +27560,7 @@ RM References: 6.03.02 (18) @itemize * @item -@emph{AI-0118 The association of parameter associations (0000-00-00)} +`AI-0118 The association of parameter associations (0000-00-00)' This AI clarifies the rules for named associations in subprogram calls and generic instantiations. The rules have been in place since Ada 83. @@ -27816,7 +27574,7 @@ RM References: 6.04.01 (2) 12.03 (9) @itemize * @item -@emph{AI-0196 Null exclusion tests for out parameters (0000-00-00)} +`AI-0196 Null exclusion tests for out parameters (0000-00-00)' Null exclusion checks are not made for @code{out} parameters when evaluating the actual parameters. GNAT has never generated these checks. @@ -27830,9 +27588,9 @@ RM References: 6.04.01 (13) @itemize * @item -@emph{AI-0015 Constant return objects (0000-00-00)} +`AI-0015 Constant return objects (0000-00-00)' -The return object declared in an @emph{extended_return_statement} may be +The return object declared in an `extended_return_statement' may be declared constant. This was always intended, and GNAT has always allowed it. RM References: 6.05 (2.1/2) 3.03 (10/2) 3.03 (21) 6.05 (5/2) @@ -27845,7 +27603,7 @@ RM References: 6.05 (2.1/2) 3.03 (10/2) 3.03 (21) 6.05 (5/2) @itemize * @item -@emph{AI-0032 Extended return for class-wide functions (0000-00-00)} +`AI-0032 Extended return for class-wide functions (0000-00-00)' If a function returns a class-wide type, the object of an extended return statement can be declared with a specific type that is covered by the class- @@ -27863,7 +27621,7 @@ RM References: 6.05 (5.2/2) 6.05 (5.3/2) 6.05 (5.6/2) 6.05 (5.8/2) @itemize * @item -@emph{AI-0103 Static matching for extended return (2010-07-23)} +`AI-0103 Static matching for extended return (2010-07-23)' If the return subtype of a function is an elementary type or a constrained type, the subtype indication in an extended return statement must match @@ -27878,7 +27636,7 @@ RM References: 6.05 (5.2/2) @itemize * @item -@emph{AI-0058 Abnormal completion of an extended return (0000-00-00)} +`AI-0058 Abnormal completion of an extended return (0000-00-00)' The RM had some incorrect wording implying wrong treatment of abnormal completion in an extended return. GNAT has always implemented the intended @@ -27893,7 +27651,7 @@ RM References: 6.05 (22/2) @itemize * @item -@emph{AI-0050 Raising Constraint_Error early for function call (0000-00-00)} +`AI-0050 Raising Constraint_Error early for function call (0000-00-00)' The implementation permissions for raising @code{Constraint_Error} early on a function call when it was clear an exception would be raised were over-permissive and allowed @@ -27909,7 +27667,7 @@ RM References: 6.05 (24/2) @itemize * @item -@emph{AI-0125 Nonoverridable operations of an ancestor (2010-09-28)} +`AI-0125 Nonoverridable operations of an ancestor (2010-09-28)' In Ada 2012, the declaration of a primitive operation of a type extension or private extension can also override an inherited primitive that is not @@ -27924,7 +27682,7 @@ RM References: 7.03.01 (6) 8.03 (23) 8.03.01 (5/2) 8.03.01 (6/2) @itemize * @item -@emph{AI-0062 Null exclusions and deferred constants (0000-00-00)} +`AI-0062 Null exclusions and deferred constants (0000-00-00)' A full constant may have a null exclusion even if its associated deferred constant does not. GNAT has always allowed this. @@ -27938,7 +27696,7 @@ RM References: 7.04 (6/2) 7.04 (7.1/2) @itemize * @item -@emph{AI-0178 Incomplete views are limited (0000-00-00)} +`AI-0178 Incomplete views are limited (0000-00-00)' This AI clarifies the role of incomplete views and plugs an omission in the RM. GNAT always correctly restricted the use of incomplete views and types. @@ -27952,7 +27710,7 @@ RM References: 7.05 (3/2) 7.05 (6/2) @itemize * @item -@emph{AI-0087 Actual for formal nonlimited derived type (2010-07-15)} +`AI-0087 Actual for formal nonlimited derived type (2010-07-15)' The actual for a formal nonlimited derived type cannot be limited. In particular, a formal derived type that extends a limited interface but which @@ -27967,7 +27725,7 @@ RM References: 7.05 (5/2) 12.05.01 (5.1/2) @itemize * @item -@emph{AI-0099 Tag determines whether finalization needed (0000-00-00)} +`AI-0099 Tag determines whether finalization needed (0000-00-00)' This AI clarifies that ‘needs finalization’ is part of dynamic semantics, and therefore depends on the run-time characteristics of an object (i.e. its @@ -27983,7 +27741,7 @@ RM References: 7.06.01 (6) 7.06.01 (7) 7.06.01 (8) 7.06.01 (9/2) @itemize * @item -@emph{AI-0064 Redundant finalization rule (0000-00-00)} +`AI-0064 Redundant finalization rule (0000-00-00)' This is an editorial change only. The intended behavior is already checked by an existing ACATS test, which GNAT has always executed correctly. @@ -27997,7 +27755,7 @@ RM References: 7.06.01 (17.1/1) @itemize * @item -@emph{AI-0026 Missing rules for Unchecked_Union (2010-07-07)} +`AI-0026 Missing rules for Unchecked_Union (2010-07-07)' Record representation clauses concerning Unchecked_Union types cannot mention the discriminant of the type. The type of a component declared in the variant @@ -28016,7 +27774,7 @@ RM References: 7.06 (9.4/2) B.03.03 (9/2) B.03.03 (10/2) @itemize * @item -@emph{AI-0205 Extended return declares visible name (0000-00-00)} +`AI-0205 Extended return declares visible name (0000-00-00)' This AI corrects a simple omission in the RM. Return objects have always been visible within an extended return statement. @@ -28030,7 +27788,7 @@ RM References: 8.03 (17) @itemize * @item -@emph{AI-0042 Overriding versus implemented-by (0000-00-00)} +`AI-0042 Overriding versus implemented-by (0000-00-00)' This AI fixes a wording gap in the RM. An operation of a synchronized interface can be implemented by a protected or task entry, but the abstract @@ -28047,7 +27805,7 @@ RM References: 9.01 (9.2/2) 9.04 (11.1/2) @itemize * @item -@emph{AI-0030 Requeue on synchronized interfaces (2010-07-19)} +`AI-0030 Requeue on synchronized interfaces (2010-07-19)' Requeue is permitted to a protected, synchronized or task interface primitive providing it is known that the overriding operation is an entry. Otherwise @@ -28066,7 +27824,7 @@ RM References: 9.05 (9) 9.05.04 (2) 9.05.04 (3) 9.05.04 (5) @itemize * @item -@emph{AI-0201 Independence of atomic object components (2010-07-22)} +`AI-0201 Independence of atomic object components (2010-07-22)' If an Atomic object has a pragma @code{Pack} or a @code{Component_Size} attribute, then individual components may not be addressable by independent @@ -28085,7 +27843,7 @@ RM References: 9.10 (1/3) C.06 (22/2) C.06 (23/2) @itemize * @item -@emph{AI-0009 Pragma Independent[_Components] (2010-07-23)} +`AI-0009 Pragma Independent[_Components] (2010-07-23)' This AI introduces the new pragmas @code{Independent} and @code{Independent_Components}, @@ -28102,7 +27860,7 @@ C.06 (4) C.06 (6) C.06 (9) C.06 (13) C.06 (14) @itemize * @item -@emph{AI-0072 Task signalling using ‘Terminated (0000-00-00)} +`AI-0072 Task signalling using ‘Terminated (0000-00-00)' This AI clarifies that task signalling for reading @code{'Terminated} only occurs if the result is True. GNAT semantics has always been consistent with @@ -28117,7 +27875,7 @@ RM References: 9.10 (6.1/1) @itemize * @item -@emph{AI-0108 Limited incomplete view and discriminants (0000-00-00)} +`AI-0108 Limited incomplete view and discriminants (0000-00-00)' This AI confirms that an incomplete type from a limited view does not have discriminants. This has always been the case in GNAT. @@ -28131,7 +27889,7 @@ RM References: 10.01.01 (12.3/2) @itemize * @item -@emph{AI-0129 Limited views and incomplete types (0000-00-00)} +`AI-0129 Limited views and incomplete types (0000-00-00)' This AI clarifies the description of limited views: a limited view of a package includes only one view of a type that has an incomplete declaration @@ -28148,7 +27906,7 @@ RM References: 10.01.01 (12.2/2) 10.01.01 (12.3/2) @itemize * @item -@emph{AI-0077 Limited withs and scope of declarations (0000-00-00)} +`AI-0077 Limited withs and scope of declarations (0000-00-00)' This AI clarifies that a declaration does not include a context clause, and confirms that it is illegal to have a context in which both a limited @@ -28164,7 +27922,7 @@ RM References: 10.01.02 (12/2) 10.01.02 (21/2) 10.01.02 (22/2) @itemize * @item -@emph{AI-0122 Private with and children of generics (0000-00-00)} +`AI-0122 Private with and children of generics (0000-00-00)' This AI clarifies the visibility of private children of generic units within instantiations of a parent. GNAT has always handled this correctly. @@ -28178,7 +27936,7 @@ RM References: 10.01.02 (12/2) @itemize * @item -@emph{AI-0040 Limited with clauses on descendant (0000-00-00)} +`AI-0040 Limited with clauses on descendant (0000-00-00)' This AI confirms that a limited with clause in a child unit cannot name an ancestor of the unit. This has always been checked in GNAT. @@ -28192,7 +27950,7 @@ RM References: 10.01.02 (20/2) @itemize * @item -@emph{AI-0132 Placement of library unit pragmas (0000-00-00)} +`AI-0132 Placement of library unit pragmas (0000-00-00)' This AI fills a gap in the description of library unit pragmas. The pragma clearly must apply to a library unit, even if it does not carry the name @@ -28207,7 +27965,7 @@ RM References: 10.01.05 (7) @itemize * @item -@emph{AI-0034 Categorization of limited views (0000-00-00)} +`AI-0034 Categorization of limited views (0000-00-00)' The RM makes certain limited with clauses illegal because of categorization considerations, when the corresponding normal with would be legal. This is @@ -28222,7 +27980,7 @@ RM References: 10.02.01 (11/1) 10.02.01 (17/2) @itemize * @item -@emph{AI-0035 Inconsistencies with Pure units (0000-00-00)} +`AI-0035 Inconsistencies with Pure units (0000-00-00)' This AI remedies some inconsistencies in the legality rules for Pure units. Derived access types are legal in a pure unit (on the assumption that the @@ -28239,7 +27997,7 @@ RM References: 10.02.01 (15.1/2) 10.02.01 (15.4/2) 10.02.01 (15.5/2) 10.0 @itemize * @item -@emph{AI-0219 Pure permissions and limited parameters (2010-05-25)} +`AI-0219 Pure permissions and limited parameters (2010-05-25)' This AI refines the rules for the cases with limited parameters which do not allow the implementations to omit ‘redundant’. GNAT now properly conforms @@ -28254,7 +28012,7 @@ RM References: 10.02.01 (18/2) @itemize * @item -@emph{AI-0043 Rules about raising exceptions (0000-00-00)} +`AI-0043 Rules about raising exceptions (0000-00-00)' This AI covers various omissions in the RM regarding the raising of exceptions. GNAT has always implemented the intended semantics. @@ -28268,7 +28026,7 @@ RM References: 11.04.01 (10.1/2) 11 (2) @itemize * @item -@emph{AI-0200 Mismatches in formal package declarations (0000-00-00)} +`AI-0200 Mismatches in formal package declarations (0000-00-00)' This AI plugs a gap in the RM which appeared to allow some obviously intended illegal instantiations. GNAT has never allowed these instantiations. @@ -28282,7 +28040,7 @@ RM References: 12.07 (16) @itemize * @item -@emph{AI-0112 Detection of duplicate pragmas (2010-07-24)} +`AI-0112 Detection of duplicate pragmas (2010-07-24)' This AI concerns giving names to various representation aspects, but the practical effect is simply to make the use of duplicate @@ -28300,7 +28058,7 @@ RM References: 13.01 (8) @itemize * @item -@emph{AI-0106 No representation pragmas on generic formals (0000-00-00)} +`AI-0106 No representation pragmas on generic formals (0000-00-00)' The RM appeared to allow representation pragmas on generic formal parameters, but this was not intended, and GNAT has never permitted this usage. @@ -28314,7 +28072,7 @@ RM References: 13.01 (9.1/1) @itemize * @item -@emph{AI-0012 Pack/Component_Size for aliased/atomic (2010-07-15)} +`AI-0012 Pack/Component_Size for aliased/atomic (2010-07-15)' It is now illegal to give an inappropriate component size or a pragma @code{Pack} that attempts to change the component size in the case of atomic @@ -28330,7 +28088,7 @@ RM References: 13.02 (6.1/2) 13.02 (7) C.06 (10) C.06 (11) C.06 (21) @itemize * @item -@emph{AI-0039 Stream attributes cannot be dynamic (0000-00-00)} +`AI-0039 Stream attributes cannot be dynamic (0000-00-00)' The RM permitted the use of dynamic expressions (such as @code{ptr.all})` for stream attributes, but these were never useful and are now illegal. GNAT @@ -28345,7 +28103,7 @@ RM References: 13.03 (4) 13.03 (6) 13.13.02 (38/2) @itemize * @item -@emph{AI-0095 Address of intrinsic subprograms (0000-00-00)} +`AI-0095 Address of intrinsic subprograms (0000-00-00)' The prefix of @code{'Address} cannot statically denote a subprogram with convention @code{Intrinsic}. The use of the @code{Address} attribute raises @@ -28361,7 +28119,7 @@ RM References: 13.03 (11/1) @itemize * @item -@emph{AI-0116 Alignment of class-wide objects (0000-00-00)} +`AI-0116 Alignment of class-wide objects (0000-00-00)' This AI requires that the alignment of a class-wide object be no greater than the alignment of any type in the class. GNAT has always followed this @@ -28376,7 +28134,7 @@ RM References: 13.03 (29) 13.11 (16) @itemize * @item -@emph{AI-0146 Type invariants (2009-09-21)} +`AI-0146 Type invariants (2009-09-21)' Type invariants may be specified for private types using the aspect notation. Aspect @code{Type_Invariant} may be specified for any private type, @@ -28385,7 +28143,7 @@ only be specified for tagged types, and is inherited by any descendent of the tagged types. The invariant is a boolean expression that is tested for being true in the following situations: conversions to the private type, object declarations for the private type that are default initialized, and -[@strong{in}] @strong{out} +[`in'] `out' parameters and returned result on return from any primitive operation for the type that is visible to a client. GNAT defines the synonyms @code{Invariant} for @code{Type_Invariant} and @@ -28400,7 +28158,7 @@ RM References: 13.03.03 (00) @itemize * @item -@emph{AI-0078 Relax Unchecked_Conversion alignment rules (0000-00-00)} +`AI-0078 Relax Unchecked_Conversion alignment rules (0000-00-00)' In Ada 2012, compilers are required to support unchecked conversion where the target alignment is a multiple of the source alignment. GNAT always supported @@ -28416,7 +28174,7 @@ RM References: 13.09 (7) @itemize * @item -@emph{AI-0195 Invalid value handling is implementation defined (2010-07-03)} +`AI-0195 Invalid value handling is implementation defined (2010-07-03)' The handling of invalid values is now designated to be implementation defined. This is a documentation change only, requiring Annex M in the GNAT @@ -28436,7 +28194,7 @@ RM References: 13.09.01 (10) @itemize * @item -@emph{AI-0193 Alignment of allocators (2010-09-16)} +`AI-0193 Alignment of allocators (2010-09-16)' This AI introduces a new attribute @code{Max_Alignment_For_Allocation}, analogous to @code{Max_Size_In_Storage_Elements}, but for alignment instead @@ -28452,7 +28210,7 @@ RM References: 13.11 (16) 13.11 (21) 13.11.01 (0) 13.11.01 (1) @itemize * @item -@emph{AI-0177 Parameterized expressions (2010-07-10)} +`AI-0177 Parameterized expressions (2010-07-10)' The new Ada 2012 notion of parameterized expressions is implemented. The form is: @@ -28474,7 +28232,7 @@ RM References: 13.11.01 (3/2) @itemize * @item -@emph{AI-0033 Attach/Interrupt_Handler in generic (2010-07-24)} +`AI-0033 Attach/Interrupt_Handler in generic (2010-07-24)' Neither of these two pragmas may appear within a generic template, because the generic might be instantiated at other than the library level. @@ -28488,7 +28246,7 @@ RM References: 13.11.02 (16) C.03.01 (7/2) C.03.01 (8/2) @itemize * @item -@emph{AI-0161 Restriction No_Default_Stream_Attributes (2010-09-11)} +`AI-0161 Restriction No_Default_Stream_Attributes (2010-09-11)' A new restriction @code{No_Default_Stream_Attributes} prevents the use of any of the default stream attributes for elementary types. If this restriction is @@ -28504,7 +28262,7 @@ RM References: 13.12.01 (4/2) 13.13.02 (40/2) 13.13.02 (52/2) @itemize * @item -@emph{AI-0194 Value of Stream_Size attribute (0000-00-00)} +`AI-0194 Value of Stream_Size attribute (0000-00-00)' The @code{Stream_Size} attribute returns the default number of bits in the stream representation of the given type. @@ -28521,7 +28279,7 @@ RM References: 13.13.02 (1.2/2) @itemize * @item -@emph{AI-0109 Redundant check in S’Class’Input (0000-00-00)} +`AI-0109 Redundant check in S’Class’Input (0000-00-00)' This AI is an editorial change only. It removes the need for a tag check that can never fail. @@ -28535,7 +28293,7 @@ RM References: 13.13.02 (34/2) @itemize * @item -@emph{AI-0007 Stream read and private scalar types (0000-00-00)} +`AI-0007 Stream read and private scalar types (0000-00-00)' The RM as written appeared to limit the possibilities of declaring read attribute procedures for private scalar types. This limitation was not @@ -28550,7 +28308,7 @@ RM References: 13.13.02 (50/2) 13.13.02 (51/2) @itemize * @item -@emph{AI-0065 Remote access types and external streaming (0000-00-00)} +`AI-0065 Remote access types and external streaming (0000-00-00)' This AI clarifies the fact that all remote access types support external streaming. This fixes an obvious oversight in the definition of the @@ -28565,7 +28323,7 @@ RM References: 13.13.02 (52/2) @itemize * @item -@emph{AI-0019 Freezing of primitives for tagged types (0000-00-00)} +`AI-0019 Freezing of primitives for tagged types (0000-00-00)' The RM suggests that primitive subprograms of a specific tagged type are frozen when the tagged type is frozen. This would be an incompatible change @@ -28581,7 +28339,7 @@ RM References: 13.14 (2) 13.14 (3/1) 13.14 (8.1/1) 13.14 (10) 13.14 (14 @itemize * @item -@emph{AI-0017 Freezing and incomplete types (0000-00-00)} +`AI-0017 Freezing and incomplete types (0000-00-00)' So-called ‘Taft-amendment types’ (i.e., types that are completed in package bodies) are not frozen by the occurrence of bodies in the @@ -28596,7 +28354,7 @@ RM References: 13.14 (3/1) @itemize * @item -@emph{AI-0060 Extended definition of remote access types (0000-00-00)} +`AI-0060 Extended definition of remote access types (0000-00-00)' This AI extends the definition of remote access types to include access to limited, synchronized, protected or task class-wide interface types. @@ -28611,7 +28369,7 @@ RM References: A (4) E.02.02 (9/1) E.02.02 (9.2/1) E.02.02 (14/2) E.02. @itemize * @item -@emph{AI-0114 Classification of letters (0000-00-00)} +`AI-0114 Classification of letters (0000-00-00)' The code points 170 (@code{FEMININE ORDINAL INDICATOR}), 181 (@code{MICRO SIGN}), and @@ -28630,7 +28388,7 @@ RM References: A.03.02 (59) A.04.06 (7) @itemize * @item -@emph{AI-0185 Ada.Wide_[Wide_]Characters.Handling (2010-07-06)} +`AI-0185 Ada.Wide_[Wide_]Characters.Handling (2010-07-06)' Two new packages @code{Ada.Wide_[Wide_]Characters.Handling} provide classification functions for @code{Wide_Character} and @@ -28647,7 +28405,7 @@ RM References: A.03.05 (0) A.03.06 (0) @itemize * @item -@emph{AI-0031 Add From parameter to Find_Token (2010-07-25)} +`AI-0031 Add From parameter to Find_Token (2010-07-25)' A new version of @code{Find_Token} is added to all relevant string packages, with an extra parameter @code{From}. Instead of starting at the first @@ -28667,7 +28425,7 @@ A.04.05 (46) @itemize * @item -@emph{AI-0056 Index on null string returns zero (0000-00-00)} +`AI-0056 Index on null string returns zero (0000-00-00)' The wording in the Ada 2005 RM implied an incompatible handling of the @code{Index} functions, resulting in raising an exception instead of @@ -28684,7 +28442,7 @@ RM References: A.04.03 (56.2/2) A.04.03 (58.5/2) @itemize * @item -@emph{AI-0137 String encoding package (2010-03-25)} +`AI-0137 String encoding package (2010-03-25)' The packages @code{Ada.Strings.UTF_Encoding}, together with its child packages, @code{Conversions}, @code{Strings}, @code{Wide_Strings}, @@ -28710,7 +28468,7 @@ RM References: A.04.11 @itemize * @item -@emph{AI-0038 Minor errors in Text_IO (0000-00-00)} +`AI-0038 Minor errors in Text_IO (0000-00-00)' These are minor errors in the description on three points. The intent on all these points has always been clear, and GNAT has always implemented the @@ -28725,7 +28483,7 @@ RM References: A.10.05 (37) A.10.07 (8/1) A.10.07 (10) A.10.07 (12) A.1 @itemize * @item -@emph{AI-0044 Restrictions on container instantiations (0000-00-00)} +`AI-0044 Restrictions on container instantiations (0000-00-00)' This AI places restrictions on allowed instantiations of generic containers. These restrictions are not checked by the compiler, so there is nothing to @@ -28740,7 +28498,7 @@ RM References: A.18 (4/2) A.18.02 (231/2) A.18.03 (145/2) A.18.06 (56/2) @itemize * @item -@emph{AI-0127 Adding Locale Capabilities (2010-09-29)} +`AI-0127 Adding Locale Capabilities (2010-09-29)' This package provides an interface for identifying the current locale. @@ -28754,7 +28512,7 @@ A.19.07 A.19.08 A.19.09 A.19.10 A.19.11 A.19.12 A.19.13 @itemize * @item -@emph{AI-0002 Export C with unconstrained arrays (0000-00-00)} +`AI-0002 Export C with unconstrained arrays (0000-00-00)' The compiler is not required to support exporting an Ada subprogram with convention C if there are parameters or a return type of an unconstrained @@ -28772,7 +28530,7 @@ RM References: B.01 (17) B.03 (62) B.03 (71.1/2) @itemize * @item -@emph{AI-0216 No_Task_Hierarchy forbids local tasks (0000-00-00)} +`AI-0216 No_Task_Hierarchy forbids local tasks (0000-00-00)' It is clearly the intention that @code{No_Task_Hierarchy} is intended to forbid tasks declared locally within subprograms, or functions returning task @@ -28789,7 +28547,7 @@ RM References: D.07 (3/3) @itemize * @item -@emph{AI-0211 No_Relative_Delays forbids Set_Handler use (2010-07-09)} +`AI-0211 No_Relative_Delays forbids Set_Handler use (2010-07-09)' The restriction @code{No_Relative_Delays} forbids any calls to the subprogram @code{Ada.Real_Time.Timing_Events.Set_Handler}. @@ -28803,12 +28561,12 @@ RM References: D.07 (5) D.07 (10/2) D.07 (10.4/2) D.07 (10.7/2) @itemize * @item -@emph{AI-0190 pragma Default_Storage_Pool (2010-09-15)} +`AI-0190 pragma Default_Storage_Pool (2010-09-15)' This AI introduces a new pragma @code{Default_Storage_Pool}, which can be used to control storage pools globally. In particular, you can force every access -type that is used for allocation (@strong{new}) to have an explicit storage pool, +type that is used for allocation (`new') to have an explicit storage pool, or you can declare a pool globally to be used for all access types that lack an explicit one. @@ -28821,7 +28579,7 @@ RM References: D.07 (8) @itemize * @item -@emph{AI-0189 No_Allocators_After_Elaboration (2010-01-23)} +`AI-0189 No_Allocators_After_Elaboration (2010-01-23)' This AI introduces a new restriction @code{No_Allocators_After_Elaboration}, which says that no dynamic allocation will occur once elaboration is @@ -28840,7 +28598,7 @@ RM References: D.07 (19.1/2) H.04 (23.3/2) @itemize * @item -@emph{AI-0171 Pragma CPU and Ravenscar Profile (2010-09-24)} +`AI-0171 Pragma CPU and Ravenscar Profile (2010-09-24)' A new package @code{System.Multiprocessors} is added, together with the definition of pragma @code{CPU} for controlling task affinity. A new no @@ -28856,7 +28614,7 @@ RM References: D.13.01 (4/2) D.16 @itemize * @item -@emph{AI-0210 Correct Timing_Events metric (0000-00-00)} +`AI-0210 Correct Timing_Events metric (0000-00-00)' This is a documentation only issue regarding wording of metric requirements, that does not affect the implementation of the compiler. @@ -28870,7 +28628,7 @@ RM References: D.15 (24/2) @itemize * @item -@emph{AI-0206 Remote types packages and preelaborate (2010-07-24)} +`AI-0206 Remote types packages and preelaborate (2010-07-24)' Remote types packages are now allowed to depend on preelaborated packages. This was formerly considered illegal. @@ -28884,7 +28642,7 @@ RM References: E.02.02 (6) @itemize * @item -@emph{AI-0152 Restriction No_Anonymous_Allocators (2010-09-08)} +`AI-0152 Restriction No_Anonymous_Allocators (2010-09-08)' Restriction @code{No_Anonymous_Allocators} prevents the use of allocators where the type of the returned value is an anonymous access type. @@ -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,14 +28673,14 @@ 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 GNAT can generate code to zero-out hardware registers before returning from a subprogram. -It can be enabled with the @code{-fzero-call-used-regs=@emph{choice}} +It can be enabled with the @code{-fzero-call-used-regs=`choice'} command-line option, to affect all subprograms in a compilation, and with a @code{Machine_Attribute} pragma, to affect only specific subprograms. @@ -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 @@ -28976,7 +28734,7 @@ pragma Machine_Attribute (Var, "strub"); -- scrubbing of the stack space used by that subprogram. @end example -There are also @code{-fstrub=@emph{choice}} command-line options to +There are also @code{-fstrub=`choice'} command-line options to control default settings. For usage and more details on the command-line options, on the @code{strub} attribute, and their use with other programming languages, see @cite{Using the GNU Compiler Collection (GCC)}. @@ -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 @@ -29447,7 +29205,7 @@ Ada 95 and later versions of the standard: @itemize * @item -@emph{Character literals} +`Character literals' Some uses of character literals are ambiguous. Since Ada 95 has introduced @code{Wide_Character} as a new predefined character type, some uses of @@ -29467,7 +29225,7 @@ for Char in Character range 'A' .. 'Z' loop ... end loop; @end example @item -@emph{New reserved words} +`New reserved words' The identifiers @code{abstract}, @code{aliased}, @code{protected}, @code{requeue}, @code{tagged}, and @code{until} are reserved in Ada 95. @@ -29475,7 +29233,7 @@ Existing Ada 83 code using any of these identifiers must be edited to use some alternative name. @item -@emph{Freezing rules} +`Freezing rules' The rules in Ada 95 are slightly different with regard to the point at which entities are frozen, and representation pragmas and clauses are @@ -29489,7 +29247,7 @@ cannot be applied to a subprogram body. If necessary, a separate subprogram declaration must be introduced to which the pragma can be applied. @item -@emph{Optional bodies for library packages} +`Optional bodies for library packages' In Ada 83, a package that did not require a package body was nevertheless allowed to have one. This lead to certain surprises in compiling large @@ -29506,7 +29264,7 @@ circularities) is to add an @code{Elaborate_Body} pragma to the package spec, since one effect of this pragma is to require the presence of a package body. @item -@emph{Numeric_Error is the same exception as Constraint_Error} +`Numeric_Error is the same exception as Constraint_Error' In Ada 95, the exception @code{Numeric_Error} is a renaming of @code{Constraint_Error}. This means that it is illegal to have separate exception handlers for @@ -29515,7 +29273,7 @@ the two exceptions. The fix is simply to remove the handler for the @code{Constraint_Error} in place of @code{Numeric_Error} in all cases). @item -@emph{Indefinite subtypes in generics} +`Indefinite subtypes in generics' In Ada 83, it was permissible to pass an indefinite type (e.g, @code{String}) as the actual for a generic formal private type, but then the instantiation @@ -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 @@ -29544,7 +29302,7 @@ the fix is usually simply to add the @code{(<>)} to the generic declaration. @itemize * @item -@emph{Conversions} +`Conversions' Conversions from real types to integer types round away from 0. In Ada 83 the conversion Integer(2.5) could deliver either 2 or 3 as its value. This @@ -29556,7 +29314,7 @@ Note, though, that this issue is no worse than already existed in Ada 83 when porting code from one vendor to another. @item -@emph{Tasking} +`Tasking' The Real-Time Annex introduces a set of policies that define the behavior of features that were implementation dependent in Ada 83, such as the order in @@ -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 @@ -29583,7 +29341,7 @@ situation that you should be alert to is the change in the predefined type @itemize * @item -@emph{Range of type `@w{`}Character`@w{`}} +`Range of type `@w{`}Character`@w{`}' The range of @code{Standard.Character} is now the full 256 characters of Latin-1, whereas in most Ada 83 implementations it was restricted @@ -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 @@ -29614,7 +29372,7 @@ covers only the restricted range. @itemize * @item -@emph{-gnat83} switch +`-gnat83' switch All implementations of GNAT provide a switch that causes GNAT to operate in Ada 83 mode. In this mode, some but not all compatibility problems @@ -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 @@ -29655,7 +29413,7 @@ for a complete description please see the @itemize * @item -@emph{New reserved words.} +`New reserved words.' The words @code{interface}, @code{overriding} and @code{synchronized} are reserved in Ada 2005. @@ -29663,7 +29421,7 @@ A pre-Ada 2005 program that uses any of these as an identifier will be illegal. @item -@emph{New declarations in predefined packages.} +`New declarations in predefined packages.' A number of packages in the predefined environment contain new declarations: @code{Ada.Exceptions}, @code{Ada.Real_Time}, @code{Ada.Strings}, @@ -29675,26 +29433,26 @@ If an Ada 95 program does a @code{with} and @code{use} of any of these packages, the new declarations may cause name clashes. @item -@emph{Access parameters.} +`Access parameters.' A nondispatching subprogram with an access parameter cannot be renamed as a dispatching operation. This was permitted in Ada 95. @item -@emph{Access types, discriminants, and constraints.} +`Access types, discriminants, and constraints.' Rule changes in this area have led to some incompatibilities; for example, constrained subtypes of some access types are not permitted in Ada 2005. @item -@emph{Aggregates for limited types.} +`Aggregates for limited types.' The allowance of aggregates for limited types in Ada 2005 raises the possibility of ambiguities in legal Ada 95 programs, since additional types now need to be considered in expression resolution. @item -@emph{Fixed-point multiplication and division.} +`Fixed-point multiplication and division.' Certain expressions involving ‘*’ or ‘/’ for a fixed-point type, which were legal in Ada 95 and invoked the predefined versions of these operations, @@ -29704,14 +29462,14 @@ expression, or by explicitly invoking the operation from package @code{Standard}. @item -@emph{Return-by-reference types.} +`Return-by-reference types.' The Ada 95 return-by-reference mechanism has been removed. Instead, the user 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 @@ -29813,7 +29571,7 @@ elaboration problems) by implicitly inserting @code{Elaborate} or @code{Elaborate_All} pragmas where needed. However, this can lead to the creation of elaboration circularities and a resulting rejection of the program by gnatbind. This issue is -thoroughly described in the @emph{Elaboration Order Handling in GNAT} appendix +thoroughly described in the `Elaboration Order Handling in GNAT' appendix in the @cite{GNAT User’s Guide}. In brief, there are several ways to deal with this situation: @@ -29829,13 +29587,13 @@ elaboration-time code into explicitly-invoked procedures Constrain the elaboration order by including explicit @code{Elaborate_Body} or @code{Elaborate} pragmas, and then inhibit the generation of implicit @code{Elaborate_All} -pragmas either globally (as an effect of the @emph{-gnatE} switch) or locally +pragmas either globally (as an effect of the `-gnatE' switch) or locally (by selectively suppressing elaboration checks via pragma @code{Suppress(Elaboration_Check)} when it is safe to do so). @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 @@ -29869,7 +29627,7 @@ when other compilers appear.) @itemize * @item -@emph{Ada 83 Pragmas and Attributes} +`Ada 83 Pragmas and Attributes' Ada 95 compilers are allowed, but not required, to implement the missing Ada 83 pragmas and attributes that are no longer defined in Ada 95. @@ -29878,7 +29636,7 @@ a compatibility concern, but some other Ada 95 compilers reject these pragmas and attributes. @item -@emph{Specialized Needs Annexes} +`Specialized Needs Annexes' GNAT implements the full set of special needs annexes. At the current time, it is the only Ada 95 compiler to do so. This means that @@ -29886,7 +29644,7 @@ programs making use of these features may not be portable to other Ada 95 compilation systems. @item -@emph{Representation Clauses} +`Representation Clauses' Some other Ada 95 compilers implement only the minimal set of representation clauses required by the Ada 95 reference manual. GNAT goes @@ -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 @@ -29918,7 +29676,7 @@ the cases most likely to arise in existing Ada 83 code. @itemize * @item -@emph{Implicit Packing} +`Implicit Packing' Some Ada 83 compilers allowed a Size specification to cause implicit packing of an array or record. This could cause expensive implicit @@ -29934,7 +29692,7 @@ the explicit pragma @code{Pack}, or for more fine tuned control, provide a Component_Size clause. @item -@emph{Meaning of Size Attribute} +`Meaning of Size Attribute' The Size attribute in Ada 95 (and Ada 2005) for discrete types is defined as the minimal number of bits required to hold values of the type. For example, @@ -29947,7 +29705,7 @@ Object_Size can provide a useful way of duplicating the behavior of some Ada 83 compiler systems. @item -@emph{Size of Access Types} +`Size of Access Types' A common assumption in Ada 83 code is that an access type is in fact a pointer, and that therefore it will be the same size as a System.Address value. This @@ -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 @@ -30000,13 +29758,13 @@ applicable to GNAT. @itemize * @item -@emph{Default floating-point representation} +`Default floating-point representation' In GNAT, the default floating-point format is IEEE, whereas in HP Ada 83, it is VMS format. @item -@emph{System} +`System' the package System in GNAT exactly corresponds to the definition in the Ada 95 reference manual, which means that it excludes many of the @@ -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 @@ -30029,7 +29787,7 @@ Copyright 2000, 2001, 2002, 2007, 2008 Free Software Foundation, Inc Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. -@strong{Preamble} +`Preamble' The purpose of this License is to make a manual, textbook, or other functional and useful document “free” in the sense of freedom: to @@ -30052,23 +29810,23 @@ it can be used for any textual work, regardless of subject matter or whether it is published as a printed book. We recommend this License principally for works whose purpose is instruction or reference. -@strong{1. APPLICABILITY AND DEFINITIONS} +`1. APPLICABILITY AND DEFINITIONS' This License applies to any manual or other work, in any medium, that contains a notice placed by the copyright holder saying it can be distributed under the terms of this License. Such a notice grants a world-wide, royalty-free license, unlimited in duration, to use that -work under the conditions stated herein. The @strong{Document}, below, +work under the conditions stated herein. The `Document', below, refers to any such manual or work. Any member of the public is a -licensee, and is addressed as “@strong{you}”. You accept the license if you +licensee, and is addressed as “`you'”. You accept the license if you copy, modify or distribute the work in a way requiring permission under copyright law. -A “@strong{Modified Version}” of the Document means any work containing the +A “`Modified Version'” of the Document means any work containing the Document or a portion of it, either copied verbatim, or with modifications and/or translated into another language. -A “@strong{Secondary Section}” is a named appendix or a front-matter section of +A “`Secondary Section'” is a named appendix or a front-matter section of the Document that deals exclusively with the relationship of the publishers or authors of the Document to the Document’s overall subject (or to related matters) and contains nothing that could fall directly @@ -30079,7 +29837,7 @@ connection with the subject or with related matters, or of legal, commercial, philosophical, ethical or political position regarding them. -The “@strong{Invariant Sections}” are certain Secondary Sections whose titles +The “`Invariant Sections'” are certain Secondary Sections whose titles are designated, as being those of Invariant Sections, in the notice that says that the Document is released under this License. If a section does not fit the above definition of Secondary then it is not @@ -30087,12 +29845,12 @@ allowed to be designated as Invariant. The Document may contain zero Invariant Sections. If the Document does not identify any Invariant Sections then there are none. -The “@strong{Cover Texts}” are certain short passages of text that are listed, +The “`Cover Texts'” are certain short passages of text that are listed, as Front-Cover Texts or Back-Cover Texts, in the notice that says that the Document is released under this License. A Front-Cover Text may be at most 5 words, and a Back-Cover Text may be at most 25 words. -A “@strong{Transparent}” copy of the Document means a machine-readable copy, +A “`Transparent'” copy of the Document means a machine-readable copy, represented in a format whose specification is available to the general public, that is suitable for revising the document straightforwardly with generic text editors or (for images composed of @@ -30103,7 +29861,7 @@ to text formatters. A copy made in an otherwise Transparent file format whose markup, or absence of markup, has been arranged to thwart or discourage subsequent modification by readers is not Transparent. An image format is not Transparent if used for any substantial amount -of text. A copy that is not “Transparent” is called @strong{Opaque}. +of text. A copy that is not “Transparent” is called `Opaque'. Examples of suitable formats for Transparent copies include plain ASCII without markup, Texinfo input format, LaTeX input format, SGML @@ -30116,22 +29874,22 @@ processing tools are not generally available, and the machine-generated HTML, PostScript or PDF produced by some word processors for output purposes only. -The “@strong{Title Page}” means, for a printed book, the title page itself, +The “`Title Page'” means, for a printed book, the title page itself, plus such following pages as are needed to hold, legibly, the material this License requires to appear in the title page. For works in formats which do not have any title page as such, “Title Page” means the text near the most prominent appearance of the work’s title, preceding the beginning of the body of the text. -The “@strong{publisher}” means any person or entity that distributes +The “`publisher'” means any person or entity that distributes copies of the Document to the public. -A section “@strong{Entitled XYZ}” means a named subunit of the Document whose +A section “`Entitled XYZ'” means a named subunit of the Document whose title either is precisely XYZ or contains XYZ in parentheses following text that translates XYZ in another language. (Here XYZ stands for a -specific section name mentioned below, such as “@strong{Acknowledgements}”, -“@strong{Dedications}”, “@strong{Endorsements}”, or “@strong{History}”.) -To “@strong{Preserve the Title}” +specific section name mentioned below, such as “`Acknowledgements'”, +“`Dedications'”, “`Endorsements'”, or “`History'”.) +To “`Preserve the Title'” of such a section when you modify the Document means that it remains a section “Entitled XYZ” according to this definition. @@ -30142,7 +29900,7 @@ License, but only as regards disclaiming warranties: any other implication that these Warranty Disclaimers may have is void and has no effect on the meaning of this License. -@strong{2. VERBATIM COPYING} +`2. VERBATIM COPYING' You may copy and distribute the Document in any medium, either commercially or noncommercially, provided that this License, the @@ -30157,7 +29915,7 @@ number of copies you must also follow the conditions in section 3. You may also lend copies, under the same conditions stated above, and you may publicly display copies. -@strong{3. COPYING IN QUANTITY} +`3. COPYING IN QUANTITY' If you publish printed copies (or copies in media that commonly have printed covers) of the Document, numbering more than 100, and the @@ -30194,7 +29952,7 @@ It is requested, but not required, that you contact the authors of the Document well before redistributing any large number of copies, to give them a chance to provide you with an updated version of the Document. -@strong{4. MODIFICATIONS} +`4. MODIFICATIONS' You may copy and distribute a Modified Version of the Document under the conditions of sections 2 and 3 above, provided that you release @@ -30311,7 +30069,7 @@ The author(s) and publisher(s) of the Document do not by this License give permission to use their names for publicity for or to assert or imply endorsement of any Modified Version. -@strong{5. COMBINING DOCUMENTS} +`5. COMBINING DOCUMENTS' You may combine the Document with other documents released under this License, under the terms defined in section 4 above for modified @@ -30335,7 +30093,7 @@ in the various original documents, forming one section Entitled and any sections Entitled “Dedications”. You must delete all sections Entitled “Endorsements”. -@strong{6. COLLECTIONS OF DOCUMENTS} +`6. COLLECTIONS OF DOCUMENTS' You may make a collection consisting of the Document and other documents released under this License, and replace the individual copies of this @@ -30348,7 +30106,7 @@ it individually under this License, provided you insert a copy of this License into the extracted document, and follow this License in all other respects regarding verbatim copying of that document. -@strong{7. AGGREGATION WITH INDEPENDENT WORKS} +`7. AGGREGATION WITH INDEPENDENT WORKS' A compilation of the Document or its derivatives with other separate and independent documents or works, in or on a volume of a storage or @@ -30367,7 +30125,7 @@ electronic equivalent of covers if the Document is in electronic form. Otherwise they must appear on printed covers that bracket the whole aggregate. -@strong{8. TRANSLATION} +`8. TRANSLATION' Translation is considered a kind of modification, so you may distribute translations of the Document under the terms of section 4. @@ -30387,7 +30145,7 @@ If a section in the Document is Entitled “Acknowledgements”, its Title (section 1) will typically require changing the actual title. -@strong{9. TERMINATION} +`9. TERMINATION' You may not copy, modify, sublicense, or distribute the Document except as expressly provided under this License. Any attempt @@ -30414,7 +30172,7 @@ this License. If your rights have been terminated and not permanently reinstated, receipt of a copy of some or all of the same material does not give you any rights to use it. -@strong{10. FUTURE REVISIONS OF THIS LICENSE} +`10. FUTURE REVISIONS OF THIS LICENSE' The Free Software Foundation may publish new, revised versions of the GNU Free Documentation License from time to time. Such new @@ -30435,7 +30193,7 @@ License can be used, that proxy’s public statement of acceptance of a version permanently authorizes you to choose that version for the Document. -@strong{11. RELICENSING} +`11. RELICENSING' “Massive Multiauthor Collaboration Site” (or “MMC Site”) means any World Wide Web server that publishes copyrightable works and also @@ -30464,7 +30222,7 @@ The operator of an MMC Site may republish an MMC contained in the site under CC-BY-SA on the same site at any time before August 1, 2009, provided the MMC is eligible for relicensing. -@strong{ADDENDUM: How to use this License for your documents} +`ADDENDUM: How to use this License for your documents' To use this License in a document you have written, include a copy of the License in the document and put the following copyright and diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index 64ebd95..f2cb1ed 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -3,7 +3,7 @@ @setfilename gnat_ugn.info @documentencoding UTF-8 @ifinfo -@*Generated by Sphinx 4.3.1.@* +@*Generated by Sphinx 5.1.1.@* @end ifinfo @settitle GNAT User's Guide for Native Platforms @defindex ge @@ -15,13 +15,11 @@ * gnat_ugn: (gnat_ugn.info). gnat_ugn @end direntry -@definfoenclose strong,`,' -@definfoenclose emph,`,' @c %**end of header @copying @quotation -GNAT User's Guide for Native Platforms , Jul 11, 2022 +GNAT User's Guide for Native Platforms , Sep 09, 2022 AdaCore @@ -48,7 +46,7 @@ Copyright @copyright{} 2008-2022, Free Software Foundation @c %**start of body @anchor{gnat_ugn doc}@anchor{0} -@emph{GNAT, The GNU Ada Development Environment} +`GNAT, The GNU Ada Development Environment' @include gcc-common.texi @@ -705,7 +703,7 @@ and @code{classes}. @code{Variables} @item -@emph{Emphasis} +`Emphasis' @item [optional information or parameters] @@ -939,15 +937,15 @@ following three separate files: @table @asis -@item @emph{greetings.ads} +@item `greetings.ads' spec of package @code{Greetings} -@item @emph{greetings.adb} +@item `greetings.adb' body of package @code{Greetings} -@item @emph{gmain.adb} +@item `gmain.adb' body of main program @end table @@ -1175,8 +1173,8 @@ code is used to represent the end of file. Each file contains a single Ada compilation unit, including any pragmas associated with the unit. For example, this means you must place a -package declaration (a package @emph{spec}) and the corresponding body in -separate files. An Ada @emph{compilation} (which is a sequence of +package declaration (a package `spec') and the corresponding body in +separate files. An Ada `compilation' (which is a sequence of compilation units) is represented using a sequence of files. Similarly, you will place each subunit or child unit in a separate file. @@ -1234,7 +1232,7 @@ GNAT also supports several other 8-bit coding schemes: @table @asis -@item @emph{ISO 8859-2 (Latin-2)} +@item `ISO 8859-2 (Latin-2)' Latin-2 letters allowed in identifiers, with uppercase and lowercase equivalence. @@ -1247,7 +1245,7 @@ equivalence. @table @asis -@item @emph{ISO 8859-3 (Latin-3)} +@item `ISO 8859-3 (Latin-3)' Latin-3 letters allowed in identifiers, with uppercase and lowercase equivalence. @@ -1260,7 +1258,7 @@ equivalence. @table @asis -@item @emph{ISO 8859-4 (Latin-4)} +@item `ISO 8859-4 (Latin-4)' Latin-4 letters allowed in identifiers, with uppercase and lowercase equivalence. @@ -1273,7 +1271,7 @@ equivalence. @table @asis -@item @emph{ISO 8859-5 (Cyrillic)} +@item `ISO 8859-5 (Cyrillic)' ISO 8859-5 letters (Cyrillic) allowed in identifiers, with uppercase and lowercase equivalence. @@ -1286,7 +1284,7 @@ lowercase equivalence. @table @asis -@item @emph{ISO 8859-15 (Latin-9)} +@item `ISO 8859-15 (Latin-9)' ISO 8859-15 (Latin-9) letters allowed in identifiers, with uppercase and lowercase equivalence @@ -1297,7 +1295,7 @@ lowercase equivalence @table @asis -@item @emph{IBM PC (code page 437)} +@item `IBM PC (code page 437)' This code page is the normal default for PCs in the U.S. It corresponds to the original IBM PC character set. This set has some, but not all, of @@ -1311,14 +1309,14 @@ identifiers with uppercase and lowercase equivalence. @table @asis -@item @emph{IBM PC (code page 850)} +@item `IBM PC (code page 850)' This code page is a modification of 437 extended to include all the Latin-1 letters, but still not with the usual Latin-1 encoding. In this mode, all these letters are allowed in identifiers with uppercase and lowercase equivalence. -@item @emph{Full Upper 8-bit} +@item `Full Upper 8-bit' Any character in the range 80-FF allowed in identifiers, and all are considered distinct. In other words, there are no uppercase and lowercase @@ -1326,7 +1324,7 @@ equivalences in this range. This is useful in conjunction with certain encoding schemes used for some foreign character sets (e.g., the typical method of representing Chinese characters on the PC). -@item @emph{No Upper-Half} +@item `No Upper-Half' No upper-half characters in the range 80-FF are allowed in identifiers. This gives Ada 83 compatibility for identifier names. @@ -1349,7 +1347,7 @@ possible encoding schemes: @table @asis -@item @emph{Hex Coding} +@item `Hex Coding' In this encoding, a wide character is represented by the following five character sequence: @@ -1364,7 +1362,7 @@ example, ESC A345 is used to represent the wide character with code @code{16#A345#}. This scheme is compatible with use of the full Wide_Character set. -@item @emph{Upper-Half Coding} +@item `Upper-Half Coding' @geindex Upper-Half Coding @@ -1375,7 +1373,7 @@ character, but is not required to be in the upper half. This method can be also used for shift-JIS or EUC, where the internal coding matches the external coding. -@item @emph{Shift JIS Coding} +@item `Shift JIS Coding' @geindex Shift JIS Coding @@ -1387,7 +1385,7 @@ character according to the standard algorithm for Shift-JIS conversion. Only characters defined in the JIS code set table can be used with this encoding method. -@item @emph{EUC Coding} +@item `EUC Coding' @geindex EUC Coding @@ -1398,7 +1396,7 @@ character code is the corresponding JIS character according to the EUC encoding algorithm. Only characters defined in the JIS code set table can be used with this encoding method. -@item @emph{UTF-8 Coding} +@item `UTF-8 Coding' A wide character is represented using UCS Transformation Format 8 (UTF-8) as defined in Annex R of ISO @@ -1419,7 +1417,7 @@ other wide characters are represented as sequences of upper-half 6-byte sequences, and in the following section on wide wide characters, the use of these sequences is documented). -@item @emph{Brackets Coding} +@item `Brackets Coding' In this encoding, a wide character is represented by the following eight character sequence: @@ -1460,7 +1458,7 @@ possible encoding schemes: @table @asis -@item @emph{UTF-8 Coding} +@item `UTF-8 Coding' A wide character is represented using UCS Transformation Format 8 (UTF-8) as defined in Annex R of ISO @@ -1480,7 +1478,7 @@ is a four, five, or six byte sequence: where the @code{xxx} bits correspond to the left-padded bits of the 32-bit character value. -@item @emph{Brackets Coding} +@item `Brackets Coding' In this encoding, a wide wide character is represented by the following ten or twelve byte character sequence: @@ -1971,7 +1969,7 @@ Display Copyright and version, then exit disregarding all other options. If @code{--version} was not used, display usage, then exit disregarding all other options. -@item @code{--subdirs=@emph{dir}} +@item @code{--subdirs=`dir'} Real object, library or exec directories are subdirectories <dir> of the specified ones. @@ -1990,7 +1988,7 @@ Start another section of directories/patterns. @table @asis -@item @code{-c@emph{filename}} +@item @code{-c`filename'} Create a configuration pragmas file @code{filename} (instead of the default @code{gnat.adc}). @@ -2007,7 +2005,7 @@ specified, no switch @code{-P} may be specified (see below). @table @asis -@item @code{-d@emph{dir}} +@item @code{-d`dir'} Look for source files in directory @code{dir}. There may be zero, one or more spaces between @code{-d} and @code{dir}. @@ -2035,7 +2033,7 @@ specified with switch @code{-d} must exist and be readable. @table @asis -@item @code{-D@emph{filename}} +@item @code{-D`filename'} Look for source files in all directories listed in text file @code{filename}. There may be zero, one or more spaces between @code{-D} @@ -2052,7 +2050,7 @@ Follow symbolic links when processing project files. @geindex -f (gnatname) -@item @code{-f@emph{pattern}} +@item @code{-f`pattern'} Foreign patterns. Using this switch, it is possible to add sources of languages other than Ada to the list of sources of a project file. @@ -2075,7 +2073,7 @@ Output usage (help) information. The output is written to @code{stdout}. @geindex -P (gnatname) -@item @code{-P@emph{proj}} +@item @code{-P`proj'} Create or update project file @code{proj}. There may be zero, one or more space between @code{-P} and @code{proj}. @code{proj} may include directory @@ -2112,7 +2110,7 @@ the Naming Patterns, an indication is given that there is no match. @geindex -x (gnatname) -@item @code{-x@emph{pattern}} +@item @code{-x`pattern'} Excluded patterns. Using this switch, it is possible to exclude some files that would match the name patterns. For example, @@ -2202,7 +2200,7 @@ and GNAT, which use the prefixes respectively. @end itemize -The @code{-gnatk@emph{nn}} +The @code{-gnatk`nn'} switch of the compiler activates a ‘krunching’ circuit that limits file names to nn characters (where nn is a decimal integer). @@ -2611,10 +2609,10 @@ Causes @code{gnatchop} to operate in compilation mode, in which configuration pragmas are handled according to strict RM rules. See previous section for a full description of this mode. -@item @code{-gnat@emph{xxx}} +@item @code{-gnat`xxx'} -This passes the given @code{-gnat@emph{xxx}} switch to @code{gnat} which is -used to parse the given file. Not all @emph{xxx} options make sense, +This passes the given @code{-gnat`xxx'} switch to @code{gnat} which is +used to parse the given file. Not all `xxx' options make sense, but for example, the use of @code{-gnati2} allows @code{gnatchop} to process a source file that uses Latin-2 coding for identifiers. @@ -2629,7 +2627,7 @@ output file showing usage information. @table @asis -@item @code{-k@emph{mm}} +@item @code{-k`mm'} Limit generated file names to the specified number @code{mm} of characters. @@ -2732,7 +2730,7 @@ units to be skipped. @table @asis -@item @code{--GCC=@emph{xxxx}} +@item @code{--GCC=`xxxx'} Specify the path of the GNAT parser to be used. When this switch is used, no attempt is made to add the prefix to the GNAT parser executable. @@ -2904,7 +2902,7 @@ the type of restriction. Restrictions that require partition-wide consistency (like @code{No_Tasking}) are recognized wherever they appear -and can be freely inherited, e.g. from a @emph{with}ed unit to the @emph{with}ing +and can be freely inherited, e.g. from a `with'ed unit to the `with'ing unit. This makes sense since the binder will in any case insist on seeing consistent use, so any unit not conforming to any restrictions that are anywhere in the partition will be rejected, and you might as well find @@ -2945,7 +2943,7 @@ configuration pragmas, or more conveniently by direct editing of the Besides @code{gnat.adc}, additional files containing configuration pragmas may be applied to the current compilation using the switch -@code{-gnatec=@emph{path}} where @code{path} must designate an existing file that +@code{-gnatec=`path'} where @code{path} must designate an existing file that contains only configuration pragmas. These configuration pragmas are in addition to those found in @code{gnat.adc} (provided @code{gnat.adc} is present and switch @code{-gnatA} is not used). @@ -3060,10 +3058,10 @@ additional source files as follows: @itemize * @item -If a file being compiled @emph{with}s a unit @code{X}, the object file +If a file being compiled `with's a unit @code{X}, the object file depends on the file containing the spec of unit @code{X}. This includes -files that are @emph{with}ed implicitly either because they are parents -of @emph{with}ed child units or they are run-time units required by the +files that are `with'ed implicitly either because they are parents +of `with'ed child units or they are run-time units required by the language constructs used in a particular unit. @item @@ -3117,7 +3115,7 @@ The object file for a parent unit depends on all its subunit body files. The previous two rules meant that for purposes of computing dependencies and recompilation, a body and all its subunits are treated as an indivisible whole. -These rules are applied transitively: if unit @code{A} @emph{with}s +These rules are applied transitively: if unit @code{A} `with's unit @code{B}, whose elaboration calls an inlined procedure in package @code{C}, the object file for unit @code{A} will depend on the body of @code{C}, in file @code{c.adb}. @@ -3179,7 +3177,7 @@ checking. Categorization information (e.g., use of pragma @code{Pure}). @item -Information on all @emph{with}ed units, including presence of +Information on all `with'ed units, including presence of @code{Elaborate} or @code{Elaborate_All} pragmas. @item @@ -3249,8 +3247,8 @@ object files for the Ada units of the program. This section describes how to build and use libraries with GNAT, and also shows how to recompile the GNAT run-time library. You should be familiar with the -Project Manager facility (see the @emph{GNAT_Project_Manager} chapter of the -@emph{GPRbuild User’s Guide}) before reading this chapter. +Project Manager facility (see the `GNAT_Project_Manager' chapter of the +`GPRbuild User’s Guide') before reading this chapter. @menu * Introduction to Libraries in GNAT:: @@ -3299,14 +3297,14 @@ documentation purposes. Alternatively, it may expose only the units needed by an external user to make use of the library. That is to say, the specs reflecting the library services along with all the units needed to compile those specs, which can include generic bodies or any body implementing an -inlined routine. In the case of @emph{stand-alone libraries} those exposed -units are called @emph{interface units} (@ref{6b,,Stand-alone Ada Libraries}). +inlined routine. In the case of `stand-alone libraries' those exposed +units are called `interface units' (@ref{6b,,Stand-alone Ada Libraries}). All compilation units comprising an application, including those in a library, need to be elaborated in an order partially defined by Ada’s semantics. GNAT computes the elaboration order from the @code{ALI} files and this is why they constitute a mandatory part of GNAT libraries. -@emph{Stand-alone libraries} are the exception to this rule because a specific +`Stand-alone libraries' are the exception to this rule because a specific library elaboration routine is produced independently of the application(s) using the library. @@ -3328,9 +3326,9 @@ using the library. The easiest way to build a library is to use the Project Manager, -which supports a special type of project called a @emph{Library Project} -(see the @emph{Library Projects} section in the @emph{GNAT Project Manager} -chapter of the @emph{GPRbuild User’s Guide}). +which supports a special type of project called a `Library Project' +(see the `Library Projects' section in the `GNAT Project Manager' +chapter of the `GPRbuild User’s Guide'). A project is considered a library project, when two project-level attributes are defined in it: @code{Library_Name} and @code{Library_Dir}. In order to @@ -3451,9 +3449,9 @@ $ rm *.o $ chmod -w *.ali @end example -Please note that the library must have a name of the form @code{lib@emph{xxx}.a} -or @code{lib@emph{xxx}.so} (or @code{lib@emph{xxx}.dll} on Windows) in order to -be accessed by the directive @code{-l@emph{xxx}} at link time. +Please note that the library must have a name of the form @code{lib`xxx'.a} +or @code{lib`xxx'.so} (or @code{lib`xxx'.dll} on Windows) in order to +be accessed by the directive @code{-l`xxx'} at link time. @node Installing a library,Using a library,Building a library,General Ada Libraries @anchor{gnat_ugn/the_gnat_compilation_model id39}@anchor{71}@anchor{gnat_ugn/the_gnat_compilation_model installing-a-library}@anchor{72} @@ -3465,8 +3463,8 @@ be accessed by the directive @code{-l@emph{xxx}} at link time. @geindex GPR_PROJECT_PATH If you use project files, library installation is part of the library build -process (see the @emph{Installing a Library with Project Files} section of the -@emph{GNAT Project Manager} chapter of the @emph{GPRbuild User’s Guide}). +process (see the `Installing a Library with Project Files' section of the +`GNAT Project Manager' chapter of the `GPRbuild User’s Guide'). When project files are not an option, it is also possible, but not recommended, to install the library so that the sources needed to use the library are on the @@ -3519,7 +3517,7 @@ any part of it. Once again, the project facility greatly simplifies the use of libraries. In this context, using a library is just a matter of adding a -@emph{with} clause in the user project. For instance, to make use of the +`with' clause in the user project. For instance, to make use of the library @code{My_Lib} shown in examples in earlier sections, you can write: @@ -3532,7 +3530,7 @@ end My_Proj; Even if you have a third-party, non-Ada library, you can still use GNAT’s Project Manager facility to provide a wrapper for it. For example, the -following project, when @emph{with}ed by your main project, will link with the +following project, when `with'ed by your main project, will link with the third-party library @code{liba.a}: @example @@ -3662,12 +3660,12 @@ main routine is not written in Ada. GNAT’s Project facility provides a simple way of building and installing -stand-alone libraries; see the @emph{Stand-alone Library Projects} section -in the @emph{GNAT Project Manager} chapter of the @emph{GPRbuild User’s Guide}. +stand-alone libraries; see the `Stand-alone Library Projects' section +in the `GNAT Project Manager' chapter of the `GPRbuild User’s Guide'. To be a Stand-alone Library Project, in addition to the two attributes that make a project a Library Project (@code{Library_Name} and -@code{Library_Dir}; see the @emph{Library Projects} section in the -@emph{GNAT Project Manager} chapter of the @emph{GPRbuild User’s Guide}), +@code{Library_Dir}; see the `Library Projects' section in the +`GNAT Project Manager' chapter of the `GPRbuild User’s Guide'), the attribute @code{Library_Interface} must be defined. For example: @example @@ -4054,7 +4052,7 @@ end Config; The @code{Config} package exists in multiple forms for the various targets, with an appropriate script selecting the version of @code{Config} needed. -Then any other unit requiring conditional compilation can do a @emph{with} +Then any other unit requiring conditional compilation can do a `with' of @code{Config} to make the constants visible. @node Debugging - A Special Case,Conditionalizing Declarations,Use of Boolean Constants,Modeling Conditional Compilation in Ada @@ -4445,7 +4443,7 @@ For further discussion of conditional compilation in general, see @subsubsection Preprocessing Symbols -Preprocessing symbols are defined in @emph{definition files} and referenced in the +Preprocessing symbols are defined in `definition files' and referenced in the sources to be preprocessed. A preprocessing symbol is an identifier, following normal Ada (case-insensitive) rules for its syntax, with the restriction that all characters need to be in the ASCII set (no accented letters). @@ -4470,7 +4468,7 @@ where @table @asis -@item @emph{switches} +@item `switches' is an optional sequence of switches as described in the next section. @end table @@ -4479,7 +4477,7 @@ is an optional sequence of switches as described in the next section. @table @asis -@item @emph{infile} +@item `infile' is the full name of the input file, which is an Ada source file containing preprocessor directives. @@ -4489,7 +4487,7 @@ file containing preprocessor directives. @table @asis -@item @emph{outfile} +@item `outfile' is the full name of the output file, which is an Ada source in standard Ada form. When used with GNAT, this file name will @@ -4580,7 +4578,7 @@ this context since comments are ignored by the compiler in any case). @table @asis -@item @code{-D@emph{symbol}[=@emph{value}]} +@item @code{-D`symbol'[=`value']} Defines a new preprocessing symbol with the specified value. If no value is given on the command line, then symbol is considered to be @code{True}. This switch @@ -4830,7 +4828,7 @@ As noted above, a file to be preprocessed consists of Ada source code in which preprocessing lines have been inserted. However, instead of using @code{gnatprep} to explicitly preprocess a file as a separate step before compilation, you can carry out the preprocessing implicitly -as part of compilation. Such @emph{integrated preprocessing}, which is the common +as part of compilation. Such `integrated preprocessing', which is the common style with C, is performed when either or both of the following switches are passed to the compiler: @@ -4840,7 +4838,7 @@ are passed to the compiler: @itemize * @item -@code{-gnatep}, which specifies the @emph{preprocessor data file}. +@code{-gnatep}, which specifies the `preprocessor data file'. This file dictates how the source files will be preprocessed (e.g., which symbol definition files apply to which sources). @@ -4869,7 +4867,7 @@ When using project files: @item the builder switch @code{-x} should be used if any Ada source is compiled with @code{gnatep=}, so that the compiler finds the -@emph{preprocessor data file}. +`preprocessor data file'. @item the preprocessing data file and the symbol definition files should be @@ -4891,7 +4889,7 @@ that relate to integrated preprocessing. @table @asis -@item @code{-gnatep=@emph{preprocessor_data_file}} +@item @code{-gnatep=`preprocessor_data_file'} This switch specifies the file name (without directory information) of the preprocessor data file. Either place this file @@ -4911,12 +4909,12 @@ end Prj; @end example @end quotation -A preprocessor data file is a text file that contains @emph{preprocessor -control lines}. A preprocessor control line directs the preprocessing of +A preprocessor data file is a text file that contains `preprocessor +control lines'. A preprocessor control line directs the preprocessing of either a particular source file, or, analogous to @code{others} in Ada, all sources not specified elsewhere in the preprocessor data file. A preprocessor control line -can optionally identify a @emph{definition file} that assigns values to +can optionally identify a `definition file' that assigns values to preprocessor symbols, as well as a list of switches that relate to preprocessing. Empty lines and comments (using Ada syntax) are also permitted, with no @@ -5007,7 +5005,7 @@ Causes both preprocessor lines and the lines deleted by preprocessing to be retained as comments marked with the special string ‘@cite{–!}’. -@item @code{-D@emph{symbol}=@emph{new_value}} +@item @code{-D`symbol'=`new_value'} Define or redefine @code{symbol} to have @code{new_value} as its value. The permitted form for @code{symbol} is either an Ada identifier, or any Ada reserved word @@ -5036,7 +5034,7 @@ a @code{#if} or @code{#elsif} test will be treated as an error. @table @asis -@item @code{-gnateD@emph{symbol}[=@emph{new_value}]} +@item @code{-gnateD`symbol'[=`new_value']} Define or redefine @code{symbol} to have @code{new_value} as its value. If no value is supplied, then the value of @code{symbol} is @code{True}. @@ -5533,7 +5531,7 @@ The return type must be the same as the type of the first argument. The size of this type can only be 8, 16, 32, or 64. @item -Binary arithmetic operators: ‘+’, ‘-‘, ‘*’, ‘/’. +Binary arithmetic operators: ‘+’, ‘-’, ‘*’, ‘/’. The corresponding operator declaration must have parameters and result type that have the same root numeric type (for example, all three are long_float types). This simplifies the definition of operations that use type checking @@ -6461,7 +6459,7 @@ If you want to generate a single Ada file and not the transitive closure, you can use instead the @code{-fdump-ada-spec-slim} switch. You can optionally specify a parent unit, of which all generated units will -be children, using @code{-fada-spec-parent=@emph{unit}}. +be children, using @code{-fada-spec-parent=`unit'}. The simple @code{gcc}-based command works only for C headers. For C++ headers you need to use either the @code{g++} command or the combination @code{gcc -x c++}. @@ -6502,7 +6500,7 @@ $ gcc -c -fdump-ada-spec readline1.h Generating bindings for C++ headers is done using the same options, always -with the @emph{g++} compiler. Note that generating Ada spec from C++ headers is a +with the `g++' compiler. Note that generating Ada spec from C++ headers is a much more complex job and support for C++ headers is much more limited that support for C headers. As a result, you will need to modify the resulting bindings by hand more extensively when using C++ headers. @@ -6510,7 +6508,7 @@ bindings by hand more extensively when using C++ headers. In this mode, C++ classes will be mapped to Ada tagged types, constructors will be mapped using the @code{CPP_Constructor} pragma, and when possible, multiple inheritance of abstract classes will be mapped to Ada interfaces -(see the @emph{Interfacing to C++} section in the @cite{GNAT Reference Manual} +(see the `Interfacing to C++' section in the @cite{GNAT Reference Manual} for additional information on interfacing to C++). For example, given the following C++ header file: @@ -6629,7 +6627,7 @@ only. @table @asis -@item @code{-fada-spec-parent=@emph{unit}} +@item @code{-fada-spec-parent=`unit'} Specifies that all files generated by @code{-fdump-ada-spec} are to be child units of the specified parent unit. @@ -6780,7 +6778,7 @@ used for Ada 83. The GNAT model of compilation is close to the C and C++ models. You can think of Ada specs as corresponding to header files in C. As in C, you don’t need to compile specs; they are compiled when they are used. The -Ada @emph{with} is similar in effect to the @code{#include} of a C +Ada `with' is similar in effect to the @code{#include} of a C header. One notable difference is that, in Ada, you may compile specs separately @@ -6830,7 +6828,7 @@ previously compiled. In particular: @itemize * @item -When a unit is @emph{with}ed, the unit seen by the compiler corresponds +When a unit is `with'ed, the unit seen by the compiler corresponds to the version of the unit most recently compiled into the library. @item @@ -6849,7 +6847,7 @@ files can affect the results of a compilation. In particular: @itemize * @item -When a unit is @emph{with}ed, the unit seen by the compiler corresponds +When a unit is `with'ed, the unit seen by the compiler corresponds to the source version of the unit that is currently accessible to the compiler. @@ -7042,8 +7040,8 @@ dependencies, they will always be tracked exactly correctly by @code{gnatmake}. Note that for advanced forms of project structure, we recommend creating -a project file as explained in the @emph{GNAT_Project_Manager} chapter in the -@emph{GPRbuild User’s Guide}, and using the +a project file as explained in the `GNAT_Project_Manager' chapter in the +`GPRbuild User’s Guide', and using the @code{gprbuild} tool which supports building with project files and works similarly to @code{gnatmake}. @@ -7125,7 +7123,7 @@ all other options. @table @asis -@item @code{-P@emph{project}} +@item @code{-P`project'} Build GNAT project file @code{project} using GPRbuild. When this switch is present, all other command-line switches are treated as GPRbuild switches @@ -7140,7 +7138,7 @@ and not @code{gnatmake} switches. @table @asis -@item @code{--GCC=@emph{compiler_name}} +@item @code{--GCC=`compiler_name'} Program used for compiling. The default is @code{gcc}. You need to use quotes around @code{compiler_name} if @code{compiler_name} contains @@ -7163,7 +7161,7 @@ all the additional switches are also taken into account. Thus, @table @asis -@item @code{--GNATBIND=@emph{binder_name}} +@item @code{--GNATBIND=`binder_name'} Program used for binding. The default is @code{gnatbind}. You need to use quotes around @code{binder_name} if @code{binder_name} contains spaces @@ -7181,7 +7179,7 @@ itself must not include any embedded spaces. @table @asis -@item @code{--GNATLINK=@emph{linker_name}} +@item @code{--GNATLINK=`linker_name'} Program used for linking. The default is @code{gnatlink}. You need to use quotes around @code{linker_name} if @code{linker_name} contains spaces @@ -7198,7 +7196,7 @@ itself must not include any embedded spaces. When linking an executable, create a map file. The name of the map file has the same name as the executable with extension “.map”. -@item @code{--create-map-file=@emph{mapfile}} +@item @code{--create-map-file=`mapfile'} When linking an executable, create a map file with the specified name. @end table @@ -7210,7 +7208,7 @@ When linking an executable, create a map file with the specified name. @item @code{--create-missing-dirs} -When using project files (@code{-P@emph{project}}), automatically create +When using project files (@code{-P`project'}), automatically create missing object directories, library directories and exec directories. @@ -7219,7 +7217,7 @@ directories. Disallow simultaneous compilations in the same object directory when project files are used. -@item @code{--subdirs=@emph{subdir}} +@item @code{--subdirs=`subdir'} Actual object directory of each project file is the subdirectory subdir of the object directory specified or defaulted in the project file. @@ -7230,7 +7228,7 @@ By default, shared library projects are not allowed to import static library projects. When this switch is used on the command line, this restriction is relaxed. -@item @code{--source-info=@emph{source info file}} +@item @code{--source-info=`source info file'} Specify a source info file. This switch is active only when project files are used. If the source info file is specified as a relative path, then it is @@ -7341,7 +7339,7 @@ will add any newly accessed sources to the mapping file. @table @asis -@item @code{-C=@emph{file}} +@item @code{-C=`file'} Use a specific mapping file. The file, specified as a path name (absolute or relative) by this switch, should already exist, otherwise the switch is @@ -7373,7 +7371,7 @@ the compiler. These lines are displayed even in quiet output mode. @table @asis -@item @code{-D @emph{dir}} +@item @code{-D `dir'} Put all object files and ALI file in directory @code{dir}. If the @code{-D} switch is not used, all object files @@ -7387,7 +7385,7 @@ This switch cannot be used when using a project file. @table @asis -@item @code{-eI@emph{nnn}} +@item @code{-eI`nnn'} Indicates that the main source is a multi-unit source and the rank of the unit in the source file is nnn. nnn needs to be a positive number and a valid @@ -7499,7 +7497,7 @@ object and ALI files in the directory where it found the dummy file. @table @asis -@item @code{-j@emph{n}} +@item @code{-j`n'} Use @code{n} processes to carry out the (re)compilations. On a multiprocessor machine compilations will occur in parallel. If @code{n} is 0, then the @@ -7591,7 +7589,7 @@ is typically what you want. If you also specify the @code{-a} switch, dependencies of the GNAT internal files are also listed. Note that dependencies of the objects in external Ada libraries (see -switch @code{-aL@emph{dir}} in the following list) +switch @code{-aL`dir'} in the following list) are never reported. @end table @@ -7614,7 +7612,7 @@ file, will eventually result in recompiling all required units. @table @asis -@item @code{-o @emph{exec_name}} +@item @code{-o `exec_name'} Output executable name. The name of the final executable program will be @code{exec_name}. If the @code{-o} switch is omitted the default @@ -7732,7 +7730,7 @@ Verbosity level Medium. Potentially display fewer lines than in verbosity High. Verbosity level High. Equivalent to -v. -@item @code{-vP@emph{x}} +@item @code{-vP`x'} Indicate the verbosity of the parsing of GNAT project files. See @ref{cf,,Switches Related to Project Files}. @@ -7754,7 +7752,7 @@ be those specified on the command line. Even when @code{-x} is used, mains specified on the command line need to be sources of a project file. -@item @code{-X@emph{name}=@emph{value}} +@item @code{-X`name'=`value'} Indicate that external variable @code{name} has the value @code{value}. The Project Manager will use this value for occurrences of @@ -7789,7 +7787,7 @@ is passed to @code{gcc} (e.g., @code{-O}, @code{-gnato,} etc.) @table @asis -@item @code{-aI@emph{dir}} +@item @code{-aI`dir'} When looking for source files also look in directory @code{dir}. The order in which source files search is undertaken is @@ -7801,7 +7799,7 @@ described in @ref{73,,Search Paths and the Run-Time Library (RTL)}. @table @asis -@item @code{-aL@emph{dir}} +@item @code{-aL`dir'} Consider @code{dir} as being an externally provided Ada library. Instructs @code{gnatmake} to skip compilation units whose @code{.ALI} @@ -7809,7 +7807,7 @@ files have been located in directory @code{dir}. This allows you to have missing bodies for the units in @code{dir} and to ignore out of date bodies for the same units. You still need to specify the location of the specs for these units by using the switches -@code{-aI@emph{dir}} or @code{-I@emph{dir}}. +@code{-aI`dir'} or @code{-I`dir'}. Note: this switch is provided for compatibility with previous versions of @code{gnatmake}. The easier method of causing standard libraries to be excluded from consideration is to write-protect the corresponding @@ -7821,7 +7819,7 @@ ALI files. @table @asis -@item @code{-aO@emph{dir}} +@item @code{-aO`dir'} When searching for library and object files, look in directory @code{dir}. The order in which library files are searched is described in @@ -7836,15 +7834,15 @@ When searching for library and object files, look in directory @table @asis -@item @code{-A@emph{dir}} +@item @code{-A`dir'} -Equivalent to @code{-aL@emph{dir}} @code{-aI@emph{dir}}. +Equivalent to @code{-aL`dir'} @code{-aI`dir'}. @geindex -I (gnatmake) -@item @code{-I@emph{dir}} +@item @code{-I`dir'} -Equivalent to @code{-aO@emph{dir} -aI@emph{dir}}. +Equivalent to @code{-aO`dir' -aI`dir'}. @end table @geindex -I- (gnatmake) @@ -7870,11 +7868,11 @@ where @code{gnatmake} was invoked. @table @asis -@item @code{-L@emph{dir}} +@item @code{-L`dir'} Add directory @code{dir} to the list of directories in which the linker will search for libraries. This is equivalent to -@code{-largs} @code{-L@emph{dir}}. +@code{-largs} @code{-L`dir'}. Furthermore, under Windows, the sources pointed to by the libraries path set in the registry are not searched for. @end table @@ -7904,7 +7902,7 @@ Do not look for library files in the system default directory. @table @asis -@item @code{--RTS=@emph{rts-path}} +@item @code{--RTS=`rts-path'} Specifies the default location of the run-time library. GNAT looks for the run-time @@ -7916,13 +7914,13 @@ in the following directories, and stops as soon as a valid run-time is found @itemize * @item -@emph{<current directory>/$rts_path} +`<current directory>/$rts_path' @item -@emph{<default-search-dir>/$rts_path} +`<default-search-dir>/$rts_path' @item -@emph{<default-search-dir>/rts-$rts_path} +`<default-search-dir>/rts-$rts_path' @item The selected path is handled like a normal RTS path. @@ -7946,7 +7944,7 @@ designated component of GNAT. @table @asis -@item @code{-cargs @emph{switches}} +@item @code{-cargs `switches'} Compiler switches. Here @code{switches} is a list of switches that are valid switches for @code{gcc}. They will be passed on to @@ -7958,7 +7956,7 @@ all compile steps performed by @code{gnatmake}. @table @asis -@item @code{-bargs @emph{switches}} +@item @code{-bargs `switches'} Binder switches. Here @code{switches} is a list of switches that are valid switches for @code{gnatbind}. They will be passed on to @@ -7970,7 +7968,7 @@ all bind steps performed by @code{gnatmake}. @table @asis -@item @code{-largs @emph{switches}} +@item @code{-largs `switches'} Linker switches. Here @code{switches} is a list of switches that are valid switches for @code{gnatlink}. They will be passed on to @@ -7982,7 +7980,7 @@ all link steps performed by @code{gnatmake}. @table @asis -@item @code{-margs @emph{switches}} +@item @code{-margs `switches'} Make switches. The switches are directly interpreted by @code{gnatmake}, regardless of any previous occurrence of @code{-cargs}, @code{-bargs} @@ -8034,9 +8032,9 @@ unless @code{-a} is also specified. @item @code{gnatmake} has been designed to make the use of Ada libraries particularly convenient. Assume you have an Ada library organized -as follows: @emph{obj-dir} contains the objects and ALI files for +as follows: `obj-dir' contains the objects and ALI files for of your Ada compilation units, -whereas @emph{include-dir} contains the +whereas `include-dir' contains the specs of these units, but no bodies. Then to compile a unit stored in @code{main.adb}, which uses this Ada library you would just type: @@ -8070,7 +8068,7 @@ it may be useful to have some basic understanding of the @code{gnatmake} approach and in particular to understand how it uses the results of previous compilations without incorrectly depending on them. -First a definition: an object file is considered @emph{up to date} if the +First a definition: an object file is considered `up to date' if the corresponding ALI file exists and if all the source files listed in the dependency section of this ALI file have time stamps matching those in the ALI file. This means that neither the source file itself nor any @@ -8114,13 +8112,13 @@ by @code{gnatmake}. It may be necessary to use the switch @table @asis -@item @emph{gnatmake hello.adb} +@item `gnatmake hello.adb' Compile all files necessary to bind and link the main program @code{hello.adb} (containing unit @code{Hello}) and bind and link the resulting object files to generate an executable file @code{hello}. -@item @emph{gnatmake main1 main2 main3} +@item `gnatmake main1 main2 main3' Compile all files necessary to bind and link the main programs @code{main1.adb} (containing unit @code{Main1}), @code{main2.adb} @@ -8129,7 +8127,7 @@ Compile all files necessary to bind and link the main programs to generate three executable files @code{main1}, @code{main2} and @code{main3}. -@item @emph{gnatmake -q Main_Unit -cargs -O2 -bargs -l} +@item `gnatmake -q Main_Unit -cargs -O2 -bargs -l' Compile all files necessary to bind and link the main program unit @code{Main_Unit} (from file @code{main_unit.adb}). All compilations will @@ -8180,7 +8178,7 @@ the body file (@code{.adb}) for a library level package or generic package that has a body @end itemize -You need @emph{not} compile the following files +You need `not' compile the following files @itemize * @@ -8242,7 +8240,7 @@ two output files in the current directory, but you may specify a source file in any directory using an absolute or relative path specification containing the directory information. -TESTING: the @code{--foobar@emph{NN}} switch +TESTING: the @code{--foobar`NN'} switch @geindex gnat1 @@ -8407,7 +8405,7 @@ file directly. @item When you compile a unit, the source files for the specs of all units -that it @emph{with}s, all its subunits, and the bodies of any generics it +that it `with's, all its subunits, and the bodies of any generics it instantiates must be available (reachable by the search-paths mechanism described above), or you will receive a fatal error message. @end itemize @@ -8489,7 +8487,7 @@ compilation units. @table @asis -@item @code{-b @emph{target}} +@item @code{-b `target'} Compile your program to run on @code{target}, which is the name of a system configuration. You must have a GNAT cross-compiler built if @@ -8501,7 +8499,7 @@ system configuration. You must have a GNAT cross-compiler built if @table @asis -@item @code{-B@emph{dir}} +@item @code{-B`dir'} Load compiler executables (for example, @code{gnat1}, the Ada compiler) from @code{dir} instead of the default location. Only use this switch @@ -8587,7 +8585,7 @@ emitted in the debug information. @table @asis -@item @code{-flto[=@emph{n}]} +@item @code{-flto[=`n']} Enables Link Time Optimization. This switch must be used in conjunction with the @code{-Ox} switches (but not with the @code{-gnatn} switch @@ -8978,7 +8976,7 @@ ALI files. @table @asis -@item @code{-gnatec=@emph{path}} +@item @code{-gnatec=`path'} Specify a configuration pragma file (the equal sign is optional) @@ -9012,7 +9010,7 @@ Disable atomic synchronization @table @asis -@item @code{-gnateDsymbol[=@emph{value}]} +@item @code{-gnateDsymbol[=`value']} Defines a symbol, associated with @code{value}, for preprocessing. (@ref{90,,Integrated Preprocessing}). @@ -9084,7 +9082,7 @@ Save result of preprocessing in a text file. @table @asis -@item @code{-gnatei@emph{nnn}} +@item @code{-gnatei`nnn'} Set maximum number of instantiations during compilation of a single unit to @code{nnn}. This may be useful in increasing the default maximum of 8000 for @@ -9096,7 +9094,7 @@ the rare case when a single unit legitimately exceeds this limit. @table @asis -@item @code{-gnateI@emph{nnn}} +@item @code{-gnateI`nnn'} Indicates that the source is a multi-unit source and that the index of the unit to compile is @code{nnn}. @code{nnn} needs to be a positive number and need @@ -9135,7 +9133,7 @@ This switch turns off the info messages about implicit elaboration pragmas. @table @asis -@item @code{-gnatem=@emph{path}} +@item @code{-gnatem=`path'} Specify a mapping file (the equal sign is optional) @@ -9147,7 +9145,7 @@ Specify a mapping file @table @asis -@item @code{-gnatep=@emph{file}} +@item @code{-gnatep=`file'} Specify a preprocessing data file (the equal sign is optional) @@ -9184,7 +9182,7 @@ Synonym of @code{-fdump-scos}, kept for backwards compatibility. @table @asis -@item @code{-gnatet=@emph{path}} +@item @code{-gnatet=`path'} Generate target dependent information. The format of the output file is described in the section about switch @code{-gnateT}. @@ -9195,7 +9193,7 @@ described in the section about switch @code{-gnateT}. @table @asis -@item @code{-gnateT=@emph{path}} +@item @code{-gnateT=`path'} Read target dependent information, such as endianness or sizes and alignments of base type. If this switch is passed, the default target dependent @@ -9449,7 +9447,7 @@ For further details see @ref{f,,Elaboration Order Handling in GNAT}. @table @asis -@item @code{-gnati@emph{c}} +@item @code{-gnati`c'} Identifier character set (@code{c} = 1/2/3/4/5/9/p/8/f/n/w). For details of the possible selections for @code{c}, @@ -9482,7 +9480,7 @@ code is likely to malfunction at run time. @table @asis -@item @code{-gnatj@emph{nn}} +@item @code{-gnatj`nn'} Reformat error messages to fit on @code{nn} character lines @end table @@ -9543,7 +9541,7 @@ details see @ref{f,,Elaboration Order Handling in GNAT}. @table @asis -@item @code{-gnatk=@emph{n}} +@item @code{-gnatk=`n'} Limit file names to @code{n} (1-999) characters (@code{k} = krunch). @end table @@ -9575,7 +9573,7 @@ source output. @table @asis -@item @code{-gnatm=@emph{n}} +@item @code{-gnatm=`n'} Limit number of detected error or warning messages to @code{n} where @code{n} is in the range 1..999999. The default setting if @@ -9656,7 +9654,7 @@ Interpretation @item -@emph{1} +`1' @tab @@ -9664,7 +9662,7 @@ All intermediate overflows checked against base type (@code{STRICT}) @item -@emph{2} +`2' @tab @@ -9672,7 +9670,7 @@ Minimize intermediate overflows (@code{MINIMIZED}) @item -@emph{3} +`3' @tab @@ -9795,7 +9793,7 @@ Print package Standard. @table @asis -@item @code{-gnatT@emph{nnn}} +@item @code{-gnatT`nnn'} All compiler tables start at @code{nnn} times usual starting size. @end table @@ -9845,7 +9843,7 @@ Control level of validity checking (@ref{e7,,Validity Checking}). @table @asis -@item @code{-gnatw@emph{xxx}} +@item @code{-gnatw`xxx'} Warning mode where @code{xxx} is a string of option letters that denotes @@ -9858,7 +9856,7 @@ are enabled or disabled (@ref{eb,,Warning Message Control}). @table @asis -@item @code{-gnatW@emph{e}} +@item @code{-gnatW`e'} Wide character encoding method (@code{e}=n/h/u/s/e/8). @@ -9899,7 +9897,7 @@ Enable built-in style checks (@ref{ec,,Style Checking}). @table @asis -@item @code{-gnatz@emph{m}} +@item @code{-gnatz`m'} Distribution stub generation and compilation (@code{m}=r/c for receiver/caller stubs). @@ -9910,7 +9908,7 @@ Distribution stub generation and compilation @table @asis -@item @code{-I@emph{dir}} +@item @code{-I`dir'} @geindex RTL @@ -9938,7 +9936,7 @@ files in the directory containing the source file named in the command line @table @asis -@item @code{-o @emph{file}} +@item @code{-o `file'} This switch is used in @code{gcc} to redirect the generated object file and its associated ALI file. Beware of this switch with GNAT, because it may @@ -9973,7 +9971,7 @@ Library (RTL) ALI files. @table @asis -@item @code{-O[@emph{n}]} +@item @code{-O[`n']} @code{n} controls the optimization level: @@ -9981,7 +9979,7 @@ Library (RTL) ALI files. @multitable {xxxxxxxxx} {xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx} @item -@emph{n} +`n' @tab @@ -9989,7 +9987,7 @@ Effect @item -@emph{0} +`0' @tab @@ -9997,7 +9995,7 @@ No optimization, the default setting if no @code{-O} appears @item -@emph{1} +`1' @tab @@ -10007,7 +10005,7 @@ time. @item -@emph{2} +`2' @tab @@ -10016,7 +10014,7 @@ the cost of substantially increased compilation time. @item -@emph{3} +`3' @tab @@ -10025,7 +10023,7 @@ subprograms in the same unit. @item -@emph{s} +`s' @tab @@ -10053,7 +10051,7 @@ exit status. @table @asis -@item @code{--RTS=@emph{rts-path}} +@item @code{--RTS=`rts-path'} Specifies the default location of the run-time library. Same meaning as the equivalent @code{gnatmake} flag (@ref{ce,,Switches for gnatmake}). @@ -10102,7 +10100,7 @@ compiler you are executing. @table @asis -@item @code{-V @emph{ver}} +@item @code{-V `ver'} Execute @code{ver} version of the compiler. This is the @code{gcc} version, not the GNAT version. @@ -10301,7 +10299,7 @@ warning messages generated. @table @asis -@item @code{-gnatl=@emph{fname}} +@item @code{-gnatl=`fname'} This has the same effect as @code{-gnatl} except that the output is written to a file instead of to standard output. If the given name @@ -10345,7 +10343,7 @@ format message or full listing (which as usual is written to @table @asis -@item @code{-gnatm=@emph{n}} +@item @code{-gnatm=`n'} The @code{m} stands for maximum. @code{n} is a decimal integer in the @@ -10607,7 +10605,7 @@ Wrong length on string assignment Violations of style rules if style checking is enabled @item -Unused @emph{with} clauses +Unused `with' clauses @item @code{Bit_Order} usage that does not have any effect @@ -10622,7 +10620,7 @@ Dereference of possibly null value Declaration that is likely to cause storage error @item -Internal GNAT unit @emph{with}ed by application unit +Internal GNAT unit `with'ed by application unit @item Values known to be out of range at compile time @@ -10676,7 +10674,7 @@ of the pragma in the @cite{GNAT_Reference_manual}). @item @code{-gnatwa} -@emph{Activate most optional warnings.} +`Activate most optional warnings.' This switch activates most optional warning messages. See the remaining list in this section for details on optional warning messages that can be @@ -10751,7 +10749,7 @@ All other optional warnings are turned on. @item @code{-gnatwA} -@emph{Suppress all optional errors.} +`Suppress all optional errors.' This switch suppresses all optional warning messages, see remaining list in this section for details on optional warning messages that can be @@ -10773,7 +10771,7 @@ the warnings for implicit dereferencing. @item @code{-gnatw.a} -@emph{Activate warnings on failing assertions.} +`Activate warnings on failing assertions.' @geindex Assert failures @@ -10790,7 +10788,7 @@ generated. @item @code{-gnatw.A} -@emph{Suppress warnings on failing assertions.} +`Suppress warnings on failing assertions.' @geindex Assert failures @@ -10805,7 +10803,7 @@ compile time that the assertion will fail. @item @code{-gnatw_a} -@emph{Activate warnings on anonymous allocators.} +`Activate warnings on anonymous allocators.' @geindex Anonymous allocators @@ -10822,7 +10820,7 @@ RM 3.10.2 (14). @item @code{-gnatw_A} -@emph{Supress warnings on anonymous allocators.} +`Supress warnings on anonymous allocators.' @geindex Anonymous allocators @@ -10836,7 +10834,7 @@ This switch suppresses warnings for anonymous access type allocators. @item @code{-gnatwb} -@emph{Activate warnings on bad fixed values.} +`Activate warnings on bad fixed values.' @geindex Bad fixed values @@ -10860,7 +10858,7 @@ are not generated. @item @code{-gnatwB} -@emph{Suppress warnings on bad fixed values.} +`Suppress warnings on bad fixed values.' This switch suppresses warnings for static fixed-point expressions whose value is not an exact multiple of Small. @@ -10873,7 +10871,7 @@ value is not an exact multiple of Small. @item @code{-gnatw.b} -@emph{Activate warnings on biased representation.} +`Activate warnings on biased representation.' @geindex Biased representation @@ -10890,7 +10888,7 @@ to represent 10/11). The default is that such warnings are generated. @item @code{-gnatw.B} -@emph{Suppress warnings on biased representation.} +`Suppress warnings on biased representation.' This switch suppresses warnings for representation clauses that force the use of biased representation. @@ -10903,7 +10901,7 @@ of biased representation. @item @code{-gnatwc} -@emph{Activate warnings on conditionals.} +`Activate warnings on conditionals.' @geindex Conditionals @geindex constant @@ -10940,7 +10938,7 @@ This warning can also be turned on using @code{-gnatwa}. @item @code{-gnatwC} -@emph{Suppress warnings on conditionals.} +`Suppress warnings on conditionals.' This switch suppresses warnings for conditional expressions used in tests that are known to be True or False at compile time. @@ -10953,7 +10951,7 @@ tests that are known to be True or False at compile time. @item @code{-gnatw.c} -@emph{Activate warnings on missing component clauses.} +`Activate warnings on missing component clauses.' @geindex Component clause @geindex missing @@ -10971,7 +10969,7 @@ component for which no component clause is present. @item @code{-gnatw.C} -@emph{Suppress warnings on missing component clauses.} +`Suppress warnings on missing component clauses.' This switch suppresses warnings for record components that are missing a component clause in the situation described above. @@ -10984,7 +10982,7 @@ missing a component clause in the situation described above. @item @code{-gnatw_c} -@emph{Activate warnings on unknown condition in Compile_Time_Warning.} +`Activate warnings on unknown condition in Compile_Time_Warning.' @geindex Compile_Time_Warning @@ -11003,7 +11001,7 @@ The default is that such warnings are generated. @item @code{-gnatw_C} -@emph{Suppress warnings on unknown condition in Compile_Time_Warning.} +`Suppress warnings on unknown condition in Compile_Time_Warning.' This switch supresses warnings on a pragma Compile_Time_Warning or Compile_Time_Error whose condition has a value that is not @@ -11017,7 +11015,7 @@ known at compile time. @item @code{-gnatwd} -@emph{Activate warnings on implicit dereferencing.} +`Activate warnings on implicit dereferencing.' If this switch is set, then the use of a prefix of an access type in an indexed component, slice, or selected component without an @@ -11035,7 +11033,7 @@ warnings are not generated. @item @code{-gnatwD} -@emph{Suppress warnings on implicit dereferencing.} +`Suppress warnings on implicit dereferencing.' @geindex Implicit dereferencing @@ -11053,7 +11051,7 @@ indexed components, slices, and selected components. @item @code{-gnatw.d} -@emph{Activate tagging of warning and info messages.} +`Activate tagging of warning and info messages.' If this switch is set, then warning messages are tagged, with one of the following strings: @@ -11064,35 +11062,35 @@ following strings: @itemize - @item -@emph{[-gnatw?]} +`[-gnatw?]' Used to tag warnings controlled by the switch @code{-gnatwx} where x is a letter a-z. @item -@emph{[-gnatw.?]} +`[-gnatw.?]' Used to tag warnings controlled by the switch @code{-gnatw.x} where x is a letter a-z. @item -@emph{[-gnatel]} +`[-gnatel]' Used to tag elaboration information (info) messages generated when the static model of elaboration is used and the @code{-gnatel} switch is set. @item -@emph{[restriction warning]} +`[restriction warning]' Used to tag warning messages for restriction violations, activated by use of the pragma @code{Restriction_Warnings}. @item -@emph{[warning-as-error]} +`[warning-as-error]' Used to tag warning messages that have been converted to error messages by use of the pragma Warning_As_Error. Note that such warnings are prefixed by -the string “error: ” rather than “warning: “. +the string “error: “ rather than “warning: “. @item -@emph{[enabled by default]} +`[enabled by default]' Used to tag all other warnings that are always given by default, unless -warnings are completely suppressed using pragma @emph{Warnings(Off)} or +warnings are completely suppressed using pragma `Warnings(Off)' or the switch @code{-gnatws}. @end itemize @end quotation @@ -11105,7 +11103,7 @@ the switch @code{-gnatws}. @item @code{-gnatw.D} -@emph{Deactivate tagging of warning and info messages messages.} +`Deactivate tagging of warning and info messages messages.' If this switch is set, then warning messages return to the default mode in which warnings and info messages are not tagged as described above for @@ -11122,7 +11120,7 @@ mode in which warnings and info messages are not tagged as described above for @item @code{-gnatwe} -@emph{Treat warnings and style checks as errors.} +`Treat warnings and style checks as errors.' This switch causes warning messages and style check messages to be treated as errors. @@ -11140,7 +11138,7 @@ are not treated as errors if this switch is present. @item @code{-gnatw.e} -@emph{Activate every optional warning.} +`Activate every optional warning.' @geindex Warnings @geindex activate every optional warning @@ -11164,7 +11162,7 @@ been specifically designed according to specialized coding rules. @item @code{-gnatwE} -@emph{Treat all run-time exception warnings as errors.} +`Treat all run-time exception warnings as errors.' This switch causes warning messages regarding errors that will be raised during run-time execution to be treated as errors. @@ -11177,7 +11175,7 @@ during run-time execution to be treated as errors. @item @code{-gnatwf} -@emph{Activate warnings on unreferenced formals.} +`Activate warnings on unreferenced formals.' @geindex Formals @geindex unreferenced @@ -11195,7 +11193,7 @@ default is that these warnings are not generated. @item @code{-gnatwF} -@emph{Suppress warnings on unreferenced formals.} +`Suppress warnings on unreferenced formals.' This switch suppresses warnings for unreferenced formal parameters. Note that the @@ -11211,7 +11209,7 @@ formals. @item @code{-gnatwg} -@emph{Activate warnings on unrecognized pragmas.} +`Activate warnings on unrecognized pragmas.' @geindex Pragmas @geindex unrecognized @@ -11230,7 +11228,7 @@ Manual requirement that such warnings appear). @item @code{-gnatwG} -@emph{Suppress warnings on unrecognized pragmas.} +`Suppress warnings on unrecognized pragmas.' This switch suppresses warnings for unrecognized pragmas. @end table @@ -11242,7 +11240,7 @@ This switch suppresses warnings for unrecognized pragmas. @item @code{-gnatw.g} -@emph{Warnings used for GNAT sources.} +`Warnings used for GNAT sources.' This switch sets the warning categories that are used by the standard GNAT style. Currently this is equivalent to @@ -11257,7 +11255,7 @@ but more warnings may be added in the future without advanced notice. @item @code{-gnatwh} -@emph{Activate warnings on hiding.} +`Activate warnings on hiding.' @geindex Hiding of Declarations @@ -11274,7 +11272,7 @@ code. The default is that warnings on hiding are not generated. @item @code{-gnatwH} -@emph{Suppress warnings on hiding.} +`Suppress warnings on hiding.' This switch suppresses warnings on hiding declarations. @end table @@ -11286,7 +11284,7 @@ This switch suppresses warnings on hiding declarations. @item @code{-gnatw.h} -@emph{Activate warnings on holes/gaps in records.} +`Activate warnings on holes/gaps in records.' @geindex Record Representation (gaps) @@ -11303,7 +11301,7 @@ should specify a contiguous layout, adding unused fill fields if needed. @item @code{-gnatw.H} -@emph{Suppress warnings on holes/gaps in records.} +`Suppress warnings on holes/gaps in records.' This switch suppresses warnings on component clauses in record representation clauses that leave holes (haps) in the record layout. @@ -11316,16 +11314,16 @@ representation clauses that leave holes (haps) in the record layout. @item @code{-gnatwi} -@emph{Activate warnings on implementation units.} +`Activate warnings on implementation units.' -This switch activates warnings for a @emph{with} of an internal GNAT +This switch activates warnings for a `with' of an internal GNAT implementation unit, defined as any unit from the @code{Ada}, @code{Interfaces}, @code{GNAT}, or @code{System} hierarchies that is not documented in either the Ada Reference Manual or the GNAT Programmer’s Reference Manual. Such units are intended only -for internal implementation purposes and should not be @emph{with}ed +for internal implementation purposes and should not be `with'ed by user programs. The default is that such warnings are generated @end table @@ -11336,9 +11334,9 @@ by user programs. The default is that such warnings are generated @item @code{-gnatwI} -@emph{Disable warnings on implementation units.} +`Disable warnings on implementation units.' -This switch disables warnings for a @emph{with} of an internal GNAT +This switch disables warnings for a `with' of an internal GNAT implementation unit. @end table @@ -11349,7 +11347,7 @@ implementation unit. @item @code{-gnatw.i} -@emph{Activate warnings on overlapping actuals.} +`Activate warnings on overlapping actuals.' This switch enables a warning on statically detectable overlapping actuals in a subprogram call, when one of the actuals is an in-out parameter, and the @@ -11363,7 +11361,7 @@ types of the actuals are not by-copy types. This warning is off by default. @item @code{-gnatw.I} -@emph{Disable warnings on overlapping actuals.} +`Disable warnings on overlapping actuals.' This switch disables warnings on overlapping actuals in a call. @end table @@ -11375,7 +11373,7 @@ This switch disables warnings on overlapping actuals in a call. @item @code{-gnatwj} -@emph{Activate warnings on obsolescent features (Annex J).} +`Activate warnings on obsolescent features (Annex J).' @geindex Features @geindex obsolescent @@ -11411,7 +11409,7 @@ Second, the restriction does flag uses of package @code{ASCII}. @item @code{-gnatwJ} -@emph{Suppress warnings on obsolescent features (Annex J).} +`Suppress warnings on obsolescent features (Annex J).' This switch disables warnings on use of obsolescent features. @end table @@ -11423,7 +11421,7 @@ This switch disables warnings on use of obsolescent features. @item @code{-gnatw.j} -@emph{Activate warnings on late declarations of tagged type primitives.} +`Activate warnings on late declarations of tagged type primitives.' This switch activates warnings on visible primitives added to a tagged type after deriving a private extension from it. @@ -11436,7 +11434,7 @@ tagged type after deriving a private extension from it. @item @code{-gnatw.J} -@emph{Suppress warnings on late declarations of tagged type primitives.} +`Suppress warnings on late declarations of tagged type primitives.' This switch suppresses warnings on visible primitives added to a tagged type after deriving a private extension from it. @@ -11449,7 +11447,7 @@ tagged type after deriving a private extension from it. @item @code{-gnatwk} -@emph{Activate warnings on variables that could be constants.} +`Activate warnings on variables that could be constants.' This switch activates warnings for variables that are initialized but never modified, and then could be declared constants. The default is that @@ -11463,7 +11461,7 @@ such warnings are not given. @item @code{-gnatwK} -@emph{Suppress warnings on variables that could be constants.} +`Suppress warnings on variables that could be constants.' This switch disables warnings on variables that could be declared constants. @end table @@ -11475,7 +11473,7 @@ This switch disables warnings on variables that could be declared constants. @item @code{-gnatw.k} -@emph{Activate warnings on redefinition of names in standard.} +`Activate warnings on redefinition of names in standard.' This switch activates warnings for declarations that declare a name that is defined in package Standard. Such declarations can be confusing, @@ -11492,7 +11490,7 @@ not included in this check. @item @code{-gnatw.K} -@emph{Suppress warnings on redefinition of names in standard.} +`Suppress warnings on redefinition of names in standard.' This switch disables warnings for declarations that declare a name that is defined in package Standard. @@ -11505,7 +11503,7 @@ is defined in package Standard. @item @code{-gnatwl} -@emph{Activate warnings for elaboration pragmas.} +`Activate warnings for elaboration pragmas.' @geindex Elaboration @geindex warnings @@ -11527,7 +11525,7 @@ are not generated. @item @code{-gnatwL} -@emph{Suppress warnings for elaboration pragmas.} +`Suppress warnings for elaboration pragmas.' This switch suppresses warnings for possible elaboration problems. @end table @@ -11539,7 +11537,7 @@ This switch suppresses warnings for possible elaboration problems. @item @code{-gnatw.l} -@emph{List inherited aspects.} +`List inherited aspects.' This switch causes the compiler to list inherited invariants, preconditions, and postconditions from Type_Invariant’Class, Invariant’Class, @@ -11553,7 +11551,7 @@ Pre’Class, and Post’Class aspects. Also list inherited subtype predicates. @item @code{-gnatw.L} -@emph{Suppress listing of inherited aspects.} +`Suppress listing of inherited aspects.' This switch suppresses listing of inherited aspects. @end table @@ -11565,7 +11563,7 @@ This switch suppresses listing of inherited aspects. @item @code{-gnatwm} -@emph{Activate warnings on modified but unreferenced variables.} +`Activate warnings on modified but unreferenced variables.' This switch activates warnings for variables that are assigned (using an initialization value or with one or more assignment statements) but @@ -11582,7 +11580,7 @@ The default is that these warnings are not given. @item @code{-gnatwM} -@emph{Disable warnings on modified but unreferenced variables.} +`Disable warnings on modified but unreferenced variables.' This switch disables warnings for variables that are assigned or initialized, but never read. @@ -11595,7 +11593,7 @@ initialized, but never read. @item @code{-gnatw.m} -@emph{Activate warnings on suspicious modulus values.} +`Activate warnings on suspicious modulus values.' This switch activates warnings for modulus values that seem suspicious. The cases caught are where the size is the same as the modulus (e.g. @@ -11615,7 +11613,7 @@ integers after wrap-around. The default is that these warnings are given. @item @code{-gnatw.M} -@emph{Disable warnings on suspicious modulus values.} +`Disable warnings on suspicious modulus values.' This switch disables warnings for suspicious modulus values. @end table @@ -11627,7 +11625,7 @@ This switch disables warnings for suspicious modulus values. @item @code{-gnatwn} -@emph{Set normal warnings mode.} +`Set normal warnings mode.' This switch sets normal warning mode, in which enabled warnings are issued and treated as warnings rather than errors. This is the default @@ -11648,7 +11646,7 @@ use of @code{-gnatg}. @item @code{-gnatw.n} -@emph{Activate warnings on atomic synchronization.} +`Activate warnings on atomic synchronization.' This switch actives warnings when an access to an atomic variable requires the generation of atomic synchronization code. These @@ -11662,7 +11660,7 @@ warnings are off by default. @item @code{-gnatw.N} -@emph{Suppress warnings on atomic synchronization.} +`Suppress warnings on atomic synchronization.' @geindex Atomic Synchronization @geindex warnings @@ -11681,7 +11679,7 @@ requires the generation of atomic synchronization code. @item @code{-gnatwo} -@emph{Activate warnings on address clause overlays.} +`Activate warnings on address clause overlays.' This switch activates warnings for possibly unintended initialization effects of defining address clauses that cause one variable to overlap @@ -11695,7 +11693,7 @@ another. The default is that such warnings are generated. @item @code{-gnatwO} -@emph{Suppress warnings on address clause overlays.} +`Suppress warnings on address clause overlays.' This switch suppresses warnings on possibly unintended initialization effects of defining address clauses that cause one variable to overlap @@ -11709,7 +11707,7 @@ another. @item @code{-gnatw.o} -@emph{Activate warnings on modified but unreferenced out parameters.} +`Activate warnings on modified but unreferenced out parameters.' This switch activates warnings for variables that are modified by using them as actuals for a call to a procedure with an out mode formal, where @@ -11729,7 +11727,7 @@ The default is that these warnings are not given. @item @code{-gnatw.O} -@emph{Disable warnings on modified but unreferenced out parameters.} +`Disable warnings on modified but unreferenced out parameters.' This switch suppresses warnings for variables that are modified by using them as actuals for a call to a procedure with an out mode formal, where @@ -11746,7 +11744,7 @@ the resulting assigned value is never read. @item @code{-gnatwp} -@emph{Activate warnings on ineffective pragma Inlines.} +`Activate warnings on ineffective pragma Inlines.' This switch activates warnings for failure of front end inlining (activated by @code{-gnatN}) to inline a particular call. There are @@ -11764,7 +11762,7 @@ separately, using the gcc switch -Winline. @item @code{-gnatwP} -@emph{Suppress warnings on ineffective pragma Inlines.} +`Suppress warnings on ineffective pragma Inlines.' This switch suppresses warnings on ineffective pragma Inlines. If the inlining mechanism cannot inline a call, it will simply ignore the @@ -11781,7 +11779,7 @@ request silently. @item @code{-gnatw.p} -@emph{Activate warnings on parameter ordering.} +`Activate warnings on parameter ordering.' This switch activates warnings for cases of suspicious parameter ordering when the list of arguments are all simple identifiers that @@ -11799,7 +11797,7 @@ default is that such warnings are not given. @item @code{-gnatw.P} -@emph{Suppress warnings on parameter ordering.} +`Suppress warnings on parameter ordering.' This switch suppresses warnings on cases of suspicious parameter ordering. @@ -11812,7 +11810,7 @@ ordering. @item @code{-gnatw_p} -@emph{Activate warnings for pedantic checks.} +`Activate warnings for pedantic checks.' This switch activates warnings for the failure of certain pedantic checks. The only case currently supported is a check that the subtype_marks given @@ -11828,7 +11826,7 @@ is that such warnings are not given. @item @code{-gnatw_P} -@emph{Suppress warnings for pedantic checks.} +`Suppress warnings for pedantic checks.' This switch suppresses warnings on violations of pedantic checks. @end table @@ -11843,7 +11841,7 @@ This switch suppresses warnings on violations of pedantic checks. @item @code{-gnatwq} -@emph{Activate warnings on questionable missing parentheses.} +`Activate warnings on questionable missing parentheses.' This switch activates warnings for cases where parentheses are not used and the result is potential ambiguity from a readers point of view. For example @@ -11862,7 +11860,7 @@ is that these warnings are given. @item @code{-gnatwQ} -@emph{Suppress warnings on questionable missing parentheses.} +`Suppress warnings on questionable missing parentheses.' This switch suppresses warnings for cases where the association is not clear and the use of parentheses is preferred. @@ -11878,7 +11876,7 @@ clear and the use of parentheses is preferred. @item @code{-gnatw.q} -@emph{Activate warnings on questionable layout of record types.} +`Activate warnings on questionable layout of record types.' This switch activates warnings for cases where the default layout of a record type, that is to say the layout of its components in textual @@ -11932,7 +11930,7 @@ The default is that these warnings are not given. @item @code{-gnatw.Q} -@emph{Suppress warnings on questionable layout of record types.} +`Suppress warnings on questionable layout of record types.' This switch suppresses warnings for cases where the default layout of a record type would very likely cause inefficiencies. @@ -11945,7 +11943,7 @@ a record type would very likely cause inefficiencies. @item @code{-gnatwr} -@emph{Activate warnings on redundant constructs.} +`Activate warnings on redundant constructs.' This switch activates warnings for redundant constructs. The following is the current list of constructs regarded as redundant: @@ -11993,7 +11991,7 @@ The default is that warnings for redundant constructs are not given. @item @code{-gnatwR} -@emph{Suppress warnings on redundant constructs.} +`Suppress warnings on redundant constructs.' This switch suppresses warnings for redundant constructs. @end table @@ -12005,7 +12003,7 @@ This switch suppresses warnings for redundant constructs. @item @code{-gnatw.r} -@emph{Activate warnings for object renaming function.} +`Activate warnings for object renaming function.' This switch activates warnings for an object renaming that renames a function call, which is equivalent to a constant declaration (as @@ -12020,7 +12018,7 @@ warnings are given. @item @code{-gnatw.R} -@emph{Suppress warnings for object renaming function.} +`Suppress warnings for object renaming function.' This switch suppresses warnings for object renaming function. @end table @@ -12032,7 +12030,7 @@ This switch suppresses warnings for object renaming function. @item @code{-gnatw_r} -@emph{Activate warnings for out-of-order record representation clauses.} +`Activate warnings for out-of-order record representation clauses.' This switch activates warnings for record representation clauses, if the order of component declarations, component clauses, @@ -12047,7 +12045,7 @@ The default is that these warnings are not given. @item @code{-gnatw_R} -@emph{Suppress warnings for out-of-order record representation clauses.} +`Suppress warnings for out-of-order record representation clauses.' @end table @geindex -gnatws (gcc) @@ -12057,7 +12055,7 @@ The default is that these warnings are not given. @item @code{-gnatws} -@emph{Suppress all warnings.} +`Suppress all warnings.' This switch completely suppresses the output of all warning messages from the GNAT front end, including @@ -12082,7 +12080,7 @@ handling of style check messages. @item @code{-gnatw.s} -@emph{Activate warnings on overridden size clauses.} +`Activate warnings on overridden size clauses.' This switch activates warnings on component clauses in record representation clauses where the length given overrides that @@ -12099,7 +12097,7 @@ component type. @item @code{-gnatw.S} -@emph{Suppress warnings on overridden size clauses.} +`Suppress warnings on overridden size clauses.' This switch suppresses warnings on component clauses in record representation clauses that override size clauses, and similar @@ -12119,7 +12117,7 @@ warnings when an array component size overrides a size clause. @item @code{-gnatwt} -@emph{Activate warnings for tracking of deleted conditional code.} +`Activate warnings for tracking of deleted conditional code.' This switch activates warnings for tracking of code in conditionals (IF and CASE statements) that is detected to be dead code which cannot be executed, and @@ -12134,7 +12132,7 @@ useful for detecting deactivated code in certified applications. @item @code{-gnatwT} -@emph{Suppress warnings for tracking of deleted conditional code.} +`Suppress warnings for tracking of deleted conditional code.' This switch suppresses warnings for tracking of deleted conditional code. @end table @@ -12146,7 +12144,7 @@ This switch suppresses warnings for tracking of deleted conditional code. @item @code{-gnatw.t} -@emph{Activate warnings on suspicious contracts.} +`Activate warnings on suspicious contracts.' This switch activates warnings on suspicious contracts. This includes warnings on suspicious postconditions (whether a pragma @code{Postcondition} or a @@ -12168,7 +12166,7 @@ warnings are generated. @item @code{-gnatw.T} -@emph{Suppress warnings on suspicious contracts.} +`Suppress warnings on suspicious contracts.' This switch suppresses warnings on suspicious contracts. @end table @@ -12180,22 +12178,22 @@ This switch suppresses warnings on suspicious contracts. @item @code{-gnatwu} -@emph{Activate warnings on unused entities.} +`Activate warnings on unused entities.' This switch activates warnings to be generated for entities that -are declared but not referenced, and for units that are @emph{with}ed +are declared but not referenced, and for units that are `with'ed and not referenced. In the case of packages, a warning is also generated if no entities in the package are referenced. This means that if a with’ed package is referenced but the only references are in @code{use} clauses or @code{renames} declarations, a warning is still generated. A warning is also generated -for a generic package that is @emph{with}ed but never instantiated. +for a generic package that is `with'ed but never instantiated. In the case where a package or subprogram body is compiled, and there -is a @emph{with} on the corresponding spec +is a `with' on the corresponding spec that is only referenced in the body, a warning is also generated, noting that the -@emph{with} can be moved to the body. The default is that +`with' can be moved to the body. The default is that such warnings are not generated. This switch also activates warnings on unreferenced formals (it includes the effect of @code{-gnatwf}). @@ -12208,7 +12206,7 @@ This switch also activates warnings on unreferenced formals @item @code{-gnatwU} -@emph{Suppress warnings on unused entities.} +`Suppress warnings on unused entities.' This switch suppresses warnings for unused entities and packages. It also turns off warnings on unreferenced formals (and thus includes @@ -12222,13 +12220,13 @@ the effect of @code{-gnatwF}). @item @code{-gnatw.u} -@emph{Activate warnings on unordered enumeration types.} +`Activate warnings on unordered enumeration types.' This switch causes enumeration types to be considered as conceptually unordered, unless an explicit pragma @code{Ordered} is given for the type. The effect is to generate warnings in clients that use explicit comparisons or subranges, since these constructs both treat objects of the type as -ordered. (A @emph{client} is defined as a unit that is other than the unit in +ordered. (A `client' is defined as a unit that is other than the unit in which the type is declared, or its body or subunits.) Please refer to the description of pragma @code{Ordered} in the @cite{GNAT Reference Manual} for further details. @@ -12242,7 +12240,7 @@ The default is that such warnings are not generated. @item @code{-gnatw.U} -@emph{Deactivate warnings on unordered enumeration types.} +`Deactivate warnings on unordered enumeration types.' This switch causes all enumeration types to be considered as ordered, so that no warnings are given for comparisons or subranges for any type. @@ -12257,7 +12255,7 @@ that no warnings are given for comparisons or subranges for any type. @item @code{-gnatwv} -@emph{Activate warnings on unassigned variables.} +`Activate warnings on unassigned variables.' This switch activates warnings for access to variables which may not be properly initialized. The default is that @@ -12278,7 +12276,7 @@ unless the relevant type fully initializes all components. @item @code{-gnatwV} -@emph{Suppress warnings on unassigned variables.} +`Suppress warnings on unassigned variables.' This switch suppresses warnings for access to variables which may not be properly initialized. @@ -12293,7 +12291,7 @@ may not be properly initialized. @item @code{-gnatw.v} -@emph{Activate info messages for non-default bit order.} +`Activate info messages for non-default bit order.' This switch activates messages (labeled “info”, they are not warnings, just informational messages) about the effects of non-default bit-order @@ -12310,7 +12308,7 @@ exact consequences of using this feature. @item @code{-gnatw.V} -@emph{Suppress info messages for non-default bit order.} +`Suppress info messages for non-default bit order.' This switch suppresses information messages for the effects of specifying non-default bit order on record components with component clauses. @@ -12325,7 +12323,7 @@ non-default bit order on record components with component clauses. @item @code{-gnatww} -@emph{Activate warnings on wrong low bound assumption.} +`Activate warnings on wrong low bound assumption.' This switch activates warnings for indexing an unconstrained string parameter with a literal or S’Length. This is a case where the code is assuming that the @@ -12340,7 +12338,7 @@ passed). The default is that such warnings are generated. @item @code{-gnatwW} -@emph{Suppress warnings on wrong low bound assumption.} +`Suppress warnings on wrong low bound assumption.' This switch suppresses warnings for indexing an unconstrained string parameter with a literal or S’Length. Note that this warning can also be suppressed @@ -12363,7 +12361,7 @@ procedure K (S : String) is @item @code{-gnatw.w} -@emph{Activate warnings on Warnings Off pragmas.} +`Activate warnings on Warnings Off pragmas.' This switch activates warnings for use of @code{pragma Warnings (Off, entity)} where either the pragma is entirely useless (because it suppresses no @@ -12382,7 +12380,7 @@ The default is that these warnings are not given. @item @code{-gnatw.W} -@emph{Suppress warnings on unnecessary Warnings Off pragmas.} +`Suppress warnings on unnecessary Warnings Off pragmas.' This switch suppresses warnings for use of @code{pragma Warnings (Off, ...)}. @end table @@ -12396,7 +12394,7 @@ This switch suppresses warnings for use of @code{pragma Warnings (Off, ...)}. @item @code{-gnatwx} -@emph{Activate warnings on Export/Import pragmas.} +`Activate warnings on Export/Import pragmas.' This switch activates warnings on Export/Import pragmas when the compiler detects a possible conflict between the Ada and @@ -12414,7 +12412,7 @@ generated. @item @code{-gnatwX} -@emph{Suppress warnings on Export/Import pragmas.} +`Suppress warnings on Export/Import pragmas.' This switch suppresses warnings on Export/Import pragmas. The sense of this is that you are telling the compiler that @@ -12429,7 +12427,7 @@ should not complain at you. @item @code{-gnatw.x} -@emph{Activate warnings for No_Exception_Propagation mode.} +`Activate warnings for No_Exception_Propagation mode.' This switch activates warnings for exception usage when pragma Restrictions (No_Exception_Propagation) is in effect. Warnings are given for implicit or @@ -12439,7 +12437,7 @@ these warnings are given for units that contain exception handlers. @item @code{-gnatw.X} -@emph{Disable warnings for No_Exception_Propagation mode.} +`Disable warnings for No_Exception_Propagation mode.' This switch disables warnings for exception usage when pragma Restrictions (No_Exception_Propagation) is in effect. @@ -12454,7 +12452,7 @@ This switch disables warnings for exception usage when pragma Restrictions @item @code{-gnatwy} -@emph{Activate warnings for Ada compatibility issues.} +`Activate warnings for Ada compatibility issues.' For the most part, newer versions of Ada are upwards compatible with older versions. For example, Ada 2005 programs will almost @@ -12476,7 +12474,7 @@ was called Ada 0Y, hence the choice of character. @item @code{-gnatwY} -@emph{Disable warnings for Ada compatibility issues.} +`Disable warnings for Ada compatibility issues.' This switch suppresses the warnings intended to help in identifying incompatibilities between Ada language versions. @@ -12491,7 +12489,7 @@ incompatibilities between Ada language versions. @item @code{-gnatw.y} -@emph{Activate information messages for why package spec needs body.} +`Activate information messages for why package spec needs body.' There are a number of cases in which a package spec needs a body. For example, the use of pragma Elaborate_Body, or the declaration @@ -12511,7 +12509,7 @@ body. The default is that such information messages are not output. @item @code{-gnatw.Y} -@emph{Disable information messages for why package spec needs body.} +`Disable information messages for why package spec needs body.' This switch suppresses the output of information messages showing why a package specification needs a body. @@ -12526,7 +12524,7 @@ a package specification needs a body. @item @code{-gnatwz} -@emph{Activate warnings on unchecked conversions.} +`Activate warnings on unchecked conversions.' This switch activates warnings for unchecked conversions where the types are known at compile time to have different @@ -12541,7 +12539,7 @@ generated for subprogram pointers with different conventions. @item @code{-gnatwZ} -@emph{Suppress warnings on unchecked conversions.} +`Suppress warnings on unchecked conversions.' This switch suppresses warnings for unchecked conversions where the types are known at compile time to have different @@ -12557,7 +12555,7 @@ sizes or conventions. @item @code{-gnatw.z} -@emph{Activate warnings for size not a multiple of alignment.} +`Activate warnings for size not a multiple of alignment.' This switch activates warnings for cases of array and record types with specified @code{Size} and @code{Alignment} attributes where the @@ -12575,7 +12573,7 @@ is that such warnings are generated. @item @code{-gnatw.Z} -@emph{Suppress warnings for size not a multiple of alignment.} +`Suppress warnings for size not a multiple of alignment.' This switch suppresses warnings for cases of array and record types with specified @code{Size} and @code{Alignment} attributes where the @@ -12615,7 +12613,7 @@ used in conjunction with an optimization level greater than zero. @table @asis -@item @code{-Wstack-usage=@emph{len}} +@item @code{-Wstack-usage=`len'} Warn if the stack usage of a subprogram might be larger than @code{len} bytes. See @ref{e6,,Static Stack Usage Analysis} for details. @@ -12956,7 +12954,7 @@ combination with optimization, since this can confuse the optimizer. If performance is a consideration, leading to the need to optimize, then the validity checking options should not be used. -The other @code{-gnatV@emph{x}} switches below allow finer-grained +The other @code{-gnatV`x'} switches below allow finer-grained control; you can enable whichever validity checks you desire. However, for most debugging purposes, @code{-gnatVa} is sufficient, and the default @code{-gnatVd} (i.e. standard Ada behavior) is usually @@ -12969,7 +12967,7 @@ the compiler can generate more efficient code, since the range of values is better known at compile time. However, an uninitialized variable can cause wild jumps and memory corruption in this mode. -The @code{-gnatV@emph{x}} switch allows control over the validity +The @code{-gnatV`x'} switch allows control over the validity checking mode as described below. The @code{x} argument is a string of letters that indicate validity checks that are performed or not performed in addition @@ -12982,11 +12980,11 @@ to the default checks required by Ada as described above. @item @code{-gnatVa} -@emph{All validity checks.} +`All validity checks.' 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,10 +12994,10 @@ equivalent to @code{gnatVcdfimoprst}. @item @code{-gnatVc} -@emph{Validity checks for copies.} +`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,14 +13007,16 @@ object declarations are validity checked. @item @code{-gnatVd} -@emph{Default (RM) validity checks.} +`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. @@ -13033,16 +13033,13 @@ overwriting may occur. @item @code{-gnatVe} -@emph{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,13 +13049,20 @@ are assigned component by component. @item @code{-gnatVf} -@emph{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 +`Validity checks for floating-point values.' + +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 @@ -13072,7 +13076,7 @@ options. For example, @code{-gnatVif} or @code{-gnatVfi} @item @code{-gnatVi} -@emph{Validity checks for `@w{`}in`@w{`} mode parameters.} +`Validity checks for `@w{`}in`@w{`} mode parameters.' Arguments for parameters of mode @code{in} are validity checked in function and procedure calls at the point of call. @@ -13085,7 +13089,7 @@ and procedure calls at the point of call. @item @code{-gnatVm} -@emph{Validity checks for `@w{`}in out`@w{`} mode parameters.} +`Validity checks for `@w{`}in out`@w{`} mode parameters.' Arguments for parameters of mode @code{in out} are validity checked in procedure calls at the point of call. The @code{'m'} here stands for @@ -13103,7 +13107,7 @@ will be subject to validity checking. @item @code{-gnatVn} -@emph{No validity checks.} +`No validity checks.' This switch turns off all validity checking, including the default checking for case statements and left hand side subscripts. Note that the use of @@ -13119,9 +13123,10 @@ is used, it cancels any other @code{-gnatV} previously issued. @item @code{-gnatVo} -@emph{Validity checks for operator and attribute operands.} +`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,16 +13142,17 @@ also made on explicit ranges using @code{..} (e.g., slices, loops etc). @item @code{-gnatVp} -@emph{Validity checks for parameters.} +`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,9 +13162,9 @@ will be checked (or rechecked) within the subprogram. @item @code{-gnatVr} -@emph{Validity checks for function returns.} +`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,11 +13175,12 @@ checked. @item @code{-gnatVs} -@emph{Validity checks for subscripts.} +`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) @@ -13183,7 +13190,7 @@ are validity checked). @item @code{-gnatVt} -@emph{Validity checks for tests.} +`Validity checks for tests.' Expressions used as conditions in @code{if}, @code{while} or @code{exit} statements are checked, as well as guard expressions in entry calls. @@ -13248,7 +13255,7 @@ checks to be performed. The following checks are defined: @item @code{-gnaty0} -@emph{Specify indentation level.} +`Specify indentation level.' If a digit from 1-9 appears in the string after @code{-gnaty} @@ -13287,7 +13294,7 @@ non-blank line. @item @code{-gnatya} -@emph{Check attribute casing.} +`Check attribute casing.' Attribute names, including the case of keywords such as @code{digits} used as attributes names, must be written in mixed case, that is, the @@ -13302,7 +13309,7 @@ All other letters must be lowercase. @item @code{-gnatyA} -@emph{Use of array index numbers in array attributes.} +`Use of array index numbers in array attributes.' When using the array attributes First, Last, Range, or Length, the index number must be omitted for one-dimensional arrays @@ -13316,7 +13323,7 @@ and is required for multi-dimensional arrays. @item @code{-gnatyb} -@emph{Blanks not allowed at statement end.} +`Blanks not allowed at statement end.' Trailing blanks are not allowed at the end of statements. The purpose of this rule, together with h (no horizontal tabs), is to enforce a canonical format @@ -13330,7 +13337,7 @@ for the use of blanks to separate source tokens. @item @code{-gnatyB} -@emph{Check Boolean operators.} +`Check Boolean operators.' The use of AND/OR operators is not permitted except in the cases of modular operands, array operands, and simple stand-alone boolean variables or @@ -13345,7 +13352,7 @@ required. @item @code{-gnatyc} -@emph{Check comments, double space.} +`Check comments, double space.' Comments must meet the following set of rules: @@ -13407,7 +13414,7 @@ example: @item @code{-gnatyC} -@emph{Check comments, single space.} +`Check comments, single space.' This is identical to @code{c} except that only one space is required following the @code{--} of a comment instead of two. @@ -13420,7 +13427,7 @@ is required following the @code{--} of a comment instead of two. @item @code{-gnatyd} -@emph{Check no DOS line terminators present.} +`Check no DOS line terminators present.' All lines must be terminated by a single ASCII.LF character (in particular the DOS line terminator sequence CR/LF is not @@ -13434,7 +13441,7 @@ allowed). @item @code{-gnatyD} -@emph{Check declared identifiers in mixed case.} +`Check declared identifiers in mixed case.' Declared identifiers must be in mixed case, as in This_Is_An_Identifier. Use -gnatyr in addition to ensure @@ -13448,7 +13455,7 @@ that references match declarations. @item @code{-gnatye} -@emph{Check end/exit labels.} +`Check end/exit labels.' Optional labels on @code{end} statements ending subprograms and on @code{exit} statements exiting named loops, are required to be present. @@ -13461,7 +13468,7 @@ Optional labels on @code{end} statements ending subprograms and on @item @code{-gnatyf} -@emph{No form feeds or vertical tabs.} +`No form feeds or vertical tabs.' Neither form feeds nor vertical tab characters are permitted in the source text. @@ -13474,7 +13481,7 @@ in the source text. @item @code{-gnatyg} -@emph{GNAT style mode.} +`GNAT style mode.' The set of style check switches is set to match that used by the GNAT sources. This may be useful when developing code that is eventually intended to be @@ -13490,7 +13497,7 @@ advance notice. @item @code{-gnatyh} -@emph{No horizontal tabs.} +`No horizontal tabs.' Horizontal tab characters are not permitted in the source text. Together with the b (no blanks at end of line) check, this @@ -13505,7 +13512,7 @@ source tokens. @item @code{-gnatyi} -@emph{Check if-then layout.} +`Check if-then layout.' The keyword @code{then} must appear either on the same line as corresponding @code{if}, or on a line on its own, lined @@ -13519,7 +13526,7 @@ up under the @code{if}. @item @code{-gnatyI} -@emph{check mode IN keywords.} +`check mode IN keywords.' Mode @code{in} (the default mode) is not allowed to be given explicitly. @code{in out} is fine, @@ -13533,7 +13540,7 @@ but not @code{in} on its own. @item @code{-gnatyk} -@emph{Check keyword casing.} +`Check keyword casing.' All keywords must be in lower case (with the exception of keywords such as @code{digits} used as attribute names to which this check @@ -13548,7 +13555,7 @@ this rule even if multiple casing issues exist on a same line. @item @code{-gnatyl} -@emph{Check layout.} +`Check layout.' Layout of statement and declaration constructs must follow the recommendations in the Ada Reference Manual, as indicated by the @@ -13624,11 +13631,11 @@ Clear : @item @code{-gnatyL} -@emph{Set maximum nesting level.} +`Set maximum nesting level.' The maximum level of nesting of constructs (including subprograms, loops, blocks, packages, and conditionals) may not exceed the given value -@emph{nnn}. A value of zero disconnects this style check. +`nnn'. A value of zero disconnects this style check. @end table @geindex -gnatym (gcc) @@ -13638,7 +13645,7 @@ blocks, packages, and conditionals) may not exceed the given value @item @code{-gnatym} -@emph{Check maximum line length.} +`Check maximum line length.' The length of source lines must not exceed 79 characters, including any trailing blanks. The value of 79 allows convenient display on an @@ -13656,10 +13663,10 @@ a single character (however many bytes are needed in the encoding). @item @code{-gnatyM} -@emph{Set maximum line length.} +`Set maximum line length.' The length of lines must not exceed the -given value @emph{nnn}. The maximum value that can be specified is 32767. +given value `nnn'. The maximum value that can be specified is 32767. If neither style option for setting the line length is used, then the default is 255. This also controls the maximum length of lexical elements, where the only restriction is that they must fit on a single line. @@ -13672,7 +13679,7 @@ where the only restriction is that they must fit on a single line. @item @code{-gnatyn} -@emph{Check casing of entities in Standard.} +`Check casing of entities in Standard.' Any identifier from Standard must be cased to match the presentation in the Ada Reference Manual (for example, @@ -13686,7 +13693,7 @@ to match the presentation in the Ada Reference Manual (for example, @item @code{-gnatyN} -@emph{Turn off all style checks.} +`Turn off all style checks.' All style check options are turned off. @end table @@ -13698,7 +13705,7 @@ All style check options are turned off. @item @code{-gnatyo} -@emph{Check order of subprogram bodies.} +`Check order of subprogram bodies.' All subprogram bodies in a given scope (e.g., a package body) must be in alphabetical order. The ordering @@ -13715,7 +13722,7 @@ before Junk10). @item @code{-gnatyO} -@emph{Check that overriding subprograms are explicitly marked as such.} +`Check that overriding subprograms are explicitly marked as such.' This applies to all subprograms of a derived type that override a primitive operation of the type, for both tagged and untagged types. In particular, @@ -13732,7 +13739,7 @@ as an equality operator). @item @code{-gnatyp} -@emph{Check pragma casing.} +`Check pragma casing.' Pragma names must be written in mixed case, that is, the initial letter and any letter following an underscore must be uppercase. @@ -13747,7 +13754,7 @@ allowed as an alternative for Spark_Mode. @item @code{-gnatyr} -@emph{Check references.} +`Check references.' All identifier references must be cased in the same way as the corresponding declaration. No specific casing style is imposed on @@ -13762,7 +13769,7 @@ with declarations. @item @code{-gnatys} -@emph{Check separate specs.} +`Check separate specs.' Separate declarations (‘specs’) are required for subprograms (a body is not allowed to serve as its own declaration). The only @@ -13778,7 +13785,7 @@ the most frequent form of main program procedures. @item @code{-gnatyS} -@emph{Check no statements after then/else.} +`Check no statements after then/else.' No statements are allowed on the same line as a @code{then} or @code{else} keyword following the @@ -13793,7 +13800,7 @@ affected, and a special exception allows a pragma to appear after @code{else}. @item @code{-gnatyt} -@emph{Check token spacing.} +`Check token spacing.' The following token spacing rules are enforced: @@ -13858,7 +13865,7 @@ a @code{not} token and a following @code{in} token. @item @code{-gnatyu} -@emph{Check unnecessary blank lines.} +`Check unnecessary blank lines.' Unnecessary blank lines are not allowed. A blank line is considered unnecessary if it appears at the end of the file, or if more than @@ -13872,7 +13879,7 @@ one blank line occurs in sequence. @item @code{-gnatyx} -@emph{Check extra parentheses.} +`Check extra parentheses.' Unnecessary extra level of parentheses (C-style) are not allowed around conditions in @code{if} statements, @code{while} statements and @@ -13886,7 +13893,7 @@ around conditions in @code{if} statements, @code{while} statements and @item @code{-gnatyy} -@emph{Set all standard style check options.} +`Set all standard style check options.' This is equivalent to @code{gnaty3aAbcefhiklmnprst}, that is all checking options enabled with the exception of @code{-gnatyB}, @code{-gnatyd}, @@ -13901,15 +13908,15 @@ options enabled with the exception of @code{-gnatyB}, @code{-gnatyd}, @item @code{-gnaty-} -@emph{Remove style check options.} +`Remove style check options.' This causes any subsequent options in the string to act as canceling the corresponding style check option. To cancel maximum nesting level control, use the @code{L} parameter without any integer value after that, because any -digit following @emph{-} in the parameter string of the @code{-gnaty} +digit following `-' in the parameter string of the @code{-gnaty} option will be treated as canceling the indentation check. The same is true for the @code{M} parameter. @code{y} and @code{N} parameters are not -allowed after @emph{-}. +allowed after `-'. @end table @geindex -gnaty+ (gcc) @@ -13919,7 +13926,7 @@ allowed after @emph{-}. @item @code{-gnaty+} -@emph{Enable style check options.} +`Enable style check options.' This causes any subsequent options in the string to enable the corresponding style check option. That is, it cancels the effect of a previous -, @@ -14076,20 +14083,20 @@ controls the mode, using the codes @table @asis -@item @emph{1 = STRICT} +@item `1 = STRICT' In STRICT mode, intermediate operations are always done using the base type, and overflow checking ensures that the result is within the base type range. -@item @emph{2 = MINIMIZED} +@item `2 = MINIMIZED' In MINIMIZED mode, overflows in intermediate operations are avoided where possible by using a larger integer type for the computation (typically @code{Long_Long_Integer}). Overflow checking ensures that the result fits in this larger integer type. -@item @emph{3 = ELIMINATED} +@item `3 = ELIMINATED' In ELIMINATED mode, overflows in intermediate operations are avoided by using multi-precision arithmetic. In this case, overflow checking @@ -14216,7 +14223,7 @@ $ Otherwise, the output is simply the error messages, if any. No object file or ALI file is generated by a syntax-only compilation. Also, no units other than the one specified are accessed. For example, if a unit @code{X} -@emph{with}s a unit @code{Y}, compiling unit @code{X} in syntax +`with's a unit @code{Y}, compiling unit @code{X} in syntax check only mode does not access the source file containing unit @code{Y}. @@ -14325,7 +14332,7 @@ with optional bodies), it is not necessary to specify the exceptions, Ada 95 and Ada 2005 are upwardly compatible with Ada 83. Thus a correct Ada 83 program is usually also a correct program in these later versions of the language standard. For further information -please refer to the @emph{Compatibility and Porting Guide} chapter in the +please refer to the `Compatibility and Porting Guide' chapter in the @cite{GNAT Reference Manual}. @end table @@ -14434,7 +14441,7 @@ extensions, see the GNAT reference manual, @code{Pragma Extensions_Allowed}. @table @asis -@item @code{-gnati@emph{c}} +@item @code{-gnati`c'} Normally GNAT recognizes the Latin-1 character set in source program identifiers, as described in the Ada Reference Manual. @@ -14446,7 +14453,7 @@ single character indicating the character set, as follows: @multitable {xxxxxxxxxxxx} {xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx} @item -@emph{1} +`1' @tab @@ -14454,7 +14461,7 @@ ISO 8859-1 (Latin-1) identifiers @item -@emph{2} +`2' @tab @@ -14462,7 +14469,7 @@ ISO 8859-2 (Latin-2) letters allowed in identifiers @item -@emph{3} +`3' @tab @@ -14470,7 +14477,7 @@ ISO 8859-3 (Latin-3) letters allowed in identifiers @item -@emph{4} +`4' @tab @@ -14478,7 +14485,7 @@ ISO 8859-4 (Latin-4) letters allowed in identifiers @item -@emph{5} +`5' @tab @@ -14486,7 +14493,7 @@ ISO 8859-5 (Cyrillic) letters allowed in identifiers @item -@emph{9} +`9' @tab @@ -14494,7 +14501,7 @@ ISO 8859-15 (Latin-9) letters allowed in identifiers @item -@emph{p} +`p' @tab @@ -14502,7 +14509,7 @@ IBM PC letters (code page 437) allowed in identifiers @item -@emph{8} +`8' @tab @@ -14510,7 +14517,7 @@ IBM PC letters (code page 850) allowed in identifiers @item -@emph{f} +`f' @tab @@ -14518,7 +14525,7 @@ Full upper-half codes allowed in identifiers @item -@emph{n} +`n' @tab @@ -14526,7 +14533,7 @@ No upper-half codes allowed in identifiers @item -@emph{w} +`w' @tab @@ -14545,7 +14552,7 @@ implementation of these character sets. @table @asis -@item @code{-gnatW@emph{e}} +@item @code{-gnatW`e'} Specify the method of encoding for wide characters. @code{e} is one of the following: @@ -14554,7 +14561,7 @@ Specify the method of encoding for wide characters. @multitable {xxxxxxxxxxxx} {xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx} @item -@emph{h} +`h' @tab @@ -14562,7 +14569,7 @@ Hex encoding (brackets coding also recognized) @item -@emph{u} +`u' @tab @@ -14570,7 +14577,7 @@ Upper half encoding (brackets encoding also recognized) @item -@emph{s} +`s' @tab @@ -14578,7 +14585,7 @@ Shift/JIS encoding (brackets encoding also recognized) @item -@emph{e} +`e' @tab @@ -14586,7 +14593,7 @@ EUC encoding (brackets encoding also recognized) @item -@emph{8} +`8' @tab @@ -14594,7 +14601,7 @@ UTF-8 encoding (brackets encoding also recognized) @item -@emph{b} +`b' @tab @@ -14661,7 +14668,7 @@ This is a common mode for many programs with foreign language comments. @table @asis -@item @code{-gnatk@emph{n}} +@item @code{-gnatk`n'} Activates file name ‘krunching’. @code{n}, a decimal integer in the range 1-999, indicates the maximum allowable length of a file name (not @@ -14760,7 +14767,7 @@ react to a compilation failure. Those exit status are: @multitable {xxxxxxxxxxxx} {xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx} @item -@emph{5} +`5' @tab @@ -14768,7 +14775,7 @@ There was an error in at least one source file. @item -@emph{3} +`3' @tab @@ -14776,7 +14783,7 @@ At least one source file did not generate an object file. @item -@emph{2} +`2' @tab @@ -14784,7 +14791,7 @@ The compiler died unexpectedly (internal error for example). @item -@emph{0} +`0' @tab @@ -14809,7 +14816,7 @@ An object file has been generated for every source file. @table @asis -@item @code{-gnatd@emph{x}} +@item @code{-gnatd`x'} Activate internal debugging switches. @code{x} is a letter or digit, or string of letters or digits, which specifies the type of debugging @@ -14824,7 +14831,7 @@ file @code{debug.adb}. @table @asis -@item @code{-gnatG[=@emph{nn}]} +@item @code{-gnatG[=`nn']} This switch causes the compiler to generate auxiliary output containing a pseudo-source listing of the generated expanded code. Like most Ada @@ -14860,47 +14867,47 @@ in the expanded source (as comment lines with the original line number). @table @asis -@item @code{new @emph{xxx} [storage_pool = @emph{yyy}]} +@item @code{new @var{xxx} [storage_pool = @var{yyy}]} Shows the storage pool being used for an allocator. -@item @code{at end @emph{procedure-name};} +@item @code{at end @var{procedure-name};} Shows the finalization (cleanup) procedure for a scope. -@item @code{(if @emph{expr} then @emph{expr} else @emph{expr})} +@item @code{(if @var{expr} then @var{expr} else @var{expr})} Conditional expression equivalent to the @code{x?y:z} construction in C. -@item @code{@emph{target}^(@emph{source})} +@item @code{@var{target}^(@var{source})} A conversion with floating-point truncation instead of rounding. -@item @code{@emph{target}?(@emph{source})} +@item @code{@var{target}?(@var{source})} A conversion that bypasses normal Ada semantic checking. In particular enumeration types and fixed-point types are treated simply as integers. -@item @code{@emph{target}?^(@emph{source})} +@item @code{@var{target}?^(@var{source})} Combines the above two cases. @end table -@code{@emph{x} #/ @emph{y}} +@code{@var{x} #/ @var{y}} -@code{@emph{x} #mod @emph{y}} +@code{@var{x} #mod @var{y}} -@code{@emph{x} # @emph{y}} +@code{@var{x} # @var{y}} @table @asis -@item @code{@emph{x} #rem @emph{y}} +@item @code{@var{x} #rem @var{y}} A division or multiplication of fixed-point values which are treated as integers without any kind of scaling. -@item @code{free @emph{expr} [storage_pool = @emph{xxx}]} +@item @code{free @var{expr} [storage_pool = @var{xxx}]} Shows the storage pool associated with a @code{free} statement. @@ -14909,30 +14916,30 @@ Shows the storage pool associated with a @code{free} statement. Used to list an equivalent declaration for an internally generated type that is referenced elsewhere in the listing. -@item @code{freeze @emph{type-name} [@emph{actions}]} +@item @code{freeze @var{type-name} [@var{actions}]} Shows the point at which @code{type-name} is frozen, with possible associated actions to be performed at the freeze point. -@item @code{reference @emph{itype}} +@item @code{reference @var{itype}} Reference (and hence definition) to internal type @code{itype}. -@item @code{@emph{function-name}! (@emph{arg}, @emph{arg}, @emph{arg})} +@item @code{@var{function-name}! (@var{arg}, @var{arg}, @var{arg})} Intrinsic function call. -@item @code{@emph{label-name} : label} +@item @code{@var{label-name} : label} Declaration of label @code{labelname}. -@item @code{#$ @emph{subprogram-name}} +@item @code{#$ @var{subprogram-name}} An implicit call to a run-time support routine (to meet the requirement of H.3.1(9) in a convenient manner). -@item @code{@emph{expr} && @emph{expr} && @emph{expr} ... && @emph{expr}} +@item @code{@var{expr} && @var{expr} && @var{expr} ... && @var{expr}} A multiple concatenation (same effect as @code{expr} & @code{expr} & @code{expr}, but handled more efficiently). @@ -14941,15 +14948,15 @@ A multiple concatenation (same effect as @code{expr} & @code{expr} & Raise the @code{Constraint_Error} exception. -@item @code{@emph{expression}'reference} +@item @code{@var{expression}'reference} A pointer to the result of evaluating @{expression@}. -@item @code{@emph{target-type}!(@emph{source-expression})} +@item @code{@var{target-type}!(@var{source-expression})} An unchecked conversion of @code{source-expression} to @code{target-type}. -@item @code{[@emph{numerator}/@emph{denominator}]} +@item @code{[@var{numerator}/@var{denominator}]} Used to represent internal real literals (that) have no exact representation in base 2-16 (for example, the result of compile time @@ -15225,7 +15232,7 @@ through the compilation and binding steps. @table @asis -@item @code{-gnatem=@emph{path}} +@item @code{-gnatem=`path'} A mapping file is a way to communicate to the compiler two mappings: from unit names to file names (without any directory information) and from @@ -15308,7 +15315,7 @@ Linker switches can be specified after @code{-largs} builder switch. @table @asis -@item @code{-fuse-ld=@emph{name}} +@item @code{-fuse-ld=`name'} Linker to be used. The default is @code{bfd} for @code{ld.bfd}, the alternative being @code{gold} for @code{ld.gold}. The later is @@ -15519,7 +15526,7 @@ Specify directory to be searched for source file. @table @asis -@item @code{-A[=@emph{filename}]} +@item @code{-A[=`filename']} Output ALI list (to standard output or to the named file). @end table @@ -15549,7 +15556,7 @@ Check only, no generation of binder output file. @table @asis -@item @code{-d@emph{nn}[k|m]} +@item @code{-d`nn'[k|m]} This switch can be used to change the default task stack size value to a specified size @code{nn}, which is expressed in bytes by default, or @@ -15570,7 +15577,7 @@ When they do not already have such a pragma. @table @asis -@item @code{-D@emph{nn}[k|m]} +@item @code{-D`nn'[k|m]} Set the default secondary stack size to @code{nn}. The suffix indicates whether the size is in bytes (no suffix), kilobytes (@code{k} suffix) or megabytes @@ -15646,7 +15653,7 @@ Currently the same as @code{-Ea}. @table @asis -@item @code{-f@emph{elab-order}} +@item @code{-f`elab-order'} Force elaboration order. For further details see @ref{111,,Elaboration Control} and @ref{f,,Elaboration Order Handling in GNAT}. @@ -15726,6 +15733,22 @@ Do not look for sources in the current directory where @code{gnatbind} was invoked, and do not look for ALI files in the directory containing the ALI file named in the @code{gnatbind} command line. +@geindex -k (gnatbind) + +@item @code{-k} + +Disable checking of elaboration flags. When using @code{-n} +either explicitly or implicitly, @code{-F} is also implied, +unless @code{-k} is used. This switch should be used with care +and you should ensure manually that elaboration routines are not called +twice unintentionally. + +@geindex -K (gnatbind) + +@item @code{-K} + +Give list of linker options specified for link. + @geindex -l (gnatbind) @item @code{-l} @@ -15734,25 +15757,25 @@ Output chosen elaboration order. @geindex -L (gnatbind) -@item @code{-L@emph{xxx}} +@item @code{-L`xxx'} Bind the units for library building. In this case the @code{adainit} and @code{adafinal} procedures (@ref{a0,,Binding with Non-Ada Main Programs}) -are renamed to @code{@emph{xxx}init} and -@code{@emph{xxx}final}. +are renamed to @code{@var{xxx}init} and +@code{@var{xxx}final}. Implies -n. (@ref{2a,,GNAT and Libraries}, for more details.) @geindex -M (gnatbind) -@item @code{-M@emph{xyz}} +@item @code{-M`xyz'} Rename generated main program from main to xyz. This option is supported on cross environments only. @geindex -m (gnatbind) -@item @code{-m@emph{n}} +@item @code{-m`n'} Limit number of detected errors or warnings to @code{n}, where @code{n} is in the range 1..999999. The default value if no switch is @@ -15769,7 +15792,7 @@ sign is optional. Generate a binder file suitable for space-constrained applications. When active, binder-generated objects not required for program operation are no -longer generated. @strong{Warning:} this option comes with the following +longer generated. `Warning:' this option comes with the following limitations: @@ -15805,14 +15828,14 @@ Do not look for library files in the system default directory. @geindex --RTS (gnatbind) -@item @code{--RTS=@emph{rts-path}} +@item @code{--RTS=`rts-path'} Specifies the default location of the run-time library. Same meaning as the equivalent @code{gnatmake} flag (@ref{ce,,Switches for gnatmake}). @geindex -o (gnatbind) -@item @code{-o @emph{file}} +@item @code{-o `file'} Name the output file @code{file} (default is @code{b~`xxx}.adb`). Note that if this option is used, then linking must be done manually, @@ -15820,7 +15843,7 @@ gnatlink cannot be used. @geindex -O (gnatbind) -@item @code{-O[=@emph{filename}]} +@item @code{-O[=`filename']} Output object list (to standard output or to the named file). @@ -15857,7 +15880,7 @@ Require all source files to be present. @geindex -S (gnatbind) -@item @code{-S@emph{xxx}} +@item @code{-S`xxx'} Specifies the value to be used when detecting uninitialized scalar objects with pragma Initialize_Scalars. @@ -15911,8 +15934,8 @@ then a 32-bit scalar value will be set to the bit patterm @code{16#BFBFBFBF#}. In addition, you can specify @code{-Sev} to indicate that the value is to be set at run time. In this case, the program will look for an environment -variable of the form @code{GNAT_INIT_SCALARS=@emph{yy}}, where @code{yy} is one -of @code{in/lo/hi/@emph{xx}} with the same meanings as above. +variable of the form @code{GNAT_INIT_SCALARS=@var{yy}}, where @code{yy} is one +of @code{in/lo/hi/@var{xx}} with the same meanings as above. If no environment variable is found, or if it does not have a valid value, then the default is @code{in} (invalid values). @end table @@ -15940,7 +15963,7 @@ Tolerate time stamp and other consistency errors. @geindex -T (gnatbind) -@item @code{-T@emph{n}} +@item @code{-T`n'} Set the time slice value to @code{n} milliseconds. If the system supports the specification of a specific time slice value, then the indicated value @@ -15956,7 +15979,7 @@ scheduling policy to @code{FIFO_Within_Priorities}. @geindex -u (gnatbind) -@item @code{-u@emph{n}} +@item @code{-u`n'} Enable dynamic stack usage, with @code{n} results stored and displayed at program termination. A result is generated when a task @@ -15973,7 +15996,7 @@ Verbose mode. Write error messages, header, summary output to @geindex -V (gnatbind) -@item @code{-V@emph{key}=@emph{value}} +@item @code{-V`key'=`value'} Store the given association of @code{key} to @code{value} in the bind environment. Values stored this way can be retrieved at run time using @@ -15981,13 +16004,13 @@ Values stored this way can be retrieved at run time using @geindex -w (gnatbind) -@item @code{-w@emph{x}} +@item @code{-w`x'} Warning mode; @code{x} = s/e for suppress/treat as error. @geindex -Wx (gnatbind) -@item @code{-Wx@emph{e}} +@item @code{-Wx`e'} Override default wide character encoding for standard Text_IO files. @@ -16010,7 +16033,7 @@ at streaming 128-bit integer types with it. @geindex -Xnnn (gnatbind) -@item @code{-X@emph{nnn}} +@item @code{-X`nnn'} Set default exit status value, normally 0 for POSIX compliance. @@ -16069,7 +16092,7 @@ file is an error. @geindex -Wx (gnatbind) -@item @code{-Wx@emph{e}} +@item @code{-Wx`e'} Override default wide character encoding for standard Text_IO files. Normally the default wide character encoding method used for standard @@ -16128,14 +16151,14 @@ specified. This is relevant only when used with the @geindex -m (gnatbind) -@item @code{-m@emph{n}} +@item @code{-m`n'} Limits the number of error messages to @code{n}, a decimal integer in the range 1-999. The binder terminates immediately if this limit is reached. @geindex -M (gnatbind) -@item @code{-M@emph{xxx}} +@item @code{-M`xxx'} Renames the generated main program from @code{main} to @code{xxx}. This is useful in the case of some cross-building environments, where @@ -16218,7 +16241,7 @@ order. For further details see @ref{f,,Elaboration Order Handling in GNAT}. @table @asis -@item @code{-f@emph{elab-order}} +@item @code{-f`elab-order'} Force elaboration order. @@ -16353,7 +16376,7 @@ directory names for the run-time units depend on the system configuration. @geindex -o (gnatbind) -@item @code{-o @emph{file}} +@item @code{-o `file'} Set name of output file to @code{file} instead of the normal @code{b~`mainprog}.adb` default. Note that @code{file} denote the Ada @@ -16473,7 +16496,7 @@ is given, more than one ALI file may appear on the command line for @code{gnatbind}. The normal @code{closure} calculation is performed for each of the specified units. Calculating the closure means finding out the set of units involved by tracing -@emph{with} references. The reason it is necessary to be able to +`with' references. The reason it is necessary to be able to specify more than one ALI file is that a given program may invoke two or more quite separate groups of Ada units. @@ -16544,9 +16567,9 @@ char **gnat_argv; are declared in one of the GNAT library routines. These variables must be set from the actual @code{argc} and @code{argv} values passed to the -main program. With no @emph{n} present, @code{gnatbind} +main program. With no `n' present, @code{gnatbind} generates the C main program to automatically set these variables. -If the @emph{n} switch is used, there is no automatic way to +If the `n' switch is used, there is no automatic way to set these variables. If they are not set, the procedures in @code{Ada.Command_Line} will not be available, and any attempt to use them will raise @code{Constraint_Error}. If command line access is @@ -16628,9 +16651,9 @@ instead if you want to specify source paths only, and @code{-aO} if you want to specify library paths only. This means that for the binder -@code{-I@emph{dir}} is equivalent to -@code{-aI@emph{dir}} -@code{-aO`@emph{dir}}. +@code{-I`dir'} is equivalent to +@code{-aI`dir'} +@code{-aO``dir'}. The binder generates the bind file (a C language source file) in the current working directory. @@ -16881,7 +16904,7 @@ it compiles the binder file, and that the system linker run in verbose mode. @table @asis -@item @code{-o @emph{exec-name}} +@item @code{-o `exec-name'} @code{exec-name} specifies an alternate name for the generated executable program. If this switch is omitted, the executable has the same @@ -16894,7 +16917,7 @@ an executable called @code{try}. @table @asis -@item @code{-B@emph{dir}} +@item @code{-B`dir'} Load compiler executables (for example, @code{gnat1}, the Ada compiler) from @code{dir} instead of the default location. Only use this switch @@ -16920,7 +16943,7 @@ has the same name as the executable with extension “.map”. @table @asis -@item @code{-M=@emph{mapfile}} +@item @code{-M=`mapfile'} When linking an executable, create a map file. The name of the map file is @code{mapfile}. @@ -16931,7 +16954,7 @@ When linking an executable, create a map file. The name of the map file is @table @asis -@item @code{--GCC=@emph{compiler_name}} +@item @code{--GCC=`compiler_name'} Program used for compiling the binder file. The default is @code{gcc}. You need to use quotes around @code{compiler_name} if @@ -16958,7 +16981,7 @@ into account. Thus, @table @asis -@item @code{--LINK=@emph{name}} +@item @code{--LINK=`name'} @code{name} is the name of the linker to be invoked. This is especially useful in mixed language programs since languages such as C++ require @@ -17366,7 +17389,7 @@ Display copyright and version, then exit disregarding all other options. If @code{--version} was not used, display usage, then exit disregarding all other options. -@item @code{--subdirs=@emph{subdir}} +@item @code{--subdirs=`subdir'} Actual object directory of each project file is the subdirectory subdir of the object directory specified or defaulted in the project file. @@ -17395,7 +17418,7 @@ files, interface copy files, binder generated files and executable files. @table @asis -@item @code{-D @emph{dir}} +@item @code{-D `dir'} Indicate that ALI and object files should normally be found in directory @code{dir}. @end table @@ -17439,7 +17462,7 @@ that would have been deleted if this switch was not specified. @table @asis -@item @code{-P@emph{project}} +@item @code{-P`project'} Use project file @code{project}. Only one such switch can be used. When cleaning a project file, the files produced by the compilation of the @@ -17488,7 +17511,7 @@ Verbose mode. @table @asis -@item @code{-vP@emph{x}} +@item @code{-vP`x'} Indicates the verbosity of the parsing of GNAT project files. @ref{cf,,Switches Related to Project Files}. @@ -17499,7 +17522,7 @@ Indicates the verbosity of the parsing of GNAT project files. @table @asis -@item @code{-X@emph{name}=@emph{value}} +@item @code{-X`name'=`value'} Indicates that external variable @code{name} has the value @code{value}. The Project Manager will use this value for occurrences of @@ -17512,7 +17535,7 @@ See @ref{cf,,Switches Related to Project Files}. @table @asis -@item @code{-aO@emph{dir}} +@item @code{-aO`dir'} When searching for ALI and object files, look in directory @code{dir}. @end table @@ -17522,9 +17545,9 @@ When searching for ALI and object files, look in directory @code{dir}. @table @asis -@item @code{-I@emph{dir}} +@item @code{-I`dir'} -Equivalent to @code{-aO@emph{dir}}. +Equivalent to @code{-aO`dir'}. @end table @geindex -I- (gnatclean) @@ -17613,12 +17636,12 @@ qualifier which can be: @table @asis -@item @emph{OK (unchanged)} +@item `OK (unchanged)' The version of the source file used for the compilation of the specified unit corresponds exactly to the actual source file. -@item @emph{MOK (slightly modified)} +@item `MOK (slightly modified)' The version of the source file used for the compilation of the specified unit differs from the actual source file but not enough to @@ -17626,16 +17649,16 @@ require recompilation. If you use gnatmake with the option @code{-m} (minimal recompilation), a file marked MOK will not be recompiled. -@item @emph{DIF (modified)} +@item `DIF (modified)' No version of the source found on the path corresponds to the source used to build this object. -@item @emph{??? (file not found)} +@item `??? (file not found)' No source file was found for this unit. -@item @emph{HID (hidden, unchanged version not first on PATH)} +@item `HID (hidden, unchanged version not first on PATH)' The version of the source that corresponds exactly to the source used for compilation has been found on the path but it is hidden by another @@ -17736,7 +17759,7 @@ Only output information about compilation units. @table @asis -@item @code{-files=@emph{file}} +@item @code{-files=`file'} Take as arguments the files listed in text file @code{file}. Text file @code{file} may contain empty lines that are ignored. @@ -17755,7 +17778,7 @@ Several such switches may be specified simultaneously. @table @asis -@item @code{-aO@emph{dir}}, @code{-aI@emph{dir}}, @code{-I@emph{dir}}, @code{-I-}, @code{-nostdinc} +@item @code{-aO`dir'}, @code{-aI`dir'}, @code{-I`dir'}, @code{-I-}, @code{-nostdinc} Source path manipulation. Same meaning as the equivalent @code{gnatmake} flags (@ref{ce,,Switches for gnatmake}). @@ -17766,7 +17789,7 @@ flags (@ref{ce,,Switches for gnatmake}). @table @asis -@item @code{-aP@emph{dir}} +@item @code{-aP`dir'} Add @code{dir} at the beginning of the project search dir. @end table @@ -17776,7 +17799,7 @@ Add @code{dir} at the beginning of the project search dir. @table @asis -@item @code{--RTS=@emph{rts-path}} +@item @code{--RTS=`rts-path'} Specifies the default location of the runtime library. Same meaning as the equivalent @code{gnatmake} flag (@ref{ce,,Switches for gnatmake}). @@ -17798,29 +17821,29 @@ characteristics such as: @itemize * @item -@emph{Preelaborable}: The unit is preelaborable in the Ada sense. +`Preelaborable': The unit is preelaborable in the Ada sense. @item -@emph{No_Elab_Code}: No elaboration code has been produced by the compiler for this unit. +`No_Elab_Code': No elaboration code has been produced by the compiler for this unit. @item -@emph{Pure}: The unit is pure in the Ada sense. +`Pure': The unit is pure in the Ada sense. @item -@emph{Elaborate_Body}: The unit contains a pragma Elaborate_Body. +`Elaborate_Body': The unit contains a pragma Elaborate_Body. @item -@emph{Remote_Types}: The unit contains a pragma Remote_Types. +`Remote_Types': The unit contains a pragma Remote_Types. @item -@emph{Shared_Passive}: The unit contains a pragma Shared_Passive. +`Shared_Passive': The unit contains a pragma Shared_Passive. @item -@emph{Predefined}: This unit is part of the predefined environment and cannot be modified +`Predefined': This unit is part of the predefined environment and cannot be modified by the user. @item -@emph{Remote_Call_Interface}: The unit contains a pragma Remote_Call_Interface. +`Remote_Call_Interface': The unit contains a pragma Remote_Call_Interface. @end itemize @end table @@ -18101,7 +18124,7 @@ describes some of the additional commands that can be given to @code{GDB}. @code{GDB} contains a large repertoire of commands. See @cite{Debugging with GDB} for extensive documentation on the use of these commands, together with examples of their use. Furthermore, -the command @emph{help} invoked from within GDB activates a simple help +the command `help' invoked from within GDB activates a simple help facility which summarizes the available commands and their options. In this section we summarize a few of the most commonly used commands to give an idea of what @code{GDB} is about. You should create @@ -18116,9 +18139,9 @@ following section. @table @asis -@item @code{set args @emph{arguments}} +@item @code{set args @var{arguments}} -The @emph{arguments} list above is a list of arguments to be passed to +The `arguments' list above is a list of arguments to be passed to the program on a subsequent run command, just as though the arguments had been entered on a normal invocation of the program. The @code{set args} command is not needed if the program does not require arguments. @@ -18141,11 +18164,11 @@ restart. @table @asis -@item @code{breakpoint @emph{location}} +@item @code{breakpoint @var{location}} The breakpoint command sets a breakpoint, that is to say a point at which execution will halt and @code{GDB} will await further -commands. @emph{location} is +commands. `location' is either a line number within a file, given in the format @code{file:linenumber}, or it is the name of a subprogram. If you request that a breakpoint be set on a subprogram that is overloaded, a prompt will ask you to specify on which of @@ -18160,7 +18183,7 @@ printing the line of code before which the program is halted. @table @asis -@item @code{catch exception @emph{name}} +@item @code{catch exception @var{name}} This command causes the program execution to stop whenever exception @code{name} is raised. If @code{name} is omitted, then the execution is @@ -18171,7 +18194,7 @@ suspended when any exception is raised. @table @asis -@item @code{print @emph{expression}} +@item @code{print @var{expression}} This will print the value of the given expression. Most simple Ada expression formats are properly handled by @code{GDB}, so the expression @@ -18260,7 +18283,7 @@ examined to the frame of its callee (the reverse of the previous command), @table @asis -@item @code{frame @emph{n}} +@item @code{frame @var{n}} Inspect the frame with the given number. The value 0 denotes the frame of the current breakpoint, that is to say the top of the call stack. @@ -18400,7 +18423,7 @@ the elements in the desired format. @node Using the next Command in a Function,Stopping When Ada Exceptions Are Raised,Calling User-Defined Subprograms,Running and Debugging Ada Programs @anchor{gnat_ugn/gnat_and_program_execution id8}@anchor{158}@anchor{gnat_ugn/gnat_and_program_execution using-the-next-command-in-a-function}@anchor{159} -@subsection Using the @emph{next} Command in a Function +@subsection Using the `next' Command in a Function When you use the @code{next} command in a function, the current source @@ -18448,10 +18471,10 @@ raises any exception. @table @asis -@item @code{catch exception @emph{name}} +@item @code{catch exception @var{name}} Set a catchpoint that stops execution whenever (any task in the) program -raises the exception @emph{name}. +raises the exception `name'. @end table @item @@ -18468,11 +18491,11 @@ raises an exception for which there is no handler. @table @asis -@item @code{info exceptions}, @code{info exceptions @emph{regexp}} +@item @code{info exceptions}, @code{info exceptions @var{regexp}} The @code{info exceptions} command permits the user to examine all defined -exceptions within Ada programs. With a regular expression, @emph{regexp}, as -argument, prints out only those exceptions whose name matches @emph{regexp}. +exceptions within Ada programs. With a regular expression, `regexp', as +argument, prints out only those exceptions whose name matches `regexp'. @end table @end itemize @@ -18517,25 +18540,25 @@ to refer to tasks in the following commands. @itemize * @item -@code{break} @emph{linespec} @code{task} @emph{taskid}, @code{break} @emph{linespec} @code{task} @emph{taskid} @code{if} … +@code{break} `linespec' @code{task} `taskid', @code{break} `linespec' @code{task} `taskid' @code{if} … @quotation These commands are like the @code{break ... thread ...}. -@emph{linespec} specifies source lines. +`linespec' specifies source lines. -Use the qualifier @code{task @emph{taskid}} with a breakpoint command +Use the qualifier @code{task @var{taskid}} with a breakpoint command to specify that you only want @code{GDB} to stop the program when a -particular Ada task reaches this breakpoint. @emph{taskid} is one of the +particular Ada task reaches this breakpoint. `taskid' is one of the numeric task identifiers assigned by @code{GDB}, shown in the first column of the @code{info tasks} display. -If you do not specify @code{task @emph{taskid}} when you set a -breakpoint, the breakpoint applies to @emph{all} tasks of your +If you do not specify @code{task @var{taskid}} when you set a +breakpoint, the breakpoint applies to `all' tasks of your program. You can use the @code{task} qualifier on conditional breakpoints as -well; in this case, place @code{task @emph{taskid}} before the +well; in this case, place @code{task @var{taskid}} before the breakpoint condition (before the @code{if}). @end quotation @end itemize @@ -18546,11 +18569,11 @@ breakpoint condition (before the @code{if}). @itemize * @item -@code{task @emph{taskno}} +@code{task @var{taskno}} @quotation -This command allows switching to the task referred by @emph{taskno}. In +This command allows switching to the task referred by `taskno'. In particular, this allows browsing of the backtrace of the specified task. It is advisable to switch back to the original task before continuing execution otherwise the scheduling of the program may be @@ -18676,7 +18699,7 @@ It is also possible to use gdbserver to attach to an already running program, in which case the execution of that program is simply suspended until the connection between the debugger and gdbserver is established. -For more information on how to use gdbserver, see the @emph{Using the gdbserver Program} +For more information on how to use gdbserver, see the `Using the gdbserver Program' section in @cite{Debugging with GDB}. GNAT provides support for gdbserver on x86-linux, x86-windows and x86_64-linux. @@ -18863,7 +18886,7 @@ are replaced with run-time calls. Traceback is a mechanism to display the sequence of subprogram calls that leads to a specified execution point in a program. Often (but not always) the execution point is an instruction at which an exception has been raised. -This mechanism is also known as @emph{stack unwinding} because it obtains +This mechanism is also known as `stack unwinding' because it obtains its information by scanning the run-time stack and recovering the activation records of all active subprograms. Stack unwinding is one of the most important tools for program debugging. @@ -18897,12 +18920,14 @@ for a complete list of supported platforms. A runtime non-symbolic traceback is a list of addresses of call instructions. -To enable this feature you must use the @code{-E} -@code{gnatbind} option. With this option a stack traceback is stored as part -of exception information. You can retrieve this information using the -@code{addr2line} tool. +To enable this feature you must use the @code{-E} @code{gnatbind} option. With +this option a stack traceback is stored as part of exception information. -Here is a simple example: +You can translate this information using the @code{addr2line} tool, provided that +the program is compiled with debugging options (see @ref{db,,Compiler Switches}) +and linked at a fixed position with @code{-no-pie}. + +Here is a simple example with @code{gnatmake}: @quotation @@ -18925,12 +18950,12 @@ end STB; @end example @example -$ gnatmake stb -bargs -E +$ gnatmake stb -g -bargs -E -largs -no-pie $ stb -Execution terminated by unhandled exception -Exception name: CONSTRAINT_ERROR -Message: stb.adb:5 +Execution of stb terminated by unhandled exception +raised CONSTRAINT_ERROR : stb.adb:5 explicit raise +Load address: 0x400000 Call stack traceback locations: 0x401373 0x40138b 0x40139c 0x401335 0x4011c4 0x4011f1 0x77e892a4 @end example @@ -18939,32 +18964,22 @@ Call stack traceback locations: As we see the traceback lists a sequence of addresses for the unhandled exception @code{CONSTRAINT_ERROR} raised in procedure P1. It is easy to guess that this exception come from procedure P1. To translate these -addresses into the source lines where the calls appear, the -@code{addr2line} tool, described below, is invaluable. The use of this tool -requires the program to be compiled with debug information. +addresses into the source lines where the calls appear, the @code{addr2line} +tool needs to be invoked like this: @quotation @example -$ gnatmake -g stb -bargs -E -$ stb - -Execution terminated by unhandled exception -Exception name: CONSTRAINT_ERROR -Message: stb.adb:5 -Call stack traceback locations: -0x401373 0x40138b 0x40139c 0x401335 0x4011c4 0x4011f1 0x77e892a4 - -$ addr2line --exe=stb 0x401373 0x40138b 0x40139c 0x401335 0x4011c4 +$ addr2line -e stb 0x401373 0x40138b 0x40139c 0x401335 0x4011c4 0x4011f1 0x77e892a4 -00401373 at d:/stb/stb.adb:5 -0040138B at d:/stb/stb.adb:10 -0040139C at d:/stb/stb.adb:14 -00401335 at d:/stb/b~stb.adb:104 -004011C4 at /build/.../crt1.c:200 -004011F1 at /build/.../crt1.c:222 -77E892A4 in ?? at ??:0 +d:/stb/stb.adb:5 +d:/stb/stb.adb:10 +d:/stb/stb.adb:14 +d:/stb/b~stb.adb:197 +crtexe.c:? +crtexe.c:? +??:0 @end example @end quotation @@ -18973,14 +18988,30 @@ The @code{addr2line} tool has several other useful options: @quotation -@multitable {xxxxxxxxxxxxxxxxxxxxxxxxxx} {xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx} +@multitable {xxxxxxxxxxxxxxxxxxxxxxxxxxx} {xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx} +@item + +@code{-a --addresses} + +@tab + +to show the addresses alongside the line numbers + +@item + +@code{-f --functions} + +@tab + +to get the function name corresponding to a location + @item -@code{--functions} +@code{-p --pretty-print} @tab -to get the function name corresponding to any location +to print all the information on a single line @item @@ -18988,61 +19019,82 @@ to get the function name corresponding to any location @tab -to use the gnat decoding mode for the function names. -Note that for binutils version 2.9.x the option is -simply @code{--demangle}. +to use the GNAT decoding mode for the function names @end multitable @example -$ addr2line --exe=stb --functions --demangle=gnat 0x401373 0x40138b - 0x40139c 0x401335 0x4011c4 0x4011f1 +$ addr2line -e stb -a -f -p --demangle=gnat 0x401373 0x40138b + 0x40139c 0x401335 0x4011c4 0x4011f1 0x77e892a4 -00401373 in stb.p1 at d:/stb/stb.adb:5 -0040138B in stb.p2 at d:/stb/stb.adb:10 -0040139C in stb at d:/stb/stb.adb:14 -00401335 in main at d:/stb/b~stb.adb:104 -004011C4 in <__mingw_CRTStartup> at /build/.../crt1.c:200 -004011F1 in <mainCRTStartup> at /build/.../crt1.c:222 +0x00401373: stb.p1 at d:/stb/stb.adb:5 +0x0040138B: stb.p2 at d:/stb/stb.adb:10 +0x0040139C: stb at d:/stb/stb.adb:14 +0x00401335: main at d:/stb/b~stb.adb:197 +0x004011c4: ?? at crtexe.c:? +0x004011f1: ?? at crtexe.c:? +0x77e892a4: ?? ??:0 @end example @end quotation -From this traceback we can see that the exception was raised in -@code{stb.adb} at line 5, which was reached from a procedure call in -@code{stb.adb} at line 10, and so on. The @code{b~std.adb} is the binder file, -which contains the call to the main program. -@ref{10e,,Running gnatbind}. The remaining entries are assorted runtime routines, -and the output will vary from platform to platform. +From this traceback we can see that the exception was raised in @code{stb.adb} +at line 5, which was reached from a procedure call in @code{stb.adb} at line +10, and so on. The @code{b~std.adb} is the binder file, which contains the +call to the main program. @ref{10e,,Running gnatbind}. The remaining entries are +assorted runtime routines and the output will vary from platform to platform. It is also possible to use @code{GDB} with these traceback addresses to debug the program. For example, we can break at a given code location, as reported in the stack traceback: -@quotation - @example $ gdb -nw stb + +(gdb) break *0x401373 +Breakpoint 1 at 0x401373: file stb.adb, line 5. @end example -@end quotation -Furthermore, this feature is not implemented inside Windows DLL. Only -the non-symbolic traceback is reported in this case. +It is important to note that the stack traceback addresses do not change when +debug information is included. This is particularly useful because it makes it +possible to release software without debug information (to minimize object +size), get a field report that includes a stack traceback whenever an internal +bug occurs, and then be able to retrieve the sequence of calls with the same +program compiled with debug information. -@quotation +However the @code{addr2line} tool does not work with Position-Independent Code +(PIC), the historical example being Windows DLLs, which nowadays encompasses +Position-Independent Executables (PIE) on recent Windows versions. + +In order to translate addresses into the source lines with Position-Independent +Executables on recent Windows versions, in other words without using the switch +@code{-no-pie} during linking, you need to use the @code{gnatsymbolize} tool +with @code{--load} instead of the @code{addr2line} tool. The main difference +is that you need to copy the Load Address output in the traceback ahead of the +sequence of addresses. And the default mode of @code{gnatsymbolize} is equivalent +to that of @code{addr2line} with the above switches, so none of them is needed: @example -(gdb) break *0x401373 -Breakpoint 1 at 0x401373: file stb.adb, line 5. -@end example -@end quotation +$ gnatmake stb -g -bargs -E +$ stb + +Execution of stb terminated by unhandled exception +raised CONSTRAINT_ERROR : stb.adb:5 explicit raise +Load address: 0x400000 +Call stack traceback locations: +0x401373 0x40138b 0x40139c 0x401335 0x4011c4 0x4011f1 0x77e892a4 + +$ gnatsymbolize --load stb 0x400000 0x401373 0x40138b 0x40139c 0x401335 + 0x4011c4 0x4011f1 0x77e892a4 -It is important to note that the stack traceback addresses -do not change when debug information is included. This is particularly useful -because it makes it possible to release software without debug information (to -minimize object size), get a field report that includes a stack traceback -whenever an internal bug occurs, and then be able to retrieve the sequence -of calls with the same program compiled with debug information. +0x00401373 Stb.P1 at stb.adb:5 +0x0040138B Stb.P2 at stb.adb:10 +0x0040139C Stb at stb.adb:14 +0x00401335 Main at b~stb.adb:197 +0x004011c4 __tmainCRTStartup at ??? +0x004011f1 mainCRTStartup at ??? +0x77e892a4 ??? at ??? +@end example @subsubheading Tracebacks From Exception Occurrences @@ -19090,8 +19142,8 @@ This program will output: @example $ stb -Exception name: CONSTRAINT_ERROR -Message: stb.adb:12 +raised CONSTRAINT_ERROR : stb.adb:12 range check failed +Load address: 0x400000 Call stack traceback locations: 0x4015e4 0x401633 0x401644 0x401461 0x4011c4 0x4011f1 0x77e892a4 @end example @@ -19100,17 +19152,16 @@ Call stack traceback locations: @subsubheading Tracebacks From Anywhere in a Program -It is also possible to retrieve a stack traceback from anywhere in a -program. For this you need to -use the @code{GNAT.Traceback} API. This package includes a procedure called -@code{Call_Chain} that computes a complete stack traceback, as well as useful -display procedures described below. It is not necessary to use the -@code{-E} @code{gnatbind} option in this case, because the stack traceback mechanism -is invoked explicitly. +It is also possible to retrieve a stack traceback from anywhere in a program. +For this you need to use the @code{GNAT.Traceback} API. This package includes a +procedure called @code{Call_Chain} that computes a complete stack traceback, as +well as useful display procedures described below. It is not necessary to use +the @code{-E} @code{gnatbind} option in this case, because the stack traceback +mechanism is invoked explicitly. -In the following example we compute a traceback at a specific location in -the program, and we display it using @code{GNAT.Debug_Utilities.Image} to -convert addresses to strings: +In the following example we compute a traceback at a specific location in the +program, and we display it using @code{GNAT.Debug_Utilities.Image} to convert +addresses to strings: @quotation @@ -19154,7 +19205,7 @@ end STB; @end example @example -$ gnatmake -g stb +$ gnatmake stb -g $ stb In STB.P1 : 16#0040_F1E4# 16#0040_14F2# 16#0040_170B# 16#0040_171C# @@ -19162,9 +19213,9 @@ In STB.P1 : 16#0040_F1E4# 16#0040_14F2# 16#0040_170B# 16#0040_171C# @end example @end quotation -You can then get further information by invoking the @code{addr2line} -tool as described earlier (note that the hexadecimal addresses -need to be specified in C format, with a leading ‘0x’). +You can then get further information by invoking the @code{addr2line} tool or +the @code{gnatsymbolize} tool as described earlier (note that the hexadecimal +addresses need to be specified in C format, with a leading ‘0x’). @geindex traceback @geindex symbolic @@ -19560,7 +19611,7 @@ The following is the subset of those switches that is most relevant: @table @asis -@item @code{--demangle[=@emph{style}]}, @code{--no-demangle} +@item @code{--demangle[=@var{style}]}, @code{--no-demangle} These options control whether symbol names should be demangled when printing output. The default is to demangle C++ symbols. The @@ -19576,9 +19627,9 @@ compiler, in particular Ada symbols generated by GNAT can be demangled using @table @asis -@item @code{-e @emph{function_name}} +@item @code{-e @var{function_name}} -The @code{-e @emph{function}} option tells @code{gprof} not to print +The @code{-e @var{function}} option tells @code{gprof} not to print information about the function @code{function_name} (and its children…) in the call graph. The function will still be listed as a child of any functions that call it, but its index number will be @@ -19592,9 +19643,9 @@ option. @table @asis -@item @code{-E @emph{function_name}} +@item @code{-E @var{function_name}} -The @code{-E @emph{function}} option works like the @code{-e} option, but +The @code{-E @var{function}} option works like the @code{-e} option, but execution time spent in the function (and children who were not called from anywhere else), will not be used to compute the percentages-of-time for the call graph. More than one @code{-E} option may be given; only one @@ -19606,9 +19657,9 @@ the call graph. More than one @code{-E} option may be given; only one @table @asis -@item @code{-f @emph{function_name}} +@item @code{-f @var{function_name}} -The @code{-f @emph{function}} option causes @code{gprof} to limit the +The @code{-f @var{function}} option causes @code{gprof} to limit the call graph to the function @code{function_name} and its children (and their children…). More than one @code{-f} option may be given; only one @code{function_name} may be indicated with each @code{-f} @@ -19620,9 +19671,9 @@ option. @table @asis -@item @code{-F @emph{function_name}} +@item @code{-F @var{function_name}} -The @code{-F @emph{function}} option works like the @code{-f} option, but +The @code{-F @var{function}} option works like the @code{-f} option, but only time spent in the function and its children (and their children…) will be used to determine total-time and percentages-of-time for the call graph. More than one @code{-F} option @@ -19921,7 +19972,7 @@ You should experiment to find the best level for your application. Since the precise set of optimizations done at each level will vary from release to release (and sometime from target to target), it is best to think of the optimization settings in general terms. -See the @emph{Options That Control Optimization} section in +See the `Options That Control Optimization' section in @cite{Using the GNU Compiler Collection (GCC)} for details about the @code{-O} settings and a number of @code{-f} options that @@ -19930,7 +19981,7 @@ individually enable or disable specific optimizations. Unlike some other compilation systems, @code{gcc} has been tested extensively at all optimization levels. There are some bugs which appear only with optimization turned on, but there have also been -bugs which show up only in @emph{unoptimized} code. Selecting a lower +bugs which show up only in `unoptimized' code. Selecting a lower level of optimization does not improve the reliability of the code generator, which in practice is highly reliable at all optimization levels. @@ -19979,7 +20030,7 @@ These are the most common cases: @itemize * @item -@emph{The ‘hopping Program Counter’:} Repeated @code{step} or @code{next} +`The ‘hopping Program Counter’:' Repeated @code{step} or @code{next} commands show the PC bouncing back and forth in the code. This may result from any of the following optimizations: @@ -19988,16 +20039,16 @@ the following optimizations: @itemize - @item -@emph{Common subexpression elimination:} using a single instance of code for a +`Common subexpression elimination:' using a single instance of code for a quantity that the source computes several times. As a result you may not be able to stop on what looks like a statement. @item -@emph{Invariant code motion:} moving an expression that does not change within a +`Invariant code motion:' moving an expression that does not change within a loop, to the beginning of the loop. @item -@emph{Instruction scheduling:} moving instructions so as to +`Instruction scheduling:' moving instructions so as to overlap loads and stores (typically) with other code, or in general to move computations of values closer to their uses. Often this causes you to pass an assignment statement without the assignment @@ -20008,16 +20059,16 @@ expected side-effects. @end itemize @item -@emph{The ‘big leap’:} More commonly known as @emph{cross-jumping}, in which +`The ‘big leap’:' More commonly known as `cross-jumping', in which two identical pieces of code are merged and the program counter suddenly jumps to a statement that is not supposed to be executed, simply because it (and the code following) translates to the same thing as the code -that @emph{was} supposed to be executed. This effect is typically seen in +that `was' supposed to be executed. This effect is typically seen in sequences that end in a jump, such as a @code{goto}, a @code{return}, or a @code{break} in a C @code{switch} statement. @item -@emph{The ‘roving variable’:} The symptom is an unexpected value in a variable. +`The ‘roving variable’:' The symptom is an unexpected value in a variable. There are various reasons for this effect: @@ -20053,7 +20104,7 @@ calling subprogram to verify that the value observed is explainable from other values (one must apply the procedure recursively to those other values); or re-running the code and stopping a little earlier (perhaps before the call) and stepping to better see how the variable obtained -the value in question; or continuing to step @emph{from} the point of the +the value in question; or continuing to step `from' the point of the strange value to see if code motion had simply moved the variable’s assignments later. @end itemize @@ -20098,7 +20149,7 @@ within it; the subprogram is small and optimization level @code{-O2} is specified; optimization level @code{-O3} is specified. @end itemize -Calls to subprograms in @emph{with}ed units are normally not inlined. +Calls to subprograms in `with'ed units are normally not inlined. To achieve actual inlining (that is, replacement of the call by the code in the body of the subprogram), the following conditions must all be true: @@ -20420,7 +20471,7 @@ to work. Examples of switches in this category are @code{-funroll-loops} and the various target-specific @code{-m} options (in particular, it has been observed that @code{-march=xxx} can significantly improve performance on appropriate machines). For full details of these switches, see -the @emph{Submodel Options} section in the @emph{Hardware Models and Configurations} +the `Submodel Options' section in the `Hardware Models and Configurations' chapter of @cite{Using the GNU Compiler Collection (GCC)}. @node Optimization and Strict Aliasing,Aliased Variables and Optimization,Other Optimization Switches,Performance Considerations @@ -20863,7 +20914,7 @@ If @code{Text_IO} must be used, note that by default output to the standard output and standard error files is unbuffered (this provides better behavior when output statements are used for debugging, or if the progress of a program is observed by tracking the output, e.g. by -using the Unix @emph{tail -f} command to watch redirected output). +using the Unix `tail -f' command to watch redirected output). If you are generating large volumes of output with @code{Text_IO} and performance is an important factor, use a designated file instead @@ -21174,7 +21225,7 @@ The three modes are: @itemize * @item -@emph{Use base type for intermediate operations} (@code{STRICT}) +`Use base type for intermediate operations' (@code{STRICT}) In this mode, all intermediate results for predefined arithmetic operators are computed using the base type, and the result must @@ -21184,7 +21235,7 @@ enabled) or the execution is erroneous (if overflow checks are suppressed). This is the normal default mode. @item -@emph{Most intermediate overflows avoided} (@code{MINIMIZED}) +`Most intermediate overflows avoided' (@code{MINIMIZED}) In this mode, the compiler attempts to avoid intermediate overflows by using a larger integer type, typically @code{Long_Long_Integer}, @@ -21217,12 +21268,12 @@ out of the range of @code{Long_Long_Integer} even though the final result is in range and the precondition is True (from a mathematical point of view). In such a case, operating in this mode, an overflow occurs for the intermediate computation (which is why this mode -says @emph{most} intermediate overflows are avoided). In this case, +says `most' intermediate overflows are avoided). In this case, an exception is raised if overflow checks are enabled, and the execution is erroneous if overflow checks are suppressed. @item -@emph{All intermediate overflows avoided} (@code{ELIMINATED}) +`All intermediate overflows avoided' (@code{ELIMINATED}) In this mode, the compiler avoids all intermediate overflows by using arbitrary precision arithmetic as required. In this @@ -21509,8 +21560,8 @@ version 7.0.1 of GNAT onwards. The GNAT-specific aspect @code{Dimension_System} allows you to define a system of units; the aspect @code{Dimension} then allows the user to declare dimensioned quantities within a given system. -(These aspects are described in the @emph{Implementation Defined Aspects} -chapter of the @emph{GNAT Reference Manual}). +(These aspects are described in the `Implementation Defined Aspects' +chapter of the `GNAT Reference Manual'). The major advantage of this model is that it does not require the declaration of multiple operators for all possible combinations of types: it is only necessary @@ -21707,9 +21758,9 @@ Final velocity: 98.10 m.s**(-1) @geindex Dimensioned subtype @end quotation -The type @code{Mks_Type} is said to be a @emph{dimensionable type} since it has a +The type @code{Mks_Type} is said to be a `dimensionable type' since it has a @code{Dimension_System} aspect, and the subtypes @code{Length}, @code{Mass}, etc., -are said to be @emph{dimensioned subtypes} since each one has a @code{Dimension} +are said to be `dimensioned subtypes' since each one has a @code{Dimension} aspect. @quotation @@ -21723,8 +21774,8 @@ aspect. The @code{Dimension} aspect of a dimensioned subtype @code{S} defines a mapping from the base type’s Unit_Names to integer (or, more generally, rational) -values. This mapping is the @emph{dimension vector} (also referred to as the -@emph{dimensionality}) for that subtype, denoted by @code{DV(S)}, and thus for each +values. This mapping is the `dimension vector' (also referred to as the +`dimensionality') for that subtype, denoted by @code{DV(S)}, and thus for each object of that subtype. Intuitively, the value specified for each @code{Unit_Name} is the exponent associated with that unit; a zero value means that the unit is not used. For example: @@ -21750,34 +21801,34 @@ dimension vectors of its components, with compile-time dimensionality checks that help prevent mismatches such as using an @code{Acceleration} where a @code{Length} is required. -The dimension vector of the result of an arithmetic expression @emph{expr}, or -@code{DV(@emph{expr})}, is defined as follows, assuming conventional +The dimension vector of the result of an arithmetic expression `expr', or +@code{DV(@var{expr})}, is defined as follows, assuming conventional mathematical definitions for the vector operations that are used: @itemize * @item -If @emph{expr} is of the type @emph{universal_real}, or is not of a dimensioned subtype, -then @emph{expr} is dimensionless; @code{DV(@emph{expr})} is the empty vector. +If `expr' is of the type `universal_real', or is not of a dimensioned subtype, +then `expr' is dimensionless; @code{DV(@var{expr})} is the empty vector. @item -@code{DV(@emph{op expr})}, where @emph{op} is a unary operator, is @code{DV(@emph{expr})} +@code{DV(@var{op expr})}, where `op' is a unary operator, is @code{DV(@var{expr})} @item -@code{DV(@emph{expr1 op expr2})} where @emph{op} is “+” or “-” is @code{DV(@emph{expr1})} -provided that @code{DV(@emph{expr1})} = @code{DV(@emph{expr2})}. +@code{DV(@var{expr1 op expr2})} where `op' is “+” or “-” is @code{DV(@var{expr1})} +provided that @code{DV(@var{expr1})} = @code{DV(@var{expr2})}. If this condition is not met then the construct is illegal. @item -@code{DV(@emph{expr1} * @emph{expr2})} is @code{DV(@emph{expr1})} + @code{DV(@emph{expr2})}, -and @code{DV(@emph{expr1} / @emph{expr2})} = @code{DV(@emph{expr1})} - @code{DV(@emph{expr2})}. -In this context if one of the @emph{expr}s is dimensionless then its empty +@code{DV(@var{expr1} * @var{expr2})} is @code{DV(@var{expr1})} + @code{DV(@var{expr2})}, +and @code{DV(@var{expr1} / @var{expr2})} = @code{DV(@var{expr1})} - @code{DV(@var{expr2})}. +In this context if one of the `expr's is dimensionless then its empty dimension vector is treated as @code{(others => 0)}. @item -@code{DV(@emph{expr} ** @emph{power})} is @emph{power} * @code{DV(@emph{expr})}, -provided that @emph{power} is a static rational value. If this condition is not +@code{DV(@var{expr} ** @var{power})} is `power' * @code{DV(@var{expr})}, +provided that `power' is a static rational value. If this condition is not met then the construct is illegal. @end itemize @@ -21787,7 +21838,7 @@ combine a dimensioned and dimensionless value. Thus an expression such as @code{Acceleration}. The dimensionality checks for relationals use the same rules as -for “+” and “-“, except when comparing to a literal; thus +for “+” and “-”, except when comparing to a literal; thus @quotation @@ -21817,17 +21868,17 @@ acc > 10.0 is accepted with a warning. Analogously a conditional expression requires the same dimension vector for each branch (with no exception for literals). -The dimension vector of a type conversion @code{T(@emph{expr})} is defined +The dimension vector of a type conversion @code{T(@var{expr})} is defined as follows, based on the nature of @code{T}: @itemize * @item -If @code{T} is a dimensioned subtype then @code{DV(T(@emph{expr}))} is @code{DV(T)} -provided that either @emph{expr} is dimensionless or -@code{DV(T)} = @code{DV(@emph{expr})}. The conversion is illegal -if @emph{expr} is dimensioned and @code{DV(@emph{expr})} /= @code{DV(T)}. +If @code{T} is a dimensioned subtype then @code{DV(T(@var{expr}))} is @code{DV(T)} +provided that either `expr' is dimensionless or +@code{DV(T)} = @code{DV(@var{expr})}. The conversion is illegal +if `expr' is dimensioned and @code{DV(@var{expr})} /= @code{DV(T)}. Note that vector equality does not require that the corresponding Unit_Names be the same. @@ -21839,9 +21890,9 @@ a length in inches (with a suitable conversion factor) but cannot be converted, for example, to a mass in pounds. @item -If @code{T} is the base type for @emph{expr} (and the dimensionless root type of -the dimension system), then @code{DV(T(@emph{expr}))} is @code{DV(expr)}. -Thus, if @emph{expr} is of a dimensioned subtype of @code{T}, the conversion may +If @code{T} is the base type for `expr' (and the dimensionless root type of +the dimension system), then @code{DV(T(@var{expr}))} is @code{DV(expr)}. +Thus, if `expr' is of a dimensioned subtype of @code{T}, the conversion may be regarded as a “view conversion” that preserves dimensionality. This rule makes it possible to write generic code that can be instantiated @@ -21853,13 +21904,13 @@ dimensionality. @item Otherwise (i.e., @code{T} is neither a dimensioned subtype nor a dimensionable -base type), @code{DV(T(@emph{expr}))} is the empty vector. Thus a dimensioned +base type), @code{DV(T(@var{expr}))} is the empty vector. Thus a dimensioned value can be explicitly converted to a non-dimensioned subtype, which of course then escapes dimensionality analysis. @end itemize -The dimension vector for a type qualification @code{T'(@emph{expr})} is the same -as for the type conversion @code{T(@emph{expr})}. +The dimension vector for a type qualification @code{T'(@var{expr})} is the same +as for the type conversion @code{T(@var{expr})}. An assignment statement @@ -22033,16 +22084,16 @@ where: @itemize * @item -@emph{Index} is a number associated with each task. +`Index' is a number associated with each task. @item -@emph{Task Name} is the name of the task analyzed. +`Task Name' is the name of the task analyzed. @item -@emph{Stack Size} is the maximum size for the stack. +`Stack Size' is the maximum size for the stack. @item -@emph{Stack Usage} is the measure done by the stack analyzer. +`Stack Usage' is the measure done by the stack analyzer. In order to prevent overflow, the stack is not entirely analyzed, and it’s not possible to know exactly how much has actually been used. @@ -22373,7 +22424,7 @@ For exception handling, either or both of two models are supplied: @itemize * @item -@strong{Zero-Cost Exceptions} (“ZCX”), +`Zero-Cost Exceptions' (“ZCX”), which uses binder-generated tables that are interrogated at run time to locate a handler. @@ -22382,7 +22433,7 @@ are interrogated at run time to locate a handler. @geindex SJLJ (setjmp/longjmp Exception Model) @item -@strong{setjmp / longjmp} (‘SJLJ’), +`setjmp / longjmp' (‘SJLJ’), which uses dynamically-set data to establish the set of handlers @end itemize @@ -22528,7 +22579,7 @@ contain a complete source and binary subdirectory. The detailed description below explains the differences between the different libraries in terms of their thread support. -The default run-time library (when GNAT is installed) is @emph{rts-native}. +The default run-time library (when GNAT is installed) is `rts-native'. This default run-time is selected by the means of soft links. For example on x86-linux: @@ -22572,7 +22623,7 @@ ADAINCLUDE ADALIB rts-native rts-sjlj (Upper-case names and dotted/dashed arrows represent soft links) @end example -If the @emph{rts-sjlj} library is to be selected on a permanent basis, +If the `rts-sjlj' library is to be selected on a permanent basis, these soft links can be modified with the following commands: @quotation @@ -23232,12 +23283,12 @@ on the stack by the caller from right to left. The callee (and not the caller) is in charge of cleaning the stack on routine exit. In addition, the name of a routine with @code{Stdcall} calling convention is mangled by adding a leading underscore (as for the @code{C} calling convention) and a -trailing @code{@@@emph{nn}}, where @code{nn} is the overall size (in +trailing @code{@@@var{nn}}, where @code{nn} is the overall size (in bytes) of the parameters passed to the routine. The name to use on the Ada side when importing a C routine with a @code{Stdcall} calling convention is the name of the C routine. The leading -underscore and trailing @code{@@@emph{nn}} are added automatically by +underscore and trailing @code{@@@var{nn}} are added automatically by the compiler. For instance the Win32 function: @quotation @@ -23284,10 +23335,10 @@ pragma Import (Stdcall, Get_Val, Link_Name => "retrieve_val"); then the imported routine is @code{retrieve_val}, that is, there is no decoration at all. No leading underscore and no Stdcall suffix -@code{@@@emph{nn}}. +@code{@@@var{nn}}. This is especially important as in some special cases a DLL’s entry -point name lacks a trailing @code{@@@emph{nn}} while the exported +point name lacks a trailing @code{@@@var{nn}} while the exported name generated for a call has it. It is also possible to import variables defined in a DLL by using an @@ -23588,16 +23639,16 @@ EXPORTS @table @asis -@item @emph{LIBRARY name} +@item `LIBRARY name' This section, which is optional, gives the name of the DLL. -@item @emph{DESCRIPTION string} +@item `DESCRIPTION string' This section, which is optional, gives a description string that will be embedded in the import library. -@item @emph{EXPORTS} +@item `EXPORTS' This section gives the list of exported symbols (procedures, functions or variables). For instance in the case of @code{API.dll} the @code{EXPORTS} @@ -23610,7 +23661,7 @@ EXPORTS @end example @end table -Note that you must specify the correct suffix (@code{@@@emph{nn}}) +Note that you must specify the correct suffix (@code{@@@var{nn}}) (see @ref{1d2,,Windows Calling Conventions}) for a Stdcall calling convention function in the exported symbols list. @@ -23631,11 +23682,11 @@ $ dlltool API.dll -z API.def --export-all-symbols @end example Note that if some routines in the DLL have the @code{Stdcall} convention -(@ref{1d2,,Windows Calling Conventions}) with stripped @code{@@@emph{nn}} +(@ref{1d2,,Windows Calling Conventions}) with stripped @code{@@@var{nn}} suffix then you’ll have to edit @code{api.def} to add it, and specify @code{-k} to @code{gnatdll} when creating the import library. -Here are some hints to find the right @code{@@@emph{nn}} suffix. +Here are some hints to find the right @code{@@@var{nn}} suffix. @itemize - @@ -23717,8 +23768,8 @@ See the Microsoft documentation for further details about the usage of @geindex building There is nothing specific to Windows in the build process. -See the @emph{Library Projects} section in the @emph{GNAT Project Manager} -chapter of the @emph{GPRbuild User’s Guide}. +See the `Library Projects' section in the `GNAT Project Manager' +chapter of the `GPRbuild User’s Guide'. Due to a system limitation, it is not possible under Windows to create threads when inside the @code{DllMain} routine which is used for auto-initialization @@ -23853,8 +23904,8 @@ Note that a relocatable DLL stripped using the @code{strip} binutils tool will not be relocatable anymore. To build a DLL without debug information pass @code{-largs -s} to @code{gnatdll}. This restriction does not apply to a DLL built using a Library Project. -See the @emph{Library Projects} section in the @emph{GNAT Project Manager} -chapter of the @emph{GPRbuild User’s Guide}. +See the `Library Projects' section in the `GNAT Project Manager' +chapter of the `GPRbuild User’s Guide'. @c Limitations_When_Using_Ada_DLLs_from Ada: @@ -24169,7 +24220,7 @@ You may specify any of the following switches to @code{gnatdll}: @table @asis -@item @code{-a[@emph{address}]} +@item @code{-a[`address']} Build a non-relocatable DLL at @code{address}. If @code{address} is not specified the default address @code{0x11000000} will be used. By default, @@ -24178,20 +24229,20 @@ advise the reader to build relocatable DLL. @geindex -b (gnatdll) -@item @code{-b @emph{address}} +@item @code{-b `address'} Set the relocatable DLL base address. By default the address is @code{0x11000000}. @geindex -bargs (gnatdll) -@item @code{-bargs @emph{opts}} +@item @code{-bargs `opts'} Binder options. Pass @code{opts} to the binder. @geindex -d (gnatdll) -@item @code{-d @emph{dllfile}} +@item @code{-d `dllfile'} @code{dllfile} is the name of the DLL. This switch must be present for @code{gnatdll} to do anything. The name of the generated import library is @@ -24205,7 +24256,7 @@ file used is @code{xyz.def}. @geindex -e (gnatdll) -@item @code{-e @emph{deffile}} +@item @code{-e `deffile'} @code{deffile} is the name of the definition file. @@ -24227,7 +24278,7 @@ Help mode. Displays @code{gnatdll} switch usage information. @geindex -I (gnatdll) -@item @code{-I@emph{dir}} +@item @code{-I`dir'} Direct @code{gnatdll} to search the @code{dir} directory for source and object files needed to build the DLL. @@ -24237,16 +24288,16 @@ object files needed to build the DLL. @item @code{-k} -Removes the @code{@@@emph{nn}} suffix from the import library’s exported +Removes the @code{@@@var{nn}} suffix from the import library’s exported names, but keeps them for the link names. You must specify this option if you want to use a @code{Stdcall} function in a DLL for which -the @code{@@@emph{nn}} suffix has been removed. This is the case for most +the @code{@@@var{nn}} suffix has been removed. This is the case for most of the Windows NT DLL for example. This option has no effect when @code{-n} option is specified. @geindex -l (gnatdll) -@item @code{-l @emph{file}} +@item @code{-l `file'} The list of ALI and object files used to build the DLL are listed in @code{file}, instead of being given in the command line. Each line in @@ -24272,7 +24323,7 @@ Verbose mode. Display extra information. @geindex -largs (gnatdll) -@item @code{-largs @emph{opts}} +@item @code{-largs `opts'} Linker options. Pass @code{opts} to the linker. @end table @@ -24406,7 +24457,7 @@ $ dlltool [`switches`] @table @asis -@item @code{--base-file @emph{basefile}} +@item @code{--base-file `basefile'} Read the base file @code{basefile} generated by the linker. This switch is used to create a relocatable DLL. @@ -24417,7 +24468,7 @@ is used to create a relocatable DLL. @table @asis -@item @code{--def @emph{deffile}} +@item @code{--def `deffile'} Read the definition file. @end table @@ -24427,7 +24478,7 @@ Read the definition file. @table @asis -@item @code{--dllname @emph{name}} +@item @code{--dllname `name'} Gives the name of the DLL. This switch is used to embed the name of the DLL in the static import library generated by @code{dlltool} with switch @@ -24441,7 +24492,7 @@ DLL in the static import library generated by @code{dlltool} with switch @item @code{-k} -Kill @code{@@@emph{nn}} from exported names +Kill @code{@@@var{nn}} from exported names (@ref{1d2,,Windows Calling Conventions} for a discussion about @code{Stdcall}-style symbols). @end table @@ -24461,7 +24512,7 @@ Prints the @code{dlltool} switches with a concise description. @table @asis -@item @code{--output-exp @emph{exportfile}} +@item @code{--output-exp `exportfile'} Generate an export file @code{exportfile}. The export file contains the export table (list of symbols in the DLL) and is used to create the DLL. @@ -24472,7 +24523,7 @@ export table (list of symbols in the DLL) and is used to create the DLL. @table @asis -@item @code{--output-lib @emph{libfile}} +@item @code{--output-lib `libfile'} Generate a static import library @code{libfile}. @end table @@ -24492,7 +24543,7 @@ Verbose mode. @table @asis -@item @code{--as @emph{assembler-name}} +@item @code{--as `assembler-name'} Use @code{assembler-name} as the assembler. The default is @code{as}. @end table @@ -24967,7 +25018,7 @@ $ main @end example @item -Use the Windows @emph{Task Manager} to find the process ID. Let’s say +Use the Windows `Task Manager' to find the process ID. Let’s say that the process PID for @code{main.exe} is 208. @item @@ -25019,7 +25070,7 @@ approach to debug a program as described in It is possible to specify the program stack size at link time. On modern versions of Windows, starting with XP, this is mostly useful to set the size of the main stack (environment task). The other task stacks are set with pragma -Storage_Size or with the @emph{gnatbind -d} command. +Storage_Size or with the `gnatbind -d' command. Since older versions of Windows (2000, NT4, etc.) do not allow setting the reserve size of individual tasks, the link-time stack size applies to all @@ -25268,7 +25319,7 @@ in the Unix group @code{_developer}. @geindex Binder output (example) This Appendix displays the source code for the output file -generated by @emph{gnatbind} for a simple ‘Hello World’ program. +generated by `gnatbind' for a simple ‘Hello World’ program. Comments have been added for clarification purposes. @example @@ -26047,13 +26098,13 @@ GNAT, either automatically or with explicit programming features. @section Elaboration Code -Ada defines the term @emph{execution} as the process by which a construct achieves -its run-time effect. This process is also referred to as @strong{elaboration} for -declarations and @emph{evaluation} for expressions. +Ada defines the term `execution' as the process by which a construct achieves +its run-time effect. This process is also referred to as `elaboration' for +declarations and `evaluation' for expressions. The execution model in Ada allows for certain sections of an Ada program to be executed prior to execution of the program itself, primarily with the intent of -initializing data. These sections are referred to as @strong{elaboration code}. +initializing data. These sections are referred to as `elaboration code'. Elaboration code is executed as follows: @@ -26070,7 +26121,7 @@ partition. @item The environment task executes all elaboration code (if available) for all units within that partition. This code is said to be executed at -@strong{elaboration time}. +`elaboration time'. @item The environment task executes the Ada program (if available) for that @@ -26083,16 +26134,16 @@ In addition to the Ada terminology, this appendix defines the following terms: @itemize * @item -@emph{Invocation} +`Invocation' The act of calling a subprogram, instantiating a generic, or activating a task. @item -@emph{Scenario} +`Scenario' A construct that is elaborated or invoked by elaboration code is referred to -as an @emph{elaboration scenario} or simply a @strong{scenario}. GNAT recognizes the +as an `elaboration scenario' or simply a `scenario'. GNAT recognizes the following scenarios: @@ -26112,10 +26163,10 @@ Instantiations of generic templates @end itemize @item -@emph{Target} +`Target' -A construct elaborated by a scenario is referred to as @emph{elaboration target} -or simply @strong{target}. GNAT recognizes the following targets: +A construct elaborated by a scenario is referred to as `elaboration target' +or simply `target'. GNAT recognizes the following targets: @itemize - @@ -26143,7 +26194,7 @@ Elaboration code may appear in two distinct contexts: @itemize * @item -@emph{Library level} +`Library level' A scenario appears at the library level when it is encapsulated by a package [body] compilation unit, ignoring any other package [body] declarations in @@ -26167,7 +26218,7 @@ given above. As a result, the call to @code{Server.Func} will be invoked when the spec of unit @code{Client} is elaborated. @item -@emph{Package body statements} +`Package body statements' A scenario appears within the statement sequence of a package body when it is bounded by the region starting from the @code{begin} keyword of the package body @@ -26196,7 +26247,7 @@ elaborated. The sequence by which the elaboration code of all units within a partition is -executed is referred to as @strong{elaboration order}. +executed is referred to as `elaboration order'. Within a single unit, elaboration code is executed in sequential order. @@ -26260,7 +26311,7 @@ factors: @itemize * @item -@emph{with}ed units +`with'ed units @item parent units @@ -26313,7 +26364,7 @@ procedure Main is begin null; end Main; @end quotation The following elaboration order exhibits a fundamental problem referred to as -@emph{access-before-elaboration} or simply @strong{ABE}. +`access-before-elaboration' or simply `ABE'. @quotation @@ -26353,7 +26404,7 @@ body of Main Ada states that a total elaboration order must exist, but it does not define what this order is. A compiler is thus tasked with choosing a suitable -elaboration order which satisfies the dependencies imposed by @emph{with} clauses, +elaboration order which satisfies the dependencies imposed by `with' clauses, unit categorization, elaboration-control pragmas, and invocations performed in elaboration code. Ideally an order that avoids ABE problems should be chosen, however a compiler may not always find such an order due to complications with @@ -26371,15 +26422,15 @@ provides three lines of defense: @itemize * @item -@emph{Static semantics} +`Static semantics' Static semantic rules restrict the possible choice of elaboration order. For -instance, if unit Client @emph{with}s unit Server, then the spec of Server is +instance, if unit Client `with's unit Server, then the spec of Server is always elaborated prior to Client. The same principle applies to child units - the spec of a parent unit is always elaborated prior to the child unit. @item -@emph{Dynamic semantics} +`Dynamic semantics' Dynamic checks are performed at run time, to ensure that a target is elaborated prior to a scenario that invokes it, thus avoiding ABE problems. @@ -26390,19 +26441,19 @@ restrictions apply: @itemize - @item -@emph{Restrictions on calls} +`Restrictions on calls' An entry, operator, or subprogram can be called from elaboration code only when the corresponding body has been elaborated. @item -@emph{Restrictions on instantiations} +`Restrictions on instantiations' A generic unit can be instantiated by elaboration code only when the corresponding body has been elaborated. @item -@emph{Restrictions on task activation} +`Restrictions on task activation' A task can be activated by elaboration code only when the body of the associated task type has been elaborated. @@ -26410,11 +26461,11 @@ associated task type has been elaborated. The restrictions above can be summarized by the following rule: -@emph{If a target has a body, then this body must be elaborated prior to the -scenario that invokes the target.} +`If a target has a body, then this body must be elaborated prior to the +scenario that invokes the target.' @item -@emph{Elaboration control} +`Elaboration control' Pragmas are provided for the programmer to specify the desired elaboration order. @@ -26432,7 +26483,7 @@ the desired elaboration order and avoiding ABE problems altogether. @itemize * @item -@emph{Packages without a body} +`Packages without a body' A library package which does not require a completing body does not suffer from ABE problems. @@ -26459,7 +26510,7 @@ any ABE problems. @itemize * @item -@emph{pragma Pure} +`pragma Pure' Pragma @code{Pure} places sufficient restrictions on a unit to guarantee that no scenario within the unit can result in an ABE problem. @@ -26471,7 +26522,7 @@ scenario within the unit can result in an ABE problem. @itemize * @item -@emph{pragma Preelaborate} +`pragma Preelaborate' Pragma @code{Preelaborate} is slightly less restrictive than pragma @code{Pure}, but still strong enough to prevent ABE problems within a unit. @@ -26483,7 +26534,7 @@ but still strong enough to prevent ABE problems within a unit. @itemize * @item -@emph{pragma Elaborate_Body} +`pragma Elaborate_Body' Pragma @code{Elaborate_Body} requires that the body of a unit is elaborated immediately after its spec. This restriction guarantees that no client @@ -26524,7 +26575,7 @@ spec of Client @end example because the spec of @code{Server} must be elaborated prior to @code{Client} by -virtue of the @emph{with} clause, and in addition the body of @code{Server} must be +virtue of the `with' clause, and in addition the body of @code{Server} must be elaborated immediately after the spec of @code{Server}. Removing pragma @code{Elaborate_Body} could result in the following incorrect @@ -26555,10 +26606,10 @@ depend on. @itemize * @item -@emph{pragma Elaborate (Unit)} +`pragma Elaborate (Unit)' Pragma @code{Elaborate} can be placed in the context clauses of a unit, after a -@emph{with} clause. It guarantees that both the spec and body of its argument will +`with' clause. It guarantees that both the spec and body of its argument will be elaborated prior to the unit with the pragma. Note that other unrelated units may be elaborated in between the spec and the body. @@ -26613,12 +26664,12 @@ has not been elaborated yet. @itemize * @item -@emph{pragma Elaborate_All (Unit)} +`pragma Elaborate_All (Unit)' Pragma @code{Elaborate_All} is placed in the context clauses of a unit, after -a @emph{with} clause. It guarantees that both the spec and body of its argument +a `with' clause. It guarantees that both the spec and body of its argument will be elaborated prior to the unit with the pragma, as well as all units -@emph{with}ed by the spec and body of the argument, recursively. Note that other +`with'ed by the spec and body of the argument, recursively. Note that other unrelated units may be elaborated in between the spec and the body. @example @@ -26704,10 +26755,10 @@ elaborated yet. All pragmas shown above can be summarized by the following rule: -@emph{If a client unit elaborates a server target directly or indirectly, then if +`If a client unit elaborates a server target directly or indirectly, then if the server unit requires a body and does not have pragma Pure, Preelaborate, or Elaborate_Body, then the client unit should have pragma Elaborate or -Elaborate_All for the server unit.} +Elaborate_All for the server unit.' If the rule outlined above is not followed, then a program may fall in one of the following states: @@ -26716,19 +26767,19 @@ the following states: @itemize * @item -@emph{No elaboration order exists} +`No elaboration order exists' In this case a compiler must diagnose the situation, and refuse to build an executable program. @item -@emph{One or more incorrect elaboration orders exist} +`One or more incorrect elaboration orders exist' In this case a compiler can build an executable program, but @code{Program_Error} will be raised when the program is run. @item -@emph{Several elaboration orders exist, some correct, some incorrect} +`Several elaboration orders exist, some correct, some incorrect' In this case the programmer has not controlled the elaboration order. As a result, a compiler may or may not pick one of the correct orders, and the @@ -26737,7 +26788,7 @@ worst possible state because the program may fail on another compiler, or even another version of the same compiler. @item -@emph{One or more correct orders exist} +`One or more correct orders exist' In this case a compiler can build an executable program, and the program is run successfully. This state may be guaranteed by following the outlined @@ -26763,7 +26814,7 @@ elaboration order and to diagnose elaboration problems. @itemize * @item -@emph{Dynamic elaboration model} +`Dynamic elaboration model' This is the most permissive of the three elaboration models and emulates the behavior specified by the Ada Reference Manual. When the dynamic model is in @@ -26785,7 +26836,7 @@ GNAT performs extensive diagnostics on a unit-by-unit basis for all scenarios that invoke internal targets. In addition, GNAT generates run-time checks for all external targets and for all scenarios that may exhibit ABE problems. -The elaboration order is obtained by honoring all @emph{with} clauses, purity and +The elaboration order is obtained by honoring all `with' clauses, purity and preelaborability of units, and elaboration-control pragmas. The dynamic model attempts to take all invocations in elaboration code into account. If an invocation leads to a circularity, GNAT ignores the invocation based on the @@ -26801,7 +26852,7 @@ The dynamic model is enabled with compiler switch @code{-gnatE}. @itemize * @item -@emph{Static elaboration model} +`Static elaboration model' This is the middle ground of the three models. When the static model is in effect, GNAT makes the following assumptions: @@ -26822,7 +26873,7 @@ GNAT performs extensive diagnostics on a unit-by-unit basis for all scenarios that invoke internal targets. In addition, GNAT generates run-time checks for all external targets and for all scenarios that may exhibit ABE problems. -The elaboration order is obtained by honoring all @emph{with} clauses, purity and +The elaboration order is obtained by honoring all `with' clauses, purity and preelaborability of units, presence of elaboration-control pragmas, and all invocations in elaboration code. An order obtained using the static model is guaranteed to be ABE problem-free, excluding dispatching calls and @@ -26837,7 +26888,7 @@ The static model is the default model in GNAT. @itemize * @item -@emph{SPARK elaboration model} +`SPARK elaboration model' This is the most conservative of the three models and enforces the SPARK rules of elaboration as defined in the SPARK Reference Manual, section 7.7. @@ -26854,7 +26905,7 @@ The SPARK model is enabled with compiler switch @code{-gnatd.v}. @itemize * @item -@emph{Legacy elaboration models} +`Legacy elaboration models' In addition to the three elaboration models outlined above, GNAT provides the following legacy models: @@ -26890,7 +26941,7 @@ however the following rules must be observed: @itemize * @item -A client unit compiled with the dynamic model can only @emph{with} a server unit +A client unit compiled with the dynamic model can only `with' a server unit that meets at least one of the following criteria: @@ -26940,8 +26991,8 @@ conservative, or a particular scenario may not be invoked due conditional execution. The warnings can be suppressed selectively with @code{pragma Warnings (Off)} or globally with compiler switch @code{-gnatwL}. -A @emph{guaranteed ABE} arises when the body of a target is not elaborated early -enough, and causes @emph{all} scenarios that directly invoke the target to fail. +A `guaranteed ABE' arises when the body of a target is not elaborated early +enough, and causes `all' scenarios that directly invoke the target to fail. @quotation @@ -26973,8 +27024,8 @@ the declaration of @code{Val}. This invokes function @code{ABE}, however the bod @end example @end quotation -A @emph{conditional ABE} arises when the body of a target is not elaborated early -enough, and causes @emph{some} scenarios that directly invoke the target to fail. +A `conditional ABE' arises when the body of a target is not elaborated early +enough, and causes `some' scenarios that directly invoke the target to fail. @quotation @@ -27063,9 +27114,9 @@ rules. @section Elaboration Circularities -An @strong{elaboration circularity} occurs whenever the elaboration of a set of +An `elaboration circularity' occurs whenever the elaboration of a set of units enters a deadlocked state, where each unit is waiting for another unit -to be elaborated. This situation may be the result of improper use of @emph{with} +to be elaborated. This situation may be the result of improper use of `with' clauses, elaboration-control pragmas, or invocations in elaboration code. The following example exhibits an elaboration circularity. @@ -27173,7 +27224,7 @@ too much modification, especially in the case of complex legacy code. When faced with an elaboration circularity, the programmer should also consider the tactics given in the suggestions section of the circularity diagnostic. -Depending on the units involved in the circularity, their @emph{with} clauses, +Depending on the units involved in the circularity, their `with' clauses, purity, preelaborability, presence of elaboration-control pragmas and invocations at elaboration time, the binder may suggest one or more of the following tactics to eliminate the circularity: @@ -27226,7 +27277,7 @@ Prevents a set of units from being elaborated. @item The removal of the pragma will not eliminate the semantic effects of the -pragma. In other words, the argument of the pragma along with its @emph{with} +pragma. In other words, the argument of the pragma along with its `with' closure will still be elaborated prior to the unit containing the pragma. @item @@ -27469,20 +27520,20 @@ information depending on the elaboration model in effect. @itemize - @item -@emph{Dynamic model} +`Dynamic model' GNAT will indicate missing @code{Elaborate} and @code{Elaborate_All} pragmas for all library-level scenarios within the partition. @item -@emph{Static model} +`Static model' GNAT will indicate all scenarios invoked during elaboration. In addition, it will provide detailed traceback when an implicit @code{Elaborate} or @code{Elaborate_All} pragma is generated. @item -@emph{SPARK model} +`SPARK model' GNAT will indicate how an elaboration requirement is met by the context of a unit. This diagnostic requires compiler switch @code{-gnatd.v}. @@ -27885,7 +27936,7 @@ pre-processor) documentation for further information. @display -@emph{Register names}@w{ } +`Register names'@w{ } @display gcc / @code{as}: Prefix with ‘%’; for example @code{%eax}@w{ } Intel: No extra punctuation; for example @code{eax}@w{ } @@ -27896,7 +27947,7 @@ Intel: No extra punctuation; for example @code{eax}@w{ } @display -@emph{Immediate operand}@w{ } +`Immediate operand'@w{ } @display gcc / @code{as}: Prefix with ‘$’; for example @code{$4}@w{ } Intel: No extra punctuation; for example @code{4}@w{ } @@ -27907,7 +27958,7 @@ Intel: No extra punctuation; for example @code{4}@w{ } @display -@emph{Address}@w{ } +`Address'@w{ } @display gcc / @code{as}: Prefix with ‘$’; for example @code{$loc}@w{ } Intel: No extra punctuation; for example @code{loc}@w{ } @@ -27918,7 +27969,7 @@ Intel: No extra punctuation; for example @code{loc}@w{ } @display -@emph{Memory contents}@w{ } +`Memory contents'@w{ } @display gcc / @code{as}: No extra punctuation; for example @code{loc}@w{ } Intel: Square brackets; for example @code{[loc]}@w{ } @@ -27929,7 +27980,7 @@ Intel: Square brackets; for example @code{[loc]}@w{ } @display -@emph{Register contents}@w{ } +`Register contents'@w{ } @display gcc / @code{as}: Parentheses; for example @code{(%eax)}@w{ } Intel: Square brackets; for example @code{[eax]}@w{ } @@ -27940,7 +27991,7 @@ Intel: Square brackets; for example @code{[eax]}@w{ } @display -@emph{Hexadecimal numbers}@w{ } +`Hexadecimal numbers'@w{ } @display gcc / @code{as}: Leading ‘0x’ (C language syntax); for example @code{0xA0}@w{ } Intel: Trailing ‘h’; for example @code{A0h}@w{ } @@ -27951,7 +28002,7 @@ Intel: Trailing ‘h’; for example @code{A0h}@w{ } @display -@emph{Operand size}@w{ } +`Operand size'@w{ } @display gcc / @code{as}: Explicit in op code; for example @code{movw} to move a 16-bit word@w{ } Intel: Implicit, deduced by assembler; for example @code{mov}@w{ } @@ -27962,7 +28013,7 @@ Intel: Implicit, deduced by assembler; for example @code{mov}@w{ } @display -@emph{Instruction repetition}@w{ } +`Instruction repetition'@w{ } @display gcc / @code{as}: Split into two lines; for example@w{ } @display @@ -27977,7 +28028,7 @@ Intel: Keep on one line; for example @code{rep stosl}@w{ } @display -@emph{Order of operands}@w{ } +`Order of operands'@w{ } @display gcc / @code{as}: Source first; for example @code{movw $4, %eax}@w{ } Intel: Destination first; for example @code{mov eax, 4}@w{ } @@ -28008,7 +28059,7 @@ end Nothing; @end quotation @code{Asm} is a procedure declared in package @code{System.Machine_Code}; -here it takes one parameter, a @emph{template string} that must be a static +here it takes one parameter, a `template string' that must be a static expression and that will form the generated instruction. @code{Asm} may be regarded as a compile-time procedure that parses the template string and additional parameters (none here), @@ -28291,7 +28342,7 @@ most useful (for the Intel x86 processor) are the following: @multitable {xxxxxxxx} {xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx} @item -@emph{=} +`=' @tab @@ -28299,7 +28350,7 @@ output constraint @item -@emph{g} +`g' @tab @@ -28307,7 +28358,7 @@ global (i.e., can be stored anywhere) @item -@emph{m} +`m' @tab @@ -28315,7 +28366,7 @@ in memory @item -@emph{I} +`I' @tab @@ -28323,7 +28374,7 @@ a constant @item -@emph{a} +`a' @tab @@ -28331,7 +28382,7 @@ use eax @item -@emph{b} +`b' @tab @@ -28339,7 +28390,7 @@ use ebx @item -@emph{c} +`c' @tab @@ -28347,7 +28398,7 @@ use ecx @item -@emph{d} +`d' @tab @@ -28355,7 +28406,7 @@ use edx @item -@emph{S} +`S' @tab @@ -28363,7 +28414,7 @@ use esi @item -@emph{D} +`D' @tab @@ -28371,7 +28422,7 @@ use edi @item -@emph{r} +`r' @tab @@ -28379,7 +28430,7 @@ use one of eax, ebx, ecx or edx @item -@emph{q} +`q' @tab @@ -28394,7 +28445,7 @@ documentation; note that it is possible to combine certain constraints in one constraint string. You specify the association of an output variable with an assembler operand -through the @code{%@emph{n}} notation, where @emph{n} is a non-negative +through the @code{%@var{n}} notation, where `n' is a non-negative integer. Thus in @quotation @@ -28725,7 +28776,7 @@ Asm ("movl %0, %%ebx" & LF & HT & @end quotation The Clobber parameter is a static string expression specifying the -register(s) you are using. Note that register names are @emph{not} prefixed +register(s) you are using. Note that register names are `not' prefixed by a percent sign. Also, if more than one register is used then their names are separated by commas; e.g., @code{"eax, ebx"} @@ -28790,7 +28841,7 @@ Copyright 2000, 2001, 2002, 2007, 2008 Free Software Foundation, Inc Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. -@strong{Preamble} +`Preamble' The purpose of this License is to make a manual, textbook, or other functional and useful document “free” in the sense of freedom: to @@ -28813,23 +28864,23 @@ it can be used for any textual work, regardless of subject matter or whether it is published as a printed book. We recommend this License principally for works whose purpose is instruction or reference. -@strong{1. APPLICABILITY AND DEFINITIONS} +`1. APPLICABILITY AND DEFINITIONS' This License applies to any manual or other work, in any medium, that contains a notice placed by the copyright holder saying it can be distributed under the terms of this License. Such a notice grants a world-wide, royalty-free license, unlimited in duration, to use that -work under the conditions stated herein. The @strong{Document}, below, +work under the conditions stated herein. The `Document', below, refers to any such manual or work. Any member of the public is a -licensee, and is addressed as “@strong{you}”. You accept the license if you +licensee, and is addressed as “`you'”. You accept the license if you copy, modify or distribute the work in a way requiring permission under copyright law. -A “@strong{Modified Version}” of the Document means any work containing the +A “`Modified Version'” of the Document means any work containing the Document or a portion of it, either copied verbatim, or with modifications and/or translated into another language. -A “@strong{Secondary Section}” is a named appendix or a front-matter section of +A “`Secondary Section'” is a named appendix or a front-matter section of the Document that deals exclusively with the relationship of the publishers or authors of the Document to the Document’s overall subject (or to related matters) and contains nothing that could fall directly @@ -28840,7 +28891,7 @@ connection with the subject or with related matters, or of legal, commercial, philosophical, ethical or political position regarding them. -The “@strong{Invariant Sections}” are certain Secondary Sections whose titles +The “`Invariant Sections'” are certain Secondary Sections whose titles are designated, as being those of Invariant Sections, in the notice that says that the Document is released under this License. If a section does not fit the above definition of Secondary then it is not @@ -28848,12 +28899,12 @@ allowed to be designated as Invariant. The Document may contain zero Invariant Sections. If the Document does not identify any Invariant Sections then there are none. -The “@strong{Cover Texts}” are certain short passages of text that are listed, +The “`Cover Texts'” are certain short passages of text that are listed, as Front-Cover Texts or Back-Cover Texts, in the notice that says that the Document is released under this License. A Front-Cover Text may be at most 5 words, and a Back-Cover Text may be at most 25 words. -A “@strong{Transparent}” copy of the Document means a machine-readable copy, +A “`Transparent'” copy of the Document means a machine-readable copy, represented in a format whose specification is available to the general public, that is suitable for revising the document straightforwardly with generic text editors or (for images composed of @@ -28864,7 +28915,7 @@ to text formatters. A copy made in an otherwise Transparent file format whose markup, or absence of markup, has been arranged to thwart or discourage subsequent modification by readers is not Transparent. An image format is not Transparent if used for any substantial amount -of text. A copy that is not “Transparent” is called @strong{Opaque}. +of text. A copy that is not “Transparent” is called `Opaque'. Examples of suitable formats for Transparent copies include plain ASCII without markup, Texinfo input format, LaTeX input format, SGML @@ -28877,22 +28928,22 @@ processing tools are not generally available, and the machine-generated HTML, PostScript or PDF produced by some word processors for output purposes only. -The “@strong{Title Page}” means, for a printed book, the title page itself, +The “`Title Page'” means, for a printed book, the title page itself, plus such following pages as are needed to hold, legibly, the material this License requires to appear in the title page. For works in formats which do not have any title page as such, “Title Page” means the text near the most prominent appearance of the work’s title, preceding the beginning of the body of the text. -The “@strong{publisher}” means any person or entity that distributes +The “`publisher'” means any person or entity that distributes copies of the Document to the public. -A section “@strong{Entitled XYZ}” means a named subunit of the Document whose +A section “`Entitled XYZ'” means a named subunit of the Document whose title either is precisely XYZ or contains XYZ in parentheses following text that translates XYZ in another language. (Here XYZ stands for a -specific section name mentioned below, such as “@strong{Acknowledgements}”, -“@strong{Dedications}”, “@strong{Endorsements}”, or “@strong{History}”.) -To “@strong{Preserve the Title}” +specific section name mentioned below, such as “`Acknowledgements'”, +“`Dedications'”, “`Endorsements'”, or “`History'”.) +To “`Preserve the Title'” of such a section when you modify the Document means that it remains a section “Entitled XYZ” according to this definition. @@ -28903,7 +28954,7 @@ License, but only as regards disclaiming warranties: any other implication that these Warranty Disclaimers may have is void and has no effect on the meaning of this License. -@strong{2. VERBATIM COPYING} +`2. VERBATIM COPYING' You may copy and distribute the Document in any medium, either commercially or noncommercially, provided that this License, the @@ -28918,7 +28969,7 @@ number of copies you must also follow the conditions in section 3. You may also lend copies, under the same conditions stated above, and you may publicly display copies. -@strong{3. COPYING IN QUANTITY} +`3. COPYING IN QUANTITY' If you publish printed copies (or copies in media that commonly have printed covers) of the Document, numbering more than 100, and the @@ -28955,7 +29006,7 @@ It is requested, but not required, that you contact the authors of the Document well before redistributing any large number of copies, to give them a chance to provide you with an updated version of the Document. -@strong{4. MODIFICATIONS} +`4. MODIFICATIONS' You may copy and distribute a Modified Version of the Document under the conditions of sections 2 and 3 above, provided that you release @@ -29072,7 +29123,7 @@ The author(s) and publisher(s) of the Document do not by this License give permission to use their names for publicity for or to assert or imply endorsement of any Modified Version. -@strong{5. COMBINING DOCUMENTS} +`5. COMBINING DOCUMENTS' You may combine the Document with other documents released under this License, under the terms defined in section 4 above for modified @@ -29096,7 +29147,7 @@ in the various original documents, forming one section Entitled and any sections Entitled “Dedications”. You must delete all sections Entitled “Endorsements”. -@strong{6. COLLECTIONS OF DOCUMENTS} +`6. COLLECTIONS OF DOCUMENTS' You may make a collection consisting of the Document and other documents released under this License, and replace the individual copies of this @@ -29109,7 +29160,7 @@ it individually under this License, provided you insert a copy of this License into the extracted document, and follow this License in all other respects regarding verbatim copying of that document. -@strong{7. AGGREGATION WITH INDEPENDENT WORKS} +`7. AGGREGATION WITH INDEPENDENT WORKS' A compilation of the Document or its derivatives with other separate and independent documents or works, in or on a volume of a storage or @@ -29128,7 +29179,7 @@ electronic equivalent of covers if the Document is in electronic form. Otherwise they must appear on printed covers that bracket the whole aggregate. -@strong{8. TRANSLATION} +`8. TRANSLATION' Translation is considered a kind of modification, so you may distribute translations of the Document under the terms of section 4. @@ -29148,7 +29199,7 @@ If a section in the Document is Entitled “Acknowledgements”, its Title (section 1) will typically require changing the actual title. -@strong{9. TERMINATION} +`9. TERMINATION' You may not copy, modify, sublicense, or distribute the Document except as expressly provided under this License. Any attempt @@ -29175,7 +29226,7 @@ this License. If your rights have been terminated and not permanently reinstated, receipt of a copy of some or all of the same material does not give you any rights to use it. -@strong{10. FUTURE REVISIONS OF THIS LICENSE} +`10. FUTURE REVISIONS OF THIS LICENSE' The Free Software Foundation may publish new, revised versions of the GNU Free Documentation License from time to time. Such new @@ -29196,7 +29247,7 @@ License can be used, that proxy’s public statement of acceptance of a version permanently authorizes you to choose that version for the Document. -@strong{11. RELICENSING} +`11. RELICENSING' “Massive Multiauthor Collaboration Site” (or “MMC Site”) means any World Wide Web server that publishes copyrightable works and also @@ -29225,7 +29276,7 @@ The operator of an MMC Site may republish an MMC contained in the site under CC-BY-SA on the same site at any time before August 1, 2009, provided the MMC is eligible for relicensing. -@strong{ADDENDUM: How to use this License for your documents} +`ADDENDUM: How to use this License for your documents' To use this License in a document you have written, include a copy of the License in the document and put the following copyright and @@ -29266,8 +29317,8 @@ to permit their use in free software. @printindex ge -@anchor{cf}@w{ } @anchor{gnat_ugn/gnat_utility_programs switches-related-to-project-files}@w{ } +@anchor{cf}@w{ } @c %**end of body @bye diff --git a/gcc/ada/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/layout.adb b/gcc/ada/layout.adb index b6cdee0..e4187dd 100644 --- a/gcc/ada/layout.adb +++ b/gcc/ada/layout.adb @@ -1053,8 +1053,6 @@ package body Layout is -- derived types. declare - FST : constant Entity_Id := First_Subtype (E); - function Has_Attribute_Clause (E : Entity_Id; Id : Attribute_Id) return Boolean; @@ -1072,7 +1070,17 @@ package body Layout is return Present (Get_Attribute_Definition_Clause (E, Id)); end Has_Attribute_Clause; + FST : Entity_Id; + begin + FST := First_Subtype (E); + + -- Deal with private types + + if Is_Private_Type (FST) then + FST := Full_View (FST); + end if; + -- If the alignment comes from a clause, then we respect it. -- Consider for example: 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-coinve.adb b/gcc/ada/libgnat/a-coinve.adb index c84175a..46d6730 100644 --- a/gcc/ada/libgnat/a-coinve.adb +++ b/gcc/ada/libgnat/a-coinve.adb @@ -197,12 +197,29 @@ is Count : Count_Type) is begin - -- In the general case, we pass the buck to Insert, but for efficiency, - -- we check for the usual case where Count = 1 and the vector has enough - -- room for at least one more element. + -- In the general case, we take the slow path; for efficiency, + -- we check for the common case where Count = 1 . - if Count = 1 - and then Container.Elements /= null + if Count = 1 then + Append (Container, New_Item); + else + Append_Slow_Path (Container, New_Item, Count); + end if; + end Append; + + ------------ + -- Append -- + ------------ + + procedure Append (Container : in out Vector; + New_Item : Element_Type) + is + begin + -- For performance, check for the common special case where the + -- container already has room for at least one more element. + -- In the general case, pass the buck to Insert. + + if Container.Elements /= null and then Container.Last /= Container.Elements.Last then TC_Check (Container.TC); @@ -223,23 +240,11 @@ is Container.Elements.EA (New_Last) := new Element_Type'(New_Item); Container.Last := New_Last; end; - else - Append_Slow_Path (Container, New_Item, Count); + Insert (Container, Last_Index (Container) + 1, New_Item, 1); end if; end Append; - ------------ - -- Append -- - ------------ - - procedure Append (Container : in out Vector; - New_Item : Element_Type) - is - begin - Insert (Container, Last_Index (Container) + 1, New_Item, 1); - end Append; - ---------------------- -- Append_Slow_Path -- ---------------------- diff --git a/gcc/ada/libgnat/a-convec.adb b/gcc/ada/libgnat/a-convec.adb index 3a2adae..751d468 100644 --- a/gcc/ada/libgnat/a-convec.adb +++ b/gcc/ada/libgnat/a-convec.adb @@ -173,27 +173,11 @@ is Count : Count_Type) is begin - -- In the general case, we pass the buck to Insert, but for efficiency, - -- we check for the usual case where Count = 1 and the vector has enough - -- room for at least one more element. - - if Count = 1 - and then Container.Elements /= null - and then Container.Last /= Container.Elements.Last - then - TC_Check (Container.TC); - - -- Increment Container.Last after assigning the New_Item, so we - -- leave the Container unmodified in case Finalize/Adjust raises - -- an exception. - - declare - New_Last : constant Index_Type := Container.Last + 1; - begin - Container.Elements.EA (New_Last) := New_Item; - Container.Last := New_Last; - end; + -- In the general case, we take the slow path; for efficiency, + -- we check for the common case where Count = 1 . + if Count = 1 then + Append (Container, New_Item); else Append_Slow_Path (Container, New_Item, Count); end if; @@ -222,7 +206,28 @@ is New_Item : Element_Type) is begin - Insert (Container, Last_Index (Container) + 1, New_Item, 1); + -- For performance, check for the common special case where the + -- container already has room for at least one more element. + -- In the general case, pass the buck to Insert. + + if Container.Elements /= null + and then Container.Last /= Container.Elements.Last + then + TC_Check (Container.TC); + + -- Increment Container.Last after assigning the New_Item, so we + -- leave the Container unmodified in case Finalize/Adjust raises + -- an exception. + + declare + New_Last : constant Index_Type := Container.Last + 1; + begin + Container.Elements.EA (New_Last) := New_Item; + Container.Last := New_Last; + end; + else + Insert (Container, Last_Index (Container) + 1, New_Item, 1); + end if; end Append; ---------------------- 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-nbnbig.ads b/gcc/ada/libgnat/a-nbnbig.ads index f574e78..3979f14 100644 --- a/gcc/ada/libgnat/a-nbnbig.ads +++ b/gcc/ada/libgnat/a-nbnbig.ads @@ -32,6 +32,8 @@ package Ada.Numerics.Big_Numbers.Big_Integers_Ghost with Ghost, Pure is + pragma Annotate (GNATprove, Always_Return, Big_Integers_Ghost); + type Big_Integer is private with Integer_Literal => From_Universal_Image; diff --git a/gcc/ada/libgnat/a-strmap.adb b/gcc/ada/libgnat/a-strmap.adb index 77780f9..e092db0 100644 --- a/gcc/ada/libgnat/a-strmap.adb +++ b/gcc/ada/libgnat/a-strmap.adb @@ -290,6 +290,7 @@ is loop pragma Loop_Invariant (Seq1 (Seq1'First .. J) = Seq2 (Seq2'First .. J)); + pragma Loop_Variant (Increases => J); if J = Positive'Last then return; @@ -440,6 +441,7 @@ is (Character'Pos (C) >= Character'Pos (C'Loop_Entry)); pragma Loop_Invariant (for all Char in C'Loop_Entry .. C => not Set (Char)); + pragma Loop_Variant (Increases => C); exit when C = Character'Last; C := Character'Succ (C); end loop; @@ -457,6 +459,7 @@ is pragma Loop_Invariant (for all Char in C'Loop_Entry .. C => (if Char /= C then Set (Char))); + pragma Loop_Variant (Increases => C); exit when not Set (C) or else C = Character'Last; C := Character'Succ (C); end loop; @@ -491,6 +494,7 @@ is pragma Loop_Invariant (for all Span of Max_Ranges (1 .. Range_Num) => (for all Char in Span.Low .. Span.High => Set (Char))); + pragma Loop_Variant (Increases => Range_Num); end loop; return Max_Ranges (1 .. Range_Num); diff --git a/gcc/ada/libgnat/a-strsea.adb b/gcc/ada/libgnat/a-strsea.adb index 71a415f..652c797 100644 --- a/gcc/ada/libgnat/a-strsea.adb +++ b/gcc/ada/libgnat/a-strsea.adb @@ -113,6 +113,7 @@ package body Ada.Strings.Search with SPARK_Mode is pragma Loop_Invariant (Num <= Ind - (Source'First - 1)); pragma Loop_Invariant (Ind >= Source'First); + pragma Loop_Variant (Increases => Ind); end loop; -- Mapped case @@ -142,6 +143,7 @@ package body Ada.Strings.Search with SPARK_Mode is null; pragma Loop_Invariant (Num <= Ind - (Source'First - 1)); pragma Loop_Invariant (Ind >= Source'First); + pragma Loop_Variant (Increases => Ind); end loop; end if; @@ -200,6 +202,7 @@ package body Ada.Strings.Search with SPARK_Mode is null; pragma Loop_Invariant (Num <= Ind - (Source'First - 1)); pragma Loop_Invariant (Ind >= Source'First); + pragma Loop_Variant (Increases => Ind); end loop; return Num; 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-aridou.adb b/gcc/ada/libgnat/s-aridou.adb index b40e4c3..52f2360 100644 --- a/gcc/ada/libgnat/s-aridou.adb +++ b/gcc/ada/libgnat/s-aridou.adb @@ -126,7 +126,7 @@ is Pre => B /= 0; -- Length doubling remainder - function Big_2xx (N : Natural) return Big_Integer is + function Big_2xx (N : Natural) return Big_Positive is (Big (Double_Uns'(2 ** N))) with Ghost, @@ -141,6 +141,13 @@ is with Ghost; -- X1&X2&X3 as a big integer + function Big3 (X1, X2, X3 : Big_Integer) return Big_Integer is + (Big_2xxSingle * Big_2xxSingle * X1 + + Big_2xxSingle * X2 + + X3) + with Ghost; + -- Version of Big3 on big integers + function Le3 (X1, X2, X3, Y1, Y2, Y3 : Single_Uns) return Boolean with Post => Le3'Result = (Big3 (X1, X2, X3) <= Big3 (Y1, Y2, Y3)); @@ -234,6 +241,17 @@ is Pre => X /= Double_Uns'Last, Post => Big (X + Double_Uns'(1)) = Big (X) + 1; + procedure Lemma_Big_Of_Double_Uns (X : Double_Uns) + with + Ghost, + Post => Big (X) < Big_2xxDouble; + + procedure Lemma_Big_Of_Double_Uns_Of_Single_Uns (X : Single_Uns) + with + Ghost, + Post => Big (Double_Uns (X)) >= 0 + and then Big (Double_Uns (X)) < Big_2xxSingle; + procedure Lemma_Bounded_Powers_Of_2_Increasing (M, N : Natural) with Ghost, @@ -447,9 +465,9 @@ is procedure Lemma_Mult_Non_Negative (X, Y : Big_Integer) with Ghost, - Pre => (X >= Big_0 and then Y >= Big_0) - or else (X <= Big_0 and then Y <= Big_0), - Post => X * Y >= Big_0; + Pre => (X >= 0 and then Y >= 0) + or else (X <= 0 and then Y <= 0), + Post => X * Y >= 0; procedure Lemma_Mult_Non_Positive (X, Y : Big_Integer) with @@ -458,6 +476,13 @@ is or else (X >= Big_0 and then Y <= Big_0), Post => X * Y <= Big_0; + procedure Lemma_Mult_Positive (X, Y : Big_Integer) + with + Ghost, + Pre => (X > Big_0 and then Y > Big_0) + or else (X < Big_0 and then Y < Big_0), + Post => X * Y > Big_0; + procedure Lemma_Neg_Div (X, Y : Big_Integer) with Ghost, @@ -604,6 +629,8 @@ is procedure Lemma_Abs_Range (X : Big_Integer) is null; procedure Lemma_Add_Commutation (X : Double_Uns; Y : Single_Uns) is null; procedure Lemma_Add_One (X : Double_Uns) is null; + procedure Lemma_Big_Of_Double_Uns (X : Double_Uns) is null; + procedure Lemma_Big_Of_Double_Uns_Of_Single_Uns (X : Single_Uns) is null; procedure Lemma_Bounded_Powers_Of_2_Increasing (M, N : Natural) is null; procedure Lemma_Deep_Mult_Commutation (Factor : Big_Integer; @@ -638,6 +665,7 @@ is procedure Lemma_Mult_Distribution (X, Y, Z : Big_Integer) is null; procedure Lemma_Mult_Non_Negative (X, Y : Big_Integer) is null; procedure Lemma_Mult_Non_Positive (X, Y : Big_Integer) is null; + procedure Lemma_Mult_Positive (X, Y : Big_Integer) is null; procedure Lemma_Neg_Rem (X, Y : Big_Integer) is null; procedure Lemma_Not_In_Range_Big2xx64 is null; procedure Lemma_Powers (A : Big_Natural; B, C : Natural) is null; @@ -1888,7 +1916,7 @@ is -- Local ghost variables - Mult : constant Big_Integer := abs (Big (X) * Big (Y)) with Ghost; + Mult : constant Big_Natural := abs (Big (X) * Big (Y)) with Ghost; Quot : Big_Integer with Ghost; Big_R : Big_Integer with Ghost; Big_Q : Big_Integer with Ghost; @@ -1955,6 +1983,15 @@ is -- Proves correctness of the multiplication of divisor by quotient to -- compute amount to subtract. + procedure Prove_Mult_Decomposition_Split3 + (D1, D2, D3, D3_Hi, D3_Lo, D4 : Big_Integer) + with + Ghost, + Pre => Is_Mult_Decomposition (D1, D2, D3, D4) + and then D3 = Big_2xxSingle * D3_Hi + D3_Lo, + Post => Is_Mult_Decomposition (D1, D2 + D3_Hi, D3_Lo, D4); + -- Proves decomposition of Mult after splitting third component + procedure Prove_Negative_Dividend with Ghost, @@ -2066,6 +2103,27 @@ is else abs Quot); -- Proves correctness of the rounding of the unsigned quotient + procedure Prove_Scaled_Mult_Decomposition_Regroup24 + (D1, D2, D3, D4 : Big_Integer) + with + Ghost, + Pre => Scale < Double_Size + and then Is_Scaled_Mult_Decomposition (D1, D2, D3, D4), + Post => Is_Scaled_Mult_Decomposition + (0, Big_2xxSingle * D1 + D2, 0, Big_2xxSingle * D3 + D4); + -- Proves scaled decomposition of Mult after regrouping on second and + -- fourth component. + + procedure Prove_Scaled_Mult_Decomposition_Regroup3 + (D1, D2, D3, D4 : Big_Integer) + with + Ghost, + Pre => Scale < Double_Size + and then Is_Scaled_Mult_Decomposition (D1, D2, D3, D4), + Post => Is_Scaled_Mult_Decomposition (0, 0, Big3 (D1, D2, D3), D4); + -- Proves scaled decomposition of Mult after regrouping on third + -- component. + procedure Prove_Sign_R with Ghost, @@ -2315,6 +2373,14 @@ is + Big (Double_Uns (S3)))); end Prove_Multiplication; + ------------------------------------- + -- Prove_Mult_Decomposition_Split3 -- + ------------------------------------- + + procedure Prove_Mult_Decomposition_Split3 + (D1, D2, D3, D3_Hi, D3_Lo, D4 : Big_Integer) + is null; + ----------------------------- -- Prove_Negative_Dividend -- ----------------------------- @@ -2413,6 +2479,22 @@ is end if; end Prove_Rounding_Case; + ----------------------------------------------- + -- Prove_Scaled_Mult_Decomposition_Regroup24 -- + ----------------------------------------------- + + procedure Prove_Scaled_Mult_Decomposition_Regroup24 + (D1, D2, D3, D4 : Big_Integer) + is null; + + ---------------------------------------------- + -- Prove_Scaled_Mult_Decomposition_Regroup3 -- + ---------------------------------------------- + + procedure Prove_Scaled_Mult_Decomposition_Regroup3 + (D1, D2, D3, D4 : Big_Integer) + is null; + ------------------ -- Prove_Sign_R -- ------------------ @@ -2585,29 +2667,15 @@ is T2 := D (3) + Lo (T1); Lemma_Add_Commutation (Double_Uns (D (3)), Lo (T1)); - pragma Assert - (Is_Mult_Decomposition - (D1 => 0, - D2 => Big (Double_Uns'(Xhi * Yhi)) + Big (Double_Uns (D (2))) - + Big (Double_Uns (Hi (T1))), - D3 => Big (T2), - D4 => Big (Double_Uns (D (4))))); Lemma_Hi_Lo (T2, Hi (T2), Lo (T2)); - pragma Assert - (By (Is_Mult_Decomposition - (D1 => 0, - D2 => Big (Double_Uns'(Xhi * Yhi)) + Big (Double_Uns (D (2))) - + Big (Double_Uns (Hi (T1))) + Big (Double_Uns (Hi (T2))), - D3 => Big (Double_Uns (Lo (T2))), - D4 => Big (Double_Uns (D (4)))), - By (Big_2xxSingle * Big (T2) = - Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (Hi (T2))) - + Big_2xxSingle * Big (Double_Uns (Lo (T2))), - Big_2xxSingle * - (Big_2xxSingle * Big (Double_Uns (Hi (T2))) - + Big (Double_Uns (Lo (T2)))) - = Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (Hi (T2))) - + Big_2xxSingle * Big (Double_Uns (Lo (T2)))))); + Prove_Mult_Decomposition_Split3 + (D1 => 0, + D2 => Big (Double_Uns'(Xhi * Yhi)) + Big (Double_Uns (D (2))) + + Big (Double_Uns (Hi (T1))), + D3 => Big (T2), + D3_Hi => Big (Double_Uns (Hi (T2))), + D3_Lo => Big (Double_Uns (Lo (T2))), + D4 => Big (Double_Uns (D (4)))); D (3) := Lo (T2); T3 := D (2) + Hi (T1); @@ -2807,8 +2875,20 @@ is pragma Assert (Mult >= Big_2xxSingle * Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (D (1)))); + Lemma_Double_Big_2xxSingle; + Lemma_Mult_Positive (Big_2xxDouble, Big_2xxSingle); + Lemma_Ge_Mult (Big (Double_Uns (D (1))), + 1, + Big_2xxDouble * Big_2xxSingle, + Big_2xxDouble * Big_2xxSingle); + Lemma_Mult_Positive (Big_2xxSingle, Big (Double_Uns (D (1)))); + Lemma_Ge_Mult (Big_2xxSingle * Big_2xxSingle, Big_2xxDouble, + Big_2xxSingle * Big (Double_Uns (D (1))), + Big_2xxDouble * Big_2xxSingle); pragma Assert (Mult >= Big_2xxDouble * Big_2xxSingle); Lemma_Ge_Commutation (2 ** Single_Size, Zu); + Lemma_Ge_Mult (Big_2xxSingle, Big (Zu), Big_2xxDouble, + Big_2xxDouble * Big (Zu)); pragma Assert (Mult >= Big_2xxDouble * Big (Zu)); else Lemma_Ge_Commutation (Double_Uns (D (2)), Zu); @@ -2887,6 +2967,13 @@ is Post => Shift / 2 = 2 ** (Log_Single_Size - (Inter + 1)) and then (Shift = 2 or (Shift / 2) mod 2 = 0); + procedure Prove_Prev_And_Mask (Prev, Mask : Single_Uns) + with + Ghost, + Pre => Prev /= 0 + and then (Prev and Mask) = 0, + Post => (Prev and not Mask) /= 0; + procedure Prove_Shift_Progress with Ghost, @@ -2918,6 +3005,7 @@ is -- Local lemma null bodies -- ----------------------------- + procedure Prove_Prev_And_Mask (Prev, Mask : Single_Uns) is null; procedure Prove_Power is null; procedure Prove_Shifting is null; procedure Prove_Shift_Progress is null; @@ -2941,6 +3029,15 @@ is if (Hi (Zu) and Mask) = 0 then Zu := Shift_Left (Zu, Shift); + pragma Assert ((Hi (Zu_Prev) and Mask_Prev) /= 0); + pragma Assert + (By ((Hi (Zu_Prev) and Mask_Prev and Mask) = 0, + (Hi (Zu_Prev) and Mask) = 0 + and then + (Hi (Zu_Prev) and Mask_Prev and Mask) + = (Hi (Zu_Prev) and Mask and Mask_Prev) + )); + Prove_Prev_And_Mask (Hi (Zu_Prev) and Mask_Prev, Mask); Prove_Shifting; pragma Assert (Big (Zu_Prev) = Big (Double_Uns'(abs Z)) * Big_2xx (Scale)); @@ -2986,6 +3083,7 @@ is -- not change the invariant that (D (1) & D (2)) < Zu. Lemma_Lt_Commutation (D (1) & D (2), abs Z); + Lemma_Big_Of_Double_Uns (Zu); Lemma_Lt_Mult (Big (D (1) & D (2)), Big (Double_Uns'(abs Z)), Big_2xx (Scale), Big_2xxDouble); @@ -3007,82 +3105,21 @@ is * Big (Double_Uns (Hi (T1))) = Big_2xxSingle * Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (D (1)))); - - pragma Assert - (Is_Scaled_Mult_Decomposition - (Big (Double_Uns (D (1))), - Big (Double_Uns (D (2))), - Big (Double_Uns (D (3))), - Big (Double_Uns (D (4))))); - pragma Assert - (By (Is_Scaled_Mult_Decomposition - (0, - 0, - Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (D (1))) - + Big_2xxSingle * Big (Double_Uns (D (2))) - + Big (Double_Uns (D (3))), - Big (Double_Uns (D (4)))), - Big_2xxSingle * - (Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (D (1))) - + Big_2xxSingle * Big (Double_Uns (D (2))) - + Big (Double_Uns (D (3)))) - + Big (Double_Uns (D (4))) = - Big_2xxSingle * - Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (D (1))) - + Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (D (2))) - + Big_2xxSingle * Big (Double_Uns (D (3))) - + Big (Double_Uns (D (4))) - and then - (By (Mult * Big_2xx (Scale) = - Big_2xxSingle * - Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (D (1))) - + Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (D (2))) - + Big_2xxSingle * Big (Double_Uns (D (3))) - + Big (Double_Uns (D (4))), - Is_Scaled_Mult_Decomposition - (Big (Double_Uns (D (1))), - Big (Double_Uns (D (2))), - Big (Double_Uns (D (3))), - Big (Double_Uns (D (4)))))))); - Lemma_Substitution - (Mult * Big_2xx (Scale), Big_2xxSingle, - Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (D (1))) - + Big_2xxSingle * Big (Double_Uns (D (2))) - + Big (Double_Uns (D (3))), - Big3 (D (1), D (2), D (3)), - Big (Double_Uns (D (4)))); Lemma_Substitution (Big_2xxDouble * Big (Zu), Big_2xxDouble, Big (Zu), Big (Double_Uns'(abs Z)) * Big_2xx (Scale), 0); Lemma_Lt_Mult (Mult, Big_2xxDouble * Big (Double_Uns'(abs Z)), Big_2xx (Scale), Big_2xxDouble * Big (Zu)); + pragma Assert (Mult >= Big_0); + pragma Assert (Big_2xx (Scale) >= Big_0); + Lemma_Mult_Non_Negative (Mult, Big_2xx (Scale)); Lemma_Div_Lt (Mult * Big_2xx (Scale), Big (Zu), Big_2xxDouble); Lemma_Concat_Definition (D (1), D (2)); Lemma_Double_Big_2xxSingle; - pragma Assert - (Big_2xxSingle * - (Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (D (1))) - + Big_2xxSingle * Big (Double_Uns (D (2))) - + Big (Double_Uns (D (3)))) - + Big (Double_Uns (D (4))) - = Big_2xxSingle * Big_2xxSingle * - (Big_2xxSingle * Big (Double_Uns (D (1))) - + Big (Double_Uns (D (2)))) - + Big_2xxSingle * Big (Double_Uns (D (3))) - + Big (Double_Uns (D (4)))); - pragma Assert - (By (Is_Scaled_Mult_Decomposition - (0, - Big_2xxSingle * Big (Double_Uns (D (1))) - + Big (Double_Uns (D (2))), - 0, - Big_2xxSingle * Big (Double_Uns (D (3))) - + Big (Double_Uns (D (4)))), - Big_2xxSingle * Big_2xxSingle * - (Big_2xxSingle * Big (Double_Uns (D (1))) - + Big (Double_Uns (D (2)))) = - Big_2xxSingle * - Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (D (1))) - + Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (D (2))))); + Prove_Scaled_Mult_Decomposition_Regroup24 + (Big (Double_Uns (D (1))), + Big (Double_Uns (D (2))), + Big (Double_Uns (D (3))), + Big (Double_Uns (D (4)))); Lemma_Substitution (Mult * Big_2xx (Scale), Big_2xxSingle * Big_2xxSingle, Big_2xxSingle * Big (Double_Uns (D (1))) @@ -3115,10 +3152,20 @@ is -- Local ghost variables Qd1 : Single_Uns := 0 with Ghost; + D234 : Big_Integer := 0 with Ghost; D123 : constant Big_Integer := Big3 (D (1), D (2), D (3)) with Ghost; + D4 : constant Big_Integer := Big (Double_Uns (D (4))) + with Ghost; begin + Prove_Scaled_Mult_Decomposition_Regroup3 + (Big (Double_Uns (D (1))), + Big (Double_Uns (D (2))), + Big (Double_Uns (D (3))), + Big (Double_Uns (D (4)))); + pragma Assert (Mult * Big_2xx (Scale) = Big_2xxSingle * D123 + D4); + for J in 1 .. 2 loop Lemma_Hi_Lo (D (J) & D (J + 1), D (J), D (J + 1)); pragma Assert (Big (D (J) & D (J + 1)) < Big (Zu)); @@ -3138,6 +3185,7 @@ is Qd (J) := Single_Uns'Last; Lemma_Concat_Definition (D (J), D (J + 1)); + Lemma_Big_Of_Double_Uns_Of_Single_Uns (D (J + 2)); pragma Assert (Big_2xxSingle > Big (Double_Uns (D (J + 2)))); pragma Assert (Big3 (D (J), D (J + 1), 0) + Big_2xxSingle > Big3 (D (J), D (J + 1), D (J + 2))); @@ -3158,6 +3206,8 @@ is Lemma_Div_Lt (Big3 (D (J), D (J + 1), D (J + 2)), Big_2xxSingle, Big (Zu)); + pragma Assert (Big (Double_Uns (Qd (J))) >= + Big3 (D (J), D (J + 1), D (J + 2)) / Big (Zu)); else Qd (J) := Lo ((D (J) & D (J + 1)) / Zhi); @@ -3165,6 +3215,7 @@ is Prove_Qd_Calculation_Part_1 (J); end if; + pragma Assert (for all K in 1 .. J => Qd (K)'Initialized); Lemma_Gt_Mult (Big (Double_Uns (Qd (J))), Big3 (D (J), D (J + 1), D (J + 2)) / Big (Zu), @@ -3199,7 +3250,9 @@ is Lemma_Hi_Lo_3 (Zu, Zhi, Zlo); while not Le3 (S1, S2, S3, D (J), D (J + 1), D (J + 2)) loop - pragma Loop_Invariant (Qd (J)'Initialized); + pragma Loop_Invariant + (for all K in 1 .. J => Qd (K)'Initialized); + pragma Loop_Invariant (if J = 2 then Qd (1) = Qd1); pragma Loop_Invariant (Big3 (S1, S2, S3) = Big (Double_Uns (Qd (J))) * Big (Zu)); pragma Loop_Invariant @@ -3240,6 +3293,7 @@ is -- Now subtract S1&S2&S3 from D1&D2&D3 ready for next step + pragma Assert (for all K in 1 .. J => Qd (K)'Initialized); pragma Assert (Big3 (S1, S2, S3) = Big (Double_Uns (Qd (J))) * Big (Zu)); pragma Assert (Big3 (S1, S2, S3) > @@ -3256,19 +3310,32 @@ is * Big_2xxSingle * Big (Double_Uns (D (J))) + Big_2xxSingle * Big (Double_Uns (D (J + 1))) + Big (Double_Uns (D (J + 2)))); - pragma Assert (Big3 (D (J), D (J + 1), D (J + 2)) = - Big_2xxDouble * Big (Double_Uns (D (J))) - + Big_2xxSingle * Big (Double_Uns (D (J + 1))) - + Big (Double_Uns (D (J + 2)))); pragma Assert (Big_2xxSingle >= 0); + Lemma_Big_Of_Double_Uns_Of_Single_Uns (D (J + 1)); pragma Assert (Big (Double_Uns (D (J + 1))) >= 0); + Lemma_Mult_Non_Negative + (Big_2xxSingle, Big (Double_Uns (D (J + 1)))); pragma Assert - (Big_2xxSingle * Big (Double_Uns (D (J + 1))) >= 0); - pragma Assert - (Big_2xxSingle * Big (Double_Uns (D (J + 1))) - + Big (Double_Uns (D (J + 2))) >= 0); - pragma Assert (Big3 (D (J), D (J + 1), D (J + 2)) >= - Big_2xxDouble * Big (Double_Uns (D (J)))); + (By (Big3 (D (J), D (J + 1), D (J + 2)) >= + Big_2xxSingle * Big_2xxSingle + * Big (Double_Uns (D (J))), + By (Big3 (D (J), D (J + 1), D (J + 2)) + - Big_2xxSingle * Big_2xxSingle + * Big (Double_Uns (D (J))) + = Big_2xxSingle * Big (Double_Uns (D (J + 1))) + + Big (Double_Uns (D (J + 2))), + Big3 (D (J), D (J + 1), D (J + 2)) = + Big_2xxSingle + * Big_2xxSingle * Big (Double_Uns (D (J))) + + Big_2xxSingle * Big (Double_Uns (D (J + 1))) + + Big (Double_Uns (D (J + 2)))) + and then + By (Big_2xxSingle * Big (Double_Uns (D (J + 1))) + + Big (Double_Uns (D (J + 2))) >= 0, + Big_2xxSingle * Big (Double_Uns (D (J + 1))) >= 0 + and then + Big (Double_Uns (D (J + 2))) >= 0 + ))); Lemma_Ge_Commutation (Double_Uns (D (J)), Double_Uns'(1)); Lemma_Ge_Mult (Big (Double_Uns (D (J))), Big (Double_Uns'(1)), @@ -3283,6 +3350,8 @@ is if J = 1 then Qd1 := Qd (1); + D234 := Big3 (D (2), D (3), D (4)); + pragma Assert (D4 = Big (Double_Uns (D (4)))); Lemma_Substitution (Mult * Big_2xx (Scale), Big_2xxSingle, D123, Big3 (D (1), D (2), D (3)) + Big3 (S1, S2, S3), @@ -3291,23 +3360,38 @@ is Lemma_Substitution (Mult * Big_2xx (Scale), Big_2xxSingle, Big3 (S1, S2, S3), Big (Double_Uns (Qd1)) * Big (Zu), - Big3 (D (2), D (3), D (4))); + D234); else pragma Assert (Qd1 = Qd (1)); pragma Assert - (Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (D (2))) - = 0); - pragma Assert - (Mult * Big_2xx (Scale) = - Big_2xxSingle * Big (Double_Uns (Qd (1))) * Big (Zu) + (By (Mult * Big_2xx (Scale) = + Big_2xxSingle * Big (Double_Uns (Qd1)) * Big (Zu) + Big3 (S1, S2, S3) - + Big3 (D (2), D (3), D (4))); + + Big3 (D (2), D (3), D (4)), + Big3 (D (2), D (3), D (4)) = D234 - Big3 (S1, S2, S3))); pragma Assert - (Mult * Big_2xx (Scale) = + (By (Mult * Big_2xx (Scale) = Big_2xxSingle * Big (Double_Uns (Qd (1))) * Big (Zu) + Big (Double_Uns (Qd (2))) * Big (Zu) + Big_2xxSingle * Big (Double_Uns (D (3))) - + Big (Double_Uns (D (4)))); + + Big (Double_Uns (D (4))), + Big_2xxSingle * Big (Double_Uns (Qd (1))) * Big (Zu) + = Big_2xxSingle * Big (Double_Uns (Qd1)) * Big (Zu) + and then + Big3 (S1, S2, S3) = Big (Double_Uns (Qd (2))) * Big (Zu) + and then + By (Big3 (D (2), D (3), D (4)) + = Big_2xxSingle * Big (Double_Uns (D (3))) + + Big (Double_Uns (D (4))), + Big3 (D (2), D (3), D (4)) + = Big_2xxSingle * Big_2xxSingle * + Big (Double_Uns (D (2))) + + Big_2xxSingle * Big (Double_Uns (D (3))) + + Big (Double_Uns (D (4))) + and then + Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (D (2))) + = 0) + )); end if; end loop; end; @@ -3319,6 +3403,7 @@ is -- We rescale the divisor as well, to make the proper comparison -- for rounding below. + pragma Assert (for all K in 1 .. 2 => Qd (K)'Initialized); Qu := Qd (1) & Qd (2); Ru := D (3) & D (4); @@ -3440,14 +3525,14 @@ is Ghost, Pre => X2 < Y2, Post => Big3 (X1, X2 - Y2, X3) - = Big3 (X1, X2, X3) + Big3 (1, 0, 0) - Big3 (0, Y2, 0); + = Big3 (X1, X2, X3) + Big3 (Single_Uns'(1), 0, 0) - Big3 (0, Y2, 0); procedure Lemma_Sub3_With_Carry3 (X1, X2, X3, Y3 : Single_Uns) with Ghost, Pre => X3 < Y3, Post => Big3 (X1, X2, X3 - Y3) - = Big3 (X1, X2, X3) + Big3 (0, 1, 0) - Big3 (0, 0, Y3); + = Big3 (X1, X2, X3) + Big3 (Single_Uns'(0), 1, 0) - Big3 (0, 0, Y3); ------------------------- -- Lemma_Add3_No_Carry -- @@ -3522,10 +3607,12 @@ is X1 := X1 - 1; pragma Assert - (Big3 (X1, X2, X3) = Big3 (XX1, XX2, XX3) - Big3 (1, 0, 0)); + (Big3 (X1, X2, X3) = + Big3 (XX1, XX2, XX3) - Big3 (Single_Uns'(1), 0, 0)); pragma Assert (Big3 (X1, X2, X3) = Big3 (XX1, XX2, XX3) - - Big3 (0, Single_Uns'Last, 0) - Big3 (0, 1, 0)); + - Big3 (Single_Uns'(0), Single_Uns'Last, 0) + - Big3 (Single_Uns'(0), 1, 0)); Lemma_Add3_No_Carry (X1, X2, X3, 0, Single_Uns'Last, 0); else Lemma_Sub3_No_Carry (X1, X2, X3, 0, 1, 0); @@ -3534,7 +3621,8 @@ is X2 := X2 - 1; pragma Assert - (Big3 (X1, X2, X3) = Big3 (XX1, XX2, XX3) - Big3 (0, 1, 0)); + (Big3 (X1, X2, X3) = + Big3 (XX1, XX2, XX3) - Big3 (Single_Uns'(0), 1, 0)); Lemma_Sub3_With_Carry3 (X1, X2, X3, Y3); else Lemma_Sub3_No_Carry (X1, X2, X3, 0, 0, Y3); @@ -3553,7 +3641,7 @@ is pragma Assert (Big3 (X1, X2, X3) = Big3 (XX1, XX2, XX3) - - Big3 (0, 0, Y3) - Big3 (1, 0, 0)); + - Big3 (0, 0, Y3) - Big3 (Single_Uns'(1), 0, 0)); Lemma_Sub3_With_Carry2 (X1, X2, X3, Y2); else Lemma_Sub3_No_Carry (X1, X2, X3, 0, Y2, 0); diff --git a/gcc/ada/libgnat/s-aridou.ads b/gcc/ada/libgnat/s-aridou.ads index 29e13a5..08af4f5 100644 --- a/gcc/ada/libgnat/s-aridou.ads +++ b/gcc/ada/libgnat/s-aridou.ads @@ -69,6 +69,7 @@ is package BI_Ghost renames Ada.Numerics.Big_Numbers.Big_Integers_Ghost; subtype Big_Integer is BI_Ghost.Big_Integer with Ghost; subtype Big_Natural is BI_Ghost.Big_Natural with Ghost; + subtype Big_Positive is BI_Ghost.Big_Positive with Ghost; use type BI_Ghost.Big_Integer; package Signed_Conversion is diff --git a/gcc/ada/libgnat/s-expmod.adb b/gcc/ada/libgnat/s-expmod.adb index 527338d..f1fdf71 100644 --- a/gcc/ada/libgnat/s-expmod.adb +++ b/gcc/ada/libgnat/s-expmod.adb @@ -106,6 +106,13 @@ is ------------------- procedure Lemma_Add_Mod (X, Y : Big_Natural; B : Big_Positive) is + + procedure Lemma_Euclidean_Mod (Q, F, R : Big_Natural) with + Pre => F /= 0, + Post => (Q * F + R) mod F = R mod F; + + procedure Lemma_Euclidean_Mod (Q, F, R : Big_Natural) is null; + Left : constant Big_Natural := (X + Y) mod B; Right : constant Big_Natural := ((X mod B) + (Y mod B)) mod B; XQuot : constant Big_Natural := X / B; @@ -119,6 +126,8 @@ is (Left = ((XQuot + YQuot) * B + X mod B + Y mod B) mod B); pragma Assert (X mod B + Y mod B = AQuot * B + Right); pragma Assert (Left = ((XQuot + YQuot + AQuot) * B + Right) mod B); + Lemma_Euclidean_Mod (XQuot + YQuot + AQuot, B, Right); + pragma Assert (Left = (Right mod B)); pragma Assert (Left = Right); end if; end Lemma_Add_Mod; @@ -259,6 +268,7 @@ is pragma Assert (Equal_Modulo ((Big (Result) * Big (Factor)) * Big (Factor) ** (Exp - 1), Big (Left) ** Right)); + pragma Assert (Big (Factor) >= 0); Lemma_Mult_Mod (Big (Result) * Big (Factor), Big (Factor) ** (Exp - 1), Big (Modulus)); diff --git a/gcc/ada/libgnat/s-imagef.adb b/gcc/ada/libgnat/s-imagef.adb index fd8e848..bfe8540 100644 --- a/gcc/ada/libgnat/s-imagef.adb +++ b/gcc/ada/libgnat/s-imagef.adb @@ -31,7 +31,8 @@ with System.Image_I; with System.Img_Util; use System.Img_Util; -with System.Val_Util; +with System.Value_I_Spec; +with System.Value_U_Spec; package body System.Image_F is @@ -69,70 +70,16 @@ package body System.Image_F is -- if the small is larger than 1, and smaller than 2**(Int'Size - 1) / 10 -- if the small is smaller than 1. - -- Define ghost subprograms without implementation (marked as Import) to - -- create a suitable package Int_Params for type Int, as instantiations - -- of System.Image_F use for this type one of the derived integer types - -- defined in Interfaces, instead of the standard signed integer types - -- which are used to define System.Img_*.Int_Params. - - type Uns_Option (Overflow : Boolean := False) is record - case Overflow is - when True => - null; - when False => - Value : Uns := 0; - end case; - end record; - Unsigned_Width_Ghost : constant Natural := Int'Width; - function Wrap_Option (Value : Uns) return Uns_Option - with Ghost, Import; - function Only_Decimal_Ghost - (Str : String; - From, To : Integer) - return Boolean - with Ghost, Import; - function Hexa_To_Unsigned_Ghost (X : Character) return Uns - with Ghost, Import; - function Scan_Based_Number_Ghost - (Str : String; - From, To : Integer; - Base : Uns := 10; - Acc : Uns := 0) - return Uns_Option - with Ghost, Import; - function Is_Integer_Ghost (Str : String) return Boolean - with Ghost, Import; - procedure Prove_Iter_Scan_Based_Number_Ghost - (Str1, Str2 : String; - From, To : Integer; - Base : Uns := 10; - Acc : Uns := 0) - with Ghost, Import; - procedure Prove_Scan_Only_Decimal_Ghost (Str : String; Val : Int) - with Ghost, Import; - function Abs_Uns_Of_Int (Val : Int) return Uns - with Ghost, Import; - function Value_Integer (Str : String) return Int - with Ghost, Import; - - package Int_Params is new Val_Util.Int_Params - (Int => Int, - Uns => Uns, - Uns_Option => Uns_Option, - Unsigned_Width_Ghost => Unsigned_Width_Ghost, - Wrap_Option => Wrap_Option, - Only_Decimal_Ghost => Only_Decimal_Ghost, - Hexa_To_Unsigned_Ghost => Hexa_To_Unsigned_Ghost, - Scan_Based_Number_Ghost => Scan_Based_Number_Ghost, - Is_Integer_Ghost => Is_Integer_Ghost, - Prove_Iter_Scan_Based_Number_Ghost => Prove_Iter_Scan_Based_Number_Ghost, - Prove_Scan_Only_Decimal_Ghost => Prove_Scan_Only_Decimal_Ghost, - Abs_Uns_Of_Int => Abs_Uns_Of_Int, - Value_Integer => Value_Integer); - - package Image_I is new System.Image_I (Int_Params); + package Uns_Spec is new System.Value_U_Spec (Uns); + package Int_Spec is new System.Value_I_Spec (Int, Uns, Uns_Spec.Uns_Params); + + package Image_I is new System.Image_I + (Int => Int, + Uns => Uns, + Unsigned_Width_Ghost => Unsigned_Width_Ghost, + Int_Params => Int_Spec.Int_Params); procedure Set_Image_Integer (V : Int; diff --git a/gcc/ada/libgnat/s-imagei.adb b/gcc/ada/libgnat/s-imagei.adb index ff853d3..c467777 100644 --- a/gcc/ada/libgnat/s-imagei.adb +++ b/gcc/ada/libgnat/s-imagei.adb @@ -46,42 +46,6 @@ package body System.Image_I is Post => Ignore, Subprogram_Variant => Ignore); - -- As a use_clause for Int_Params cannot be used for instances of this - -- generic in System specs, rename all constants and subprograms. - - Unsigned_Width_Ghost : constant Natural := Int_Params.Unsigned_Width_Ghost; - - function Wrap_Option (Value : Uns) return Uns_Option - renames Int_Params.Wrap_Option; - function Only_Decimal_Ghost - (Str : String; - From, To : Integer) - return Boolean - renames Int_Params.Only_Decimal_Ghost; - function Hexa_To_Unsigned_Ghost (X : Character) return Uns - renames Int_Params.Hexa_To_Unsigned_Ghost; - function Scan_Based_Number_Ghost - (Str : String; - From, To : Integer; - Base : Uns := 10; - Acc : Uns := 0) - return Uns_Option - renames Int_Params.Scan_Based_Number_Ghost; - function Is_Integer_Ghost (Str : String) return Boolean - renames Int_Params.Is_Integer_Ghost; - procedure Prove_Iter_Scan_Based_Number_Ghost - (Str1, Str2 : String; - From, To : Integer; - Base : Uns := 10; - Acc : Uns := 0) - renames Int_Params.Prove_Iter_Scan_Based_Number_Ghost; - procedure Prove_Scan_Only_Decimal_Ghost (Str : String; Val : Int) - renames Int_Params.Prove_Scan_Only_Decimal_Ghost; - function Abs_Uns_Of_Int (Val : Int) return Uns - renames Int_Params.Abs_Uns_Of_Int; - function Value_Integer (Str : String) return Int - renames Int_Params.Value_Integer; - subtype Non_Positive is Int range Int'First .. 0; function Uns_Of_Non_Positive (T : Non_Positive) return Uns is @@ -99,9 +63,9 @@ package body System.Image_I is and then P <= S'Last - Unsigned_Width_Ghost + 1, Post => S (S'First .. P'Old) = S'Old (S'First .. P'Old) and then P in P'Old + 1 .. S'Last - and then Only_Decimal_Ghost (S, From => P'Old + 1, To => P) - and then Scan_Based_Number_Ghost (S, From => P'Old + 1, To => P) - = Wrap_Option (Uns_Of_Non_Positive (T)); + and then UP.Only_Decimal_Ghost (S, From => P'Old + 1, To => P) + and then UP.Scan_Based_Number_Ghost (S, From => P'Old + 1, To => P) + = UP.Wrap_Option (Uns_Of_Non_Positive (T)); -- Set digits of absolute value of T, which is zero or negative. We work -- with the negative of the value so that the largest negative number is -- not a special case. @@ -182,11 +146,12 @@ package body System.Image_I is and then P in 2 .. S'Last and then S (1) in ' ' | '-' and then (S (1) = '-') = (V < 0) - and then Only_Decimal_Ghost (S, From => 2, To => P) - and then Scan_Based_Number_Ghost (S, From => 2, To => P) - = Wrap_Option (Abs_Uns_Of_Int (V)), - Post => Is_Integer_Ghost (S (1 .. P)) - and then Value_Integer (S (1 .. P)) = V; + and then UP.Only_Decimal_Ghost (S, From => 2, To => P) + and then UP.Scan_Based_Number_Ghost (S, From => 2, To => P) + = UP.Wrap_Option (IP.Abs_Uns_Of_Int (V)), + Post => not System.Val_Util.Only_Space_Ghost (S, 1, P) + and then IP.Is_Integer_Ghost (S (1 .. P)) + and then IP.Is_Value_Integer_Ghost (S (1 .. P), V); -- Ghost lemma to prove the value of Value_Integer from the value of -- Scan_Based_Number_Ghost and the sign on a decimal string. @@ -198,17 +163,22 @@ package body System.Image_I is Str : constant String := S (1 .. P); begin pragma Assert (Str'First = 1); - pragma Assert (Only_Decimal_Ghost (Str, From => 2, To => P)); - Prove_Iter_Scan_Based_Number_Ghost (S, Str, From => 2, To => P); - pragma Assert (Scan_Based_Number_Ghost (Str, From => 2, To => P) - = Wrap_Option (Abs_Uns_Of_Int (V))); - Prove_Scan_Only_Decimal_Ghost (Str, V); + pragma Assert (Str (2) /= ' '); + pragma Assert + (UP.Only_Decimal_Ghost (Str, From => 2, To => P)); + UP.Prove_Scan_Based_Number_Ghost_Eq (S, Str, From => 2, To => P); + pragma Assert + (UP.Scan_Based_Number_Ghost (Str, From => 2, To => P) + = UP.Wrap_Option (IP.Abs_Uns_Of_Int (V))); + IP.Prove_Scan_Only_Decimal_Ghost (Str, V); end Prove_Value_Integer; -- Start of processing for Image_Integer begin if V >= 0 then + pragma Annotate (CodePeer, False_Positive, "test always false", + "V can be positive"); S (1) := ' '; P := 1; pragma Assert (P < S'Last); @@ -226,6 +196,8 @@ package body System.Image_I is pragma Assert (P_Prev + Offset = 2); end; + pragma Assert (if V >= 0 then S (1) = ' '); + pragma Assert (S (1) in ' ' | '-'); Prove_Value_Integer; end Image_Integer; @@ -248,42 +220,78 @@ package body System.Image_I is S_Init : constant String := S with Ghost; Uns_T : constant Uns := Uns_Of_Non_Positive (T) with Ghost; Uns_Value : Uns := Uns_Of_Non_Positive (Value) with Ghost; - Prev, Cur : Uns_Option with Ghost; Prev_Value : Uns with Ghost; Prev_S : String := S with Ghost; -- Local ghost lemmas - procedure Prove_Character_Val (RU : Uns; RI : Int) + procedure Prove_Character_Val (RU : Uns; RI : Non_Positive) with Ghost, - Pre => RU in 0 .. 9 - and then RI in 0 .. 9, - Post => Character'Val (48 + RU) in '0' .. '9' - and then Character'Val (48 + RI) in '0' .. '9'; + Post => RU rem 10 in 0 .. 9 + and then -(RI rem 10) in 0 .. 9 + and then Character'Val (48 + RU rem 10) in '0' .. '9' + and then Character'Val (48 - RI rem 10) in '0' .. '9'; -- Ghost lemma to prove the value of a character corresponding to the -- next figure. + procedure Prove_Euclidian (Val, Quot, Rest : Uns) + with + Ghost, + Pre => Quot = Val / 10 + and then Rest = Val rem 10, + Post => Uns'Last - Rest >= 10 * Quot and then Val = 10 * Quot + Rest; + -- Ghost lemma to prove the relation between the quotient/remainder of + -- division by 10 and the initial value. + procedure Prove_Hexa_To_Unsigned_Ghost (RU : Uns; RI : Int) with Ghost, Pre => RU in 0 .. 9 and then RI in 0 .. 9, - Post => Hexa_To_Unsigned_Ghost (Character'Val (48 + RU)) = RU - and then Hexa_To_Unsigned_Ghost (Character'Val (48 + RI)) = Uns (RI); + Post => UP.Hexa_To_Unsigned_Ghost + (Character'Val (48 + RU)) = RU + and then UP.Hexa_To_Unsigned_Ghost + (Character'Val (48 + RI)) = Uns (RI); -- Ghost lemma to prove that Hexa_To_Unsigned_Ghost returns the source -- figure when applied to the corresponding character. - procedure Prove_Unchanged - with - Ghost, - Pre => P <= S'Last - and then S_Init'First = S'First - and then S_Init'Last = S'Last - and then (for all K in S'First .. P => S (K) = S_Init (K)), - Post => S (S'First .. P) = S_Init (S'First .. P); - -- Ghost lemma to prove that the part of string S before P has not been - -- modified. + procedure Prove_Scan_Iter + (S, Prev_S : String; + V, Prev_V, Res : Uns; + P, Max : Natural) + with + Ghost, + Pre => + S'First = Prev_S'First and then S'Last = Prev_S'Last + and then S'Last < Natural'Last and then + Max in S'Range and then P in S'First .. Max and then + (for all I in P + 1 .. Max => Prev_S (I) in '0' .. '9') + and then (for all I in P + 1 .. Max => Prev_S (I) = S (I)) + and then S (P) in '0' .. '9' + and then V <= Uns'Last / 10 + and then Uns'Last - UP.Hexa_To_Unsigned_Ghost (S (P)) + >= 10 * V + and then Prev_V = + V * 10 + UP.Hexa_To_Unsigned_Ghost (S (P)) + and then + (if P = Max then Prev_V = Res + else UP.Scan_Based_Number_Ghost + (Str => Prev_S, + From => P + 1, + To => Max, + Base => 10, + Acc => Prev_V) = UP.Wrap_Option (Res)), + Post => + (for all I in P .. Max => S (I) in '0' .. '9') + and then UP.Scan_Based_Number_Ghost + (Str => S, + From => P, + To => Max, + Base => 10, + Acc => V) = UP.Wrap_Option (Res); + -- Ghost lemma to prove that Scan_Based_Number_Ghost is preserved + -- through an iteration of the loop. procedure Prove_Uns_Of_Non_Positive_Value with @@ -294,50 +302,44 @@ package body System.Image_I is -- Ghost lemma to prove that the relation between Value and its unsigned -- version is preserved. - procedure Prove_Iter_Scan - (Str1, Str2 : String; - From, To : Integer; - Base : Uns := 10; - Acc : Uns := 0) - with - Ghost, - Pre => Str1'Last /= Positive'Last - and then - (From > To or else (From >= Str1'First and then To <= Str1'Last)) - and then Only_Decimal_Ghost (Str1, From, To) - and then Str1'First = Str2'First - and then Str1'Last = Str2'Last - and then (for all J in From .. To => Str1 (J) = Str2 (J)), - Post => - Scan_Based_Number_Ghost (Str1, From, To, Base, Acc) - = Scan_Based_Number_Ghost (Str2, From, To, Base, Acc); - -- Ghost lemma to prove that the result of Scan_Based_Number_Ghost only - -- depends on the value of the argument string in the (From .. To) range - -- of indexes. This is a wrapper on Prove_Iter_Scan_Based_Number_Ghost - -- so that we can call it here on ghost arguments. - ----------------------------- -- Local lemma null bodies -- ----------------------------- - procedure Prove_Character_Val (RU : Uns; RI : Int) is null; + procedure Prove_Character_Val (RU : Uns; RI : Non_Positive) is null; + procedure Prove_Euclidian (Val, Quot, Rest : Uns) is null; procedure Prove_Hexa_To_Unsigned_Ghost (RU : Uns; RI : Int) is null; - procedure Prove_Unchanged is null; procedure Prove_Uns_Of_Non_Positive_Value is null; --------------------- - -- Prove_Iter_Scan -- + -- Prove_Scan_Iter -- --------------------- - procedure Prove_Iter_Scan - (Str1, Str2 : String; - From, To : Integer; - Base : Uns := 10; - Acc : Uns := 0) + procedure Prove_Scan_Iter + (S, Prev_S : String; + V, Prev_V, Res : Uns; + P, Max : Natural) is + pragma Unreferenced (Res); begin - Prove_Iter_Scan_Based_Number_Ghost (Str1, Str2, From, To, Base, Acc); - end Prove_Iter_Scan; + UP.Lemma_Scan_Based_Number_Ghost_Step + (Str => S, + From => P, + To => Max, + Base => 10, + Acc => V); + if P < Max then + UP.Prove_Scan_Based_Number_Ghost_Eq + (Prev_S, S, P + 1, Max, 10, Prev_V); + else + UP.Lemma_Scan_Based_Number_Ghost_Base + (Str => S, + From => P + 1, + To => Max, + Base => 10, + Acc => Prev_V); + end if; + end Prove_Scan_Iter; -- Start of processing for Set_Digits @@ -383,13 +385,9 @@ package body System.Image_I is for J in reverse 1 .. Nb_Digits loop Lemma_Div_Commutation (Uns_Value, 10); Lemma_Div_Twice (Big (Uns_T), Big_10 ** (Nb_Digits - J), Big_10); - Prove_Character_Val (Uns_Value rem 10, -(Value rem 10)); + Prove_Character_Val (Uns_Value, Value); Prove_Hexa_To_Unsigned_Ghost (Uns_Value rem 10, -(Value rem 10)); Prove_Uns_Of_Non_Positive_Value; - pragma Assert (Uns_Value rem 10 = Uns_Of_Non_Positive (Value rem 10)); - pragma Assert (Uns_Value rem 10 = Uns (-(Value rem 10))); - pragma Assert - (Uns_Value = From_Big (Big (Uns_T) / Big_10 ** (Nb_Digits - J))); Prev_Value := Uns_Value; Prev_S := S; @@ -399,68 +397,44 @@ package body System.Image_I is S (P + J) := Character'Val (48 - (Value rem 10)); Value := Value / 10; - pragma Assert (S (P + J) in '0' .. '9'); - pragma Assert (Hexa_To_Unsigned_Ghost (S (P + J)) = - From_Big (Big (Uns_T) / Big_10 ** (Nb_Digits - J)) rem 10); - pragma Assert - (for all K in P + J + 1 .. P + Nb_Digits => S (K) in '0' .. '9'); + Prove_Euclidian + (Val => Prev_Value, + Quot => Uns_Value, + Rest => UP.Hexa_To_Unsigned_Ghost (S (P + J))); - Prev := Scan_Based_Number_Ghost - (Str => S, - From => P + J + 1, - To => P + Nb_Digits, - Base => 10, - Acc => Prev_Value); - Cur := Scan_Based_Number_Ghost - (Str => S, - From => P + J, - To => P + Nb_Digits, - Base => 10, - Acc => Uns_Value); - pragma Assert (Prev_Value = 10 * Uns_Value + (Prev_Value rem 10)); - pragma Assert - (Prev_Value rem 10 = Hexa_To_Unsigned_Ghost (S (P + J))); - pragma Assert - (Prev_Value = 10 * Uns_Value + Hexa_To_Unsigned_Ghost (S (P + J))); - - if J /= Nb_Digits then - Prove_Iter_Scan - (Prev_S, S, P + J + 1, P + Nb_Digits, 10, Prev_Value); - end if; - - pragma Assert (Prev = Cur); - pragma Assert (Prev = Wrap_Option (Uns_T)); + Prove_Scan_Iter + (S, Prev_S, Uns_Value, Prev_Value, Uns_T, P + J, P + Nb_Digits); pragma Loop_Invariant (Uns_Value = Uns_Of_Non_Positive (Value)); pragma Loop_Invariant (Uns_Value <= Uns'Last / 10); pragma Loop_Invariant (for all K in S'First .. P => S (K) = S_Init (K)); - pragma Loop_Invariant (Only_Decimal_Ghost (S, P + J, P + Nb_Digits)); + pragma Loop_Invariant + (UP.Only_Decimal_Ghost (S, P + J, P + Nb_Digits)); pragma Loop_Invariant (for all K in P + J .. P + Nb_Digits => S (K) in '0' .. '9'); pragma Loop_Invariant (Pow = Big_10 ** (Nb_Digits - J + 1)); pragma Loop_Invariant (Big (Uns_Value) = Big (Uns_T) / Pow); pragma Loop_Invariant - (Scan_Based_Number_Ghost + (UP.Scan_Based_Number_Ghost (Str => S, From => P + J, To => P + Nb_Digits, Base => 10, Acc => Uns_Value) - = Wrap_Option (Uns_T)); + = UP.Wrap_Option (Uns_T)); end loop; pragma Assert (Big (Uns_Value) = Big (Uns_T) / Big_10 ** (Nb_Digits)); pragma Assert (Uns_Value = 0); - Prove_Unchanged; pragma Assert - (Scan_Based_Number_Ghost + (UP.Scan_Based_Number_Ghost (Str => S, From => P + 1, To => P + Nb_Digits, Base => 10, Acc => Uns_Value) - = Wrap_Option (Uns_T)); + = UP.Wrap_Option (Uns_T)); P := P + Nb_Digits; end Set_Digits; diff --git a/gcc/ada/libgnat/s-imagei.ads b/gcc/ada/libgnat/s-imagei.ads index 10116d1..575c60a 100644 --- a/gcc/ada/libgnat/s-imagei.ads +++ b/gcc/ada/libgnat/s-imagei.ads @@ -48,19 +48,19 @@ pragma Assertion_Policy (Pre => Ignore, with System.Val_Util; generic + type Int is range <>; + type Uns is mod <>; - with package Int_Params is new System.Val_Util.Int_Params (<>); + Unsigned_Width_Ghost : Natural; -package System.Image_I is - - subtype Int is Int_Params.Int; - use type Int_Params.Int; + with package Int_Params is new System.Val_Util.Int_Params + (Int => Int, Uns => Uns, others => <>) + with Ghost; - subtype Uns is Int_Params.Uns; - use type Int_Params.Uns; - - subtype Uns_Option is Int_Params.Uns_Option; - use type Int_Params.Uns_Option; +package System.Image_I is + package IP renames Int_Params; + package UP renames IP.Uns_Params; + use type UP.Uns_Option; procedure Image_Integer (V : Int; @@ -69,9 +69,9 @@ package System.Image_I is with Pre => S'First = 1 and then S'Last < Integer'Last - and then S'Last >= Int_Params.Unsigned_Width_Ghost, + and then S'Last >= Unsigned_Width_Ghost, Post => P in S'Range - and then Int_Params.Value_Integer (S (1 .. P)) = V; + and then IP.Is_Value_Integer_Ghost (S (1 .. P), V); -- Computes Int'Image (V) and stores the result in S (1 .. P) -- setting the resulting value of P. The caller guarantees that S -- is long enough to hold the result, and that S'First is 1. @@ -87,23 +87,23 @@ package System.Image_I is and then S'First <= S'Last and then (if V >= 0 then - P <= S'Last - Int_Params.Unsigned_Width_Ghost + 1 + P <= S'Last - Unsigned_Width_Ghost + 1 else - P <= S'Last - Int_Params.Unsigned_Width_Ghost), + P <= S'Last - Unsigned_Width_Ghost), Post => S (S'First .. P'Old) = S'Old (S'First .. P'Old) and then (declare Minus : constant Boolean := S (P'Old + 1) = '-'; Offset : constant Positive := (if V >= 0 then 1 else 2); - Abs_V : constant Uns := Int_Params.Abs_Uns_Of_Int (V); + Abs_V : constant Uns := IP.Abs_Uns_Of_Int (V); begin Minus = (V < 0) and then P in P'Old + Offset .. S'Last - and then Int_Params.Only_Decimal_Ghost + and then UP.Only_Decimal_Ghost (S, From => P'Old + Offset, To => P) - and then Int_Params.Scan_Based_Number_Ghost + and then UP.Scan_Based_Number_Ghost (S, From => P'Old + Offset, To => P) - = Int_Params.Wrap_Option (Abs_V)); + = UP.Wrap_Option (Abs_V)); -- Stores the image of V in S starting at S (P + 1), P is updated to point -- to the last character stored. The value stored is identical to the value -- of Int'Image (V) except that no leading space is stored when V is diff --git a/gcc/ada/libgnat/s-imageu.adb b/gcc/ada/libgnat/s-imageu.adb index 6932487..0e1c2bb 100644 --- a/gcc/ada/libgnat/s-imageu.adb +++ b/gcc/ada/libgnat/s-imageu.adb @@ -147,11 +147,12 @@ package body System.Image_U is and then S'Last < Integer'Last and then P in 2 .. S'Last and then S (1) = ' ' - and then Only_Decimal_Ghost (S, From => 2, To => P) - and then Scan_Based_Number_Ghost (S, From => 2, To => P) - = Wrap_Option (V), - Post => Is_Unsigned_Ghost (S (1 .. P)) - and then Value_Unsigned (S (1 .. P)) = V; + and then Uns_Params.Only_Decimal_Ghost (S, From => 2, To => P) + and then Uns_Params.Scan_Based_Number_Ghost (S, From => 2, To => P) + = Uns_Params.Wrap_Option (V), + Post => not System.Val_Util.Only_Space_Ghost (S, 1, P) + and then Uns_Params.Is_Unsigned_Ghost (S (1 .. P)) + and then Uns_Params.Is_Value_Unsigned_Ghost (S (1 .. P), V); -- Ghost lemma to prove the value of Value_Unsigned from the value of -- Scan_Based_Number_Ghost on a decimal string. @@ -163,11 +164,15 @@ package body System.Image_U is Str : constant String := S (1 .. P); begin pragma Assert (Str'First = 1); - pragma Assert (Only_Decimal_Ghost (Str, From => 2, To => P)); - Prove_Iter_Scan_Based_Number_Ghost (S, Str, From => 2, To => P); - pragma Assert (Scan_Based_Number_Ghost (Str, From => 2, To => P) - = Wrap_Option (V)); - Prove_Scan_Only_Decimal_Ghost (Str, V); + pragma Assert (S (2) /= ' '); + pragma Assert + (Uns_Params.Only_Decimal_Ghost (Str, From => 2, To => P)); + Uns_Params.Prove_Scan_Based_Number_Ghost_Eq + (S, Str, From => 2, To => P); + pragma Assert + (Uns_Params.Scan_Based_Number_Ghost (Str, From => 2, To => P) + = Uns_Params.Wrap_Option (V)); + Uns_Params.Prove_Scan_Only_Decimal_Ghost (Str, V); end Prove_Value_Unsigned; -- Start of processing for Image_Unsigned @@ -196,7 +201,6 @@ package body System.Image_U is Pow : Big_Positive := 1 with Ghost; S_Init : constant String := S with Ghost; - Prev, Cur : Uns_Option with Ghost; Prev_Value : Uns with Ghost; Prev_S : String := S with Ghost; @@ -205,8 +209,8 @@ package body System.Image_U is procedure Prove_Character_Val (R : Uns) with Ghost, - Pre => R in 0 .. 9, - Post => Character'Val (48 + R) in '0' .. '9'; + Post => R rem 10 in 0 .. 9 + and then Character'Val (48 + R rem 10) in '0' .. '9'; -- Ghost lemma to prove the value of a character corresponding to the -- next figure. @@ -215,7 +219,7 @@ package body System.Image_U is Ghost, Pre => Quot = Val / 10 and then Rest = Val rem 10, - Post => Val = 10 * Quot + Rest; + Post => Uns'Last - Rest >= 10 * Quot and then Val = 10 * Quot + Rest; -- Ghost lemma to prove the relation between the quotient/remainder of -- division by 10 and the initial value. @@ -223,42 +227,46 @@ package body System.Image_U is with Ghost, Pre => R in 0 .. 9, - Post => Hexa_To_Unsigned_Ghost (Character'Val (48 + R)) = R; + Post => Uns_Params.Hexa_To_Unsigned_Ghost (Character'Val (48 + R)) = R; -- Ghost lemma to prove that Hexa_To_Unsigned_Ghost returns the source -- figure when applied to the corresponding character. - procedure Prove_Unchanged - with - Ghost, - Pre => P <= S'Last - and then S_Init'First = S'First - and then S_Init'Last = S'Last - and then (for all K in S'First .. P => S (K) = S_Init (K)), - Post => S (S'First .. P) = S_Init (S'First .. P); - -- Ghost lemma to prove that the part of string S before P has not been - -- modified. - - procedure Prove_Iter_Scan - (Str1, Str2 : String; - From, To : Integer; - Base : Uns := 10; - Acc : Uns := 0) - with - Ghost, - Pre => Str1'Last /= Positive'Last - and then - (From > To or else (From >= Str1'First and then To <= Str1'Last)) - and then Only_Decimal_Ghost (Str1, From, To) - and then Str1'First = Str2'First - and then Str1'Last = Str2'Last - and then (for all J in From .. To => Str1 (J) = Str2 (J)), - Post => - Scan_Based_Number_Ghost (Str1, From, To, Base, Acc) - = Scan_Based_Number_Ghost (Str2, From, To, Base, Acc); - -- Ghost lemma to prove that the result of Scan_Based_Number_Ghost only - -- depends on the value of the argument string in the (From .. To) range - -- of indexes. This is a wrapper on Prove_Iter_Scan_Based_Number_Ghost - -- so that we can call it here on ghost arguments. + procedure Prove_Scan_Iter + (S, Prev_S : String; + V, Prev_V, Res : Uns; + P, Max : Natural) + with + Ghost, + Pre => + S'First = Prev_S'First and then S'Last = Prev_S'Last + and then S'Last < Natural'Last and then + Max in S'Range and then P in S'First .. Max and then + (for all I in P + 1 .. Max => Prev_S (I) in '0' .. '9') + and then (for all I in P + 1 .. Max => Prev_S (I) = S (I)) + and then S (P) in '0' .. '9' + and then V <= Uns'Last / 10 + and then Uns'Last - Uns_Params.Hexa_To_Unsigned_Ghost (S (P)) + >= 10 * V + and then Prev_V = + V * 10 + Uns_Params.Hexa_To_Unsigned_Ghost (S (P)) + and then + (if P = Max then Prev_V = Res + else Uns_Params.Scan_Based_Number_Ghost + (Str => Prev_S, + From => P + 1, + To => Max, + Base => 10, + Acc => Prev_V) = Uns_Params.Wrap_Option (Res)), + Post => + (for all I in P .. Max => S (I) in '0' .. '9') + and then Uns_Params.Scan_Based_Number_Ghost + (Str => S, + From => P, + To => Max, + Base => 10, + Acc => V) = Uns_Params.Wrap_Option (Res); + -- Ghost lemma to prove that Scan_Based_Number_Ghost is preserved + -- through an iteration of the loop. ----------------------------- -- Local lemma null bodies -- @@ -267,21 +275,36 @@ package body System.Image_U is procedure Prove_Character_Val (R : Uns) is null; procedure Prove_Euclidian (Val, Quot, Rest : Uns) is null; procedure Prove_Hexa_To_Unsigned_Ghost (R : Uns) is null; - procedure Prove_Unchanged is null; --------------------- - -- Prove_Iter_Scan -- + -- Prove_Scan_Iter -- --------------------- - procedure Prove_Iter_Scan - (Str1, Str2 : String; - From, To : Integer; - Base : Uns := 10; - Acc : Uns := 0) + procedure Prove_Scan_Iter + (S, Prev_S : String; + V, Prev_V, Res : Uns; + P, Max : Natural) is + pragma Unreferenced (Res); begin - Prove_Iter_Scan_Based_Number_Ghost (Str1, Str2, From, To, Base, Acc); - end Prove_Iter_Scan; + Uns_Params.Lemma_Scan_Based_Number_Ghost_Step + (Str => S, + From => P, + To => Max, + Base => 10, + Acc => V); + if P < Max then + Uns_Params.Prove_Scan_Based_Number_Ghost_Eq + (Prev_S, S, P + 1, Max, 10, Prev_V); + else + Uns_Params.Lemma_Scan_Based_Number_Ghost_Base + (Str => S, + From => P + 1, + To => Max, + Base => 10, + Acc => Prev_V); + end if; + end Prove_Scan_Iter; -- Start of processing for Set_Image_Unsigned @@ -313,6 +336,7 @@ package body System.Image_U is Lemma_Non_Zero (Value); pragma Assert (Pow <= Big (Uns'Last)); end loop; + pragma Assert (Big (V) / (Big_10 ** Nb_Digits) = 0); Value := V; Pow := 1; @@ -323,77 +347,43 @@ package body System.Image_U is for J in reverse 1 .. Nb_Digits loop Lemma_Div_Commutation (Value, 10); Lemma_Div_Twice (Big (V), Big_10 ** (Nb_Digits - J), Big_10); - Prove_Character_Val (Value rem 10); + Prove_Character_Val (Value); Prove_Hexa_To_Unsigned_Ghost (Value rem 10); Prev_Value := Value; Prev_S := S; Pow := Pow * 10; - S (P + J) := Character'Val (48 + (Value rem 10)); Value := Value / 10; - pragma Assert (S (P + J) in '0' .. '9'); - pragma Assert (Hexa_To_Unsigned_Ghost (S (P + J)) = - From_Big (Big (V) / Big_10 ** (Nb_Digits - J)) rem 10); - pragma Assert - (for all K in P + J + 1 .. P + Nb_Digits => S (K) in '0' .. '9'); - pragma Assert - (for all K in P + J + 1 .. P + Nb_Digits => - Hexa_To_Unsigned_Ghost (S (K)) = - From_Big (Big (V) / Big_10 ** (Nb_Digits - (K - P))) rem 10); - - Prev := Scan_Based_Number_Ghost - (Str => S, - From => P + J + 1, - To => P + Nb_Digits, - Base => 10, - Acc => Prev_Value); - Cur := Scan_Based_Number_Ghost - (Str => S, - From => P + J, - To => P + Nb_Digits, - Base => 10, - Acc => Value); - - if J /= Nb_Digits then - Prove_Euclidian (Val => Prev_Value, - Quot => Value, - Rest => Hexa_To_Unsigned_Ghost (S (P + J))); - pragma Assert - (Prev_Value = 10 * Value + Hexa_To_Unsigned_Ghost (S (P + J))); - Prove_Iter_Scan - (Prev_S, S, P + J + 1, P + Nb_Digits, 10, Prev_Value); - end if; + Prove_Euclidian + (Val => Prev_Value, + Quot => Value, + Rest => Uns_Params.Hexa_To_Unsigned_Ghost (S (P + J))); - pragma Assert (Prev = Cur); - pragma Assert (Prev = Wrap_Option (V)); + Prove_Scan_Iter + (S, Prev_S, Value, Prev_Value, V, P + J, P + Nb_Digits); pragma Loop_Invariant (Value <= Uns'Last / 10); pragma Loop_Invariant (for all K in S'First .. P => S (K) = S_Init (K)); - pragma Loop_Invariant (Only_Decimal_Ghost (S, P + J, P + Nb_Digits)); - pragma Loop_Invariant - (for all K in P + J .. P + Nb_Digits => S (K) in '0' .. '9'); pragma Loop_Invariant - (for all K in P + J .. P + Nb_Digits => - Hexa_To_Unsigned_Ghost (S (K)) = - From_Big (Big (V) / Big_10 ** (Nb_Digits - (K - P))) rem 10); + (Uns_Params.Only_Decimal_Ghost + (S, From => P + J, To => P + Nb_Digits)); pragma Loop_Invariant (Pow = Big_10 ** (Nb_Digits - J + 1)); pragma Loop_Invariant (Big (Value) = Big (V) / Pow); pragma Loop_Invariant - (Scan_Based_Number_Ghost + (Uns_Params.Scan_Based_Number_Ghost (Str => S, From => P + J, To => P + Nb_Digits, Base => 10, Acc => Value) - = Wrap_Option (V)); + = Uns_Params.Wrap_Option (V)); end loop; + pragma Assert (Big (Value) = Big (V) / (Big_10 ** Nb_Digits)); pragma Assert (Value = 0); - Prove_Unchanged; - P := P + Nb_Digits; end Set_Image_Unsigned; diff --git a/gcc/ada/libgnat/s-imageu.ads b/gcc/ada/libgnat/s-imageu.ads index 789cf65..3d80ea9 100644 --- a/gcc/ada/libgnat/s-imageu.ads +++ b/gcc/ada/libgnat/s-imageu.ads @@ -45,45 +45,22 @@ pragma Assertion_Policy (Pre => Ignore, Ghost => Ignore, Subprogram_Variant => Ignore); +with System.Val_Util; + generic type Uns is mod <>; - type Uns_Option is private; -- Additional parameters for ghost subprograms used inside contracts Unsigned_Width_Ghost : Natural; - with function Wrap_Option (Value : Uns) return Uns_Option - with Ghost; - with function Only_Decimal_Ghost - (Str : String; - From, To : Integer) - return Boolean - with Ghost; - with function Hexa_To_Unsigned_Ghost (X : Character) return Uns - with Ghost; - with function Scan_Based_Number_Ghost - (Str : String; - From, To : Integer; - Base : Uns := 10; - Acc : Uns := 0) return Uns_Option - with Ghost; - with function Is_Unsigned_Ghost (Str : String) return Boolean - with Ghost; - with function Value_Unsigned (Str : String) return Uns; - with procedure Prove_Iter_Scan_Based_Number_Ghost - (Str1, Str2 : String; - From, To : Integer; - Base : Uns := 10; - Acc : Uns := 0) - with Ghost; - with procedure Prove_Scan_Only_Decimal_Ghost - (Str : String; - Val : Uns) - with Ghost; + with package Uns_Params is new System.Val_Util.Uns_Params + (Uns => Uns, others => <>) + with Ghost; package System.Image_U is + use all type Uns_Params.Uns_Option; procedure Image_Unsigned (V : Uns; @@ -94,7 +71,7 @@ package System.Image_U is and then S'Last < Integer'Last and then S'Last >= Unsigned_Width_Ghost, Post => P in S'Range - and then Value_Unsigned (S (1 .. P)) = V; + and then Uns_Params.Is_Value_Unsigned_Ghost (S (1 .. P), V); pragma Inline (Image_Unsigned); -- Computes Uns'Image (V) and stores the result in S (1 .. P) setting -- the resulting value of P. The caller guarantees that S is long enough to @@ -112,9 +89,10 @@ package System.Image_U is and then P <= S'Last - Unsigned_Width_Ghost + 1, Post => S (S'First .. P'Old) = S'Old (S'First .. P'Old) and then P in P'Old + 1 .. S'Last - and then Only_Decimal_Ghost (S, From => P'Old + 1, To => P) - and then Scan_Based_Number_Ghost (S, From => P'Old + 1, To => P) - = Wrap_Option (V); + and then Uns_Params.Only_Decimal_Ghost (S, From => P'Old + 1, To => P) + and then Uns_Params.Scan_Based_Number_Ghost + (S, From => P'Old + 1, To => P) + = Uns_Params.Wrap_Option (V); -- Stores the image of V in S starting at S (P + 1), P is updated to point -- to the last character stored. The value stored is identical to the value -- of Uns'Image (V) except that no leading space is stored. The caller diff --git a/gcc/ada/libgnat/s-imgint.ads b/gcc/ada/libgnat/s-imgint.ads index fd5bea3..8672e58 100644 --- a/gcc/ada/libgnat/s-imgint.ads +++ b/gcc/ada/libgnat/s-imgint.ads @@ -48,8 +48,6 @@ pragma Assertion_Policy (Pre => Ignore, with System.Image_I; with System.Unsigned_Types; with System.Val_Int; -with System.Val_Uns; -with System.Val_Util; with System.Wid_Uns; package System.Img_Int @@ -57,27 +55,12 @@ package System.Img_Int is subtype Unsigned is Unsigned_Types.Unsigned; - package Int_Params is new Val_Util.Int_Params - (Int => Integer, - Uns => Unsigned, - Uns_Option => Val_Uns.Impl.Uns_Option, - Unsigned_Width_Ghost => + package Impl is new Image_I + (Int => Integer, + Uns => Unsigned, + Unsigned_Width_Ghost => Wid_Uns.Width_Unsigned (0, Unsigned'Last), - Only_Decimal_Ghost => Val_Uns.Impl.Only_Decimal_Ghost, - Hexa_To_Unsigned_Ghost => - Val_Uns.Impl.Hexa_To_Unsigned_Ghost, - Wrap_Option => Val_Uns.Impl.Wrap_Option, - Scan_Based_Number_Ghost => - Val_Uns.Impl.Scan_Based_Number_Ghost, - Prove_Iter_Scan_Based_Number_Ghost => - Val_Uns.Impl.Prove_Iter_Scan_Based_Number_Ghost, - Is_Integer_Ghost => Val_Int.Impl.Is_Integer_Ghost, - Prove_Scan_Only_Decimal_Ghost => - Val_Int.Impl.Prove_Scan_Only_Decimal_Ghost, - Abs_Uns_Of_Int => Val_Int.Impl.Abs_Uns_Of_Int, - Value_Integer => Val_Int.Impl.Value_Integer); - - package Impl is new Image_I (Int_Params); + Int_Params => System.Val_Int.Impl.Spec.Int_Params); procedure Image_Integer (V : Integer; diff --git a/gcc/ada/libgnat/s-imglli.ads b/gcc/ada/libgnat/s-imglli.ads index 20f108c..99c1951 100644 --- a/gcc/ada/libgnat/s-imglli.ads +++ b/gcc/ada/libgnat/s-imglli.ads @@ -48,8 +48,6 @@ pragma Assertion_Policy (Pre => Ignore, with System.Image_I; with System.Unsigned_Types; with System.Val_LLI; -with System.Val_LLU; -with System.Val_Util; with System.Wid_LLU; package System.Img_LLI @@ -57,27 +55,13 @@ package System.Img_LLI is subtype Long_Long_Unsigned is Unsigned_Types.Long_Long_Unsigned; - package Int_Params is new Val_Util.Int_Params - (Int => Long_Long_Integer, - Uns => Long_Long_Unsigned, - Uns_Option => Val_LLU.Impl.Uns_Option, - Unsigned_Width_Ghost => - Wid_LLU.Width_Long_Long_Unsigned (0, Long_Long_Unsigned'Last), - Only_Decimal_Ghost => Val_LLU.Impl.Only_Decimal_Ghost, - Hexa_To_Unsigned_Ghost => - Val_LLU.Impl.Hexa_To_Unsigned_Ghost, - Wrap_Option => Val_LLU.Impl.Wrap_Option, - Scan_Based_Number_Ghost => - Val_LLU.Impl.Scan_Based_Number_Ghost, - Prove_Iter_Scan_Based_Number_Ghost => - Val_LLU.Impl.Prove_Iter_Scan_Based_Number_Ghost, - Is_Integer_Ghost => Val_LLI.Impl.Is_Integer_Ghost, - Prove_Scan_Only_Decimal_Ghost => - Val_LLI.Impl.Prove_Scan_Only_Decimal_Ghost, - Abs_Uns_Of_Int => Val_LLI.Impl.Abs_Uns_Of_Int, - Value_Integer => Val_LLI.Impl.Value_Integer); - - package Impl is new Image_I (Int_Params); + package Impl is new Image_I + (Int => Long_Long_Integer, + Uns => Long_Long_Unsigned, + Unsigned_Width_Ghost => + Wid_LLU.Width_Long_Long_Unsigned + (0, Long_Long_Unsigned'Last), + Int_Params => System.Val_LLI.Impl.Spec.Int_Params); procedure Image_Long_Long_Integer (V : Long_Long_Integer; diff --git a/gcc/ada/libgnat/s-imgllli.ads b/gcc/ada/libgnat/s-imgllli.ads index 989c296..931c288 100644 --- a/gcc/ada/libgnat/s-imgllli.ads +++ b/gcc/ada/libgnat/s-imgllli.ads @@ -48,8 +48,6 @@ pragma Assertion_Policy (Pre => Ignore, with System.Image_I; with System.Unsigned_Types; with System.Val_LLLI; -with System.Val_LLLU; -with System.Val_Util; with System.Wid_LLLU; package System.Img_LLLI @@ -57,28 +55,13 @@ package System.Img_LLLI is subtype Long_Long_Long_Unsigned is Unsigned_Types.Long_Long_Long_Unsigned; - package Int_Params is new Val_Util.Int_Params - (Int => Long_Long_Long_Integer, - Uns => Long_Long_Long_Unsigned, - Uns_Option => Val_LLLU.Impl.Uns_Option, - Unsigned_Width_Ghost => + package Impl is new Image_I + (Int => Long_Long_Long_Integer, + Uns => Long_Long_Long_Unsigned, + Unsigned_Width_Ghost => Wid_LLLU.Width_Long_Long_Long_Unsigned (0, Long_Long_Long_Unsigned'Last), - Only_Decimal_Ghost => Val_LLLU.Impl.Only_Decimal_Ghost, - Hexa_To_Unsigned_Ghost => - Val_LLLU.Impl.Hexa_To_Unsigned_Ghost, - Wrap_Option => Val_LLLU.Impl.Wrap_Option, - Scan_Based_Number_Ghost => - Val_LLLU.Impl.Scan_Based_Number_Ghost, - Prove_Iter_Scan_Based_Number_Ghost => - Val_LLLU.Impl.Prove_Iter_Scan_Based_Number_Ghost, - Is_Integer_Ghost => Val_LLLI.Impl.Is_Integer_Ghost, - Prove_Scan_Only_Decimal_Ghost => - Val_LLLI.Impl.Prove_Scan_Only_Decimal_Ghost, - Abs_Uns_Of_Int => Val_LLLI.Impl.Abs_Uns_Of_Int, - Value_Integer => Val_LLLI.Impl.Value_Integer); - - package Impl is new Image_I (Int_Params); + Int_Params => System.Val_LLLI.Impl.Spec.Int_Params); procedure Image_Long_Long_Long_Integer (V : Long_Long_Long_Integer; diff --git a/gcc/ada/libgnat/s-imglllu.ads b/gcc/ada/libgnat/s-imglllu.ads index 0116aa8..53b39a8 100644 --- a/gcc/ada/libgnat/s-imglllu.ads +++ b/gcc/ada/libgnat/s-imglllu.ads @@ -56,23 +56,11 @@ is subtype Long_Long_Long_Unsigned is Unsigned_Types.Long_Long_Long_Unsigned; package Impl is new Image_U - (Uns => Long_Long_Long_Unsigned, - Uns_Option => Val_LLLU.Impl.Uns_Option, - Unsigned_Width_Ghost => + (Uns => Long_Long_Long_Unsigned, + Unsigned_Width_Ghost => Wid_LLLU.Width_Long_Long_Long_Unsigned (0, Long_Long_Long_Unsigned'Last), - Only_Decimal_Ghost => Val_LLLU.Impl.Only_Decimal_Ghost, - Hexa_To_Unsigned_Ghost => - Val_LLLU.Impl.Hexa_To_Unsigned_Ghost, - Wrap_Option => Val_LLLU.Impl.Wrap_Option, - Scan_Based_Number_Ghost => - Val_LLLU.Impl.Scan_Based_Number_Ghost, - Is_Unsigned_Ghost => Val_LLLU.Impl.Is_Unsigned_Ghost, - Value_Unsigned => Val_LLLU.Impl.Value_Unsigned, - Prove_Iter_Scan_Based_Number_Ghost => - Val_LLLU.Impl.Prove_Iter_Scan_Based_Number_Ghost, - Prove_Scan_Only_Decimal_Ghost => - Val_LLLU.Impl.Prove_Scan_Only_Decimal_Ghost); + Uns_Params => System.Val_LLLU.Impl.Spec.Uns_Params); procedure Image_Long_Long_Long_Unsigned (V : Long_Long_Long_Unsigned; diff --git a/gcc/ada/libgnat/s-imgllu.ads b/gcc/ada/libgnat/s-imgllu.ads index 67372d7..28339cd 100644 --- a/gcc/ada/libgnat/s-imgllu.ads +++ b/gcc/ada/libgnat/s-imgllu.ads @@ -56,22 +56,10 @@ is subtype Long_Long_Unsigned is Unsigned_Types.Long_Long_Unsigned; package Impl is new Image_U - (Uns => Long_Long_Unsigned, - Uns_Option => Val_LLU.Impl.Uns_Option, - Unsigned_Width_Ghost => + (Uns => Long_Long_Unsigned, + Unsigned_Width_Ghost => Wid_LLU.Width_Long_Long_Unsigned (0, Long_Long_Unsigned'Last), - Only_Decimal_Ghost => Val_LLU.Impl.Only_Decimal_Ghost, - Hexa_To_Unsigned_Ghost => - Val_LLU.Impl.Hexa_To_Unsigned_Ghost, - Wrap_Option => Val_LLU.Impl.Wrap_Option, - Scan_Based_Number_Ghost => - Val_LLU.Impl.Scan_Based_Number_Ghost, - Is_Unsigned_Ghost => Val_LLU.Impl.Is_Unsigned_Ghost, - Value_Unsigned => Val_LLU.Impl.Value_Unsigned, - Prove_Iter_Scan_Based_Number_Ghost => - Val_LLU.Impl.Prove_Iter_Scan_Based_Number_Ghost, - Prove_Scan_Only_Decimal_Ghost => - Val_LLU.Impl.Prove_Scan_Only_Decimal_Ghost); + Uns_Params => System.Val_LLU.Impl.Spec.Uns_Params); procedure Image_Long_Long_Unsigned (V : Long_Long_Unsigned; diff --git a/gcc/ada/libgnat/s-imguns.ads b/gcc/ada/libgnat/s-imguns.ads index fa903ce..120bd5d 100644 --- a/gcc/ada/libgnat/s-imguns.ads +++ b/gcc/ada/libgnat/s-imguns.ads @@ -56,22 +56,10 @@ is subtype Unsigned is Unsigned_Types.Unsigned; package Impl is new Image_U - (Uns => Unsigned, - Uns_Option => Val_Uns.Impl.Uns_Option, - Unsigned_Width_Ghost => + (Uns => Unsigned, + Unsigned_Width_Ghost => Wid_Uns.Width_Unsigned (0, Unsigned'Last), - Only_Decimal_Ghost => Val_Uns.Impl.Only_Decimal_Ghost, - Hexa_To_Unsigned_Ghost => - Val_Uns.Impl.Hexa_To_Unsigned_Ghost, - Wrap_Option => Val_Uns.Impl.Wrap_Option, - Scan_Based_Number_Ghost => - Val_Uns.Impl.Scan_Based_Number_Ghost, - Is_Unsigned_Ghost => Val_Uns.Impl.Is_Unsigned_Ghost, - Value_Unsigned => Val_Uns.Impl.Value_Unsigned, - Prove_Iter_Scan_Based_Number_Ghost => - Val_Uns.Impl.Prove_Iter_Scan_Based_Number_Ghost, - Prove_Scan_Only_Decimal_Ghost => - Val_Uns.Impl.Prove_Scan_Only_Decimal_Ghost); + Uns_Params => System.Val_Uns.Impl.Spec.Uns_Params); procedure Image_Unsigned (V : Unsigned; 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-vaispe.adb b/gcc/ada/libgnat/s-vaispe.adb new file mode 100644 index 0000000..dca2fd7 --- /dev/null +++ b/gcc/ada/libgnat/s-vaispe.adb @@ -0,0 +1,87 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V A L U E _ I _ S P E C -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2022-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/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma Assertion_Policy (Pre => Ignore, + Post => Ignore, + Contract_Cases => Ignore, + Ghost => Ignore, + Subprogram_Variant => Ignore); + +package body System.Value_I_Spec is + + ----------------------------------- + -- Prove_Scan_Only_Decimal_Ghost -- + ----------------------------------- + + procedure Prove_Scan_Only_Decimal_Ghost (Str : String; Val : Int) is + Non_Blank : constant Positive := First_Non_Space_Ghost + (Str, Str'First, Str'Last); + pragma Assert (Str (Str'First + 1) /= ' '); + pragma Assert + (if Val < 0 then Non_Blank = Str'First + else + Str (Str'First) = ' ' + and then Non_Blank = Str'First + 1); + Minus : constant Boolean := Str (Non_Blank) = '-'; + Fst_Num : constant Positive := + (if Minus then Non_Blank + 1 else Non_Blank); + pragma Assert (Fst_Num = Str'First + 1); + Uval : constant Uns := Abs_Uns_Of_Int (Val); + + procedure Prove_Conversion_Is_Identity (Val : Int; Uval : Uns) + with + Pre => Minus = (Val < 0) + and then Uval = Abs_Uns_Of_Int (Val), + Post => Uns_Is_Valid_Int (Minus, Uval) + and then Is_Int_Of_Uns (Minus, Uval, Val); + -- Local proof of the unicity of the signed representation + + procedure Prove_Conversion_Is_Identity (Val : Int; Uval : Uns) is null; + + -- Start of processing for Prove_Scan_Only_Decimal_Ghost + + begin + Prove_Conversion_Is_Identity (Val, Uval); + pragma Assert + (Uns_Params.Is_Raw_Unsigned_Format_Ghost (Str (Fst_Num .. Str'Last))); + pragma Assert + (Uns_Params.Scan_Split_No_Overflow_Ghost (Str, Fst_Num, Str'Last)); + Uns_Params.Lemma_Exponent_Unsigned_Ghost_Base (Uval, 0, 10); + pragma Assert + (Uns_Params.Raw_Unsigned_No_Overflow_Ghost (Str, Fst_Num, Str'Last)); + pragma Assert (Only_Space_Ghost + (Str, Uns_Params.Raw_Unsigned_Last_Ghost + (Str, Fst_Num, Str'Last), Str'Last)); + pragma Assert (Is_Integer_Ghost (Str)); + pragma Assert (Is_Value_Integer_Ghost (Str, Val)); + end Prove_Scan_Only_Decimal_Ghost; + +end System.Value_I_Spec; diff --git a/gcc/ada/libgnat/s-vaispe.ads b/gcc/ada/libgnat/s-vaispe.ads new file mode 100644 index 0000000..5a5e051 --- /dev/null +++ b/gcc/ada/libgnat/s-vaispe.ads @@ -0,0 +1,199 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V A L U E _ I _ S P E C -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2022-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/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the specification entities using for the formal +-- verification of the routines for scanning signed integer values. + +-- Preconditions in this unit are meant for analysis only, not for run-time +-- checking, so that the expected exceptions are raised. This is enforced by +-- setting the corresponding assertion policy to Ignore. Postconditions and +-- contract cases should not be executed at runtime as well, in order not to +-- slow down the execution of these functions. + +pragma Assertion_Policy (Pre => Ignore, + Post => Ignore, + Contract_Cases => Ignore, + Ghost => Ignore, + Subprogram_Variant => Ignore); + +with System.Val_Util; use System.Val_Util; + +generic + + type Int is range <>; + + type Uns is mod <>; + + -- Additional parameters for specification subprograms on modular Unsigned + -- integers. + + with package Uns_Params is new System.Val_Util.Uns_Params + (Uns => Uns, others => <>) + with Ghost; + +package System.Value_I_Spec with + Ghost, + SPARK_Mode, + Annotate => (GNATprove, Always_Return) +is + pragma Preelaborate; + use all type Uns_Params.Uns_Option; + + function Uns_Is_Valid_Int (Minus : Boolean; Uval : Uns) return Boolean is + (if Minus then Uval <= Uns (Int'Last) + 1 + else Uval <= Uns (Int'Last)) + with Post => True; + -- Return True if Uval (or -Uval when Minus is True) is a valid number of + -- type Int. + + function Is_Int_Of_Uns + (Minus : Boolean; + Uval : Uns; + Val : Int) + return Boolean + is + (if Minus and then Uval = Uns (Int'Last) + 1 then Val = Int'First + elsif Minus then Val = -(Int (Uval)) + else Val = Int (Uval)) + with + Pre => Uns_Is_Valid_Int (Minus, Uval), + Post => True; + -- Return True if Uval (or -Uval when Minus is True) is equal to Val + + function Abs_Uns_Of_Int (Val : Int) return Uns is + (if Val = Int'First then Uns (Int'Last) + 1 + elsif Val < 0 then Uns (-Val) + else Uns (Val)); + -- Return the unsigned absolute value of Val + + function Slide_To_1 (Str : String) return String + with + Post => + Only_Space_Ghost (Str, Str'First, Str'Last) = + (for all J in Str'First .. Str'Last => + Slide_To_1'Result (J - Str'First + 1) = ' '); + -- Slides Str so that it starts at 1 + + function Slide_If_Necessary (Str : String) return String is + (if Str'Last = Positive'Last then Slide_To_1 (Str) else Str); + -- If Str'Last = Positive'Last then slides Str so that it starts at 1 + + function Is_Integer_Ghost (Str : String) return Boolean is + (declare + Non_Blank : constant Positive := First_Non_Space_Ghost + (Str, Str'First, Str'Last); + Fst_Num : constant Positive := + (if Str (Non_Blank) in '+' | '-' then Non_Blank + 1 else Non_Blank); + begin + Uns_Params.Is_Raw_Unsigned_Format_Ghost (Str (Fst_Num .. Str'Last)) + and then Uns_Params.Raw_Unsigned_No_Overflow_Ghost + (Str, Fst_Num, Str'Last) + and then + Uns_Is_Valid_Int + (Minus => Str (Non_Blank) = '-', + Uval => Uns_Params.Scan_Raw_Unsigned_Ghost + (Str, Fst_Num, Str'Last)) + and then Only_Space_Ghost + (Str, Uns_Params.Raw_Unsigned_Last_Ghost + (Str, Fst_Num, Str'Last), Str'Last)) + with + Pre => not Only_Space_Ghost (Str, Str'First, Str'Last) + and then Str'Last /= Positive'Last, + Post => True; + -- Ghost function that determines if Str has the correct format for a + -- signed number, consisting in some blank characters, an optional + -- sign, a raw unsigned number which does not overflow and then some + -- more blank characters. + + function Is_Value_Integer_Ghost (Str : String; Val : Int) return Boolean is + (declare + Non_Blank : constant Positive := First_Non_Space_Ghost + (Str, Str'First, Str'Last); + Fst_Num : constant Positive := + (if Str (Non_Blank) in '+' | '-' then Non_Blank + 1 else Non_Blank); + Uval : constant Uns := + Uns_Params.Scan_Raw_Unsigned_Ghost (Str, Fst_Num, Str'Last); + begin + Is_Int_Of_Uns (Minus => Str (Non_Blank) = '-', + Uval => Uval, + Val => Val)) + with + Pre => not Only_Space_Ghost (Str, Str'First, Str'Last) + and then Str'Last /= Positive'Last + and then Is_Integer_Ghost (Str), + Post => True; + -- Ghost function that returns True if Val is the value corresponding to + -- the signed number represented by Str. + + procedure Prove_Scan_Only_Decimal_Ghost (Str : String; Val : Int) + with + Ghost, + Pre => Str'Last /= Positive'Last + and then Str'Length >= 2 + and then Str (Str'First) in ' ' | '-' + and then (Str (Str'First) = '-') = (Val < 0) + and then Uns_Params.Only_Decimal_Ghost (Str, Str'First + 1, Str'Last) + and then Uns_Params.Scan_Based_Number_Ghost + (Str, Str'First + 1, Str'Last) + = Uns_Params.Wrap_Option (Abs_Uns_Of_Int (Val)), + Post => Is_Integer_Ghost (Slide_If_Necessary (Str)) + and then Is_Value_Integer_Ghost (Str, Val); + -- Ghost lemma used in the proof of 'Image implementation, to prove that + -- the result of Value_Integer on a decimal string is the same as the + -- signing the result of Scan_Based_Number_Ghost. + + -- Bundle Int type with other types, constants and subprograms used in + -- ghost code, so that this package can be instantiated once and used + -- multiple times as generic formal for a given Int type. + + package Int_Params is new System.Val_Util.Int_Params + (Uns => Uns, + Int => Int, + P_Uns_Params => Uns_Params, + P_Is_Integer_Ghost => Is_Integer_Ghost, + P_Is_Value_Integer_Ghost => Is_Value_Integer_Ghost, + P_Is_Int_Of_Uns => Is_Int_Of_Uns, + P_Abs_Uns_Of_Int => Abs_Uns_Of_Int, + P_Prove_Scan_Only_Decimal_Ghost => Prove_Scan_Only_Decimal_Ghost); + +private + + ---------------- + -- Slide_To_1 -- + ---------------- + + function Slide_To_1 (Str : String) return String is + (declare + Res : constant String (1 .. Str'Length) := Str; + begin + Res); + +end System.Value_I_Spec; diff --git a/gcc/ada/libgnat/s-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-valint.ads b/gcc/ada/libgnat/s-valint.ads index 9e47f1b..3872d7c 100644 --- a/gcc/ada/libgnat/s-valint.ads +++ b/gcc/ada/libgnat/s-valint.ads @@ -54,23 +54,10 @@ package System.Val_Int with SPARK_Mode is subtype Unsigned is Unsigned_Types.Unsigned; package Impl is new Value_I - (Int => Integer, - Uns => Unsigned, - Scan_Raw_Unsigned => Val_Uns.Scan_Raw_Unsigned, - Uns_Option => Val_Uns.Impl.Uns_Option, - Wrap_Option => Val_Uns.Impl.Wrap_Option, - Is_Raw_Unsigned_Format_Ghost => - Val_Uns.Impl.Is_Raw_Unsigned_Format_Ghost, - Raw_Unsigned_Overflows_Ghost => - Val_Uns.Impl.Raw_Unsigned_Overflows_Ghost, - Scan_Raw_Unsigned_Ghost => - Val_Uns.Impl.Scan_Raw_Unsigned_Ghost, - Raw_Unsigned_Last_Ghost => - Val_Uns.Impl.Raw_Unsigned_Last_Ghost, - Only_Decimal_Ghost => - Val_Uns.Impl.Only_Decimal_Ghost, - Scan_Based_Number_Ghost => - Val_Uns.Impl.Scan_Based_Number_Ghost); + (Int => Integer, + Uns => Unsigned, + Scan_Raw_Unsigned => Val_Uns.Scan_Raw_Unsigned, + Uns_Params => System.Val_Uns.Impl.Spec.Uns_Params); procedure Scan_Integer (Str : String; 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-vallli.ads b/gcc/ada/libgnat/s-vallli.ads index 5bccb1a..85bf282 100644 --- a/gcc/ada/libgnat/s-vallli.ads +++ b/gcc/ada/libgnat/s-vallli.ads @@ -54,24 +54,10 @@ package System.Val_LLI with SPARK_Mode is subtype Long_Long_Unsigned is Unsigned_Types.Long_Long_Unsigned; package Impl is new Value_I - (Int => Long_Long_Integer, - Uns => Long_Long_Unsigned, - Scan_Raw_Unsigned => - Val_LLU.Scan_Raw_Long_Long_Unsigned, - Uns_Option => Val_LLU.Impl.Uns_Option, - Wrap_Option => Val_LLU.Impl.Wrap_Option, - Is_Raw_Unsigned_Format_Ghost => - Val_LLU.Impl.Is_Raw_Unsigned_Format_Ghost, - Raw_Unsigned_Overflows_Ghost => - Val_LLU.Impl.Raw_Unsigned_Overflows_Ghost, - Scan_Raw_Unsigned_Ghost => - Val_LLU.Impl.Scan_Raw_Unsigned_Ghost, - Raw_Unsigned_Last_Ghost => - Val_LLU.Impl.Raw_Unsigned_Last_Ghost, - Only_Decimal_Ghost => - Val_LLU.Impl.Only_Decimal_Ghost, - Scan_Based_Number_Ghost => - Val_LLU.Impl.Scan_Based_Number_Ghost); + (Int => Long_Long_Integer, + Uns => Long_Long_Unsigned, + Scan_Raw_Unsigned => Val_LLU.Scan_Raw_Long_Long_Unsigned, + Uns_Params => System.Val_LLU.Impl.Spec.Uns_Params); procedure Scan_Long_Long_Integer (Str : String; diff --git a/gcc/ada/libgnat/s-valllli.ads b/gcc/ada/libgnat/s-valllli.ads index 586c737..e53fb0b 100644 --- a/gcc/ada/libgnat/s-valllli.ads +++ b/gcc/ada/libgnat/s-valllli.ads @@ -54,24 +54,10 @@ package System.Val_LLLI with SPARK_Mode is subtype Long_Long_Long_Unsigned is Unsigned_Types.Long_Long_Long_Unsigned; package Impl is new Value_I - (Int => Long_Long_Long_Integer, - Uns => Long_Long_Long_Unsigned, - Scan_Raw_Unsigned => - Val_LLLU.Scan_Raw_Long_Long_Long_Unsigned, - Uns_Option => Val_LLLU.Impl.Uns_Option, - Wrap_Option => Val_LLLU.Impl.Wrap_Option, - Is_Raw_Unsigned_Format_Ghost => - Val_LLLU.Impl.Is_Raw_Unsigned_Format_Ghost, - Raw_Unsigned_Overflows_Ghost => - Val_LLLU.Impl.Raw_Unsigned_Overflows_Ghost, - Scan_Raw_Unsigned_Ghost => - Val_LLLU.Impl.Scan_Raw_Unsigned_Ghost, - Raw_Unsigned_Last_Ghost => - Val_LLLU.Impl.Raw_Unsigned_Last_Ghost, - Only_Decimal_Ghost => - Val_LLLU.Impl.Only_Decimal_Ghost, - Scan_Based_Number_Ghost => - Val_LLLU.Impl.Scan_Based_Number_Ghost); + (Int => Long_Long_Long_Integer, + Uns => Long_Long_Long_Unsigned, + Scan_Raw_Unsigned => Val_LLLU.Scan_Raw_Long_Long_Long_Unsigned, + Uns_Params => System.Val_LLLU.Impl.Spec.Uns_Params); procedure Scan_Long_Long_Long_Integer (Str : String; 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-valuei.adb b/gcc/ada/libgnat/s-valuei.adb index b453ffc..51764b2 100644 --- a/gcc/ada/libgnat/s-valuei.adb +++ b/gcc/ada/libgnat/s-valuei.adb @@ -41,59 +41,6 @@ package body System.Value_I is Assert_And_Cut => Ignore, Subprogram_Variant => Ignore); - ----------------------------------- - -- Prove_Scan_Only_Decimal_Ghost -- - ----------------------------------- - - procedure Prove_Scan_Only_Decimal_Ghost (Str : String; Val : Int) is - Non_Blank : constant Positive := First_Non_Space_Ghost - (Str, Str'First, Str'Last); - pragma Assert - (if Val < 0 then Non_Blank = Str'First - else - Only_Space_Ghost (Str, Str'First, Str'First) - and then Non_Blank = Str'First + 1); - Minus : constant Boolean := Str (Non_Blank) = '-'; - Fst_Num : constant Positive := - (if Minus then Non_Blank + 1 else Non_Blank); - pragma Assert (Fst_Num = Str'First + 1); - Uval : constant Uns := - Scan_Raw_Unsigned_Ghost (Str, Fst_Num, Str'Last); - - procedure Unique_Int_Of_Uns (Val1, Val2 : Int) - with - Pre => Uns_Is_Valid_Int (Minus, Uval) - and then Is_Int_Of_Uns (Minus, Uval, Val1) - and then Is_Int_Of_Uns (Minus, Uval, Val2), - Post => Val1 = Val2; - -- Local proof of the unicity of the signed representation - - procedure Unique_Int_Of_Uns (Val1, Val2 : Int) is null; - - -- Start of processing for Prove_Scan_Only_Decimal_Ghost - - begin - pragma Assert (Minus = (Val < 0)); - pragma Assert (Uval = Abs_Uns_Of_Int (Val)); - pragma Assert (if Minus then Uval <= Uns (Int'Last) + 1 - else Uval <= Uns (Int'Last)); - pragma Assert (Uns_Is_Valid_Int (Minus, Uval)); - pragma Assert - (if Minus and then Uval = Uns (Int'Last) + 1 then Val = Int'First - elsif Minus then Val = -(Int (Uval)) - else Val = Int (Uval)); - pragma Assert (Is_Int_Of_Uns (Minus, Uval, Val)); - pragma Assert - (Is_Raw_Unsigned_Format_Ghost (Str (Fst_Num .. Str'Last))); - pragma Assert - (not Raw_Unsigned_Overflows_Ghost (Str, Fst_Num, Str'Last)); - pragma Assert (Only_Space_Ghost - (Str, Raw_Unsigned_Last_Ghost (Str, Fst_Num, Str'Last), Str'Last)); - pragma Assert (Is_Integer_Ghost (Str)); - pragma Assert (Is_Value_Integer_Ghost (Str, Val)); - Unique_Int_Of_Uns (Val, Value_Integer (Str)); - end Prove_Scan_Only_Decimal_Ghost; - ------------------ -- Scan_Integer -- ------------------ @@ -104,6 +51,25 @@ package body System.Value_I is Max : Integer; Res : out Int) is + procedure Prove_Is_Int_Of_Uns + (Minus : Boolean; + Uval : Uns; + Val : Int) + with Ghost, + Pre => Spec.Uns_Is_Valid_Int (Minus, Uval) + and then + (if Minus and then Uval = Uns (Int'Last) + 1 then Val = Int'First + elsif Minus then Val = -(Int (Uval)) + else Val = Int (Uval)), + Post => Spec.Is_Int_Of_Uns (Minus, Uval, Val); + -- Unfold the definition of Is_Int_Of_Uns + + procedure Prove_Is_Int_Of_Uns + (Minus : Boolean; + Uval : Uns; + Val : Int) + is null; + Uval : Uns; -- Unsigned result @@ -131,7 +97,8 @@ package body System.Value_I is end if; Scan_Raw_Unsigned (Str, Ptr, Max, Uval); - pragma Assert (Uval = Scan_Raw_Unsigned_Ghost (Str, Fst_Num, Max)); + pragma Assert + (Uval = Uns_Params.Scan_Raw_Unsigned_Ghost (Str, Fst_Num, Max)); -- Deal with overflow cases, and also with largest negative number @@ -152,6 +119,11 @@ package body System.Value_I is else Res := Int (Uval); end if; + + Prove_Is_Int_Of_Uns + (Minus => Str (Non_Blank) = '-', + Uval => Uval, + Val => Res); end Scan_Integer; ------------------- @@ -167,7 +139,15 @@ package body System.Value_I is if Str'Last = Positive'Last then declare subtype NT is String (1 .. Str'Length); + procedure Prove_Is_Integer_Ghost with + Ghost, + Pre => Str'Length < Natural'Last + and then not Only_Space_Ghost (Str, Str'First, Str'Last) + and then Spec.Is_Integer_Ghost (Spec.Slide_To_1 (Str)), + Post => Spec.Is_Integer_Ghost (NT (Str)); + procedure Prove_Is_Integer_Ghost is null; begin + Prove_Is_Integer_Ghost; return Value_Integer (NT (Str)); end; @@ -187,8 +167,6 @@ package body System.Value_I is else Non_Blank) with Ghost; begin - pragma Assert - (Is_Raw_Unsigned_Format_Ghost (Str (Fst_Num .. Str'Last))); declare P_Acc : constant not null access Integer := P'Access; @@ -197,12 +175,13 @@ package body System.Value_I is end; pragma Assert - (P = Raw_Unsigned_Last_Ghost (Str, Fst_Num, Str'Last)); + (P = Uns_Params.Raw_Unsigned_Last_Ghost + (Str, Fst_Num, Str'Last)); Scan_Trailing_Blanks (Str, P); pragma Assert - (Is_Value_Integer_Ghost (Slide_If_Necessary (Str), V)); + (Spec.Is_Value_Integer_Ghost (Spec.Slide_If_Necessary (Str), V)); return V; end; end if; diff --git a/gcc/ada/libgnat/s-valuei.ads b/gcc/ada/libgnat/s-valuei.ads index 5e42773..3f78db6 100644 --- a/gcc/ada/libgnat/s-valuei.ads +++ b/gcc/ada/libgnat/s-valuei.ads @@ -39,6 +39,7 @@ pragma Assertion_Policy (Pre => Ignore, Subprogram_Variant => Ignore); with System.Val_Util; use System.Val_Util; +with System.Value_I_Spec; generic @@ -54,71 +55,15 @@ generic -- Additional parameters for ghost subprograms used inside contracts - type Uns_Option is private; - with function Wrap_Option (Value : Uns) return Uns_Option - with Ghost; - with function Is_Raw_Unsigned_Format_Ghost (Str : String) return Boolean - with Ghost; - with function Raw_Unsigned_Overflows_Ghost - (Str : String; - From, To : Integer) - return Boolean - with Ghost; - with function Scan_Raw_Unsigned_Ghost - (Str : String; - From, To : Integer) - return Uns - with Ghost; - with function Raw_Unsigned_Last_Ghost - (Str : String; - From, To : Integer) - return Positive - with Ghost; - with function Only_Decimal_Ghost - (Str : String; - From, To : Integer) - return Boolean - with Ghost; - with function Scan_Based_Number_Ghost - (Str : String; - From, To : Integer; - Base : Uns := 10; - Acc : Uns := 0) - return Uns_Option - with Ghost; + with package Uns_Params is new System.Val_Util.Uns_Params + (Uns => Uns, others => <>) + with Ghost; package System.Value_I is pragma Preelaborate; + use all type Uns_Params.Uns_Option; - function Uns_Is_Valid_Int (Minus : Boolean; Uval : Uns) return Boolean is - (if Minus then Uval <= Uns (Int'Last) + 1 - else Uval <= Uns (Int'Last)) - with Ghost, - Post => True; - -- Return True if Uval (or -Uval when Minus is True) is a valid number of - -- type Int. - - function Is_Int_Of_Uns - (Minus : Boolean; - Uval : Uns; - Val : Int) - return Boolean - is - (if Minus and then Uval = Uns (Int'Last) + 1 then Val = Int'First - elsif Minus then Val = -(Int (Uval)) - else Val = Int (Uval)) - with - Ghost, - Pre => Uns_Is_Valid_Int (Minus, Uval), - Post => True; - -- Return True if Uval (or -Uval when Minus is True) is equal to Val - - function Abs_Uns_Of_Int (Val : Int) return Uns is - (if Val = Int'First then Uns (Int'Last) + 1 - elsif Val < 0 then Uns (-Val) - else Uns (Val)) - with Ghost; - -- Return the unsigned absolute value of Val + package Spec is new System.Value_I_Spec (Int, Uns, Uns_Params); procedure Scan_Integer (Str : String; @@ -139,11 +84,13 @@ package System.Value_I is (if Str (Non_Blank) in '+' | '-' then Non_Blank + 1 else Non_Blank); begin - Is_Raw_Unsigned_Format_Ghost (Str (Fst_Num .. Max)) - and then not Raw_Unsigned_Overflows_Ghost (Str, Fst_Num, Max) - and then Uns_Is_Valid_Int + Uns_Params.Is_Raw_Unsigned_Format_Ghost (Str (Fst_Num .. Max)) + and then Uns_Params.Raw_Unsigned_No_Overflow_Ghost + (Str, Fst_Num, Max) + and then Spec.Uns_Is_Valid_Int (Minus => Str (Non_Blank) = '-', - Uval => Scan_Raw_Unsigned_Ghost (Str, Fst_Num, Max))), + Uval => Uns_Params.Scan_Raw_Unsigned_Ghost + (Str, Fst_Num, Max))), Post => (declare Non_Blank : constant Positive := First_Non_Space_Ghost @@ -152,12 +99,13 @@ package System.Value_I is (if Str (Non_Blank) in '+' | '-' then Non_Blank + 1 else Non_Blank); Uval : constant Uns := - Scan_Raw_Unsigned_Ghost (Str, Fst_Num, Max); + Uns_Params.Scan_Raw_Unsigned_Ghost (Str, Fst_Num, Max); begin - Is_Int_Of_Uns (Minus => Str (Non_Blank) = '-', - Uval => Uval, - Val => Res) - and then Ptr.all = Raw_Unsigned_Last_Ghost (Str, Fst_Num, Max)); + Spec.Is_Int_Of_Uns (Minus => Str (Non_Blank) = '-', + Uval => Uval, + Val => Res) + and then Ptr.all = Uns_Params.Raw_Unsigned_Last_Ghost + (Str, Fst_Num, Max)); -- This procedure scans the string starting at Str (Ptr.all) for a valid -- integer according to the syntax described in (RM 3.5(43)). The substring -- scanned extends no further than Str (Max). There are three cases for the @@ -183,111 +131,17 @@ package System.Value_I is -- special case of an all-blank string, and Ptr is unchanged, and hence -- is greater than Max as required in this case. - function Slide_To_1 (Str : String) return String - with - Ghost, - Post => - Only_Space_Ghost (Str, Str'First, Str'Last) = - (for all J in Str'First .. Str'Last => - Slide_To_1'Result (J - Str'First + 1) = ' '); - -- Slides Str so that it starts at 1 - - function Slide_If_Necessary (Str : String) return String is - (if Str'Last = Positive'Last then Slide_To_1 (Str) else Str) - with - Ghost, - Post => - Only_Space_Ghost (Str, Str'First, Str'Last) = - Only_Space_Ghost (Slide_If_Necessary'Result, - Slide_If_Necessary'Result'First, - Slide_If_Necessary'Result'Last); - -- If Str'Last = Positive'Last then slides Str so that it starts at 1 - - function Is_Integer_Ghost (Str : String) return Boolean is - (declare - Non_Blank : constant Positive := First_Non_Space_Ghost - (Str, Str'First, Str'Last); - Fst_Num : constant Positive := - (if Str (Non_Blank) in '+' | '-' then Non_Blank + 1 else Non_Blank); - begin - Is_Raw_Unsigned_Format_Ghost (Str (Fst_Num .. Str'Last)) - and then not Raw_Unsigned_Overflows_Ghost (Str, Fst_Num, Str'Last) - and then - Uns_Is_Valid_Int - (Minus => Str (Non_Blank) = '-', - Uval => Scan_Raw_Unsigned_Ghost (Str, Fst_Num, Str'Last)) - and then Only_Space_Ghost - (Str, Raw_Unsigned_Last_Ghost (Str, Fst_Num, Str'Last), Str'Last)) - with - Ghost, - Pre => not Only_Space_Ghost (Str, Str'First, Str'Last) - and then Str'Last /= Positive'Last, - Post => True; - -- Ghost function that determines if Str has the correct format for a - -- signed number, consisting in some blank characters, an optional - -- sign, a raw unsigned number which does not overflow and then some - -- more blank characters. - - function Is_Value_Integer_Ghost (Str : String; Val : Int) return Boolean is - (declare - Non_Blank : constant Positive := First_Non_Space_Ghost - (Str, Str'First, Str'Last); - Fst_Num : constant Positive := - (if Str (Non_Blank) in '+' | '-' then Non_Blank + 1 else Non_Blank); - Uval : constant Uns := - Scan_Raw_Unsigned_Ghost (Str, Fst_Num, Str'Last); - begin - Is_Int_Of_Uns (Minus => Str (Non_Blank) = '-', - Uval => Uval, - Val => Val)) - with - Ghost, - Pre => not Only_Space_Ghost (Str, Str'First, Str'Last) - and then Str'Last /= Positive'Last - and then Is_Integer_Ghost (Str), - Post => True; - -- Ghost function that returns True if Val is the value corresponding to - -- the signed number represented by Str. - function Value_Integer (Str : String) return Int with Pre => not Only_Space_Ghost (Str, Str'First, Str'Last) and then Str'Length /= Positive'Last - and then Is_Integer_Ghost (Slide_If_Necessary (Str)), - Post => Is_Value_Integer_Ghost - (Slide_If_Necessary (Str), Value_Integer'Result), + and then Spec.Is_Integer_Ghost (Spec.Slide_If_Necessary (Str)), + Post => Spec.Is_Value_Integer_Ghost + (Spec.Slide_If_Necessary (Str), Value_Integer'Result), Subprogram_Variant => (Decreases => Str'First); -- Used in computing X'Value (Str) where X is a signed integer type whose -- base range does not exceed the base range of Integer. Str is the string -- argument of the attribute. Constraint_Error is raised if the string is -- malformed, or if the value is out of range. - procedure Prove_Scan_Only_Decimal_Ghost (Str : String; Val : Int) - with - Ghost, - Pre => Str'Last /= Positive'Last - and then Str'Length >= 2 - and then Str (Str'First) in ' ' | '-' - and then (Str (Str'First) = '-') = (Val < 0) - and then Only_Decimal_Ghost (Str, Str'First + 1, Str'Last) - and then Scan_Based_Number_Ghost (Str, Str'First + 1, Str'Last) - = Wrap_Option (Abs_Uns_Of_Int (Val)), - Post => Is_Integer_Ghost (Slide_If_Necessary (Str)) - and then Value_Integer (Str) = Val; - -- Ghost lemma used in the proof of 'Image implementation, to prove that - -- the result of Value_Integer on a decimal string is the same as the - -- signing the result of Scan_Based_Number_Ghost. - -private - - ---------------- - -- Slide_To_1 -- - ---------------- - - function Slide_To_1 (Str : String) return String is - (declare - Res : constant String (1 .. Str'Length) := Str; - begin - Res); - end System.Value_I; diff --git a/gcc/ada/libgnat/s-valuer.adb b/gcc/ada/libgnat/s-valuer.adb index b474f84..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); @@ -184,7 +187,7 @@ package body System.Value_R is UmaxB : constant Uns := Precision_Limit / Uns (Base); -- Numbers bigger than UmaxB overflow if multiplied by base - Precision_Limit_Reached : Boolean := False; + Precision_Limit_Reached : Boolean; -- Set to True if addition of a digit will cause Value to be superior -- to Precision_Limit. @@ -198,23 +201,28 @@ package body System.Value_R is Temp : Uns; -- Temporary - Trailing_Zeros : Natural := 0; + Trailing_Zeros : Natural; -- Number of trailing zeros at a given point begin -- If initial Scale is not 0 then it means that Precision_Limit was -- reached during scanning of the integral part. - if Scale > 0 then + if Scale (Data_Index'Last) > 0 then Precision_Limit_Reached := True; else Extra := 0; + Precision_Limit_Reached := False; end if; if Round then Precision_Limit_Just_Reached := False; end if; + -- Initialize trailing zero counter + + Trailing_Zeros := 0; + -- The function precondition is that the first character is a valid -- digit. @@ -242,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; @@ -253,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; @@ -276,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 @@ -287,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; @@ -347,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); @@ -362,7 +381,7 @@ package body System.Value_R is UmaxB : constant Uns := Precision_Limit / Uns (Base); -- Numbers bigger than UmaxB overflow if multiplied by base - Precision_Limit_Reached : Boolean := False; + Precision_Limit_Reached : Boolean; -- Set to True if addition of a digit will cause Value to be superior -- to Precision_Limit. @@ -377,12 +396,15 @@ 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; + if Round then Precision_Limit_Just_Reached := False; end if; @@ -415,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; @@ -444,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; @@ -485,37 +517,44 @@ 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); After_Point : Boolean; -- True if a decimal should be parsed - Base_Char : Character := ASCII.NUL; - -- Character used to set the base. If Nul this means that default + Base_Char : Character; + -- Character used to set the base. If it is Nul, this means that default -- base is used. - Base_Violation : Boolean := False; + Base_Violation : Boolean; -- 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 + Index : Integer; -- Local copy of string pointer Start : Positive; + -- Index of the first non-blank character - Value : Uns; - -- Mantissa as an Integer - - Expon : Integer; + Value : Value_Array; + -- Mantissa as an array of integers begin -- The default base is 10 - Base := 10; + Base := 10; + Base_Char := ASCII.NUL; + Base_Violation := False; -- We do not tolerate strings with Str'Last = Positive'Last @@ -543,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)) @@ -554,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 @@ -571,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; @@ -586,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; @@ -598,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? @@ -625,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 @@ -649,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 @@ -661,7 +707,6 @@ package body System.Value_R is else return Value; end if; - end Scan_Raw_Real; -------------------- @@ -671,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 @@ -686,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/s-valueu.adb b/gcc/ada/libgnat/s-valueu.adb index f5a6881..8f19086 100644 --- a/gcc/ada/libgnat/s-valueu.adb +++ b/gcc/ada/libgnat/s-valueu.adb @@ -41,9 +41,12 @@ package body System.Value_U is Assert_And_Cut => Ignore, Subprogram_Variant => Ignore); + use type Spec.Uns_Option; + use type Spec.Split_Value_Ghost; + -- Local lemmas - procedure Lemma_Digit_Is_Before_Last + procedure Lemma_Digit_Not_Last (Str : String; P : Integer; From : Integer; @@ -54,257 +57,47 @@ package body System.Value_U is and then To in From .. Str'Last and then Str (From) in '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' and then P in From .. To - and then Str (P) in '0' .. '9' | 'a' .. 'f' | 'A' .. 'F', - Post => P /= Last_Hexa_Ghost (Str (From .. To)) + 1; - -- If the character at position P is a digit, P cannot be the position of - -- of the first non-digit in Str. + and then P <= Spec.Last_Hexa_Ghost (Str (From .. To)) + 1 + and then Spec.Is_Based_Format_Ghost (Str (From .. To)), + Post => + (if Str (P) in '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' + then P <= Spec.Last_Hexa_Ghost (Str (From .. To))); - procedure Lemma_End_Of_Scan + procedure Lemma_Underscore_Not_Last (Str : String; + P : Integer; From : Integer; - To : Integer; - Base : Uns; - Acc : Uns) - with Ghost, - Pre => Str'Last /= Positive'Last and then From > To, - Post => Scan_Based_Number_Ghost (Str, From, To, Base, Acc) = - (False, Acc); - -- Unfold the definition of Scan_Based_Number_Ghost on an empty string - - procedure Lemma_Scan_Digit - (Str : String; - P : Integer; - Lst : Integer; - Digit : Uns; - Base : Uns; - Old_Acc : Uns; - Acc : Uns; - Scan_Val : Uns_Option; - Old_Overflow : Boolean; - Overflow : Boolean) - with Ghost, - Pre => Str'Last /= Positive'Last - and then Lst in Str'Range - and then P in Str'First .. Lst - and then Str (P) in '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' - and then Digit = Hexa_To_Unsigned_Ghost (Str (P)) - and then Only_Hexa_Ghost (Str, P, Lst) - and then Base in 2 .. 16 - and then (if Digit < Base and then Old_Acc <= Uns'Last / Base - then Acc = Base * Old_Acc + Digit) - and then (if Digit >= Base - or else Old_Acc > Uns'Last / Base - or else (Old_Acc > (Uns'Last - Base + 1) / Base - and then Acc < Uns'Last / Base) - then Overflow - else Overflow = Old_Overflow) - and then - (if not Old_Overflow then - Scan_Val = Scan_Based_Number_Ghost - (Str, P, Lst, Base, Old_Acc)), - Post => - (if not Overflow then - Scan_Val = Scan_Based_Number_Ghost - (Str, P + 1, Lst, Base, Acc)) - and then - (if Overflow then Old_Overflow or else Scan_Val.Overflow); - -- Unfold the definition of Scan_Based_Number_Ghost when the string starts - -- with a digit. - - procedure Lemma_Scan_Underscore - (Str : String; - P : Integer; - From : Integer; - To : Integer; - Lst : Integer; - Base : Uns; - Acc : Uns; - Scan_Val : Uns_Option; - Overflow : Boolean; - Ext : Boolean) + To : Integer) with Ghost, Pre => Str'Last /= Positive'Last and then From in Str'Range and then To in From .. Str'Last - and then Lst <= To - and then P in From .. Lst + 1 - and then P <= To - and then - (if Ext then - Is_Based_Format_Ghost (Str (From .. To)) - and then Lst = Last_Hexa_Ghost (Str (From .. To)) - else Is_Natural_Format_Ghost (Str (From .. To)) - and then Lst = Last_Number_Ghost (Str (From .. To))) + and then Str (From) in '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' + and then P in From .. To and then Str (P) = '_' - and then - (if not Overflow then - Scan_Val = Scan_Based_Number_Ghost (Str, P, Lst, Base, Acc)), - Post => P + 1 <= Lst - and then - (if Ext then Str (P + 1) in '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' - else Str (P + 1) in '0' .. '9') - and then - (if not Overflow then - Scan_Val = Scan_Based_Number_Ghost (Str, P + 1, Lst, Base, Acc)); - -- Unfold the definition of Scan_Based_Number_Ghost when the string starts - -- with an underscore. + and then P <= Spec.Last_Hexa_Ghost (Str (From .. To)) + 1 + and then Spec.Is_Based_Format_Ghost (Str (From .. To)), + Post => P + 1 <= Spec.Last_Hexa_Ghost (Str (From .. To)) + and then Str (P + 1) in '0' .. '9' | 'a' .. 'f' | 'A' .. 'F'; ----------------------------- -- Local lemma null bodies -- ----------------------------- - procedure Lemma_Digit_Is_Before_Last + procedure Lemma_Digit_Not_Last (Str : String; P : Integer; From : Integer; To : Integer) is null; - procedure Lemma_End_Of_Scan - (Str : String; - From : Integer; - To : Integer; - Base : Uns; - Acc : Uns) - is null; - - procedure Lemma_Scan_Underscore - (Str : String; - P : Integer; - From : Integer; - To : Integer; - Lst : Integer; - Base : Uns; - Acc : Uns; - Scan_Val : Uns_Option; - Overflow : Boolean; - Ext : Boolean) + procedure Lemma_Underscore_Not_Last + (Str : String; + P : Integer; + From : Integer; + To : Integer) is null; - --------------------- - -- Last_Hexa_Ghost -- - --------------------- - - function Last_Hexa_Ghost (Str : String) return Positive is - begin - for J in Str'Range loop - if Str (J) not in '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' | '_' then - return J - 1; - end if; - - pragma Loop_Invariant - (for all K in Str'First .. J => - Str (K) in '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' | '_'); - end loop; - - return Str'Last; - end Last_Hexa_Ghost; - - ---------------------- - -- Lemma_Scan_Digit -- - ---------------------- - - procedure Lemma_Scan_Digit - (Str : String; - P : Integer; - Lst : Integer; - Digit : Uns; - Base : Uns; - Old_Acc : Uns; - Acc : Uns; - Scan_Val : Uns_Option; - Old_Overflow : Boolean; - Overflow : Boolean) - is - pragma Unreferenced (Str, P, Lst, Scan_Val, Overflow, Old_Overflow); - begin - if Digit >= Base then - null; - - elsif Old_Acc <= (Uns'Last - Base + 1) / Base then - pragma Assert (not Scan_Overflows_Ghost (Digit, Base, Old_Acc)); - - elsif Old_Acc > Uns'Last / Base then - null; - - else - pragma Assert - ((Acc < Uns'Last / Base) = - Scan_Overflows_Ghost (Digit, Base, Old_Acc)); - end if; - end Lemma_Scan_Digit; - - ---------------------------------------- - -- Prove_Iter_Scan_Based_Number_Ghost -- - ---------------------------------------- - - procedure Prove_Iter_Scan_Based_Number_Ghost - (Str1, Str2 : String; - From, To : Integer; - Base : Uns := 10; - Acc : Uns := 0) - is - begin - if From > To then - null; - elsif Str1 (From) = '_' then - Prove_Iter_Scan_Based_Number_Ghost - (Str1, Str2, From + 1, To, Base, Acc); - elsif Scan_Overflows_Ghost - (Hexa_To_Unsigned_Ghost (Str1 (From)), Base, Acc) - then - null; - else - Prove_Iter_Scan_Based_Number_Ghost - (Str1, Str2, From + 1, To, Base, - Base * Acc + Hexa_To_Unsigned_Ghost (Str1 (From))); - end if; - end Prove_Iter_Scan_Based_Number_Ghost; - - ----------------------------------- - -- Prove_Scan_Only_Decimal_Ghost -- - ----------------------------------- - - procedure Prove_Scan_Only_Decimal_Ghost - (Str : String; - Val : Uns) - is - Non_Blank : constant Positive := First_Non_Space_Ghost - (Str, Str'First, Str'Last); - pragma Assert (Non_Blank = Str'First + 1); - Fst_Num : constant Positive := - (if Str (Non_Blank) = '+' then Non_Blank + 1 else Non_Blank); - pragma Assert (Fst_Num = Str'First + 1); - Last_Num_Init : constant Integer := - Last_Number_Ghost (Str (Str'First + 1 .. Str'Last)); - pragma Assert (Last_Num_Init = Str'Last); - Starts_As_Based : constant Boolean := - Last_Num_Init < Str'Last - 1 - and then Str (Last_Num_Init + 1) in '#' | ':' - and then Str (Last_Num_Init + 2) in - '0' .. '9' | 'a' .. 'f' | 'A' .. 'F'; - pragma Assert (Starts_As_Based = False); - Last_Num_Based : constant Integer := - (if Starts_As_Based - then Last_Hexa_Ghost (Str (Last_Num_Init + 2 .. Str'Last)) - else Last_Num_Init); - pragma Assert (Last_Num_Based = Str'Last); - begin - pragma Assert - (Is_Opt_Exponent_Format_Ghost (Str (Str'Last + 1 .. Str'Last))); - pragma Assert - (Is_Natural_Format_Ghost (Str (Str'First + 1 .. Str'Last))); - pragma Assert - (Is_Raw_Unsigned_Format_Ghost (Str (Str'First + 1 .. Str'Last))); - pragma Assert - (not Raw_Unsigned_Overflows_Ghost (Str, Str'First + 1, Str'Last)); - pragma Assert (Val = Exponent_Unsigned_Ghost (Val, 0, 10).Value); - pragma Assert - (Val = Scan_Raw_Unsigned_Ghost (Str, Str'First + 1, Str'Last)); - pragma Assert (Is_Unsigned_Ghost (Str)); - pragma Assert (Is_Value_Unsigned_Ghost (Str, Val)); - end Prove_Scan_Only_Decimal_Ghost; - ----------------------- -- Scan_Raw_Unsigned -- ----------------------- @@ -341,8 +134,8 @@ package body System.Value_U is Last_Num_Init : constant Integer := Last_Number_Ghost (Str (Ptr.all .. Max)) with Ghost; - Init_Val : constant Uns_Option := - Scan_Based_Number_Ghost (Str, Ptr.all, Last_Num_Init) + Init_Val : constant Spec.Uns_Option := + Spec.Scan_Based_Number_Ghost (Str, Ptr.all, Last_Num_Init) with Ghost; Starts_As_Based : constant Boolean := Last_Num_Init < Max - 1 @@ -352,7 +145,7 @@ package body System.Value_U is with Ghost; Last_Num_Based : constant Integer := (if Starts_As_Based - then Last_Hexa_Ghost (Str (Last_Num_Init + 2 .. Max)) + then Spec.Last_Hexa_Ghost (Str (Last_Num_Init + 2 .. Max)) else Last_Num_Init) with Ghost; Is_Based : constant Boolean := @@ -360,9 +153,9 @@ package body System.Value_U is and then Last_Num_Based < Max and then Str (Last_Num_Based + 1) = Str (Last_Num_Init + 1) with Ghost; - Based_Val : constant Uns_Option := + Based_Val : constant Spec.Uns_Option := (if Starts_As_Based and then not Init_Val.Overflow - then Scan_Based_Number_Ghost + then Spec.Scan_Based_Number_Ghost (Str, Last_Num_Init + 2, Last_Num_Based, Init_Val.Value) else Init_Val) with Ghost; @@ -379,6 +172,7 @@ package body System.Value_U is end if; P := Ptr.all; + Spec.Lemma_Scan_Based_Number_Ghost_Step (Str, P, Last_Num_Init); Uval := Character'Pos (Str (P)) - Character'Pos ('0'); P := P + 1; @@ -392,9 +186,6 @@ package body System.Value_U is Umax10 : constant Uns := Uns'Last / 10; -- Numbers bigger than Umax10 overflow if multiplied by 10 - Old_Uval : Uns with Ghost; - Old_Overflow : Boolean with Ghost; - begin -- Loop through decimal digits loop @@ -403,7 +194,7 @@ package body System.Value_U is (if Overflow then Init_Val.Overflow); pragma Loop_Invariant (if not Overflow - then Init_Val = Scan_Based_Number_Ghost + then Init_Val = Spec.Scan_Based_Number_Ghost (Str, P, Last_Num_Init, Acc => Uval)); exit when P > Max; @@ -414,9 +205,8 @@ package body System.Value_U is if Digit > 9 then if Str (P) = '_' then - Lemma_Scan_Underscore - (Str, P, Ptr_Old, Max, Last_Num_Init, 10, Uval, - Init_Val, Overflow, False); + Spec.Lemma_Scan_Based_Number_Ghost_Underscore + (Str, P, Last_Num_Init, Acc => Uval); Scan_Underscore (Str, P, Ptr, Max, False); else exit; @@ -425,11 +215,19 @@ package body System.Value_U is -- Accumulate result, checking for overflow else - Old_Uval := Uval; - Old_Overflow := Overflow; + Spec.Lemma_Scan_Based_Number_Ghost_Step + (Str, P, Last_Num_Init, Acc => Uval); + Spec.Lemma_Scan_Based_Number_Ghost_Overflow + (Str, P, Last_Num_Init, Acc => Uval); if Uval <= Umax then + pragma Assert + (Spec.Hexa_To_Unsigned_Ghost (Str (P)) = Digit); Uval := 10 * Uval + Digit; + pragma Assert + (if not Overflow + then Init_Val = Spec.Scan_Based_Number_Ghost + (Str, P + 1, Last_Num_Init, Acc => Uval)); elsif Uval > Umax10 then Overflow := True; @@ -440,17 +238,17 @@ package body System.Value_U is if Uval < Umax10 then Overflow := True; end if; + pragma Assert + (if not Overflow + then Init_Val = Spec.Scan_Based_Number_Ghost + (Str, P + 1, Last_Num_Init, Acc => Uval)); end if; - Lemma_Scan_Digit - (Str, P, Last_Num_Init, Digit, 10, Old_Uval, Uval, Init_Val, - Old_Overflow, Overflow); - P := P + 1; end if; end loop; - pragma Assert (P = Last_Num_Init + 1); - pragma Assert (Init_Val.Overflow = Overflow); + Spec.Lemma_Scan_Based_Number_Ghost_Base + (Str, P, Last_Num_Init, Acc => Uval); end; pragma Assert_And_Cut @@ -488,18 +286,14 @@ package body System.Value_U is UmaxB : constant Uns := Uns'Last / Base; -- Numbers bigger than UmaxB overflow if multiplied by base - Old_Uval : Uns with Ghost; - Old_Overflow : Boolean with Ghost; - begin pragma Assert (if Str (P) in '0' .. '9' | 'A' .. 'F' | 'a' .. 'f' - then Is_Based_Format_Ghost (Str (P .. Max))); + then Spec.Is_Based_Format_Ghost (Str (P .. Max))); -- Loop to scan out based integer value loop - -- We require a digit at this stage if Str (P) in '0' .. '9' then @@ -519,6 +313,8 @@ package body System.Value_U is -- already stored in Ptr.all. else + Spec.Lemma_Scan_Based_Number_Ghost_Base + (Str, P, Last_Num_Based, Base, Uval); Uval := Base; Base := 10; pragma Assert (Ptr.all = Last_Num_Init + 1); @@ -529,25 +325,25 @@ package body System.Value_U is exit; end if; - Lemma_Digit_Is_Before_Last (Str, P, Last_Num_Init + 2, Max); - pragma Loop_Invariant (P in P'Loop_Entry .. Last_Num_Based); pragma Loop_Invariant (Str (P) in '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' - and then Digit = Hexa_To_Unsigned_Ghost (Str (P))); + and then Digit = Spec.Hexa_To_Unsigned_Ghost (Str (P))); pragma Loop_Invariant (if Overflow'Loop_Entry then Overflow); pragma Loop_Invariant (if Overflow then - Overflow'Loop_Entry or else Based_Val.Overflow); + (Overflow'Loop_Entry or else Based_Val.Overflow)); pragma Loop_Invariant (if not Overflow - then Based_Val = Scan_Based_Number_Ghost + then Based_Val = Spec.Scan_Based_Number_Ghost (Str, P, Last_Num_Based, Base, Uval)); pragma Loop_Invariant (Ptr.all = Last_Num_Init + 1); - Old_Uval := Uval; - Old_Overflow := Overflow; + Spec.Lemma_Scan_Based_Number_Ghost_Step + (Str, P, Last_Num_Based, Base, Uval); + Spec.Lemma_Scan_Based_Number_Ghost_Overflow + (Str, P, Last_Num_Based, Base, Uval); -- If digit is too large, just signal overflow and continue. -- The idea here is to keep scanning as long as the input is @@ -560,6 +356,10 @@ package body System.Value_U is elsif Uval <= Umax then Uval := Base * Uval + Digit; + pragma Assert + (if not Overflow + then Based_Val = Spec.Scan_Based_Number_Ghost + (Str, P + 1, Last_Num_Based, Base, Uval)); elsif Uval > UmaxB then Overflow := True; @@ -570,6 +370,10 @@ package body System.Value_U is if Uval < UmaxB then Overflow := True; end if; + pragma Assert + (if not Overflow + then Based_Val = Spec.Scan_Based_Number_Ghost + (Str, P + 1, Last_Num_Based, Base, Uval)); end if; -- If at end of string with no base char, not a based number @@ -579,10 +383,6 @@ package body System.Value_U is P := P + 1; - Lemma_Scan_Digit - (Str, P - 1, Last_Num_Based, Digit, Base, Old_Uval, Uval, - Based_Val, Old_Overflow, Overflow); - if P > Max then Ptr.all := P; Bad_Value (Str); @@ -592,48 +392,54 @@ package body System.Value_U is if Str (P) = Base_Char then Ptr.all := P + 1; + pragma Assert (P = Last_Num_Based + 1); pragma Assert (Ptr.all = Last_Num_Based + 2); + pragma Assert (Starts_As_Based); + pragma Assert (Last_Num_Based < Max); + pragma Assert (Str (Last_Num_Based + 1) = Base_Char); + pragma Assert (Base_Char = Str (Last_Num_Init + 1)); pragma Assert (Is_Based); - pragma Assert - (if not Overflow then - Based_Val = Scan_Based_Number_Ghost - (Str, P, Last_Num_Based, Base, Uval)); - Lemma_End_Of_Scan (Str, P, Last_Num_Based, Base, Uval); - pragma Assert (if not Overflow then Uval = Based_Val.Value); + Spec.Lemma_Scan_Based_Number_Ghost_Base + (Str, P, Last_Num_Based, Base, Uval); exit; -- Deal with underscore elsif Str (P) = '_' then - Lemma_Scan_Underscore - (Str, P, Last_Num_Init + 2, Max, Last_Num_Based, Base, - Uval, Based_Val, Overflow, True); + Lemma_Underscore_Not_Last (Str, P, Last_Num_Init + 2, Max); + Spec.Lemma_Scan_Based_Number_Ghost_Underscore + (Str, P, Last_Num_Based, Base, Uval); Scan_Underscore (Str, P, Ptr, Max, True); pragma Assert (if not Overflow - then Based_Val = Scan_Based_Number_Ghost + then Based_Val = Spec.Scan_Based_Number_Ghost (Str, P, Last_Num_Based, Base, Uval)); + pragma Assert (Str (P) /= '_'); + pragma Assert (Str (P) /= Base_Char); end if; + + Lemma_Digit_Not_Last (Str, P, Last_Num_Init + 2, Max); + pragma Assert (Str (P) /= '_'); + pragma Assert (Str (P) /= Base_Char); end loop; end; pragma Assert (if Starts_As_Based then P = Last_Num_Based + 1 else P = Last_Num_Init + 2); pragma Assert + (Last_Num_Init < Max - 1 + and then Str (Last_Num_Init + 1) in '#' | ':'); + pragma Assert (Overflow = (Init_Val.Overflow or else Init_Val.Value not in 2 .. 16 or else (Starts_As_Based and then Based_Val.Overflow))); + pragma Assert + (Overflow /= Spec.Scan_Split_No_Overflow_Ghost (Str, Ptr_Old, Max)); end if; pragma Assert_And_Cut - (Overflow = - (Init_Val.Overflow - or else - (Last_Num_Init < Max - 1 - and then Str (Last_Num_Init + 1) in '#' | ':' - and then Init_Val.Value not in 2 .. 16) - or else (Starts_As_Based and then Based_Val.Overflow)) + (Overflow /= Spec.Scan_Split_No_Overflow_Ghost (Str, Ptr_Old, Max) and then (if not Overflow then (if Is_Based then Uval = Based_Val.Value @@ -649,10 +455,12 @@ package body System.Value_U is Scan_Exponent (Str, Ptr, Max, Expon); - pragma Assert (Ptr.all = Raw_Unsigned_Last_Ghost (Str, Ptr_Old, Max)); pragma Assert - (if Starts_As_Exponent_Format_Ghost (Str (First_Exp .. Max)) - then Expon = Scan_Exponent_Ghost (Str (First_Exp .. Max))); + (Ptr.all = Spec.Raw_Unsigned_Last_Ghost (Str, Ptr_Old, Max)); + pragma Assert + (if not Overflow + then Spec.Scan_Split_Value_Ghost (Str, Ptr_Old, Max) = + (Uval, Base, Expon)); if Expon /= 0 and then Uval /= 0 then @@ -664,8 +472,8 @@ package body System.Value_U is UmaxB : constant Uns := Uns'Last / Base; -- Numbers bigger than UmaxB overflow if multiplied by base - Res_Val : constant Uns_Option := - Exponent_Unsigned_Ghost (Uval, Expon, Base) + Res_Val : constant Spec.Uns_Option := + Spec.Exponent_Unsigned_Ghost (Uval, Expon, Base) with Ghost; begin for J in 1 .. Expon loop @@ -674,48 +482,45 @@ package body System.Value_U is pragma Loop_Invariant (if Overflow then Overflow'Loop_Entry or else Res_Val.Overflow); + pragma Loop_Invariant (Uval /= 0); pragma Loop_Invariant (if not Overflow - then Res_Val = Exponent_Unsigned_Ghost + then Res_Val = Spec.Exponent_Unsigned_Ghost (Uval, Expon - J + 1, Base)); pragma Assert - ((Uval > UmaxB) = Scan_Overflows_Ghost (0, Base, Uval)); + ((Uval > UmaxB) = Spec.Scan_Overflows_Ghost (0, Base, Uval)); if Uval > UmaxB then + Spec.Lemma_Exponent_Unsigned_Ghost_Overflow + (Uval, Expon - J + 1, Base); Overflow := True; exit; end if; + Spec.Lemma_Exponent_Unsigned_Ghost_Step + (Uval, Expon - J + 1, Base); + Uval := Uval * Base; end loop; + Spec.Lemma_Exponent_Unsigned_Ghost_Base (Uval, 0, Base); + pragma Assert - (Overflow = (Init_Val.Overflow - or else - (Last_Num_Init < Max - 1 - and then Str (Last_Num_Init + 1) in '#' | ':' - and then Init_Val.Value not in 2 .. 16) - or else (Starts_As_Based and then Based_Val.Overflow) - or else Res_Val.Overflow)); - pragma Assert - (Overflow = Raw_Unsigned_Overflows_Ghost (Str, Ptr_Old, Max)); - pragma Assert - (Exponent_Unsigned_Ghost (Uval, 0, Base) = (False, Uval)); - pragma Assert - (if not Overflow then Uval = Res_Val.Value); - pragma Assert - (if not Overflow then - Uval = Scan_Raw_Unsigned_Ghost (Str, Ptr_Old, Max)); + (Overflow /= + Spec.Raw_Unsigned_No_Overflow_Ghost (Str, Ptr_Old, Max)); + pragma Assert (if not Overflow then Res_Val = (False, Uval)); end; end if; + Spec.Lemma_Exponent_Unsigned_Ghost_Base (Uval, Expon, Base); pragma Assert (if Expon = 0 or else Uval = 0 then - Exponent_Unsigned_Ghost (Uval, Expon, Base) = (False, Uval)); + Spec.Exponent_Unsigned_Ghost (Uval, Expon, Base) = (False, Uval)); pragma Assert - (Overflow = Raw_Unsigned_Overflows_Ghost (Str, Ptr_Old, Max)); + (Overflow /= + Spec.Raw_Unsigned_No_Overflow_Ghost (Str, Ptr_Old, Max)); pragma Assert (if not Overflow then - Uval = Scan_Raw_Unsigned_Ghost (Str, Ptr_Old, Max)); + Uval = Spec.Scan_Raw_Unsigned_Ghost (Str, Ptr_Old, Max)); -- Return result, dealing with overflow @@ -774,7 +579,15 @@ package body System.Value_U is if Str'Last = Positive'Last then declare subtype NT is String (1 .. Str'Length); + procedure Prove_Is_Unsigned_Ghost with + Ghost, + Pre => Str'Length < Natural'Last + and then not Only_Space_Ghost (Str, Str'First, Str'Last) + and then Spec.Is_Unsigned_Ghost (Spec.Slide_To_1 (Str)), + Post => Spec.Is_Unsigned_Ghost (NT (Str)); + procedure Prove_Is_Unsigned_Ghost is null; begin + Prove_Is_Unsigned_Ghost; return Value_Unsigned (NT (Str)); end; @@ -784,7 +597,6 @@ package body System.Value_U is declare V : Uns; P : aliased Integer := Str'First; - Non_Blank : constant Positive := First_Non_Space_Ghost (Str, Str'First, Str'Last) with Ghost; @@ -792,9 +604,6 @@ package body System.Value_U is (if Str (Non_Blank) = '+' then Non_Blank + 1 else Non_Blank) with Ghost; begin - pragma Assert - (Is_Raw_Unsigned_Format_Ghost (Str (Fst_Num .. Str'Last))); - declare P_Acc : constant not null access Integer := P'Access; begin @@ -802,14 +611,15 @@ package body System.Value_U is end; pragma Assert - (P = Raw_Unsigned_Last_Ghost (Str, Fst_Num, Str'Last)); + (P = Spec.Raw_Unsigned_Last_Ghost (Str, Fst_Num, Str'Last)); pragma Assert - (V = Scan_Raw_Unsigned_Ghost (Str, Fst_Num, Str'Last)); + (V = Spec.Scan_Raw_Unsigned_Ghost (Str, Fst_Num, Str'Last)); Scan_Trailing_Blanks (Str, P); pragma Assert - (Is_Value_Unsigned_Ghost (Slide_If_Necessary (Str), V)); + (Spec.Is_Value_Unsigned_Ghost + (Spec.Slide_If_Necessary (Str), V)); return V; end; end if; diff --git a/gcc/ada/libgnat/s-valueu.ads b/gcc/ada/libgnat/s-valueu.ads index 1508b6e..466b96a 100644 --- a/gcc/ada/libgnat/s-valueu.ads +++ b/gcc/ada/libgnat/s-valueu.ads @@ -44,6 +44,7 @@ pragma Assertion_Policy (Pre => Ignore, Ghost => Ignore, Subprogram_Variant => Ignore); +with System.Value_U_Spec; with System.Val_Util; use System.Val_Util; generic @@ -53,317 +54,7 @@ generic package System.Value_U is pragma Preelaborate; - type Uns_Option (Overflow : Boolean := False) is record - case Overflow is - when True => - null; - when False => - Value : Uns := 0; - end case; - end record; - - function Wrap_Option (Value : Uns) return Uns_Option is - (Overflow => False, Value => Value) - with - Ghost; - - function Only_Decimal_Ghost - (Str : String; - From, To : Integer) - return Boolean - is - (for all J in From .. To => Str (J) in '0' .. '9') - with - Ghost, - Pre => From > To or else (From >= Str'First and then To <= Str'Last); - -- Ghost function that returns True if S has only decimal characters - -- from index From to index To. - - function Only_Hexa_Ghost (Str : String; From, To : Integer) return Boolean - is - (for all J in From .. To => - Str (J) in '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' | '_') - with - Ghost, - Pre => From > To or else (From >= Str'First and then To <= Str'Last); - -- Ghost function that returns True if S has only hexadecimal characters - -- from index From to index To. - - function Last_Hexa_Ghost (Str : String) return Positive - with - Ghost, - Pre => Str /= "" - and then Str (Str'First) in '0' .. '9' | 'a' .. 'f' | 'A' .. 'F', - Post => Last_Hexa_Ghost'Result in Str'Range - and then (if Last_Hexa_Ghost'Result < Str'Last then - Str (Last_Hexa_Ghost'Result + 1) not in - '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' | '_') - and then Only_Hexa_Ghost (Str, Str'First, Last_Hexa_Ghost'Result); - -- Ghost function that returns the index of the last character in S that - -- is either an hexadecimal digit or an underscore, which necessarily - -- exists given the precondition on Str. - - function Is_Based_Format_Ghost (Str : String) return Boolean - is - (Str /= "" - and then Str (Str'First) in '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' - and then - (declare - L : constant Positive := Last_Hexa_Ghost (Str); - begin - Str (L) /= '_' - and then (for all J in Str'First .. L => - (if Str (J) = '_' then Str (J + 1) /= '_')))) - with - Ghost; - -- Ghost function that determines if Str has the correct format for a - -- based number, consisting in a sequence of hexadecimal digits possibly - -- separated by single underscores. It may be followed by other characters. - - function Hexa_To_Unsigned_Ghost (X : Character) return Uns is - (case X is - when '0' .. '9' => Character'Pos (X) - Character'Pos ('0'), - when 'a' .. 'f' => Character'Pos (X) - Character'Pos ('a') + 10, - when 'A' .. 'F' => Character'Pos (X) - Character'Pos ('A') + 10, - when others => raise Program_Error) - with - Ghost, - Pre => X in '0' .. '9' | 'a' .. 'f' | 'A' .. 'F'; - -- Ghost function that computes the value corresponding to an hexadecimal - -- digit. - - function Scan_Overflows_Ghost - (Digit : Uns; - Base : Uns; - Acc : Uns) return Boolean - is - (Digit >= Base - or else Acc > Uns'Last / Base - or else Uns'Last - Digit < Base * Acc) - with Ghost; - -- Ghost function which returns True if Digit + Base * Acc overflows or - -- Digit is greater than Base, as this is used by the algorithm for the - -- test of overflow. - - function Scan_Based_Number_Ghost - (Str : String; - From, To : Integer; - Base : Uns := 10; - Acc : Uns := 0) return Uns_Option - with - Ghost, - Subprogram_Variant => (Increases => From), - Pre => Str'Last /= Positive'Last - and then - (From > To or else (From >= Str'First and then To <= Str'Last)) - and then Only_Hexa_Ghost (Str, From, To); - -- Ghost function that recursively computes the based number in Str, - -- assuming Acc has been scanned already and scanning continues at index - -- From. - - function Exponent_Unsigned_Ghost - (Value : Uns; - Exp : Natural; - Base : Uns := 10) return Uns_Option - with - Ghost, - Subprogram_Variant => (Decreases => Exp); - -- Ghost function that recursively computes Value * Base ** Exp - - function Is_Raw_Unsigned_Format_Ghost (Str : String) return Boolean is - (Is_Natural_Format_Ghost (Str) - and then - (declare - Last_Num_Init : constant Integer := Last_Number_Ghost (Str); - Starts_As_Based : constant Boolean := - Last_Num_Init < Str'Last - 1 - and then Str (Last_Num_Init + 1) in '#' | ':' - and then Str (Last_Num_Init + 2) in - '0' .. '9' | 'a' .. 'f' | 'A' .. 'F'; - Last_Num_Based : constant Integer := - (if Starts_As_Based - then Last_Hexa_Ghost (Str (Last_Num_Init + 2 .. Str'Last)) - else Last_Num_Init); - Is_Based : constant Boolean := - Starts_As_Based - and then Last_Num_Based < Str'Last - and then Str (Last_Num_Based + 1) = Str (Last_Num_Init + 1); - First_Exp : constant Integer := - (if Is_Based then Last_Num_Based + 2 else Last_Num_Init + 1); - begin - (if Starts_As_Based then - Is_Based_Format_Ghost (Str (Last_Num_Init + 2 .. Str'Last)) - and then Last_Num_Based < Str'Last) - and then Is_Opt_Exponent_Format_Ghost - (Str (First_Exp .. Str'Last)))) - with - Ghost, - Pre => Str'Last /= Positive'Last, - Post => True; - -- Ghost function that determines if Str has the correct format for an - -- unsigned number without a sign character. - -- It is a natural number in base 10, optionally followed by a based - -- number surrounded by delimiters # or :, optionally followed by an - -- exponent part. - - function Raw_Unsigned_Overflows_Ghost - (Str : String; - From, To : Integer) - return Boolean - is - (declare - Last_Num_Init : constant Integer := - Last_Number_Ghost (Str (From .. To)); - Init_Val : constant Uns_Option := - Scan_Based_Number_Ghost (Str, From, Last_Num_Init); - Starts_As_Based : constant Boolean := - Last_Num_Init < To - 1 - and then Str (Last_Num_Init + 1) in '#' | ':' - and then Str (Last_Num_Init + 2) in - '0' .. '9' | 'a' .. 'f' | 'A' .. 'F'; - Last_Num_Based : constant Integer := - (if Starts_As_Based - then Last_Hexa_Ghost (Str (Last_Num_Init + 2 .. To)) - else Last_Num_Init); - Is_Based : constant Boolean := - Starts_As_Based - and then Last_Num_Based < To - and then Str (Last_Num_Based + 1) = Str (Last_Num_Init + 1); - Based_Val : constant Uns_Option := - (if Starts_As_Based and then not Init_Val.Overflow - then Scan_Based_Number_Ghost - (Str, Last_Num_Init + 2, Last_Num_Based, Init_Val.Value) - else Init_Val); - First_Exp : constant Integer := - (if Is_Based then Last_Num_Based + 2 else Last_Num_Init + 1); - Expon : constant Natural := - (if Starts_As_Exponent_Format_Ghost (Str (First_Exp .. To)) - then Scan_Exponent_Ghost (Str (First_Exp .. To)) - else 0); - begin - Init_Val.Overflow - or else - (Last_Num_Init < To - 1 - and then Str (Last_Num_Init + 1) in '#' | ':' - and then Init_Val.Value not in 2 .. 16) - or else - (Starts_As_Based - and then Based_Val.Overflow) - or else - (Starts_As_Exponent_Format_Ghost (Str (First_Exp .. To)) - and then - (declare - Base : constant Uns := - (if Is_Based then Init_Val.Value else 10); - Value : constant Uns := - (if Is_Based then Based_Val.Value else Init_Val.Value); - begin - Exponent_Unsigned_Ghost - (Value, Expon, Base).Overflow))) - with - Ghost, - Pre => Str'Last /= Positive'Last - and then From in Str'Range - and then To in From .. Str'Last - and then Str (From) in '0' .. '9', - Post => True; - -- Ghost function that determines if the computation of the unsigned number - -- represented by Str will overflow. The computation overflows if either: - -- * The computation of the decimal part overflows, - -- * The decimal part is followed by a valid delimiter for a based - -- part, and the number corresponding to the base is not a valid base, - -- * The computation of the based part overflows, or - -- * There is an exponent and the computation of the exponentiation - -- overflows. - - function Scan_Raw_Unsigned_Ghost - (Str : String; - From, To : Integer) - return Uns - is - (declare - Last_Num_Init : constant Integer := - Last_Number_Ghost (Str (From .. To)); - Init_Val : constant Uns_Option := - Scan_Based_Number_Ghost (Str, From, Last_Num_Init); - Starts_As_Based : constant Boolean := - Last_Num_Init < To - 1 - and then Str (Last_Num_Init + 1) in '#' | ':' - and then Str (Last_Num_Init + 2) in - '0' .. '9' | 'a' .. 'f' | 'A' .. 'F'; - Last_Num_Based : constant Integer := - (if Starts_As_Based - then Last_Hexa_Ghost (Str (Last_Num_Init + 2 .. To)) - else Last_Num_Init); - Is_Based : constant Boolean := - Starts_As_Based - and then Last_Num_Based < To - and then Str (Last_Num_Based + 1) = Str (Last_Num_Init + 1); - Based_Val : constant Uns_Option := - (if Starts_As_Based and then not Init_Val.Overflow - then Scan_Based_Number_Ghost - (Str, Last_Num_Init + 2, Last_Num_Based, Init_Val.Value) - else Init_Val); - First_Exp : constant Integer := - (if Is_Based then Last_Num_Based + 2 else Last_Num_Init + 1); - Expon : constant Natural := - (if Starts_As_Exponent_Format_Ghost (Str (First_Exp .. To)) - then Scan_Exponent_Ghost (Str (First_Exp .. To)) - else 0); - Base : constant Uns := - (if Is_Based then Init_Val.Value else 10); - Value : constant Uns := - (if Is_Based then Based_Val.Value else Init_Val.Value); - begin - Exponent_Unsigned_Ghost (Value, Expon, Base).Value) - with - Ghost, - Pre => Str'Last /= Positive'Last - and then From in Str'Range - and then To in From .. Str'Last - and then Str (From) in '0' .. '9' - and then not Raw_Unsigned_Overflows_Ghost (Str, From, To), - Post => True; - -- Ghost function that scans an unsigned number without a sign character - - function Raw_Unsigned_Last_Ghost - (Str : String; - From, To : Integer) - return Positive - is - (declare - Last_Num_Init : constant Integer := - Last_Number_Ghost (Str (From .. To)); - Starts_As_Based : constant Boolean := - Last_Num_Init < To - 1 - and then Str (Last_Num_Init + 1) in '#' | ':' - and then Str (Last_Num_Init + 2) in - '0' .. '9' | 'a' .. 'f' | 'A' .. 'F'; - Last_Num_Based : constant Integer := - (if Starts_As_Based - then Last_Hexa_Ghost (Str (Last_Num_Init + 2 .. To)) - else Last_Num_Init); - Is_Based : constant Boolean := - Starts_As_Based - and then Last_Num_Based < To - and then Str (Last_Num_Based + 1) = Str (Last_Num_Init + 1); - First_Exp : constant Integer := - (if Is_Based then Last_Num_Based + 2 else Last_Num_Init + 1); - begin - (if not Starts_As_Exponent_Format_Ghost (Str (First_Exp .. To)) - then First_Exp - elsif Str (First_Exp + 1) in '-' | '+' then - Last_Number_Ghost (Str (First_Exp + 2 .. To)) + 1 - else Last_Number_Ghost (Str (First_Exp + 1 .. To)) + 1)) - with - Ghost, - Pre => Str'Last /= Positive'Last - and then From in Str'Range - and then To in From .. Str'Last - and then Str (From) in '0' .. '9', - Post => Raw_Unsigned_Last_Ghost'Result in From .. To + 1; - -- Ghost function that returns the position of the cursor once an unsigned - -- number has been seen. + package Spec is new System.Value_U_Spec (Uns); procedure Scan_Raw_Unsigned (Str : String; @@ -373,10 +64,10 @@ package System.Value_U is with Pre => Str'Last /= Positive'Last and then Ptr.all in Str'Range and then Max in Ptr.all .. Str'Last - and then Is_Raw_Unsigned_Format_Ghost (Str (Ptr.all .. Max)), - Post => not Raw_Unsigned_Overflows_Ghost (Str, Ptr.all'Old, Max) - and Res = Scan_Raw_Unsigned_Ghost (Str, Ptr.all'Old, Max) - and Ptr.all = Raw_Unsigned_Last_Ghost (Str, Ptr.all'Old, Max); + and then Spec.Is_Raw_Unsigned_Format_Ghost (Str (Ptr.all .. Max)), + Post => Spec.Raw_Unsigned_No_Overflow_Ghost (Str, Ptr.all'Old, Max) + and Res = Spec.Scan_Raw_Unsigned_Ghost (Str, Ptr.all'Old, Max) + and Ptr.all = Spec.Raw_Unsigned_Last_Ghost (Str, Ptr.all'Old, Max); -- This function scans the string starting at Str (Ptr.all) for a valid -- integer according to the syntax described in (RM 3.5(43)). The substring @@ -464,7 +155,7 @@ package System.Value_U is Fst_Num : constant Positive := (if Str (Non_Blank) = '+' then Non_Blank + 1 else Non_Blank); begin - Is_Raw_Unsigned_Format_Ghost (Str (Fst_Num .. Max))), + Spec.Is_Raw_Unsigned_Format_Ghost (Str (Fst_Num .. Max))), Post => (declare Non_Blank : constant Positive := @@ -472,9 +163,9 @@ package System.Value_U is Fst_Num : constant Positive := (if Str (Non_Blank) = '+' then Non_Blank + 1 else Non_Blank); begin - not Raw_Unsigned_Overflows_Ghost (Str, Fst_Num, Max) - and then Res = Scan_Raw_Unsigned_Ghost (Str, Fst_Num, Max) - and then Ptr.all = Raw_Unsigned_Last_Ghost (Str, Fst_Num, Max)); + Spec.Raw_Unsigned_No_Overflow_Ghost (Str, Fst_Num, Max) + and then Res = Spec.Scan_Raw_Unsigned_Ghost (Str, Fst_Num, Max) + and then Ptr.all = Spec.Raw_Unsigned_Last_Ghost (Str, Fst_Num, Max)); -- Same as Scan_Raw_Unsigned, except scans optional leading -- blanks, and an optional leading plus sign. @@ -482,157 +173,18 @@ package System.Value_U is -- Note: if a minus sign is present, Constraint_Error will be raised. -- Note: trailing blanks are not scanned. - function Slide_To_1 (Str : String) return String - with Ghost, - Post => - Only_Space_Ghost (Str, Str'First, Str'Last) = - (for all J in Str'First .. Str'Last => - Slide_To_1'Result (J - Str'First + 1) = ' '); - -- Slides Str so that it starts at 1 - - function Slide_If_Necessary (Str : String) return String is - (if Str'Last = Positive'Last then Slide_To_1 (Str) else Str) - with Ghost, - Post => - Only_Space_Ghost (Str, Str'First, Str'Last) = - Only_Space_Ghost (Slide_If_Necessary'Result, - Slide_If_Necessary'Result'First, - Slide_If_Necessary'Result'Last); - -- If Str'Last = Positive'Last then slides Str so that it starts at 1 - - function Is_Unsigned_Ghost (Str : String) return Boolean is - (declare - Non_Blank : constant Positive := First_Non_Space_Ghost - (Str, Str'First, Str'Last); - Fst_Num : constant Positive := - (if Str (Non_Blank) = '+' then Non_Blank + 1 else Non_Blank); - begin - Is_Raw_Unsigned_Format_Ghost (Str (Fst_Num .. Str'Last)) - and then not Raw_Unsigned_Overflows_Ghost (Str, Fst_Num, Str'Last) - and then Only_Space_Ghost - (Str, Raw_Unsigned_Last_Ghost (Str, Fst_Num, Str'Last), Str'Last)) - with Ghost, - Pre => not Only_Space_Ghost (Str, Str'First, Str'Last) - and then Str'Last /= Positive'Last, - Post => True; - -- Ghost function that determines if Str has the correct format for an - -- unsigned number, consisting in some blank characters, an optional - -- + sign, a raw unsigned number which does not overflow and then some - -- more blank characters. - - function Is_Value_Unsigned_Ghost (Str : String; Val : Uns) return Boolean is - (declare - Non_Blank : constant Positive := First_Non_Space_Ghost - (Str, Str'First, Str'Last); - Fst_Num : constant Positive := - (if Str (Non_Blank) = '+' then Non_Blank + 1 else Non_Blank); - begin - Val = Scan_Raw_Unsigned_Ghost (Str, Fst_Num, Str'Last)) - with Ghost, - Pre => not Only_Space_Ghost (Str, Str'First, Str'Last) - and then Str'Last /= Positive'Last - and then Is_Unsigned_Ghost (Str), - Post => True; - -- Ghost function that returns True if Val is the value corresponding to - -- the unsigned number represented by Str. - function Value_Unsigned (Str : String) return Uns - with Pre => not Only_Space_Ghost (Str, Str'First, Str'Last) - and then Str'Length /= Positive'Last - and then Is_Unsigned_Ghost (Slide_If_Necessary (Str)), + with Pre => Str'Length /= Positive'Last + and then not Only_Space_Ghost (Str, Str'First, Str'Last) + and then Spec.Is_Unsigned_Ghost (Spec.Slide_If_Necessary (Str)), Post => - Is_Value_Unsigned_Ghost - (Slide_If_Necessary (Str), Value_Unsigned'Result), + Spec.Is_Value_Unsigned_Ghost + (Spec.Slide_If_Necessary (Str), Value_Unsigned'Result), Subprogram_Variant => (Decreases => Str'First); -- Used in computing X'Value (Str) where X is a modular integer type whose -- modulus does not exceed the range of System.Unsigned_Types.Unsigned. Str -- is the string argument of the attribute. Constraint_Error is raised if -- the string is malformed, or if the value is out of range. - procedure Prove_Iter_Scan_Based_Number_Ghost - (Str1, Str2 : String; - From, To : Integer; - Base : Uns := 10; - Acc : Uns := 0) - with - Ghost, - Subprogram_Variant => (Increases => From), - Pre => Str1'Last /= Positive'Last - and then Str2'Last /= Positive'Last - and then - (From > To or else (From >= Str1'First and then To <= Str1'Last)) - and then - (From > To or else (From >= Str2'First and then To <= Str2'Last)) - and then Only_Hexa_Ghost (Str1, From, To) - and then (for all J in From .. To => Str1 (J) = Str2 (J)), - Post => - Scan_Based_Number_Ghost (Str1, From, To, Base, Acc) - = Scan_Based_Number_Ghost (Str2, From, To, Base, Acc); - -- Ghost lemma used in the proof of 'Image implementation, to prove the - -- preservation of Scan_Based_Number_Ghost across an update in the string - -- in lower indexes. - - procedure Prove_Scan_Only_Decimal_Ghost - (Str : String; - Val : Uns) - with - Ghost, - Pre => Str'Last /= Positive'Last - and then Str'Length >= 2 - and then Str (Str'First) = ' ' - and then Only_Decimal_Ghost (Str, Str'First + 1, Str'Last) - and then Scan_Based_Number_Ghost (Str, Str'First + 1, Str'Last) - = Wrap_Option (Val), - Post => Is_Unsigned_Ghost (Slide_If_Necessary (Str)) - and then Value_Unsigned (Str) = Val; - -- Ghost lemma used in the proof of 'Image implementation, to prove that - -- the result of Value_Unsigned on a decimal string is the same as the - -- result of Scan_Based_Number_Ghost. - -private - - ----------------------------- - -- Exponent_Unsigned_Ghost -- - ----------------------------- - - function Exponent_Unsigned_Ghost - (Value : Uns; - Exp : Natural; - Base : Uns := 10) return Uns_Option - is - (if Exp = 0 or Value = 0 then (Overflow => False, Value => Value) - elsif Scan_Overflows_Ghost (0, Base, Value) then (Overflow => True) - else Exponent_Unsigned_Ghost (Value * Base, Exp - 1, Base)); - - ----------------------------- - -- Scan_Based_Number_Ghost -- - ----------------------------- - - function Scan_Based_Number_Ghost - (Str : String; - From, To : Integer; - Base : Uns := 10; - Acc : Uns := 0) return Uns_Option - is - (if From > To then (Overflow => False, Value => Acc) - elsif Str (From) = '_' - then Scan_Based_Number_Ghost (Str, From + 1, To, Base, Acc) - elsif Scan_Overflows_Ghost - (Hexa_To_Unsigned_Ghost (Str (From)), Base, Acc) - then (Overflow => True) - else Scan_Based_Number_Ghost - (Str, From + 1, To, Base, - Base * Acc + Hexa_To_Unsigned_Ghost (Str (From)))); - - ---------------- - -- Slide_To_1 -- - ---------------- - - function Slide_To_1 (Str : String) return String is - (declare - Res : constant String (1 .. Str'Length) := Str; - begin - Res); - end System.Value_U; diff --git a/gcc/ada/libgnat/s-valuti.ads b/gcc/ada/libgnat/s-valuti.ads index 2b89b12..7c2da17 100644 --- a/gcc/ada/libgnat/s-valuti.ads +++ b/gcc/ada/libgnat/s-valuti.ads @@ -374,48 +374,274 @@ is -- no check for this case, the caller must ensure this condition is met. pragma Warnings (GNATprove, On, """Ptr"" is not modified"); - -- Bundle Int type with other types, constants and subprograms used in + -- Bundle Uns type with other types, constants and subprograms used in -- ghost code, so that this package can be instantiated once and used - -- multiple times as generic formal for a given Int type. + -- multiple times as generic formal for a given Uns type. generic - type Int is range <>; type Uns is mod <>; - type Uns_Option is private; + type P_Uns_Option is private with Ghost; + with function P_Wrap_Option (Value : Uns) return P_Uns_Option + with Ghost; + with function P_Hexa_To_Unsigned_Ghost (X : Character) return Uns + with Ghost; + with function P_Scan_Overflows_Ghost + (Digit : Uns; + Base : Uns; + Acc : Uns) return Boolean + with Ghost; + with function P_Is_Raw_Unsigned_Format_Ghost + (Str : String) return Boolean + with Ghost; + with function P_Scan_Split_No_Overflow_Ghost + (Str : String; + From, To : Integer) + return Boolean + with Ghost; + with function P_Raw_Unsigned_No_Overflow_Ghost + (Str : String; + From, To : Integer) + return Boolean + with Ghost; - Unsigned_Width_Ghost : Natural; + with function P_Exponent_Unsigned_Ghost + (Value : Uns; + Exp : Natural; + Base : Uns := 10) return P_Uns_Option + with Ghost; + with procedure P_Lemma_Exponent_Unsigned_Ghost_Base + (Value : Uns; + Exp : Natural; + Base : Uns := 10) + with Ghost; + with procedure P_Lemma_Exponent_Unsigned_Ghost_Overflow + (Value : Uns; + Exp : Natural; + Base : Uns := 10) + with Ghost; + with procedure P_Lemma_Exponent_Unsigned_Ghost_Step + (Value : Uns; + Exp : Natural; + Base : Uns := 10) + with Ghost; - with function Wrap_Option (Value : Uns) return Uns_Option - with Ghost; - with function Only_Decimal_Ghost + with function P_Scan_Raw_Unsigned_Ghost (Str : String; From, To : Integer) - return Boolean - with Ghost; - with function Hexa_To_Unsigned_Ghost (X : Character) return Uns - with Ghost; - with function Scan_Based_Number_Ghost + return Uns + with Ghost; + with procedure P_Lemma_Scan_Based_Number_Ghost_Base (Str : String; From, To : Integer; Base : Uns := 10; Acc : Uns := 0) - return Uns_Option - with Ghost; - with function Is_Integer_Ghost (Str : String) return Boolean - with Ghost; - with procedure Prove_Iter_Scan_Based_Number_Ghost + with Ghost; + with procedure P_Lemma_Scan_Based_Number_Ghost_Underscore + (Str : String; + From, To : Integer; + Base : Uns := 10; + Acc : Uns := 0) + with Ghost; + with procedure P_Lemma_Scan_Based_Number_Ghost_Overflow + (Str : String; + From, To : Integer; + Base : Uns := 10; + Acc : Uns := 0) + with Ghost; + with procedure P_Lemma_Scan_Based_Number_Ghost_Step + (Str : String; + From, To : Integer; + Base : Uns := 10; + Acc : Uns := 0) + with Ghost; + + with function P_Raw_Unsigned_Last_Ghost + (Str : String; + From, To : Integer) + return Positive + with Ghost; + with function P_Only_Decimal_Ghost + (Str : String; + From, To : Integer) + return Boolean + with Ghost; + with function P_Scan_Based_Number_Ghost + (Str : String; + From, To : Integer; + Base : Uns := 10; + Acc : Uns := 0) + return P_Uns_Option + with Ghost; + with function P_Is_Unsigned_Ghost (Str : String) return Boolean + with Ghost; + with function P_Is_Value_Unsigned_Ghost + (Str : String; + Val : Uns) return Boolean + with Ghost; + + with procedure P_Prove_Scan_Only_Decimal_Ghost + (Str : String; + Val : Uns) + with Ghost; + with procedure P_Prove_Scan_Based_Number_Ghost_Eq (Str1, Str2 : String; + From, To : Integer; + Base : Uns := 10; + Acc : Uns := 0) + with Ghost; + + package Uns_Params is + subtype Uns_Option is P_Uns_Option with Ghost; + function Wrap_Option (Value : Uns) return Uns_Option renames + P_Wrap_Option; + function Hexa_To_Unsigned_Ghost + (X : Character) return Uns + renames P_Hexa_To_Unsigned_Ghost; + function Scan_Overflows_Ghost + (Digit : Uns; + Base : Uns; + Acc : Uns) return Boolean + renames P_Scan_Overflows_Ghost; + function Is_Raw_Unsigned_Format_Ghost + (Str : String) return Boolean + renames P_Is_Raw_Unsigned_Format_Ghost; + function Scan_Split_No_Overflow_Ghost + (Str : String; + From, To : Integer) return Boolean + renames P_Scan_Split_No_Overflow_Ghost; + function Raw_Unsigned_No_Overflow_Ghost + (Str : String; + From, To : Integer) return Boolean + renames P_Raw_Unsigned_No_Overflow_Ghost; + + function Exponent_Unsigned_Ghost + (Value : Uns; + Exp : Natural; + Base : Uns := 10) return Uns_Option + renames P_Exponent_Unsigned_Ghost; + procedure Lemma_Exponent_Unsigned_Ghost_Base + (Value : Uns; + Exp : Natural; + Base : Uns := 10) + renames P_Lemma_Exponent_Unsigned_Ghost_Base; + procedure Lemma_Exponent_Unsigned_Ghost_Overflow + (Value : Uns; + Exp : Natural; + Base : Uns := 10) + renames P_Lemma_Exponent_Unsigned_Ghost_Overflow; + procedure Lemma_Exponent_Unsigned_Ghost_Step + (Value : Uns; + Exp : Natural; + Base : Uns := 10) + renames P_Lemma_Exponent_Unsigned_Ghost_Step; + + function Scan_Raw_Unsigned_Ghost + (Str : String; + From, To : Integer) return Uns + renames P_Scan_Raw_Unsigned_Ghost; + procedure Lemma_Scan_Based_Number_Ghost_Base + (Str : String; + From, To : Integer; + Base : Uns := 10; + Acc : Uns := 0) + renames P_Lemma_Scan_Based_Number_Ghost_Base; + procedure Lemma_Scan_Based_Number_Ghost_Underscore + (Str : String; From, To : Integer; Base : Uns := 10; Acc : Uns := 0) + renames P_Lemma_Scan_Based_Number_Ghost_Underscore; + procedure Lemma_Scan_Based_Number_Ghost_Overflow + (Str : String; + From, To : Integer; + Base : Uns := 10; + Acc : Uns := 0) + renames P_Lemma_Scan_Based_Number_Ghost_Overflow; + procedure Lemma_Scan_Based_Number_Ghost_Step + (Str : String; + From, To : Integer; + Base : Uns := 10; + Acc : Uns := 0) + renames P_Lemma_Scan_Based_Number_Ghost_Step; + + function Raw_Unsigned_Last_Ghost + (Str : String; + From, To : Integer) return Positive + renames P_Raw_Unsigned_Last_Ghost; + function Only_Decimal_Ghost + (Str : String; + From, To : Integer) return Boolean + renames P_Only_Decimal_Ghost; + function Scan_Based_Number_Ghost + (Str : String; + From, To : Integer; + Base : Uns := 10; + Acc : Uns := 0) return Uns_Option + renames P_Scan_Based_Number_Ghost; + function Is_Unsigned_Ghost (Str : String) return Boolean + renames P_Is_Unsigned_Ghost; + function Is_Value_Unsigned_Ghost + (Str : String; + Val : Uns) return Boolean + renames P_Is_Value_Unsigned_Ghost; + + procedure Prove_Scan_Only_Decimal_Ghost + (Str : String; + Val : Uns) + renames P_Prove_Scan_Only_Decimal_Ghost; + procedure Prove_Scan_Based_Number_Ghost_Eq + (Str1, Str2 : String; + From, To : Integer; + Base : Uns := 10; + Acc : Uns := 0) + renames P_Prove_Scan_Based_Number_Ghost_Eq; + end Uns_Params; + + -- Bundle Int type with other types, constants and subprograms used in + -- ghost code, so that this package can be instantiated once and used + -- multiple times as generic formal for a given Int type. + generic + type Int is range <>; + type Uns is mod <>; + + with package P_Uns_Params is new System.Val_Util.Uns_Params + (Uns => Uns, others => <>) + with Ghost; + + with function P_Abs_Uns_Of_Int (Val : Int) return Uns + with Ghost; + with function P_Is_Int_Of_Uns + (Minus : Boolean; + Uval : Uns; + Val : Int) + return Boolean with Ghost; - with procedure Prove_Scan_Only_Decimal_Ghost (Str : String; Val : Int) + with function P_Is_Integer_Ghost (Str : String) return Boolean with Ghost; - with function Abs_Uns_Of_Int (Val : Int) return Uns + with function P_Is_Value_Integer_Ghost + (Str : String; + Val : Int) return Boolean with Ghost; - with function Value_Integer (Str : String) return Int + with procedure P_Prove_Scan_Only_Decimal_Ghost (Str : String; Val : Int) with Ghost; package Int_Params is + package Uns_Params renames P_Uns_Params; + function Abs_Uns_Of_Int (Val : Int) return Uns renames + P_Abs_Uns_Of_Int; + function Is_Int_Of_Uns + (Minus : Boolean; + Uval : Uns; + Val : Int) + return Boolean + renames P_Is_Int_Of_Uns; + function Is_Integer_Ghost (Str : String) return Boolean renames + P_Is_Integer_Ghost; + function Is_Value_Integer_Ghost + (Str : String; + Val : Int) return Boolean + renames P_Is_Value_Integer_Ghost; + procedure Prove_Scan_Only_Decimal_Ghost (Str : String; Val : Int) renames + P_Prove_Scan_Only_Decimal_Ghost; end Int_Params; private diff --git a/gcc/ada/libgnat/s-vauspe.adb b/gcc/ada/libgnat/s-vauspe.adb new file mode 100644 index 0000000..1a870b9 --- /dev/null +++ b/gcc/ada/libgnat/s-vauspe.adb @@ -0,0 +1,198 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V A L U E _ U _ S P E C -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2022-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/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma Assertion_Policy (Pre => Ignore, + Post => Ignore, + Contract_Cases => Ignore, + Ghost => Ignore, + Subprogram_Variant => Ignore); + +package body System.Value_U_Spec with SPARK_Mode is + + ----------------------------- + -- Exponent_Unsigned_Ghost -- + ----------------------------- + + function Exponent_Unsigned_Ghost + (Value : Uns; + Exp : Natural; + Base : Uns := 10) return Uns_Option + is + (if Exp = 0 or Value = 0 then (Overflow => False, Value => Value) + elsif Scan_Overflows_Ghost (0, Base, Value) then (Overflow => True) + else Exponent_Unsigned_Ghost (Value * Base, Exp - 1, Base)); + + --------------------- + -- Last_Hexa_Ghost -- + --------------------- + + function Last_Hexa_Ghost (Str : String) return Positive is + begin + for J in Str'Range loop + if Str (J) not in '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' | '_' then + return J - 1; + end if; + + pragma Loop_Invariant + (for all K in Str'First .. J => + Str (K) in '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' | '_'); + end loop; + + return Str'Last; + end Last_Hexa_Ghost; + + ----------------------------- + -- Lemmas with null bodies -- + ----------------------------- + + procedure Lemma_Scan_Based_Number_Ghost_Base + (Str : String; + From, To : Integer; + Base : Uns := 10; + Acc : Uns := 0) + is null; + + procedure Lemma_Scan_Based_Number_Ghost_Underscore + (Str : String; + From, To : Integer; + Base : Uns := 10; + Acc : Uns := 0) + is null; + + procedure Lemma_Scan_Based_Number_Ghost_Overflow + (Str : String; + From, To : Integer; + Base : Uns := 10; + Acc : Uns := 0) + is null; + + procedure Lemma_Scan_Based_Number_Ghost_Step + (Str : String; + From, To : Integer; + Base : Uns := 10; + Acc : Uns := 0) + is null; + + procedure Lemma_Exponent_Unsigned_Ghost_Base + (Value : Uns; + Exp : Natural; + Base : Uns := 10) + is null; + + procedure Lemma_Exponent_Unsigned_Ghost_Overflow + (Value : Uns; + Exp : Natural; + Base : Uns := 10) + is null; + + procedure Lemma_Exponent_Unsigned_Ghost_Step + (Value : Uns; + Exp : Natural; + Base : Uns := 10) + is null; + + -------------------------------------- + -- Prove_Scan_Based_Number_Ghost_Eq -- + -------------------------------------- + + procedure Prove_Scan_Based_Number_Ghost_Eq + (Str1, Str2 : String; + From, To : Integer; + Base : Uns := 10; + Acc : Uns := 0) + is + begin + if From > To then + null; + elsif Str1 (From) = '_' then + Prove_Scan_Based_Number_Ghost_Eq + (Str1, Str2, From + 1, To, Base, Acc); + elsif Scan_Overflows_Ghost + (Hexa_To_Unsigned_Ghost (Str1 (From)), Base, Acc) + then + null; + else + Prove_Scan_Based_Number_Ghost_Eq + (Str1, Str2, From + 1, To, Base, + Base * Acc + Hexa_To_Unsigned_Ghost (Str1 (From))); + end if; + end Prove_Scan_Based_Number_Ghost_Eq; + + ----------------------------------- + -- Prove_Scan_Only_Decimal_Ghost -- + ----------------------------------- + + procedure Prove_Scan_Only_Decimal_Ghost + (Str : String; + Val : Uns) + is + pragma Assert (Str (Str'First + 1) /= ' '); + Non_Blank : constant Positive := First_Non_Space_Ghost + (Str, Str'First, Str'Last); + pragma Assert (Non_Blank = Str'First + 1); + Fst_Num : constant Positive := + (if Str (Non_Blank) = '+' then Non_Blank + 1 else Non_Blank); + pragma Assert (Fst_Num = Str'First + 1); + begin + pragma Assert + (Is_Raw_Unsigned_Format_Ghost (Str (Fst_Num .. Str'Last))); + pragma Assert + (Scan_Split_No_Overflow_Ghost (Str, Str'First + 1, Str'Last)); + pragma Assert + ((Val, 10, 0) = Scan_Split_Value_Ghost (Str, Str'First + 1, Str'Last)); + pragma Assert + (Raw_Unsigned_No_Overflow_Ghost (Str, Fst_Num, Str'Last)); + pragma Assert (Val = Exponent_Unsigned_Ghost (Val, 0, 10).Value); + pragma Assert (Is_Unsigned_Ghost (Str)); + pragma Assert (Is_Value_Unsigned_Ghost (Str, Val)); + end Prove_Scan_Only_Decimal_Ghost; + + ----------------------------- + -- Scan_Based_Number_Ghost -- + ----------------------------- + + function Scan_Based_Number_Ghost + (Str : String; + From, To : Integer; + Base : Uns := 10; + Acc : Uns := 0) return Uns_Option + is + (if From > To then (Overflow => False, Value => Acc) + elsif Str (From) = '_' + then Scan_Based_Number_Ghost (Str, From + 1, To, Base, Acc) + elsif Scan_Overflows_Ghost + (Hexa_To_Unsigned_Ghost (Str (From)), Base, Acc) + then (Overflow => True) + else Scan_Based_Number_Ghost + (Str, From + 1, To, Base, + Base * Acc + Hexa_To_Unsigned_Ghost (Str (From)))); + +end System.Value_U_Spec; diff --git a/gcc/ada/libgnat/s-vauspe.ads b/gcc/ada/libgnat/s-vauspe.ads new file mode 100644 index 0000000..0d5c19e --- /dev/null +++ b/gcc/ada/libgnat/s-vauspe.ads @@ -0,0 +1,639 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V A L U E _ U _ S P E C -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2022-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/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the specification entities using for the formal +-- verification of the routines for scanning modular Unsigned values. + +-- Preconditions in this unit are meant for analysis only, not for run-time +-- checking, so that the expected exceptions are raised. This is enforced by +-- setting the corresponding assertion policy to Ignore. Postconditions and +-- contract cases should not be executed at runtime as well, in order not to +-- slow down the execution of these functions. + +pragma Assertion_Policy (Pre => Ignore, + Post => Ignore, + Contract_Cases => Ignore, + Ghost => Ignore, + Subprogram_Variant => Ignore); + +with System.Val_Util; use System.Val_Util; + +generic + + type Uns is mod <>; + +package System.Value_U_Spec with + Ghost, + SPARK_Mode, + Annotate => (GNATprove, Always_Return) +is + pragma Preelaborate; + + type Uns_Option (Overflow : Boolean := False) is record + case Overflow is + when True => + null; + when False => + Value : Uns := 0; + end case; + end record; + + function Wrap_Option (Value : Uns) return Uns_Option is + (Overflow => False, Value => Value); + + function Only_Decimal_Ghost + (Str : String; + From, To : Integer) + return Boolean + is + (for all J in From .. To => Str (J) in '0' .. '9') + with + Pre => From > To or else (From >= Str'First and then To <= Str'Last); + -- Ghost function that returns True if S has only decimal characters + -- from index From to index To. + + function Only_Hexa_Ghost (Str : String; From, To : Integer) return Boolean + is + (for all J in From .. To => + Str (J) in '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' | '_') + with + Pre => From > To or else (From >= Str'First and then To <= Str'Last); + -- Ghost function that returns True if S has only hexadecimal characters + -- from index From to index To. + + function Last_Hexa_Ghost (Str : String) return Positive + with + Pre => Str /= "" + and then Str (Str'First) in '0' .. '9' | 'a' .. 'f' | 'A' .. 'F', + Post => Last_Hexa_Ghost'Result in Str'Range + and then (if Last_Hexa_Ghost'Result < Str'Last then + Str (Last_Hexa_Ghost'Result + 1) not in + '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' | '_') + and then Only_Hexa_Ghost (Str, Str'First, Last_Hexa_Ghost'Result); + -- Ghost function that returns the index of the last character in S that + -- is either an hexadecimal digit or an underscore, which necessarily + -- exists given the precondition on Str. + + function Is_Based_Format_Ghost (Str : String) return Boolean + is + (Str /= "" + and then Str (Str'First) in '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' + and then + (declare + L : constant Positive := Last_Hexa_Ghost (Str); + begin + Str (L) /= '_' + and then (for all J in Str'First .. L => + (if Str (J) = '_' then Str (J + 1) /= '_')))); + -- Ghost function that determines if Str has the correct format for a + -- based number, consisting in a sequence of hexadecimal digits possibly + -- separated by single underscores. It may be followed by other characters. + + function Hexa_To_Unsigned_Ghost (X : Character) return Uns is + (case X is + when '0' .. '9' => Character'Pos (X) - Character'Pos ('0'), + when 'a' .. 'f' => Character'Pos (X) - Character'Pos ('a') + 10, + when 'A' .. 'F' => Character'Pos (X) - Character'Pos ('A') + 10, + when others => raise Program_Error) + with + Pre => X in '0' .. '9' | 'a' .. 'f' | 'A' .. 'F'; + -- Ghost function that computes the value corresponding to an hexadecimal + -- digit. + + function Scan_Overflows_Ghost + (Digit : Uns; + Base : Uns; + Acc : Uns) return Boolean + is + (Digit >= Base + or else Acc > Uns'Last / Base + or else Uns'Last - Digit < Base * Acc); + -- Ghost function which returns True if Digit + Base * Acc overflows or + -- Digit is greater than Base, as this is used by the algorithm for the + -- test of overflow. + + function Scan_Based_Number_Ghost + (Str : String; + From, To : Integer; + Base : Uns := 10; + Acc : Uns := 0) return Uns_Option + with + Subprogram_Variant => (Increases => From), + Pre => Str'Last /= Positive'Last + and then + (From > To or else (From >= Str'First and then To <= Str'Last)) + and then Only_Hexa_Ghost (Str, From, To); + -- Ghost function that recursively computes the based number in Str, + -- assuming Acc has been scanned already and scanning continues at index + -- From. + + -- Lemmas unfolding the recursive definition of Scan_Based_Number_Ghost + + procedure Lemma_Scan_Based_Number_Ghost_Base + (Str : String; + From, To : Integer; + Base : Uns := 10; + Acc : Uns := 0) + with + Global => null, + Pre => Str'Last /= Positive'Last + and then + (From > To or else (From >= Str'First and then To <= Str'Last)) + and then Only_Hexa_Ghost (Str, From, To), + Post => + (if From > To + then Scan_Based_Number_Ghost (Str, From, To, Base, Acc) = + (Overflow => False, Value => Acc)); + -- Base case: Scan_Based_Number_Ghost returns Acc if From is bigger than To + + procedure Lemma_Scan_Based_Number_Ghost_Underscore + (Str : String; + From, To : Integer; + Base : Uns := 10; + Acc : Uns := 0) + with + Global => null, + Pre => Str'Last /= Positive'Last + and then + (From > To or else (From >= Str'First and then To <= Str'Last)) + and then Only_Hexa_Ghost (Str, From, To), + Post => + (if From <= To and then Str (From) = '_' + then Scan_Based_Number_Ghost (Str, From, To, Base, Acc) = + Scan_Based_Number_Ghost (Str, From + 1, To, Base, Acc)); + -- Underscore case: underscores are ignored while scanning + + procedure Lemma_Scan_Based_Number_Ghost_Overflow + (Str : String; + From, To : Integer; + Base : Uns := 10; + Acc : Uns := 0) + with + Global => null, + Pre => Str'Last /= Positive'Last + and then + (From > To or else (From >= Str'First and then To <= Str'Last)) + and then Only_Hexa_Ghost (Str, From, To), + Post => + (if From <= To + and then Str (From) /= '_' + and then Scan_Overflows_Ghost + (Hexa_To_Unsigned_Ghost (Str (From)), Base, Acc) + then Scan_Based_Number_Ghost (Str, From, To, Base, Acc) = + (Overflow => True)); + -- Overflow case: scanning a digit which causes an overflow + + procedure Lemma_Scan_Based_Number_Ghost_Step + (Str : String; + From, To : Integer; + Base : Uns := 10; + Acc : Uns := 0) + with + Global => null, + Pre => Str'Last /= Positive'Last + and then + (From > To or else (From >= Str'First and then To <= Str'Last)) + and then Only_Hexa_Ghost (Str, From, To), + Post => + (if From <= To + and then Str (From) /= '_' + and then not Scan_Overflows_Ghost + (Hexa_To_Unsigned_Ghost (Str (From)), Base, Acc) + then Scan_Based_Number_Ghost (Str, From, To, Base, Acc) = + Scan_Based_Number_Ghost + (Str, From + 1, To, Base, + Base * Acc + Hexa_To_Unsigned_Ghost (Str (From)))); + -- Normal case: scanning a digit without overflows + + function Exponent_Unsigned_Ghost + (Value : Uns; + Exp : Natural; + Base : Uns := 10) return Uns_Option + with + Subprogram_Variant => (Decreases => Exp); + -- Ghost function that recursively computes Value * Base ** Exp + + -- Lemmas unfolding the recursive definition of Exponent_Unsigned_Ghost + + procedure Lemma_Exponent_Unsigned_Ghost_Base + (Value : Uns; + Exp : Natural; + Base : Uns := 10) + with + Post => + (if Exp = 0 or Value = 0 + then Exponent_Unsigned_Ghost (Value, Exp, Base) = + (Overflow => False, Value => Value)); + -- Base case: Exponent_Unsigned_Ghost returns 0 if Value or Exp is 0 + + procedure Lemma_Exponent_Unsigned_Ghost_Overflow + (Value : Uns; + Exp : Natural; + Base : Uns := 10) + with + Post => + (if Exp /= 0 + and then Value /= 0 + and then Scan_Overflows_Ghost (0, Base, Value) + then Exponent_Unsigned_Ghost (Value, Exp, Base) = (Overflow => True)); + -- Overflow case: the next multiplication overflows + + procedure Lemma_Exponent_Unsigned_Ghost_Step + (Value : Uns; + Exp : Natural; + Base : Uns := 10) + with + Post => + (if Exp /= 0 + and then Value /= 0 + and then not Scan_Overflows_Ghost (0, Base, Value) + then Exponent_Unsigned_Ghost (Value, Exp, Base) = + Exponent_Unsigned_Ghost (Value * Base, Exp - 1, Base)); + -- Normal case: exponentiation without overflows + + function Is_Raw_Unsigned_Format_Ghost (Str : String) return Boolean is + (Is_Natural_Format_Ghost (Str) + and then + (declare + Last_Num_Init : constant Integer := Last_Number_Ghost (Str); + Starts_As_Based : constant Boolean := + Last_Num_Init < Str'Last - 1 + and then Str (Last_Num_Init + 1) in '#' | ':' + and then Str (Last_Num_Init + 2) in + '0' .. '9' | 'a' .. 'f' | 'A' .. 'F'; + Last_Num_Based : constant Integer := + (if Starts_As_Based + then Last_Hexa_Ghost (Str (Last_Num_Init + 2 .. Str'Last)) + else Last_Num_Init); + Is_Based : constant Boolean := + Starts_As_Based + and then Last_Num_Based < Str'Last + and then Str (Last_Num_Based + 1) = Str (Last_Num_Init + 1); + First_Exp : constant Integer := + (if Is_Based then Last_Num_Based + 2 else Last_Num_Init + 1); + begin + (if Starts_As_Based then + Is_Based_Format_Ghost (Str (Last_Num_Init + 2 .. Str'Last)) + and then Last_Num_Based < Str'Last) + and then Is_Opt_Exponent_Format_Ghost + (Str (First_Exp .. Str'Last)))) + with + Pre => Str'Last /= Positive'Last; + -- Ghost function that determines if Str has the correct format for an + -- unsigned number without a sign character. + -- It is a natural number in base 10, optionally followed by a based + -- number surrounded by delimiters # or :, optionally followed by an + -- exponent part. + + type Split_Value_Ghost is record + Value : Uns; + Base : Uns; + Expon : Natural; + end record; + + function Scan_Split_No_Overflow_Ghost + (Str : String; + From, To : Integer) + return Boolean + is + (declare + Last_Num_Init : constant Integer := + Last_Number_Ghost (Str (From .. To)); + Init_Val : constant Uns_Option := + Scan_Based_Number_Ghost (Str, From, Last_Num_Init); + Starts_As_Based : constant Boolean := + Last_Num_Init < To - 1 + and then Str (Last_Num_Init + 1) in '#' | ':' + and then Str (Last_Num_Init + 2) in + '0' .. '9' | 'a' .. 'f' | 'A' .. 'F'; + Last_Num_Based : constant Integer := + (if Starts_As_Based + then Last_Hexa_Ghost (Str (Last_Num_Init + 2 .. To)) + else Last_Num_Init); + Based_Val : constant Uns_Option := + (if Starts_As_Based and then not Init_Val.Overflow + then Scan_Based_Number_Ghost + (Str, Last_Num_Init + 2, Last_Num_Based, Init_Val.Value) + else Init_Val); + begin + not Init_Val.Overflow + and then + (Last_Num_Init >= To - 1 + or else Str (Last_Num_Init + 1) not in '#' | ':' + or else Init_Val.Value in 2 .. 16) + and then + (not Starts_As_Based + or else not Based_Val.Overflow)) + with + Pre => Str'Last /= Positive'Last + and then From in Str'Range + and then To in From .. Str'Last + and then Str (From) in '0' .. '9'; + -- Ghost function that determines if an overflow might occur while scanning + -- the representation of an unsigned number. The computation overflows if + -- either: + -- * The computation of the decimal part overflows, + -- * The decimal part is followed by a valid delimiter for a based + -- part, and the number corresponding to the base is not a valid base, + -- or + -- * The computation of the based part overflows. + + pragma Warnings (Off, "constant * is not referenced"); + function Scan_Split_Value_Ghost + (Str : String; + From, To : Integer) + return Split_Value_Ghost + is + (declare + Last_Num_Init : constant Integer := + Last_Number_Ghost (Str (From .. To)); + Init_Val : constant Uns_Option := + Scan_Based_Number_Ghost (Str, From, Last_Num_Init); + Starts_As_Based : constant Boolean := + Last_Num_Init < To - 1 + and then Str (Last_Num_Init + 1) in '#' | ':' + and then Str (Last_Num_Init + 2) in + '0' .. '9' | 'a' .. 'f' | 'A' .. 'F'; + Last_Num_Based : constant Integer := + (if Starts_As_Based + then Last_Hexa_Ghost (Str (Last_Num_Init + 2 .. To)) + else Last_Num_Init); + Is_Based : constant Boolean := + Starts_As_Based + and then Last_Num_Based < To + and then Str (Last_Num_Based + 1) = Str (Last_Num_Init + 1); + Based_Val : constant Uns_Option := + (if Starts_As_Based and then not Init_Val.Overflow + then Scan_Based_Number_Ghost + (Str, Last_Num_Init + 2, Last_Num_Based, Init_Val.Value) + else Init_Val); + First_Exp : constant Integer := + (if Is_Based then Last_Num_Based + 2 else Last_Num_Init + 1); + Expon : constant Natural := + (if Starts_As_Exponent_Format_Ghost (Str (First_Exp .. To)) + then Scan_Exponent_Ghost (Str (First_Exp .. To)) + else 0); + Base : constant Uns := + (if Is_Based then Init_Val.Value else 10); + Value : constant Uns := + (if Is_Based then Based_Val.Value else Init_Val.Value); + begin + (Value => Value, Base => Base, Expon => Expon)) + with + Pre => Str'Last /= Positive'Last + and then From in Str'Range + and then To in From .. Str'Last + and then Str (From) in '0' .. '9' + and then Scan_Split_No_Overflow_Ghost (Str, From, To); + -- Ghost function that scans an unsigned number without a sign character + -- and return a record containing the values scanned for its value, its + -- base, and its exponent. + pragma Warnings (On, "constant * is not referenced"); + + function Raw_Unsigned_No_Overflow_Ghost + (Str : String; + From, To : Integer) + return Boolean + is + (Scan_Split_No_Overflow_Ghost (Str, From, To) + and then + (declare + Val : constant Split_Value_Ghost := Scan_Split_Value_Ghost + (Str, From, To); + begin + not Exponent_Unsigned_Ghost + (Val.Value, Val.Expon, Val.Base).Overflow)) + with + Pre => Str'Last /= Positive'Last + and then From in Str'Range + and then To in From .. Str'Last + and then Str (From) in '0' .. '9'; + -- Ghost function that determines if the computation of the unsigned number + -- represented by Str will overflow. The computation overflows if either: + -- * The scan of the string overflows, or + -- * The computation of the exponentiation overflows. + + function Scan_Raw_Unsigned_Ghost + (Str : String; + From, To : Integer) + return Uns + is + (declare + Val : constant Split_Value_Ghost := Scan_Split_Value_Ghost + (Str, From, To); + begin + Exponent_Unsigned_Ghost (Val.Value, Val.Expon, Val.Base).Value) + with + Pre => Str'Last /= Positive'Last + and then From in Str'Range + and then To in From .. Str'Last + and then Str (From) in '0' .. '9' + and then Raw_Unsigned_No_Overflow_Ghost (Str, From, To); + -- Ghost function that scans an unsigned number without a sign character + + function Raw_Unsigned_Last_Ghost + (Str : String; + From, To : Integer) + return Positive + is + (declare + Last_Num_Init : constant Integer := + Last_Number_Ghost (Str (From .. To)); + Starts_As_Based : constant Boolean := + Last_Num_Init < To - 1 + and then Str (Last_Num_Init + 1) in '#' | ':' + and then Str (Last_Num_Init + 2) in + '0' .. '9' | 'a' .. 'f' | 'A' .. 'F'; + Last_Num_Based : constant Integer := + (if Starts_As_Based + then Last_Hexa_Ghost (Str (Last_Num_Init + 2 .. To)) + else Last_Num_Init); + Is_Based : constant Boolean := + Starts_As_Based + and then Last_Num_Based < To + and then Str (Last_Num_Based + 1) = Str (Last_Num_Init + 1); + First_Exp : constant Integer := + (if Is_Based then Last_Num_Based + 2 else Last_Num_Init + 1); + begin + (if not Starts_As_Exponent_Format_Ghost (Str (First_Exp .. To)) + then First_Exp + elsif Str (First_Exp + 1) in '-' | '+' then + Last_Number_Ghost (Str (First_Exp + 2 .. To)) + 1 + else Last_Number_Ghost (Str (First_Exp + 1 .. To)) + 1)) + with + Pre => Str'Last /= Positive'Last + and then From in Str'Range + and then To in From .. Str'Last + and then Str (From) in '0' .. '9'; + -- Ghost function that returns the position of the cursor once an unsigned + -- number has been seen. + + function Slide_To_1 (Str : String) return String + with + Post => + Only_Space_Ghost (Str, Str'First, Str'Last) = + (for all J in Str'First .. Str'Last => + Slide_To_1'Result (J - Str'First + 1) = ' '); + -- Slides Str so that it starts at 1 + + function Slide_If_Necessary (Str : String) return String is + (if Str'Last = Positive'Last then Slide_To_1 (Str) else Str); + -- If Str'Last = Positive'Last then slides Str so that it starts at 1 + + function Is_Unsigned_Ghost (Str : String) return Boolean is + (declare + Non_Blank : constant Positive := First_Non_Space_Ghost + (Str, Str'First, Str'Last); + Fst_Num : constant Positive := + (if Str (Non_Blank) = '+' then Non_Blank + 1 else Non_Blank); + begin + Is_Raw_Unsigned_Format_Ghost (Str (Fst_Num .. Str'Last)) + and then Raw_Unsigned_No_Overflow_Ghost (Str, Fst_Num, Str'Last) + and then Only_Space_Ghost + (Str, Raw_Unsigned_Last_Ghost (Str, Fst_Num, Str'Last), Str'Last)) + with + Pre => not Only_Space_Ghost (Str, Str'First, Str'Last) + and then Str'Last /= Positive'Last; + -- Ghost function that determines if Str has the correct format for an + -- unsigned number, consisting in some blank characters, an optional + -- + sign, a raw unsigned number which does not overflow and then some + -- more blank characters. + + function Is_Value_Unsigned_Ghost (Str : String; Val : Uns) return Boolean is + (declare + Non_Blank : constant Positive := First_Non_Space_Ghost + (Str, Str'First, Str'Last); + Fst_Num : constant Positive := + (if Str (Non_Blank) = '+' then Non_Blank + 1 else Non_Blank); + begin + Val = Scan_Raw_Unsigned_Ghost (Str, Fst_Num, Str'Last)) + with + Pre => not Only_Space_Ghost (Str, Str'First, Str'Last) + and then Str'Last /= Positive'Last + and then Is_Unsigned_Ghost (Str); + -- Ghost function that returns True if Val is the value corresponding to + -- the unsigned number represented by Str. + + procedure Prove_Scan_Based_Number_Ghost_Eq + (Str1, Str2 : String; + From, To : Integer; + Base : Uns := 10; + Acc : Uns := 0) + with + Subprogram_Variant => (Increases => From), + Pre => Str1'Last /= Positive'Last + and then Str2'Last /= Positive'Last + and then + (From > To or else (From >= Str1'First and then To <= Str1'Last)) + and then + (From > To or else (From >= Str2'First and then To <= Str2'Last)) + and then Only_Hexa_Ghost (Str1, From, To) + and then (for all J in From .. To => Str1 (J) = Str2 (J)), + Post => + Scan_Based_Number_Ghost (Str1, From, To, Base, Acc) + = Scan_Based_Number_Ghost (Str2, From, To, Base, Acc); + -- Scan_Based_Number_Ghost returns the same value on two slices which are + -- equal. + + procedure Prove_Scan_Only_Decimal_Ghost + (Str : String; + Val : Uns) + with + Pre => Str'Last /= Positive'Last + and then Str'Length >= 2 + and then Str (Str'First) = ' ' + and then Only_Decimal_Ghost (Str, Str'First + 1, Str'Last) + and then Scan_Based_Number_Ghost (Str, Str'First + 1, Str'Last) + = Wrap_Option (Val), + Post => Is_Unsigned_Ghost (Slide_If_Necessary (Str)) + and then + Is_Value_Unsigned_Ghost (Slide_If_Necessary (Str), Val); + -- Ghost lemma used in the proof of 'Image implementation, to prove that + -- the result of Value_Unsigned on a decimal string is the same as the + -- result of Scan_Based_Number_Ghost. + + -- Bundle Uns type with other types, constants and subprograms used in + -- ghost code, so that this package can be instantiated once and used + -- multiple times as generic formal for a given Int type. + + package Uns_Params is new System.Val_Util.Uns_Params + (Uns => Uns, + P_Uns_Option => Uns_Option, + P_Wrap_Option => Wrap_Option, + P_Hexa_To_Unsigned_Ghost => Hexa_To_Unsigned_Ghost, + P_Scan_Overflows_Ghost => Scan_Overflows_Ghost, + P_Is_Raw_Unsigned_Format_Ghost => + Is_Raw_Unsigned_Format_Ghost, + P_Scan_Split_No_Overflow_Ghost => + Scan_Split_No_Overflow_Ghost, + P_Raw_Unsigned_No_Overflow_Ghost => + Raw_Unsigned_No_Overflow_Ghost, + P_Exponent_Unsigned_Ghost => Exponent_Unsigned_Ghost, + P_Lemma_Exponent_Unsigned_Ghost_Base => + Lemma_Exponent_Unsigned_Ghost_Base, + P_Lemma_Exponent_Unsigned_Ghost_Overflow => + Lemma_Exponent_Unsigned_Ghost_Overflow, + P_Lemma_Exponent_Unsigned_Ghost_Step => + Lemma_Exponent_Unsigned_Ghost_Step, + P_Scan_Raw_Unsigned_Ghost => Scan_Raw_Unsigned_Ghost, + P_Lemma_Scan_Based_Number_Ghost_Base => + Lemma_Scan_Based_Number_Ghost_Base, + P_Lemma_Scan_Based_Number_Ghost_Underscore => + Lemma_Scan_Based_Number_Ghost_Underscore, + P_Lemma_Scan_Based_Number_Ghost_Overflow => + Lemma_Scan_Based_Number_Ghost_Overflow, + P_Lemma_Scan_Based_Number_Ghost_Step => + Lemma_Scan_Based_Number_Ghost_Step, + P_Raw_Unsigned_Last_Ghost => Raw_Unsigned_Last_Ghost, + P_Only_Decimal_Ghost => Only_Decimal_Ghost, + P_Scan_Based_Number_Ghost => Scan_Based_Number_Ghost, + P_Is_Unsigned_Ghost => + Is_Unsigned_Ghost, + P_Is_Value_Unsigned_Ghost => + Is_Value_Unsigned_Ghost, + P_Prove_Scan_Only_Decimal_Ghost => + Prove_Scan_Only_Decimal_Ghost, + P_Prove_Scan_Based_Number_Ghost_Eq => + Prove_Scan_Based_Number_Ghost_Eq); + +private + + ---------------- + -- Slide_To_1 -- + ---------------- + + function Slide_To_1 (Str : String) return String is + (declare + Res : constant String (1 .. Str'Length) := Str; + begin + Res); + +end System.Value_U_Spec; diff --git a/gcc/ada/libgnat/s-widthu.adb b/gcc/ada/libgnat/s-widthu.adb index 390942c..df5f224 100644 --- a/gcc/ada/libgnat/s-widthu.adb +++ b/gcc/ada/libgnat/s-widthu.adb @@ -73,6 +73,14 @@ package body System.Width_U is Ghost, Post => X / Y / Z = X / (Y * Z); + procedure Lemma_Euclidian (V, Q, F, R : Big_Integer) + with + Ghost, + Pre => F > 0 and then Q = V / F and then R = V rem F, + Post => V = Q * F + R; + -- Ghost lemma to prove the relation between the quotient/remainder of + -- division by F and the value V. + ---------------------- -- Lemma_Lower_Mult -- ---------------------- @@ -104,6 +112,12 @@ package body System.Width_U is pragma Assert (X / YZ = XYZ + R / YZ); end Lemma_Div_Twice; + --------------------- + -- Lemma_Euclidian -- + --------------------- + + procedure Lemma_Euclidian (V, Q, F, R : Big_Integer) is null; + -- Local variables W : Natural; @@ -152,7 +166,7 @@ package body System.Width_U is R : constant Big_Integer := Big (T_Init) rem F with Ghost; begin pragma Assert (Q < Big_10); - pragma Assert (Big (T_Init) = Q * F + R); + Lemma_Euclidian (Big (T_Init), Q, F, R); Lemma_Lower_Mult (Q, Big (9), F); pragma Assert (Big (T_Init) <= Big (9) * F + F - 1); pragma Assert (Big (T_Init) < Big_10 * F); 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 0490895..8f903ca 100644 --- a/gcc/ada/opt.ads +++ b/gcc/ada/opt.ads @@ -267,6 +267,10 @@ package Opt is -- Set to True to detect whether subprogram parameters and function results -- alias the same object(s). + Check_Elaboration_Flags : Boolean := True; + -- GNATBIND + -- Set to False if switch -k is set. + Check_Float_Overflow : Boolean := False; -- GNAT -- Set to True to check that operations on predefined unconstrained float @@ -540,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 4ab4dcb..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; - -- An operator node is legal as a prefix to other names, - -- but not for a slice. + 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); - if Nkind (Prefix_Node) = N_Operator_Symbol then - Error_Msg_N ("illegal prefix for slice", Prefix_Node); - end if; + -- An operator node is legal as a prefix to other names, + -- but not for a slice. - -- If we have a name extension, go scan it + if Nkind (Prefix_Node) = N_Operator_Symbol then + Error_Msg_N ("illegal prefix for slice", Prefix_Node); + end if; - if Token in Token_Class_Namext then - goto Scan_Name_Extension_OK; + -- If we have a name extension, go scan it - -- Otherwise return (a slice is a name, but is not a call) + if Token in Token_Class_Namext then + goto Scan_Name_Extension_OK; - else - Expr_Form := EF_Name; - return Name_Node; - end if; + -- Otherwise return (a slice is a name, but is not a call) + + 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; @@ -3554,7 +3544,6 @@ package body Ch4 is when Tok_Of => Restore_Scan_State (State); Scan; -- past OF - Set_Defining_Identifier (Assoc_Node, Id); Iter_Spec := P_Iterator_Specification (Id); Set_Iterator_Specification (Assoc_Node, Iter_Spec); @@ -3639,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"); @@ -3838,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 3835588..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,14 +221,10 @@ 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, and - -- parsing a statement. + -- P_Declarative_Items to parse zero or more declarative items, + -- and parsing a statement. loop Ignore (Tok_Semicolon); @@ -255,31 +236,22 @@ package body Ch5 is (Statement_List, Declare_Expression => False, In_Spec => False, In_Statements => True); - -- Use the length of the list to determine whether we parsed any - -- declarative items. If so, it's an error pre-2022. ???We should - -- be calling Error_Msg_Ada_2022_Feature below, to advertise the - -- new feature, but that causes a lot of test diffs, so for now, - -- we mimic the old "...before begin" message. + -- Use the length of the list to determine whether we parsed + -- any declarative items. If so, it's an error unless language + -- extensions are enabled. if List_Length (Statement_List) > Num_Statements then if All_Errors_Mode or else No (Decl_Loc) then Decl_Loc := Sloc (Pick (Statement_List, Num_Statements + 1)); - if False then - Error_Msg_Ada_2022_Feature - ("declarations mixed with statements", - Sloc (Pick (Statement_List, Num_Statements + 1))); - else - if Ada_Version < Ada_2022 then - Error_Msg - ("declarations must come before BEGIN", Decl_Loc); - end if; - end if; + Error_Msg_GNAT_Extension + ("declarations mixed with statements", + Sloc (Pick (Statement_List, Num_Statements + 1))); end if; end if; end; - begin + begin -- handle Error_Resync if Style_Check then Style.Check_Indentation; end if; @@ -299,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 @@ -318,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 @@ -713,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 @@ -1461,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 @@ -1773,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; @@ -2281,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); @@ -2393,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 2cd8807..5db1fce 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -404,10 +404,6 @@ package body Sem_Aggr is -- The bounds of the aggregate itype are cooked up to look reasonable -- (in this particular case the bounds will be 1 .. 2). - function Is_Null_Aggregate (N : Node_Id) return Boolean; - -- Returns True for a "[]" aggregate (an Ada 2022 feature), even after - -- it has been transformed by expansion. Returns False otherwise. - procedure Make_String_Into_Aggregate (N : Node_Id); -- A string literal can appear in a context in which a one dimensional -- array of characters is expected. This procedure simply rewrites the @@ -419,9 +415,6 @@ package body Sem_Aggr is -- is constrained). If the subtype is unconstrained, then the bounds -- are determined in much the same way as the bounds for a null string -- literal with no applicable index constraint. - -- Emit a check that the bounds for each dimension define a null - -- range; no check is emitted if it is statically known that the - -- check would succeed. --------------------------------- -- Delta aggregate processing -- @@ -567,7 +560,29 @@ package body Sem_Aggr is end if; Set_Parent (Index_Constraints, N); - Collect_Aggr_Bounds (N, 1); + + -- When resolving a null aggregate we created a list of aggregate bounds + -- for the consecutive dimensions. The bounds for the first dimension + -- are attached as the Aggregate_Bounds of the aggregate node. + + if Is_Null_Aggregate (N) then + declare + This_Range : Node_Id := Aggregate_Bounds (N); + begin + for J in 1 .. Aggr_Dimension loop + Aggr_Range (J) := This_Range; + Next_Index (This_Range); + + -- Remove bounds from the list, so they can be reattached as + -- the First_Index/Next_Index again by the code that also + -- handles non-null aggregates. + + Remove (Aggr_Range (J)); + end loop; + end; + else + Collect_Aggr_Bounds (N, 1); + end if; -- Build the list of constrained indexes of our aggregate itype @@ -1203,9 +1218,6 @@ package body Sem_Aggr is Aggr_Subtyp := Any_Composite; - elsif Is_Null_Aggr then - Aggr_Subtyp := Etype (N); - else Aggr_Subtyp := Array_Aggr_Subtype (N, Typ); end if; @@ -1742,17 +1754,15 @@ package body Sem_Aggr is Loc : constant Source_Ptr := Sloc (N); Id : constant Entity_Id := Defining_Identifier (N); - Id_Typ : Entity_Id := Any_Type; - ----------------------- -- Remove_References -- ----------------------- - function Remove_Ref (N : Node_Id) return Traverse_Result; - -- Remove references to the entity Id after analysis, so it can be + function Remove_Reference (N : Node_Id) return Traverse_Result; + -- Remove reference to the entity Id after analysis, so it can be -- properly reanalyzed after construct is expanded into a loop. - function Remove_Ref (N : Node_Id) return Traverse_Result is + function Remove_Reference (N : Node_Id) return Traverse_Result is begin if Nkind (N) = N_Identifier and then Present (Entity (N)) @@ -1763,15 +1773,15 @@ package body Sem_Aggr is end if; Set_Analyzed (N, False); return OK; - end Remove_Ref; + end Remove_Reference; - procedure Remove_References is new Traverse_Proc (Remove_Ref); + procedure Remove_References is new Traverse_Proc (Remove_Reference); -- Local variables Choice : Node_Id; Dummy : Boolean; - Ent : Entity_Id; + Scop : Entity_Id; Expr : Node_Id; -- Start of processing for Resolve_Iterated_Component_Association @@ -1779,37 +1789,29 @@ package body Sem_Aggr is begin Error_Msg_Ada_2022_Feature ("iterated component", Loc); - if Present (Iterator_Specification (N)) then - Analyze (Name (Iterator_Specification (N))); + -- Create a scope in which to introduce an index, to make it visible + -- for the analysis of component expression. - -- We assume that the domain of iteration cannot be overloaded. + Scop := New_Internal_Entity (E_Loop, Current_Scope, Loc, 'L'); + Set_Etype (Scop, Standard_Void_Type); + Set_Parent (Scop, Parent (N)); + Push_Scope (Scop); - declare - Domain : constant Node_Id := Name (Iterator_Specification (N)); - D_Type : constant Entity_Id := Etype (Domain); - Elt : Entity_Id; - begin - if Is_Array_Type (D_Type) then - Id_Typ := Component_Type (D_Type); + -- If there is iterator specification, then its preanalysis will make + -- the index visible. - else - if Has_Aspect (D_Type, Aspect_Iterable) then - Elt := - Get_Iterable_Type_Primitive (D_Type, Name_Element); - if No (Elt) then - Error_Msg_N - ("missing Element primitive for iteration", Domain); - else - Id_Typ := Etype (Elt); - end if; - else - Error_Msg_N ("cannot iterate over", Domain); - end if; - end if; - end; + if Present (Iterator_Specification (N)) then + Preanalyze (Iterator_Specification (N)); + + -- Otherwise, analyze discrete choices and make the index visible else - Id_Typ := Index_Typ; + -- Insert index name into current scope but don't decorate it yet, + -- so that a premature usage of this name in discrete choices will + -- be nicely diagnosed. + + Enter_Name (Id); + Choice := First (Discrete_Choices (N)); while Present (Choice) loop @@ -1835,25 +1837,13 @@ package body Sem_Aggr is Next (Choice); end loop; - end if; - -- Create a scope in which to introduce an index, which is usually - -- visible in the expression for the component, and needed for its - -- analysis. - - Ent := New_Internal_Entity (E_Loop, Current_Scope, Loc, 'L'); - Set_Etype (Ent, Standard_Void_Type); - Set_Parent (Ent, Parent (N)); - Push_Scope (Ent); - - -- Insert and decorate the index variable in the current scope. - -- The expression has to be analyzed once the index variable is - -- directly visible. + -- Decorate the index variable - Enter_Name (Id); - Set_Etype (Id, Id_Typ); - Mutate_Ekind (Id, E_Variable); - Set_Scope (Id, Ent); + Set_Etype (Id, Index_Typ); + Mutate_Ekind (Id, E_Variable); + Set_Scope (Id, Scop); + end if; -- Analyze expression without expansion, to verify legality. -- When generating code, we then remove references to the index @@ -1926,7 +1916,7 @@ package body Sem_Aggr is and then No (Component_Associations (N)) and then not Null_Record_Present (N) then - return False; + return Failure; end if; -- Disable the warning for GNAT Mode to allow for easier transition. @@ -1966,7 +1956,7 @@ package body Sem_Aggr is Error_Msg_N ("mixed iterated component association" & " (RM 4.3.3 (17.1/5))", Assoc); - return False; + return Failure; end if; Next (Assoc); @@ -1985,7 +1975,7 @@ package body Sem_Aggr is Error_Msg_N ("mixed iterated component association" & " (RM 4.3.3 (17.1/5))", Assoc); - return False; + return Failure; end if; Next (Assoc); @@ -1997,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)); @@ -3075,7 +3070,8 @@ package body Sem_Aggr is elsif Present (Iterator_Specification (Comp)) then Copy := Copy_Separate_Tree (Iterator_Specification (Comp)); - Id_Name := Chars (Defining_Identifier (Comp)); + Id_Name := + Chars (Defining_Identifier (Iterator_Specification (Comp))); Analyze (Copy); Typ := Etype (Defining_Identifier (Copy)); @@ -3203,7 +3199,7 @@ package body Sem_Aggr is end if; end; - elsif Present (Add_Named_Subp) then + elsif Present (Add_Named_Subp) then declare -- Retrieves types of container, key, and element from the -- specified insertion procedure. @@ -4104,14 +4100,16 @@ package body Sem_Aggr is Loc : constant Source_Ptr := Sloc (N); Typ : constant Entity_Id := Etype (N); - Check : Node_Id; - Decl : Node_Id; Index : Node_Id; Lo, Hi : Node_Id; Constr : constant List_Id := New_List; - Subt : constant Entity_Id := Make_Temporary (Loc, 'S'); begin + -- Attach the list of constraints at the location of the aggregate, so + -- the individual constraints can be analyzed. + + Set_Parent (Constr, N); + -- Create a constrained subtype with null dimensions Index := First_Index (Typ); @@ -4126,40 +4124,14 @@ package body Sem_Aggr is Attribute_Name => Name_Pred, Expressions => New_List (New_Copy_Tree (Lo))); - -- Check that high bound (i.e., low bound predecessor) exists. - -- Fail if low bound is low bound of base subtype (in all cases, - -- including modular). - - Check := - Make_If_Statement (Loc, - Condition => - Make_Op_Le (Loc, New_Copy_Tree (Lo), New_Copy_Tree (Hi)), - Then_Statements => - New_List (Make_Raise_Constraint_Error - (Loc, Reason => CE_Range_Check_Failed))); - - Insert_Action (N, Check); - - Append (Make_Range (Loc, Lo, Hi), Constr); + Append (Make_Range (Loc, New_Copy_Tree (Lo), Hi), Constr); + Analyze_And_Resolve (Last (Constr), Etype (Index)); Index := Next_Index (Index); end loop; - Decl := Make_Subtype_Declaration (Loc, - Defining_Identifier => Subt, - Subtype_Indication => - Make_Subtype_Indication (Loc, - Subtype_Mark => - New_Occurrence_Of (Base_Type (Typ), Loc), - Constraint => - Make_Index_Or_Discriminant_Constraint (Loc, Constr))); - - Insert_Action (N, Decl); - Set_Is_Internal (Subt); - Analyze (Decl); - Set_Etype (N, Subt); Set_Compile_Time_Known_Aggregate (N); - Set_Aggregate_Bounds (N, New_Copy_Tree (First_Index (Etype (N)))); + Set_Aggregate_Bounds (N, First (Constr)); return True; end Resolve_Null_Array_Aggregate; @@ -5067,9 +5039,7 @@ package body Sem_Aggr is -- OTHERS cannot be used. -- Positional and named associations cannot be mixed. - if Present (Component_Associations (N)) - and then Present (First (Component_Associations (N))) - then + if Present (Component_Associations (N)) then declare Assoc : Node_Id; diff --git a/gcc/ada/sem_aggr.ads b/gcc/ada/sem_aggr.ads index 75af8f7..0d305a8 100644 --- a/gcc/ada/sem_aggr.ads +++ b/gcc/ada/sem_aggr.ads @@ -43,6 +43,10 @@ package Sem_Aggr is -- WARNING: There is a matching C declaration of this subprogram in fe.h + function Is_Null_Aggregate (N : Node_Id) return Boolean; + -- Returns True for a "[]" aggregate (an Ada 2022 feature), even after + -- it has been transformed by expansion. Returns False otherwise. + function Is_Null_Array_Aggregate_High_Bound (N : Node_Id) return Boolean; -- Returns True for the high bound of a null array aggregate. 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 a64a3cd..54b10dd 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -944,29 +944,6 @@ package body Sem_Ch13 is -- aspect node N for the given type (entity) of the aspect does not -- appear too late according to the rules in RM 13.1(9) and 13.1(10). - procedure Inherit_Delayed_Rep_Aspects (ASN : Node_Id); - -- As discussed in the spec of Aspects (see Aspect_Delay declaration), - -- a derived type can inherit aspects from its parent which have been - -- specified at the time of the derivation using an aspect, as in: - -- - -- type A is range 1 .. 10 - -- with Size => Not_Defined_Yet; - -- .. - -- type B is new A; - -- .. - -- Not_Defined_Yet : constant := 64; - -- - -- In this example, the Size of A is considered to be specified prior - -- to the derivation, and thus inherited, even though the value is not - -- known at the time of derivation. To deal with this, we use two entity - -- flags. The flag Has_Derived_Rep_Aspects is set in the parent type (A - -- here), and then the flag May_Inherit_Delayed_Rep_Aspects is set in - -- the derived type (B here). If this flag is set when the derived type - -- is frozen, then this procedure is called to ensure proper inheritance - -- of all delayed aspects from the parent type. The derived type is E, - -- the argument to Analyze_Aspects_At_Freeze_Point. ASN is the first - -- aspect specification node in the Rep_Item chain for the parent type. - procedure Make_Pragma_From_Boolean_Aspect (ASN : Node_Id); -- Given an aspect specification node ASN whose expression is an -- optional Boolean, this routines creates the corresponding pragma @@ -1084,199 +1061,6 @@ package body Sem_Ch13 is end if; end Check_Aspect_Too_Late; - --------------------------------- - -- Inherit_Delayed_Rep_Aspects -- - --------------------------------- - - procedure Inherit_Delayed_Rep_Aspects (ASN : Node_Id) is - A_Id : constant Aspect_Id := Get_Aspect_Id (ASN); - P : constant Entity_Id := Entity (ASN); - -- Entity for parent type - - N : Node_Id; - -- Item from Rep_Item chain - - A : Aspect_Id; - - begin - -- Loop through delayed aspects for the parent type - - N := ASN; - while Present (N) loop - if Nkind (N) = N_Aspect_Specification then - exit when Entity (N) /= P; - - if Is_Delayed_Aspect (N) then - A := Get_Aspect_Id (Chars (Identifier (N))); - - -- Process delayed rep aspect. For Boolean attributes it is - -- not possible to cancel an attribute once set (the attempt - -- to use an aspect with xxx => False is an error) for a - -- derived type. So for those cases, we do not have to check - -- if a clause has been given for the derived type, since it - -- is harmless to set it again if it is already set. - - case A is - - -- Alignment - - when Aspect_Alignment => - if not Has_Alignment_Clause (E) then - Set_Alignment (E, Alignment (P)); - end if; - - -- Atomic - - when Aspect_Atomic => - if Is_Atomic (P) then - Set_Is_Atomic (E); - end if; - - -- Atomic_Components - - when Aspect_Atomic_Components => - if Has_Atomic_Components (P) then - Set_Has_Atomic_Components (Base_Type (E)); - end if; - - -- Bit_Order - - when Aspect_Bit_Order => - if Is_Record_Type (E) - and then No (Get_Attribute_Definition_Clause - (E, Attribute_Bit_Order)) - and then Reverse_Bit_Order (P) - then - Set_Reverse_Bit_Order (Base_Type (E)); - end if; - - -- Component_Size - - when Aspect_Component_Size => - if Is_Array_Type (E) - and then not Has_Component_Size_Clause (E) - then - Set_Component_Size - (Base_Type (E), Component_Size (P)); - end if; - - -- Machine_Radix - - when Aspect_Machine_Radix => - if Is_Decimal_Fixed_Point_Type (E) - and then not Has_Machine_Radix_Clause (E) - then - Set_Machine_Radix_10 (E, Machine_Radix_10 (P)); - end if; - - -- Object_Size (also Size which also sets Object_Size) - - when Aspect_Object_Size - | Aspect_Size - => - if not Has_Size_Clause (E) - and then - No (Get_Attribute_Definition_Clause - (E, Attribute_Object_Size)) - then - Set_Esize (E, Esize (P)); - end if; - - -- Pack - - when Aspect_Pack => - if not Is_Packed (E) then - Set_Is_Packed (Base_Type (E)); - - if Is_Bit_Packed_Array (P) then - Set_Is_Bit_Packed_Array (Base_Type (E)); - Set_Packed_Array_Impl_Type - (E, Packed_Array_Impl_Type (P)); - end if; - end if; - - -- Scalar_Storage_Order - - when Aspect_Scalar_Storage_Order => - if (Is_Record_Type (E) or else Is_Array_Type (E)) - and then No (Get_Attribute_Definition_Clause - (E, Attribute_Scalar_Storage_Order)) - and then Reverse_Storage_Order (P) - then - Set_Reverse_Storage_Order (Base_Type (E)); - - -- Clear default SSO indications, since the aspect - -- overrides the default. - - Set_SSO_Set_Low_By_Default (Base_Type (E), False); - Set_SSO_Set_High_By_Default (Base_Type (E), False); - end if; - - -- Small - - when Aspect_Small => - if Is_Fixed_Point_Type (E) - and then not Has_Small_Clause (E) - then - Set_Small_Value (E, Small_Value (P)); - end if; - - -- Storage_Size - - when Aspect_Storage_Size => - if (Is_Access_Type (E) or else Is_Task_Type (E)) - and then not Has_Storage_Size_Clause (E) - then - Set_Storage_Size_Variable - (Base_Type (E), Storage_Size_Variable (P)); - end if; - - -- Value_Size - - when Aspect_Value_Size => - - -- Value_Size is never inherited, it is either set by - -- default, or it is explicitly set for the derived - -- type. So nothing to do here. - - null; - - -- Volatile - - when Aspect_Volatile => - if Is_Volatile (P) then - Set_Is_Volatile (E); - end if; - - -- Volatile_Full_Access (also Full_Access_Only) - - when Aspect_Volatile_Full_Access - | Aspect_Full_Access_Only - => - if Is_Volatile_Full_Access (P) then - Set_Is_Volatile_Full_Access (E); - end if; - - -- Volatile_Components - - when Aspect_Volatile_Components => - if Has_Volatile_Components (P) then - Set_Has_Volatile_Components (Base_Type (E)); - end if; - - -- That should be all the Rep Aspects - - when others => - pragma Assert (Aspect_Delay (A_Id) /= Rep_Aspect); - null; - end case; - end if; - end if; - - Next_Rep_Item (N); - end loop; - end Inherit_Delayed_Rep_Aspects; - ------------------------------------- -- Make_Pragma_From_Boolean_Aspect -- ------------------------------------- @@ -1600,15 +1384,6 @@ package body Sem_Ch13 is Next_Rep_Item (ASN); end loop; - -- This is where we inherit delayed rep aspects from our parent. Note - -- that if we fell out of the above loop with ASN non-empty, it means - -- we hit an aspect for an entity other than E, and it must be the - -- type from which we were derived. - - if May_Inherit_Delayed_Rep_Aspects (E) then - Inherit_Delayed_Rep_Aspects (ASN); - end if; - if In_Instance and then E /= Base_Type (E) and then Is_First_Subtype (E) @@ -2518,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; @@ -7184,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 @@ -7194,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; @@ -13126,139 +12904,6 @@ package body Sem_Ch13 is Inside_Freezing_Actions := Inside_Freezing_Actions - 1; - -- If we have a type with predicates, build predicate function. This is - -- not needed in the generic case, nor within e.g. TSS subprograms and - -- other predefined primitives. For a derived type, ensure that the - -- parent type is already frozen so that its predicate function has been - -- constructed already. This is necessary if the parent is declared - -- in a nested package and its own freeze point has not been reached. - - if Is_Type (E) - and then Nongeneric_Case - and then Has_Predicates (E) - and then Predicate_Check_In_Scope (N) - then - declare - Atyp : constant Entity_Id := Nearest_Ancestor (E); - begin - if Present (Atyp) - and then Has_Predicates (Atyp) - and then not Is_Frozen (Atyp) - then - Freeze_Before (N, Atyp); - end if; - end; - - -- Before we build a predicate function, ensure that discriminant - -- checking functions are available. The predicate function might - -- need to call these functions if the predicate references - -- any components declared in a variant part. - if Ekind (E) = E_Record_Type and then Has_Discriminants (E) then - Build_Or_Copy_Discr_Checking_Funcs (Parent (E)); - end if; - - Build_Predicate_Function (E, N); - end if; - - -- If type has delayed aspects, this is where we do the preanalysis at - -- the freeze point, as part of the consistent visibility check. Note - -- that this must be done after calling Build_Predicate_Function or - -- Build_Invariant_Procedure since these subprograms fix occurrences of - -- the subtype name in the saved expression so that they will not cause - -- trouble in the preanalysis. - - -- This is also not needed in the generic case - - if Nongeneric_Case - and then Has_Delayed_Aspects (E) - and then Scope (E) = Current_Scope - then - declare - Ritem : Node_Id; - - begin - -- Look for aspect specification entries for this entity - - Ritem := First_Rep_Item (E); - while Present (Ritem) loop - if Nkind (Ritem) = N_Aspect_Specification - and then Entity (Ritem) = E - and then Is_Delayed_Aspect (Ritem) - then - if Get_Aspect_Id (Ritem) in Aspect_CPU - | Aspect_Dynamic_Predicate - | Aspect_Predicate - | Aspect_Static_Predicate - | Aspect_Priority - then - -- Retrieve the visibility to components and discriminants - -- in order to properly analyze the aspects. - - Push_Type (E); - Check_Aspect_At_Freeze_Point (Ritem); - - -- In the case of predicate aspects, there will be - -- a corresponding Predicate pragma associated with - -- the aspect, and the expression of the pragma also - -- needs to be analyzed at this point, to ensure that - -- Save_Global_References will capture global refs in - -- expressions that occur in generic bodies, for proper - -- later resolution of the pragma in instantiations. - - if Is_Type (E) - and then Inside_A_Generic - and then Has_Predicates (E) - and then Present (Aspect_Rep_Item (Ritem)) - then - declare - Pragma_Args : constant List_Id := - Pragma_Argument_Associations - (Aspect_Rep_Item (Ritem)); - Pragma_Expr : constant Node_Id := - Expression (Next (First (Pragma_Args))); - begin - if Present (Pragma_Expr) then - Analyze_And_Resolve - (Pragma_Expr, Standard_Boolean); - end if; - end; - end if; - - Pop_Type (E); - - else - Check_Aspect_At_Freeze_Point (Ritem); - end if; - - -- A pragma Predicate should be checked like one of the - -- corresponding aspects, wrt possible misuse of ghost - -- entities. - - elsif Nkind (Ritem) = N_Pragma - and then No (Corresponding_Aspect (Ritem)) - and then - Get_Pragma_Id (Pragma_Name (Ritem)) = Pragma_Predicate - then - -- Retrieve the visibility to components and discriminants - -- in order to properly analyze the pragma. - - declare - Arg : constant Node_Id := - Next (First (Pragma_Argument_Associations (Ritem))); - begin - Push_Type (E); - Preanalyze_Spec_Expression - (Expression (Arg), Standard_Boolean); - Pop_Type (E); - end; - end if; - - Next_Rep_Item (Ritem); - end loop; - end; - - end if; - -- For a record type, deal with variant parts. This has to be delayed to -- this point, because of the issue of statically predicated subtypes, -- which we have to ensure are frozen before checking choices, since we @@ -13424,6 +13069,140 @@ package body Sem_Ch13 is end Check_Variant_Part; end if; + -- If we have a type with predicates, build predicate function. This is + -- not needed in the generic case, nor within e.g. TSS subprograms and + -- other predefined primitives. For a derived type, ensure that the + -- parent type is already frozen so that its predicate function has been + -- constructed already. This is necessary if the parent is declared + -- in a nested package and its own freeze point has not been reached. + + if Is_Type (E) + and then Nongeneric_Case + and then Has_Predicates (E) + and then Predicate_Check_In_Scope (N) + then + declare + Atyp : constant Entity_Id := Nearest_Ancestor (E); + + begin + if Present (Atyp) + and then Has_Predicates (Atyp) + and then not Is_Frozen (Atyp) + then + Freeze_Before (N, Atyp); + end if; + end; + + -- Before we build a predicate function, ensure that discriminant + -- checking functions are available. The predicate function might + -- need to call these functions if the predicate references any + -- components declared in a variant part. + + if Ekind (E) = E_Record_Type and then Has_Discriminants (E) then + Build_Or_Copy_Discr_Checking_Funcs (Parent (E)); + end if; + + Build_Predicate_Function (E, N); + end if; + + -- If type has delayed aspects, this is where we do the preanalysis at + -- the freeze point, as part of the consistent visibility check. Note + -- that this must be done after calling Build_Predicate_Function or + -- Build_Invariant_Procedure since these subprograms fix occurrences of + -- the subtype name in the saved expression so that they will not cause + -- trouble in the preanalysis. + + -- This is also not needed in the generic case + + if Nongeneric_Case + and then Has_Delayed_Aspects (E) + and then Scope (E) = Current_Scope + then + declare + Ritem : Node_Id; + + begin + -- Look for aspect specification entries for this entity + + Ritem := First_Rep_Item (E); + while Present (Ritem) loop + if Nkind (Ritem) = N_Aspect_Specification + and then Entity (Ritem) = E + and then Is_Delayed_Aspect (Ritem) + then + if Get_Aspect_Id (Ritem) in Aspect_CPU + | Aspect_Dynamic_Predicate + | Aspect_Predicate + | Aspect_Static_Predicate + | Aspect_Priority + then + -- Retrieve the visibility to components and discriminants + -- in order to properly analyze the aspects. + + Push_Type (E); + Check_Aspect_At_Freeze_Point (Ritem); + + -- In the case of predicate aspects, there will be + -- a corresponding Predicate pragma associated with + -- the aspect, and the expression of the pragma also + -- needs to be analyzed at this point, to ensure that + -- Save_Global_References will capture global refs in + -- expressions that occur in generic bodies, for proper + -- later resolution of the pragma in instantiations. + + if Is_Type (E) + and then Inside_A_Generic + and then Has_Predicates (E) + and then Present (Aspect_Rep_Item (Ritem)) + then + declare + Pragma_Args : constant List_Id := + Pragma_Argument_Associations + (Aspect_Rep_Item (Ritem)); + Pragma_Expr : constant Node_Id := + Expression (Next (First (Pragma_Args))); + begin + if Present (Pragma_Expr) then + Analyze_And_Resolve + (Pragma_Expr, Standard_Boolean); + end if; + end; + end if; + + Pop_Type (E); + + else + Check_Aspect_At_Freeze_Point (Ritem); + end if; + + -- A pragma Predicate should be checked like one of the + -- corresponding aspects, wrt possible misuse of ghost + -- entities. + + elsif Nkind (Ritem) = N_Pragma + and then No (Corresponding_Aspect (Ritem)) + and then + Get_Pragma_Id (Pragma_Name (Ritem)) = Pragma_Predicate + then + -- Retrieve the visibility to components and discriminants + -- in order to properly analyze the pragma. + + declare + Arg : constant Node_Id := + Next (First (Pragma_Argument_Associations (Ritem))); + begin + Push_Type (E); + Preanalyze_Spec_Expression + (Expression (Arg), Standard_Boolean); + Pop_Type (E); + end; + end if; + + Next_Rep_Item (Ritem); + end loop; + end; + end if; + if not In_Generic_Scope (E) and then Ekind (E) = E_Record_Type and then Is_Tagged_Type (E) @@ -13738,14 +13517,6 @@ package body Sem_Ch13 is -- representation aspect in the rep item chain of Typ, if any, isn't -- directly specified to Typ but to one of its parents. - -- ??? Note that, for now, just a limited number of representation - -- aspects have been inherited here so far. Many of them are - -- still inherited in Sem_Ch3. This will be fixed soon. Here is - -- a non- exhaustive list of aspects that likely also need to - -- be moved to this routine: Alignment, Component_Alignment, - -- Component_Size, Machine_Radix, Object_Size, Pack, Predicates, - -- Preelaborable_Initialization, RM_Size and Small. - -- In addition, Convention must be propagated from base type to subtype, -- because the subtype may have been declared on an incomplete view. @@ -13813,9 +13584,21 @@ package body Sem_Ch13 is and then not Has_Rep_Item (Typ, Name_Default_Component_Value, False) and then Has_Rep_Item (Typ, Name_Default_Component_Value) then - Set_Default_Aspect_Component_Value (Typ, - Default_Aspect_Component_Value - (Entity (Get_Rep_Item (Typ, Name_Default_Component_Value)))); + declare + E : Entity_Id; + + begin + E := Entity (Get_Rep_Item (Typ, Name_Default_Component_Value)); + + -- Deal with private types + + if Is_Private_Type (E) then + E := Full_View (E); + end if; + + Set_Default_Aspect_Component_Value (Typ, + Default_Aspect_Component_Value (E)); + end; end if; -- Default_Value @@ -13826,9 +13609,21 @@ package body Sem_Ch13 is and then Has_Rep_Item (Typ, Name_Default_Value) then Set_Has_Default_Aspect (Typ); - Set_Default_Aspect_Value (Typ, - Default_Aspect_Value - (Entity (Get_Rep_Item (Typ, Name_Default_Value)))); + + declare + E : Entity_Id; + + begin + E := Entity (Get_Rep_Item (Typ, Name_Default_Value)); + + -- Deal with private types + + if Is_Private_Type (E) then + E := Full_View (E); + end if; + + Set_Default_Aspect_Value (Typ, Default_Aspect_Value (E)); + end; end if; -- Discard_Names @@ -13956,6 +13751,209 @@ package body Sem_Ch13 is end if; end Inherit_Aspects_At_Freeze_Point; + --------------------------------- + -- Inherit_Delayed_Rep_Aspects -- + --------------------------------- + + procedure Inherit_Delayed_Rep_Aspects (Typ : Entity_Id) is + A : Aspect_Id; + N : Node_Id; + P : Entity_Id; + + begin + -- Find the first aspect that has been inherited + + N := First_Rep_Item (Typ); + while Present (N) loop + if Nkind (N) = N_Aspect_Specification then + exit when Entity (N) /= Typ; + end if; + + Next_Rep_Item (N); + end loop; + + -- There must be one if we reach here + + pragma Assert (Present (N)); + P := Entity (N); + + -- Loop through delayed aspects for the parent type + + while Present (N) loop + if Nkind (N) = N_Aspect_Specification then + exit when Entity (N) /= P; + + if Is_Delayed_Aspect (N) then + A := Get_Aspect_Id (N); + + -- Process delayed rep aspect. For Boolean attributes it is + -- not possible to cancel an attribute once set (the attempt + -- to use an aspect with xxx => False is an error) for a + -- derived type. So for those cases, we do not have to check + -- if a clause has been given for the derived type, since it + -- is harmless to set it again if it is already set. + + case A is + + -- Alignment + + when Aspect_Alignment => + if not Has_Alignment_Clause (Typ) then + Set_Alignment (Typ, Alignment (P)); + end if; + + -- Atomic + + when Aspect_Atomic => + if Is_Atomic (P) then + Set_Is_Atomic (Typ); + end if; + + -- Atomic_Components + + when Aspect_Atomic_Components => + if Has_Atomic_Components (P) then + Set_Has_Atomic_Components (Base_Type (Typ)); + end if; + + -- Bit_Order + + when Aspect_Bit_Order => + if Is_Record_Type (Typ) + and then No (Get_Attribute_Definition_Clause + (Typ, Attribute_Bit_Order)) + and then Reverse_Bit_Order (P) + then + Set_Reverse_Bit_Order (Base_Type (Typ)); + end if; + + -- Component_Size + + when Aspect_Component_Size => + if Is_Array_Type (Typ) + and then not Has_Component_Size_Clause (Typ) + then + Set_Component_Size + (Base_Type (Typ), Component_Size (P)); + end if; + + -- Machine_Radix + + when Aspect_Machine_Radix => + if Is_Decimal_Fixed_Point_Type (Typ) + and then not Has_Machine_Radix_Clause (Typ) + then + Set_Machine_Radix_10 (Typ, Machine_Radix_10 (P)); + end if; + + -- Object_Size (also Size which also sets Object_Size) + + when Aspect_Object_Size + | Aspect_Size + => + if not Has_Size_Clause (Typ) + and then + No (Get_Attribute_Definition_Clause + (Typ, Attribute_Object_Size)) + then + Set_Esize (Typ, Esize (P)); + end if; + + -- Pack + + when Aspect_Pack => + if not Is_Packed (Typ) then + Set_Is_Packed (Base_Type (Typ)); + + if Is_Bit_Packed_Array (P) then + Set_Is_Bit_Packed_Array (Base_Type (Typ)); + Set_Packed_Array_Impl_Type + (Typ, Packed_Array_Impl_Type (P)); + end if; + end if; + + -- Scalar_Storage_Order + + when Aspect_Scalar_Storage_Order => + if (Is_Record_Type (Typ) or else Is_Array_Type (Typ)) + and then No (Get_Attribute_Definition_Clause + (Typ, Attribute_Scalar_Storage_Order)) + and then Reverse_Storage_Order (P) + then + Set_Reverse_Storage_Order (Base_Type (Typ)); + + -- Clear default SSO indications, since the aspect + -- overrides the default. + + Set_SSO_Set_Low_By_Default (Base_Type (Typ), False); + Set_SSO_Set_High_By_Default (Base_Type (Typ), False); + end if; + + -- Small + + when Aspect_Small => + if Is_Fixed_Point_Type (Typ) + and then not Has_Small_Clause (Typ) + then + Set_Small_Value (Typ, Small_Value (P)); + end if; + + -- Storage_Size + + when Aspect_Storage_Size => + if (Is_Access_Type (Typ) or else Is_Task_Type (Typ)) + and then not Has_Storage_Size_Clause (Typ) + then + Set_Storage_Size_Variable + (Base_Type (Typ), Storage_Size_Variable (P)); + end if; + + -- Value_Size + + when Aspect_Value_Size => + + -- Value_Size is never inherited, it is either set by + -- default, or it is explicitly set for the derived + -- type. So nothing to do here. + + null; + + -- Volatile + + when Aspect_Volatile => + if Is_Volatile (P) then + Set_Is_Volatile (Typ); + end if; + + -- Volatile_Full_Access (also Full_Access_Only) + + when Aspect_Volatile_Full_Access + | Aspect_Full_Access_Only + => + if Is_Volatile_Full_Access (P) then + Set_Is_Volatile_Full_Access (Typ); + end if; + + -- Volatile_Components + + when Aspect_Volatile_Components => + if Has_Volatile_Components (P) then + Set_Has_Volatile_Components (Base_Type (Typ)); + end if; + + -- That should be all the Rep Aspects + + when others => + pragma Assert (Aspect_Delay (A) /= Rep_Aspect); + null; + end case; + end if; + end if; + + Next_Rep_Item (N); + end loop; + end Inherit_Delayed_Rep_Aspects; + ---------------- -- Initialize -- ---------------- @@ -15880,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 @@ -15906,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 @@ -15919,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 @@ -15929,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 @@ -17089,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); @@ -17731,7 +17747,9 @@ package body Sem_Ch13 is begin -- Skip if function marked as warnings off - if Warnings_Off (Act_Unit) or else Serious_Errors_Detected > 0 then + if Has_Warnings_Off (Act_Unit) + or else Serious_Errors_Detected > 0 + then goto Continue; end if; diff --git a/gcc/ada/sem_ch13.ads b/gcc/ada/sem_ch13.ads index e0d84c9..1405f89 100644 --- a/gcc/ada/sem_ch13.ads +++ b/gcc/ada/sem_ch13.ads @@ -324,6 +324,36 @@ package Sem_Ch13 is -- Given an entity Typ that denotes a derived type or a subtype, this -- routine performs the inheritance of aspects at the freeze point. + -- ??? Note that, for now, just a limited number of representation aspects + -- have been inherited here so far. Many of them are still inherited in + -- Sem_Ch3 and need to be dealt with. Here is a non-exhaustive list of + -- aspects that likely also need to be moved to this routine: Alignment, + -- Component_Alignment, Component_Size, Machine_Radix, Object_Size, Pack, + -- Predicates, Preelaborable_Initialization, Size and Small. + + procedure Inherit_Delayed_Rep_Aspects (Typ : Entity_Id); + -- As discussed in the spec of Aspects (see Aspect_Delay declaration), + -- a derived type can inherit aspects from its parent which have been + -- specified at the time of the derivation using an aspect, as in: + -- + -- type A is range 1 .. 10 + -- with Size => Not_Defined_Yet; + -- .. + -- type B is new A; + -- .. + -- Not_Defined_Yet : constant := 64; + -- + -- In this example, the Size of A is considered to be specified prior + -- to the derivation, and thus inherited, even though the value is not + -- known at the time of derivation. To deal with this, we use two entity + -- flags. The flag Has_Derived_Rep_Aspects is set in the parent type (A + -- here), and then the flag May_Inherit_Delayed_Rep_Aspects is set in + -- the derived type (B here). If this flag is set when the derived type + -- is frozen, then this procedure is called to ensure proper inheritance + -- of all delayed aspects from the parent type. + + -- ??? Obviously we ought not to have two mechanisms to do the same thing + procedure Resolve_Aspect_Expressions (E : Entity_Id); -- Name resolution of an aspect expression happens at the end of the -- current declarative part or at the freeze point for the entity, diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 790d1d1..00c2e67 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -4770,20 +4770,13 @@ package body Sem_Ch3 is if not Is_Entity_Name (Object_Definition (N)) then Act_T := Etype (E); Check_Compile_Time_Size (Act_T); - - if Aliased_Present (N) then - Set_Is_Constr_Subt_For_UN_Aliased (Act_T); - end if; end if; -- When the given object definition and the aggregate are specified -- independently, and their lengths might differ do a length check. -- This cannot happen if the aggregate is of the form (others =>...) - if not Is_Constrained (T) then - null; - - elsif Nkind (E) = N_Raise_Constraint_Error then + if Nkind (E) = N_Raise_Constraint_Error then -- Aggregate is statically illegal. Place back in declaration @@ -7419,12 +7412,13 @@ package body Sem_Ch3 is Analyze (High_Bound (Range_Expression (Constraint (Indic)))); end if; - -- Introduce an implicit base type for the derived type even if there + -- Create an implicit base type for the derived type even if there -- is no constraint attached to it, since this seems closer to the - -- Ada semantics. Build a full type declaration tree for the derived - -- type using the implicit base type as the defining identifier. Then - -- build a subtype declaration tree which applies the constraint (if - -- any) have it replace the derived type declaration. + -- Ada semantics. Use an Itype like for the implicit base type of + -- other kinds of derived type, but build a full type declaration + -- for it so as to analyze the new literals properly. Then build a + -- subtype declaration tree which applies the constraint (if any) + -- and have it replace the derived type declaration. Literal := First_Literal (Parent_Type); Literals_List := New_List; @@ -7457,8 +7451,7 @@ package body Sem_Ch3 is end loop; Implicit_Base := - Make_Defining_Identifier (Sloc (Derived_Type), - Chars => New_External_Name (Chars (Derived_Type), 'B')); + Create_Itype (E_Enumeration_Type, N, Derived_Type, 'B'); -- Indicate the proper nature of the derived type. This must be done -- before analysis of the literals, to recognize cases when a literal @@ -7471,12 +7464,12 @@ package body Sem_Ch3 is Type_Decl := Make_Full_Type_Declaration (Loc, Defining_Identifier => Implicit_Base, - Discriminant_Specifications => No_List, Type_Definition => Make_Enumeration_Type_Definition (Loc, Literals_List)); - Mark_Rewrite_Insertion (Type_Decl); - Insert_Before (N, Type_Decl); + -- Do not insert the declarationn, just analyze it in the context + + Set_Parent (Type_Decl, Parent (N)); Analyze (Type_Decl); -- The anonymous base now has a full declaration, but this base @@ -7777,35 +7770,6 @@ package body Sem_Ch3 is -- must be converted to the derived type. Convert_Scalar_Bounds (N, Parent_Type, Derived_Type, Loc); - - -- The implicit_base should be frozen when the derived type is frozen, - -- but note that it is used in the conversions of the bounds. For fixed - -- types we delay the determination of the bounds until the proper - -- freezing point. For other numeric types this is rejected by GCC, for - -- reasons that are currently unclear (???), so we choose to freeze the - -- implicit base now. In the case of integers and floating point types - -- this is harmless because subsequent representation clauses cannot - -- affect anything, but it is still baffling that we cannot use the - -- same mechanism for all derived numeric types. - - -- There is a further complication: actually some representation - -- clauses can affect the implicit base type. For example, attribute - -- definition clauses for stream-oriented attributes need to set the - -- corresponding TSS entries on the base type, and this normally - -- cannot be done after the base type is frozen, so the circuitry in - -- Sem_Ch13.New_Stream_Subprogram must account for this possibility - -- and not use Set_TSS in this case. - - -- There are also consequences for the case of delayed representation - -- aspects for some cases. For example, a Size aspect is delayed and - -- should not be evaluated to the freeze point. This early freezing - -- means that the size attribute evaluation happens too early??? - - if Is_Fixed_Point_Type (Parent_Type) then - Conditional_Delay (Implicit_Base, Parent_Type); - else - Freeze_Before (N, Implicit_Base); - end if; end Build_Derived_Numeric_Type; -------------------------------- @@ -14450,14 +14414,18 @@ package body Sem_Ch3 is begin Mutate_Ekind (Def_Id, E_Enumeration_Subtype); - Set_First_Literal (Def_Id, First_Literal (Base_Type (T))); + Set_First_Literal (Def_Id, First_Literal (Base_Type (T))); + Set_Etype (Def_Id, Base_Type (T)); + Set_Size_Info (Def_Id, (T)); + Set_Is_Character_Type (Def_Id, Is_Character_Type (T)); + Set_Scalar_Range_For_Subtype (Def_Id, Range_Expression (C), T); - Set_Etype (Def_Id, Base_Type (T)); - Set_Size_Info (Def_Id, (T)); - Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); - Set_Is_Character_Type (Def_Id, Is_Character_Type (T)); + -- Inherit the chain of representation items instead of replacing it + -- because Build_Derived_Enumeration_Type rewrites the declaration of + -- the derived type as a subtype declaration and the former needs to + -- preserve existing representation items (see Build_Derived_Type). - Set_Scalar_Range_For_Subtype (Def_Id, Range_Expression (C), T); + Inherit_Rep_Item_Chain (Def_Id, T); Set_Discrete_RM_Size (Def_Id); end Constrain_Enumeration; @@ -16999,11 +16967,9 @@ package body Sem_Ch3 is Low_Bound => Lo, High_Bound => Hi)); - Conditional_Delay (Derived_Type, Parent_Type); - - Mutate_Ekind (Derived_Type, E_Enumeration_Subtype); - Set_Etype (Derived_Type, Implicit_Base); - Set_Size_Info (Derived_Type, Parent_Type); + Mutate_Ekind (Derived_Type, E_Enumeration_Subtype); + Set_Etype (Derived_Type, Implicit_Base); + Set_Size_Info (Derived_Type, Parent_Type); if not Known_RM_Size (Derived_Type) then Set_RM_Size (Derived_Type, RM_Size (Parent_Type)); @@ -17022,16 +16988,6 @@ package body Sem_Ch3 is end if; Convert_Scalar_Bounds (N, Parent_Type, Derived_Type, Loc); - - -- Because the implicit base is used in the conversion of the bounds, we - -- have to freeze it now. This is similar to what is done for numeric - -- types, and it equally suspicious, but otherwise a nonstatic bound - -- will have a reference to an unfrozen type, which is rejected by Gigi - -- (???). This requires specific care for definition of stream - -- attributes. For details, see comments at the end of - -- Build_Derived_Numeric_Type. - - Freeze_Before (N, Implicit_Base); end Derived_Standard_Character; ------------------------------ diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 5497483..ceaf66b 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -4394,9 +4394,8 @@ package body Sem_Ch4 is procedure Analyze_Quantified_Expression (N : Node_Id) is function Is_Empty_Range (Typ : Entity_Id) return Boolean; - -- If the iterator is part of a quantified expression, and the range is - -- known to be statically empty, emit a warning and replace expression - -- with its static value. Returns True if the replacement occurs. + -- Return True if the iterator is part of a quantified expression and + -- the range is known to be statically empty. function No_Else_Or_Trivial_True (If_Expr : Node_Id) return Boolean; -- Determine whether if expression If_Expr lacks an else part or if it @@ -4407,36 +4406,12 @@ package body Sem_Ch4 is -------------------- function Is_Empty_Range (Typ : Entity_Id) return Boolean is - Loc : constant Source_Ptr := Sloc (N); - begin - if Is_Array_Type (Typ) + return Is_Array_Type (Typ) and then Compile_Time_Known_Bounds (Typ) and then - (Expr_Value (Type_Low_Bound (Etype (First_Index (Typ)))) > - Expr_Value (Type_High_Bound (Etype (First_Index (Typ))))) - then - Preanalyze_And_Resolve (Condition (N), Standard_Boolean); - - if All_Present (N) then - Error_Msg_N - ("??quantified expression with ALL " - & "over a null range has value True", N); - Rewrite (N, New_Occurrence_Of (Standard_True, Loc)); - - else - Error_Msg_N - ("??quantified expression with SOME " - & "over a null range has value False", N); - Rewrite (N, New_Occurrence_Of (Standard_False, Loc)); - end if; - - Analyze (N); - return True; - - else - return False; - end if; + Expr_Value (Type_Low_Bound (Etype (First_Index (Typ)))) > + Expr_Value (Type_High_Bound (Etype (First_Index (Typ)))); end Is_Empty_Range; ----------------------------- @@ -4456,6 +4431,7 @@ package body Sem_Ch4 is -- Local variables Cond : constant Node_Id := Condition (N); + Loc : constant Source_Ptr := Sloc (N); Loop_Id : Entity_Id; QE_Scop : Entity_Id; @@ -4466,7 +4442,7 @@ package body Sem_Ch4 is -- expression. The scope is needed to provide proper visibility of the -- loop variable. - QE_Scop := New_Internal_Entity (E_Loop, Current_Scope, Sloc (N), 'L'); + QE_Scop := New_Internal_Entity (E_Loop, Current_Scope, Loc, 'L'); Set_Etype (QE_Scop, Standard_Void_Type); Set_Scope (QE_Scop, Current_Scope); Set_Parent (QE_Scop, N); @@ -4482,11 +4458,30 @@ package body Sem_Ch4 is Preanalyze (Iterator_Specification (N)); -- Do not proceed with the analysis when the range of iteration is - -- empty. The appropriate error is issued by Is_Empty_Range. + -- empty. if Is_Entity_Name (Name (Iterator_Specification (N))) and then Is_Empty_Range (Etype (Name (Iterator_Specification (N)))) then + Preanalyze_And_Resolve (Condition (N), Standard_Boolean); + End_Scope; + + -- Emit a warning and replace expression with its static value + + if All_Present (N) then + Error_Msg_N + ("??quantified expression with ALL " + & "over a null range has value True", N); + Rewrite (N, New_Occurrence_Of (Standard_True, Loc)); + + else + Error_Msg_N + ("??quantified expression with SOME " + & "over a null range has value False", N); + Rewrite (N, New_Occurrence_Of (Standard_False, Loc)); + end if; + + Analyze (N); return; end if; @@ -4803,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; @@ -4819,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 @@ -4847,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 -- -------------------------------- @@ -5134,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 @@ -5294,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_ch5.adb b/gcc/ada/sem_ch5.adb index e1b5722..17bf6d9 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -2211,7 +2211,7 @@ package body Sem_Ch5 is procedure Check_Subtype_Definition (Comp_Type : Entity_Id) is begin - if not Present (Subt) then + if No (Subt) then return; end if; @@ -2231,9 +2231,8 @@ package body Sem_Ch5 is Subt, Comp_Type); end if; - elsif Present (Subt) - and then (not Covers (Base_Type (Bas), Comp_Type) - or else not Subtypes_Statically_Match (Bas, Comp_Type)) + elsif not Covers (Base_Type (Bas), Comp_Type) + or else not Subtypes_Statically_Match (Bas, Comp_Type) then if Is_Array_Type (Typ) then Error_Msg_NE @@ -2330,7 +2329,7 @@ package body Sem_Ch5 is Decl := Make_Full_Type_Declaration (Loc, Defining_Identifier => S, - Type_Definition => + Type_Definition => New_Copy_Tree (Access_To_Subprogram_Definition (Subt))); end if; @@ -3365,9 +3364,7 @@ package body Sem_Ch5 is declare Flist : constant List_Id := Freeze_Entity (Id, N); begin - if Is_Non_Empty_List (Flist) then - Insert_Actions (N, Flist); - end if; + Insert_Actions (N, Flist); end; end if; diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index e4af71c..7db0cb7 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -505,7 +505,7 @@ package body Sem_Ch6 is -- this because it is not part of the original source. -- If this is an ignored Ghost entity, analysis of the generated -- body is needed to hide external references (as is done in - -- Analyze_Subprogram_Body) after which the the subprogram profile + -- Analyze_Subprogram_Body) after which the subprogram profile -- can be frozen, which is needed to expand calls to such an ignored -- Ghost subprogram. @@ -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; @@ -5410,13 +5403,11 @@ package body Sem_Ch6 is -- the warning. declare - Stm : Node_Id; - + Stm : Node_Id := First (Statements (Handled_Statement_Sequence (N))); begin -- Skip call markers installed by the ABE mechanism, labels, and -- Push_xxx_Error_Label to find the first real statement. - Stm := First (Statements (HSS)); while Nkind (Stm) in N_Call_Marker | N_Label | N_Push_xxx_Label loop Next (Stm); end loop; @@ -5513,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_disp.ads b/gcc/ada/sem_disp.ads index 563b7f3..841fc74 100644 --- a/gcc/ada/sem_disp.ads +++ b/gcc/ada/sem_disp.ads @@ -63,7 +63,7 @@ package Sem_Disp is -- the inherited subprogram will have been hidden by the current one at -- the point of the type derivation, so it does not appear in the list -- of primitive operations of the type, and this procedure inserts the - -- overriding subprogram in the the full type's list of primitives by + -- overriding subprogram in the full type's list of primitives by -- iterating over the list for the parent type. If instead Subp is a new -- primitive, then it's simply appended to the primitive list. diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb index 077c988..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. @@ -3339,7 +3326,9 @@ package body Sem_Elab is Traverse_List (Else_Actions (Scen)); elsif Nkind (Scen) in - N_Component_Association | N_Iterated_Component_Association + N_Component_Association + | N_Iterated_Component_Association + | N_Iterated_Element_Association then Traverse_List (Loop_Actions (Scen)); @@ -6636,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. @@ -13089,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 @@ -13178,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 @@ -14452,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; ---------------------------- @@ -14495,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); @@ -14651,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 -- --------------------------- @@ -17480,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; @@ -18765,9 +18722,9 @@ package body Sem_Elab is T : constant Entity_Id := Etype (First_Formal (E)); begin if Is_Controlled (T) then - if Warnings_Off (T) + if Has_Warnings_Off (T) or else (Ekind (T) = E_Private_Type - and then Warnings_Off (Full_View (T))) + and then Has_Warnings_Off (Full_View (T))) then goto Output; 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 44fc955..7675070 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -3163,9 +3163,21 @@ package body Sem_Res is = N_Iterated_Component_Association and then Is_Boolean_Type (Typ) then - Error_Msg_N -- CODEFIX - ("missing ALL or SOME in quantified expression", - Defining_Identifier (First (Component_Associations (N)))); + if Present + (Iterator_Specification + (First (Component_Associations (N)))) + then + Error_Msg_N -- CODEFIX + ("missing ALL or SOME in quantified expression", + Defining_Identifier + (Iterator_Specification + (First (Component_Associations (N))))); + else + Error_Msg_N -- CODEFIX + ("missing ALL or SOME in quantified expression", + Defining_Identifier + (First (Component_Associations (N)))); + end if; -- For an operator with no interpretation, check whether -- one of its operands may be a user-defined literal. @@ -8400,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. @@ -8864,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 13ffb11..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. + -- Otherwise, return subprogram when profile matches its ancestor - 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; - - 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; -------------------------------------- @@ -22167,19 +22221,6 @@ package body Sem_Util is pragma Assert (No (Actual)); end Iterate_Call_Parameters; - --------------------------- - -- Itype_Has_Declaration -- - --------------------------- - - function Itype_Has_Declaration (Id : Entity_Id) return Boolean is - begin - pragma Assert (Is_Itype (Id)); - return Present (Parent (Id)) - and then Nkind (Parent (Id)) in - N_Full_Type_Declaration | N_Subtype_Declaration - and then Defining_Entity (Parent (Id)) = Id; - end Itype_Has_Declaration; - ------------------------- -- Kill_Current_Values -- ------------------------- @@ -22913,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; @@ -24062,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); @@ -24583,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 @@ -24693,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 -- ------------------------------- @@ -25437,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 @@ -28033,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; --------------- @@ -29500,6 +29504,9 @@ package body Sem_Util is when N_Iterated_Component_Association => Traverse_More (Loop_Actions (Node), Result); + when N_Iterated_Element_Association => + Traverse_More (Loop_Actions (Node), Result); + when N_Iteration_Scheme => Traverse_More (Condition_Actions (Node), Result); @@ -32479,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 dde5b27..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 @@ -2561,11 +2563,6 @@ package Sem_Util is -- Calls Handle_Parameter for each pair of formal and actual parameters of -- a function, procedure, or entry call. - function Itype_Has_Declaration (Id : Entity_Id) return Boolean; - -- Applies to Itypes. True if the Itype is attached to a declaration for - -- the type through its Parent field, which may or not be present in the - -- tree. - procedure Kill_Current_Values (Last_Assignment_Only : Boolean := False); -- This procedure is called to clear all constant indications from all -- entities in the current scope and in any parent scopes if the current @@ -2748,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/sigtramp-vxworks-target.h b/gcc/ada/sigtramp-vxworks-target.h index 153426e..3c85aa2 100644 --- a/gcc/ada/sigtramp-vxworks-target.h +++ b/gcc/ada/sigtramp-vxworks-target.h @@ -149,7 +149,7 @@ In general: There is no unique numbering for the x86 architecture. It's parameterized - by DWARF_FRAME_REGNUM, which is DBX_REGISTER_NUMBER except for Windows, and + by DWARF_FRAME_REGNUM, which is DEBUGGER_REGNO except for Windows, and the latter depends on the platform. */ 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 ddac1c9..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 @@ -4183,11 +4183,15 @@ package Sinfo is -- ITERATED_COMPONENT_ASSOCIATION ::= -- for DEFINING_IDENTIFIER in DISCRETE_CHOICE_LIST => EXPRESSION + -- for ITERATOR_SPECIFICATION => EXPRESSION + + -- At most one of (Defining_Identifier, Iterator_Specification) + -- is present at a time, in which case the other one is empty. -- N_Iterated_Component_Association -- Sloc points to FOR -- Defining_Identifier - -- Iterator_Specification (set to Empty if no Iterator_Spec) + -- Iterator_Specification -- Expression -- Discrete_Choices -- Loop_Actions @@ -4207,9 +4211,13 @@ package Sinfo is -- Etype --------------------------------- - -- 3.4.5 Comtainer_Aggregates -- + -- 3.4.5 Container_Aggregates -- --------------------------------- + -- ITERATED_ELEMENT_ASSOCIATION ::= + -- for LOOP_PARAMETER_SPECIFICATION[ use KEY_EXPRESSION] => EXPRESSION + -- | for ITERATOR_SPECIFICATION[ use KEY_EXPRESSION] => EXPRESSION + -- N_Iterated_Element_Association -- Key_Expression -- Iterator_Specification @@ -5159,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 -- @@ -5678,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 @@ -6156,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 -- @@ -6707,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 -- @@ -6737,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 -- @@ -6822,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 @@ -6848,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 42a6e4f..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; @@ -1341,9 +1361,13 @@ package body Sprint is when N_Iterated_Component_Association => Set_Debug_Sloc; Write_Str (" for "); - Write_Id (Defining_Identifier (Node)); - Write_Str (" in "); - Sprint_Bar_List (Discrete_Choices (Node)); + if Present (Iterator_Specification (Node)) then + Sprint_Node (Iterator_Specification (Node)); + else + Write_Id (Defining_Identifier (Node)); + Write_Str (" in "); + Sprint_Bar_List (Discrete_Choices (Node)); + end if; Write_Str (" => "); Sprint_Node (Expression (Node)); @@ -1642,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 @@ -2160,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; @@ -2307,6 +2325,11 @@ package body Sprint is Sprint_Node (Name (Node)); + if Present (Iterator_Filter (Node)) then + Write_Str (" when "); + Sprint_Node (Iterator_Filter (Node)); + end if; + when N_Itype_Reference => Write_Indent_Str_Sloc ("reference "); Write_Id (Itype (Node)); @@ -2690,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 "); @@ -3317,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)) @@ -3389,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 10feb23..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 @@ -379,6 +388,12 @@ package body Switch.B is Bad_Switch (Switch_Chars); end if; + -- Processing for k switch + + when 'k' => + Ptr := Ptr + 1; + Check_Elaboration_Flags := False; + -- Processing for K switch when 'K' => diff --git a/gcc/ada/treepr.adb b/gcc/ada/treepr.adb index 32f6e81..a9f4088 100644 --- a/gcc/ada/treepr.adb +++ b/gcc/ada/treepr.adb @@ -135,10 +135,6 @@ package body Treepr is function From_Union is new Ada.Unchecked_Conversion (Union_Id, Uint); function From_Union is new Ada.Unchecked_Conversion (Union_Id, Ureal); - function To_Mixed (S : String) return String; - -- Turns an identifier into Mixed_Case. For bootstrap reasons, we cannot - -- use To_Mixed function from System.Case_Util. - function Image (F : Node_Or_Entity_Field) return String; procedure Print_Init; @@ -371,8 +367,9 @@ package body Treepr is when others => declare - Result : constant String := To_Mixed (F'Img); + Result : String := F'Img; begin + To_Mixed (Result); return Result (3 .. Result'Last); -- Remove "F_" end; end case; @@ -1671,8 +1668,10 @@ package body Treepr is -------------------------- procedure Print_Str_Mixed_Case (S : String) is + Tmp : String := S; begin - Print_Str (To_Mixed (S)); + To_Mixed (Tmp); + Print_Str (Tmp); end Print_Str_Mixed_Case; ---------------- @@ -1806,17 +1805,6 @@ package body Treepr is Next_Serial_Number := Next_Serial_Number + 1; end Set_Serial_Number; - -------------- - -- To_Mixed -- - -------------- - - function To_Mixed (S : String) return String is - begin - return Result : String (S'Range) := S do - To_Mixed (Result); - end return; - end To_Mixed; - --------------- -- Tree_Dump -- --------------- 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 |