diff options
| author | Ian Lance Taylor <iant@golang.org> | 2023-06-21 11:04:04 -0700 |
|---|---|---|
| committer | Ian Lance Taylor <iant@golang.org> | 2023-06-21 11:04:04 -0700 |
| commit | 97e31a0a2a2d2273687fcdb4e5416aab1a2186e1 (patch) | |
| tree | d5c1cae4de436a0fe54a5f0a2a197d309f3d654c /gcc/ada | |
| parent | 6612f4f8cb9b0d5af18ec69ad04e56debc3e6ced (diff) | |
| parent | 577223aebc7acdd31e62b33c1682fe54a622ae27 (diff) | |
| download | gcc-97e31a0a2a2d2273687fcdb4e5416aab1a2186e1.zip gcc-97e31a0a2a2d2273687fcdb4e5416aab1a2186e1.tar.gz gcc-97e31a0a2a2d2273687fcdb4e5416aab1a2186e1.tar.bz2 | |
Merge from trunk revision 577223aebc7acdd31e62b33c1682fe54a622ae27.
Diffstat (limited to 'gcc/ada')
333 files changed, 16103 insertions, 9412 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index c3741f7..5110f3d 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,3018 @@ +2023-06-20 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/decl.cc (gnat_to_gnu_entity) <E_Variable>: Pass + the NULL_TREE explicitly and test imported_p in lieu of + Is_Imported. <E_Function>: Remove public_flag local variable and + make extern_flag local variable a constant. + +2023-06-20 Yannick Moy <moy@adacore.com> + + * sem_res.adb (Resolve_Call): Fix change that replaced test for + quantified expressions by the test for potentially unevaluated + contexts. Both should be performed. + +2023-06-20 Eric Botcazou <ebotcazou@adacore.com> + + * exp_ch7.adb (Convert_View): Detect more cases of mismatches for + private types and use Implementation_Base_Type as main criterion. + * gen_il-fields.ads (Opt_Field_Enum): Add + Has_Secondary_Private_View + * gen_il-gen-gen_nodes.adb (N_Expanded_Name): Likewise. + (N_Direct_Name): Likewise. + (N_Op): Likewise. + * sem_ch12.ads (Check_Private_View): Document the usage of second + flag Has_Secondary_Private_View. + * sem_ch12.adb (Get_Associated_Entity): New function to retrieve + the ultimate associated entity, if any. + (Check_Private_View): Implement Has_Secondary_Private_View + support. + (Copy_Generic_Node): Remove specific treatment for Component_Type + of an array type and Designated_Type of an access type. Add + specific treatment for comparison and equality operators, as well + as iterator and loop parameter specifications. + (Instantiate_Type): Implement Has_Secondary_Private_View support. + (Requires_Delayed_Save): Call Get_Associated_Entity. + (Set_Global_Type): Implement Has_Secondary_Private_View support. + * sem_ch6.adb (Conforming_Types): Remove bypass for private views + in instances. + * sem_type.adb (Covers): Return true if Is_Subtype_Of does so. + Remove bypass for private views in instances. + (Specific_Type): Likewise. + * sem_util.adb (Wrong_Type): Likewise. + * sinfo.ads (Has_Secondary_Private_View): Document new flag. + +2023-06-20 Ronan Desplanques <desplanques@adacore.com> + + * libgnarl/s-mudido.ads: Remove outdated comment. + +2023-06-20 Eric Botcazou <ebotcazou@adacore.com> + + * doc/gnat_ugn/gnat_and_program_execution.rst (Overflows in GNAT) + <Default Settings>: Remove obsolete paragraph about -gnato. + <Implementation Notes>: Replace CHECKED with STRICT. + * gnat_ugn.texi: Regenerate. + +2023-06-20 Yannick Moy <moy@adacore.com> + + * sem_util.adb (Check_Result_And_Post_State): Do not warn in cases + where the warning could be spurious. + +2023-06-20 Yannick Moy <moy@adacore.com> + + * err_vars.ads (Error_Msg_Code): New variable for error codes. + * errout.adb (Error_Msg_Internal): Display continuation message + when an error code was present. + (Set_Msg_Text): Handle character sequence [] for error codes. + * errout.ads: Document new insertion sequence []. + (Error_Msg_Code): New renaming. + * erroutc.adb (Prescan_Message): Detect presence of error code. + (Set_Msg_Insertion_Code): Handle new insertion sequence []. + * erroutc.ads (Has_Error_Code): New variable for prescan. + (Set_Msg_Insertion_Code): Handle new insertion sequence []. + * contracts.adb (Check_Type_Or_Object_External_Properties): + Replace reference to SPARK RM section by an error code. + * sem_elab.adb (SPARK_Processor): Same. + * sem_prag.adb (Check_Missing_Part_Of): Same. + * sem_res.adb (Resolve_Actuals, Resolve_Entity_Name): Same. + +2023-06-20 Piotr Trojanek <trojanek@adacore.com> + + * sem_res.adb (Resolve_Entity_Name): Handle Range like First and Last. + +2023-06-20 Jose Ruiz <ruiz@adacore.com> + + * doc/gnat_ugn/the_gnat_compilation_model.rst + (Partition-Wide Settings): add this subsection to document + configuration settings made by the Ada run time. + * gnat_ugn.texi: Regenerate. + +2023-06-20 Piotr Trojanek <trojanek@adacore.com> + + * sem_res.adb (Resolve_Entity_Name): Ignore implicit loop scopes + introduced by quantified expressions. + +2023-06-20 Bob Duff <duff@adacore.com> + + * sem_ch3.adb (Analyze_Object_Declaration): Remove predicate-check + generation if there is an address clause. These are unnecessary, + and cause gigi to crash. + * exp_util.ads (Following_Address_Clause): Remove obsolete "???" + comments. The suggested changes were done long ago. + +2023-06-20 Eric Botcazou <ebotcazou@adacore.com> + + * einfo.ads (Has_Private_Ancestor): Fix inaccuracy in description. + * sem_ch12.adb (Check_Actual_Type): Do not switch the view of the + type if it has a private ancestor. + +2023-06-20 Daniel King <dmking@adacore.com> + + * libgnat/i-cheri.ads: Add CHERI intrinsics and helper functions. + * libgnat/i-cheri.adb: Likewise + +2023-06-20 Eric Botcazou <ebotcazou@adacore.com> + + * exp_ch7.adb (Convert_View): Remove Ind parameter and adjust. + * sem_ch12.adb (Check_Generic_Actuals): Check the type of both in + and in out actual objects, as well as the type of formal parameters + of actual subprograms. Extend the condition under which the views + are swapped to nested generic constructs. + (Save_References_In_Identifier): Call Set_Global_Type on a global + identifier rewritten as an explicit dereference, either directly + or after having first been rewritten as a function call. + (Save_References_In_Operator): Set N2 unconditionally and reuse it. + * sem_ch3.adb (Build_Derived_Record_Type): Add missing comment. + * sem_res.adb (Resolve_Implicit_Dereference): Remove special bypass + for private views in instances. + +2023-06-20 Eric Botcazou <ebotcazou@adacore.com> + + * exp_aggr.adb (Convert_To_Assignments): Tweak comment. + (Expand_Array_Aggregate): Do not delay the expansion if the parent + node is a container aggregate. + +2023-06-20 Ghjuvan Lacambre <lacambre@adacore.com> + + * errout.adb (Output_Messages): Fix loop termination condition. + +2023-06-20 Eric Botcazou <ebotcazou@adacore.com> + + * doc/gnat_ugn/building_executable_programs_with_gnat.rst (Compiler + Switches): Document -gnateH. + * opt.ads (Reverse_Bit_Order_Threshold): New variable. + * sem_ch13.adb (Adjust_Record_For_Reverse_Bit_Order): Use its value + if it is nonnegative instead of System_Max_Integer_Size. + * switch-c.adb (Scan_Front_End_Switches): Deal with -gnateH. + * usage.adb (Usage): Print -gnateH. + * gnat_ugn.texi: Regenerate. + +2023-06-20 Yannick Moy <moy@adacore.com> + + * libgnat/s-aridou.adb (Scaled_Divide): Add assertions. + * libgnat/s-valuti.adb: Add Loop_Variant. + * libgnat/s-valuti.ads: Add Exceptional_Cases on No_Return + procedure. + +2023-06-20 Marc Poulhiès <poulhies@adacore.com> + + * sem_ch3.adb (Build_Derived_Record_Type): Use full view as + Parent_Base if needed. + +2023-06-20 Ghjuvan Lacambre <lacambre@adacore.com> + + * lib-load.adb (Load_Unit): Pass Error_Node to calls to Error_Msg. + +2023-06-20 Claire Dross <dross@adacore.com> + + * libgnat/a-strfix.ads: Replace Might_Not_Return annotations by + Exceptional_Cases and Always_Terminates aspects. + * libgnat/a-tideio.ads: Idem. + * libgnat/a-tienio.ads: Idem. + * libgnat/a-tifiio.ads: Idem. + * libgnat/a-tiflio.ads: Idem. + * libgnat/a-tiinio.ads: Idem. + * libgnat/a-timoio.ads: Idem. + * libgnat/a-textio.ads: Idem. Also mark functions Name, Col, Line, + and Page as out of SPARK as they might raise Layout_Error. + * libgnarl/a-reatim.ads: Replace Always_Return annotations by + Always_Terminates aspects. + * libgnat/a-chahan.ads: Idem. + * libgnat/a-nbnbig.ads: Idem. + * libgnat/a-nbnbin.ads: Idem. + * libgnat/a-nbnbre.ads: Idem. + * libgnat/a-ngelfu.ads: Idem. + * libgnat/a-nlelfu.ads: Idem. + * libgnat/a-nllefu.ads: Idem. + * libgnat/a-nselfu.ads: Idem. + * libgnat/a-nuelfu.ads: Idem. + * libgnat/a-strbou.ads: Idem. + * libgnat/a-strmap.ads: Idem. + * libgnat/a-strsea.ads: Idem. + * libgnat/a-strsup.ads: Idem. + * libgnat/a-strunb.ads: Idem. + * libgnat/a-strunb__shared.ads: Idem. + * libgnat/g-souinf.ads: Idem. + * libgnat/i-c.ads: Idem. + * libgnat/interfac.ads: Idem. + * libgnat/interfac__2020.ads: Idem. + * libgnat/s-aridou.adb: Idem. + * libgnat/s-arit32.adb: Idem. + * libgnat/s-atacco.ads: Idem. + * libgnat/s-spcuop.ads: Idem. + * libgnat/s-stoele.ads: Idem. + * libgnat/s-vaispe.ads: Idem. + * libgnat/s-vauspe.ads: Idem. + * libgnat/i-cstrin.ads: Add a precondition instead of a + Might_Not_Return annotation. + +2023-06-20 Javier Miranda <miranda@adacore.com> + + * sem_ch4.adb + (Try_Selected_Component_In_Instance): New subprogram; factorizes + existing code. + (Find_Component_In_Instance) Moved inside the new subprogram. + (Analyze_Selected_Component): Invoke the new subprogram before + trying the Object.Operation notation. + +2023-06-20 Ronan Desplanques <desplanques@adacore.com> + + * libgnat/a-calfor.adb (Time_Of): Fix handling of special case. + +2023-06-15 Marek Polacek <polacek@redhat.com> + + * gcc-interface/Make-lang.in (ALL_ADAFLAGS): Remove NO_PIE_CFLAGS. Add + PICFLAG. Use PICFLAG when building ada/b_gnat1.o and ada/b_gnatb.o. + * gcc-interface/Makefile.in: Use pic/libiberty.a if PICFLAG is set. + Remove NO_PIE_FLAG. + +2023-06-15 Marc Poulhiès <poulhies@adacore.com> + + * vxworks7-cert-rtp-base-link.spec: Removed. + * vxworks7-cert-rtp-base-link__ppc64.spec: Removed. + * vxworks7-cert-rtp-base-link__x86.spec: Removed. + * vxworks7-cert-rtp-base-link__x86_64.spec: Removed. + * vxworks7-cert-rtp-link.spec: Removed. + * vxworks7-cert-rtp-link__ppcXX.spec: Removed. + +2023-06-15 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/utils2.cc (build_binary_op) <MODIFY_EXPR>: Do not + remove a VIEW_CONVERT_EXPR on the LHS if it is also on the RHS. + +2023-06-15 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/decl.cc (gnat_to_gnu_entity) <E_Variable>: Restrict + the special handling of temporaries created for return values and + subject to a renaming to the top level. + +2023-06-15 Ronan Desplanques <desplanques@adacore.com> + + * doc/gnat_ugn/about_this_guide.rst: Fix typo. Uniformize punctuation. + * doc/gnat_ugn/the_gnat_compilation_model.rst: Uniformize punctuation. + Fix capitalization. Fix indentation of code block. Fix RST formatting + syntax errors. + * gnat_ugn.texi: Regenerate. + +2023-06-15 Yannick Moy <moy@adacore.com> + + * sem_attr.adb (Analyze_Attribute): Reject case of Loop_Entry + inside the prefix of Loop_Entry, as per SPARK RM 5.5.3.1(4,8). + +2023-06-15 Eric Botcazou <ebotcazou@adacore.com> + + * exp_ch3.adb (Make_Allocator_For_Return): Rewrite the logic that + determines the type used for the allocation and add assertions. + * exp_util.adb (Has_Tag_Of_Type): Also return true for extension + aggregates. + +2023-06-15 Eric Botcazou <ebotcazou@adacore.com> + + * sinfo.ads (Iterator_Filter): Document field. + * sem_ch5.adb (Analyze_Iterator_Specification): Move comment around. + (Analyze_Loop_Parameter_Specification): Only preanalyze the iterator + filter, if any. + * exp_ch5.adb (Expand_N_Loop_Statement): Analyze the new list built + when an iterator filter is present. + +2023-06-15 Eric Botcazou <ebotcazou@adacore.com> + + * exp_util.adb (Find_Hook_Context): Revert latest change. + +2023-06-15 Eric Botcazou <ebotcazou@adacore.com> + + * exp_ch3.adb (Make_Allocator_For_Return): Deal again specifically + with an aggregate returned through an object of a class-wide type. + +2023-06-15 Eric Botcazou <ebotcazou@adacore.com> + + * exp_ch5.adb (Expand_Iterator_Loop_Over_Container): Do not insert + an always empty list. Remove unused parameter Isc. + (Expand_Iterator_Loop): Adjust call to above procedure. + +2023-06-15 Ronan Desplanques <desplanques@adacore.com> + + * targparm.adb: Allow pragma Style_Checks in some forms. + * targparm.ads: Document new pragma permission. + +2023-06-15 Eric Botcazou <ebotcazou@adacore.com> + + * exp_util.ads (Within_Case_Or_If_Expression): Adjust description. + * exp_util.adb (Find_Hook_Context): Stop the search for the topmost + conditional expression, if within one, at contexts where temporaries + may be contained. + (Within_Case_Or_If_Expression): Return false upon first encoutering + contexts where temporaries may be contained. + +2023-06-15 Johannes Kliemann <kliemann@adacore.com> + + * libgnarl/s-osinte__qnx.adb: Adjust priority conversion function. + * libgnat/system-qnx-arm.ads: Adjust priority range and default + priority. + +2023-06-15 Ronan Desplanques <desplanques@adacore.com> + + * targparm.ads: Remove references to front-end-based exceptions. Fix + thinko. + +2023-06-15 Piotr Trojanek <trojanek@adacore.com> + + * contracts.adb (Add_Contract_Item): Add pragma Always_Terminates to + package contract. + * sem_prag.adb (Analyze_Pragma): Accept pragma Always_Terminates on + packages and generic packages, but only when it has no arguments. + +2023-06-15 Piotr Trojanek <trojanek@adacore.com> + + * sem_prag.adb (Analyze_Pragma): Accept pragma Always_Terminates when + it applies to an entry. + +2023-06-15 Piotr Trojanek <trojanek@adacore.com> + + * sem_prag.adb (Analyze_Pragma): Reject pragma Always_Terminates when + it applies to a function or generic function. + +2023-06-15 Eric Botcazou <ebotcazou@adacore.com> + + * sem_ch4.adb (Analyze_Call): Adjust the test to detect the presence + of an incomplete view of a type on a function call. + +2023-06-15 Ronan Desplanques <desplanques@adacore.com> + + * ttypes.ads: Remove reference to Ttypef in comment. Fix typo in + comment. + +2023-06-15 Eric Botcazou <ebotcazou@adacore.com> + + * get_targ.ads (Get_Max_Unaligned_Field): Delete. + * ada_get_targ.adb (Get_Max_Unaligned_Field): Likewise. + * get_targ.adb (Get_Max_Unaligned_Field): Likewise. + * set_targ.ads (Max_Unaligned_Field): Adjust comment. + * set_targ.adb: Set Max_Unaligned_Field to 1 during elaboration. + * ttypes.ads (Max_Unaligned_Field): Delete. + +2023-06-15 Eric Botcazou <ebotcazou@adacore.com> + + * sem_type.adb (Disambiguate): Fix pasto in the implementation of + the RM 8.4(10) clause for operators. + +2023-06-15 Piotr Trojanek <trojanek@adacore.com> + + * aspects.adb + (Base_Aspect): Fix layout. + * aspects.ads + (Aspect_Argument): Expression for Always_Terminates is optional. + * sem_prag.adb + (Analyze_Always_Terminates_In_Decl_Part): Only analyze expression when + pragma argument is present. + (Analyze_Pragma): Argument for Always_Terminates is optional; fix + whitespace for Async_Readers. + +2023-06-15 Javier Miranda <miranda@adacore.com> + + * sem_util.adb + (Is_CPP_Constructor_Call): Add missing support for calls to + functions returning a private type. + +2023-06-15 Eric Botcazou <ebotcazou@adacore.com> + + * exp_util.ads (Build_Transient_Object_Statements): Remove obsolete + references to array and record aggregates in documentation. + +2023-06-15 Eric Botcazou <ebotcazou@adacore.com> + + * sem_ch13.adb (Analyze_Aspect_Specifications): Add missing items + in the list of aspects handled by means of Insert_Pragma. + <Aspect_Linker_Section>: Remove obsolete code. Do not delay the + processing of the aspect if the entity is already frozen. + +2023-06-15 Piotr Trojanek <trojanek@adacore.com> + + * sem_aggr.adb + (Resolve_Array_Aggregate): Simplify comment. + (Resolve_Iterated_Component_Association): Tune comment; change variable + to constant. + +2023-06-13 Piotr Trojanek <trojanek@adacore.com> + + * sem_aggr.adb (Resolve_Iterated_Component_Association): Simply resolve + the expression. + +2023-06-13 Bob Duff <duff@adacore.com> + + * exp_ch4.adb + (Expand_N_Quantified_Expression): Detect the secondary-stack + case, and find the innermost scope where we should mark/release, + and Set_Uses_Sec_Stack on that. Skip intermediate blocks and loops + that are part of expansion. + +2023-06-13 Piotr Trojanek <trojanek@adacore.com> + + * sem_util.adb (Is_Repeatedly_Evaluated): Recognize iterated component + association as repeatedly evaluated. + +2023-06-13 Piotr Trojanek <trojanek@adacore.com> + + * sem_util.adb (Is_Potentially_Unevaluated): Recognize iterated + component association as potentially unevaluated. + +2023-06-13 Piotr Trojanek <trojanek@adacore.com> + + * sem_res.adb (Resolve_Call): Replace early call to + In_Quantified_Expression with a call to Is_Potentially_Unevaluated that + was only done when Full_Analysis is true. + +2023-06-13 Piotr Trojanek <trojanek@adacore.com> + + * aspects.ads (Aspect_Id): Add new aspect. + (Implementation_Defined_Aspect): New aspect is + implementation-defined. + (Aspect_Argument): New aspect has an expression argument. + (Is_Representation_Aspect): New aspect is not a representation + aspect. + (Aspect_Names): Link new aspect identifier with a name. + (Aspect_Delay): New aspect is never delayed. + * contracts.adb (Expand_Subprogram_Contract): Mention new aspect + in comment. + (Add_Contract_Item): Attach pragma corresponding to the new aspect + to contract items. + (Analyze_Entry_Or_Subprogram_Contract): Analyze pragma + corresponding to the new aspect that appears with subprogram spec. + (Analyze_Subprogram_Body_Stub_Contract): Expand pragma + corresponding to the new aspect. + * contracts.ads + (Add_Contract_Item, Analyze_Entry_Or_Subprogram_Contract) + (Analyze_Entry_Or_Subprogram_Body_Contract) + (Analyze_Subprogram_Body_Stub_Contract): Mention new aspect in + comment. + * einfo-utils.adb (Get_Pragma): Return pragma attached to + contract. + * einfo-utils.ads (Get_Pragma): Mention new contract in comment. + * exp_prag.adb (Expand_Pragma_Always_Terminates): Placeholder for + possibly expanding new aspect. + * exp_prag.ads (Expand_Pragma_Always_Terminates): Dedicated + routine for expansion of the new aspect. + * inline.adb (Remove_Aspects_And_Pragmas): Remove aspect from + inlined bodies. + * par-prag.adb (Prag): Postpone checking of the pragma until + analysis. + * sem_ch12.adb: Mention new aspect in explanation of handling + contracts on generic units. + * sem_ch13.adb (Analyze_Aspect_Specifications): Convert new aspect + into a corresponding pragma. + (Check_Aspect_At_Freeze_Point): Don't expect new aspect. + * sem_prag.adb (Analyze_Always_Terminates_In_Decl_Part): Analyze + pragma corresponding to the new aspect. + (Analyze_Pragma): Handle pragma corresponding to the new aspect. + (Is_Non_Significant_Pragma_Reference): Handle references appearing + within new aspect. + * sem_prag.ads (Aspect_Specifying_Pragma): New aspect can be + emulated with a pragma. + (Assertion_Expression_Pragma): New aspect has an assertion + expression. + (Pragma_Significant_To_Subprograms): New aspect is significant to + subprograms. + (Analyze_Always_Terminates_In_Decl_Part): Add spec for routine + that analyses new aspect. + (Find_Related_Declaration_Or_Body): Mention new aspect in comment. + * sem_util.adb (Is_Subprogram_Contract_Annotation): New aspect is + a subprogram contract annotation. + * sem_util.ads (Is_Subprogram_Contract_Annotation): Mention new + aspect in comment. + * sinfo.ads (Is_Generic_Contract_Pragma): New pragma is a generic + contract. + (Contract): Explain attaching new pragma to subprogram contract. + * snames.ads-tmpl (Name_Always_Terminates): New name for the new + contract. + (Pragma_Always_Terminates): New pragma identifier. + +2023-06-13 Piotr Trojanek <trojanek@adacore.com> + + * sem_elab.adb (Check_Overriding_Primitive): Prevent Corresponding_Body + to be called with entity of an abstract subprogram. + +2023-06-13 Eric Botcazou <ebotcazou@adacore.com> + + * sem_ch12.adb (Save_References_In_Identifier): In the case where + the identifier has been turned into a function call by analysis, + call Set_Global_Type on the entity if it is global. + +2023-06-13 Marc Poulhiès <poulhies@adacore.com> + + * sem_aggr.adb (Resolve_Iterated_Component_Association): Call + Preanalyze_And_Resolve instead of Resolve_Aggr_Expr except for + aggregate. + Co-authored-by: Ed Schonberg <schonberg@adacore.com> + +2023-06-13 Eric Botcazou <ebotcazou@adacore.com> + + * contracts.adb (Contract_Error): New exception. + (Add_Contract_Item): Raise Contract_Error instead of Program_Error. + (Add_Generic_Contract_Pragma): Deal with Contract_Error. + +2023-06-13 Eric Botcazou <ebotcazou@adacore.com> + + * sem_attr.adb (Eval_Attribute): Add more exceptions to the early + return for a prefix which is a nonfrozen generic actual type. + * sem_ch12.adb (Copy_Generic_Node): Also check private views in the + case of an entity name or operator analyzed as a function call. + (Set_Global_Type): Make it a child of Save_Global_References. + (Save_References_In_Operator): In the case where the operator has + been turned into a function call, call Set_Global_Type on the entity + if it is global. + +2023-06-13 Eric Botcazou <ebotcazou@adacore.com> + + * contracts.adb (Analyze_Entry_Or_Subprogram_Body_Contract): For a + subprogram body that has no contracts and does not come from source, + make sure that contracts on its corresponding spec are analyzed, if + any, before expanding them. + +2023-06-13 Eric Botcazou <ebotcazou@adacore.com> + + * gen_il-fields.ads (Opt_Field_Enum): Add No_Finalize_Actions and + remove No_Side_Effect_Removal. + * gen_il-gen-gen_nodes.adb (N_Function_Call): Remove semantic flag + No_Side_Effect_Removal + (N_Assignment_Statement): Add semantic flag No_Finalize_Actions. + * sinfo.ads (No_Ctrl_Actions): Adjust comment. + (No_Finalize_Actions): New flag on assignment statements. + (No_Side_Effect_Removal): Delete. + * exp_aggr.adb (Build_Record_Aggr_Code): Remove obsolete comment and + Ancestor_Is_Expression variable. In the case of an extension, do + not generate a call to Adjust manually, call Set_No_Finalize_Actions + instead. Do not set the tags, replace call to Make_Unsuppress_Block + by Make_Suppress_Block and remove useless assertions. + In the general case, call Initialize_Component. + (Initialize_Controlled_Component): Delete. + (Initialize_Simple_Component): Delete. + (Initialize_Component): Do the low-level processing, but do not + generate a call to Adjust manually, call Set_No_Finalize_Actions. + (Process_Transient_Component): Delete. + (Process_Transient_Component_Completion): Likewise. + * exp_ch5.adb (Expand_Assign_Array): Deal with No_Finalize_Actions. + (Expand_Assign_Array_Loop): Likewise. + (Expand_N_Assignment_Statement): Likewise. + (Make_Tag_Ctrl_Assignment): Likewise. + * exp_util.adb (Remove_Side_Effects): Do not test the + No_Side_Effect_Removal flag. + * sem_prag.adb (Process_Suppress_Unsuppress): Give the warning in + SPARK mode only for pragma Suppress. + * tbuild.ads (Make_Suppress_Block): New declaration. + (Make_Unsuppress_Block): Adjust comment. + * tbuild.adb (Make_Suppress_Block): New procedure. + (Make_Unsuppress_Block): Unsuppress instead of suppressing. + +2023-06-13 Eric Botcazou <ebotcazou@adacore.com> + + * sem_ch5.adb (Analyze_Assignment): Turn Rhs into a constant and + remove calls to the following subprograms. + (Transform_BIP_Assignment): Delete. + (Should_Transform_BIP_Assignment): Likewise. + +2023-06-13 Piotr Trojanek <trojanek@adacore.com> + + * sem_util.ads (Is_Inherited_Operation_For_Type): Remove spec. + * sem_util.adb (Is_Inherited_Operation_For_Type): Remove body. + +2023-06-13 Eric Botcazou <ebotcazou@adacore.com> + + * exp_aggr.adb (Build_Record_Aggr_Code): Add new variable Ancestor_Q + to store the result of Unqualify on Ancestor. Remove the dead call + to Generate_Finalization_Actions in the case of another aggregate as + ancestor part. Remove the redundant setting of Assignment_OK. Use + Init_Typ in lieu of Etype (Ancestor) more consistently. + +2023-06-13 Eric Botcazou <ebotcazou@adacore.com> + + * exp_aggr.adb (Build_Record_Aggr_Code): In the case of an extension + aggregate of a limited type whose ancestor part is an aggregate, do + not skip the final code assigning the tag of the extension. + +2023-06-13 Yannick Moy <moy@adacore.com> + + * ghost.adb (Check_Ghost_Context): Allow absence of Ghost_Id + for attribute. Update error message to mention Ghost_Predicate. + (Is_Ghost_Attribute_Reference): New query. + * ghost.ads (Is_Ghost_Attribute_Reference): New query. + * sem_attr.adb (Resolve_Attribute): Check ghost context for ghost + attributes. + +2023-06-13 Daniel King <dmking@adacore.com> + + * libgnat/s-stoele.ads: Add No_Elaboration_Code_All pragma. + +2023-06-13 Eric Botcazou <ebotcazou@adacore.com> + + * exp_util.ads (Make_Tag_Assignment_From_Type): Declare. + * exp_util.adb (Make_Tag_Assignment_From_Type): New function. + * exp_aggr.adb (Build_Record_Aggr_Code): Call the above function. + (Initialize_Simple_Component): Likewise. + * exp_ch3.adb (Build_Record_Init_Proc.Build_Assignment): Likewise. + (Build_Record_Init_Proc.Build_Init_Procedure ): Likewise. + (Make_Tag_Assignment): Likewise. Rename local variable and call + Unqualify to go through qualified expressions. + * exp_ch4.adb (Expand_Allocator_Expression): Likewise. + +2023-06-13 Yannick Moy <moy@adacore.com> + + * libgnat/a-strsup.ads: Change predicate aspect. + * sem_ch13.adb (Add_Predicate): Fix for first predicate. + +2023-06-13 Eric Botcazou <ebotcazou@adacore.com> + + * exp_aggr.adb (Initialize_Component): Perform immediate expansion + of the initialization expression if it is a conditional expression + and the component type is controlled. + +2023-06-13 Eric Botcazou <ebotcazou@adacore.com> + + * exp_aggr.adb (Initialize_Component): New procedure factored out + from the processing of array and record aggregates. + (Initialize_Controlled_Component): Likewise. + (Initialize_Simple_Component): Likewise. + (Build_Array_Aggr_Code.Gen_Assign): Remove In_Loop parameter. + Call Initialize_Component to initialize the component. + (Initialize_Array_Component): Delete. + (Initialize_Ctrl_Array_Component): Likewise. + (Build_Array_Aggr_Code): Adjust calls to Gen_Assign. + (Build_Record_Aggr_Code): Call Initialize_Simple_Component or + Initialize_Component to initialize the component. + (Initialize_Ctrl_Record_Component): Delete. + (Initialize_Record_Component): Likewise. + +2023-06-13 Piotr Trojanek <trojanek@adacore.com> + + * exp_ch11.adb (Expand_N_Raise_Statement): Expansion of raise statements + never happens in GNATprove mode. + +2023-06-13 Piotr Trojanek <trojanek@adacore.com> + + * exp_ch11.adb (Find_Local_Handler): Replace guard against other + constructs appearing in the list of exception handlers with iteration + using First_Non_Pragma/Next_Non_Pragma. + +2023-06-13 Piotr Trojanek <trojanek@adacore.com> + + * exp_ch11.ads (Find_Local_Handler): Fix typo in comment. + * exp_ch11.adb (Find_Local_Handler): Remove redundant check for the + Exception_Handler list being present; use membership test to eliminate + local object LCN; fold nested IF statements. Remove useless ELSIF + condition. + +2023-06-13 Piotr Trojanek <trojanek@adacore.com> + + * sem_util.adb (Check_Function_Writable_Actuals): Tune style; use + subtype name to detect membership test nodes. + +2023-06-13 Piotr Trojanek <trojanek@adacore.com> + + * exp_disp.adb (Make_Disp_Asynchronous_Select_Spec): Use a single call + to New_List. + +2023-06-13 Yannick Moy <moy@adacore.com> + + * doc/gnat_rm/implementation_defined_aspects.rst: Document new + aspect. + * doc/gnat_rm/implementation_defined_pragmas.rst: Whitespace. + * aspects.adb (Init_Canonical_Aspect): Set it to Predicate. + * aspects.ads: Set global constants for new aspect. + * einfo.ads: Describe new flag related to new aspect. + * exp_ch6.adb (Can_Fold_Predicate_Call): Do not fold new aspect. + * exp_util.adb (Make_Predicate_Check): Add comment. + * gen_il-fields.ads: Add new flag. + * gen_il-gen-gen_entities.adb: Add new flag. + * ghost.adb (Is_OK_Ghost_Context): Ghost predicate is an OK + ghost context. + (Mark_Ghost_Pragma): Add overloading with ghost mode parameter. + * ghost.ads (Mark_Ghost_Pragma): Add overloading with ghpst mode + parameter. + (Name_To_Ghost_Mode): Make function public. + * sem_aggr.adb: Issue error for violation of valid use. + * sem_case.adb: Issue error for violation of valid use. + * sem_ch13.adb: Adapt for new aspect. + * sem_ch3.adb (Analyze_Full_Type_Declaration): Remove dead code + which was trying to propagate Has_Predicates flag in the wrong + direction (from derived to parent type). + (Analyze_Number_Declaration): Issue error for violation of valid + use. + (Build_Derived_Type): Cleanup inheritance of predicate flags from + parent to derived type. + (Build_Predicate_Function): Only add a predicate check when it + is not ignored as Ghost code. + * sem_ch4.adb (Analyze_Membership_Op): Issue an error for use of + a subtype with a ghost predicate as name in a membership test. + * sem_ch5.adb (Check_Predicate_Use): Issue error for violation of + valid use. + * sem_eval.adb: Adapt code for Dynamic_Predicate to account for + Ghost_Predicate too. + * sem_prag.adb (Analyze_Pragma): Make pragma ghost or not. + * sem_util.adb (Bad_Predicated_Subtype_Use): Adapt to new aspect. + (Inherit_Predicate_Flags): Add inheritance of flag. Add parameter + to apply to derived types. + * sem_util.ads (Inherit_Predicate_Flags): Change signature. + * snames.ads-tmpl: Add new aspect name. + * gnat_rm.texi: Regenerate. + +2023-06-13 Piotr Trojanek <trojanek@adacore.com> + + * exp_ch3.adb (Make_Controlling_Function_Wrappers): Remove early + decoration. + +2023-05-30 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/trans.cc (get_storage_model_access): Also strip any + type conversion in the node when unwinding the components. + +2023-05-30 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/trans.cc (node_is_component): Remove parentheses. + (node_is_type_conversion): New predicate. + (get_atomic_access): Use it. + (get_storage_model_access): Likewise and look into the parent to + find a component if it returns true. + (present_in_lhs_or_actual_p): Likewise. + +2023-05-30 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/trans.cc (Attribute_to_gnu) <Attr_Size>: Check that + the storage model has Copy_From before instantiating loads for it. + <Attr_Length>: Likewise. + <Attr_Bit_Position>: Likewise. + (gnat_to_gnu) <N_Indexed_Component>: Likewise. + <N_Slice>: Likewise. + +2023-05-30 Marc Poulhiès <poulhies@adacore.com> + + * gcc-interface/trans.cc (Attribute_to_gnu): Also strip conversion + in case of DECL. + +2023-05-30 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/decl.cc (gnat_to_gnu_entity) <E_Array_Type>: Use a + local variable for the GNAT index type. + <E_Array_Subtype>: Likewise. Call Is_Null_Range on the bounds and + force the zero on TYPE_SIZE and TYPE_SIZE_UNIT if it returns true. + +2023-05-30 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/trans.cc (gnat_to_gnu) <N_Op_Mod>: Test the + precision of the operation rather than that of the result type. + +2023-05-30 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/decl.cc (gnat_to_gnu_entity) <E_Variable>: Replace + integer_zero_node with null_pointer_node for pointer types. + * gcc-interface/trans.cc (gnat_gimplify_expr) <NULL_EXPR>: Likewise. + * gcc-interface/utils.cc (maybe_pad_type): Do not attempt to make a + packable type from a fat pointer type. + * gcc-interface/utils2.cc (build_atomic_load): Use a local variable. + (build_atomic_store): Likewise. + +2023-05-30 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/misc.cc (internal_error_function): Be prepared for + an input_location set to UNKNOWN_LOCATION. + +2023-05-30 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/trans.cc (Attribute_to_gnu) <Attr_Size>: Tweak. + (gnat_to_gnu) <N_Assignment_Statement>: Declare a local variable. + For a target with a storage model, use the Actual_Designated_Subtype + to compute the size if it is present. + +2023-05-30 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/trans.cc (Call_to_gnu): Remove code implementing the + by-copy semantics for actuals with nonnative storage models. + (gnat_to_gnu) <N_Assignment_Statement>: Remove code instantiating a + temporary for assignments between nonnative storage models. + +2023-05-30 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/decl.cc (range_cannot_be_superflat): Return true + immediately if Cannot_Be_Superflat is set. + * gcc-interface/misc.cc (gnat_post_options): Do not override the + -Wstringop-overflow setting. + +2023-05-30 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/Make-lang.in (ADA_CFLAGS): Move up. + (ALL_ADAFLAGS): Add $(NO_PIE_CFLAGS). + (ada/mdll.o): Remove. + (ada/mdll-fil.o): Likewise. + (ada/mdll-utl.o): Likewise. + +2023-05-30 Marc Poulhiès <poulhies@adacore.com> + + * gcc-interface/trans.cc (get_storage_model_access): Don't require + storage model access for dereference used as lvalue or renamings. + +2023-05-30 Eric Botcazou <ebotcazou@adacore.com> + + * exp_aggr.adb (Build_Array_Aggr_Code): Move the declaration of Typ + to the beginning. + (Initialize_Array_Component): Test the unqualified version of the + expression for the nested array case. + (Initialize_Ctrl_Array_Component): Do not duplicate the expression + here. Do the pattern matching of the unqualified version of it. + (Gen_Assign): Call Unqualify to compute Expr_Q and use Expr_Q in + subsequent pattern matching. + (Initialize_Ctrl_Record_Component): Do the pattern matching of the + unqualified version of the aggregate. + (Build_Record_Aggr_Code): Call Unqualify. + (Convert_Aggr_In_Assignment): Likewise. + (Convert_Aggr_In_Object_Decl): Likewise. + (Component_OK_For_Backend): Likewise. + (Is_Delayed_Aggregate): Likewise. + +2023-05-30 Eric Botcazou <ebotcazou@adacore.com> + + * exp_aggr.adb (Build_Array_Aggr_Code.Get_Assoc_Expr): Duplicate the + expression here instead of... + (Build_Array_Aggr_Code): ...here. + +2023-05-30 Eric Botcazou <ebotcazou@adacore.com> + + * freeze.adb (Check_Large_Modular_Array): Fix head comment, use + Standard_Long_Long_Integer_Size directly and generate a reference + just before the raise statement if the Etype of the object is an + itype declared in an open scope. + +2023-05-30 Eric Botcazou <ebotcazou@adacore.com> + + * exp_ch7.adb (Find_Enclosing_Transient_Scope): Return the index in + the scope table instead of the scope's entity. + (Establish_Transient_Scope): If an enclosing scope already exists, + do not set the Uses_Sec_Stack flag on it if the node to be wrapped + is a return statement which requires secondary stack management. + +2023-05-30 Joel Brobecker <brobecker@adacore.com> + + * Makefile.rtl: Use libgnat/s-tsmona__linux.adb on + aarch64-linux. Link libgnat with -ldl, as the use of + s-tsmona__linux.adb requires it. + +2023-05-30 Piotr Trojanek <trojanek@adacore.com> + + * exp_ch3.adb + (Build_Access_Subprogram_Wrapper_Body): Build wrapper body if requested + by routine that builds wrapper spec. + * sem_ch3.adb + (Analyze_Full_Type_Declaration): Only build wrapper when expander is + active. + (Build_Access_Subprogram_Wrapper): + Remove special-case for GNATprove. + +2023-05-30 Ronan Desplanques <desplanques@adacore.com> + + * doc/gnat_ugn/building_executable_programs_with_gnat.rst: Fix minor issues. + * doc/gnat_ugn/the_gnat_compilation_model.rst: Fix minor issues. + * gnat_ugn.texi: Regenerate. + +2023-05-30 Johannes Kliemann <kliemann@adacore.com> + + * libgnat/s-parame.adb: Check that Default_Stack_Size >= + Minimum_Stack_size. + * libgnat/s-parame__rtems.adb: Ditto. + * libgnat/s-parame__vxworks.adb: Check that Default_Stack_Size >= + Minimum_Stack_size and use the proper Minimum_Stack_Size if + Stack_Check_Limits is enabled. + +2023-05-30 Eric Botcazou <ebotcazou@adacore.com> + + * sem_res.adb (Resolve_Call): Restrict previous change to calls that + return on the same stack as the enclosing function. Tidy up. + +2023-05-30 Eric Botcazou <ebotcazou@adacore.com> + + * libgnat/a-cidlli.adb (Put_Image): Simplify. + * libgnat/a-coinve.adb (Put_Image): Likewise. + +2023-05-30 Eric Botcazou <ebotcazou@adacore.com> + + * exp_util.adb (Build_DIC_Procedure_Body.Add_Own_DIC): When inside + a generic unit, preanalyze the expression directly. + (Build_Invariant_Procedure_Body.Add_Own_Invariants): Likewise. + +2023-05-30 Cedric Landet <landet@adacore.com> + + * init.c: Replace FIXME by ??? + +2023-05-29 Cedric Landet <landet@adacore.com> + + * s-oscons-tmplt.c: move the definition of sigset out of the + HAVE_SOCKETS bloc. + +2023-05-29 Cedric Landet <landet@adacore.com> + + * Makefile.rtl: Move g-spogwa$(objext) from GNATRTL_NONTASKING_OBJS + to GNATRTL_SOCKETS_OBJS + +2023-05-29 Eric Botcazou <ebotcazou@adacore.com> + + * freeze.adb (Wrap_Imported_Subprogram): Use Copy_Subprogram_Spec in + both cases to copy the spec of the subprogram. + +2023-05-29 Eric Botcazou <ebotcazou@adacore.com> + + * exp_ch7.adb (Establish_Transient_Scope.Find_Transient_Context): + Bail out for a simple return statement only if the transient scope + and the function both require secondary stack management, or else + if the function is a thunk. + * sem_res.adb (Resolve_Call): Do not create a transient scope when + the call is the expression of a simple return statement. + +2023-05-29 Patrick Bernardi <bernardi@adacore.com> + + * libgnat/a-excach.adb (Call_Chain): Replace + Code_Address_For_AAA/ZZZ functions with AAA/ZZZ'Code_Address. + * libgnat/a-except.adb (Code_Address_For_AAA/ZZZ): Delete. + (AAA/ZZZ): New null procedures. + * libgnat/g-debpoo.adb + (Code_Address_For_Allocate_End): Delete. + (Code_Address_For_Deallocate_End): Delete. + (Code_Address_For_Dereference_End): Delete. + (Allocate): Remove label and use Code_Address attribute to + determine subprogram addresses. + (Dellocate): Likewise. + (Dereference): Likewise. + (Allocate_End): Convert to null procedure. + (Dellocate_End): Likewise. + (Dereference_End): Likewise. + +2023-05-29 Eric Botcazou <ebotcazou@adacore.com> + + * exp_ch6.adb (Expand_Simple_Function_Return): Call Insert_Actions + consistently when rewriting the expression. + +2023-05-29 Eric Botcazou <ebotcazou@adacore.com> + + * exp_util.adb (Is_Finalizable_Transient.Is_Indexed_Container): + New predicate to detect a temporary created to hold the result of + a constant indexing on a container. + (Is_Finalizable_Transient.Is_Iterated_Container): Adjust a couple + of obsolete comments. + (Is_Finalizable_Transient): Return False if Is_Indexed_Container + returns True on the object. + +2023-05-29 Eric Botcazou <ebotcazou@adacore.com> + + * sem_res.adb (Has_Applicable_User_Defined_Literal): Make it clear + that the predicate also checks the node itself. + (Try_User_Defined_Literal): Move current implementation to... + Deal only with literals, named numbers and conditional expressions + whose dependent expressions are literals or named numbers. + (Try_User_Defined_Literal_For_Operator): ...this. Remove multiple + return False statements and put a single one at the end. + (Resolve): Call Try_User_Defined_Literal instead of directly + Has_Applicable_User_Defined_Literal for all nodes. Call + Try_User_Defined_Literal_For_Operator for operator nodes. + +2023-05-29 Piotr Trojanek <trojanek@adacore.com> + + * sem_res.adb (Invoked_With_Different_Arguments): Use Get_Called_Entity, + which properly deals with calls via an access-to-subprogram; fix + inconsistent use of a Call object declared in enclosing subprogram. + +2023-05-29 Piotr Trojanek <trojanek@adacore.com> + + * contracts.adb + (Add_Pre_Post_Condition): Attach pre/post aspects to E_Subprogram_Type + entity. + (Analyze_Entry_Or_Subprogram_Contract): Adapt to use full type + declaration for a contract attached to E_Subprogram_Type entity. + * sem_prag.adb + (Analyze_Pre_Post_Condition): Add pre/post aspects to the designed type. + +2023-05-29 Piotr Trojanek <trojanek@adacore.com> + + * sem_util.adb (Check_Function_Writable_Actuals): Remove guard against + a membership test with no alternatives; simplify with a membership test. + +2023-05-29 Piotr Trojanek <trojanek@adacore.com> + + * doc/gnat_ugn/gnat_and_program_execution.rst + (Some Useful Memory Pools): Remove extra whitespace from examples. + * sem_aggr.adb (Make_String_Into_Aggregate): Remove extra whitespace. + * gnat_ugn.texi: Regenerate. + +2023-05-29 Piotr Trojanek <trojanek@adacore.com> + + * exp_aggr.adb (Convert_Aggr_In_Allocator): Replace Get_TSS_Name + with a high-level Is_TSS. + * sem_ch6.adb (Check_Conformance): Replace DECLARE block and + nested IF with a call to Get_TSS_Name and a membership test. + (Has_Reliable_Extra_Formals): Refactor repeated calls to + Get_TSS_Name. + * sem_disp.adb (Check_Dispatching_Operation): Replace repeated + calls to Get_TSS_Name with a membership test. + +2023-05-29 Eric Botcazou <ebotcazou@adacore.com> + + * exp_ch5.adb (Expand_N_Case_Statement): Do not remove the statement + if it is the node to be wrapped by a transient scope. + +2023-05-29 Eric Botcazou <ebotcazou@adacore.com> + + * sem_prag.adb (Process_Compile_Time_Warning_Or_Error): Do not defer + anything to the back-end when the main unit is generic. + +2023-05-29 Eric Botcazou <ebotcazou@adacore.com> + + * sem_res.adb (Try_User_Defined_Literal): Restrict previous change + to non-leaf nodes. + +2023-05-29 Eric Botcazou <ebotcazou@adacore.com> + + * sem_res.adb (Try_User_Defined_Literal): For arithmetic operators, + also accept operands whose type is covered by the resolution type. + +2023-05-29 Eric Botcazou <ebotcazou@adacore.com> + + * exp_aggr.adb (Initialize_Array_Component): Fix condition detecting + the nested case that requires an adjustment. + +2023-05-29 Eric Botcazou <ebotcazou@adacore.com> + + * exp_ch4.adb (Expand_N_In): Deal specifically with a null operand. + +2023-05-29 Eric Botcazou <ebotcazou@adacore.com> + + * exp_ch6.adb (Expand_Simple_Function_Return): Deal with a rewriting + of the simple return during the adjustment of its expression. + +2023-05-29 Eric Botcazou <ebotcazou@adacore.com> + + * exp_ch4.adb (Expand_N_Case_Expression): Distribute simple return + statements enclosing the conditional expression into the dependent + expressions in almost all cases. + (Expand_N_If_Expression): Likewise. + (Process_Transient_In_Expression): Adjust to the above distribution. + * exp_ch6.adb (Expand_Ctrl_Function_Call): Deal with calls in the + dependent expressions of a conditional expression. + * sem_ch6.adb (Analyze_Function_Return): Deal with the rewriting of + a simple return statement during the resolution of its expression. + +2023-05-29 Piotr Trojanek <trojanek@adacore.com> + + * sem_res.adb (Resolve_Entity_Name): Refine rules for Exceptional_Cases. + +2023-05-29 Marc Poulhiès <poulhies@adacore.com> + + * exp_aggr.adb (Convert_To_Assignments): Do not mark node for + delayed expansion if parent type has the Aggregate aspect. + * sem_util.adb (Is_Container_Aggregate): Move... + * sem_util.ads (Is_Container_Aggregate): ... here and make it + public. + +2023-05-29 Piotr Trojanek <trojanek@adacore.com> + + * sem_res.adb (Resolve_Entity_Name): Relax rules for Exceptional_Cases. + +2023-05-29 Eric Botcazou <ebotcazou@adacore.com> + + * sem_ch4.ads (Unresolved_Operator): New procedure. + * sem_ch4.adb (Has_Possible_Literal_Aspects): Rename into... + (Has_Possible_User_Defined_Literal): ...this. Tidy up. + (Operator_Check): Accept again unresolved operators if they have a + possible user-defined literal as operand. Factor out the handling + of the general error message into... + (Unresolved_Operator): ...this new procedure. + * sem_res.adb (Resolve): Be prepared for unresolved operators on + entry in Ada 2022 or later. If they are still unresolved on exit, + call Unresolved_Operator to give the error message. + (Try_User_Defined_Literal): Tidy up. + +2023-05-29 Steve Baird <baird@adacore.com> + + * exp_ch3.adb + (Expand_N_Object_Declaration.Default_Initialize_Object): Add test for + specified Default_Component_Value aspect when deciding whether + either Initialize_Scalars or Normalize_Scalars impacts default + initialization of an array object. + +2023-05-29 Javier Miranda <miranda@adacore.com> + + * sem_aggr.adb + (Resolve_Record_Aggregate): For aggregates of derived tagged + record types with discriminants, when collecting components + from ancestors, pass to subprogram Gather_Components the + parent type. Required to report errors on wrong aggregate + components. + +2023-05-29 Piotr Trojanek <trojanek@adacore.com> + + * sem_util.adb (Check_Result_And_Post_State): Replace low-level + navigation with a high-level Unique_Entity. + +2023-05-29 Piotr Trojanek <trojanek@adacore.com> + + * sem_util.adb (Check_Result_And_Post_State): Properly handle entry + bodies. + +2023-05-29 Piotr Trojanek <trojanek@adacore.com> + + * contracts.adb (Fix_Parent): Fir part both for lists and nodes. + +2023-05-29 Arnaud Charlet <charlet@adacore.com> + + * sem_ch7.adb: Refine handling of inlining for CCG + +2023-05-29 Eric Botcazou <ebotcazou@adacore.com> + + * sem_ch12.adb (Copy_Generic_Node): Test the original node kind + for the sake of consistency. For identifiers and other entity + names and operators, accept an expanded name as associated node. + Replace "or" with "or else" in condtion and fix its formatting. + +2023-05-29 Piotr Trojanek <trojanek@adacore.com> + + * sem_util.adb (Check_Result_And_Post_State): Tune message. + +2023-05-29 Piotr Trojanek <trojanek@adacore.com> + + * contracts.adb (Remove_Formals): Remove. + (Preanalyze_Condition): Replace Pop_Scope with End_Scope. + * sem_ch13.adb (Build_Discrete_Static_Predicate): Replace + Pop_Scope with End_Scope; enclose Install_Formals within + Push_Scope/End_Scope. + +2023-05-29 Piotr Trojanek <trojanek@adacore.com> + + * sem_prag.adb (Analyze_Pre_Post_Condition): Tune error message. + +2023-05-29 Javier Miranda <miranda@adacore.com> + + * scans.ads (Inside_Interpolated_String_Expression): New variable. + * par-ch2.adb (P_Interpolated_String_Literal): Set/clear new + variable when parsing interpolated string expressions. + * scng.adb (Set_String): Skip processing operator symbols when we + arescanning an interpolated string literal. + +2023-05-29 Johannes Kliemann <kliemann@adacore.com> + + * Makefile.rtl (QNX): Use s-parame__qnx.adb for s-parame.adb. + * libgnat/s-parame__qnx.adb: Add QNX specific version of + System.Parameters. + +2023-05-29 Yannick Moy <moy@adacore.com> + + * libgnat/a-ngelfu.ads: Restore SPARK_Mode from context. + +2023-05-29 Marc Poulhiès <poulhies@adacore.com> + + * contracts.adb (Restore_Original_Selected_Component): Adjust assertion. + +2023-05-29 Piotr Trojanek <trojanek@adacore.com> + + * contracts.adb + (Add_Pre_Post_Condition): Adapt to handle pre/post of an + access-to-subprogram type. + (Analyze_Type_Contract): Analyze pre/post of an + access-to-subprogram. + * contracts.ads + (Analyze_Type_Contract): Adapt comment. + * sem_ch3.adb + (Build_Access_Subprogram_Wrapper): Copy pre/post aspects to + wrapper spec and keep it on the type. + * sem_prag.adb + (Analyze_Pre_Post_Condition): Expect pre/post aspects on + access-to-subprogram and complain if they appear without -gnat2022 + switch. + (Analyze_Pre_Post_Condition_In_Decl_Part): Adapt to handle + pre/post on an access-to-subprogram type entity. + * sem_attr.adb (Analyze_Attribute_Old_Result): Likewise. + (Result): Likewise. + +2023-05-26 Bob Duff <duff@adacore.com> + + * sem_ch3.adb + (Build_Derived_Record_Type): Temporarily set the state of the + Derived_Type to "self-hidden" while processing constraints + and discriminants of a record extension. + +2023-05-26 Bob Duff <duff@adacore.com> + + * einfo.ads: Add comma. + * contracts.adb: Fix typos. + * exp_attr.adb: Likewise. + * exp_ch5.adb: Likewise. + * exp_ch6.adb: Likewise. + * lib-xref.adb: Likewise. + +2023-05-26 Eric Botcazou <ebotcazou@adacore.com> + + * debug.adb (d.N): Document new usage. + * exp_ch4.adb (Expand_N_Type_Conversion): Copy the Float_Truncate + flag when rewriting a floating-point to fixed-point conversion as + a floating-point to integer conversion. + * exp_fixd.adb: Add with and use clauses for Debug. + (Expand_Convert_Fixed_To_Fixed): Generate a truncation in all cases + except if the result is explicitly rounded. + (Expand_Convert_Integer_To_Fixed): Likewise. + (Expand_Convert_Float_To_Fixed): Generate a truncation for all kind + of fixed-point types, except if the result is explicitly rounded, or + -gnatd.N is specified and the type is an ordinary fixed-point type. + * sinfo.ads (Float_Truncate): Document usage for floating-point to + fixed-point conversions. + +2023-05-26 Javier Miranda <miranda@adacore.com> + + * exp_ch4.adb + (Expand_N_Allocator): If an allocator with constraints is called + in the return statement of a function returning a general access + type, then propagate to the itype the master of the general + access type (since it is the master associated with the + returned object). + +2023-05-26 Yannick Moy <moy@adacore.com> + + * sem_aggr.adb (Resolve_Record_Aggregate): Add dummy initialization and + assertion that clarifies when we reassigned to a useful value. + +2023-05-26 Yannick Moy <moy@adacore.com> + + * doc/gnat_rm/gnat_language_extensions.rst: Be more explicit on + pattern matching limitation. + * gnat_rm.texi: Regenerate. + * gnat_ugn.texi: Regenerate. + +2023-05-26 Yannick Moy <moy@adacore.com> + + * libgnat/a-calend.ads: Mark with SPARK_Mode=>Off the functions which may + raise Time_Error. + * libgnat/a-ngelfu.ads: Mark with SPARK_Mode=>Off the functions which may + lead to an overflow (which is not the case of Tan with one parameter for + example, or Arctanh or Arcoth, despite their mathematical range covering + the reals). + * libgnat/a-textio.ads: Remove Always_Return annotation from functions, as + this is now compulsory for functions to always return in SPARK. + * libgnat/i-cstrin.ads: Add Might_Not_Return annotation to Update procedure + which may not return. + +2023-05-26 Bob Duff <duff@adacore.com> + + * exp_put_image.adb (Build_Image_Call): Treat 'Img the same as + 'Image. + * exp_imgv.adb (Expand_Image_Attribute): If Discard_Names, expand + to 'Image instead of 'Img. + * snames.ads-tmpl, par-ch4.adb, sem_attr.adb, sem_attr.ads: + Cleanups: Rename Attribute_Class_Array to be Attribute_Set. Remove + unnecessary qualifications. DRY: Don't repeat "True". + +2023-05-26 Piotr Trojanek <trojanek@adacore.com> + + * sem_prag.adb (Record_Possible_Body_Reference): Remove call to Present. + * sem_util.adb (Find_Untagged_Type_Of): Likewise. + +2023-05-26 Eric Botcazou <ebotcazou@adacore.com> + + * exp_aggr.adb (Initialize_Array_Component): Remove obsolete code. + (Expand_Array_Aggregate): In the case where a temporary is created + and the parent is an assignment statement with No_Ctrl_Actions set, + set Is_Ignored_Transient on the temporary. + +2023-05-26 Eric Botcazou <ebotcazou@adacore.com> + + * sem_ch12.adb (Instantiate_Package_Body): Set the ghost mode to + that of the instance only after loading the generic's parent. + (Instantiate_Subprogram_Body): Likewise. + +2023-05-26 Piotr Trojanek <trojanek@adacore.com> + + * exp_ch4.adb (Expand_Set_Membership): Simplify by using Evolve_Or_Else. + +2023-05-26 Piotr Trojanek <trojanek@adacore.com> + + * exp_ch4.adb (Is_OK_Object_Reference): Replace loop with a call to + Unqual_Conv; consequently, change object from variable to constant; + replace an IF statement with an AND THEN expression. + +2023-05-26 Piotr Trojanek <trojanek@adacore.com> + + * exp_ch9.adb + (Build_Entry_Count_Expression): Remove loop over component declaration; + consequently remove a parameter that is no longer used; adapt callers. + (Make_Task_Create_Call): Refine type of a local variable. + +2023-05-26 Piotr Trojanek <trojanek@adacore.com> + + * sem_cat.adb (Check_Non_Static_Default_Expr): Detect components inside + loop, not in the loop condition itself. + +2023-05-26 Eric Botcazou <ebotcazou@adacore.com> + + * libgnat/a-cbdlli.ads (List): Move Nodes component to the end. + +2023-05-26 Eric Botcazou <ebotcazou@adacore.com> + + * libgnat/a-crdlli.ads (List): Move Nodes component to the end. + +2023-05-26 Eric Botcazou <ebotcazou@adacore.com> + + * sem_attr.adb (Is_Thin_Pointer_To_Unc_Array): New predicate. + (Resolve_Attribute): Apply the static matching legality rule to an + Unrestricted_Access attribute applied to an aliased prefix if the + type is a thin pointer. Call Is_Thin_Pointer_To_Unc_Array for the + aliasing legality rule as well. + +2023-05-26 Piotr Trojanek <trojanek@adacore.com> + + * sem_util.adb (Is_Null_Record_Definition): Use First_Non_Pragma and + Next_Non_Pragma to ignore pragmas within component list. + +2023-05-26 Piotr Trojanek <trojanek@adacore.com> + + * sem_prag.adb (Get_Argument): Improve detection of generic units. + +2023-05-26 Piotr Trojanek <trojanek@adacore.com> + + * sem_ch4.adb (Check_Action_OK): Replace low-level test with a + high-level routine. + * sem_ch13.adb (Is_Predicate_Static): Likewise. + +2023-05-26 Javier Miranda <miranda@adacore.com> + + * exp_ch9.adb + (Expand_N_Conditional_Entry_Call): Factorize code to avoid + duplicating subtrees; required to avoid problems when the copied + code has implicit labels. + * sem_util.ads (New_Copy_Separate_List): Removed. + (New_Copy_Separate_Tree): Removed. + * sem_util.adb (New_Copy_Separate_List): Removed. + (New_Copy_Separate_Tree): Removed. + +2023-05-26 Piotr Trojanek <trojanek@adacore.com> + + * sem_ch13.adb (Check_Component_List): Local variable Compl is now + a constant; a nested block is no longer needed. + +2023-05-26 Piotr Trojanek <trojanek@adacore.com> + + * sem_aggr.adb + (Resolve_Record_Aggregate): Remove useless assignment. + * sem_aux.adb + (Has_Variant_Part): Remove useless guard; this routine is only called + on type entities (and now will crash in other cases). + * sem_ch3.adb + (Create_Constrained_Components): Only assign Assoc_List when necessary; + tune whitespace. + (Is_Variant_Record): Refactor repeated calls to Parent. + * sem_util.adb + (Gather_Components): Assert that discriminant association has just one + choice in component_association; refactor repeated calls to Next. + * sem_util.ads + (Gather_Components): Tune whitespace in comment. + +2023-05-26 Piotr Trojanek <trojanek@adacore.com> + + * sem_ch3.adb (Check_CPP_Type_Has_No_Defaults): Iterate with + First_Non_Pragma and Next_Non_Pragma. + * exp_dist.adb (Append_Record_Traversal): Likewise. + +2023-05-26 Javier Miranda <miranda@adacore.com> + + * exp_ch9.adb (Build_Class_Wide_Master): Remember internal blocks + that have a task master entity declaration. + (Build_Master_Entity): Code cleanup. + * sem_util.ads (Is_Internal_Block): New subprogram. + * sem_util.adb (Is_Internal_Block): New subprogram. + +2023-05-26 Piotr Trojanek <trojanek@adacore.com> + + * sem_util.adb (Gather_Components): Remove guard for empty list of + components. + +2023-05-26 Eric Botcazou <ebotcazou@adacore.com> + + * back_end.adb (Call_Back_End): Add gigi_standard_address to the + signature of the gigi procedure and alphabetize other parameters. + Pass Standard_Address as actual parameter for it. + * cstand.adb (Create_Standard): Do not set Is_Descendant_Of_Address + on Standard_Address. + * gcc-interface/gigi.h (gigi): Add a standard_address parameter and + alphabetize others. + * gcc-interface/trans.cc (gigi): Likewise. Record a builtin address + type and save it as the type for Standard.Address. + +2023-05-26 Ghjuvan Lacambre <lacambre@adacore.com> + + * exp_disp.adb (Expand_Dispatching_Call): Handle new Controlling_Tag. + * sem_scil.adb (Check_SCIL_Node): Treat N_Object_Renaming_Declaration as + N_Object_Declaration. + +2023-05-26 Piotr Trojanek <trojanek@adacore.com> + + * exp_aggr.adb + (Build_Constrained_Type): Remove local constants that were shadowing + equivalent global constants; replace a wrapper that calls + Make_Integer_Literal with a numeric literal; remove explicit + Aliased_Present parameter which is equivalent to the default value. + (Check_Bounds): Remove unused initial value. + (Expand_Array_Aggregate): Use aggregate type from the context. + +2023-05-26 Eric Botcazou <ebotcazou@adacore.com> + + * einfo.ads (Delay_Cleanups): Document new usage. + * exp_ch7.ads (Build_Finalizer): New declaration. + * exp_ch7.adb (Build_Finalizer.Process_Declarations): Do not treat + library-level package instantiations specially. + (Build_Finalizer): Return early for package bodies and specs that + are not compilation units instead of using a more convoluted test. + (Expand_N_Package_Body): Do not build a finalizer if Delay_Cleanups + is set on the defining entity. + (Expand_N_Package_Declaration): Likewise. + * inline.ads (Pending_Body_Info): Reorder and add Fin_Scop. + (Add_Pending_Instantiation): Add Fin_Scop parameter. + * inline.adb (Add_Pending_Instantiation): Likewise and copy it into + the Pending_Body_Info appended to Pending_Instantiations. + (Add_Scope_To_Clean): Change parameter name to Scop and remove now + irrelevant processing. + (Cleanup_Scopes): Deal with scopes that are package specs or bodies. + (Instantiate_Body): For package instantiations, deal specially with + scopes that are package bodies and with scopes that are dynamic. + Pass the resulting scope to Add_Scope_To_Clean directly. + * sem_ch12.adb (Analyze_Package_Instantiation): In the case where a + body is needed, compute the enclosing finalization scope and pass it + in the call to Add_Pending_Instantiation. + (Inline_Instance_Body): Adjust aggregate passed in the calls to + Instantiate_Package_Body. + (Load_Parent_Of_Generic): Likewise. + +2023-05-26 Eric Botcazou <ebotcazou@adacore.com> + + * sem_util.adb (Compile_Time_Constraint_Error): Test the Ekind. + +2023-05-26 Piotr Trojanek <trojanek@adacore.com> + + * exp_aggr.adb (Build_Constrained_Type): Use List_Length to count + expressions in consecutive subaggregates. + +2023-05-26 Doug Rupp <rupp@adacore.com> + + * libgnarl/s-osinte__qnx.ads (sigset_t): Modify + declaration to use system.os_constants computed + value. Align it. + +2023-05-26 Eric Botcazou <ebotcazou@adacore.com> + + * exp_sel.adb: Add clauses for Sem_Util, remove them for Opt, Sinfo + and Sinfo.Nodes. + (Build_K): Always use 'Tag of the object. + (Build_S_Assignment): Likewise. + +2023-05-26 Piotr Trojanek <trojanek@adacore.com> + + * accessibility.adb + (Is_Formal_Of_Current_Function): This routine expects an entity + reference and not the entity itself, so its parameter is a Node_Id + and not an Entity_Id. + +2023-05-26 Piotr Trojanek <trojanek@adacore.com> + + * exp_aggr.adb + (Build_Array_Aggr_Code): Change variable to constant. + (Check_Same_Aggr_Bounds): Fix style; remove unused initial value. + +2023-05-26 Ronan Desplanques <desplanques@adacore.com> + + * sem_ch6.adb (Analyze_Subprogram_Body_Helper): Create extra formals + in more situations. + +2023-05-26 Eric Botcazou <ebotcazou@adacore.com> + + * checks.adb (Selected_Range_Checks): Add guards to protect calls + to Expr_Value on bounds. + +2023-05-26 Eric Botcazou <ebotcazou@adacore.com> + + * sem_eval.ads (Is_Null_Range): Remove requirements of compile-time + known bounds and add WARNING line. + (Not_Null_Range): Remove requirements of compile-time known bounds. + * sem_eval.adb (Is_Null_Range): Fall back to Compile_Time_Compare. + (Not_Null_Range): Likewise. + * fe.h (Is_Null_Range): New predicate. + +2023-05-25 Javier Miranda <miranda@adacore.com> + + * sem_aggr.adb + (Warn_On_Null_Component_Association): New subprogram. + (Empty_Range): Adding missing support for iterated component + association node. + (Resolve_Array_Aggregate): Report warning on iterated component + association that may initialize some component of an array of + null-excluding access type components with a null value. + * exp_ch4.adb + (Expand_N_Expression_With_Actions): Add missing type check since + the subtype of the EWA node and the subtype of the expression + may differ. + +2023-05-25 Piotr Trojanek <trojanek@adacore.com> + + * sem_util.adb (Determining_Expressions): Fix style; fix layout and + ordering of pragma names; expect pragma Exceptional_Cases. + +2023-05-25 Piotr Trojanek <trojanek@adacore.com> + + * einfo-utils.adb (Write_Entity_Info): Use procedural Next_Index. + * sem_aggr.adb (Collect_Aggr_Bounds): Reuse local constant. + (Resolve_Null_Array_Aggregate): Use procedural Next_Index. + +2023-05-25 Javier Miranda <miranda@adacore.com> + + * exp_aggr.adb (Build_Record_Aggr_Code): Protect access to + aggregate components when the aggregate is empty. + +2023-05-25 Johannes Kliemann <kliemann@adacore.com> + + * libgnat/system-vxworks7-ppc-kernel.ads: Enable + Support_Atomic_Primitives. + * libgnat/system-vxworks7-ppc-rtp-smp.ads: Likewise. + +2023-05-25 Eric Botcazou <ebotcazou@adacore.com> + + * sem_ch3.adb (Find_Type_Of_Object): Copy the object definition when + building the subtype declaration in the case of a spec expression. + +2023-05-25 Tom Tromey <tromey@adacore.com> + + * Make-generated.in (ada/stamp-snames): Check result of + gnatmake. + +2023-05-25 Eric Botcazou <ebotcazou@adacore.com> + + * cstand.adb (Create_Standard): Set the Is_Descendant_Of_Address + flag on Standard_Address. + * freeze.adb (Freeze_Entity): Copy the modulus of System.Address + onto Standard_Address. + +2023-05-25 Eric Botcazou <ebotcazou@adacore.com> + + * libgnat/system-aix.ads (Address): Likewise. + * libgnat/system-darwin-arm.ads (Address): Likewise. + * libgnat/system-darwin-ppc.ads (Address): Likewise. + * libgnat/system-darwin-x86.ads (Address): Likewise. + * libgnat/system-djgpp.ads (Address): Likewise. + * libgnat/system-dragonfly-x86_64.ads (Address): Likewise. + * libgnat/system-freebsd.ads (Address): Likewise. + * libgnat/system-hpux-ia64.ads (Address): Likewise. + * libgnat/system-hpux.ads (Address): Likewise. + * libgnat/system-linux-alpha.ads (Address): Likewise. + * libgnat/system-linux-arm.ads (Address): Likewise. + * libgnat/system-linux-hppa.ads (Address): Likewise. + * libgnat/system-linux-ia64.ads (Address): Likewise. + * libgnat/system-linux-m68k.ads (Address): Likewise. + * libgnat/system-linux-mips.ads (Address): Likewise. + * libgnat/system-linux-ppc.ads (Address): Likewise. + * libgnat/system-linux-riscv.ads (Address): Likewise. + * libgnat/system-linux-s390.ads (Address): Likewise. + * libgnat/system-linux-sh4.ads (Address): Likewise. + * libgnat/system-linux-sparc.ads (Address): Likewise. + * libgnat/system-linux-x86.ads (Address): Likewise. + * libgnat/system-lynxos178-ppc.ads (Address): Likewise. + * libgnat/system-lynxos178-x86.ads (Address): Likewise. + * libgnat/system-mingw.ads (Address): Likewise. + * libgnat/system-qnx-arm.ads (Address): Likewise. + * libgnat/system-rtems.ads (Address): Likewise. + * libgnat/system-solaris-sparc.ads (Address): Likewise. + * libgnat/system-solaris-x86.ads (Address): Likewise. + * libgnat/system-vxworks-ppc-kernel.ads (Address): Likewise. + * libgnat/system-vxworks-ppc-rtp-smp.ads (Address): Likewise. + * libgnat/system-vxworks-ppc-rtp.ads (Address): Likewise. + * libgnat/system-vxworks7-aarch64-rtp-smp.ads (Address): Likewise. + * libgnat/system-vxworks7-aarch64.ads (Address): Likewise. + * libgnat/system-vxworks7-arm-rtp-smp.ads (Address): Likewise. + * libgnat/system-vxworks7-arm.ads (Address): Likewise. + * libgnat/system-vxworks7-ppc-kernel.ads (Address): Likewise. + * libgnat/system-vxworks7-ppc-rtp-smp.ads (Address): Likewise. + * libgnat/system-vxworks7-ppc64-kernel.ads (Address): Likewise. + * libgnat/system-vxworks7-ppc64-rtp-smp.ads (Address): Likewise. + * libgnat/system-vxworks7-x86-kernel.ads (Address): Likewise. + * libgnat/system-vxworks7-x86-rtp-smp.ads (Address): Likewise. + * libgnat/system-vxworks7-x86_64-kernel.ads (Address): Likewise. + * libgnat/system-vxworks7-x86_64-rtp-smp.ads (Address): Likewise. + +2023-05-25 Marc Poulhiès <poulhies@adacore.com> + + * sem_ch13.adb (Check_Aspect_At_Freeze_Point): fix format string, + use existing local Ident. + +2023-05-25 Bob Duff <duff@adacore.com> + + * atree.adb (Check_Vanishing_Fields): Fix bug in the "blah type + only" cases. Remove the special cases for E_Void. Misc cleanup. + (Mutate_Nkind): Disallow mutating to the same kind. + (Mutate_Ekind): Disallow mutating to E_Void. + (From E_Void is still OK -- entities start out as E_Void by + default.) Fix bug in statistics gathering -- was setting the wrong + count. Enable Check_Vanishing_Fields for entities. + * sem_ch8.adb (Is_Self_Hidden): New function. + (Find_Direct_Name): Call Is_Self_Hidden to use the new + Is_Not_Self_Hidden flag to determine whether a declaration is + hidden from all visibility by itself. This replaces the old method + of checking E_Void. + (Find_Expanded_Name): Likewise. + (Find_Selected_Component): Likewise. + * sem_util.adb (Enter_Name): Remove setting of Ekind to E_Void. + * sem_ch3.adb: Set the Is_Not_Self_Hidden flag in appropriate + places. Comment fixes. + (Inherit_Component): Remove setting of Ekind to E_Void. + * sem_ch9.adb + (Analyze_Protected_Type_Declaration): Update comment. Skip Itypes, + which should not be turned into components. + * atree.ads (Mutate_Nkind): Document error case. + (Mutate_Ekind): Remove comments apologizing for E_Void mutations. + Document error cases. + +2023-05-25 Eric Botcazou <ebotcazou@adacore.com> + + * libgnat/a-ststio.adb (Set_Mode): Test System.Memory_Size. + * libgnat/g-debuti.ads (Address_64): Likewise. + * libgnat/i-c.ads: Add with clause for System. + (ptrdiff_t): Define based on the size of memory space. + (size_t): Likewise. + * libgnat/s-crtl.ads (size_t): Likewise. + (ssize_t): Likewise. + * libgnat/s-memory.ads (size_t): Likewise. + * libgnat/s-parame.ads (Size_Type): Likewise. + * libgnat/s-parame__hpux.ads (Size_Type): Likewise. + * libgnat/s-parame__posix2008.ads (Size_Type): Likewise. + * libgnat/s-parame__vxworks.ads (Size_Type): Likewise. + * libgnat/s-putima.adb (Signed_Address): Likewise. + (Unsigned_Address): Likewise. + * libgnat/s-stoele.ads (Storage_Offset): Likewise. + +2023-05-25 Piotr Trojanek <trojanek@adacore.com> + + * sem_util.adb (Visit_Node): Decrement EWA_Level with the same condition + as when it was incremented. + +2023-05-25 Piotr Trojanek <trojanek@adacore.com> + + * sem_util.ads (New_Copy_Tree): Remove Scopes_In_EWA_OK from spec; + adapt comment. + * sem_util.adb (New_Copy_Tree): Remove Scopes_In_EWA_OK from body; + adapt code. + +2023-05-25 Piotr Trojanek <trojanek@adacore.com> + + * sem_util.adb (Update_New_Entities): Remove redundant check for entity + map being present. + +2023-05-25 Piotr Trojanek <trojanek@adacore.com> + + * atree.adb (Copy_List): Call Copy_Separate_Tree for both entities and + other nodes. + +2023-05-25 Steve Baird <baird@adacore.com> + + * exp_attr.adb + (Cached_Streaming_Ops): A new package, providing maps to save + previously-generated Read/Write/Input/Output procedures. + (Expand_N_Attribute_Reference): When a new subprogram is generated + for a Read/Write/Input/Output attribute reference, record that + type/subp pair in the appropriate Cached_Streaming_Ops map. + (Find_Stream_Subprogram): Check the appropriate + Cached_Streaming_Ops map to see if an appropriate subprogram has + already been generated. If so, then return it. The appropriateness + test includes a call to a new nested subprogram, + In_Available_Context. + * exp_strm.ads, exp_strm.adb: Do not pass in a Loc parameter (or a + source-location-bearing Nod parameter) to the 16 procedures + provided for building streaming-related subprograms. Use the + source location of the type instead. + * exp_dist.adb, exp_ch3.adb: Adapt to Exp_Strm spec changes. For + these calls the source location of the type was already being + used. + +2023-05-25 Marc Poulhiès <poulhies@adacore.com> + + * sem_ch6.adb (Analyze_Function_Return): Add missing + Is_Access_Type check before accessing the Designated_Type field. + +2023-05-25 Piotr Trojanek <trojanek@adacore.com> + + * sem_ch6.adb (Analyze_Return_Type): Remove unused initial value. + +2023-05-25 Marc Poulhiès <poulhies@adacore.com> + + * sem_ch13.adb (Analyze_One_Aspect): Call Record_Rep_Item. + (Check_Aspect_At_Freeze_Point): Check the aspect is specified on + non-array type only... + (Analyze_One_Aspect): ... instead of doing it too early here. + * sem_aggr.adb (Resolve_Container_Aggregate): Do nothing in case + the parameters failed to resolve. + +2023-05-25 Piotr Trojanek <trojanek@adacore.com> + + * sem_util.adb (Check_Internal_Protected_Use): Add standard protection + against search going too far. + +2023-05-25 Piotr Trojanek <trojanek@adacore.com> + + * contracts.adb + (Add_Pre_Post_Condition): Mention new aspects in the comment. + * contracts.ads + (Add_Contract_Item): Likewise. + (Analyze_Subprogram_Body_Stub_Contract): Likewise. + * sem_prag.adb + (Contract_Freeze_Error): Likewise. + (Ensure_Aggregate_Form): Likewise. + * sem_prag.ads + (Find_Related_Declaration_Or_Body): Likewise. + * sinfo.ads + (Is_Generic_Contract_Pragma): Likewise. + +2023-05-25 Piotr Trojanek <trojanek@adacore.com> + + * aspects.ads + (Implementation_Defined_Aspect): Recently added aspects are + implementation-defined, just like Contract_Cases. + * sem_prag.ads + (Aspect_Specifying_Pragma): Recently added aspects have corresponding + pragmas, just like Contract_Cases. + (Pragma_Significant_To_Subprograms): Recently added aspects are + significant to subprograms, just like Contract_Cases. + +2023-05-25 Piotr Trojanek <trojanek@adacore.com> + + * sem_res.adb (Resolve_Entity_Name): Tune handling of formal parameters + in contract Exceptional_Cases. + +2023-05-25 Piotr Trojanek <trojanek@adacore.com> + + * par-ch7.adb (P_Package): Remove redundant guard from call to + Move_Aspects. + * par-ch9.adb (P_Task): Likewise. + * sem_ch6.adb (Analyze_Expression_Function, Is_Inline_Pragma): Likewise. + +2023-05-25 Eric Botcazou <ebotcazou@adacore.com> + + * exp_ch6.adb (Add_Simple_Call_By_Copy_Code): Use Get_Actual_Subtype + to retrieve the actual subtype for all actuals and do it in only one + place for all unconstrained composite formal types. + +2023-05-25 Piotr Trojanek <trojanek@adacore.com> + + * sem_prag.adb (Analyze_Pragma): Fix references to Exceptional_Cases in + code copied from handling of Subprogram_Variant. + +2023-05-25 Ronan Desplanques <desplanques@adacore.com> + + * sem_ch3.adb (Replace_Type): Add more documentation. + +2023-05-25 Ronan Desplanques <desplanques@adacore.com> + + * sem_ch3.adb (Replace_Type): Use existing constant wherever + possible. + +2023-05-25 Ronan Desplanques <desplanques@adacore.com> + + * sem_ch3.adb (Replace_Type): Reduce span of variable. + +2023-05-25 Bob Duff <duff@adacore.com> + + * sem_ch9.adb (Analyze_Protected_Type_Declaration): Set the flag + for protected types. + (Analyze_Single_Protected_Declaration): Likewise, for singleton + protected objects. + (Analyze_Task_Type_Declaration): Set the flag for task types. + (Analyze_Single_Task_Declaration): Likewise, for singleton task + objects. + * sem_ch10.adb (Decorate_Type): Set the flag for types treated as + incomplete. + (Build_Shadow_Entity): Set the flag for shadow entities. + (Decorate_State): Set the flag for an abstract state. + (Build_Limited_Views): Set the flag for limited view of package. + * sem_attr.adb (Check_Not_Incomplete_Type): Disable the check when + this is a current instance. + +2023-05-25 Ronan Desplanques <desplanques@adacore.com> + + * freeze.adb (Build_DTW_Body): Add appropriate type conversions for + controlling access parameters. + * sem_util.adb (Build_Overriding_Spec): Fix designated types in + controlling access parameters. + +2023-05-25 Bob Duff <duff@adacore.com> + + * gen_il-gen-gen_entities.adb (E_Label): Add + Entry_Cancel_Parameter. This is necessary because + Analyze_Implicit_Label_Declaration set the Ekind to E_Label. + Without this change, this field would fail the vanishing-fields + check in Atree (which is currently commented out). + * einfo.ads (Entry_Cancel_Parameter): Document for E_Label. + * sem_eval.adb (Why_Not_Static): Protect against previous errors + (no need to explain why something is not static if it's already + illegal for other reasons). + * sem_util.ads (Enter_Name): Fix misleading comment. + +2023-05-25 Eric Botcazou <ebotcazou@adacore.com> + + * einfo.ads (Scope_Depth): Fix circular definition. + (Scope_Depth_Value): Fix value for library units. + +2023-05-25 Piotr Trojanek <trojanek@adacore.com> + + * sem_ch11.adb (Analyze_Raise_Expression): Tune warning condition. + * libgnat/g-dirope.ads (Open): Remove a potentially inaccurate comment. + * libgnat/g-dirope.adb (Open): Remove a potentially useless assignment; + the Dir output parameter should be assigned a null value anyway by the + preceding call to Free. + +2023-05-25 Piotr Trojanek <trojanek@adacore.com> + + * sem_res.adb (Resolve_Entity_Name): Allow aliased parameters; tune + error message. + +2023-05-25 Marc Poulhiès <poulhies@adacore.com> + + * sem_ch13.adb (Analyze_One_Aspect): Mark Aggregate aspect as + needing delayed resolution and reject the aspect on non-array + type. + +2023-05-25 Bob Duff <duff@adacore.com> + + * sinfo-utils.adb: Update comment to refer to + New_Node_Debugging_Output. + +2023-05-25 Marc Poulhiès <poulhies@adacore.com> + + * rtsfind.adb (Load_RTU.Restore_SPARK_Context): New. + (Load_RTU): Use Restore_SPARK_Context on all exit paths. + * sem_ch6.adb (Analyze_Subprogram_Body_Helper): Initialize local + variable to Empty. + +2023-05-25 Piotr Trojanek <trojanek@adacore.com> + + * sem_attr.adb + (Analyze_Attribute_Old_Result): Allow uses of 'Old and 'Result within + the new aspect. + * sem_res.adb + (Within_Exceptional_Cases_Consequence): New utility routine. + (Resolve_Entity_Name): Restrict use of formal parameters within the + new aspect. + +2023-05-23 Piotr Trojanek <trojanek@adacore.com> + + * aspects.ads + (Aspect_Id): Add aspect identifier. + (Aspect_Argument): New aspect accepts an expression. + (Is_Representation_Aspect): New aspect is not a representation + aspect. + (Aspect_Names): Associate name with the new aspect identifier. + (Aspect_Delay): New aspect is never delayed. + * contracts.adb + (Add_Contract_Item): Store new aspect among contract items. + (Analyze_Entry_Or_Subprogram_Contract): Likewise. + (Analyze_Subprogram_Body_Stub_Contract): Likewise. + (Process_Contract_Cases): Expand new aspect, if present. + * contracts.ads + (Analyze_Entry_Or_Subprogram_Body_Contract): Mention new aspect in + spec. + (Analyze_Entry_Or_Subprogram_Contract): Likewise. + * einfo-utils.adb + (Get_Pragma): Allow new aspect to be picked by the backend. + * einfo-utils.ads + (Get_Pragma): Mention new aspect in spec. + * exp_prag.adb + (Expand_Pragma_Exceptional_Cases): Dummy expansion routine. + * exp_prag.ads + (Expand_Pragma_Exceptional_Cases): Add spec for expansion routine. + * inline.adb + (Remove_Aspects_And_Pragmas): Remove aspect from bodies to inline. + * par-prag.adb + (Par.Prag): Accept pragma in the parser, so it will be checked + later. + * sem_ch12.adb + (Implementation of Generic Contracts): Mention new aspect in + comment. + * sem_ch13.adb + (Analyze_Aspect_Specifications): Transform new aspect info a + corresponding pragma. + * sem_prag.adb + (Analyze_Exceptional_Cases_In_Decl_Part): Analyze aspect + expression; heavily inspired by the existing code for analysis of + Subprogram_Variant and exception handlers. + (Analyze_Pragma): Analyze pragma corresponding to the new aspect. + (Is_Non_Significant_Pragma_Reference): Add new pragma to the + table. + * sem_prag.ads + (Assertion_Expression_Pragma): New pragma acts as an assertion + expression, even though it is not currently expanded. + (Analyze_Exceptional_Cases_In_Decl_Part): Add spec. + * sem_util.adb + (Is_Subprogram_Contract_Annotation): Mark new annotation is a + subprogram contract, so the subprogram with it won't be inlined. + * sem_util.ads + (Is_Subprogram_Contract_Annotation): Mention new aspect in + comment. + * sinfo.ads + (Contract_Test_Cases): Mention new aspect in comment. + * snames.ads-tmpl: Add entries for the new name and pragma. + +2023-05-23 Eric Botcazou <ebotcazou@adacore.com> + + * sem_ch13.adb (Build_Predicate_Functions): If the current scope + is not that of the type, push this scope and pop it at the end. + * sem_util.ads (Current_Scope_No_Loops_No_Blocks): Delete. + * sem_util.adb (Current_Scope_No_Loops_No_Blocks): Likewise. + (Set_Public_Status): Call again Current_Scope. + +2023-05-23 Gary Dismukes <dismukes@adacore.com> + + * exp_ch6.adb (Might_Have_Tasks): Remove unneeded Etype call from + call to Is_Limited_Record, since that flag is now properly + inherited by class-wide types. + * sem_ch3.adb (Analyze_Private_Extension_Declaration): Remove call + to Make_Class_Wide_Type, which is done too early, and will later + be done in Build_Derived_Record_Type after flags such as + Is_Limited_Record and Is_Controlled_Active have been set on the + derived type. + +2023-05-23 Patrick Bernardi <bernardi@adacore.com> + + * libgnat/s-stchop.adb (Stack_Check): Remove redundant parentheses. + +2023-05-23 Piotr Trojanek <trojanek@adacore.com> + + * freeze.adb (Freeze_Record_Type): Add tag for redundant pragma Pack. + * sem_aggr.adb (Resolve_Record_Aggregate): Add tag for redundant OTHERS + choice. + * sem_ch8.adb (Use_One_Type): Add tag for redundant USE clauses. + +2023-05-23 Piotr Trojanek <trojanek@adacore.com> + + * sem_ch11.adb + (Check_Duplication): Fix inconsistent iteration. + (Others_Present): Iterate over handlers using First_Non_Pragma and + Next_Non_Pragma just like in Check_Duplication. + +2023-05-23 Eric Botcazou <ebotcazou@adacore.com> + + * einfo.ads (Delay_Subprogram_Descriptors): Delete. + * gen_il-fields.ads (Opt_Field_Enum): Remove + Delay_Subprogram_Descriptors. + * gen_il-gen-gen_entities.adb (Gen_Entities): Likewise. + * gen_il-gen-gen_nodes.adb (N_Entry_Body): Add Corresponding_Spec. + * sinfo.ads (Corresponding_Spec): Document new use. + (N_Entry_Body): Likewise. + * exp_ch6.adb (Expand_Protected_Object_Reference): Be prepared for + protected subprograms that have been expanded. + * exp_ch7.adb (Expand_Cleanup_Actions): Remove unreachable code. + * exp_ch9.adb (Build_Protected_Entry): Add a local variable for the + new block and propagate Uses_Sec_Stack from the corresponding spec. + (Expand_N_Protected_Body) <N_Subprogram_Body>: Unconditionally reset + the scopes of top-level entities in the new body. + * inline.adb (Cleanup_Scopes): Do not adjust the scope on the fly. + * sem_ch9.adb (Analyze_Entry_Body): Set Corresponding_Spec. + * sem_ch12.adb (Analyze_Package_Instantiation): Remove obsolete code + setting Delay_Subprogram_Descriptors and tidy up. + * sem_util.adb (Scope_Within): Deal with protected subprograms that + have been expanded. + (Scope_Within_Or_Same): Likewise. + +2023-05-23 Eric Botcazou <ebotcazou@adacore.com> + + * libgnarl/s-taskin.ads (Atomic_Address): Delete. + (Attribute_Array): Add pragma Atomic_Components. + (Ada_Task_Control_Block): Adjust default value of Attributes. + * libgnarl/s-tasini.adb (Finalize_Attributes): Adjust type of local + variable. + * libgnarl/s-tataat.ads (Deallocator): Adjust type of parameter. + (To_Attribute): Adjust source type. + * libgnarl/a-tasatt.adb: Add clauses for System.Storage_Elements. + (New_Attribute): Adjust return type. + (Deallocate): Adjust type of parameter. + (To_Real_Attribute): Adjust source type. + (To_Address): Add target type. + (To_Attribute): Adjust source type. + (Fast_Path): Adjust tested type. + (Finalize): Compare with Null_Address. + (Reference): Likewise. + (Reinitialize): Likewise. + (Set_Value): Likewise. Add conversion to Integer_Address. + (Value): Likewise. + +2023-05-23 Raphael Amiard <amiard@adacore.com> + + * scng.adb (Scan): Replace occurrences of All_Extensions_Allowed + by Core_Extensions_Allowed. + +2023-05-23 Claire Dross <dross@adacore.com> + + * libgnat/s-valueu.adb (Scan_Raw_Unsigned): Use new helpers. + * libgnat/s-vauspe.ads (Raw_Unsigned_Starts_As_Based_Ghost, + Raw_Unsigned_Is_Based_Ghost): New ghost helper functions. + (Is_Raw_Unsigned_Format_Ghost, Scan_Split_No_Overflow_Ghost, + Scan_Split_Value_Ghost, Raw_Unsigned_Last_Ghost): Use new + helpers. + +2023-05-23 Arnaud Charlet <charlet@adacore.com> + + * par-ch5.adb, style.ads, styleg.adb, styleg.ads + (Check_Xtra_Parens): Remove extra parameter Enable. + (Check_Xtra_Parens_Precedence): New. + (P_Case_Statement): Add -gnatyx style check. + * sem_ch4.adb: Replace calls to Check_Xtra_Parens by + Check_Xtra_Parens_Precedence. + * stylesw.ads, stylesw.adb, usage.adb: Add support for + -gnatyz. + * doc/gnat_ugn/building_executable_programs_with_gnat.rst: + Update -gnatyxzg doc. + * sem_prag.adb, libgnat/s-regpat.adb, + libgnarl/s-interr__hwint.adb, libgnarl/s-interr__vxworks.adb: + Remove extra parens. + * par-ch3.adb (P_Discrete_Range): Do not emit a style check if + the expression is not a simple expression. + * gnat_ugn.texi: Regenerate. + +2023-05-23 Eric Botcazou <ebotcazou@adacore.com> + + * libgnat/s-dwalin.adb (Enable_Cache): Use the subtract operator of + System.Storage_Elements to compute the offset. + (Symbolic_Address): Likewise. + +2023-05-23 Eric Botcazou <ebotcazou@adacore.com> + + * sem_res.adb (Resolve_Intrinsic_Operator): Always perform the same + resolution for the special mod operator of System.Storage_Elements. + +2023-05-23 Raphael Amiard <amiard@adacore.com> + + * doc/gnat_rm.rst, doc/gnat_rm/gnat_language_extensions.rst, + doc/gnat_rm/implementation_defined_pragmas.rst: + * gnat_rm.texi: Regenerate. + +2023-05-23 Eric Botcazou <ebotcazou@adacore.com> + + * exp_ch4.adb (Expand_N_Op_Mod): Adjust the detection of the special + operator of System.Storage_Elements. Do not rewrite it into a rem. + * sem_res.adb (Resolve_Intrinsic_Operator): Use the base type of the + left operand for the special mod operator of System.Storage_Elements + +2023-05-23 Vadim Godunko <godunko@adacore.com> + + * libgnat/a-coinho__shared.adb (Constant_Reference): Remove call + of Detach + (Query_Element): Likewise. + +2023-05-23 Ronan Desplanques <desplanques@adacore.com> + + * sem_disp.adb: Fix reference to Ada issue in comment. + +2023-05-23 Eric Botcazou <ebotcazou@adacore.com> + + * exp_disp.adb (Expand_Dispatching_Call): In the abstract interface + class-wide case, use 'Tag of the object as the controlling tag. + (Expand_Interface_Thunk): Perform address arithmetic using operators + of System.Storage_Elements. + +2023-05-23 Eric Botcazou <ebotcazou@adacore.com> + + * libgnat/i-cpoint.adb: Add clauses for System.Storage_Elements. + (Addr): Delete. + (Offset): New subtype of Storage_Offset. + (To_Offset): New instance of Unchecked_Conversion. + (To_Pointer): Adjust. + (To_Addr): Likewise. + (To_Ptrdiff): Likewise. + ("+"): Call To_Offset on the offset. + ("-"): Likewise. + * libgnat/s-bituti.adb: Add clauses for System.Storage_Elements. + (Val_Bytes): Change type to Storage_Count. + (Get_Val_2): Add qualification to second operand of mod operator. + (Set_Val_2): Likewise. + (Copy_Bitfield): Likewise. Change type of Src_Adjust & Dest_Adjust. + * libgnat/s-stratt.ads (Thin_Pointer): Change to subtype of Address. + * libgnat/s-statxd.adb (I_AD): Adjust. + (I_AS): Likewise. + (W_AS): Likewise. + +2023-05-23 Steve Baird <baird@adacore.com> + + * sem_util.adb + (Is_Variable): Correctly return False for a selected component + name of the form Some_Object.Some_Discriminant, even if + Some_Object is a variable. We don't want to allow such a name as + an actual parameter in a call if the corresponding formal + parameter's mode is not "in". + +2023-05-23 Yannick Moy <moy@adacore.com> + + * sem_util.adb (Check_Node): Add default init on local Id. + +2023-05-23 Yannick Moy <moy@adacore.com> + + * libgnat/i-c.adb (To_Ada): Add loop invariant. + +2023-05-23 Eric Botcazou <ebotcazou@adacore.com> + + * exp_ch4.adb (Expand_N_Op_Mod): Deal with the special mod + operator of System.Storage_Elements. + * exp_intr.adb (Expand_To_Integer): New procedure. + (Expand_Intrinsic_Call): Call Expand_To_Integer appropriately. + (Expand_To_Address): Deal with an argument with modular type. + * sem_ch3.adb (Derive_Subprogram): Also set convention Intrinsic + on a derived intrinsic subprogram. + * sem_res.adb (Resolve_Arithmetic_Op): Deal with intrinsic + operators not coming from source exactly as those coming from + source and also generate a reference in both cases. + (Resolve_Op_Expon): Likewise. + (Resolve_Intrinsic_Operator): Call Implementation_Base_Type to get + a nonprivate base type. + * snames.ads-tmpl (Name_To_Integer): New intrinsic name. + * libgnat/s-stoele.ads: Replace pragma Convention with pragma + Import throughout and remove pragma Inline_Always and + Pure_Function. + * libgnat/s-stoele.adb: Replace entire contents with pragma + No_Body. + * libgnat/s-atacco.adb: Adjust comment about pragma No_Body. + +2023-05-23 Javier Miranda <miranda@adacore.com> + + * sem_prag.adb (Analyze_Pre_Post_Condition_In_Decl_Part): Remove + call to preanalyze class-wide conditions since here it is too + early; they must be preanalyzed when full views of private types + have been analyzed. + * sem_ch7.adb (Analyze_Package_Specification): Preanalyze + class-wide conditions of dispatching primitives defined in nested + packages. + +2023-05-23 Piotr Trojanek <trojanek@adacore.com> + + * errout.adb (Last_Sloc): Refactor a heavily repeated "S := S + 1" + statement into a subprogram; replace assertions with defensive code; + fix few more off-by-one errors. + +2023-05-23 Ronan Desplanques <desplanques@adacore.com> + + * einfo.ads: Mention full name of LSP. + +2023-05-23 Piotr Trojanek <trojanek@adacore.com> + + * errout.adb (Last_Sloc): Rewrite skipping past numeric literals. + +2023-05-23 Eric Botcazou <ebotcazou@adacore.com> + + * sem_ch13.adb (Build_Predicate_Function_Declaration): Adjust the + commentary to the current implementation. + * sem_util.ads (Current_Scope_No_Loops): Move around. + (Current_Scope_No_Loops_No_Blocks): New declaration. + (Add_Block_Identifier): Fix formatting. + * sem_util.adb (Add_Block_Identifier): Likewise. + (Current_Scope_No_Loops_No_Blocks): New function. + (Set_Public_Status): Call Current_Scope_No_Loops_No_Blocks instead + of Current_Scope to get the current scope. + +2023-05-23 Eric Botcazou <ebotcazou@adacore.com> + + * exp_ch3.adb (Build_Record_Init_Proc.Build_Assignment): Do not + manually generate a predicate check. Call Unqualify before doing + pattern matching on the expression. + * sem_ch3.adb (Analyze_Object_Declaration): Also freeze the actual + subtype when it is built in the definite case. + +2023-05-23 Piotr Trojanek <trojanek@adacore.com> + + * libgnarl/s-interr.adb + (Registered_Handler): Remove default expression. + (Registered_Handlers): Switch to singly-linked list. + (Bind_Interrupt_To_Entry): Sync whitespace with other unit variants. + (Is_Registered): Use singly-linked list. + (Register_Interrupt_Handler): Use singly-linked list and initialized + allocator; sync assertion with other unit variants. + * libgnarl/s-interr__sigaction.adb: Likewise. + * libgnarl/s-interr__vxworks.adb: Likewise. + * libgnarl/s-interr__hwint.adb: Likewise. + (Is_Registered): Remove repeated declaration. + +2023-05-23 Piotr Trojanek <trojanek@adacore.com> + + * pprint.adb (Expression_Image): Restore some of the old pretty-printing + for CodePeer. + +2023-05-23 Piotr Trojanek <trojanek@adacore.com> + + * errout.adb (First_And_Last_Nodes): Ignore accessibility parameters. + +2023-05-23 Piotr Trojanek <trojanek@adacore.com> + + * exp_ch4.adb (Expand_N_Op_Ne): Simply don't add extra parens. + +2023-05-23 Piotr Trojanek <trojanek@adacore.com> + + * pprint.adb (Expression_Image): Move Count_Parentheses and + Fix_Parentheses routines from GNATprove and apply them before + returning the slice of a source code buffer. + +2023-05-23 Piotr Trojanek <trojanek@adacore.com> + + * errout.adb + (Paren_Required): New subsidiary routine for better handling of + parentheses in First_Node/Last_Node. + (First_Sloc, Last_Sloc): Use Get_Source_File_Index to correctly + handle generic instances and inlined subprograms; tune handling of + parentheses; improve handling of literals. + * pprint.adb (Expression_Image): Simplify using + First_Sloc/Last_Sloc. + * sem_ch6.adb (Analyze_Expression_Function): Remove parenthesis + when relocating expression from expression function to simple + return statement. + +2023-05-23 Piotr Trojanek <trojanek@adacore.com> + + * exp_prag.adb (Expand_Pragma_Check): Suppress warning for checks of + subprogram variants. + +2023-05-23 Eric Botcazou <ebotcazou@adacore.com> + + * frontend.adb (Frontend): Merge two conditional blocks and adjust. + +2023-05-23 Piotr Trojanek <trojanek@adacore.com> + + * libgnat/s-mmap.adb (Mapped_Region_Record): Fix typo in comment. + +2023-05-23 Ronan Desplanques <desplanques@adacore.com> + + * sem_ch7.adb: Remove duplicate comment. + +2023-05-23 Javier Miranda <miranda@adacore.com> + + * sem_ch10.adb + (Analyze_Required_Limited_With_Units): New subprogram. + (Depends_On_Limited_Views): New subprogram. + (Has_Limited_With_Clauses): New subprogram. + (Analyze_Compilation_Unit): Call the new subprogram that performs + the full analysis of required limited-with units. + +2023-05-22 Ronan Desplanques <desplanques@adacore.com> + + * cstand.adb: Use more idiomatic procedure. + +2023-05-22 Piotr Trojanek <trojanek@adacore.com> + + * errout.adb (First_Loc): Avoid repeated calls. + (Last_Loc): Likewise. + +2023-05-22 Eric Botcazou <ebotcazou@adacore.com> + + * inline.adb (Cleanup_Scopes): Do not propagate the Uses_Sec_Stack + flag from original to rewritten protected subprograms here... + * exp_ch9.adb (Expand_N_Protected_Body) <N_Subprogram_Body>: + ...but here instead. Add local variables and remove a useless + test. + +2023-05-22 Eric Botcazou <ebotcazou@adacore.com> + + * exp_ch7.adb (Expand_N_Package_Body): Call Defining_Entity to get + the entity of the body. + +2023-05-22 Piotr Trojanek <trojanek@adacore.com> + + * exp_attr.adb (Expand_Loop_Entry_Attribute): Use location of the + attribute reference, not of the loop statement. + +2023-05-22 Ronan Desplanques <desplanques@adacore.com> + + * par-ch3.adb: Add missing word in comment. + +2023-05-22 Justin Squirek <squirek@adacore.com> + + * checks.adb (Install_Null_Excluding_Check): Avoid non-null + optimizations when assertions are enabled. + +2023-05-22 Marc Poulhiès <poulhies@adacore.com> + + * exp_aggr.adb (Process_Transient_Component): Reset Analyzed flag + for the copy of the initialization expression. + * sem_attr.adb (Validate_Non_Static_Attribute_Function_Call): Skip + error emission during Pre_Analyze. + +2023-05-22 Eric Botcazou <ebotcazou@adacore.com> + + * exp_ch7.adb (Process_Package_Body): New procedure taken from... + (Build_Finalizer.Process_Declarations): ...here. Call the above + procedure to deal with both package bodies and package body stubs. + +2023-05-22 Ronan Desplanques <desplanques@adacore.com> + + * atree.ads: Remove outdated part of comment. + +2023-05-22 Eric Botcazou <ebotcazou@adacore.com> + + * exp_ch7.adb (Build_Finalizer): Reverse the test comparing the + instantiation and declaration nodes of a package instance, and + therefore bail out only when they are equal. Adjust comments. + (Expand_N_Package_Declaration): Do not clear the Finalizer field. + * lib-writ.adb: Add with and use clauses for Sem_Util. + (Write_Unit_Information): Look at unit nodes to find finalizers. + * sem_ch12.adb (Analyze_Package_Instantiation): Beef up the comment + about the rewriting of the instantiation node into a declaration. + +2023-05-22 Bob Duff <duff@adacore.com> + + * cstand.adb (Is_Past_Self_Hiding_Point): Rename to be + Is_Not_Self_Hidden. + * einfo.ads: Likewise. + * exp_aggr.adb: Likewise. + * gen_il-fields.ads: Likewise. + * gen_il-gen-gen_entities.adb: Likewise. + * sem.adb: Likewise. + * sem_aggr.adb: Likewise. + * sem_ch11.adb: Likewise. + * sem_ch12.adb: Likewise. + * sem_ch5.adb: Likewise. + * sem_ch6.adb: Likewise. + * sem_ch7.adb: Likewise. + * sem_prag.adb: Likewise. + +2023-05-22 Eric Botcazou <ebotcazou@adacore.com> + + * exp_ch3.adb (Make_Controlling_Function_Wrappers): Create the body + as the expanded body of an expression function. + +2023-05-22 Piotr Trojanek <trojanek@adacore.com> + + * pprint.adb (Expression_Image): Handle several previously unsupported + constructs. + +2023-05-22 Piotr Trojanek <trojanek@adacore.com> + + * sem_res.adb (Resolve_Entity_Name): Combine two IF statements that + execute code only for references that come from source. + +2023-05-22 Bob Duff <duff@adacore.com> + + * einfo.ads (Is_Past_Self_Hiding_Point): Document. + * gen_il-fields.ads (Is_Past_Self_Hiding_Point): Add to list of + fields. + * gen_il-gen-gen_entities.adb (Is_Past_Self_Hiding_Point): Declare + in all entities. + * exp_aggr.adb: Set Is_Past_Self_Hiding_Point as appropriate. + * sem.adb: Likewise. + * sem_aggr.adb: Likewise. + * sem_ch11.adb: Likewise. + * sem_ch12.adb: Likewise. + * sem_ch5.adb: Likewise. + * sem_ch7.adb: Likewise. + * sem_prag.adb: Likewise. + * sem_ch6.adb: Likewise. + (Set_Formal_Mode): Minor cleanup: Move from spec. + * sem_ch6.ads: + (Set_Formal_Mode): Minor cleanup: Move to body. + * cstand.adb: Call Set_Is_Past_Self_Hiding_Point on all entities + as soon as they are created. + * comperr.adb (Compiler_Abort): Minor cleanup -- use 'in' instead + of 'or else'. + * debug.adb: Minor comment cleanups. + +2023-05-22 Steve Baird <baird@adacore.com> + + * sem_ch4.adb (Analyze_Expression_With_Actions.Check_Action_Ok): + Accept an executable pragma occuring in a declare expression as + per AI22-0045. This means Assert and Inspection_Point pragmas as + well as any implementation-defined pragmas that the implementation + chooses to categorize as executable. Currently Assume and Debug + are the only such pragmas. + +2023-05-22 Piotr Trojanek <trojanek@adacore.com> + + * sem_prag.adb + (Check_Postcondition_Use_In_Inlined_Subprogram): Mention + Subprogram_Variant in the comment. + (Analyze_Subprogram_Variant_In_Decl_Part): Warn when contract is + ignored because of pragma Inline_Always and frontend inlining. + +2023-05-22 Piotr Trojanek <trojanek@adacore.com> + + * sem_prag.adb (Check_Postcondition_Use_In_Inlined_Subprogram): Only + emit warning when frontend inlining is enabled. + +2023-05-22 Arnaud Charlet <charlet@adacore.com> + + * par-ch3.adb, sem_ch4.adb (P_Discrete_Range, Analyze_Logical_Op, + Analyze_Short_Circuit): Add calls to Check_Xtra_Parentheses. + * par-ch5.adb (P_Condition): Move logic to Check_Xtra_Parentheses. + * style.ads, styleg.adb, styleg.ads (Check_Xtra_Parens): Move logic + related to expressions requiring parentheses here. + +2023-05-22 Arnaud Charlet <charlet@adacore.com> + + * ali-util.adb, par-endh.adb, par-prag.adb, par-ch2.adb, + checks.adb, fmap.adb, libgnat/a-nbnbig.ads, libgnat/g-dynhta.adb, + libgnat/s-carun8.adb, libgnat/s-strcom.adb, libgnat/a-dhfina.adb, + libgnat/a-direct.adb, libgnat/a-rbtgbo.adb, libgnat/a-strsea.adb, + libgnat/a-ststio.adb, libgnat/a-suenco.adb, libgnat/a-costso.adb, + libgnat/a-strmap.adb, libgnat/g-alleve.adb, + libgnat/g-debpoo.adb, libgnat/g-sercom__linux.adb, + libgnat/s-genbig.adb, libgnat/s-mmap.adb, libgnat/s-regpat.adb, + par-ch5.adb, sem_case.adb, sem_ch12.adb, sem_ch13.adb, + sem_ch8.adb, sem_eval.adb, sem_prag.adb, sem_type.adb, + exp_ch11.adb, exp_ch2.adb, exp_ch3.adb, exp_ch4.adb, exp_ch5.adb, + exp_ch6.adb, exp_ch9.adb, exp_put_image.adb, freeze.adb, live.adb, + sem_aggr.adb, sem_cat.adb, sem_ch10.adb, sem_ch3.adb, sem_ch6.adb, + sem_ch9.adb, sem_disp.adb, sem_elab.adb, sem_res.adb, + sem_util.adb, sinput.adb, uintp.adb, bcheck.adb, binde.adb, + binderr.adb, einfo-utils.adb, clean.adb, sem_ch4.adb, gnatls.adb, + gprep.adb, sem_ch11.adb: Remove extra parentheses. + +2023-05-22 Arnaud Charlet <charlet@adacore.com> + + * sem_aggr.adb (Get_Value): Use ?? instead of ?. + +2023-05-22 Piotr Trojanek <trojanek@adacore.com> + + * exp_aggr.adb (Aggregate_Size): Remove redundant calls to + Present. + * exp_ch5.adb (Expand_N_If_Statement): Likewise. + * sem_prag.adb (Analyze_Pragma): Likewise. + * sem_warn.adb (Find_Var): Likewise. + +2023-05-22 Claire Dross <dross@adacore.com> + + * sem_util.adb (Find_Actual): On calls through dereferences, + return the corresponding formal in the designated subprogram + profile. + +2023-05-22 Piotr Trojanek <trojanek@adacore.com> + + * sem_util.ads (Is_Actual_Tagged_Parameter): Remove spec. + * sem_util.adb (Is_Actual_Tagged_Parameter): Remove body. + +2023-05-22 Joffrey Huguet <huguet@adacore.com> + + * libgnat/a-strunb.ads, libgnat/a-strunb__shared.ads + (To_Unbounded_String): Add postcondition. Add aspect SPARK_Mode + Off on the version that takes a Natural as parameter. + (To_String): Complete postcondition. + (Set_Unbounded_String): Add postcondition. + (Element): Likewise. + ("="): Likewise. + +2023-05-22 Eric Botcazou <ebotcazou@adacore.com> + + * exp_ch3.adb (Freeze_Type): Do not associate the Finalize_Address + routine for a class-wide type if restriction No_Dispatching_Calls + is in effect. + +2023-05-22 Eric Botcazou <ebotcazou@adacore.com> + + * libgnat/s-genbig.ads (From_Bignum): New overloaded declarations. + * libgnat/s-genbig.adb (LLLI): New subtype. + (LLLI_Is_128): New boolean constant. + (From_Bignum): Change the return type of the signed implementation + to Long_Long_Long_Integer and add support for the case where its + size is 128 bits. Add a wrapper around it for Long_Long_Integer. + Add an unsigned implementation returning Unsigned_128 and a wrapper + around it for Unsigned_64. + (To_Bignum): Test LLLI_Is_128 instead of its size. + (To_String.Image): Add qualification to calls to From_Bignum. + * libgnat/a-nbnbin.adb (To_Big_Integer): Likewise. + (Signed_Conversions.From_Big_Integer): Likewise. + (Unsigned_Conversions): Likewise. + +2023-05-22 Eric Botcazou <ebotcazou@adacore.com> + + * freeze.adb (Wrap_Imported_Subprogram): Use Copy_Subprogram_Spec + to copy the spec from the subprogram to the generated subprogram + body. + (Freeze_Entity): Do not wrap imported subprograms inside generics. + +2023-05-22 Steve Baird <baird@adacore.com> + + * sem_ch4.adb (Analyze_Expression_With_Actions.Check_Action_Ok): + If Comes_From_Source (A) is False, then look at Original_Node (A) + instead of A. In particular, if an (illegal) expression function + is transformed into a "vanilla" function, we don't want to allow + it just because Comes_From_Source is now False. + +2023-05-22 Steve Baird <baird@adacore.com> + + * sem_prag.adb (Analyze_Pragma): In Check_No_Return, call + Error_Msg_Ada_2022_Feature in the case of a function. Remove code + outside of Check_No_Return that was querying Ada_Version. + +2023-05-22 Eric Botcazou <ebotcazou@adacore.com> + + * exp_ch4.adb (Expand_N_Expression_With_Actions.Process_Action): Do + not look into nested blocks. + +2023-05-22 Eric Botcazou <ebotcazou@adacore.com> + + * sem_ch3.adb (Find_Type_Of_Object): In a spec expression, also set + the Scope of the type, and call Constrain_Array for array subtypes. + +2023-05-22 Piotr Trojanek <trojanek@adacore.com> + + * pprint.adb (Expression_Image): Reduce scope of local variables; inline + local uncommented constant From_Source; concatenate string with a single + character, as it is likely to execute faster; add missing cases to + traversal for the rightmost node and assertion to demonstrate that the + ??? comment is no longer relevant. + +2023-05-22 Piotr Trojanek <trojanek@adacore.com> + + * pprint.adb (Expr_Name): Qualify CASE expression with N_Subexpr; add + missing alternative for N_Raise_Storage_Error; remove dead alternatives; + explicitly list unsupported alternatives. + +2023-05-22 Piotr Trojanek <trojanek@adacore.com> + + * pprint.adb (Expr_Name): Exclude DEL from printable range. + +2023-05-22 Piotr Trojanek <trojanek@adacore.com> + + * sem_util.ads (New_Copy_Tree): Update comment. + * sem_util.adb (New_Copy_Tree): Update Controlling_Argument, very + much like we update the First/Next_Named_Association. + +2023-05-22 Bob Duff <duff@adacore.com> + + * fe.h: Remove Ada_With_Extensions and add commentary. + * opt.ads: Rearrange code and add commentary. + +2023-05-22 Bob Duff <duff@adacore.com> + + * sem_util.adb (Process_Type): Stop the recursion. + * exp_aggr.adb (Build_Record_Aggr_Code): Add assertion. + +2023-05-18 Bernhard Reutner-Fischer <aldot@gcc.gnu.org> + + * gcc-interface/decl.cc (gnat_to_gnu_entity): Use _P defines + from tree.h. + (constructor_address_p): Ditto. + (elaborate_expression_1): Ditto. + * gcc-interface/trans.cc (Identifier_to_gnu): Ditto. + (is_nrv_p): Ditto. + (Subprogram_Body_to_gnu): Ditto. + (gnat_to_gnu): Ditto. + (gnat_to_gnu_external): Ditto. + (add_decl_expr): Ditto. + (gnat_gimplify_expr): Ditto. + * gcc-interface/utils.cc (create_var_decl): Ditto. + * gcc-interface/utils2.cc (get_base_type): Ditto. + (build_binary_op): Ditto. + (build_unary_op): Ditto. + (gnat_protect_expr): Ditto. + (gnat_invariant_expr): Ditto. + +2023-05-16 Steve Baird <baird@adacore.com> + + * usage.adb: Generate output text describing the -gnatw_s switch + (and the corresponding -gnatw_S switch). + +2023-05-16 Eric Botcazou <ebotcazou@adacore.com> + + * exp_attr.adb (Expand_N_Attribute_Reference) <Attribute_Reduce>: + Use the canonical accumulator type as the type of the accumulator + in the prefixed case. + +2023-05-16 Eric Botcazou <ebotcazou@adacore.com> + + * exp_aggr.adb (Expand_Array_Aggregate): Do not set Warnings_Off on + the temporary created when in-place expansion is not possible. + +2023-05-16 Eric Botcazou <ebotcazou@adacore.com> + + * freeze.adb (Freeze_Expression): When the freezing is to be done + outside the current scope, skip any scope that is an internal loop. + +2023-05-16 Eric Botcazou <ebotcazou@adacore.com> + + * exp_imgv.adb (Rewrite_Object_Image): If the prefix is a component + that depends on a discriminant, create an actual subtype for it. + +2023-05-16 Eric Botcazou <ebotcazou@adacore.com> + + * sem_ch13.adb: Add with and use clauses for Expander. + (Resolve_Aspect_Expressions) <Aspect_Predicate>: Emulate a + bona-fide preanalysis setup before calling + Resolve_Aspect_Expression. + +2023-05-16 Yannick Moy <moy@adacore.com> + + * libgnat/s-aridou.adb (Lemma_Div_Pow2): Add assertion. + * libgnat/s-arit32.adb (Lemma_Abs_Div_Commutation): Simplify. + * libgnat/s-expmod.adb (Lemma_Exp_Mod): Add assertions. + (Lemma_Euclidean_Mod): Add body to lemma. + (Lemma_Mult_Mod): Add assertion. + * libgnat/s-valueu.adb (Scan_Raw_Unsigned): Modify assertion. + * libgnat/s-vauspe.ads (Raw_Unsigned_Last_Ghost): Add + postcondition. + * libgnat/s-widthi.adb: Use more precise types. + +2023-05-16 Eric Botcazou <ebotcazou@adacore.com> + + * sem_res.adb (Has_Applicable_User_Defined_Literal): Apply the + same processing for derived untagged types as for tagged types. + * sem_util.ads (Corresponding_Primitive_Op): Adjust description. + * sem_util.adb (Corresponding_Primitive_Op): Handle untagged + types. + +2023-05-16 Javier Miranda <miranda@adacore.com> + + * sem_attr.adb + (Analyze_Attribute_Old_Result): When preanalyzing a class-wide + condition, search in the scopes stack for the subprogram that has + the condition. This is required because returning the current + scope causes reporting spurious errors when the occurrence of the + attribute is found, for example, in a quantified expression. + +2023-05-16 Javier Miranda <miranda@adacore.com> + + * exp_ch6.adb + (Needs_BIP_Alloc_Form): Return False for functions with foreign + convention since we never use build-in-place for such functions. + +2023-05-16 Piotr Trojanek <trojanek@adacore.com> + + * sem_util.adb (Aggregate_Constraint_Checks): Don't exit early + when preanalysing in GNATprove mode. Now the condition is + consistent with other similar conditions in other code. + +2023-05-16 Ghjuvan Lacambre <lacambre@adacore.com> + + * usage.adb (Usage): Document -gnatyD. + +2023-05-16 Marc Poulhiès <poulhies@adacore.com> + + * libgnat/s-tsmona__linux.adb (link_map, r_debug_type): Add + 'aliased' on all components. + +2023-05-16 Johannes Kliemann <kliemann@adacore.com> + + * libgnat/system-linux-ppc.ads: Add Support_Atomic_Primitives. + * libgnat/s-atopri__32.ads: Add 32 bit version of s-atopri.ads. + * Makefile.rtl: Use s-atopro__32.ads for ppc-linux. + +2023-05-16 Eric Botcazou <ebotcazou@adacore.com> + + * sem_util.adb (Get_Actual_Subtype): For an explicit dereference, + return the Actual_Designated_Subtype if it is present. + (Get_Actual_Subtype_If_Available): Likewise. + +2023-05-16 Arnaud Charlet <charlet@adacore.com> + + * errout.ads: Update comment. + * errout.adb (Skip_Msg_Insertion_Warning): Update to take e.g. + -gnatyM into account. + * erroutc.adb (Get_Warning_Option, Get_Warning_Tag) + (Prescan_Message): Add support for Style tags. + * par-ch5.adb, par-ch6.adb, par-ch7.adb, par-endh.adb, + par-util.adb, style.adb, styleg.adb: Set tag on all style + messages. + +2023-05-16 Tom Tromey <tromey@adacore.com> + + * doc/gnat_ugn/building_executable_programs_with_gnat.rst + (Switches_for_gnatbind): Fix typo. + * libgnat/g-spipat.ads: Fix typo. + * gnat_ugn.texi: Regenerate. + +2023-05-16 Eric Botcazou <ebotcazou@adacore.com> + + * exp_aggr.adb (Build_Assignment_With_Temporary): Adjust comment + and fix type of second parameter. Create the temporary on the + secondary stack by calling Build_Temporary_On_Secondary_Stack. + (Convert_Array_Aggr_In_Allocator): Adjust formatting. + (Expand_Array_Aggregate): Likewise. + * exp_ch4.adb (Expand_N_Allocator): Set Actual_Designated_Subtype + on the dereference in the initialization for all composite types. + * exp_ch5.adb (Expand_N_Assignment_Statement): Create a temporary + on the host for an assignment between nonnative storage models. + Suppress more checks when Suppress_Assignment_Checks is set. + * exp_ch6.adb (Add_Simple_Call_By_Copy_Code): Deal with actuals + that are dereferences with an Actual_Designated_Subtype. Add + support for nonnative storage models. + (Expand_Actuals): Create a copy if the actual is a dereference + with a nonnative storage model. + * exp_util.ads (Build_Temporary_On_Secondary_Stack): Declare. + * exp_util.adb (Build_Temporary_On_Secondary_Stack): New function. + * sem_ch5.adb (Analyze_Assignment.Set_Assignment_Type): Do not + build an actual subtype for dereferences with an + Actual_Designated_Subtype + * sinfo.ads (Actual_Designated_Subtype): Adjust documentation. + (Suppress_Assignment_Checks): Likewise. + +2023-05-16 Piotr Trojanek <trojanek@adacore.com> + + * exp_spark.adb (SPARK_Freeze_Type): Copy whole handling of DIC + and Type_Invariant from Freeze_Type. + +2023-05-16 Richard Kenner <kenner@adacore.com> + + * sem_util.adb (Subprogram_Name): If what's passed is already an + entity, use that for the name. + +2023-05-16 Eric Botcazou <ebotcazou@adacore.com> + + * doc/gnat_rm/standard_and_implementation_defined_restrictions.rst + (No_Dependence): Give examples of new No_Dependence restrictions. + * gnat_rm.texi: Regenerate. + +2023-05-16 Arnaud Charlet <charlet@adacore.com> + + * snames.ads-tmpl (Name_ASCII): New. + * style.adb (Check_Identifier): Fix handling of ASCII. + +2023-05-16 Eric Botcazou <ebotcazou@adacore.com> + + * gen_il-fields.ads (Opt_Field_Enum): Add Cannot_Be_Superflat. + * gen_il-gen-gen_nodes.adb (N_Range): Add Cannot_Be_Superflat as + semantical flag and change Includes_Infinities to semantical. + * sinfo.ads (Cannot_Be_Superflat): Document it for N_Range. + * exp_ch4.adb (Expand_Concatenate): Set Cannot_Be_Superflat on the + range of the result if the result cannot be null. + +2023-05-16 Richard Kenner <kenner@adacore.com> + + * gen_il-gen-gen_nodes.adb (Present_Expr): Type is now Uint. + +2023-05-16 Yannick Moy <moy@adacore.com> + + * libgnat/s-aridou.adb (Big3, Is_Mult_Decomposition) + (Is_Scaled_Mult_Decomposition): Add annotation for inlining. + (Double_Divide, Scaled_Divide): Simplify and remove ghost code. + (Prove_Multiplication): Add calls to lemmas to make proof go + through. + * libgnat/s-aridou.ads (Big, In_Double_Int_Range): Add annotation + for inlining. + +2023-05-16 Yannick Moy <moy@adacore.com> + + * libgnat/a-strsup.adb: Add intermediate assertions. + +2023-05-16 Arnaud Charlet <charlet@adacore.com> + + * gnat1drv.adb: Ensure all dependencies are recorded even when not + generating code. + +2023-05-16 Yannick Moy <moy@adacore.com> + + * libgnat/a-strsup.adb: Set assertion policy for Loop_Variant. + +2023-05-16 Marc Poulhiès <poulhies@adacore.com> + + * sem_ch12.adb (Instantiate_Package_Body): Simplify if/then/else. + (Instantiate_Subprogram_Body): Likewise. + +2023-05-16 Yannick Moy <moy@adacore.com> + + * libgnat/s-aridou.adb: + (Big3): Remove override made useless. + (Lemma_Quot_Rem): Add new lemma and justify it, as no prover + manages to prove it. + (Lemma_Div_Pow2): Use new lemma Lemma_Quot_Rem. + (Prove_Scaled_Mult_Decomposition_Regroup3): Retype for + simplification. + (Scaled_Divide): Remove useless assertions.Decompose some + assertions with cut operations. Use Assert_And_Cut for second + half. Add assertions. + +2023-05-15 Marc Poulhiès <poulhies@adacore.com> + + * exp_ch3.adb (Make_Allocator_For_Return): Fix typo in comment. + +2023-05-15 Yannick Moy <moy@adacore.com> + + * libgnat/a-strbou.ads: Add justifications for Mapping. + * libgnat/a-strfix.adb: Same. + * libgnat/a-strfix.ads: Same. + * libgnat/a-strsea.adb: Same. + * libgnat/a-strsea.ads: Same. + * libgnat/a-strsup.adb: Same and add loop variants. + * libgnat/a-strsup.ads: Same and add specification of termination. + +2023-05-15 Yannick Moy <moy@adacore.com> + + * libgnat/a-strsup.adb (Super_Slice): Reorder component assignment + to avoid failing predicate check related to initialization. + * libgnat/s-expmod.adb (Exp_Modular): Add intermediate assertion. + +2023-05-15 Yannick Moy <moy@adacore.com> + + * libgnat/i-c.adb: Add loop variants. Remove useless + initialization. + +2023-05-15 Bob Duff <duff@adacore.com> + + * einfo-utils.ads: Remove comment. + +2023-05-15 Bob Duff <duff@adacore.com> + + * einfo-utils.ads, einfo-utils.adb: Get rid of the Proc_Next_... + procedures. Use Inline aspect instead of pragma Inline. + Is_Discrete_Or_Fixed_Point_Type did not have pragma Inline, but + now has the aspect; this was probably an oversight + (which illustrates why aspects are better). + +2023-05-15 Ronan Desplanques <desplanques@adacore.com> + + * doc/gnat_ugn/gnat_utility_programs.rst: Fix formatting + inconsistency. + +2023-05-15 Bob Duff <duff@adacore.com> + + * einfo-utils.adb: + (Proc_Next_Component_Or_Discriminant): Call + Next_Component_Or_Discriminant. + +2023-05-15 Bob Duff <duff@adacore.com> + + * einfo.ads: + (First_Entity): Update comment explaining why this exists on all + [sub]types, as opposed to just the ones with associated entities. + +2023-05-15 Bob Duff <duff@adacore.com> + + * atree.adb + (Check_Vanishing_Fields): Disable the check for "root/base type + only" fields. This is a bug fix -- if we're checking some subtype + S, we don't want to reach over to the root or base type and + Reinit_Field_To_Zero of that, thus modifying the field for lots of + subtypes other than S. Disable in the to/from E_Void cases. Misc + cleanup. + * gen_il-gen-gen_entities.adb: Define First_Entity, Last_Entity, + and Stored_Constraint for all type entities, because there are too + many cases where Reinit_Field_To_Zero would otherwise be needed. + In any case, it seems cleaner to have First_Entity and Last_Entity + defined in the same entity kinds. + * einfo.ads: + (First_Entity, Last_Entity, Stored_Constraint): Update comments to + reflect gen_il-gen-gen_entities.adb changes. + (Lit_Hash): Add missing "[root type only]" comment. + * exp_ch5.adb: Add Reinit_Field_To_Zero calls for vanishing + fields. + * sem_ch10.adb: Likewise. + * sem_ch6.adb: Likewise. + * sem_ch7.adb: Likewise. + * sem_ch8.adb: Likewise. + * sem_ch3.adb: Likewise. Also remove now-unnecessary + Reinit_Field_To_Zero calls. + +2023-05-15 Eric Botcazou <ebotcazou@adacore.com> + + * sem_ch7.adb (Hide_Public_Entities): Use the same condition for + subprogram bodies without specification as for those with one. + +2023-05-15 Piotr Trojanek <trojanek@adacore.com> + + * sem_util.adb (New_Copy_Tree): Remove redundant calls to Present. + +2023-05-15 Ronan Desplanques <desplanques@adacore.com> + + * sem_ch8.adb (End_Scope): Simplify lookup of predecessor in + homonym chain. + +2023-05-15 Piotr Trojanek <trojanek@adacore.com> + + * sem_aggr.adb (Resolve_Aggregate): Accept aggregates with OTHERS + appearing inside unchecked conversions. + +2023-05-15 Steve Baird <baird@adacore.com> + + * warnsw.ads: Add a new element, + Warn_On_Ineffective_Predicate_Test, to the Opt_Warnings_Enum + enumeration type. + * warnsw.adb: Bind "-gnatw_s" to the new + Warn_On_Ineffective_Predicate_Test switch. Add the new switch to + the set of switches enabled by -gnata . + * sem_ch13.adb + (Build_Discrete_Static_Predicate): Declare new local procedure, + Warn_If_Test_Ineffective, which conditionally generates new + warning. Call this new procedure when building a new element of an + RList. + * doc/gnat_ugn/building_executable_programs_with_gnat.rst: + Document the -gnatw_s switch (and the corresponding -gnatw_S + switch). + * gnat_ugn.texi: Regenerate. + +2023-05-15 Yannick Moy <moy@adacore.com> + + * sem_attr.adb: Update comment referring to rule number. + +2023-05-15 Ronan Desplanques <desplanques@adacore.com> + + * sem_attr.adb: sem_attr.adb (Analyze_Access_Attribute): Tighten + validity check for task types. + +2023-05-15 Ronan Desplanques <desplanques@adacore.com> + + * doc/gnat_rm/implementation_defined_characteristics.rst: Fix + minor documentation formatting issue. + * gnat_rm.texi: Regenerate. + * gnat_ugn.texi: Regenerate. + +2023-05-15 Bob Duff <duff@adacore.com> + + * exp_ch4.adb + (Expand_N_Op_Expon): Remove the too-big check. Simplify. Signed + and modular cases are combined, etc. Remove code with comment "We + only handle cases where the right type is a[sic] integer", because + the right operand must always be an integer at this point. + +2023-05-15 Bob Duff <duff@adacore.com> + + * sem_attr.adb + (Analyze_Attribute): Add a call to Check_Error_Detected. + +2023-05-15 Yannick Moy <moy@adacore.com> + + * par-prag.adb (First_Arg_Is_Matching_Tool_Name): Fix access to + expression in pragma association. + +2023-05-15 Eric Botcazou <ebotcazou@adacore.com> + + * repinfo.ads (JSON output format): Document special case of + Present member of a Variant object. + * repinfo.adb (List_Structural_Record_Layout): Change the type of + Ext_Level parameter to Integer. Restrict the first recursion with + increasing levels to the fixed part and implement a second + recursion with decreasing levels for the variant part. Deal with + an extension of a type with unknown discriminants. + +2023-05-15 Claire Dross <dross@adacore.com> + + * libgnat/s-valueu.adb: Use cut operations inside assertion to + restore proofs + * gcc-interface/Make-lang.in (GNAT_ADA_OBJS): Add s-spark and + s-spcuop dependencies. + +2023-05-15 Yannick Moy <moy@adacore.com> + + * sem_prag.adb (Check_Grouping): Allow Annotate pragmas between + loop pragmas. + +2023-05-15 Javier Miranda <miranda@adacore.com> + + * doc/gnat_rm/implementation_defined_pragmas.rst + (Extensions_Allowed): Document string interpolation. + * gnat_rm.texi: Regenerate. + * gnat_ugn.texi: Regenerate. + +2023-05-15 Joel Brobecker <brobecker@adacore.com> + + * doc/gnat_ugn/platform_specific_information.rst + (_PIE_Enabled_By_Default_On_Linux): New section. + * gnat-style.texi: Regenerate. + * gnat_ugn.texi: Regenerate. + +2023-05-15 Javier Miranda <miranda@adacore.com> + + * exp_disp.adb + (Has_Dispatching_Constructor_Call): New subprogram. + (Expand_Interface_Conversion): No need to perform dynamic + interface conversion when the operand and the target type are + interface types and the target interface type is an ancestor of + the operand type. The unique exception to this rule is when the + operand has a dispatching constructor call (as documented in the + sources). + +2023-05-15 Piotr Trojanek <trojanek@adacore.com> + + * sem_attr.adb (Analyze_Attribute): Reject attribute Initialized + on unchecked unions; fix grammar in comment. + +2023-05-15 Ronan Desplanques <desplanques@adacore.com> + + * sem_ch13.adb (Validate_Unchecked_Conversion): Fix behavior on + System.Address to access to subprogram subtype conversion. + +2023-05-15 Piotr Trojanek <trojanek@adacore.com> + + * atree.ads + (Is_Syntactic_Node): Refactored from New_Copy_Tree. + * atree.adb + (Is_Syntactic_Node): Likewise. + (Copy_Separate_Tree): Use Is_Syntactic_Node. + * sem_util.adb + (Has_More_Ids): Move to Atree. + (Is_Syntactic_Node): Likewise. + +2023-04-18 Jin Ma <jinma@linux.alibaba.com> + + * gcc-interface/utils.cc (unchecked_convert): Fix typo. + +2023-04-17 Martin Liska <mliska@suse.cz> + + * gnatvsn.ads: Bump Library_Version to 14. + +2023-04-15 Eric Botcazou <ebotcazou@adacore.com> + + PR bootstrap/109510 + * gcc-interface/decl.cc (gnat_to_gnu_entity) <types>: Do not reset + align to zero in any case. Set TYPE_USER_ALIGN on the type only if + it is an aggregate type, or else a type whose default alignment is + specifically capped on selected platforms. + +2023-04-14 Eric Botcazou <ebotcazou@adacore.com> + + PR bootstrap/109510 + * gcc-interface/decl.cc (gnat_to_gnu_entity) <types>: Reset align + to zero if its value is equal to TYPE_ALIGN and the type is scalar. + Set TYPE_USER_ALIGN on the type only if align is positive. + 2023-03-06 Javier Miranda <miranda@adacore.com> PR ada/108858 diff --git a/gcc/ada/Make-generated.in b/gcc/ada/Make-generated.in index 948fc50..95c2a1d 100644 --- a/gcc/ada/Make-generated.in +++ b/gcc/ada/Make-generated.in @@ -46,7 +46,7 @@ ada/stamp-snames : ada/snames.ads-tmpl ada/snames.adb-tmpl ada/snames.h-tmpl ada -$(MKDIR) ada/bldtools/snamest $(RM) $(addprefix ada/bldtools/snamest/,$(notdir $^)) $(CP) $^ ada/bldtools/snamest - cd ada/bldtools/snamest; gnatmake -q xsnamest ; ./xsnamest + cd ada/bldtools/snamest && gnatmake -q xsnamest && ./xsnamest $(fsrcdir)/../move-if-change ada/bldtools/snamest/snames.ns ada/snames.ads $(fsrcdir)/../move-if-change ada/bldtools/snamest/snames.nb ada/snames.adb $(fsrcdir)/../move-if-change ada/bldtools/snamest/snames.nh ada/snames.h diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl index 96306f8..ca4c528 100644 --- a/gcc/ada/Makefile.rtl +++ b/gcc/ada/Makefile.rtl @@ -478,7 +478,6 @@ GNATRTL_NONTASKING_OBJS= \ g-speche$(objext) \ g-spipat$(objext) \ g-spitbo$(objext) \ - g-spogwa$(objext) \ g-sptabo$(objext) \ g-sptain$(objext) \ g-sptavs$(objext) \ @@ -856,7 +855,7 @@ GNATLIB_SHARED = gnatlib # to LIBGNAT_TARGET_PAIRS. GNATRTL_SOCKETS_OBJS = g-soccon$(objext) g-socket$(objext) g-socthi$(objext) \ - g-soliop$(objext) g-sothco$(objext) g-socpol$(objext) + g-soliop$(objext) g-sothco$(objext) g-socpol$(objext) g-spogwa$(objext) DUMMY_SOCKETS_TARGET_PAIRS = \ g-socket.adb<libgnat/g-socket__dummy.adb \ @@ -1412,6 +1411,7 @@ ifeq ($(strip $(filter-out arm aarch64 %qnx,$(target_cpu) $(target_os))),) s-taspri.ads<libgnarl/s-taspri__posix.ads \ s-tpopsp.adb<libgnarl/s-tpopsp__posix-foreign.adb \ g-soliop.ads<libgnat/g-soliop__qnx.ads \ + s-parame.adb<libgnat/s-parame__qnx.adb \ $(ATOMICS_TARGET_PAIRS) \ $(ATOMICS_BUILTINS_TARGET_PAIRS) \ system.ads<libgnat/system-qnx-arm.ads @@ -2185,6 +2185,7 @@ ifeq ($(strip $(filter-out powerpc% linux%,$(target_cpu) $(target_os))),) EXTRA_GNATRTL_NONTASKING_OBJS += $(GNATRTL_128BIT_OBJS) endif else + LIBGNAT_TARGET_PAIRS += s-atopri.ads<libgnat/s-atopri__32.ads ifeq ($(strip $(MULTISUBDIR)),/64) LIBGNAT_TARGET_PAIRS += $(GNATRTL_128BIT_PAIRS) EXTRA_GNATRTL_NONTASKING_OBJS += $(GNATRTL_128BIT_OBJS) @@ -2249,6 +2250,7 @@ ifeq ($(strip $(filter-out aarch64% linux%,$(target_cpu) $(target_os))),) s-intman.adb<libgnarl/s-intman__posix.adb \ s-linux.ads<libgnarl/s-linux.ads \ $(TRASYM_DWARF_UNIX_PAIRS) \ + s-tsmona.adb<libgnat/s-tsmona__linux.adb \ s-mudido.adb<libgnarl/s-mudido__affinity.adb \ s-osinte.ads<libgnarl/s-osinte__linux.ads \ s-osinte.adb<libgnarl/s-osinte__posix.adb \ @@ -2271,6 +2273,7 @@ ifeq ($(strip $(filter-out aarch64% linux%,$(target_cpu) $(target_os))),) EH_MECHANISM=-gcc THREADSLIB=-lpthread -lrt GNATLIB_SHARED=gnatlib-shared-dual + MISCLIB = -ldl GMEM_LIB = gmemlib LIBRARY_VERSION := $(LIB_VERSION) endif diff --git a/gcc/ada/accessibility.adb b/gcc/ada/accessibility.adb index c65c26d..bc897d1 100644 --- a/gcc/ada/accessibility.adb +++ b/gcc/ada/accessibility.adb @@ -1153,7 +1153,7 @@ package body Accessibility is -- Obtain the first selector or choice from a given association function Is_Formal_Of_Current_Function - (Assoc_Expr : Entity_Id) return Boolean; + (Assoc_Expr : Node_Id) return Boolean; -- Predicate to test if a given expression associated with a -- discriminant is a formal parameter to the function in which the -- return construct we checking applies to. @@ -1180,7 +1180,7 @@ package body Accessibility is ----------------------------------- function Is_Formal_Of_Current_Function - (Assoc_Expr : Entity_Id) return Boolean is + (Assoc_Expr : Node_Id) return Boolean is begin return Is_Entity_Name (Assoc_Expr) and then Enclosing_Subprogram diff --git a/gcc/ada/ada_get_targ.adb b/gcc/ada/ada_get_targ.adb index 6aadb77..5de9fc4 100644 --- a/gcc/ada/ada_get_targ.adb +++ b/gcc/ada/ada_get_targ.adb @@ -209,15 +209,6 @@ package body Get_Targ is end Get_Double_Scalar_Alignment; ----------------------------- - -- Get_Max_Unaligned_Field -- - ----------------------------- - - function Get_Max_Unaligned_Field return Pos is - begin - return 64; -- Can be different on some targets - end Get_Max_Unaligned_Field; - - ----------------------------- -- Register_Back_End_Types -- ----------------------------- diff --git a/gcc/ada/ali-util.adb b/gcc/ada/ali-util.adb index c0b8ad6..2bd5bca 100644 --- a/gcc/ada/ali-util.adb +++ b/gcc/ada/ali-util.adb @@ -447,7 +447,7 @@ package body ALI.Util is Stringt.Release; end if; - if (not Read_Only) or else Source.Table (Src).Source_Found then + if not Read_Only or else Source.Table (Src).Source_Found then if not Source.Table (Src).Source_Found or else Sdep.Table (D).Stamp /= Source.Table (Src).Stamp then diff --git a/gcc/ada/aspects.adb b/gcc/ada/aspects.adb index 0b2774f..c14769c 100644 --- a/gcc/ada/aspects.adb +++ b/gcc/ada/aspects.adb @@ -41,20 +41,20 @@ package body Aspects is -- type. False means it is not inherited. Base_Aspect : constant array (Aspect_Id) of Boolean := - (Aspect_Atomic => True, - Aspect_Atomic_Components => True, - Aspect_Constant_Indexing => True, - Aspect_Default_Iterator => True, - Aspect_Discard_Names => True, - Aspect_Independent_Components => True, - Aspect_Iterator_Element => True, - Aspect_Stable_Properties => True, - Aspect_Type_Invariant => True, - Aspect_Unchecked_Union => True, - Aspect_Variable_Indexing => True, - Aspect_Volatile => True, - Aspect_Volatile_Full_Access => True, - others => False); + (Aspect_Atomic => True, + Aspect_Atomic_Components => True, + Aspect_Constant_Indexing => True, + Aspect_Default_Iterator => True, + Aspect_Discard_Names => True, + Aspect_Independent_Components => True, + Aspect_Iterator_Element => True, + Aspect_Stable_Properties => True, + Aspect_Type_Invariant => True, + Aspect_Unchecked_Union => True, + Aspect_Variable_Indexing => True, + Aspect_Volatile => True, + Aspect_Volatile_Full_Access => True, + others => False); -- The following array indicates type aspects that are inherited and apply -- to the class-wide type as well. @@ -542,6 +542,7 @@ package body Aspects is -- ...except for these: Result (Aspect_Dynamic_Predicate) := Aspect_Predicate; + Result (Aspect_Ghost_Predicate) := Aspect_Predicate; Result (Aspect_Inline_Always) := Aspect_Inline; Result (Aspect_Interrupt_Priority) := Aspect_Priority; Result (Aspect_Postcondition) := Aspect_Post; diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads index 36957d4..0567797 100644 --- a/gcc/ada/aspects.ads +++ b/gcc/ada/aspects.ads @@ -72,6 +72,7 @@ package Aspects is Aspect_Address, Aspect_Aggregate, Aspect_Alignment, + Aspect_Always_Terminates, -- GNAT Aspect_Annotate, -- GNAT Aspect_Async_Readers, -- GNAT Aspect_Async_Writers, -- GNAT @@ -96,10 +97,12 @@ package Aspects is Aspect_Dynamic_Predicate, Aspect_Effective_Reads, -- GNAT Aspect_Effective_Writes, -- GNAT + Aspect_Exceptional_Cases, -- GNAT Aspect_Extensions_Visible, -- GNAT Aspect_External_Name, Aspect_External_Tag, Aspect_Ghost, -- GNAT + Aspect_Ghost_Predicate, -- GNAT Aspect_Global, -- GNAT Aspect_GNAT_Annotate, -- GNAT Aspect_Implicit_Dereference, @@ -259,6 +262,7 @@ package Aspects is Implementation_Defined_Aspect : constant array (Aspect_Id) of Boolean := (Aspect_Abstract_State => True, + Aspect_Always_Terminates => True, Aspect_Annotate => True, Aspect_Async_Readers => True, Aspect_Async_Writers => True, @@ -269,9 +273,11 @@ package Aspects is Aspect_Dimension_System => True, Aspect_Effective_Reads => True, Aspect_Effective_Writes => True, + Aspect_Exceptional_Cases => True, Aspect_Extensions_Visible => True, Aspect_Favor_Top_Level => True, Aspect_Ghost => True, + Aspect_Ghost_Predicate => True, Aspect_Global => True, Aspect_GNAT_Annotate => True, Aspect_Inline_Always => True, @@ -291,6 +297,7 @@ package Aspects is Aspect_Shared => True, Aspect_Simple_Storage_Pool => True, Aspect_Simple_Storage_Pool_Type => True, + Aspect_Subprogram_Variant => True, Aspect_Suppress_Debug_Info => True, Aspect_Suppress_Initialization => True, Aspect_Thread_Local_Storage => True, @@ -365,6 +372,7 @@ package Aspects is Aspect_Address => Expression, Aspect_Aggregate => Expression, Aspect_Alignment => Expression, + Aspect_Always_Terminates => Optional_Expression, Aspect_Annotate => Expression, Aspect_Async_Readers => Optional_Expression, Aspect_Async_Writers => Optional_Expression, @@ -389,10 +397,12 @@ package Aspects is Aspect_Dynamic_Predicate => Expression, Aspect_Effective_Reads => Optional_Expression, Aspect_Effective_Writes => Optional_Expression, + Aspect_Exceptional_Cases => Expression, Aspect_Extensions_Visible => Optional_Expression, Aspect_External_Name => Expression, Aspect_External_Tag => Expression, Aspect_Ghost => Optional_Expression, + Aspect_Ghost_Predicate => Expression, Aspect_Global => Expression, Aspect_GNAT_Annotate => Expression, Aspect_Implicit_Dereference => Name, @@ -470,6 +480,7 @@ package Aspects is Aspect_Address => True, Aspect_Aggregate => False, Aspect_Alignment => True, + Aspect_Always_Terminates => False, Aspect_Annotate => False, Aspect_Async_Readers => False, Aspect_Async_Writers => False, @@ -496,13 +507,15 @@ package Aspects is Aspect_Dynamic_Predicate => False, Aspect_Effective_Reads => False, Aspect_Effective_Writes => False, + Aspect_Exceptional_Cases => False, Aspect_Exclusive_Functions => False, Aspect_Extensions_Visible => False, Aspect_External_Name => False, Aspect_External_Tag => False, Aspect_Ghost => False, + Aspect_Ghost_Predicate => False, Aspect_Global => False, - Aspect_GNAT_Annotate => False, + Aspect_GNAT_Annotate => False, Aspect_Implicit_Dereference => False, Aspect_Initial_Condition => False, Aspect_Initializes => False, @@ -621,6 +634,7 @@ package Aspects is Aspect_Aggregate => Name_Aggregate, Aspect_Alignment => Name_Alignment, Aspect_All_Calls_Remote => Name_All_Calls_Remote, + Aspect_Always_Terminates => Name_Always_Terminates, Aspect_Annotate => Name_Annotate, Aspect_Async_Readers => Name_Async_Readers, Aspect_Async_Writers => Name_Async_Writers, @@ -653,6 +667,7 @@ package Aspects is Aspect_Effective_Reads => Name_Effective_Reads, Aspect_Effective_Writes => Name_Effective_Writes, Aspect_Elaborate_Body => Name_Elaborate_Body, + Aspect_Exceptional_Cases => Name_Exceptional_Cases, Aspect_Exclusive_Functions => Name_Exclusive_Functions, Aspect_Export => Name_Export, Aspect_Extensions_Visible => Name_Extensions_Visible, @@ -661,6 +676,7 @@ package Aspects is Aspect_Favor_Top_Level => Name_Favor_Top_Level, Aspect_Full_Access_Only => Name_Full_Access_Only, Aspect_Ghost => Name_Ghost, + Aspect_Ghost_Predicate => Name_Ghost_Predicate, Aspect_Global => Name_Global, Aspect_GNAT_Annotate => Name_GNAT_Annotate, Aspect_Implicit_Dereference => Name_Implicit_Dereference, @@ -906,6 +922,7 @@ package Aspects is Aspect_External_Name => Always_Delay, Aspect_External_Tag => Always_Delay, Aspect_Favor_Top_Level => Always_Delay, + Aspect_Ghost_Predicate => Always_Delay, Aspect_Implicit_Dereference => Always_Delay, Aspect_Independent => Always_Delay, Aspect_Independent_Components => Always_Delay, @@ -968,6 +985,7 @@ package Aspects is Aspect_Write => Always_Delay, Aspect_Abstract_State => Never_Delay, + Aspect_Always_Terminates => Never_Delay, Aspect_Annotate => Never_Delay, Aspect_Async_Readers => Never_Delay, Aspect_Async_Writers => Never_Delay, @@ -981,6 +999,7 @@ package Aspects is Aspect_Disable_Controlled => Never_Delay, Aspect_Effective_Reads => Never_Delay, Aspect_Effective_Writes => Never_Delay, + Aspect_Exceptional_Cases => Never_Delay, Aspect_Export => Never_Delay, Aspect_Extensions_Visible => Never_Delay, Aspect_Ghost => Never_Delay, diff --git a/gcc/ada/atree.adb b/gcc/ada/atree.adb index 6ad8b5d..f1e4e2c 100644 --- a/gcc/ada/atree.adb +++ b/gcc/ada/atree.adb @@ -25,10 +25,10 @@ with Ada.Unchecked_Conversion; with Aspects; use Aspects; -with Debug; use Debug; with Namet; use Namet; with Nlists; use Nlists; with Opt; use Opt; +with Osint; with Output; use Output; with Sinfo.Utils; use Sinfo.Utils; with System.Storage_Elements; @@ -948,11 +948,10 @@ package body Atree is procedure Check_Vanishing_Fields (Old_N : Node_Id; New_Kind : Node_Kind) is - Old_Kind : constant Node_Kind := Nkind (Old_N); - - -- If this fails, it means you need to call Reinit_Field_To_Zero before - -- calling Mutate_Nkind. + -- If this fails, see comments in the spec of Mutate_Nkind and in + -- Check_Vanishing_Fields for entities below. + Old_Kind : constant Node_Kind := Nkind (Old_N); begin for J in Node_Field_Table (Old_Kind)'Range loop declare @@ -979,42 +978,76 @@ package body Atree is procedure Check_Vanishing_Fields (Old_N : Entity_Id; New_Kind : Entity_Kind) is + -- If this fails, it means Mutate_Ekind is changing the Ekind from + -- Old_Kind to New_Kind, such that some field F exists in Old_Kind but + -- not in New_Kind, and F contains non-default information. The usual + -- solution is to call Reinit_Field_To_Zero before calling Mutate_Ekind. + -- Another solution is to change Gen_IL so that the new field DOES exist + -- in New_Kind. See also comments in the spec of Mutate_Ekind. + Old_Kind : constant Entity_Kind := Ekind (Old_N); - -- If this fails, it means you need to call Reinit_Field_To_Zero before - -- calling Mutate_Ekind. But we have many cases where vanishing fields - -- are expected to reappear after converting to/from E_Void. Other cases - -- are more problematic; set a breakpoint on "(non-E_Void case)" below. + function Same_Node_To_Fetch_From + (N : Node_Or_Entity_Id; Field : Node_Or_Entity_Field) + return Boolean; + -- True if the field should be fetched from N. For most fields, this is + -- true. However, if the field is a "root type only" field, then this is + -- true only if N is the root type. If this is false, then we should not + -- do Reinit_Field_To_Zero, and we should not fail below, because the + -- field is not vanishing from the root type. Similar comments apply to + -- "base type only" and "implementation base type only" fields. + -- + -- We need to ignore exceptions here, because in some cases, + -- Node_To_Fetch_From is being called before the relevant (root, base) + -- type has been set, so we fail some assertions. + + function Same_Node_To_Fetch_From + (N : Node_Or_Entity_Id; Field : Node_Or_Entity_Field) + return Boolean is + begin + return N = Node_To_Fetch_From (N, Field); + exception + when others => return False; -- ignore the exception + end Same_Node_To_Fetch_From; + + -- Start of processing for Check_Vanishing_Fields begin for J in Entity_Field_Table (Old_Kind)'Range loop declare F : constant Entity_Field := Entity_Field_Table (Old_Kind) (J); begin - if not Field_Checking.Field_Present (New_Kind, F) then + if not Same_Node_To_Fetch_From (Old_N, F) then + null; -- no check in this case + elsif not Field_Checking.Field_Present (New_Kind, F) then if not Field_Is_Initial_Zero (Old_N, F) then + Write_Str ("# "); + Write_Str (Osint.Get_First_Main_File_Name); + Write_Str (": "); Write_Str (Old_Kind'Img); Write_Str (" --> "); Write_Str (New_Kind'Img); Write_Str (" Nonzero field "); Write_Str (F'Img); - Write_Str (" is vanishing for node "); - Write_Int (Nat (Old_N)); - Write_Eol; + Write_Str (" is vanishing "); if New_Kind = E_Void or else Old_Kind = E_Void then - Write_Line (" (E_Void case)"); + Write_Line ("(E_Void case)"); else - Write_Line (" (non-E_Void case)"); + Write_Line ("(non-E_Void case)"); end if; + + Write_Str (" ...mutating node "); + Write_Int (Nat (Old_N)); + Write_Line (""); + raise Program_Error; end if; end if; end; end loop; end Check_Vanishing_Fields; - Nkind_Offset : constant Field_Offset := - Field_Descriptors (F_Nkind).Offset; + Nkind_Offset : constant Field_Offset := Field_Descriptors (F_Nkind).Offset; procedure Set_Node_Kind_Type is new Set_8_Bit_Field (Node_Kind) with Inline; @@ -1036,6 +1069,8 @@ package body Atree is All_Node_Offsets : Node_Offsets.Table_Type renames Node_Offsets.Table (Node_Offsets.First .. Node_Offsets.Last); begin + pragma Assert (Nkind (N) /= Val); + pragma Debug (Check_Vanishing_Fields (N, Val)); -- Grow the slots if necessary @@ -1082,29 +1117,25 @@ package body Atree is Mutate_Nkind (N, Val, Old_Size => Size_In_Slots_Dynamic (N)); end Mutate_Nkind; - Ekind_Offset : constant Field_Offset := - Field_Descriptors (F_Ekind).Offset; + Ekind_Offset : constant Field_Offset := Field_Descriptors (F_Ekind).Offset; procedure Set_Entity_Kind_Type is new Set_8_Bit_Field (Entity_Kind) with Inline; - procedure Mutate_Ekind - (N : Entity_Id; Val : Entity_Kind) - is + procedure Mutate_Ekind (N : Entity_Id; Val : Entity_Kind) is begin if Ekind (N) = Val then return; end if; - if Debug_Flag_Underscore_V then - pragma Debug (Check_Vanishing_Fields (N, Val)); - end if; + pragma Assert (Val /= E_Void); + pragma Debug (Check_Vanishing_Fields (N, Val)); -- For now, we are allocating all entities with the same size, so we -- don't need to reallocate slots here. if Atree_Statistics_Enabled then - Set_Count (F_Nkind) := Set_Count (F_Ekind) + 1; + Set_Count (F_Ekind) := Set_Count (F_Ekind) + 1; end if; Set_Entity_Kind_Type (N, Ekind_Offset, Val); @@ -1353,12 +1384,7 @@ package body Atree is E := First (List); while Present (E) loop - if Is_Entity (E) then - Append (Copy_Entity (E), NL); - else - Append (Copy_Separate_Tree (E), NL); - end if; - + Append (Copy_Separate_Tree (E), NL); Next (E); end loop; @@ -1378,7 +1404,7 @@ package body Atree is New_N := Union_Id (Copy_Separate_Tree (Node_Id (Field))); if Present (Node_Id (Field)) - and then Parent (Node_Id (Field)) = Source + and then Is_Syntactic_Node (Source, Node_Id (Field)) then Set_Parent (Node_Id (New_N), New_Id); end if; @@ -1619,6 +1645,66 @@ package body Atree is return Nkind (N) in N_Entity; end Is_Entity; + ----------------------- + -- Is_Syntactic_Node -- + ----------------------- + + function Is_Syntactic_Node + (Source : Node_Id; + Field : Node_Id) + return Boolean + is + function Has_More_Ids (N : Node_Id) return Boolean; + -- Return True when N has attribute More_Ids set to True + + ------------------ + -- Has_More_Ids -- + ------------------ + + function Has_More_Ids (N : Node_Id) return Boolean is + begin + if Nkind (N) in N_Component_Declaration + | N_Discriminant_Specification + | N_Exception_Declaration + | N_Formal_Object_Declaration + | N_Number_Declaration + | N_Object_Declaration + | N_Parameter_Specification + | N_Use_Package_Clause + | N_Use_Type_Clause + then + return More_Ids (N); + else + return False; + end if; + end Has_More_Ids; + + -- Start of processing for Is_Syntactic_Node + + begin + if Parent (Field) = Source then + return True; + + -- Perform the check using the last id in the syntactic chain + + elsif Has_More_Ids (Source) then + declare + N : Node_Id := Source; + + begin + while Present (N) and then More_Ids (N) loop + Next (N); + end loop; + + pragma Assert (Prev_Ids (N)); + return Parent (Field) = N; + end; + + else + return False; + end if; + end Is_Syntactic_Node; + ---------------- -- Initialize -- ---------------- diff --git a/gcc/ada/atree.ads b/gcc/ada/atree.ads index eb1ff90..abe5cc5 100644 --- a/gcc/ada/atree.ads +++ b/gcc/ada/atree.ads @@ -225,6 +225,14 @@ package Atree is pragma Inline (Is_Entity); -- Returns True if N is an entity + function Is_Syntactic_Node + (Source : Node_Id; + Field : Node_Id) + return Boolean; + -- Return True when Field is a syntactic child of node Source. It is called + -- when creating a copy of Source to preserve the Parent link in the copy + -- of Field. + function New_Node (New_Node_Kind : Node_Kind; New_Sloc : Source_Ptr) return Node_Id; @@ -253,8 +261,7 @@ package Atree is function New_Entity (New_Node_Kind : Node_Kind; New_Sloc : Source_Ptr) return Entity_Id; - -- Similar to New_Node, except that it is used only for entity nodes - -- and returns an extended node. + -- Similar to New_Node, except that it is used only for entity nodes. procedure Set_Comes_From_Source_Default (Default : Boolean); -- Sets value of Comes_From_Source flag to be used in all subsequent @@ -630,16 +637,15 @@ package Atree is -- Mutate_Nkind. This is necessary, because the memory occupied by the -- vanishing fields might be used for totally unrelated fields in the new -- node. See Reinit_Field_To_Zero. + -- + -- It is an error to mutate a node to the same kind it already has. - procedure Mutate_Ekind - (N : Entity_Id; Val : Entity_Kind) with Inline; + procedure Mutate_Ekind (N : Entity_Id; Val : Entity_Kind) with Inline; -- Ekind is also like a discriminant, and is mostly treated as above (see - -- Mutate_Nkind). However, there are a few cases where we set the Ekind - -- from its initial E_Void value to something else, then set it back to - -- E_Void, then back to the something else, and we expect the "something - -- else" fields to retain their value. The two "something else"s are not - -- always the same; for example we change from E_Void, to E_Variable, to - -- E_Void, to E_Constant. + -- Mutate_Nkind). + -- + -- It is not (yet?) an error to mutate an entity to the same kind it + -- already has. It is an error to mutate to E_Void. function Node_To_Fetch_From (N : Node_Or_Entity_Id; Field : Node_Or_Entity_Field) diff --git a/gcc/ada/back_end.adb b/gcc/ada/back_end.adb index 23f5abe..bc370e9 100644 --- a/gcc/ada/back_end.adb +++ b/gcc/ada/back_end.adb @@ -103,11 +103,12 @@ package body Back_End is number_file : Nat; file_info_ptr : Address; + gigi_standard_address : Entity_Id; gigi_standard_boolean : Entity_Id; - gigi_standard_integer : Entity_Id; gigi_standard_character : Entity_Id; - gigi_standard_long_long_float : Entity_Id; gigi_standard_exception_type : Entity_Id; + gigi_standard_integer : Entity_Id; + gigi_standard_long_long_float : Entity_Id; gigi_operating_mode : Back_End_Mode_Type); pragma Import (C, gigi); @@ -171,11 +172,12 @@ package body Back_End is number_file => Num_Source_Files, file_info_ptr => File_Info_Array'Address, + gigi_standard_address => Standard_Address, gigi_standard_boolean => Standard_Boolean, - gigi_standard_integer => Standard_Integer, gigi_standard_character => Standard_Character, - gigi_standard_long_long_float => Standard_Long_Long_Float, gigi_standard_exception_type => Standard_Exception_Type, + gigi_standard_integer => Standard_Integer, + gigi_standard_long_long_float => Standard_Long_Long_Float, gigi_operating_mode => Mode); end Call_Back_End; diff --git a/gcc/ada/bcheck.adb b/gcc/ada/bcheck.adb index f09de1b..86ed920 100644 --- a/gcc/ada/bcheck.adb +++ b/gcc/ada/bcheck.adb @@ -223,7 +223,7 @@ package body Bcheck is end if; end if; - if (not Tolerate_Consistency_Errors) and Verbose_Mode then + if not Tolerate_Consistency_Errors and Verbose_Mode then Error_Msg_File_1 := Source.Table (Src).Stamp_File; if Source.Table (Src).Source_Found then @@ -1402,7 +1402,7 @@ package body Bcheck is Secondary := 0; end if; - if (Primary /= -1) and (Secondary /= -1) then + if Primary /= -1 and Secondary /= -1 then return (Primary => Primary, Secondary => Secondary); end if; @@ -1421,7 +1421,7 @@ package body Bcheck is V2 : constant ALI_Version := Extract_Version (V2_Text); Include_Version_Numbers_In_Message : constant Boolean := - (V1 /= V2) and (V1 /= No_Version) and (V2 /= No_Version); + V1 /= V2 and V1 /= No_Version and V2 /= No_Version; begin Error_Msg_File_1 := ALIs.Table (A).Sfile; Error_Msg_File_2 := ALIs.Table (ALIs.First).Sfile; diff --git a/gcc/ada/binde.adb b/gcc/ada/binde.adb index 101213c..fe262c0 100644 --- a/gcc/ada/binde.adb +++ b/gcc/ada/binde.adb @@ -1937,7 +1937,7 @@ package body Binde is Units.Table (U).Last_With loop if Withs.Table (W).Sfile /= No_File - and then (not Withs.Table (W).SAL_Interface) + and then not Withs.Table (W).SAL_Interface then -- Check for special case of withing a unit that does not -- exist any more. If the unit was completely missing we @@ -2793,7 +2793,7 @@ package body Binde is Units.Table (U).Last_With loop if Withs.Table (W).Sfile /= No_File - and then (not Withs.Table (W).SAL_Interface) + and then not Withs.Table (W).SAL_Interface then -- Check for special case of withing a unit that does not -- exist any more. diff --git a/gcc/ada/binderr.adb b/gcc/ada/binderr.adb index 765482c..5fb32c6 100644 --- a/gcc/ada/binderr.adb +++ b/gcc/ada/binderr.adb @@ -50,7 +50,7 @@ package body Binderr is Errors_Detected := Errors_Detected + 1; end if; - if Brief_Output or else (not Verbose_Mode) then + if Brief_Output or else not Verbose_Mode then Set_Standard_Error; Error_Msg_Output (Msg, Info => False); Set_Standard_Output; @@ -90,7 +90,7 @@ package body Binderr is procedure Error_Msg_Info (Msg : String) is begin - if Brief_Output or else (not Verbose_Mode) then + if Brief_Output or else not Verbose_Mode then Set_Standard_Error; Error_Msg_Output (Msg, Info => True); Set_Standard_Output; diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index e21f306..6525982 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -1810,9 +1810,9 @@ package body Checks is Determine_Range (Left, LOK, Llo, Lhi, Assume_Valid => True); LLB := Expr_Value (Type_Low_Bound (Base_Type (Typ))); - if ((not ROK) or else (Rlo <= (-1) and then (-1) <= Rhi)) + if (not ROK or else (Rlo <= (-1) and then (-1) <= Rhi)) and then - ((not LOK) or else (Llo = LLB)) + (not LOK or else Llo = LLB) then -- Ensure that expressions are not evaluated twice (once -- for their runtime checks and once for their regular @@ -1872,7 +1872,7 @@ package body Checks is then Set_Do_Division_Check (N, False); - if (not ROK) or else (Rlo <= 0 and then 0 <= Rhi) then + if not ROK or else (Rlo <= 0 and then 0 <= Rhi) then if Is_Floating_Point_Type (Etype (N)) then Opnd := Make_Real_Literal (Loc, Ureal_0); else @@ -2727,7 +2727,7 @@ package body Checks is Par : Node_Id; S : Entity_Id; - Check_Disabled : constant Boolean := (not Predicate_Enabled (Typ)) + Check_Disabled : constant Boolean := not Predicate_Enabled (Typ) or else not Predicate_Check_In_Scope (N); begin S := Current_Scope; @@ -3501,7 +3501,7 @@ package body Checks is -- for the subscript, and that convert will do the necessary validity -- check. - if (No_Check_Needed = Empty_Dimension_Set) + if No_Check_Needed = Empty_Dimension_Set or else not No_Check_Needed.Elements (Dimension) then Ensure_Valid (Sub, Holes_OK => True); @@ -8437,7 +8437,18 @@ package body Checks is Right_Opnd => Make_Null (Loc)), Reason => CE_Access_Check_Failed)); - Mark_Non_Null; + -- Mark the entity of N "non-null" except when assertions are enabled - + -- since expansion becomes much more complicated (especially when it + -- comes to contracts) due to the generation of wrappers and wholesale + -- moving of declarations and statements which may happen. + + -- Additionally, it is assumed that extra checks will exist with + -- assertions enabled so some potentially redundant checks are + -- acceptable. + + if not Assertions_Enabled then + Mark_Non_Null; + end if; end Install_Null_Excluding_Check; ----------------------------------------- @@ -10815,6 +10826,8 @@ package body Checks is if not Check_Added and then Is_Fixed_Lower_Bound_Index_Subtype (T_Typ) + and then Known_LB + and then Known_T_LB and then Expr_Value (LB) /= Expr_Value (T_LB) then Add_Check diff --git a/gcc/ada/clean.adb b/gcc/ada/clean.adb index fe0bda4..993e311 100644 --- a/gcc/ada/clean.adb +++ b/gcc/ada/clean.adb @@ -554,7 +554,7 @@ package body Clean is -- In verbose mode, if Delete has not been called, indicate that no file -- needs to be deleted. - if Verbose_Mode and (not File_Deleted) then + if Verbose_Mode and not File_Deleted then New_Line; if Do_Nothing then diff --git a/gcc/ada/comperr.adb b/gcc/ada/comperr.adb index 4fc0e5d..c52db7b 100644 --- a/gcc/ada/comperr.adb +++ b/gcc/ada/comperr.adb @@ -177,10 +177,8 @@ package body Comperr is -- Output target name, deleting junk final reverse slash - if Target_Name.all (Target_Name.all'Last) = '\' - or else Target_Name.all (Target_Name.all'Last) = '/' - then - Write_Str (Target_Name.all (1 .. Target_Name.all'Last - 1)); + if Target_Name (Target_Name'Last) in '/' | '\' then + Write_Str (Target_Name (1 .. Target_Name'Last - 1)); else Write_Str (Target_Name.all); end if; diff --git a/gcc/ada/contracts.adb b/gcc/ada/contracts.adb index b0a0ab20..77578da 100644 --- a/gcc/ada/contracts.adb +++ b/gcc/ada/contracts.adb @@ -62,6 +62,11 @@ with Warnsw; use Warnsw; package body Contracts is + Contract_Error : exception; + -- This exception is raised by Add_Contract_Item when it is invoked on an + -- invalid pragma. Note that clients of the package must filter them out + -- before invoking Add_Contract_Item, so it should not escape the package. + procedure Analyze_Package_Instantiation_Contract (Inst_Id : Entity_Id); -- Analyze all delayed pragmas chained on the contract of package -- instantiation Inst_Id as if they appear at the end of a declarative @@ -104,8 +109,9 @@ package body Contracts is procedure Expand_Subprogram_Contract (Body_Id : Entity_Id); -- Expand the contracts of a subprogram body and its correspoding spec (if -- any). This routine processes all [refined] pre- and postconditions as - -- well as Contract_Cases, Subprogram_Variant, invariants and predicates. - -- Body_Id denotes the entity of the subprogram body. + -- well as Always_Terminates, Contract_Cases, Exceptional_Cases, + -- Subprogram_Variant, invariants and predicates. Body_Id denotes the + -- entity of the subprogram body. procedure Preanalyze_Condition (Subp : Entity_Id; @@ -197,7 +203,7 @@ package body Contracts is -- The pragma is not a proper contract item else - raise Program_Error; + raise Contract_Error; end if; -- Entry bodies, the applicable pragmas are: @@ -215,18 +221,21 @@ package body Contracts is -- The pragma is not a proper contract item else - raise Program_Error; + raise Contract_Error; end if; -- Entry or subprogram declarations, the applicable pragmas are: + -- Always_Terminates -- Attach_Handler -- Contract_Cases -- Depends + -- Exceptional_Cases -- Extensions_Visible -- Global -- Interrupt_Handler -- Postcondition -- Precondition + -- Subprogram_Variant -- Test_Case -- Volatile_Function @@ -252,7 +261,9 @@ package body Contracts is then Add_Classification; - elsif Prag_Nam in Name_Contract_Cases + elsif Prag_Nam in Name_Always_Terminates + | Name_Contract_Cases + | Name_Exceptional_Cases | Name_Subprogram_Variant | Name_Test_Case then @@ -264,7 +275,7 @@ package body Contracts is -- The pragma is not a proper contract item else - raise Program_Error; + raise Contract_Error; end if; -- Packages or instantiations, the applicable pragmas are: @@ -285,10 +296,13 @@ package body Contracts is elsif Prag_Nam = Name_Part_Of and then Is_Generic_Instance (Id) then Add_Classification; + elsif Prag_Nam = Name_Always_Terminates then + Add_Contract_Test_Case; + -- The pragma is not a proper contract item else - raise Program_Error; + raise Contract_Error; end if; -- Package bodies, the applicable pragmas are: @@ -301,16 +315,19 @@ package body Contracts is -- The pragma is not a proper contract item else - raise Program_Error; + raise Contract_Error; end if; -- The four volatility refinement pragmas are ok for all types. -- Part_Of is ok for task types and protected types. -- Depends and Global are ok for task types. + -- + -- Precondition and Postcondition are added separately; they are allowed + -- for access-to-subprogram types. elsif Is_Type (Id) then declare - Is_OK : constant Boolean := + Is_OK_Classification : constant Boolean := Prag_Nam in Name_Async_Readers | Name_Async_Writers | Name_Effective_Reads @@ -322,14 +339,21 @@ package body Contracts is | Name_Global) or else (Ekind (Id) = E_Protected_Type and Prag_Nam = Name_Part_Of); + begin - if Is_OK then + if Is_OK_Classification then Add_Classification; + + elsif Ekind (Id) = E_Subprogram_Type + and then Prag_Nam in Name_Precondition + | Name_Postcondition + then + Add_Pre_Post_Condition; else -- The pragma is not a proper contract item - raise Program_Error; + raise Contract_Error; end if; end; @@ -353,7 +377,7 @@ package body Contracts is -- The pragma is not a proper contract item else - raise Program_Error; + raise Contract_Error; end if; -- Task bodies, the applicable pragmas are: @@ -367,7 +391,7 @@ package body Contracts is -- The pragma is not a proper contract item else - raise Program_Error; + raise Contract_Error; end if; -- Task units, the applicable pragmas are: @@ -402,11 +426,11 @@ package body Contracts is -- The pragma is not a proper contract item else - raise Program_Error; + raise Contract_Error; end if; else - raise Program_Error; + raise Contract_Error; end if; end Add_Contract_Item; @@ -584,6 +608,22 @@ package body Contracts is else Set_Analyzed (Items); end if; + + -- When this is a subprogram body not coming from source, for example an + -- expression function, it does not cause freezing of previous contracts + -- (see Analyze_Subprogram_Body_Helper), in particular not of those on + -- its spec if it exists. In this case make sure they have been properly + -- analyzed before being expanded below, as we may be invoked during the + -- freezing of the subprogram in the middle of its enclosing declarative + -- part because the declarative part contains e.g. the declaration of a + -- variable initialized by means of a call to the subprogram. + + elsif Nkind (Body_Decl) = N_Subprogram_Body + and then not Comes_From_Source (Original_Node (Body_Decl)) + and then Present (Corresponding_Spec (Body_Decl)) + and then Present (Contract (Corresponding_Spec (Body_Decl))) + then + Analyze_Entry_Or_Subprogram_Contract (Corresponding_Spec (Body_Decl)); end if; -- Due to the timing of contract analysis, delayed pragmas may be @@ -628,9 +668,10 @@ package body Contracts is Gen_Id => Spec_Id); end if; - -- Deal with preconditions, [refined] postconditions, Contract_Cases, - -- Subprogram_Variant, invariants and predicates associated with body - -- and its spec. Do not expand the contract of subprogram body stubs. + -- Deal with preconditions, [refined] postconditions, Always_Terminates, + -- Contract_Cases, Exceptional_Cases, Subprogram_Variant, invariants and + -- predicates associated with body and its spec. Do not expand the + -- contract of subprogram body stubs. if Nkind (Body_Decl) = N_Subprogram_Body then Expand_Subprogram_Contract (Body_Id); @@ -650,7 +691,10 @@ package body Contracts is Freeze_Id : Entity_Id := Empty) is Items : constant Node_Id := Contract (Subp_Id); - Subp_Decl : constant Node_Id := Unit_Declaration_Node (Subp_Id); + Subp_Decl : constant Node_Id := + (if Ekind (Subp_Id) = E_Subprogram_Type + then Associated_Node_For_Itype (Subp_Id) + else Unit_Declaration_Node (Subp_Id)); Saved_SM : constant SPARK_Mode_Type := SPARK_Mode; Saved_SMP : constant Node_Id := SPARK_Mode_Pragma; @@ -750,7 +794,10 @@ package body Contracts is while Present (Prag) loop Prag_Nam := Pragma_Name (Prag); - if Prag_Nam = Name_Contract_Cases then + if Prag_Nam = Name_Always_Terminates then + Analyze_Always_Terminates_In_Decl_Part (Prag); + + elsif Prag_Nam = Name_Contract_Cases then -- Do not analyze the contract cases of an entry declaration -- unless annotating the original tree for GNATprove. @@ -766,6 +813,9 @@ package body Contracts is Analyze_Contract_Cases_In_Decl_Part (Prag, Freeze_Id); end if; + elsif Prag_Nam = Name_Exceptional_Cases then + Analyze_Exceptional_Cases_In_Decl_Part (Prag); + elsif Prag_Nam = Name_Subprogram_Variant then Analyze_Subprogram_Variant_In_Decl_Part (Prag); @@ -990,11 +1040,12 @@ package body Contracts is -- appear at the library level (SPARK RM 7.1.3(3), C.6(6)). if not Is_Library_Level_Entity (Type_Or_Obj_Id) then + Error_Msg_Code := GEC_Volatile_At_Library_Level; Error_Msg_N ("effectively volatile " & Decl_Kind - & " & must be declared at library level " - & "(SPARK RM 7.1.3(3))", Type_Or_Obj_Id); + & " & must be declared at library level '[[]']", + Type_Or_Obj_Id); -- An object of a discriminated type cannot be effectively -- volatile except for protected objects (SPARK RM 7.1.3(5)). @@ -1491,8 +1542,10 @@ package body Contracts is Analyze_Entry_Or_Subprogram_Body_Contract (Stub_Id); -- The stub acts as its own spec, the applicable pragmas are: + -- Always_Terminates -- Contract_Cases -- Depends + -- Exceptional_Cases -- Global -- Postcondition -- Precondition @@ -1571,6 +1624,13 @@ package body Contracts is begin Check_Type_Or_Object_External_Properties (Type_Or_Obj_Id => Type_Id); + + -- Analyze Pre/Post on access-to-subprogram type + + if Ekind (Type_Id) in Access_Subprogram_Kind then + Analyze_Entry_Or_Subprogram_Contract + (Directly_Designated_Type (Type_Id)); + end if; end Analyze_Type_Contract; --------------------------------------- @@ -1631,7 +1691,7 @@ package body Contracts is -- return -- Result_Obj : constant Typ := _Wrapped_Statements -- do - -- <postconditions statments> + -- <postconditions statements> -- end return; -- end; @@ -1649,7 +1709,7 @@ package body Contracts is -- -- begin -- _Wrapped_Statements; - -- <postconditions statments> + -- <postconditions statements> -- end; -- Create Identifier @@ -2180,6 +2240,12 @@ package body Contracts is else Add_Contract_Item (Prag, Templ_Id); end if; + + exception + -- We do not stop the compilation at this point in the case of an + -- invalid pragma because it will be properly diagnosed afterward. + + when Contract_Error => null; end Add_Generic_Contract_Pragma; -- Local variables @@ -2823,13 +2889,19 @@ package body Contracts is Prag := Contract_Test_Cases (Items); while Present (Prag) loop if Is_Checked (Prag) then - if Pragma_Name (Prag) = Name_Contract_Cases then + if Pragma_Name (Prag) = Name_Always_Terminates then + Expand_Pragma_Always_Terminates (Prag); + + elsif Pragma_Name (Prag) = Name_Contract_Cases then Expand_Pragma_Contract_Cases (CCs => Prag, Subp_Id => Subp_Id, Decls => Decls, Stmts => Stmts); + elsif Pragma_Name (Prag) = Name_Exceptional_Cases then + Expand_Pragma_Exceptional_Cases (Prag); + elsif Pragma_Name (Prag) = Name_Subprogram_Variant then Expand_Pragma_Subprogram_Variant (Prag => Prag, @@ -4818,9 +4890,6 @@ package body Contracts is -- Traverse Expr and clear the Controlling_Argument of calls to -- nonabstract functions. - procedure Remove_Formals (Id : Entity_Id); - -- Remove formals from homonym chains and make them not visible - procedure Restore_Original_Selected_Component; -- Traverse Expr searching for dispatching calls to functions whose -- original node was a selected component, and replace them with @@ -4870,21 +4939,6 @@ package body Contracts is Remove_Ctrl_Args (Expr); end Remove_Controlling_Arguments; - -------------------- - -- Remove_Formals -- - -------------------- - - procedure Remove_Formals (Id : Entity_Id) is - F : Entity_Id := First_Formal (Id); - - begin - while Present (F) loop - Set_Is_Immediately_Visible (F, False); - Remove_Homonym (F); - Next_Formal (F); - end loop; - end Remove_Formals; - ----------------------------------------- -- Restore_Original_Selected_Component -- ----------------------------------------- @@ -4926,8 +4980,11 @@ package body Contracts is begin if Par /= Parent_Node then - pragma Assert (not Is_List_Member (Node)); - Set_Parent (Node, Parent_Node); + if Is_List_Member (Node) then + Set_List_Parent (List_Containing (Node), Parent_Node); + else + Set_Parent (Node, Parent_Node); + end if; end if; return OK; @@ -5003,8 +5060,7 @@ package body Contracts is Preanalyze_Spec_Expression (Expr, Standard_Boolean); Inside_Class_Condition_Preanalysis := False; - Remove_Formals (Subp); - Pop_Scope; + End_Scope; -- If this preanalyzed condition has occurrences of dispatching calls -- using the Object.Operation notation, during preanalysis such calls diff --git a/gcc/ada/contracts.ads b/gcc/ada/contracts.ads index 0a03d19..c3dc5d6 100644 --- a/gcc/ada/contracts.ads +++ b/gcc/ada/contracts.ads @@ -37,6 +37,7 @@ package Contracts is -- The following are valid pragmas: -- -- Abstract_State + -- Always_Terminates -- Async_Readers -- Async_Writers -- Attach_Handler @@ -45,6 +46,7 @@ package Contracts is -- Depends -- Effective_Reads -- Effective_Writes + -- Exceptional_Cases -- Extensions_Visible -- Global -- Initial_Condition @@ -58,6 +60,7 @@ package Contracts is -- Refined_Global -- Refined_Post -- Refined_States + -- Subprogram_Variant -- Test_Case -- Volatile_Function @@ -79,8 +82,10 @@ package Contracts is -- subprogram body Body_Id as if they appeared at the end of a declarative -- region. Pragmas in question are: -- + -- Always_Terminates (stand alone subprogram body) -- Contract_Cases (stand alone subprogram body) -- Depends (stand alone subprogram body) + -- Exceptional_Cases (stand alone subprogram body) -- Global (stand alone subprogram body) -- Postcondition (stand alone subprogram body) -- Precondition (stand alone subprogram body) @@ -97,8 +102,10 @@ package Contracts is -- subprogram Subp_Id as if they appeared at the end of a declarative -- region. The pragmas in question are: -- + -- Always_Terminates -- Contract_Cases -- Depends + -- Exceptional_Cases -- Global -- Postcondition -- Precondition @@ -135,6 +142,8 @@ package Contracts is -- Async_Writers -- Effective_Reads -- Effective_Writes + -- Postcondition + -- Precondition -- -- In the case of a protected or task type, there will also be -- a call to Analyze_Protected_Contract or Analyze_Task_Contract. @@ -169,14 +178,17 @@ package Contracts is -- stub Stub_Id as if they appeared at the end of a declarative region. The -- pragmas in question are: -- + -- Always_Terminates -- Contract_Cases -- Depends + -- Exceptional_Cases -- Global -- Postcondition -- Precondition -- Refined_Depends -- Refined_Global -- Refined_Post + -- Subprogram_Variant -- Test_Case procedure Analyze_Task_Contract (Task_Id : Entity_Id); diff --git a/gcc/ada/cstand.adb b/gcc/ada/cstand.adb index 72c287a..fbd5888 100644 --- a/gcc/ada/cstand.adb +++ b/gcc/ada/cstand.adb @@ -1642,8 +1642,7 @@ package body CStand is for E in Standard_Entity_Type loop if Ekind (Standard_Entity (E)) /= E_Operator then - Set_Name_Entity_Id - (Chars (Standard_Entity (E)), Standard_Entity (E)); + Set_Current_Entity (Standard_Entity (E)); Set_Homonym (Standard_Entity (E), Empty); end if; @@ -1784,6 +1783,7 @@ package body CStand is Set_Is_Immediately_Visible (Ident_Node, True); Set_Is_Intrinsic_Subprogram (Ident_Node, True); + Set_Is_Not_Self_Hidden (Ident_Node); Set_Name_Entity_Id (Op, Ident_Node); Append_Entity (Ident_Node, Standard_Standard); @@ -1806,9 +1806,10 @@ package body CStand is Set_Is_Public (E); -- All standard entity names are analyzed manually, and are thus - -- frozen as soon as they are created. + -- frozen and not self-hidden as soon as they are created. Set_Is_Frozen (E); + Set_Is_Not_Self_Hidden (E); -- Set debug information required for all standard types diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb index 7497fa0..fd94203 100644 --- a/gcc/ada/debug.adb +++ b/gcc/ada/debug.adb @@ -41,7 +41,7 @@ package body Debug is -- dh Generate listing showing loading of name table hash chains -- di Generate messages for visibility linking/delinking -- dj Suppress "junk null check" for access parameter values - -- dk Generate GNATBUG message on abort, even if previous errors + -- dk Generate "GNAT BUG" message on abort, even if previous errors -- dl Generate unit load trace messages -- dm Prevent special frontend inlining in GNATprove mode -- dn Generate messages for node/list allocation @@ -113,7 +113,7 @@ package body Debug is -- d.z Restore previous support for frontend handling of Inline_Always -- d.A Enable statistics printing in Atree - -- d.B Generate a bug box on abort_statement + -- d.B Generate a "GNAT BUG" message on abort_statement -- d.C Generate concatenation call, do not generate inline code -- d.D Disable errors on use of overriding keyword in Ada 95 mode -- d.E Turn selected errors into warnings @@ -125,7 +125,7 @@ package body Debug is -- d.K Do not reject components in extensions overlapping with parent -- d.L Depend on back end for limited types in if and case expressions -- d.M Relaxed RM semantics - -- d.N + -- d.N Use rounding when converting from floating point to fixed point -- d.O Dump internal SCO tables -- d.P Previous (non-optimized) handling of length comparisons -- d.Q Previous (incomplete) style check for binary operators @@ -486,9 +486,12 @@ package body Debug is -- GNAT before 3.10, so this switch can ease the transition process. -- dk Immediate kill on abort. Normally on an abort (i.e. a call to - -- Comperr.Compiler_Abort), the GNATBUG message is not given if - -- there is a previous error. This debug switch bypasses this test - -- and gives the message unconditionally (useful for debugging). + -- Comperr.Compiler_Abort), the "GNAT BUG" message is not given if + -- there is a previous error. Instead, the message "compilation + -- abandoned due to previous error" is given. This debug switch + -- bypasses this test and gives the "GNAT BUG" message unconditionally + -- (useful for debugging). Use -gnatdO in addition to see the previous + -- errors. -- dl Generate unit load trace messages. A line of traceback output is -- generated each time a request is made to the library manager to @@ -835,12 +838,12 @@ package body Debug is -- with -gnatd.A. You might want to apply "sort -nr" to parts of the -- output. - -- d.B Generate a bug box when we see an abort_statement, even though - -- there is no bug. Useful for testing Comperr.Compiler_Abort: write - -- some code containing an abort_statement, and compile it with + -- d.B Generate a "GNAT BUG" message when we see an abort_statement, even + -- though there is no bug. Useful for testing Comperr.Compiler_Abort: + -- write some code containing an abort_statement, and compile it with -- -gnatd.B. There is nothing special about abort_statements; it just - -- provides a way to control where the bug box is generated. See "when - -- N_Abort_Statement" in package body Expander. + -- provides a way to control where the bug box is generated. See the + -- "when N_Abort_Statement" in package body Expander. -- d.C Generate call to System.Concat_n.Str_Concat_n routines in cases -- where we would normally generate inline concatenation code. @@ -903,6 +906,10 @@ package body Debug is -- d.M Relaxed RM semantics. This flag sets Opt.Relaxed_RM_Semantics -- See Opt.Relaxed_RM_Semantics for more details. + -- d.N Use rounding instead of truncation when dynamically converting from + -- a floating-point type to an ordinary fixed-point type, for the sake + -- of compatibility with earlier versions of the compiler. + -- d.O Dump internal SCO tables. Before outputting the SCO information to -- the ALI file, the internal SCO tables (SCO_Table/SCO_Unit_Table) -- are dumped for debugging purposes. diff --git a/gcc/ada/doc/gnat_rm.rst b/gcc/ada/doc/gnat_rm.rst index 7743ef8..e52f2a6 100644 --- a/gcc/ada/doc/gnat_rm.rst +++ b/gcc/ada/doc/gnat_rm.rst @@ -55,6 +55,7 @@ GNAT Reference Manual gnat_rm/specialized_needs_annexes gnat_rm/implementation_of_specific_ada_features gnat_rm/implementation_of_ada_2012_features + gnat_rm/gnat_language_extensions gnat_rm/security_hardening_features gnat_rm/obsolescent_features gnat_rm/compatibility_and_porting_guide diff --git a/gcc/ada/doc/gnat_rm/gnat_language_extensions.rst b/gcc/ada/doc/gnat_rm/gnat_language_extensions.rst new file mode 100644 index 0000000..220345d --- /dev/null +++ b/gcc/ada/doc/gnat_rm/gnat_language_extensions.rst @@ -0,0 +1,477 @@ +.. _GNAT_Language_Extensions: + +************************ +GNAT language extensions +************************ + +The GNAT compiler implements a certain number of language extensions on top of +the latest Ada standard, implementing its own extended superset of Ada. + +There are two sets of language extensions: + +* The first is the curated set. The features in that set are features that we + consider being worthy additions to the Ada language, and that we want to make + available to users early on. + +* The second is the experimental set. It includes the first, but also + experimental features, that are here because they're still in an early + prototyping phase. + +How to activate the extended GNAT Ada superset +============================================== + +There are two ways to activate the extended GNAT Ada superset: + +* The :ref:`Pragma Extensions_Allowed<Pragma_Extensions_Allowed>`. To activate + the curated set of extensions, you should use + +.. code-block:: ada + + pragma Extensions_Allowed (On) + +As a configuration pragma, you can either put it at the beginning of a source +file, or in a ``.adc`` file corresponding to your project. + +* The ``-gnatX`` option, that you can pass to the compiler directly, will + activate the curated subset of extensions. + +.. attention:: You can activate the extended set of extensions by using either + the ``-gnatX0`` command line flag, or the pragma ``Extensions_Allowed`` with + ``All`` as an argument. However, it is not recommended you use this subset + for serious projects, and is only means as a playground/technology preview. + +.. _Curated_Language_Extensions: + +Curated Extensions +================== + +Conditional when constructs +--------------------------- + +This feature extends the use of ``when`` as a way to condition a control-flow +related statement, to all control-flow related statements. + +To do a conditional return in a procedure the following syntax should be used: + +.. code-block:: ada + + procedure P (Condition : Boolean) is + begin + return when Condition; + end; + +This will return from the procedure if ``Condition`` is true. + +When being used in a function the conditional part comes after the return value: + +.. code-block:: ada + + function Is_Null (I : Integer) return Boolean is + begin + return True when I = 0; + return False; + end; + +In a similar way to the ``exit when`` a ``goto ... when`` can be employed: + +.. code-block:: ada + + procedure Low_Level_Optimized is + Flags : Bitmapping; + begin + Do_1 (Flags); + goto Cleanup when Flags (1); + + Do_2 (Flags); + goto Cleanup when Flags (32); + + -- ... + + <<Cleanup>> + -- ... + end; + +.. code-block + +To use a conditional raise construct: + +.. code-block:: ada + + procedure Foo is + begin + raise Error when Imported_C_Func /= 0; + end; + +An exception message can also be added: + +.. code-block:: ada + + procedure Foo is + begin + raise Error with "Unix Error" + when Imported_C_Func /= 0; + end; + + +Link to the original RFC: +https://github.com/AdaCore/ada-spark-rfcs/blob/master/prototyped/rfc-conditional-when-constructs.rst + +Case pattern matching +--------------------- + +The selector for a case statement (but not yet for a case expression) may be of a composite type, subject to +some restrictions (described below). Aggregate syntax is used for choices +of such a case statement; however, in cases where a "normal" aggregate would +require a discrete value, a discrete subtype may be used instead; box +notation can also be used to match all values. + +Consider this example: + +.. code-block:: ada + + type Rec is record + F1, F2 : Integer; + end record; + + procedure Caser_1 (X : Rec) is + begin + case X is + when (F1 => Positive, F2 => Positive) => + Do_This; + when (F1 => Natural, F2 => <>) | (F1 => <>, F2 => Natural) => + Do_That; + when others => + Do_The_Other_Thing; + end case; + end Caser_1; + +If ``Caser_1`` is called and both components of X are positive, then +``Do_This`` will be called; otherwise, if either component is nonnegative +then ``Do_That`` will be called; otherwise, ``Do_The_Other_Thing`` will be +called. + +In addition, pattern bindings are supported. This is a mechanism +for binding a name to a component of a matching value for use within +an alternative of a case statement. For a component association +that occurs within a case choice, the expression may be followed by +``is <identifier>``. In the special case of a "box" component association, +the identifier may instead be provided within the box. Either of these +indicates that the given identifier denotes (a constant view of) the matching +subcomponent of the case selector. + +.. attention:: Binding is not yet supported for arrays or subcomponents + thereof. + +Consider this example (which uses type ``Rec`` from the previous example): + +.. code-block:: ada + + procedure Caser_2 (X : Rec) is + begin + case X is + when (F1 => Positive is Abc, F2 => Positive) => + Do_This (Abc) + when (F1 => Natural is N1, F2 => <N2>) | + (F1 => <N2>, F2 => Natural is N1) => + Do_That (Param_1 => N1, Param_2 => N2); + when others => + Do_The_Other_Thing; + end case; + end Caser_2; + +This example is the same as the previous one with respect to determining +whether ``Do_This``, ``Do_That``, or ``Do_The_Other_Thing`` will be called. But +for this version, ``Do_This`` takes a parameter and ``Do_That`` takes two +parameters. If ``Do_This`` is called, the actual parameter in the call will be +``X.F1``. + +If ``Do_That`` is called, the situation is more complex because there are two +choices for that alternative. If ``Do_That`` is called because the first choice +matched (i.e., because ``X.F1`` is nonnegative and either ``X.F1`` or ``X.F2`` +is zero or negative), then the actual parameters of the call will be (in order) +``X.F1`` and ``X.F2``. If ``Do_That`` is called because the second choice +matched (and the first one did not), then the actual parameters will be +reversed. + +Within the choice list for single alternative, each choice must define the same +set of bindings and the component subtypes for for a given identifer must all +statically match. Currently, the case of a binding for a nondiscrete component +is not implemented. + +If the set of values that match the choice(s) of an earlier alternative +overlaps the corresponding set of a later alternative, then the first set shall +be a proper subset of the second (and the later alternative will not be +executed if the earlier alternative "matches"). All possible values of the +composite type shall be covered. The composite type of the selector shall be an +array or record type that is neither limited nor 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 choice expression +is a "box" component association (which matches all possible values for the +subcomponent). This restriction applies if: + +- the component subtype is not a record, array, or discrete type; or + +- the component subtype is subject to a non-static constraint or has a + predicate; or: + +- the component type is an enumeration type that is subject to an enumeration + representation clause; or + +- the component type is a multidimensional array type or an array type with a + nonstatic index subtype. + +Support for casing on arrays (and on records that contain arrays) is +currently subject to some restrictions. Non-positional +array aggregates are not supported as (or within) case choices. Likewise +for array type and subtype names. The current implementation exceeds +compile-time capacity limits in some annoyingly common scenarios; the +message generated in such cases is usually "Capacity exceeded in compiling +case statement with composite selector type". + +Link to the original RFC: +https://github.com/AdaCore/ada-spark-rfcs/blob/master/prototyped/rfc-pattern-matching.rst + +Fixed lower bounds for array types and subtypes +----------------------------------------------- + +Unconstrained array types and subtypes can be specified with a lower bound that +is fixed to a certain value, by writing an index range that uses the syntax +``<lower-bound-expression> .. <>``. This guarantees that all objects of the +type or subtype will have the specified lower bound. + +For example, a matrix type with fixed lower bounds of zero for each dimension +can be declared by the following: + +.. code-block:: ada + + type Matrix is + array (Natural range 0 .. <>, Natural range 0 .. <>) of Integer; + +Objects of type ``Matrix`` declared with an index constraint must have index +ranges starting at zero: + +.. code-block:: ada + + M1 : Matrix (0 .. 9, 0 .. 19); + M2 : Matrix (2 .. 11, 3 .. 22); -- Warning about bounds; will raise CE + +Similarly, a subtype of ``String`` can be declared that specifies the lower +bound of objects of that subtype to be ``1``: + + .. code-block:: ada + + subtype String_1 is String (1 .. <>); + +If a string slice is passed to a formal of subtype ``String_1`` in a call to a +subprogram ``S``, the slice's bounds will "slide" so that the lower bound is +``1``. + +Within ``S``, the lower bound of the formal is known to be ``1``, so, unlike a +normal unconstrained ``String`` formal, there is no need to worry about +accounting for other possible lower-bound values. Sliding of bounds also occurs +in other contexts, such as for object declarations with an unconstrained +subtype with fixed lower bound, as well as in subtype conversions. + +Use of this feature increases safety by simplifying code, and can also improve +the efficiency of indexing operations, since the compiler statically knows the +lower bound of unconstrained array formals when the formal's subtype has index +ranges with static fixed lower bounds. + +Link to the original RFC: +https://github.com/AdaCore/ada-spark-rfcs/blob/master/prototyped/rfc-fixed-lower-bound.rst + +Prefixed-view notation for calls to primitive subprograms of untagged types +--------------------------------------------------------------------------- + +When operating on an untagged type, if it has any primitive operations, and the +first parameter of an operation is of the type (or is an access parameter with +an anonymous type that designates the type), you may invoke these operations +using an ``object.op(...)`` notation, where the parameter that would normally be +the first parameter is brought out front, and the remaining parameters (if any) +appear within parentheses after the name of the primitive operation. + +This same notation is already available for tagged types. This extension allows +for untagged types. It is allowed for all primitive operations of the type +independent of whether they were originally declared in a package spec or its +private part, or were inherited and/or overridden as part of a derived type +declaration occuring anywhere, so long as the first parameter is of the type, +or an access parameter designating the type. + +For example: + +.. code-block:: ada + + generic + type Elem_Type is private; + package Vectors is + type Vector is private; + procedure Add_Element (V : in out Vector; Elem : Elem_Type); + function Nth_Element (V : Vector; N : Positive) return Elem_Type; + function Length (V : Vector) return Natural; + private + function Capacity (V : Vector) return Natural; + -- Return number of elements that may be added without causing + -- any new allocation of space + + type Vector is ... + with Type_Invariant => Vector.Length <= Vector.Capacity; + ... + end Vectors; + + package Int_Vecs is new Vectors(Integer); + + V : Int_Vecs.Vector; + ... + V.Add_Element(42); + V.Add_Element(-33); + + pragma Assert (V.Length = 2); + pragma Assert (V.Nth_Element(1) = 42); + +Link to the original RFC: +https://github.com/AdaCore/ada-spark-rfcs/blob/master/prototyped/rfc-prefixed-untagged.rst + +Expression defaults for generic formal functions +------------------------------------------------ + +The declaration of a generic formal function is allowed to specify +an expression as a default, using the syntax of an expression function. + +Here is an example of this feature: + +.. code-block:: ada + + generic + type T is private; + with function Copy (Item : T) return T is (Item); -- Defaults to Item + package Stacks is + + type Stack is limited private; + + procedure Push (S : in out Stack; X : T); -- Calls Copy on X + function Pop (S : in out Stack) return T; -- Calls Copy to return item + + private + -- ... + end Stacks; + +Link to the original RFC: +https://github.com/AdaCore/ada-spark-rfcs/blob/master/prototyped/rfc-expression-functions-as-default-for-generic-formal-function-parameters.rst + +String interpolation +-------------------- + +The syntax for string literals is extended to support string interpolation. + +Within an interpolated string literal, an arbitrary expression, when +enclosed in ``{ ... }``, is expanded at run time into the result of calling +``'Image`` on the result of evaluating the expression enclosed by the brace +characters, unless it is already a string or a single character. + +Here is an example of this feature where the expressions ``Name`` and ``X + Y`` +will be evaluated and included in the string. + +.. code-block:: ada + + procedure Test_Interpolation is + X : Integer := 12; + Y : Integer := 15; + Name : String := "Leo"; + begin + Put_Line (f"The name is {Name} and the sum is {X + Y}."); + end Test_Interpolation; + +In addition, an escape character (``\``) is provided for inserting certain +standard control characters (such as ``\t`` for tabulation or ``\n`` for +newline) or to escape characters with special significance to the +interpolated string syntax, namely ``"``, ``{``, ``}``,and ``\`` itself. + +================= ================= +escaped_character meaning +----------------- ----------------- +``\a`` ALERT +``\b`` BACKSPACE +``\f`` FORM FEED +``\n`` LINE FEED +``\r`` CARRIAGE RETURN +``\t`` CHARACTER TABULATION +``\v`` LINE TABULATION +``\0`` NUL +----------------- ----------------- +``\\`` ``\`` +``\"`` ``"`` +``\{`` ``{`` +``\}`` ``}`` +================= ================= + +Note that, unlike normal string literals, doubled characters have no +special significance. So to include a double-quote or a brace character +in an interpolated string, they must be preceded by a ``\``. +For example: + +.. code-block:: ada + + Put_Line + (f"X = {X} and Y = {Y} and X+Y = {X+Y};\n" & + f" a double quote is \" and" & + f" an open brace is \{"); + +Finally, a syntax is provided for creating multi-line string literals, +without having to explicitly use an escape sequence such as ``\n``. For +example: + +.. code-block:: ada + + Put_Line + (f"This is a multi-line" + "string literal" + "There is no ambiguity about how many" + "spaces are included in each line"); + +Here is a link to the original RFC : +https://github.com/AdaCore/ada-spark-rfcs/blob/master/prototyped/rfc-string-interpolation.rst + +Constrained attribute for generic objects +----------------------------------------- + +The ``Constrained`` attribute is permitted for objects of generic types. The +result indicates whether the corresponding actual is constrained. + +``Static`` aspect on intrinsic functions +---------------------------------------- + +The Ada 202x ``Static`` aspect can be specified on Intrinsic imported functions +and the compiler will evaluate some of these intrinsics statically, in +particular the ``Shift_Left`` and ``Shift_Right`` intrinsics. + +.. _Experimental_Language_Extensions: + +Experimental Language Extensions +================================ + +Pragma Storage_Model +-------------------- + +This feature proposes to redesign the concepts of Storage Pools into a more +efficient model allowing higher performances and easier integration with low +footprint embedded run-times. + +It also extends it to support distributed memory models, in particular to +support interactions with GPU. + +Here is a link to the full RFC: +https://github.com/AdaCore/ada-spark-rfcs/blob/master/prototyped/rfc-storage-model.rst + +Simpler accessibility model +--------------------------- + +The goal of this feature is to restore a common understanding of accessibility +rules for implementers and users alike. The new rules should both be effective +at preventing errors and feel natural and compatible in an Ada environment +while removing dynamic accessibility checking. + +Here is a link to the full RFC: +https://github.com/AdaCore/ada-spark-rfcs/blob/master/prototyped/rfc-simpler-accessibility.md diff --git a/gcc/ada/doc/gnat_rm/implementation_defined_aspects.rst b/gcc/ada/doc/gnat_rm/implementation_defined_aspects.rst index 960c505..b37a158 100644 --- a/gcc/ada/doc/gnat_rm/implementation_defined_aspects.rst +++ b/gcc/ada/doc/gnat_rm/implementation_defined_aspects.rst @@ -255,6 +255,16 @@ Aspect Ghost This aspect is equivalent to :ref:`pragma Ghost<Pragma-Ghost>`. +Aspect Ghost_Predicate +====================== +.. index:: Ghost_Predicate + +This aspect introduces a subtype predicate that can reference ghost +entities. The subtype cannot appear as a subtype_mark in a membership test. + +For the detailed semantics of this aspect, see the entry for subtype predicates +in the SPARK Reference Manual, section 3.2.4. + Aspect Global ============= .. index:: Global diff --git a/gcc/ada/doc/gnat_rm/implementation_defined_characteristics.rst b/gcc/ada/doc/gnat_rm/implementation_defined_characteristics.rst index fb6a63c..0d3f340 100644 --- a/gcc/ada/doc/gnat_rm/implementation_defined_characteristics.rst +++ b/gcc/ada/doc/gnat_rm/implementation_defined_characteristics.rst @@ -820,7 +820,7 @@ This definition is determined by the underlying operating system. "The circumstances where an environment variable cannot be defined. See A.17(16)." - There are no such implementation-defined circumstances. +There are no such implementation-defined circumstances. * "Environment names for which Set has the effect of Clear. See A.17(17)." @@ -1154,8 +1154,8 @@ Execution is erroneous in that case. * "Whether the use of pragma Restrictions results in a reduction in program code or data size or execution time. See D.7(20)." - Yes it can, but the precise circumstances and properties of such reductions - are difficult to characterize. +Yes it can, but the precise circumstances and properties of such reductions +are difficult to characterize. * "The value of Barrier_Limit'Last in Synchronous_Barriers. See D.10.1(4)." diff --git a/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst b/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst index ed42d08..35a3fe5 100644 --- a/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst +++ b/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst @@ -2163,6 +2163,8 @@ To compile it you will have to use the *-gnatg* switch for compiling System units, as explained in the GNAT User's Guide. +.. _Pragma_Extensions_Allowed: + Pragma Extensions_Allowed ========================= .. index:: Ada Extensions @@ -2179,251 +2181,16 @@ Syntax: This configuration pragma enables (via the "On" or "All" argument) or disables (via the "Off" argument) the implementation extension mode; the pragma takes -precedence over the *-gnatX* and *-gnatX0* command switches. - -If an argument of "All" is specified, the latest version of the Ada language -is implemented (currently Ada 2022) and, in addition, a number -of GNAT specific extensions are recognized. These extensions are listed -below. An argument of "On" has the same effect except that only -some, not all, of the listed extensions are enabled; those extensions -are identified below. - -* Constrained attribute for generic objects - - The ``Constrained`` attribute is permitted for objects of - generic types. The result indicates if the corresponding actual - is constrained. - -* ``Static`` aspect on intrinsic functions - - The Ada 202x ``Static`` aspect can be specified on Intrinsic imported - functions and the compiler will evaluate some of these intrinsic statically, - in particular the ``Shift_Left`` and ``Shift_Right`` intrinsics. - - An Extensions_Allowed pragma argument of "On" enables this extension. - -* ``[]`` aggregates - - This new aggregate syntax for arrays and containers is provided under -gnatX - to experiment and confirm this new language syntax. - -* Additional ``when`` constructs - - In addition to the ``exit when CONDITION`` control structure, several - additional constructs are allowed following this format. Including - ``return when CONDITION``, ``goto when CONDITION``, and - ``raise [with EXCEPTION_MESSAGE] when CONDITION.`` - - Some examples: - - .. code-block:: ada - - return Result when Variable > 10; - - raise Program_Error with "Element is null" when Element = null; - - goto End_Of_Subprogram when Variable = -1; - -* Casing on composite values (aka pattern matching) - - The selector for a case statement may be of a composite type, subject to - some restrictions (described below). Aggregate syntax is used for choices - of such a case statement; however, in cases where a "normal" aggregate would - require a discrete value, a discrete subtype may be used instead; box - notation can also be used to match all values. - - Consider this example: - - .. code-block:: ada - - type Rec is record - F1, F2 : Integer; - end record; - - procedure Caser_1 (X : Rec) is - begin - case X is - when (F1 => Positive, F2 => Positive) => - Do_This; - when (F1 => Natural, F2 => <>) | (F1 => <>, F2 => Natural) => - Do_That; - when others => - Do_The_Other_Thing; - end case; - end Caser_1; - - If Caser_1 is called and both components of X are positive, then - Do_This will be called; otherwise, if either component is nonnegative - then Do_That will be called; otherwise, Do_The_Other_Thing will be called. - - If the set of values that match the choice(s) of an earlier alternative - overlaps the corresponding set of a later alternative, then the first - set shall be a proper subset of the second (and the later alternative - will not be executed if the earlier alternative "matches"). All possible - values of the composite type shall be covered. The composite type of the - selector shall be an array or record type that is neither limited - 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 - choice expression is a "box" component association (which matches all - possible values for the subcomponent). This restriction applies if - - - the component subtype is not a record, array, or discrete type; or - - - the component subtype is subject to a non-static constraint or - has a predicate; or - - - the component type is an enumeration type that is subject to an - enumeration representation clause; or - - - the component type is a multidimensional array type or an - array type with a nonstatic index subtype. - - Support for casing on arrays (and on records that contain arrays) is - currently subject to some restrictions. Non-positional - array aggregates are not supported as (or within) case choices. Likewise - for array type and subtype names. The current implementation exceeds - compile-time capacity limits in some annoyingly common scenarios; the - message generated in such cases is usually "Capacity exceeded in compiling - case statement with composite selector type". - - In addition, pattern bindings are supported. This is a mechanism - for binding a name to a component of a matching value for use within - an alternative of a case statement. For a component association - that occurs within a case choice, the expression may be followed by - "is <identifier>". In the special case of a "box" component association, - the identifier may instead be provided within the box. Either of these - indicates that the given identifer denotes (a constant view of) the matching - subcomponent of the case selector. Binding is not yet supported for arrays - or subcomponents thereof. - - Consider this example (which uses type Rec from the previous example): - - .. code-block:: ada - - procedure Caser_2 (X : Rec) is - begin - case X is - when (F1 => Positive is Abc, F2 => Positive) => - Do_This (Abc) - when (F1 => Natural is N1, F2 => <N2>) | - (F1 => <N2>, F2 => Natural is N1) => - Do_That (Param_1 => N1, Param_2 => N2); - when others => - Do_The_Other_Thing; - end case; - end Caser_2; - - This example is the same as the previous one with respect to - determining whether Do_This, Do_That, or Do_The_Other_Thing will - be called. But for this version, Do_This takes a parameter and Do_That - takes two parameters. If Do_This is called, the actual parameter in the - call will be X.F1. - - If Do_That is called, the situation is more complex because there are two - choices for that alternative. If Do_That is called because the first choice - matched (i.e., because X.F1 is nonnegative and either X.F1 or X.F2 is zero - or negative), then the actual parameters of the call will be (in order) - X.F1 and X.F2. If Do_That is called because the second choice matched (and - the first one did not), then the actual parameters will be reversed. - - Within the choice list for single alternative, each choice must - define the same set of bindings and the component subtypes for - for a given identifer must all statically match. Currently, the case - of a binding for a nondiscrete component is not implemented. - - An Extensions_Allowed pragma argument of "On" enables this extension. - -* Fixed lower bounds for array types and subtypes - - Unconstrained array types and subtypes can be specified with a lower bound - that is fixed to a certain value, by writing an index range that uses the - syntax "<lower-bound-expression> .. <>". This guarantees that all objects - of the type or subtype will have the specified lower bound. - - For example, a matrix type with fixed lower bounds of zero for each - dimension can be declared by the following: +precedence over the ``-gnatX`` and ``-gnatX0`` command switches. - .. code-block:: ada - - type Matrix is - array (Natural range 0 .. <>, Natural range 0 .. <>) of Integer; - - Objects of type Matrix declared with an index constraint must have index - ranges starting at zero: - - .. code-block:: ada - - M1 : Matrix (0 .. 9, 0 .. 19); - M2 : Matrix (2 .. 11, 3 .. 22); -- Warning about bounds; will raise CE - - Similarly, a subtype of String can be declared that specifies the lower - bound of objects of that subtype to be 1: - - .. code-block:: ada - - subtype String_1 is String (1 .. <>); - - If a string slice is passed to a formal of subtype String_1 in a call to - a subprogram S, the slice's bounds will "slide" so that the lower bound - is 1. Within S, the lower bound of the formal is known to be 1, so, unlike - a normal unconstrained String formal, there is no need to worry about - accounting for other possible lower-bound values. Sliding of bounds also - occurs in other contexts, such as for object declarations with an - unconstrained subtype with fixed lower bound, as well as in subtype - conversions. - - Use of this feature increases safety by simplifying code, and can also - improve the efficiency of indexing operations, since the compiler statically - knows the lower bound of unconstrained array formals when the formal's - subtype has index ranges with static fixed lower bounds. - - An Extensions_Allowed pragma argument of "On" enables this extension. +If an argument of ``"On"`` is specified, the latest version of the Ada language +is implemented (currently Ada 2022) and, in addition, a curated set of GNAT +specific extensions are recognized. (See the list here +:ref:`here<Curated_Language_Extensions>`) -* Prefixed-view notation for calls to primitive subprograms of untagged types - - Since Ada 2005, calls to primitive subprograms of a tagged type that - have a "prefixed view" (see RM 4.1.3(9.2)) have been allowed to be - written using the form of a selected_component, with the first actual - parameter given as the prefix and the name of the subprogram as a - selector. This prefixed-view notation for calls is extended so as to - also allow such syntax for calls to primitive subprograms of untagged - types. The primitives of an untagged type T that have a prefixed view - are those where the first formal parameter of the subprogram either - is of type T or is an anonymous access parameter whose designated type - is T. For a type that has a component that happens to have the same - simple name as one of the type's primitive subprograms, where the - component is visible at the point of a selected_component using that - name, preference is given to the component in a selected_component - (as is currently the case for tagged types with such component names). - - An Extensions_Allowed pragma argument of "On" enables this extension. - -* Expression defaults for generic formal functions - - The declaration of a generic formal function is allowed to specify - an expression as a default, using the syntax of an expression function. - - Here is an example of this feature: - - .. code-block:: ada - - generic - type T is private; - with function Copy (Item : T) return T is (Item); -- Defaults to Item - package Stacks is - - type Stack is limited private; - - procedure Push (S : in out Stack; X : T); -- Calls Copy on X - - function Pop (S : in out Stack) return T; -- Calls Copy to return item - - private - -- ... - end Stacks; +An argument of ``"All"`` has the same effect except that some extra +experimental extensions are enabled (See the list here +:ref:`here<Experimental_Language_Extensions>`) .. _Pragma-Extensions_Visible: @@ -3763,7 +3530,7 @@ 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 ===================== 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 f8e2a58..275b46c 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 @@ -186,7 +186,17 @@ No_Dependence [RM 13.12.1] This restriction ensures at compile time that there are no 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. +to support specific constructs of the language. Here are some examples: + +* ``System.Arith_64``: 64-bit arithmetics for 32-bit platforms, +* ``System.Arith_128``: 128-bit arithmetics for 64-bit platforms, +* ``System.Memory``: heap memory allocation routines, +* ``System.Memory_Compare``: memory comparison routine (aka ``memcmp`` for C), +* ``System.Memory_Copy``: memory copy routine (aka ``memcpy`` for C), +* ``System.Memory_Move``: memoy move routine (aka ``memmove`` for C), +* ``System.Memory_Set``: memory set routine (aka ``memset`` for C), +* ``System.Stack_Checking[.Operations]``: stack checking without MMU, +* ``System.GCC``: support routines from the GCC library. No_Direct_Boolean_Operators --------------------------- diff --git a/gcc/ada/doc/gnat_ugn/about_this_guide.rst b/gcc/ada/doc/gnat_ugn/about_this_guide.rst index 3347626..18cfb02 100644 --- a/gcc/ada/doc/gnat_ugn/about_this_guide.rst +++ b/gcc/ada/doc/gnat_ugn/about_this_guide.rst @@ -38,17 +38,17 @@ This guide contains the following chapters: using the GNU make utility with GNAT. * :ref:`GNAT_Utility_Programs` explains the various utility programs that - are included in the GNAT environment + are included in the GNAT environment. * :ref:`GNAT_and_Program_Execution` covers a number of topics related to - running, debugging, and tuning the performace of programs developed - with GNAT + running, debugging, and tuning the performance of programs developed + with GNAT. Appendices cover several additional topics: * :ref:`Platform_Specific_Information` describes the different run-time library implementations and also presents information on how to use - GNAT on several specific platforms + GNAT on several specific platforms. * :ref:`Example_of_Binder_Output_File` shows the source code for the binder output file for a sample program. 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 634bbc9..8e47967 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 @@ -895,12 +895,12 @@ by ``gnatmake``. It may be necessary to use the switch Examples of ``gnatmake`` Usage ------------------------------ -*gnatmake hello.adb* +``gnatmake hello.adb`` Compile all files necessary to bind and link the main program :file:`hello.adb` (containing unit ``Hello``) and bind and link the resulting object files to generate an executable file :file:`hello`. -*gnatmake main1 main2 main3* +``gnatmake main1 main2 main3`` Compile all files necessary to bind and link the main programs :file:`main1.adb` (containing unit ``Main1``), :file:`main2.adb` (containing unit ``Main2``) and :file:`main3.adb` @@ -908,7 +908,7 @@ Examples of ``gnatmake`` Usage to generate three executable files :file:`main1`, :file:`main2` and :file:`main3`. -*gnatmake -q Main_Unit -cargs -O2 -bargs -l* +``gnatmake -q Main_Unit -cargs -O2 -bargs -l`` Compile all files necessary to bind and link the main program unit ``Main_Unit`` (from file :file:`main_unit.adb`). All compilations will be done with optimization level 2 and the order of elaboration will be @@ -949,7 +949,7 @@ You need *not* compile the following files * subunits -because they are compiled as part of compiling related units. GNAT +because they are compiled as part of compiling related units. GNAT compiles package specs when the corresponding body is compiled, and subunits when the parent is compiled. @@ -997,8 +997,6 @@ 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 :switch:`--foobar{NN}` switch - .. index:: gnat1 ``gcc`` is actually a driver program that looks at the extensions of @@ -1068,7 +1066,7 @@ directories, in the following order: * The content of the :file:`ada_source_path` file which is part of the GNAT installation tree and is used to store standard libraries such as the GNAT Run Time Library (RTL) source files. - :ref:`Installing_a_library` + See also :ref:`Installing_a_library`. Specifying the switch :switch:`-I-` inhibits the use of the directory @@ -1159,7 +1157,7 @@ Compile body in file :file:`xyz.adb` with all default options. $ gcc -c -O2 -gnata xyz-def.adb Compile the child unit package in file :file:`xyz-def.adb` with extensive -optimizations, and pragma ``Assert``/`Debug` statements +optimizations, and pragma ``Assert``/``Debug`` statements enabled. .. code-block:: sh @@ -1274,7 +1272,7 @@ Alphabetical List of All Switches size of the executable, compared with a traditional per-unit compilation with inlining across units enabled by the :switch:`-gnatn` switch. The drawback of this approach is that it may require more memory and that - the debugging information generated by -g with it might be hardly usable. + the debugging information generated by ``-g`` with it might be hardly usable. The switch, as well as the accompanying :switch:`-Ox` switches, must be specified both for the compilation and the link phases. If the ``n`` parameter is specified, the optimization and final code @@ -1472,7 +1470,7 @@ Alphabetical List of All Switches This switch will generate an intermediate representation suitable for use by CodePeer (:file:`.scil` files). This switch is not compatible with code generation (it will, among other things, disable some switches such - as -gnatn, and enable others such as -gnata). + as ``-gnatn``, and enable others such as ``-gnata``). .. index:: -gnatd (gcc) @@ -1482,9 +1480,9 @@ Alphabetical List of All Switches the :switch:`-gnatd` specifies the specific debug options. The possible characters are 0-9, a-z, A-Z, optionally preceded by a dot or underscore. See compiler source file :file:`debug.adb` for details of the implemented - debug options. Certain debug options are relevant to applications + debug options. Certain debug options are relevant to application programmers, and these are documented at appropriate points in this - users guide. + user's guide. .. index:: -gnatD[nn] (gcc) @@ -1493,7 +1491,7 @@ Alphabetical List of All Switches Create expanded source files for source level debugging. This switch also suppresses generation of cross-reference information (see :switch:`-gnatx`). Note that this switch is not allowed if a previous - -gnatR switch has been given, since these two switches are not compatible. + ``-gnatR`` switch has been given, since these two switches are not compatible. .. index:: -gnateA (gcc) @@ -1614,6 +1612,14 @@ Alphabetical List of All Switches Save result of preprocessing in a text file. +.. index:: -gnateH (gcc) + +:switch:`-gnateH` + Set the threshold from which the RM 13.5.1(13.3/2) clause applies to 64. + This is useful only on 64-bit plaforms where this threshold is 128, but + used to be 64 in earlier versions of the compiler. + + .. index:: -gnatei (gcc) :switch:`-gnatei{nnn}` @@ -1638,7 +1644,7 @@ Alphabetical List of All Switches where implicit ``pragma Elaborate`` and ``pragma Elaborate_All`` are generated. This is useful in diagnosing elaboration circularities caused by these implicit pragmas when using the static elaboration - model. See See the section in this guide on elaboration checking for + model. See the section in this guide on elaboration checking for further details. These messages are not generated by default, and are intended only for temporary use when debugging circularity problems. @@ -2801,6 +2807,8 @@ of the pragma in the :title:`GNAT_Reference_manual`). * :switch:`-gnatw.s` (overridden size clause) + * :switch:`-gnatw_s` (ineffective predicate test) + * :switch:`-gnatwt` (tracking of deleted conditional code) * :switch:`-gnatw.u` (unordered enumeration) @@ -2869,7 +2877,7 @@ of the pragma in the :title:`GNAT_Reference_manual`). .. index:: -gnatw_A :switch:`-gnatw_A` - *Supress warnings on anonymous allocators.* + *Suppress warnings on anonymous allocators.* .. index:: Anonymous allocators @@ -3009,7 +3017,7 @@ of the pragma in the :title:`GNAT_Reference_manual`). :switch:`-gnatw_C` *Suppress warnings on unknown condition in Compile_Time_Warning.* - This switch supresses warnings on a pragma Compile_Time_Warning + This switch suppresses warnings on a pragma Compile_Time_Warning or Compile_Time_Error whose condition has a value that is not known at compile time. @@ -3365,7 +3373,7 @@ of the pragma in the :title:`GNAT_Reference_manual`). This switch activates warnings for declarations that declare a name that is defined in package Standard. Such declarations can be confusing, especially since the names in package Standard continue to be directly - visible, meaning that use visibiliy on such redeclared names does not + visible, meaning that use visibility on such redeclared names does not work as expected. Names of discriminants and components in records are not included in this check. @@ -3834,6 +3842,25 @@ of the pragma in the :title:`GNAT_Reference_manual`). warnings when an array component size overrides a size clause. +.. index:: -gnatw_s (gcc) +.. index:: Warnings + +:switch:`-gnatw_s` + *Activate warnings on ineffective predicate tests.* + + This switch activates warnings on Static_Predicate aspect + specifications that test for values that do not belong to + the parent subtype. Not all such ineffective tests are detected. + +.. index:: -gnatw_S (gcc) + +:switch:`-gnatw_S` + *Suppress warnings on ineffective predicate tests.* + + This switch suppresses warnings on Static_Predicate aspect + specifications that test for values that do not belong to + the parent subtype. + .. index:: -gnatwt (gcc) .. index:: Deactivated code, warnings .. index:: Deleted code, warnings @@ -4685,7 +4712,7 @@ Style Checking .. index:: -gnaty (gcc) -The :switch:`-gnatyx` switch causes the compiler to +The :switch:`-gnaty` switch causes the compiler to enforce specified style rules. A limited set of style rules has been used in writing the GNAT sources themselves. This switch allows user programs to activate all or some of these checks. If the source program fails a @@ -4883,9 +4910,9 @@ checks to be performed. The following checks are defined: 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 - incorporated into GNAT. Currently this is equivalent to :switch:`-gnatyydISux`) - but additional style switches may be added to this set in the future without - advance notice. + incorporated into GNAT. Currently this is equivalent to + :switch:`-gnatyydISuxz`) but additional style switches may be added to this + set in the future without advance notice. .. index:: -gnatyh (gcc) @@ -5186,9 +5213,9 @@ checks to be performed. The following checks are defined: :switch:`-gnatyx` *Check extra parentheses.* - Unnecessary extra level of parentheses (C-style) are not allowed - around conditions in ``if`` statements, ``while`` statements and - ``exit`` statements. + Unnecessary extra levels of parentheses (C-style) are not allowed + around conditions (or selection expressions) in ``if``, ``while``, + ``case``, and ``exit`` statements, as well as part of ranges. .. index:: -gnatyy (gcc) @@ -5202,6 +5229,15 @@ checks to be performed. The following checks are defined: :switch:`-gnatyS`, :switch:`-gnatyu`, and :switch:`-gnatyx`. +.. index:: -gnatyz (gcc) + +:switch:`-gnatyz` + *Check extra parentheses (operator precedence).* + + Extra levels of parentheses that are not required by operator precedence + rules are flagged. See also ``-gnatyx``. + + .. index:: -gnaty- (gcc) :switch:`-gnaty-` @@ -6785,7 +6821,7 @@ be presented in subsequent sections. The underlying scalar is set to a value consisting of repeated bytes, whose value corresponds to the given value. For example if ``BF`` is given, - then a 32-bit scalar value will be set to the bit patterm ``16#BFBFBFBF#``. + then a 32-bit scalar value will be set to the bit pattern ``16#BFBFBFBF#``. .. index:: GNAT_INIT_SCALARS 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 5dab2d4..62abca2 100644 --- a/gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst +++ b/gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst @@ -2925,25 +2925,8 @@ The default mode for overflow checks is General => Strict -which causes all computations both inside and outside assertions to use -the base type. - -This retains compatibility with previous versions of -GNAT which suppressed overflow checks by default and always -used the base type for computation of intermediate results. - -.. Sphinx allows no emphasis within :index: role. As a workaround we - point the index to "switch" and use emphasis for "-gnato". - -The :index:`switch <-gnato (gcc)>` :switch:`-gnato` (with no digits following) -is equivalent to - - :: - - General => Strict - -which causes overflow checking of all intermediate overflows -both inside and outside assertions against the base type. +which causes all computations both inside and outside assertions to use the +base type, and is equivalent to :switch:`-gnato` (with no digits following). The pragma ``Suppress (Overflow_Check)`` disables overflow checking, but it has no effect on the method used for computing @@ -2964,7 +2947,7 @@ reasonably efficient, and can be generally used. It also helps to ensure compatibility with code imported from some other compiler to GNAT. -Setting all intermediate overflows checking (``CHECKED`` mode) +Setting all intermediate overflows checking (``STRICT`` mode) makes sense if you want to make sure that your code is compatible with any other possible Ada implementation. This may be useful in ensuring portability @@ -3530,12 +3513,12 @@ leak memory even though it does not perform explicit deallocation: for A'Storage_Pool use X; v : A; begin - for I in 1 .. 50 loop + for I in 1 .. 50 loop v := new Integer; end loop; end Internal; begin - for I in 1 .. 100 loop + for I in 1 .. 100 loop Internal; end loop; end Pooloc1; diff --git a/gcc/ada/doc/gnat_ugn/gnat_utility_programs.rst b/gcc/ada/doc/gnat_ugn/gnat_utility_programs.rst index 639534d..98c9090 100644 --- a/gcc/ada/doc/gnat_ugn/gnat_utility_programs.rst +++ b/gcc/ada/doc/gnat_ugn/gnat_utility_programs.rst @@ -1650,8 +1650,8 @@ building specialized scripts. .. _The_Body_Stub_Generator_gnatstub: - The Body Stub Generator *gnatstub* - ================================== + The Body Stub Generator ``gnatstub`` + ==================================== .. index:: ! gnatstub diff --git a/gcc/ada/doc/gnat_ugn/platform_specific_information.rst b/gcc/ada/doc/gnat_ugn/platform_specific_information.rst index a136a5a..3744b74 100644 --- a/gcc/ada/doc/gnat_ugn/platform_specific_information.rst +++ b/gcc/ada/doc/gnat_ugn/platform_specific_information.rst @@ -254,6 +254,48 @@ Other GNU/Linux distributions might be choosing a different name for those packages. +.. _PIE_Enabled_By_Default_On_Linux: + +Position Independent Executable (PIE) Enabled by Default on Linux +----------------------------------------------------------------- + +GNAT generates Position Independent Executable (PIE) code by default. +PIE binaries are loaded into random memory locations, introducing +an additional layer of protection against attacks. + +Building PIE binaries requires that all of their dependencies also be +built as Position Independent. If the link of your project fails with +an error like:: + + /[...]/ld: /path/to/object/file: relocation R_X86_64_32S against symbol + `symbol name' can not be used when making a PIE object; + recompile with -fPIE + +it means the identified object file has not been built as Position +Independent. + +If you are not interested in building PIE binaries, you can simply +turn this feature off by first compiling your code with :samp:`-fno-pie` +and then by linking with :samp:`-no-pie` (note the subtle but important +difference in the names of the options -- the linker option does **not** +have an `f` after the dash!). When using gprbuild, this is +achieved by updating the *Required_Switches* attribute in package `Compiler` +and, depending on your type of project, either attribute *Switches* +or attribute *Library_Options* in package `Linker`. + +On the other hand, if you would like to build PIE binaries and you are +getting the error above, a quick and easy workaround to allow linking +to succeed again is to disable PIE during the link, thus temporarily +lifting the requirement that all dependencies also be Position +Independent code. To do so, you simply need to add :samp:`-no-pie` to +the list of switches passed to the linker. As part of this workaround, +there is no need to adjust the compiler switches. + +From there, to be able to link your binaries with PIE and therefore +drop the :samp:`-no-pie` workaround, you'll need to get the identified +dependencies rebuilt with PIE enabled (compiled with :samp:`-fPIE` +and linked with :samp:`-pie`). + .. _A_GNU_Linux_debug_quirk: A GNU/Linux Debug Quirk diff --git a/gcc/ada/doc/gnat_ugn/the_gnat_compilation_model.rst b/gcc/ada/doc/gnat_ugn/the_gnat_compilation_model.rst index 3636703..e4639d9 100644 --- a/gcc/ada/doc/gnat_ugn/the_gnat_compilation_model.rst +++ b/gcc/ada/doc/gnat_ugn/the_gnat_compilation_model.rst @@ -168,7 +168,7 @@ GNAT also supports several other 8-bit coding schemes: *ISO 8859-15 (Latin-9)* ISO 8859-15 (Latin-9) letters allowed in identifiers, with uppercase and - lowercase equivalence + lowercase equivalence. .. index:: code page 437 (IBM PC) @@ -1778,8 +1778,8 @@ default, that contains calls to the elaboration procedures of those compilation unit that require them, followed by a call to the main program. This Ada program is compiled to generate the object file for the main program. The name of -the Ada file is :file:`b~xxx`.adb` (with the corresponding spec -:file:`b~xxx`.ads`) where ``xxx`` is the name of the +the Ada file is :file:`b~xxx.adb` (with the corresponding spec +:file:`b~xxx.ads`) where ``xxx`` is the name of the main program unit. Finally, the linker is used to build the resulting executable program, @@ -1974,7 +1974,7 @@ process (see the *Installing a Library with Project Files* section of the When project files are not an option, it is also possible, but not recommended, to install the library so that the sources needed to use the library are on the Ada source path and the ALI files & libraries be on the Ada Object path (see -:ref:`Search_Paths_and_the_Run-Time_Library_RTL`. Alternatively, the system +:ref:`Search_Paths_and_the_Run-Time_Library_RTL`). Alternatively, the system administrator can place general-purpose libraries in the default compiler paths, by specifying the libraries' location in the configuration files :file:`ada_source_path` and :file:`ada_object_path`. These configuration files @@ -3590,7 +3590,7 @@ Convention identifiers are recognized by GNAT: Ada compiler for further details on elaboration. However, it is not possible to mix the tasking run time of GNAT and - HP Ada 83, All the tasking operations must either be entirely within + HP Ada 83, all the tasking operations must either be entirely within GNAT compiled sections of the program, or entirely within HP Ada 83 compiled sections of the program. @@ -3715,14 +3715,14 @@ Convention identifiers are recognized by GNAT: to perform dimensional checks: - .. code-block:: ada + .. code-block:: ada - type Distance is new Long_Float; - type Time is new Long_Float; - type Velocity is new Long_Float; - function "/" (D : Distance; T : Time) - return Velocity; - pragma Import (Intrinsic, "/"); + type Distance is new Long_Float; + type Time is new Long_Float; + type Velocity is new Long_Float; + function "/" (D : Distance; T : Time) + return Velocity; + pragma Import (Intrinsic, "/"); This common idiom is often programmed with a generic definition and an explicit body. The pragma makes it simpler to introduce such declarations. @@ -3858,7 +3858,7 @@ considered: * Using GNAT and G++ from two different GCC installations: If both - compilers are on the :envvar`PATH`, the previous method may be used. It is + compilers are on the :envvar:`PATH`, the previous method may be used. It is important to note that environment variables such as :envvar:`C_INCLUDE_PATH`, :envvar:`GCC_EXEC_PREFIX`, :envvar:`BINUTILS_ROOT`, and @@ -4493,6 +4493,53 @@ finalizing the Ada run-time system along the way: return 0; } +.. _Partition_Wide_Settings: + +Partition-Wide Settings +----------------------- + +When building a mixed-language application it is important to be aware that +Ada enforces some partition-wide settings that may implicitly impact the +behavior of the other languages. + +This is the case of certain signals that are reserved to the +implementation to implement proper Ada semantics (such as the behavior +of ``abort`` statements). + +It means that the Ada part of the application may override signal handlers +that were previously installed by either the system or by other user code. + +If your application requires that either system or user signals be preserved +then you need to instruct the Ada part not to install its own signal handler. +This is done using ``pragma Interrupt_State`` that provides a general +mechanism for overriding such uses of interrupts. + +The set of interrupts for which the Ada run-time library sets a specific signal +handler is the following: + +* Ada.Interrupts.Names.SIGSEGV +* Ada.Interrupts.Names.SIGBUS +* Ada.Interrupts.Names.SIGFPE +* Ada.Interrupts.Names.SIGILL +* Ada.Interrupts.Names.SIGABRT + +The run-time library can be instructed not to install its signal handler for a +particular signal by using the configuration pragma ``Interrupt_State`` in the +Ada code. For example: + +.. code-block:: ada + + pragma Interrupt_State (Ada.Interrupts.Names.SIGSEGV, System); + pragma Interrupt_State (Ada.Interrupts.Names.SIGBUS, System); + pragma Interrupt_State (Ada.Interrupts.Names.SIGFPE, System); + pragma Interrupt_State (Ada.Interrupts.Names.SIGILL, System); + pragma Interrupt_State (Ada.Interrupts.Names.SIGABRT, System); + +Obviously, if the Ada run-time system cannot set these handlers it comes with the +drawback of not fully preserving Ada semantics. ``SIGSEGV``, ``SIGBUS``, ``SIGFPE`` +and ``SIGILL`` are used to raise corresponding Ada exceptions in the application, +while ``SIGABRT`` is used to asynchronously abort an action or a task. + .. _Generating_Ada_Bindings_for_C_and_C++_headers: Generating Ada Bindings for C and C++ headers diff --git a/gcc/ada/einfo-utils.adb b/gcc/ada/einfo-utils.adb index dc379cb..dad3a65 100644 --- a/gcc/ada/einfo-utils.adb +++ b/gcc/ada/einfo-utils.adb @@ -1017,7 +1017,9 @@ package body Einfo.Utils is -- Contract / subprogram variant / test case pragmas Is_CTC : constant Boolean := + Id = Pragma_Always_Terminates or else Id = Pragma_Contract_Cases or else + Id = Pragma_Exceptional_Cases or else Id = Pragma_Subprogram_Variant or else Id = Pragma_Test_Case; @@ -1505,11 +1507,10 @@ package body Einfo.Utils is Kind : constant Node_Kind := Nkind (N); begin - -- Identifiers, operator symbols, expanded names are entity names + -- Identifiers, operator symbols, expanded names are entity names. + -- (But not N_Character_Literal.) - return Kind = N_Identifier - or else Kind = N_Operator_Symbol - or else Kind = N_Expanded_Name + return Kind in N_Identifier | N_Operator_Symbol | N_Expanded_Name -- Attribute references are entity names if they refer to an entity. -- Note that we don't do this by testing for the presence of the @@ -1976,7 +1977,7 @@ package body Einfo.Utils is end if; exit when Ekind (D) = E_Discriminant - and then (Is_Completely_Hidden (D) = Is_Completely_Hidden (Id)); + and then Is_Completely_Hidden (D) = Is_Completely_Hidden (Id); end loop; return D; @@ -3171,7 +3172,7 @@ package body Einfo.Utils is Index := First_Index (Id); while Present (Index) loop Write_Attribute (" ", Etype (Index)); - Index := Next_Index (Index); + Next_Index (Index); end loop; Write_Eol; @@ -3212,53 +3213,49 @@ package body Einfo.Utils is -- Iterator Procedures -- ------------------------- - procedure Proc_Next_Component (N : in out Node_Id) is + procedure Next_Component (N : in out Node_Id) is begin N := Next_Component (N); - end Proc_Next_Component; + end Next_Component; - procedure Proc_Next_Component_Or_Discriminant (N : in out Node_Id) is + procedure Next_Component_Or_Discriminant (N : in out Node_Id) is begin - N := Next_Entity (N); - while Present (N) loop - exit when Ekind (N) in E_Component | E_Discriminant; - N := Next_Entity (N); - end loop; - end Proc_Next_Component_Or_Discriminant; + N := Next_Component_Or_Discriminant (N); + end Next_Component_Or_Discriminant; - procedure Proc_Next_Discriminant (N : in out Node_Id) is + procedure Next_Discriminant (N : in out Node_Id) is begin N := Next_Discriminant (N); - end Proc_Next_Discriminant; + end Next_Discriminant; - procedure Proc_Next_Formal (N : in out Node_Id) is + procedure Next_Formal (N : in out Node_Id) is begin N := Next_Formal (N); - end Proc_Next_Formal; + end Next_Formal; - procedure Proc_Next_Formal_With_Extras (N : in out Node_Id) is + procedure Next_Formal_With_Extras (N : in out Node_Id) is begin N := Next_Formal_With_Extras (N); - end Proc_Next_Formal_With_Extras; + end Next_Formal_With_Extras; - procedure Proc_Next_Index (N : in out Node_Id) is + procedure Next_Index (N : in out Node_Id) is begin N := Next_Index (N); - end Proc_Next_Index; + end Next_Index; - procedure Proc_Next_Inlined_Subprogram (N : in out Node_Id) is + procedure Next_Inlined_Subprogram (N : in out Node_Id) is begin N := Next_Inlined_Subprogram (N); - end Proc_Next_Inlined_Subprogram; + end Next_Inlined_Subprogram; - procedure Proc_Next_Literal (N : in out Node_Id) is + procedure Next_Literal (N : in out Node_Id) is begin N := Next_Literal (N); - end Proc_Next_Literal; + end Next_Literal; - procedure Proc_Next_Stored_Discriminant (N : in out Node_Id) is + procedure Next_Stored_Discriminant (N : in out Node_Id) is begin N := Next_Stored_Discriminant (N); - end Proc_Next_Stored_Discriminant; + end Next_Stored_Discriminant; end Einfo.Utils; diff --git a/gcc/ada/einfo-utils.ads b/gcc/ada/einfo-utils.ads index 896d8f0..fee771c 100644 --- a/gcc/ada/einfo-utils.ads +++ b/gcc/ada/einfo-utils.ads @@ -43,32 +43,24 @@ package Einfo.Utils is -- expressions, but those use different mechanisms; the fields here are not -- used. - function Alias (N : Entity_Id) return Entity_Id; - procedure Set_Alias (N : Entity_Id; Val : Entity_Id); - function Renamed_Entity (N : Entity_Id) return Entity_Id; - procedure Set_Renamed_Entity (N : Entity_Id; Val : Entity_Id); - function Renamed_Object (N : Entity_Id) return Node_Id; - procedure Set_Renamed_Object (N : Entity_Id; Val : Node_Id); - - function Renamed_Entity_Or_Object (N : Entity_Id) return Node_Id; + function Alias (N : Entity_Id) return Entity_Id with Inline; + procedure Set_Alias (N : Entity_Id; Val : Entity_Id) with Inline; + function Renamed_Entity (N : Entity_Id) return Entity_Id with Inline; + procedure Set_Renamed_Entity (N : Entity_Id; Val : Entity_Id) with Inline; + function Renamed_Object (N : Entity_Id) return Node_Id with Inline; + procedure Set_Renamed_Object (N : Entity_Id; Val : Node_Id) with Inline; + + function Renamed_Entity_Or_Object (N : Entity_Id) return Node_Id + with Inline; -- This getter is used when we don't know statically whether we want to -- call Renamed_Entity or Renamed_Object. procedure Set_Renamed_Object_Of_Possibly_Void - (N : Entity_Id; Val : Node_Id); + (N : Entity_Id; Val : Node_Id) with Inline; -- Set_Renamed_Object doesn't allow Void; this is used in the rare cases -- where we set the field of an entity that might be Void. It might be a -- good idea to get rid of calls to this. - pragma Inline (Alias); - pragma Inline (Set_Alias); - pragma Inline (Renamed_Entity); - pragma Inline (Set_Renamed_Entity); - pragma Inline (Renamed_Object); - pragma Inline (Set_Renamed_Object); - pragma Inline (Renamed_Entity_Or_Object); - pragma Inline (Set_Renamed_Object_Of_Possibly_Void); - ------------------- -- Type Synonyms -- ------------------- @@ -100,100 +92,53 @@ package Einfo.Utils is -- Is_Generic_Type where the Ekind does not provide the needed -- information). - function Is_Access_Object_Type (Id : E) return B; - function Is_Access_Type (Id : E) return B; - function Is_Access_Protected_Subprogram_Type (Id : E) return B; - function Is_Access_Subprogram_Type (Id : E) return B; - function Is_Aggregate_Type (Id : E) return B; - function Is_Anonymous_Access_Type (Id : E) return B; - function Is_Array_Type (Id : E) return B; - function Is_Assignable (Id : E) return B; - function Is_Class_Wide_Type (Id : E) return B; - function Is_Composite_Type (Id : E) return B; - function Is_Concurrent_Body (Id : E) return B; - function Is_Concurrent_Type (Id : E) return B; - function Is_Decimal_Fixed_Point_Type (Id : E) return B; - function Is_Digits_Type (Id : E) return B; - function Is_Discrete_Or_Fixed_Point_Type (Id : E) return B; - function Is_Discrete_Type (Id : E) return B; - function Is_Elementary_Type (Id : E) return B; - function Is_Entry (Id : E) return B; - function Is_Enumeration_Type (Id : E) return B; - function Is_Fixed_Point_Type (Id : E) return B; - function Is_Floating_Point_Type (Id : E) return B; - function Is_Formal (Id : E) return B; - function Is_Formal_Object (Id : E) return B; - function Is_Generic_Subprogram (Id : E) return B; - function Is_Generic_Unit (Id : E) return B; - function Is_Ghost_Entity (Id : E) return B; - function Is_Incomplete_Or_Private_Type (Id : E) return B; - function Is_Incomplete_Type (Id : E) return B; - function Is_Integer_Type (Id : E) return B; - function Is_Modular_Integer_Type (Id : E) return B; - function Is_Named_Access_Type (Id : E) return B; - function Is_Named_Number (Id : E) return B; - function Is_Numeric_Type (Id : E) return B; - function Is_Object (Id : E) return B; - function Is_Ordinary_Fixed_Point_Type (Id : E) return B; - function Is_Overloadable (Id : E) return B; - function Is_Private_Type (Id : E) return B; - function Is_Protected_Type (Id : E) return B; - function Is_Real_Type (Id : E) return B; - function Is_Record_Type (Id : E) return B; - function Is_Scalar_Type (Id : E) return B; - function Is_Signed_Integer_Type (Id : E) return B; - function Is_Subprogram (Id : E) return B; - function Is_Subprogram_Or_Entry (Id : E) return B; - function Is_Subprogram_Or_Generic_Subprogram (Id : E) return B; - function Is_Task_Type (Id : E) return B; - function Is_Type (Id : E) return B; - - pragma Inline (Is_Access_Object_Type); - pragma Inline (Is_Access_Type); - pragma Inline (Is_Access_Protected_Subprogram_Type); - pragma Inline (Is_Access_Subprogram_Type); - pragma Inline (Is_Aggregate_Type); - pragma Inline (Is_Anonymous_Access_Type); - pragma Inline (Is_Array_Type); - pragma Inline (Is_Assignable); - pragma Inline (Is_Class_Wide_Type); - pragma Inline (Is_Composite_Type); - pragma Inline (Is_Concurrent_Body); - pragma Inline (Is_Concurrent_Type); - pragma Inline (Is_Decimal_Fixed_Point_Type); - pragma Inline (Is_Digits_Type); - pragma Inline (Is_Discrete_Type); - pragma Inline (Is_Elementary_Type); - pragma Inline (Is_Entry); - pragma Inline (Is_Enumeration_Type); - pragma Inline (Is_Fixed_Point_Type); - pragma Inline (Is_Floating_Point_Type); - pragma Inline (Is_Formal); - pragma Inline (Is_Formal_Object); - pragma Inline (Is_Generic_Subprogram); - pragma Inline (Is_Generic_Unit); - pragma Inline (Is_Ghost_Entity); - pragma Inline (Is_Incomplete_Or_Private_Type); - pragma Inline (Is_Incomplete_Type); - pragma Inline (Is_Integer_Type); - pragma Inline (Is_Modular_Integer_Type); - pragma Inline (Is_Named_Access_Type); - pragma Inline (Is_Named_Number); - pragma Inline (Is_Numeric_Type); - pragma Inline (Is_Object); - pragma Inline (Is_Ordinary_Fixed_Point_Type); - pragma Inline (Is_Overloadable); - pragma Inline (Is_Private_Type); - pragma Inline (Is_Protected_Type); - pragma Inline (Is_Real_Type); - pragma Inline (Is_Record_Type); - pragma Inline (Is_Scalar_Type); - pragma Inline (Is_Signed_Integer_Type); - pragma Inline (Is_Subprogram); - pragma Inline (Is_Subprogram_Or_Entry); - pragma Inline (Is_Subprogram_Or_Generic_Subprogram); - pragma Inline (Is_Task_Type); - pragma Inline (Is_Type); + function Is_Access_Object_Type (Id : E) return B with Inline; + function Is_Access_Type (Id : E) return B with Inline; + function Is_Access_Protected_Subprogram_Type (Id : E) return B with Inline; + function Is_Access_Subprogram_Type (Id : E) return B with Inline; + function Is_Aggregate_Type (Id : E) return B with Inline; + function Is_Anonymous_Access_Type (Id : E) return B with Inline; + function Is_Array_Type (Id : E) return B with Inline; + function Is_Assignable (Id : E) return B with Inline; + function Is_Class_Wide_Type (Id : E) return B with Inline; + function Is_Composite_Type (Id : E) return B with Inline; + function Is_Concurrent_Body (Id : E) return B with Inline; + function Is_Concurrent_Type (Id : E) return B with Inline; + function Is_Decimal_Fixed_Point_Type (Id : E) return B with Inline; + function Is_Digits_Type (Id : E) return B with Inline; + function Is_Discrete_Or_Fixed_Point_Type (Id : E) return B with Inline; + function Is_Discrete_Type (Id : E) return B with Inline; + function Is_Elementary_Type (Id : E) return B with Inline; + function Is_Entry (Id : E) return B with Inline; + function Is_Enumeration_Type (Id : E) return B with Inline; + function Is_Fixed_Point_Type (Id : E) return B with Inline; + function Is_Floating_Point_Type (Id : E) return B with Inline; + function Is_Formal (Id : E) return B with Inline; + function Is_Formal_Object (Id : E) return B with Inline; + function Is_Generic_Subprogram (Id : E) return B with Inline; + function Is_Generic_Unit (Id : E) return B with Inline; + function Is_Ghost_Entity (Id : E) return B with Inline; + function Is_Incomplete_Or_Private_Type (Id : E) return B with Inline; + function Is_Incomplete_Type (Id : E) return B with Inline; + function Is_Integer_Type (Id : E) return B with Inline; + function Is_Modular_Integer_Type (Id : E) return B with Inline; + function Is_Named_Access_Type (Id : E) return B with Inline; + function Is_Named_Number (Id : E) return B with Inline; + function Is_Numeric_Type (Id : E) return B with Inline; + function Is_Object (Id : E) return B with Inline; + function Is_Ordinary_Fixed_Point_Type (Id : E) return B with Inline; + function Is_Overloadable (Id : E) return B with Inline; + function Is_Private_Type (Id : E) return B with Inline; + function Is_Protected_Type (Id : E) return B with Inline; + function Is_Real_Type (Id : E) return B with Inline; + function Is_Record_Type (Id : E) return B with Inline; + function Is_Scalar_Type (Id : E) return B with Inline; + function Is_Signed_Integer_Type (Id : E) return B with Inline; + function Is_Subprogram (Id : E) return B with Inline; + function Is_Subprogram_Or_Entry (Id : E) return B with Inline; + function Is_Subprogram_Or_Generic_Subprogram (Id : E) return B with Inline; + function Is_Task_Type (Id : E) return B with Inline; + function Is_Type (Id : E) return B with Inline; ------------------------------------- -- Synthesized Attribute Functions -- @@ -202,17 +147,17 @@ package Einfo.Utils is -- The functions in this section synthesize attributes from the tree, -- so they do not correspond to defined fields in the entity itself. - function Address_Clause (Id : E) return Node_Id; - function Aft_Value (Id : E) return U; - function Alignment_Clause (Id : E) return Node_Id; - function Base_Type (Id : E) return E; - function Declaration_Node (Id : E) return Node_Id; - function Designated_Type (Id : E) return E; - function Entry_Index_Type (Id : E) return E; - function First_Component (Id : E) return Entity_Id; - function First_Component_Or_Discriminant (Id : E) return Entity_Id; - function First_Formal (Id : E) return Entity_Id; - function First_Formal_With_Extras (Id : E) return Entity_Id; + function Address_Clause (Id : E) return Node_Id with Inline; + function Aft_Value (Id : E) return U; + function Alignment_Clause (Id : E) return Node_Id with Inline; + function Base_Type (Id : E) return E with Inline; + function Declaration_Node (Id : E) return Node_Id; + function Designated_Type (Id : E) return E; + function Entry_Index_Type (Id : E) return E; + function First_Component (Id : E) return Entity_Id; + function First_Component_Or_Discriminant (Id : E) return Entity_Id; + function First_Formal (Id : E) return Entity_Id; + function First_Formal_With_Extras (Id : E) return Entity_Id; function Float_Rep (N : Entity_Id) return F with Inline, Pre => @@ -223,117 +168,89 @@ package Einfo.Utils is Ignore_N in E_Void_Id | Float_Kind_Id; - function Has_Attach_Handler (Id : E) return B; - function Has_DIC (Id : E) return B; - function Has_Entries (Id : E) return B; - function Has_Foreign_Convention (Id : E) return B; - function Has_Interrupt_Handler (Id : E) return B; - function Has_Invariants (Id : E) return B; - function Has_Limited_View (Id : E) return B; - function Has_Non_Limited_View (Id : E) return B; - function Has_Non_Null_Abstract_State (Id : E) return B; - function Has_Non_Null_Visible_Refinement (Id : E) return B; - function Has_Null_Abstract_State (Id : E) return B; - function Has_Null_Visible_Refinement (Id : E) return B; - function Implementation_Base_Type (Id : E) return E; - function Is_Base_Type (Id : E) return B; + function Has_Attach_Handler (Id : E) return B; + function Has_DIC (Id : E) return B; + function Has_Entries (Id : E) return B; + function Has_Foreign_Convention (Id : E) return B with Inline; + function Has_Interrupt_Handler (Id : E) return B; + function Has_Invariants (Id : E) return B; + function Has_Limited_View (Id : E) return B; + function Has_Non_Limited_View (Id : E) return B with Inline; + function Has_Non_Null_Abstract_State (Id : E) return B; + function Has_Non_Null_Visible_Refinement (Id : E) return B; + function Has_Null_Abstract_State (Id : E) return B; + function Has_Null_Visible_Refinement (Id : E) return B; + function Implementation_Base_Type (Id : E) return E; + function Is_Base_Type (Id : E) return B with Inline; -- Note that Is_Base_Type returns True for nontypes - function Is_Boolean_Type (Id : E) return B; - function Is_Constant_Object (Id : E) return B; - function Is_Controlled (Id : E) return B; - function Is_Discriminal (Id : E) return B; - function Is_Dynamic_Scope (Id : E) return B; - function Is_Elaboration_Target (Id : E) return B; - function Is_External_State (Id : E) return B; - function Is_Finalizer (Id : E) return B; - function Is_Full_Access (Id : E) return B; - function Is_Null_State (Id : E) return B; - function Is_Package_Or_Generic_Package (Id : E) return B; - function Is_Packed_Array (Id : E) return B; - function Is_Prival (Id : E) return B; - function Is_Protected_Component (Id : E) return B; - function Is_Protected_Interface (Id : E) return B; - function Is_Protected_Record_Type (Id : E) return B; - function Is_Relaxed_Initialization_State (Id : E) return B; - function Is_Standard_Character_Type (Id : E) return B; - function Is_Standard_String_Type (Id : E) return B; - function Is_String_Type (Id : E) return B; - function Is_Synchronized_Interface (Id : E) return B; - function Is_Synchronized_State (Id : E) return B; - function Is_Task_Interface (Id : E) return B; - function Is_Task_Record_Type (Id : E) return B; - function Is_Wrapper_Package (Id : E) return B; - function Last_Formal (Id : E) return Entity_Id; - function Machine_Emax_Value (Id : E) return U; - function Machine_Emin_Value (Id : E) return U; - function Machine_Mantissa_Value (Id : E) return U; - function Machine_Radix_Value (Id : E) return U; - function Model_Emin_Value (Id : E) return U; - function Model_Epsilon_Value (Id : E) return R; - function Model_Mantissa_Value (Id : E) return U; - function Model_Small_Value (Id : E) return R; - function Next_Component (Id : E) return Entity_Id; - function Next_Component_Or_Discriminant (Id : E) return Entity_Id; - function Next_Discriminant (Id : E) return Entity_Id; - function Next_Formal (Id : E) return Entity_Id; - function Next_Formal_With_Extras (Id : E) return Entity_Id; - function Next_Index (Id : N) return Node_Id; - function Next_Literal (Id : E) return Entity_Id; - function Next_Stored_Discriminant (Id : E) return Entity_Id; - function Number_Dimensions (Id : E) return Pos; - function Number_Entries (Id : E) return Nat; - function Number_Formals (Id : E) return Pos; - function Object_Size_Clause (Id : E) return Node_Id; - function Parameter_Mode (Id : E) return Formal_Kind; - function Partial_Refinement_Constituents (Id : E) return L; - function Primitive_Operations (Id : E) return L; - function Root_Type (Id : E) return E; - function Safe_Emax_Value (Id : E) return U; - function Safe_First_Value (Id : E) return R; - function Safe_Last_Value (Id : E) return R; - function Size_Clause (Id : E) return Node_Id; - function Stream_Size_Clause (Id : E) return N; - function Type_High_Bound (Id : E) return N; - function Type_Low_Bound (Id : E) return N; - function Underlying_Type (Id : E) return Entity_Id; - - function Scope_Depth (Id : E) return U; - function Scope_Depth_Set (Id : E) return B; - - function Scope_Depth_Default_0 (Id : E) return U; + function Is_Boolean_Type (Id : E) return B with Inline; + function Is_Constant_Object (Id : E) return B with Inline; + function Is_Controlled (Id : E) return B with Inline; + function Is_Discriminal (Id : E) return B with Inline; + function Is_Dynamic_Scope (Id : E) return B; + function Is_Elaboration_Target (Id : E) return B; + function Is_External_State (Id : E) return B; + function Is_Finalizer (Id : E) return B with Inline; + function Is_Full_Access (Id : E) return B with Inline; + function Is_Null_State (Id : E) return B; + function Is_Package_Or_Generic_Package (Id : E) return B with Inline; + function Is_Packed_Array (Id : E) return B with Inline; + function Is_Prival (Id : E) return B with Inline; + function Is_Protected_Component (Id : E) return B with Inline; + function Is_Protected_Interface (Id : E) return B; + function Is_Protected_Record_Type (Id : E) return B with Inline; + function Is_Relaxed_Initialization_State (Id : E) return B; + function Is_Standard_Character_Type (Id : E) return B; + function Is_Standard_String_Type (Id : E) return B; + function Is_String_Type (Id : E) return B with Inline; + function Is_Synchronized_Interface (Id : E) return B; + function Is_Synchronized_State (Id : E) return B; + function Is_Task_Interface (Id : E) return B; + function Is_Task_Record_Type (Id : E) return B with Inline; + function Is_Wrapper_Package (Id : E) return B with Inline; + function Last_Formal (Id : E) return Entity_Id; + function Machine_Emax_Value (Id : E) return U; + function Machine_Emin_Value (Id : E) return U; + function Machine_Mantissa_Value (Id : E) return U; + function Machine_Radix_Value (Id : E) return U; + function Model_Emin_Value (Id : E) return U; + function Model_Epsilon_Value (Id : E) return R; + function Model_Mantissa_Value (Id : E) return U; + function Model_Small_Value (Id : E) return R; + function Next_Component (Id : E) return Entity_Id; + function Next_Component_Or_Discriminant (Id : E) return Entity_Id; + function Next_Discriminant (Id : E) return Entity_Id; + function Next_Formal (Id : E) return Entity_Id; + function Next_Formal_With_Extras (Id : E) return Entity_Id; + function Next_Index (Id : N) return Node_Id; + function Next_Literal (Id : E) return Entity_Id; + function Next_Stored_Discriminant (Id : E) return Entity_Id; + function Number_Dimensions (Id : E) return Pos; + function Number_Entries (Id : E) return Nat; + function Number_Formals (Id : E) return Pos; + function Object_Size_Clause (Id : E) return Node_Id; + function Parameter_Mode (Id : E) return Formal_Kind; + function Partial_Refinement_Constituents (Id : E) return L; + function Primitive_Operations (Id : E) return L; + function Root_Type (Id : E) return E; + function Safe_Emax_Value (Id : E) return U; + function Safe_First_Value (Id : E) return R; + function Safe_Last_Value (Id : E) return R; + function Size_Clause (Id : E) return Node_Id with Inline; + function Stream_Size_Clause (Id : E) return N with Inline; + function Type_High_Bound (Id : E) return N with Inline; + function Type_Low_Bound (Id : E) return N with Inline; + function Underlying_Type (Id : E) return Entity_Id; + + function Scope_Depth (Id : E) return U with Inline; + function Scope_Depth_Set (Id : E) return B with Inline; + + function Scope_Depth_Default_0 (Id : E) return U; -- In rare cases, the Scope_Depth_Value (queried by Scope_Depth) is -- not correctly set before querying it; this may be used instead of -- Scope_Depth in such cases. It returns Uint_0 if the Scope_Depth_Value -- has not been set. See documentation in Einfo. - pragma Inline (Address_Clause); - pragma Inline (Alignment_Clause); - pragma Inline (Base_Type); - pragma Inline (Has_Foreign_Convention); - pragma Inline (Has_Non_Limited_View); - pragma Inline (Is_Base_Type); - pragma Inline (Is_Boolean_Type); - pragma Inline (Is_Constant_Object); - pragma Inline (Is_Controlled); - pragma Inline (Is_Discriminal); - pragma Inline (Is_Finalizer); - pragma Inline (Is_Full_Access); - pragma Inline (Is_Null_State); - pragma Inline (Is_Package_Or_Generic_Package); - pragma Inline (Is_Packed_Array); - pragma Inline (Is_Prival); - pragma Inline (Is_Protected_Component); - pragma Inline (Is_Protected_Record_Type); - pragma Inline (Is_String_Type); - pragma Inline (Is_Task_Record_Type); - pragma Inline (Is_Wrapper_Package); - pragma Inline (Scope_Depth); - pragma Inline (Scope_Depth_Set); - pragma Inline (Size_Clause); - pragma Inline (Stream_Size_Clause); - pragma Inline (Type_High_Bound); - pragma Inline (Type_Low_Bound); - ------------------------------------------ -- Type Representation Attribute Fields -- ------------------------------------------ @@ -451,56 +368,17 @@ package Einfo.Utils is -- Iterators -- --------------- - -- The call to Next_xxx (obj) is equivalent to obj := Next_xxx (obj) - -- We define the set of Proc_Next_xxx routines simply for the purposes - -- of inlining them without necessarily inlining the function. - - procedure Proc_Next_Component (N : in out Node_Id); - procedure Proc_Next_Component_Or_Discriminant (N : in out Node_Id); - procedure Proc_Next_Discriminant (N : in out Node_Id); - procedure Proc_Next_Formal (N : in out Node_Id); - procedure Proc_Next_Formal_With_Extras (N : in out Node_Id); - procedure Proc_Next_Index (N : in out Node_Id); - procedure Proc_Next_Inlined_Subprogram (N : in out Node_Id); - procedure Proc_Next_Literal (N : in out Node_Id); - procedure Proc_Next_Stored_Discriminant (N : in out Node_Id); - - pragma Inline (Proc_Next_Component); - pragma Inline (Proc_Next_Component_Or_Discriminant); - pragma Inline (Proc_Next_Discriminant); - pragma Inline (Proc_Next_Formal); - pragma Inline (Proc_Next_Formal_With_Extras); - pragma Inline (Proc_Next_Index); - pragma Inline (Proc_Next_Inlined_Subprogram); - pragma Inline (Proc_Next_Literal); - pragma Inline (Proc_Next_Stored_Discriminant); - - procedure Next_Component (N : in out Node_Id) - renames Proc_Next_Component; - - procedure Next_Component_Or_Discriminant (N : in out Node_Id) - renames Proc_Next_Component_Or_Discriminant; + -- Next_xxx (obj) is equivalent to obj := Next_xxx (obj) - procedure Next_Discriminant (N : in out Node_Id) - renames Proc_Next_Discriminant; - - procedure Next_Formal (N : in out Node_Id) - renames Proc_Next_Formal; - - procedure Next_Formal_With_Extras (N : in out Node_Id) - renames Proc_Next_Formal_With_Extras; - - procedure Next_Index (N : in out Node_Id) - renames Proc_Next_Index; - - procedure Next_Inlined_Subprogram (N : in out Node_Id) - renames Proc_Next_Inlined_Subprogram; - - procedure Next_Literal (N : in out Node_Id) - renames Proc_Next_Literal; - - procedure Next_Stored_Discriminant (N : in out Node_Id) - renames Proc_Next_Stored_Discriminant; + procedure Next_Component (N : in out Node_Id) with Inline; + procedure Next_Component_Or_Discriminant (N : in out Node_Id) with Inline; + procedure Next_Discriminant (N : in out Node_Id) with Inline; + procedure Next_Formal (N : in out Node_Id) with Inline; + procedure Next_Formal_With_Extras (N : in out Node_Id) with Inline; + procedure Next_Index (N : in out Node_Id) with Inline; + procedure Next_Inlined_Subprogram (N : in out Node_Id) with Inline; + procedure Next_Literal (N : in out Node_Id) with Inline; + procedure Next_Stored_Discriminant (N : in out Node_Id) with Inline; --------------------------- -- Testing Warning Flags -- @@ -561,6 +439,7 @@ package Einfo.Utils is -- node, otherwise Empty is returned. The following contract pragmas that -- appear in N_Contract nodes are also handled by this routine: -- Abstract_State + -- Always_Terminates -- Async_Readers -- Async_Writers -- Attach_Handler @@ -569,6 +448,7 @@ package Einfo.Utils is -- Depends -- Effective_Reads -- Effective_Writes + -- Exceptional_Cases -- Global -- Initial_Condition -- Initializes @@ -622,7 +502,7 @@ package Einfo.Utils is -- is the name of a class_wide type whose root is incomplete, return the -- corresponding full declaration, else return T itself. - function Is_Entity_Name (N : Node_Id) return Boolean; + function Is_Entity_Name (N : Node_Id) return Boolean with Inline; -- Test if the node N is the name of an entity (i.e. is an identifier, -- expanded name, or an attribute reference that returns an entity). @@ -661,8 +541,6 @@ package Einfo.Utils is -- Also, if the Etype of E is set and is an anonymous access type with -- no convention set, this anonymous type inherits the convention of E. - pragma Inline (Is_Entity_Name); - ---------------------------------- -- Debugging Output Subprograms -- ---------------------------------- diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index a200d63..b356b76 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -864,29 +864,12 @@ package Einfo is -- and IN OUT parameters in the absence of errors). -- Delay_Cleanups --- Defined in entities that have finalization lists (subprograms --- blocks, and tasks). Set if there are pending generic body --- instantiations for the corresponding entity. If this flag is --- set, then generation of cleanup actions for the corresponding --- entity must be delayed, since the insertion of the generic body --- may affect cleanup generation (see Inline for further details). - --- Delay_Subprogram_Descriptors --- Defined in entities for which exception subprogram descriptors --- are generated (subprograms, package declarations and package --- bodies). Defined if there are pending generic body instantiations --- for the corresponding entity. If this flag is set, then generation --- of the subprogram descriptor for the corresponding entities must --- be delayed, since the insertion of the generic body may add entries --- to the list of handlers. --- --- Note: for subprograms, Delay_Subprogram_Descriptors is set if and --- only if Delay_Cleanups is set. But Delay_Cleanups can be set for a --- a block (in which case Delay_Subprogram_Descriptors is set for the --- containing subprogram). In addition Delay_Subprogram_Descriptors is --- set for a library level package declaration or body which contains --- delayed instantiations (in this case the descriptor refers to the --- enclosing elaboration procedure). +-- Defined in entities that have finalization lists (subprograms, blocks +-- and tasks) or finalizers (package specs and bodies). Set if there are +-- pending package body instantiations for the corresponding entity. If +-- it is set, then generation of cleanup actions for the corresponding +-- entity must be delayed, since the insertion of the package bodies may +-- affect cleanup generation (see Inline for further details). -- Delta_Value -- Defined in fixed and decimal types. Points to a universal real @@ -1148,6 +1131,8 @@ package Einfo is -- object for task entry calls and a Communications_Block object -- in the case of protected entry calls. In both cases the objects -- are declared in outer scopes to this block. +-- This is also defined in labels, because we temporarily set the +-- Ekind of an E_Block to E_Label in Analyze_Implicit_Label_Declaration. -- Entry_Component -- Defined in formal parameters (in, in out and out parameters). Used @@ -1346,12 +1331,14 @@ package Einfo is -- find the first discriminant if discriminants are present. -- First_Entity --- Defined in all entities which act as scopes to which a list of --- associated entities is attached (blocks, class subtypes and types, --- entries, functions, loops, packages, procedures, protected objects, --- record types and subtypes, private types, task types and subtypes). --- Points to a list of associated entities using the Next_Entity field --- as a chain pointer with Empty marking the end of the list. +-- Defined in all entities that act as scopes to which a list of +-- associated entities is attached, and also in all [sub]types. Some +-- entities are both; for example E_Record_Type acts as a scope and +-- is a type. [Sub]types that do not act as scopes (e.g. scalars) are +-- included to make it more convenient to Mutate_Entity between type +-- kinds. Points to a list of associated entities linked through the +-- Next_Entity field with Empty marking end-of-list. +-- See also Last_Entity. -- First_Exit_Statement -- Defined in E_Loop entity. The exit statements for a loop are chained @@ -1690,6 +1677,10 @@ package Einfo is -- Exp_Dbug for a full description of the use of this flag and also the -- related flag Has_Qualified_Name. +-- Has_Ghost_Predicate_Aspect +-- Defined in all types and subtypes. Set if a Ghost_Predicate aspect +-- was explicitly applied to the type. + -- Has_Gigi_Rep_Item -- Defined in all entities. Set if the rep item chain (referenced by -- First_Rep_Item and linked through the Next_Rep_Item chain) contains a @@ -1978,7 +1969,7 @@ package Einfo is -- is defined for the type. -- Has_Private_Ancestor --- Applies to type extensions. True if some ancestor is derived from a +-- Applies to derived record types. True if an ancestor is derived from a -- private type, making some components invisible and aggregates illegal. -- This flag is set at the point of derivation. The legality of the -- aggregate must be rechecked because it also depends on the visibility @@ -3102,6 +3093,18 @@ package Einfo is -- procedure which verifies the invariants of the partial view of a -- private type or private extension. +-- Is_Not_Self_Hidden +-- Defined in all entities. Roughly speaking, this is False if the +-- declaration of the entity is hidden from all visibility because +-- we are within its declaration, as defined by 8.3(16-18). When +-- we reach the end of the declaration or other place defined by +-- 8.3(16-18), this is set to True. However, this flag is not used +-- for most overloaded declarations (but is used for enumeration +-- literals), and is also used for other cases of premature usage +-- such as defined in 3.8(10) for record components and the like. +-- In addition, there are cases involving discriminants where we +-- set this True, then temporarily False again. + -- Is_Potentially_Use_Visible -- Defined in all entities. Set if entity is potentially use visible, -- i.e. it is defined in a package that appears in a currently active @@ -3510,12 +3513,8 @@ package Einfo is -- statements whose value is not used. -- Last_Entity --- Defined in all entities which act as scopes to which a list of --- associated entities is attached (blocks, class subtypes and types, --- entries, functions, loops, packages, procedures, protected objects, --- record types and subtypes, private types, task types and subtypes). --- Points to the last entry in the list of associated entities chained --- through the Next_Entity field. Empty if no entities are chained. +-- Defined for the same entity kinds as First_Entity. Last_Entity +-- is the last entry in the list. Empty if no entities are chained. -- Last_Formal (synthesized) -- Applies to subprograms and subprogram types, and also in entries @@ -3538,7 +3537,7 @@ package Einfo is -- field may be set as a result of a linker section pragma applied to the -- type of the object. --- Lit_Hash +-- Lit_Hash [root type only] -- Defined in enumeration types and subtypes. Non-empty only for the -- case of an enumeration root type, where it contains the entity for -- the generated hash function. See unit Exp_Imgv for full details of @@ -4331,14 +4330,14 @@ package Einfo is -- concurrent types, private types and entries, and also to record types, -- i.e. to any entity that can appear on the scope stack. Yields the -- scope depth value, which for those entities other than records is --- simply the scope depth value, for record entities, it is the --- Scope_Depth of the record scope. +-- simply the Scope_Depth_Value, and for record entities, is the +-- Scope_Depth of the record's scope. -- Scope_Depth_Value -- Defined in program units, blocks, loops, return statements, -- concurrent types, private types and entries. -- Indicates the number of scopes that statically enclose the declaration --- of the unit or type. Library units have a depth of zero. Note that +-- of the unit or type. Library units have a depth of one. Note that -- record types can act as scopes but do NOT have this field set (see -- Scope_Depth above). Queries should normally be via Scope_Depth, -- and not call Scope_Depth_Value directly. @@ -4535,11 +4534,9 @@ package Einfo is -- share the same storage pool). -- Stored_Constraint --- Defined in entities that can have discriminants (concurrent types --- subtypes, record types and subtypes, private types and subtypes, --- limited private types and subtypes and incomplete types). Points --- to an element list containing the expressions for each of the --- stored discriminants for the record (sub)type. +-- Defined in type entities. Points to an element list containing the +-- expressions for each of the stored discriminants, if any, for the +-- (sub)type. -- Stores_Attribute_Old_Prefix -- Defined in constants, variables, and types which are created during @@ -4769,7 +4766,7 @@ package Einfo is -- Wrapped_Statements -- Defined in functions, procedures, entries, and entry families. Refers --- to the entity of the _Wrapped_Statements procedure which gets +-- 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. @@ -4778,7 +4775,8 @@ package Einfo is -- Defined in subprogram entities. Set on wrappers created to handle -- inherited class-wide pre/post conditions that call overridden -- primitives. It references the parent primitive that has the --- class-wide pre/post conditions. +-- class-wide pre/post conditions. LSP stands for Liskov Substitution +-- Principle. --------------------------- -- Renaming and Aliasing -- @@ -4949,6 +4947,7 @@ package Einfo is -- Is_Obsolescent -- Is_Package_Body_Entity -- Is_Packed_Array_Impl_Type + -- Is_Not_Self_Hidden -- Is_Potentially_Use_Visible -- Is_Preelaborated -- Is_Primitive_Wrapper @@ -5031,6 +5030,7 @@ package Einfo is -- Has_Delayed_Rep_Aspects -- Has_Discriminants -- Has_Dynamic_Predicate_Aspect + -- Has_Ghost_Predicate_Aspect -- Has_Independent_Components (base type only) -- Has_Inheritable_Invariants (base type only) -- Has_Inherited_DIC (base type only) @@ -5542,7 +5542,6 @@ package Einfo is -- Contains_Ignored_Ghost_Code -- Default_Expressions_Processed -- Delay_Cleanups - -- Delay_Subprogram_Descriptors -- Discard_Names -- Elaboration_Entity_Required -- Has_Completion @@ -5668,6 +5667,7 @@ package Einfo is -- E_Label -- Renamed_Object $$$ -- Renamed_Entity $$$ + -- Entry_Cancel_Parameter -- Enclosing_Scope -- Reachable @@ -5791,7 +5791,6 @@ package Einfo is -- Body_Needed_For_Inlining -- Body_Needed_For_SAL -- Contains_Ignored_Ghost_Code - -- Delay_Subprogram_Descriptors -- Discard_Names -- Elaborate_Body_Desirable (non-generic case only) -- Elaboration_Entity_Required @@ -5834,7 +5833,6 @@ package Einfo is -- SPARK_Pragma -- SPARK_Aux_Pragma -- Contains_Ignored_Ghost_Code - -- Delay_Subprogram_Descriptors -- Ignore_SPARK_Mode_Pragmas -- SPARK_Aux_Pragma_Inherited -- SPARK_Pragma_Inherited @@ -5908,7 +5906,6 @@ package Einfo is -- Elaboration_Entity_Required -- Default_Expressions_Processed -- Delay_Cleanups - -- Delay_Subprogram_Descriptors -- Discard_Names -- Has_Completion -- Has_Expanded_Contract (non-generic case only) diff --git a/gcc/ada/err_vars.ads b/gcc/ada/err_vars.ads index e73e9fb..e84efb6 100644 --- a/gcc/ada/err_vars.ads +++ b/gcc/ada/err_vars.ads @@ -100,6 +100,11 @@ package Err_Vars is Error_Msg_Uint_2 : Uint := No_Uint; -- Uint values for ^ insertion characters in message + Error_Msg_Code_Digits : constant := 4; + Error_Msg_Code : Nat range 0 .. 10 ** Error_Msg_Code_Digits - 1; + -- Nat value for [] insertion sequence in message, where a value of zero + -- indicates the absence of an error code. + -- WARNING: There is a matching C declaration of these variables in fe.h Error_Msg_Sloc : Source_Ptr; diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb index 96b56ff..adc2608 100644 --- a/gcc/ada/errout.adb +++ b/gcc/ada/errout.adb @@ -50,6 +50,7 @@ with Sinfo.Nodes; use Sinfo.Nodes; with Sinfo.Utils; use Sinfo.Utils; with Snames; use Snames; with Stand; use Stand; +with Stringt; use Stringt; with Stylesw; use Stylesw; with System.OS_Lib; with Uname; use Uname; @@ -139,6 +140,11 @@ package body Errout is -- indicates if there are errors attached to the line, which forces -- listing on, even in the presence of pragma List (Off). + function Paren_Required (N : Node_Id) return Boolean; + -- Subsidiary to First_Sloc and Last_Sloc. Returns True iff parentheses + -- around node N are required by the Ada syntax, e.g. when N is an + -- expression of a qualified expression. + procedure Set_Msg_Insertion_Column; -- Handle column number insertion (@ insertion character) @@ -1441,6 +1447,22 @@ package body Errout is raise Unrecoverable_Error; end if; end if; + + if Has_Error_Code then + declare + Msg : constant String := + "launch ""gnatprove --explain=[]"" for more information"; + begin + Prescan_Message (Msg); + Has_Error_Code := False; + Error_Msg_Internal + (Msg => Msg, + Span => Span, + Opan => Opan, + Msg_Cont => True, + Node => Node); + end; + end if; end Error_Msg_Internal; ----------------- @@ -1763,6 +1785,24 @@ package body Errout is Loc : constant Source_Ptr := Sloc (Norig); begin + -- ??? For assignments that require accessiblity checks, e.g.: + -- + -- Y := Func (123); + -- + -- the function call gets an extra actual parameter association with + -- Sloc of the assigned name "Y": + -- + -- Y := Func (123, A8b => 2); + -- + -- We can simply ignore those extra actual parameters when + -- determining the Sloc range of the "Func (123)" expression. + + if Nkind (N) = N_Parameter_Association + and then Is_Accessibility_Actual (N) + then + return Skip; + end if; + -- Check for earlier if Loc < Eloc @@ -1845,11 +1885,12 @@ package body Errout is ---------------- function First_Sloc (N : Node_Id) return Source_Ptr is - SI : constant Source_File_Index := Source_Index (Get_Source_Unit (N)); - SF : constant Source_Ptr := Source_First (SI); - SL : constant Source_Ptr := Source_Last (SI); - F : Node_Id; - S : Source_Ptr; + SI : constant Source_File_Index := Get_Source_File_Index (Sloc (N)); + SF : constant Source_Ptr := Source_First (SI); + SL : constant Source_Ptr := Source_Last (SI); + Src : constant Source_Buffer_Ptr := Source_Text (SI); + F : Node_Id; + S : Source_Ptr; begin F := First_Node (N); @@ -1868,6 +1909,12 @@ package body Errout is -- values), but this is only for an error message so it is good enough. Node_Loop : loop + -- Include parentheses around the top node, except when they are + -- required by the syntax of the parent node. + + exit Node_Loop when F = N + and then Paren_Required (N); + Paren_Loop : for J in 1 .. Paren_Count (F) loop -- We don't look more than 12 characters behind the current @@ -1876,11 +1923,11 @@ package body Errout is Search_Loop : for K in 1 .. 12 loop exit Search_Loop when S = SF; - if Source_Text (SI) (S - 1) = '(' then + if Src (S - 1) = '(' then S := S - 1; exit Search_Loop; - elsif Source_Text (SI) (S - 1) <= ' ' then + elsif Src (S - 1) <= ' ' then S := S - 1; else @@ -1963,11 +2010,28 @@ package body Errout is --------------- function Last_Sloc (N : Node_Id) return Source_Ptr is - SI : constant Source_File_Index := Source_Index (Get_Source_Unit (N)); - SF : constant Source_Ptr := Source_First (SI); - SL : constant Source_Ptr := Source_Last (SI); - F : Node_Id; - S : Source_Ptr; + procedure Skip_Char (S : in out Source_Ptr); + -- Skip one character of the source buffer at location S + + --------------- + -- Skip_Char -- + --------------- + + procedure Skip_Char (S : in out Source_Ptr) is + begin + S := S + 1; + end Skip_Char; + + -- Local variables + + SI : constant Source_File_Index := Get_Source_File_Index (Sloc (N)); + SF : constant Source_Ptr := Source_First (SI); + SL : constant Source_Ptr := Source_Last (SI); + Src : constant Source_Buffer_Ptr := Source_Text (SI); + F : Node_Id; + S : Source_Ptr; + + -- Start of processing for Last_Sloc begin F := Last_Node (N); @@ -1977,21 +2041,182 @@ package body Errout is return S; end if; - -- Skip past an identifier + -- For string and character literals simply forward the sloc by their + -- length including the closing quotes. Perhaps we should do something + -- special for multibyte characters, but this code is only used to emit + -- error messages, so it is not worth the effort. - while S in SF .. SL - 1 - and then Source_Text (SI) (S + 1) - in - '0' .. '9' | 'a' .. 'z' | 'A' .. 'Z' | '.' | '_' - loop - S := S + 1; - end loop; + case Nkind (F) is + when N_String_Literal => + return S + Source_Ptr (String_Length (Strval (F))) + 1; + + when N_Character_Literal => + return S + 2; + + -- Skip past integer literals, both decimal and based, integer and + -- real. We can't greedily accept all allowed character, because + -- we would consme too many of them in expressions like "123+ABC" + -- or "123..456", so we follow quite precisely the Ada grammar and + -- consume different characters depending on the context. + + when N_Integer_Literal => + + -- Skip past the initial numeral, which either leads the decimal + -- literal or is the base of a based literal. + + while S < SL + and then Src (S + 1) in '0' .. '9' | '_' + loop + Skip_Char (S); + end loop; + + -- Skip past #based_numeral#, if present + + if S < SL + and then Src (S + 1) = '#' + then + Skip_Char (S); + + while S < SL + and then + Src (S + 1) in '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' | '_' + loop + Skip_Char (S); + end loop; + + if S < SL + and then Src (S + 1) = '#' + then + Skip_Char (S); + end if; + end if; + + -- Skip past exponent, if present + + if S < SL + and then Src (S + 1) in 'e' | 'E' + then + Skip_Char (S); + + -- For positive exponents the plus sign is optional, but we + -- can simply skip past both plus and minus. + + if S < SL + and then Src (S + 1) in '+' | '-' + then + Skip_Char (S); + end if; + + -- Skip past the numeral part + + while S < SL + and then Src (S + 1) in '0' .. '9' | '_' + loop + Skip_Char (S); + end loop; + end if; + + when N_Real_Literal => + -- Skip past the initial numeral, which either leads the decimal + -- literal or is the base of a based literal. + + while S < SL + and then Src (S + 1) in '0' .. '9' | '_' + loop + Skip_Char (S); + end loop; + + if S < SL then + + -- Skip the dot and continue with a decimal literal + + if Src (S + 1) = '.' then + Skip_Char (S); + + while S < SL + and then Src (S + 1) in '0' .. '9' | '_' + loop + Skip_Char (S); + end loop; + + -- Skip the hash and continue with a based literal + + elsif Src (S + 1) = '#' then + Skip_Char (S); + + while S < SL + and then + Src (S + 1) in '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' | '_' + loop + Skip_Char (S); + end loop; + + if S < SL + and then Src (S + 1) = '.' + then + Skip_Char (S); + end if; + + while S < SL + and then + Src (S + 1) in '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' | '_' + loop + Skip_Char (S); + end loop; + + if S < SL + and then Src (S + 1) = '#' + then + Skip_Char (S); + end if; + end if; + end if; + + -- Skip past exponent, if present + + if S < SL + and then Src (S + 1) in 'e' | 'E' + then + Skip_Char (S); + -- For positive exponents the plus sign is optional, but we + -- can simply skip past both plus and minus. + + if Src (S + 1) in '+' | '-' then + Skip_Char (S); + end if; + + -- Skip past the numeral part + + while S < SL + and then Src (S + 1) in '0' .. '9' | '_' + loop + Skip_Char (S); + end loop; + end if; + + -- For other nodes simply skip past a keyword/identifier + + when others => + while S in SF .. SL - 1 + and then Src (S + 1) + in + '0' .. '9' | 'a' .. 'z' | 'A' .. 'Z' | '_' + loop + Skip_Char (S); + end loop; + end case; -- The following circuit attempts at crawling up the tree from the -- Last_Node, adjusting the Sloc value for any parentheses we know -- are present, similarly to what is done in First_Sloc. Node_Loop : loop + -- Include parentheses around the top node, except when they are + -- required by the syntax of the parent node. + + exit Node_Loop when F = N + and then Paren_Required (N); + Paren_Loop : for J in 1 .. Paren_Count (F) loop -- We don't look more than 12 characters after the current @@ -2000,11 +2225,11 @@ package body Errout is Search_Loop : for K in 1 .. 12 loop exit Node_Loop when S = SL; - if Source_Text (SI) (S + 1) = ')' then + if Src (S + 1) = ')' then S := S + 1; exit Search_Loop; - elsif Source_Text (SI) (S + 1) <= ' ' then + elsif Src (S + 1) <= ' ' then S := S + 1; else @@ -2021,7 +2246,7 @@ package body Errout is -- Remove any trailing space while S in SF + 1 .. SL - and then Source_Text (SI) (S) = ' ' + and then Src (S) = ' ' loop S := S - 1; end loop; @@ -2853,16 +3078,19 @@ package body Errout is E := Errors.Table (E).Next; - -- Skip deleted messages. - -- Also skip continuation messages, as they have already been - -- printed along the message they're attached to. + while E /= No_Error_Msg loop + + -- Skip deleted messages. + -- Also skip continuation messages, as they have already been + -- printed along the message they're attached to. + + if not Errors.Table (E).Deleted + and then not Errors.Table (E).Msg_Cont + then + Write_Char (','); + Output_JSON_Message (E); + end if; - while E /= No_Error_Msg - and then not Errors.Table (E).Deleted - and then not Errors.Table (E).Msg_Cont - loop - Write_Char (','); - Output_JSON_Message (E); E := Errors.Table (E).Next; end loop; end if; @@ -3296,6 +3524,23 @@ package body Errout is end if; end Output_Source_Line; + -------------------- + -- Paren_Required -- + -------------------- + + function Paren_Required (N : Node_Id) return Boolean is + begin + -- In a qualifed_expression the expression part needs to be enclosed in + -- parentheses. + + if Nkind (Parent (N)) = N_Qualified_Expression then + return N = Expression (Parent (N)); + + else + return False; + end if; + end Paren_Required; + ----------------------------- -- Remove_Warning_Messages -- ----------------------------- @@ -3976,7 +4221,8 @@ package body Errout is P := P + 1; elsif P < Text'Last and then Text (P + 1) = C - and then Text (P) in 'a' .. 'z' | '*' | '$' + and then Text (P) in 'a' .. 'z' | 'A' .. 'Z' | + '0' .. '9' | '*' | '$' then P := P + 2; @@ -4108,21 +4354,29 @@ package body Errout is when '[' => - -- Switch the message from a warning to an error if the flag - -- -gnatwE is specified to treat run-time exception warnings - -- as errors. + -- "[]" (insertion of error code) - if Is_Warning_Msg - and then Warning_Mode = Treat_Run_Time_Warnings_As_Errors - then - Is_Warning_Msg := False; - Is_Runtime_Raise := True; - end if; + if P <= Text'Last and then Text (P) = ']' then + P := P + 1; + Set_Msg_Insertion_Code; - if Is_Warning_Msg then - Set_Msg_Str ("will be raised at run time"); else - Set_Msg_Str ("would have been raised at run time"); + -- Switch the message from a warning to an error if the flag + -- -gnatwE is specified to treat run-time exception warnings + -- as errors. + + if Is_Warning_Msg + and then Warning_Mode = Treat_Run_Time_Warnings_As_Errors + then + Is_Warning_Msg := False; + Is_Runtime_Raise := True; + end if; + + if Is_Warning_Msg then + Set_Msg_Str ("will be raised at run time"); + else + Set_Msg_Str ("would have been raised at run time"); + end if; end if; -- ']' (may be/might have been raised at run time) diff --git a/gcc/ada/errout.ads b/gcc/ada/errout.ads index 1e09961..80dd7df 100644 --- a/gcc/ada/errout.ads +++ b/gcc/ada/errout.ads @@ -307,9 +307,9 @@ package Errout is -- Insertion character ?x? ?.x? ?_x? (warning with switch) -- "x" is a (lower-case) warning switch character. -- Like ??, but if the flag Warn_Doc_Switch is True, adds the string - -- "[-gnatwx]", "[-gnatw.x]", or "[-gnatw_x]", at the end of the - -- warning message. For continuations, use this on each continuation - -- message. + -- "[-gnatwx]", "[-gnatw.x]", "[-gnatw_x]", or "[-gnatyx]" (for style + -- messages), at the end of the warning message. For continuations, use + -- this on each continuation message. -- Insertion character ?*? (restriction warning) -- Like ?, but if the flag Warn_Doc_Switch is True, adds the string @@ -404,6 +404,10 @@ package Errout is -- This is like [ except that the insertion messages say may/might, -- instead of will/would. + -- Insertion sequence [] (Left and right brackets: error code) + -- The insertion sequence [] should be replaced by an error code, whose + -- value is given by Error_Msg_Code. + -- Insertion sequence "(style)" (style message) -- This appears only at the start of the message (and not any of its -- continuations, if any), and indicates that the message is a style @@ -454,6 +458,11 @@ package Errout is Error_Msg_Uint_2 : Uint renames Err_Vars.Error_Msg_Uint_2; -- Uint values for ^ insertion characters in message + Error_Msg_Code_Digits : constant := Err_Vars.Error_Msg_Code_Digits; + Error_Msg_Code : Nat renames Err_Vars.Error_Msg_Code; + -- Nat value for [] insertion sequence in message, where a value of zero + -- indicates the absence of an error code. + Error_Msg_Sloc : Source_Ptr renames Err_Vars.Error_Msg_Sloc; -- Source location for # insertion character in message @@ -600,6 +609,21 @@ package Errout is -- Returns the flag location of the error message with the given id E ------------------------ + -- GNAT Explain Codes -- + ------------------------ + + -- Explain codes are used in GNATprove to provide more information on + -- selected error/warning messages. The subset of those codes used in + -- the GNAT frontend are defined here. + + GEC_None : constant := 0000; + GEC_Volatile_At_Library_Level : constant := 0001; + GEC_Type_Early_Call_Region : constant := 0003; + GEC_Volatile_Non_Interfering_Context : constant := 0004; + GEC_Required_Part_Of : constant := 0009; + GEC_Ownership_Moved_Object : constant := 0010; + + ------------------------ -- List Pragmas Table -- ------------------------ diff --git a/gcc/ada/erroutc.adb b/gcc/ada/erroutc.adb index 291a340..5a8556b 100644 --- a/gcc/ada/erroutc.adb +++ b/gcc/ada/erroutc.adb @@ -367,17 +367,25 @@ package body Erroutc is function Get_Warning_Option (Id : Error_Msg_Id) return String is Warn : constant Boolean := Errors.Table (Id).Warn; + Style : constant Boolean := Errors.Table (Id).Style; Warn_Chr : constant String (1 .. 2) := Errors.Table (Id).Warn_Chr; + begin - if Warn and then Warn_Chr /= " " and then Warn_Chr (1) /= '?' then + if (Warn or Style) + and then Warn_Chr /= " " + and then Warn_Chr (1) /= '?' + then if Warn_Chr = "$ " then return "-gnatel"; + elsif Style then + return "-gnaty" & Warn_Chr (1); elsif Warn_Chr (2) = ' ' then return "-gnatw" & Warn_Chr (1); else return "-gnatw" & Warn_Chr; end if; end if; + return ""; end Get_Warning_Option; @@ -387,10 +395,12 @@ package body Erroutc is function Get_Warning_Tag (Id : Error_Msg_Id) return String is Warn : constant Boolean := Errors.Table (Id).Warn; + Style : constant Boolean := Errors.Table (Id).Style; Warn_Chr : constant String (1 .. 2) := Errors.Table (Id).Warn_Chr; Option : constant String := Get_Warning_Option (Id); + begin - if Warn then + if Warn or Style then if Warn_Chr = "? " then return "[enabled by default]"; elsif Warn_Chr = "* " then @@ -880,7 +890,7 @@ package body Erroutc is J := J + 1; elsif J < Msg'Last and then Msg (J + 1) = C - and then Msg (J) in 'a' .. 'z' | '*' | '$' + and then Msg (J) in 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '*' | '$' then Message_Class := Msg (J) & " "; J := J + 2; @@ -949,6 +959,7 @@ package body Erroutc is end if; Has_Double_Exclam := False; + Has_Error_Code := False; Has_Insertion_Line := False; -- Loop through message looking for relevant insertion sequences @@ -964,19 +975,20 @@ package body Erroutc is -- Warning message (? or < insertion sequence) elsif Msg (J) = '?' or else Msg (J) = '<' then - Is_Warning_Msg := Msg (J) = '?' or else Error_Msg_Warn; - J := J + 1; - - if Is_Warning_Msg then + if Msg (J) = '?' or else Error_Msg_Warn then + Is_Warning_Msg := not Is_Style_Msg; + J := J + 1; Warning_Msg_Char := Parse_Message_Class; - end if; - -- Bomb if untagged warning message. This code can be uncommented - -- for debugging when looking for untagged warning messages. + -- Bomb if untagged warning message. This code can be + -- uncommented for debugging when looking for untagged warning + -- messages. + + -- pragma Assert (Warning_Msg_Char /= " "); - -- if Is_Warning_Msg and then Warning_Msg_Char = ' ' then - -- raise Program_Error; - -- end if; + else + J := J + 1; + end if; -- Unconditional message (! insertion) @@ -1001,6 +1013,15 @@ package body Erroutc is Is_Serious_Error := False; J := J + 1; + -- Error code ([] insertion) + + elsif Msg (J) = '[' + and then J < Msg'Last + and then Msg (J + 1) = ']' + then + Has_Error_Code := True; + J := J + 2; + else J := J + 1; end if; @@ -1145,6 +1166,42 @@ package body Erroutc is end if; end Set_Msg_Char; + ---------------------------- + -- Set_Msg_Insertion_Code -- + ---------------------------- + + procedure Set_Msg_Insertion_Code is + H : constant array (Nat range 0 .. 9) of Character := "0123456789"; + P10 : constant array (Natural range 0 .. 3) of Nat := + (10 ** 0, + 10 ** 1, + 10 ** 2, + 10 ** 3); + + Code_Len : constant Natural := + (case Error_Msg_Code is + when 0 => 0, + when 1 .. 9 => 1, + when 10 .. 99 => 2, + when 100 .. 999 => 3, + when 1000 .. 9999 => 4); + Code_Rest : Nat := Error_Msg_Code; + Code_Digit : Nat; + + begin + Set_Msg_Char ('E'); + + for J in 1 .. Error_Msg_Code_Digits - Code_Len loop + Set_Msg_Char ('0'); + end loop; + + for J in 1 .. Code_Len loop + Code_Digit := Code_Rest / P10 (Code_Len - J); + Set_Msg_Char (H (Code_Digit)); + Code_Rest := Code_Rest - Code_Digit * P10 (Code_Len - J); + end loop; + end Set_Msg_Insertion_Code; + --------------------------------- -- Set_Msg_Insertion_File_Name -- --------------------------------- diff --git a/gcc/ada/erroutc.ads b/gcc/ada/erroutc.ads index c32b19f..6602907 100644 --- a/gcc/ada/erroutc.ads +++ b/gcc/ada/erroutc.ads @@ -51,6 +51,10 @@ package Erroutc is -- Set true to indicate that the current message contains the insertion -- sequence !! (force warnings even in non-main unit source files). + Has_Error_Code : Boolean := False; + -- Set true to indicate that the current message contains the insertion + -- sequence [] (insert error code). + Has_Insertion_Line : Boolean := False; -- Set True to indicate that the current message contains the insertion -- character # (insert line number reference). @@ -547,6 +551,9 @@ package Erroutc is -- Has_Double_Exclam is set True if the message contains the sequence !! -- and is otherwise set False. -- + -- Has_Error_Code is set True if the message contains the sequence [] + -- and is otherwise set False. + -- -- Has_Insertion_Line is set True if the message contains the character # -- and is otherwise set False. -- @@ -581,6 +588,9 @@ package Erroutc is -- check for special insertion characters (they are just treated as text -- characters if they occur). + procedure Set_Msg_Insertion_Code; + -- Handle error code insertion ([] insertion character) + procedure Set_Msg_Insertion_File_Name; -- Handle file name insertion (left brace insertion character) diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index f1cbbfc..5e22fef 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -62,7 +62,7 @@ with Sem_Eval; use Sem_Eval; with Sem_Mech; use Sem_Mech; with Sem_Res; use Sem_Res; with Sem_Util; use Sem_Util; -use Sem_Util.Storage_Model_Support; + use Sem_Util.Storage_Model_Support; with Sinfo; use Sinfo; with Sinfo.Nodes; use Sinfo.Nodes; with Sinfo.Utils; use Sinfo.Utils; @@ -78,12 +78,10 @@ package body Exp_Aggr is function Build_Assignment_With_Temporary (Target : Node_Id; - Typ : Node_Id; + Typ : Entity_Id; Source : Node_Id) return List_Id; -- Returns a list of actions to assign Source to Target of type Typ using - -- an extra temporary: - -- Tmp := Source; - -- Target := Tmp; + -- an extra temporary, which can potentially be large. type Case_Bounds is record Choice_Lo : Node_Id; @@ -107,6 +105,16 @@ package body Exp_Aggr is -- N is an aggregate (record or array). Checks the presence of default -- initialization (<>) in any component (Ada 2005: AI-287). + procedure Initialize_Component + (N : Node_Id; + Comp : Node_Id; + Comp_Typ : Node_Id; + Init_Expr : Node_Id; + Stmts : List_Id); + -- Perform the initialization of component Comp with expected type + -- Comp_Typ of aggregate N. Init_Expr denotes the initialization + -- expression of the component. All generated code is added to Stmts. + function Is_CCG_Supported_Aggregate (N : Node_Id) return Boolean; -- Return True if aggregate N is located in a context supported by the -- CCG backend; False otherwise. @@ -153,37 +161,6 @@ package body Exp_Aggr is -- Returns the number of discrete choices (not including the others choice -- if present) contained in (sub-)aggregate N. - procedure Process_Transient_Component - (Loc : Source_Ptr; - Comp_Typ : Entity_Id; - Init_Expr : Node_Id; - Fin_Call : out Node_Id; - Hook_Clear : out Node_Id; - Aggr : Node_Id := Empty; - Stmts : List_Id := No_List); - -- Subsidiary to the expansion of array and record aggregates. Generate - -- part of the necessary code to finalize a transient component. Comp_Typ - -- is the component type. Init_Expr is the initialization expression of the - -- component which is always a function call. Fin_Call is the finalization - -- call used to clean up the transient function result. Hook_Clear is the - -- hook reset statement. Aggr and Stmts both control the placement of the - -- generated code. Aggr is the related aggregate. If present, all code is - -- inserted prior to Aggr using Insert_Action. Stmts is the initialization - -- statements of the component. If present, all code is added to Stmts. - - procedure Process_Transient_Component_Completion - (Loc : Source_Ptr; - Aggr : Node_Id; - Fin_Call : Node_Id; - Hook_Clear : Node_Id; - Stmts : List_Id); - -- Subsidiary to the expansion of array and record aggregates. Generate - -- part of the necessary code to finalize a transient component. Aggr is - -- the related aggregate. Fin_Clear is the finalization call used to clean - -- up the transient component. Hook_Clear is the hook reset statement. - -- Stmts is the initialization statement list for the component. All - -- generated code is added to Stmts. - procedure Sort_Case_Table (Case_Table : in out Case_Table_Type); -- Sort the Case Table using the Lower Bound of each Choice as the key. -- A simple insertion sort is used since the number of choices in a case @@ -1062,6 +1039,7 @@ package body Exp_Aggr is Indexes : List_Id := No_List) return List_Id is Loc : constant Source_Ptr := Sloc (N); + Typ : constant Entity_Id := Etype (N); Index_Base : constant Entity_Id := Base_Type (Etype (Index)); Index_Base_L : constant Node_Id := Type_Low_Bound (Index_Base); Index_Base_H : constant Node_Id := Type_High_Bound (Index_Base); @@ -1082,16 +1060,14 @@ package body Exp_Aggr is function Gen_Assign (Ind : Node_Id; - Expr : Node_Id; - In_Loop : Boolean := False) return List_Id; + Expr : Node_Id) return List_Id; -- Ind must be a side-effect-free expression. If the input aggregate N -- to Build_Loop contains no subaggregates, then this function returns -- the assignment statement: -- -- Into (Indexes, Ind) := Expr; -- - -- Otherwise we call Build_Code recursively. Flag In_Loop should be set - -- when the assignment appears within a generated loop. + -- Otherwise we call Build_Code recursively. -- -- Ada 2005 (AI-287): In case of default initialized component, Expr -- is empty and we generate a call to the corresponding IP subprogram. @@ -1311,35 +1287,13 @@ package body Exp_Aggr is function Gen_Assign (Ind : Node_Id; - Expr : Node_Id; - In_Loop : Boolean := False) return List_Id + Expr : Node_Id) return List_Id is function Add_Loop_Actions (Lis : List_Id) return List_Id; -- Collect insert_actions generated in the construction of a loop, -- and prepend them to the sequence of assignments to complete the -- eventual body of the loop. - procedure Initialize_Array_Component - (Arr_Comp : Node_Id; - Comp_Typ : Node_Id; - Init_Expr : Node_Id; - Stmts : List_Id); - -- Perform the initialization of array component Arr_Comp with - -- expected type Comp_Typ. Init_Expr denotes the initialization - -- expression of the array component. All generated code is added - -- to list Stmts. - - procedure Initialize_Ctrl_Array_Component - (Arr_Comp : Node_Id; - Comp_Typ : Entity_Id; - Init_Expr : Node_Id; - Stmts : List_Id); - -- Perform the initialization of array component Arr_Comp when its - -- expected type Comp_Typ needs finalization actions. Init_Expr is - -- the initialization expression of the array component. All hook- - -- related declarations are inserted prior to aggregate N. Remaining - -- code is added to list Stmts. - ---------------------- -- Add_Loop_Actions -- ---------------------- @@ -1367,289 +1321,6 @@ package body Exp_Aggr is end if; end Add_Loop_Actions; - -------------------------------- - -- Initialize_Array_Component -- - -------------------------------- - - procedure Initialize_Array_Component - (Arr_Comp : Node_Id; - Comp_Typ : Node_Id; - Init_Expr : Node_Id; - Stmts : List_Id) - is - Exceptions_OK : constant Boolean := - not Restriction_Active - (No_Exception_Propagation); - - Finalization_OK : constant Boolean := - Present (Comp_Typ) - and then Needs_Finalization (Comp_Typ); - - Full_Typ : constant Entity_Id := Underlying_Type (Comp_Typ); - Adj_Call : Node_Id; - Blk_Stmts : List_Id; - Init_Stmt : Node_Id; - - begin - -- Protect the initialization statements from aborts. Generate: - - -- Abort_Defer; - - if Finalization_OK and Abort_Allowed then - if Exceptions_OK then - Blk_Stmts := New_List; - else - Blk_Stmts := Stmts; - end if; - - Append_To (Blk_Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer)); - - -- Otherwise aborts are not allowed. All generated code is added - -- directly to the input list. - - else - Blk_Stmts := Stmts; - end if; - - -- Initialize the array element. Generate: - - -- Arr_Comp := Init_Expr; - - -- Note that the initialization expression is replicated because - -- it has to be reevaluated within a generated loop. - - Init_Stmt := - Make_OK_Assignment_Statement (Loc, - Name => New_Copy_Tree (Arr_Comp), - Expression => New_Copy_Tree (Init_Expr)); - Set_No_Ctrl_Actions (Init_Stmt); - - -- If this is an aggregate for an array of arrays, each - -- subaggregate will be expanded as well, and even with - -- No_Ctrl_Actions the assignments of inner components will - -- require attachment in their assignments to temporaries. These - -- temporaries must be finalized for each subaggregate. Generate: - - -- begin - -- Arr_Comp := Init_Expr; - -- end; - - if Finalization_OK and then Is_Array_Type (Comp_Typ) then - Init_Stmt := - Make_Block_Statement (Loc, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List (Init_Stmt))); - end if; - - Append_To (Blk_Stmts, Init_Stmt); - - -- Adjust the tag due to a possible view conversion. Generate: - - -- Arr_Comp._tag := Full_TypP; - - if Tagged_Type_Expansion - and then Present (Comp_Typ) - and then Is_Tagged_Type (Comp_Typ) - then - Append_To (Blk_Stmts, - Make_OK_Assignment_Statement (Loc, - Name => - Make_Selected_Component (Loc, - Prefix => New_Copy_Tree (Arr_Comp), - Selector_Name => - New_Occurrence_Of - (First_Tag_Component (Full_Typ), Loc)), - - Expression => - Unchecked_Convert_To (RTE (RE_Tag), - New_Occurrence_Of - (Node (First_Elmt (Access_Disp_Table (Full_Typ))), - Loc)))); - end if; - - -- Adjust the array component. Controlled subaggregates are not - -- considered because each of their individual elements will - -- receive an adjustment of its own. Generate: - - -- [Deep_]Adjust (Arr_Comp); - - if Finalization_OK - and then not Is_Limited_Type (Comp_Typ) - and then not Is_Build_In_Place_Function_Call (Init_Expr) - and then not - (Is_Array_Type (Comp_Typ) - and then Is_Controlled (Component_Type (Comp_Typ)) - and then Nkind (Expr) = N_Aggregate) - then - Adj_Call := - Make_Adjust_Call - (Obj_Ref => New_Copy_Tree (Arr_Comp), - Typ => Comp_Typ); - - -- Guard against a missing [Deep_]Adjust when the component - -- type was not frozen properly. - - if Present (Adj_Call) then - Append_To (Blk_Stmts, Adj_Call); - end if; - end if; - - -- Complete the protection of the initialization statements - - if Finalization_OK and Abort_Allowed then - - -- Wrap the initialization statements in a block to catch a - -- potential exception. Generate: - - -- begin - -- Abort_Defer; - -- Arr_Comp := Init_Expr; - -- Arr_Comp._tag := Full_TypP; - -- [Deep_]Adjust (Arr_Comp); - -- at end - -- Abort_Undefer_Direct; - -- end; - - if Exceptions_OK then - Append_To (Stmts, - Build_Abort_Undefer_Block (Loc, - Stmts => Blk_Stmts, - Context => N)); - - -- Otherwise exceptions are not propagated. Generate: - - -- Abort_Defer; - -- Arr_Comp := Init_Expr; - -- Arr_Comp._tag := Full_TypP; - -- [Deep_]Adjust (Arr_Comp); - -- Abort_Undefer; - - else - Append_To (Blk_Stmts, - Build_Runtime_Call (Loc, RE_Abort_Undefer)); - end if; - end if; - end Initialize_Array_Component; - - ------------------------------------- - -- Initialize_Ctrl_Array_Component -- - ------------------------------------- - - procedure Initialize_Ctrl_Array_Component - (Arr_Comp : Node_Id; - Comp_Typ : Entity_Id; - Init_Expr : Node_Id; - Stmts : List_Id) - is - Act_Aggr : Node_Id; - Act_Stmts : List_Id; - Expr : Node_Id; - Fin_Call : Node_Id; - Hook_Clear : Node_Id; - - In_Place_Expansion : Boolean; - -- Flag set when a nonlimited controlled function call requires - -- in-place expansion. - - begin - -- Duplicate the initialization expression in case the context is - -- a multi choice list or an "others" choice which plugs various - -- holes in the aggregate. As a result the expression is no longer - -- shared between the various components and is reevaluated for - -- each such component. - - Expr := New_Copy_Tree (Init_Expr); - Set_Parent (Expr, Parent (Init_Expr)); - - -- Perform a preliminary analysis and resolution to determine what - -- the initialization expression denotes. An unanalyzed function - -- call may appear as an identifier or an indexed component. - - if Nkind (Expr) in N_Function_Call - | N_Identifier - | N_Indexed_Component - and then not Analyzed (Expr) - then - Preanalyze_And_Resolve (Expr, Comp_Typ); - end if; - - In_Place_Expansion := - Nkind (Expr) = N_Function_Call - and then not Is_Build_In_Place_Result_Type (Comp_Typ); - - -- The initialization expression is a controlled function call. - -- Perform in-place removal of side effects to avoid creating a - -- transient scope, which leads to premature finalization. - - -- This in-place expansion is not performed for limited transient - -- objects, because the initialization is already done in place. - - if In_Place_Expansion then - - -- Suppress the removal of side effects by general analysis, - -- because this behavior is emulated here. This avoids the - -- generation of a transient scope, which leads to out-of-order - -- adjustment and finalization. - - Set_No_Side_Effect_Removal (Expr); - - -- When the transient component initialization is related to a - -- range or an "others", keep all generated statements within - -- the enclosing loop. This way the controlled function call - -- will be evaluated at each iteration, and its result will be - -- finalized at the end of each iteration. - - if In_Loop then - Act_Aggr := Empty; - Act_Stmts := Stmts; - - -- Otherwise this is a single component initialization. Hook- - -- related statements are inserted prior to the aggregate. - - else - Act_Aggr := N; - Act_Stmts := No_List; - end if; - - -- Install all hook-related declarations and prepare the clean - -- up statements. - - Process_Transient_Component - (Loc => Loc, - Comp_Typ => Comp_Typ, - Init_Expr => Expr, - Fin_Call => Fin_Call, - Hook_Clear => Hook_Clear, - Aggr => Act_Aggr, - Stmts => Act_Stmts); - end if; - - -- Use the noncontrolled component initialization circuitry to - -- assign the result of the function call to the array element. - -- This also performs subaggregate wrapping, tag adjustment, and - -- [deep] adjustment of the array element. - - Initialize_Array_Component - (Arr_Comp => Arr_Comp, - Comp_Typ => Comp_Typ, - Init_Expr => Expr, - Stmts => Stmts); - - -- At this point the array element is fully initialized. Complete - -- the processing of the controlled array component by finalizing - -- the transient function result. - - if In_Place_Expansion then - Process_Transient_Component_Completion - (Loc => Loc, - Aggr => N, - Fin_Call => Fin_Call, - Hook_Clear => Hook_Clear, - Stmts => Stmts); - end if; - end Initialize_Ctrl_Array_Component; - -- Local variables Stmts : constant List_Id := New_List; @@ -1696,13 +1367,7 @@ package body Exp_Aggr is -- Ada 2005 (AI-287): In case of default initialized component, Expr -- is not present (and therefore we also initialize Expr_Q to empty). - if No (Expr) then - Expr_Q := Empty; - elsif Nkind (Expr) = N_Qualified_Expression then - Expr_Q := Expression (Expr); - else - Expr_Q := Expr; - end if; + Expr_Q := Unqualify (Expr); if Present (Etype (N)) and then Etype (N) /= Any_Composite then Comp_Typ := Component_Type (Etype (N)); @@ -1801,57 +1466,12 @@ package body Exp_Aggr is end if; if Present (Expr) then - - -- Handle an initialization expression of a controlled type in - -- case it denotes a function call. In general such a scenario - -- will produce a transient scope, but this will lead to wrong - -- order of initialization, adjustment, and finalization in the - -- context of aggregates. - - -- Target (1) := Ctrl_Func_Call; - - -- begin -- scope - -- Trans_Obj : ... := Ctrl_Func_Call; -- object - -- Target (1) := Trans_Obj; - -- Finalize (Trans_Obj); - -- end; - -- Target (1)._tag := ...; - -- Adjust (Target (1)); - - -- In the example above, the call to Finalize occurs too early - -- and as a result it may leave the array component in a bad - -- state. Finalization of the transient object should really - -- happen after adjustment. - - -- To avoid this scenario, perform in-place side-effect removal - -- of the function call. This eliminates the transient property - -- of the function result and ensures correct order of actions. - - -- Res : ... := Ctrl_Func_Call; - -- Target (1) := Res; - -- Target (1)._tag := ...; - -- Adjust (Target (1)); - -- Finalize (Res); - - if Present (Comp_Typ) - and then Needs_Finalization (Comp_Typ) - and then Nkind (Expr) /= N_Aggregate - then - Initialize_Ctrl_Array_Component - (Arr_Comp => Indexed_Comp, - Comp_Typ => Comp_Typ, - Init_Expr => Expr, - Stmts => Stmts); - - -- Otherwise perform simple component initialization - - else - Initialize_Array_Component - (Arr_Comp => Indexed_Comp, - Comp_Typ => Comp_Typ, - Init_Expr => Expr, - Stmts => Stmts); - end if; + Initialize_Component + (N => N, + Comp => Indexed_Comp, + Comp_Typ => Comp_Typ, + Init_Expr => Expr, + Stmts => Stmts); -- Ada 2005 (AI-287): In case of default initialized component, call -- the initialization subprogram associated with the component type. @@ -2059,6 +1679,7 @@ package body Exp_Aggr is Set_Etype (L_J, Any_Type); Mutate_Ekind (L_J, E_Variable); + Set_Is_Not_Self_Hidden (L_J); Set_Scope (L_J, Ent); else L_J := Make_Temporary (Loc, 'J', L); @@ -2102,8 +1723,7 @@ package body Exp_Aggr is -- Construct the statements to execute in the loop body - L_Body := - Gen_Assign (New_Occurrence_Of (L_J, Loc), Expr, In_Loop => True); + L_Body := Gen_Assign (New_Occurrence_Of (L_J, Loc), Expr); -- Construct the final loop @@ -2216,7 +1836,7 @@ package body Exp_Aggr is Append_To (W_Body, W_Increment); Append_List_To (W_Body, - Gen_Assign (New_Occurrence_Of (W_J, Loc), Expr, In_Loop => True)); + Gen_Assign (New_Occurrence_Of (W_J, Loc), Expr)); -- Construct the final loop @@ -2234,21 +1854,32 @@ package body Exp_Aggr is -- Get_Assoc_Expr -- -------------------- + -- Duplicate the expression in case we will be generating several loops. + -- As a result the expression is no longer shared between the loops and + -- is reevaluated for each such loop. + function Get_Assoc_Expr (Assoc : Node_Id) return Node_Id is Typ : constant Entity_Id := Base_Type (Etype (N)); begin if Box_Present (Assoc) then if Present (Default_Aspect_Component_Value (Typ)) then - return Default_Aspect_Component_Value (Typ); + return New_Copy_Tree (Default_Aspect_Component_Value (Typ)); elsif Needs_Simple_Initialization (Ctype) then - return Get_Simple_Init_Val (Ctype, N); + return New_Copy_Tree (Get_Simple_Init_Val (Ctype, N)); else return Empty; end if; else - return Expression (Assoc); + -- The expression will be passed to Gen_Loop, which immediately + -- calls Parent_Kind on it, so we set Parent when it matters. + + return + Expr : constant Node_Id := New_Copy_Tree (Expression (Assoc)) + do + Copy_Parent (To => Expr, From => Expression (Assoc)); + end return; end if; end Get_Assoc_Expr; @@ -2306,7 +1937,6 @@ package body Exp_Aggr is Assoc : Node_Id; Choice : Node_Id; Expr : Node_Id; - Typ : Entity_Id; Bounds : Range_Nodes; Low : Node_Id renames Bounds.First; @@ -2324,12 +1954,10 @@ package body Exp_Aggr is -- Start of processing for Build_Array_Aggr_Code begin - -- First before we start, a special case. if we have a bit packed + -- First before we start, a special case. If we have a bit packed -- array represented as a modular type, then clear the value to -- zero first, to ensure that unused bits are properly cleared. - Typ := Etype (N); - if Present (Typ) and then Is_Bit_Packed_Array (Typ) and then Is_Modular_Integer_Type (Packed_Array_Impl_Type (Typ)) @@ -2415,8 +2043,7 @@ package body Exp_Aggr is if Present (Others_Assoc) then declare - First : Boolean := True; - Dup_Expr : Node_Id; + First : Boolean := True; begin for J in 0 .. Nb_Choices loop @@ -2450,23 +2077,11 @@ package body Exp_Aggr is end if; end if; - if First - or else not Empty_Range (Low, High) - then + if First or else not Empty_Range (Low, High) then First := False; - - -- Duplicate the expression in case we will be generating - -- several loops. As a result the expression is no longer - -- shared between the loops and is reevaluated for each - -- such loop. - - Expr := Get_Assoc_Expr (Others_Assoc); - Dup_Expr := New_Copy_Tree (Expr); - Copy_Parent (To => Dup_Expr, From => Expr); - Set_Loop_Actions (Others_Assoc, New_List); - Append_List - (Gen_Loop (Low, High, Dup_Expr), To => New_Code); + Expr := Get_Assoc_Expr (Others_Assoc); + Append_List (Gen_Loop (Low, High, Expr), To => New_Code); end if; end loop; end; @@ -2524,33 +2139,33 @@ package body Exp_Aggr is function Build_Assignment_With_Temporary (Target : Node_Id; - Typ : Node_Id; + Typ : Entity_Id; Source : Node_Id) return List_Id is Loc : constant Source_Ptr := Sloc (Source); Aggr_Code : List_Id; Tmp : Entity_Id; - Tmp_Decl : Node_Id; begin - Tmp := Make_Temporary (Loc, 'A', Source); - Tmp_Decl := - Make_Object_Declaration (Loc, - Defining_Identifier => Tmp, - Object_Definition => New_Occurrence_Of (Typ, Loc)); - Set_No_Initialization (Tmp_Decl, True); + Aggr_Code := New_List; + + Tmp := Build_Temporary_On_Secondary_Stack (Loc, Typ, Aggr_Code); - Aggr_Code := New_List (Tmp_Decl); Append_To (Aggr_Code, Make_OK_Assignment_Statement (Loc, - Name => New_Occurrence_Of (Tmp, Loc), + Name => + Make_Explicit_Dereference (Loc, + Prefix => New_Occurrence_Of (Tmp, Loc)), Expression => Source)); Append_To (Aggr_Code, Make_OK_Assignment_Statement (Loc, Name => Target, - Expression => New_Occurrence_Of (Tmp, Loc))); + Expression => + Make_Explicit_Dereference (Loc, + Prefix => New_Occurrence_Of (Tmp, Loc)))); + return Aggr_Code; end Build_Assignment_With_Temporary; @@ -2576,14 +2191,6 @@ package body Exp_Aggr is Comp_Expr : Node_Id; Expr_Q : Node_Id; - -- If this is an internal aggregate, the External_Final_List is an - -- expression for the controller record of the enclosing type. - - -- If the current aggregate has several controlled components, this - -- expression will appear in several calls to attach to the finali- - -- zation list, and it must not be shared. - - Ancestor_Is_Expression : Boolean := False; Ancestor_Is_Subtype_Mark : Boolean := False; Init_Typ : Entity_Id := Empty; @@ -2643,26 +2250,6 @@ package body Exp_Aggr is -- The type of the aggregate is a subtype created ealier using the -- given values of the discriminant components of the aggregate. - procedure Initialize_Ctrl_Record_Component - (Rec_Comp : Node_Id; - Comp_Typ : Entity_Id; - Init_Expr : Node_Id; - Stmts : List_Id); - -- Perform the initialization of controlled record component Rec_Comp. - -- Comp_Typ is the component type. Init_Expr is the initialization - -- expression for the record component. Hook-related declarations are - -- inserted prior to aggregate N using Insert_Action. All remaining - -- generated code is added to list Stmts. - - procedure Initialize_Record_Component - (Rec_Comp : Node_Id; - Comp_Typ : Entity_Id; - Init_Expr : Node_Id; - Stmts : List_Id); - -- Perform the initialization of record component Rec_Comp. Comp_Typ - -- is the component type. Init_Expr is the initialization expression - -- of the record component. All generated code is added to list Stmts. - function Is_Int_Range_Bounds (Bounds : Node_Id) return Boolean; -- Check whether Bounds is a range node and its lower and higher bounds -- are integers literals. @@ -3156,234 +2743,6 @@ package body Exp_Aggr is end loop; end Init_Stored_Discriminants; - -------------------------------------- - -- Initialize_Ctrl_Record_Component -- - -------------------------------------- - - procedure Initialize_Ctrl_Record_Component - (Rec_Comp : Node_Id; - Comp_Typ : Entity_Id; - Init_Expr : Node_Id; - Stmts : List_Id) - is - Fin_Call : Node_Id; - Hook_Clear : Node_Id; - - In_Place_Expansion : Boolean; - -- Flag set when a nonlimited controlled function call requires - -- in-place expansion. - - begin - -- Perform a preliminary analysis and resolution to determine what - -- the initialization expression denotes. Unanalyzed function calls - -- may appear as identifiers or indexed components. - - if Nkind (Init_Expr) in N_Function_Call - | N_Identifier - | N_Indexed_Component - and then not Analyzed (Init_Expr) - then - Preanalyze_And_Resolve (Init_Expr, Comp_Typ); - end if; - - In_Place_Expansion := - Nkind (Init_Expr) = N_Function_Call - and then not Is_Build_In_Place_Result_Type (Comp_Typ); - - -- The initialization expression is a controlled function call. - -- Perform in-place removal of side effects to avoid creating a - -- transient scope. - - -- This in-place expansion is not performed for limited transient - -- objects because the initialization is already done in place. - - if In_Place_Expansion then - - -- Suppress the removal of side effects by general analysis - -- because this behavior is emulated here. This avoids the - -- generation of a transient scope, which leads to out-of-order - -- adjustment and finalization. - - Set_No_Side_Effect_Removal (Init_Expr); - - -- Install all hook-related declarations and prepare the clean up - -- statements. The generated code follows the initialization order - -- of individual components and discriminants, rather than being - -- inserted prior to the aggregate. This ensures that a transient - -- component which mentions a discriminant has proper visibility - -- of the discriminant. - - Process_Transient_Component - (Loc => Loc, - Comp_Typ => Comp_Typ, - Init_Expr => Init_Expr, - Fin_Call => Fin_Call, - Hook_Clear => Hook_Clear, - Stmts => Stmts); - end if; - - -- Use the noncontrolled component initialization circuitry to - -- assign the result of the function call to the record component. - -- This also performs tag adjustment and [deep] adjustment of the - -- record component. - - Initialize_Record_Component - (Rec_Comp => Rec_Comp, - Comp_Typ => Comp_Typ, - Init_Expr => Init_Expr, - Stmts => Stmts); - - -- At this point the record component is fully initialized. Complete - -- the processing of the controlled record component by finalizing - -- the transient function result. - - if In_Place_Expansion then - Process_Transient_Component_Completion - (Loc => Loc, - Aggr => N, - Fin_Call => Fin_Call, - Hook_Clear => Hook_Clear, - Stmts => Stmts); - end if; - end Initialize_Ctrl_Record_Component; - - --------------------------------- - -- Initialize_Record_Component -- - --------------------------------- - - procedure Initialize_Record_Component - (Rec_Comp : Node_Id; - Comp_Typ : Entity_Id; - Init_Expr : Node_Id; - Stmts : List_Id) - is - Exceptions_OK : constant Boolean := - not Restriction_Active (No_Exception_Propagation); - - Finalization_OK : constant Boolean := Needs_Finalization (Comp_Typ); - - Full_Typ : constant Entity_Id := Underlying_Type (Comp_Typ); - Adj_Call : Node_Id; - Blk_Stmts : List_Id; - Init_Stmt : Node_Id; - - begin - pragma Assert (Nkind (Init_Expr) in N_Subexpr); - - -- Protect the initialization statements from aborts. Generate: - - -- Abort_Defer; - - if Finalization_OK and Abort_Allowed then - if Exceptions_OK then - Blk_Stmts := New_List; - else - Blk_Stmts := Stmts; - end if; - - Append_To (Blk_Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer)); - - -- Otherwise aborts are not allowed. All generated code is added - -- directly to the input list. - - else - Blk_Stmts := Stmts; - end if; - - -- Initialize the record component. Generate: - - -- Rec_Comp := Init_Expr; - - -- Note that the initialization expression is NOT replicated because - -- only a single component may be initialized by it. - - Init_Stmt := - Make_OK_Assignment_Statement (Loc, - Name => New_Copy_Tree (Rec_Comp), - Expression => Init_Expr); - Set_No_Ctrl_Actions (Init_Stmt); - - Append_To (Blk_Stmts, Init_Stmt); - - -- Adjust the tag due to a possible view conversion. Generate: - - -- Rec_Comp._tag := Full_TypeP; - - if Tagged_Type_Expansion and then Is_Tagged_Type (Comp_Typ) then - Append_To (Blk_Stmts, - Make_OK_Assignment_Statement (Loc, - Name => - Make_Selected_Component (Loc, - Prefix => New_Copy_Tree (Rec_Comp), - Selector_Name => - New_Occurrence_Of - (First_Tag_Component (Full_Typ), Loc)), - - Expression => - Unchecked_Convert_To (RTE (RE_Tag), - New_Occurrence_Of - (Node (First_Elmt (Access_Disp_Table (Full_Typ))), - Loc)))); - end if; - - -- Adjust the component. Generate: - - -- [Deep_]Adjust (Rec_Comp); - - if Finalization_OK - and then not Is_Limited_Type (Comp_Typ) - and then not Is_Build_In_Place_Function_Call (Init_Expr) - then - Adj_Call := - Make_Adjust_Call - (Obj_Ref => New_Copy_Tree (Rec_Comp), - Typ => Comp_Typ); - - -- Guard against a missing [Deep_]Adjust when the component type - -- was not properly frozen. - - if Present (Adj_Call) then - Append_To (Blk_Stmts, Adj_Call); - end if; - end if; - - -- Complete the protection of the initialization statements - - if Finalization_OK and Abort_Allowed then - - -- Wrap the initialization statements in a block to catch a - -- potential exception. Generate: - - -- begin - -- Abort_Defer; - -- Rec_Comp := Init_Expr; - -- Rec_Comp._tag := Full_TypP; - -- [Deep_]Adjust (Rec_Comp); - -- at end - -- Abort_Undefer_Direct; - -- end; - - if Exceptions_OK then - Append_To (Stmts, - Build_Abort_Undefer_Block (Loc, - Stmts => Blk_Stmts, - Context => N)); - - -- Otherwise exceptions are not propagated. Generate: - - -- Abort_Defer; - -- Rec_Comp := Init_Expr; - -- Rec_Comp._tag := Full_TypP; - -- [Deep_]Adjust (Rec_Comp); - -- Abort_Undefer; - - else - Append_To (Blk_Stmts, - Build_Runtime_Call (Loc, RE_Abort_Undefer)); - end if; - end if; - end Initialize_Record_Component; - ------------------------- -- Is_Int_Range_Bounds -- ------------------------- @@ -3476,9 +2835,7 @@ package body Exp_Aggr is -- to the actual type of the aggregate, so that the proper components -- are visible. We know already that the types are compatible. - if Present (Etype (Lhs)) - and then Is_Class_Wide_Type (Etype (Lhs)) - then + if Present (Etype (Lhs)) and then Is_Class_Wide_Type (Etype (Lhs)) then Target := Unchecked_Convert_To (Typ, Lhs); else Target := Lhs; @@ -3489,12 +2846,13 @@ package body Exp_Aggr is if Nkind (N) = N_Extension_Aggregate then declare - Ancestor : constant Node_Id := Ancestor_Part (N); - Adj_Call : Node_Id; + Ancestor : constant Node_Id := Ancestor_Part (N); + Ancestor_Q : constant Node_Id := Unqualify (Ancestor); + Assign : List_Id; begin - -- If the ancestor part is a subtype mark "T", we generate + -- If the ancestor part is a subtype mark T, we generate -- init-proc (T (tmp)); if T is constrained and -- init-proc (S (tmp)); where S applies an appropriate @@ -3618,125 +2976,61 @@ package body Exp_Aggr is -- qualified). elsif Is_Limited_Type (Etype (Ancestor)) - and then Nkind (Unqualify (Ancestor)) in - N_Aggregate | N_Extension_Aggregate + and then Nkind (Ancestor_Q) in N_Aggregate + | N_Extension_Aggregate then - Ancestor_Is_Expression := True; - - -- Set up finalization data for enclosing record, because - -- controlled subcomponents of the ancestor part will be - -- attached to it. - - Generate_Finalization_Actions; - Append_List_To (L, Build_Record_Aggr_Code - (N => Unqualify (Ancestor), - Typ => Etype (Unqualify (Ancestor)), + (N => Ancestor_Q, + Typ => Etype (Ancestor_Q), Lhs => Target)); - -- If the ancestor part is an expression "E", we generate + -- If the ancestor part is an expression E of type T, we generate -- T (tmp) := E; -- In Ada 2005, this includes the case of a (possibly qualified) - -- limited function call. The assignment will turn into a - -- build-in-place function call (for further details, see + -- limited function call. The assignment will later be turned into + -- a build-in-place function call (for further details, see -- Make_Build_In_Place_Call_In_Assignment). else - Ancestor_Is_Expression := True; Init_Typ := Etype (Ancestor); -- If the ancestor part is an aggregate, force its full -- expansion, which was delayed. - if Nkind (Unqualify (Ancestor)) in - N_Aggregate | N_Extension_Aggregate + if Nkind (Ancestor_Q) in N_Aggregate | N_Extension_Aggregate then Set_Analyzed (Ancestor, False); Set_Analyzed (Expression (Ancestor), False); end if; Ref := Convert_To (Init_Typ, New_Copy_Tree (Target)); - Set_Assignment_OK (Ref); - - -- Make the assignment without usual controlled actions, since - -- we only want to Adjust afterwards, but not to Finalize - -- beforehand. Add manual Adjust when necessary. Assign := New_List ( Make_OK_Assignment_Statement (Loc, Name => Ref, Expression => Ancestor)); - Set_No_Ctrl_Actions (First (Assign)); - - -- Assign the tag now to make sure that the dispatching call in - -- the subsequent deep_adjust works properly (unless - -- Tagged_Type_Expansion where tags are implicit). - - if Tagged_Type_Expansion then - Instr := - Make_OK_Assignment_Statement (Loc, - Name => - Make_Selected_Component (Loc, - Prefix => New_Copy_Tree (Target), - Selector_Name => - New_Occurrence_Of - (First_Tag_Component (Base_Type (Typ)), Loc)), - - Expression => - Unchecked_Convert_To (RTE (RE_Tag), - New_Occurrence_Of - (Node (First_Elmt - (Access_Disp_Table (Base_Type (Typ)))), - Loc))); - - Set_Assignment_OK (Name (Instr)); - Append_To (Assign, Instr); - - -- Ada 2005 (AI-251): If tagged type has progenitors we must - -- also initialize tags of the secondary dispatch tables. - - if Has_Interfaces (Base_Type (Typ)) then - Init_Secondary_Tags - (Typ => Base_Type (Typ), - Target => Target, - Stmts_List => Assign, - Init_Tags_List => Assign); - end if; - end if; - -- Call Adjust manually + -- Arrange for the component to be adjusted if need be (the + -- call will be generated by Make_Tag_Ctrl_Assignment). - if Needs_Finalization (Etype (Ancestor)) - and then not Is_Limited_Type (Etype (Ancestor)) - and then not Is_Build_In_Place_Function_Call (Ancestor) + if Needs_Finalization (Init_Typ) + and then not Is_Limited_View (Init_Typ) then - Adj_Call := - Make_Adjust_Call - (Obj_Ref => New_Copy_Tree (Ref), - Typ => Etype (Ancestor)); - - -- Guard against a missing [Deep_]Adjust when the ancestor - -- type was not properly frozen. - - if Present (Adj_Call) then - Append_To (Assign, Adj_Call); - end if; + Set_No_Finalize_Actions (First (Assign)); + else + Set_No_Ctrl_Actions (First (Assign)); end if; Append_To (L, - Make_Unsuppress_Block (Loc, Name_Discriminant_Check, Assign)); + Make_Suppress_Block (Loc, Name_Discriminant_Check, Assign)); if Has_Discriminants (Init_Typ) then Check_Ancestor_Discriminants (Init_Typ); end if; end if; - - pragma Assert (Nkind (N) = N_Extension_Aggregate); - pragma Assert - (not (Ancestor_Is_Expression and Ancestor_Is_Subtype_Mark)); end; -- Generate assignments of hidden discriminants. If the base type is @@ -3839,6 +3133,7 @@ package body Exp_Aggr is Comp := First (Component_Associations (N)); while Present (Comp) loop Selector := Entity (First (Choices (Comp))); + pragma Assert (Present (Selector)); -- C++ constructors @@ -3862,8 +3157,9 @@ package body Exp_Aggr is Prefix => New_Copy_Tree (Target), Selector_Name => New_Occurrence_Of (Selector, Loc)); - Initialize_Record_Component - (Rec_Comp => Comp_Expr, + Initialize_Component + (N => N, + Comp => Comp_Expr, Comp_Typ => Etype (Selector), Init_Expr => Get_Simple_Init_Val (Typ => Etype (Selector), @@ -3941,11 +3237,7 @@ package body Exp_Aggr is Prefix => New_Copy_Tree (Target), Selector_Name => New_Occurrence_Of (Selector, Loc)); - if Nkind (Expression (Comp)) = N_Qualified_Expression then - Expr_Q := Expression (Expression (Comp)); - else - Expr_Q := Expression (Comp); - end if; + Expr_Q := Unqualify (Expression (Comp)); -- Now either create the assignment or generate the code for the -- inner aggregate top-down. @@ -4061,7 +3353,9 @@ package body Exp_Aggr is Decl : Node_Id; begin - if Nkind (First (Choices (Assoc))) = N_Others_Choice + if Present (Assoc) + and then + Nkind (First (Choices (Assoc))) = N_Others_Choice then Decl := Build_Actual_Subtype_Of_Component @@ -4098,56 +3392,12 @@ package body Exp_Aggr is end; else - -- Handle an initialization expression of a controlled type - -- in case it denotes a function call. In general such a - -- scenario will produce a transient scope, but this will - -- lead to wrong order of initialization, adjustment, and - -- finalization in the context of aggregates. - - -- Target.Comp := Ctrl_Func_Call; - - -- begin -- scope - -- Trans_Obj : ... := Ctrl_Func_Call; -- object - -- Target.Comp := Trans_Obj; - -- Finalize (Trans_Obj); - -- end - -- Target.Comp._tag := ...; - -- Adjust (Target.Comp); - - -- In the example above, the call to Finalize occurs too - -- early and as a result it may leave the record component - -- in a bad state. Finalization of the transient object - -- should really happen after adjustment. - - -- To avoid this scenario, perform in-place side-effect - -- removal of the function call. This eliminates the - -- transient property of the function result and ensures - -- correct order of actions. - - -- Res : ... := Ctrl_Func_Call; - -- Target.Comp := Res; - -- Target.Comp._tag := ...; - -- Adjust (Target.Comp); - -- Finalize (Res); - - if Needs_Finalization (Comp_Type) - and then Nkind (Expr_Q) /= N_Aggregate - then - Initialize_Ctrl_Record_Component - (Rec_Comp => Comp_Expr, - Comp_Typ => Etype (Selector), - Init_Expr => Expr_Q, - Stmts => L); - - -- Otherwise perform single component initialization - - else - Initialize_Record_Component - (Rec_Comp => Comp_Expr, - Comp_Typ => Etype (Selector), - Init_Expr => Expr_Q, - Stmts => L); - end if; + Initialize_Component + (N => N, + Comp => Comp_Expr, + Comp_Typ => Etype (Selector), + Init_Expr => Expr_Q, + Stmts => L); end if; end if; @@ -4238,36 +3488,22 @@ package body Exp_Aggr is Next (Comp); end loop; - -- If the type is tagged, the tag needs to be initialized (unless we - -- are in VM-mode where tags are implicit). It is done late in the - -- initialization process because in some cases, we call the init - -- proc of an ancestor which will not leave out the right tag. - - if Ancestor_Is_Expression then - null; - -- For CPP types we generated a call to the C++ default constructor -- before the components have been initialized to ensure the proper -- initialization of the _Tag component (see above). - elsif Is_CPP_Class (Typ) then + if Is_CPP_Class (Typ) then null; + -- If the type is tagged, the tag needs to be initialized (unless we + -- are in VM-mode where tags are implicit). It is done late in the + -- initialization process because in some cases, we call the init + -- proc of an ancestor which will not leave out the right tag. + elsif Is_Tagged_Type (Typ) and then Tagged_Type_Expansion then Instr := - Make_OK_Assignment_Statement (Loc, - Name => - Make_Selected_Component (Loc, - Prefix => New_Copy_Tree (Target), - Selector_Name => - New_Occurrence_Of - (First_Tag_Component (Base_Type (Typ)), Loc)), - - Expression => - Unchecked_Convert_To (RTE (RE_Tag), - New_Occurrence_Of - (Node (First_Elmt (Access_Disp_Table (Base_Type (Typ)))), - Loc))); + Make_Tag_Assignment_From_Type + (Loc, New_Copy_Tree (Target), Base_Type (Typ)); Append_To (L, Instr); @@ -4339,15 +3575,11 @@ package body Exp_Aggr is -------------------------------- procedure Convert_Aggr_In_Assignment (N : Node_Id) is - Aggr : Node_Id := Expression (N); + Aggr : constant Node_Id := Unqualify (Expression (N)); Typ : constant Entity_Id := Etype (Aggr); Occ : constant Node_Id := New_Copy_Tree (Name (N)); begin - if Nkind (Aggr) = N_Qualified_Expression then - Aggr := Expression (Aggr); - end if; - Insert_Actions_After (N, Late_Expansion (Aggr, Typ, Occ)); end Convert_Aggr_In_Assignment; @@ -4357,7 +3589,7 @@ package body Exp_Aggr is procedure Convert_Aggr_In_Object_Decl (N : Node_Id) is Obj : constant Entity_Id := Defining_Identifier (N); - Aggr : Node_Id := Expression (N); + Aggr : constant Node_Id := Unqualify (Expression (N)); Loc : constant Source_Ptr := Sloc (Aggr); Typ : constant Entity_Id := Etype (Aggr); Occ : constant Node_Id := New_Occurrence_Of (Obj, Loc); @@ -4437,10 +3669,6 @@ package body Exp_Aggr is begin Set_Assignment_OK (Occ); - if Nkind (Aggr) = N_Qualified_Expression then - Aggr := Expression (Aggr); - end if; - if Has_Discriminants (Typ) and then Typ /= Etype (Obj) and then Is_Constrained (Etype (Obj)) @@ -4505,8 +3733,7 @@ package body Exp_Aggr is while Present (Stmt) loop if Nkind (Stmt) = N_Procedure_Call_Statement - and then Get_TSS_Name (Entity (Name (Stmt))) - = TSS_Slice_Assign + and then Is_TSS (Entity (Name (Stmt)), TSS_Slice_Assign) then Param := First (Parameter_Associations (Stmt)); Insert_Actions @@ -4571,8 +3798,9 @@ package body Exp_Aggr is (Storage_Model_Object (Etype (Prefix (Expression (Target)))))) then - Aggr_Code := Build_Assignment_With_Temporary (Target, - Typ, New_Aggr); + Aggr_Code := + Build_Assignment_With_Temporary (Target, Typ, New_Aggr); + else Aggr_Code := New_List ( @@ -5016,10 +4244,13 @@ package body Exp_Aggr is -- done top down from above. if - -- Internal aggregate (transformed when expanding the parent) + -- Internal aggregates (transformed when expanding the parent), + -- excluding container aggregates as these are transformed into + -- subprogram calls later. - Parent_Kind in - N_Aggregate | N_Extension_Aggregate | N_Component_Association + (Parent_Kind in + N_Component_Association | N_Aggregate | N_Extension_Aggregate + and then not Is_Container_Aggregate (Parent_Node)) -- Allocator (see Convert_Aggr_In_Allocator) @@ -5834,12 +5065,9 @@ package body Exp_Aggr is ---------------------------- procedure Build_Constrained_Type (Positional : Boolean) is - Loc : constant Source_Ptr := Sloc (N); - Agg_Type : constant Entity_Id := Make_Temporary (Loc, 'A'); - Comp : Node_Id; + Agg_Type : constant Entity_Id := Make_Temporary (Loc, 'A'); Decl : Node_Id; - Typ : constant Entity_Id := Etype (N); - Indexes : constant List_Id := New_List; + Indexes : constant List_Id := New_List; Num : Nat; Sub_Agg : Node_Id; @@ -5851,20 +5079,15 @@ package body Exp_Aggr is if Positional then Sub_Agg := N; - for D in 1 .. Number_Dimensions (Typ) loop - Sub_Agg := First (Expressions (Sub_Agg)); - - Comp := Sub_Agg; - Num := 0; - while Present (Comp) loop - Num := Num + 1; - Next (Comp); - end loop; + for D in 1 .. Aggr_Dimension loop + Num := List_Length (Expressions (Sub_Agg)); Append_To (Indexes, Make_Range (Loc, - Low_Bound => Make_Integer_Literal (Loc, 1), + Low_Bound => Make_Integer_Literal (Loc, Uint_1), High_Bound => Make_Integer_Literal (Loc, Num))); + + Sub_Agg := First (Expressions (Sub_Agg)); end loop; else @@ -5872,7 +5095,7 @@ package body Exp_Aggr is -- is not processable by the back end, therefore not necessarily -- positional. Retrieve each dimension bounds (computed earlier). - for D in 1 .. Number_Dimensions (Typ) loop + for D in 1 .. Aggr_Dimension loop Append_To (Indexes, Make_Range (Loc, Low_Bound => Aggr_Low (D), @@ -5888,7 +5111,6 @@ package body Exp_Aggr is Discrete_Subtype_Definitions => Indexes, Component_Definition => Make_Component_Definition (Loc, - Aliased_Present => False, Subtype_Indication => New_Occurrence_Of (Component_Type (Typ), Loc)))); @@ -5909,7 +5131,7 @@ package body Exp_Aggr is Ind_Bounds : constant Range_Nodes := Get_Index_Bounds (Index_Bounds_Node); - Cond : Node_Id := Empty; + Cond : Node_Id; begin -- For a null array aggregate check that high bound (i.e., low @@ -5999,8 +5221,8 @@ package body Exp_Aggr is ---------------------------- procedure Check_Same_Aggr_Bounds (Sub_Aggr : Node_Id; Dim : Pos) is - Sub_Bounds : constant Range_Nodes - := Get_Index_Bounds (Aggregate_Bounds (Sub_Aggr)); + Sub_Bounds : constant Range_Nodes := + Get_Index_Bounds (Aggregate_Bounds (Sub_Aggr)); Sub_Lo : Node_Id renames Sub_Bounds.First; Sub_Hi : Node_Id renames Sub_Bounds.Last; -- The bounds of this specific subaggregate @@ -6012,7 +5234,7 @@ package body Exp_Aggr is Ind_Typ : constant Entity_Id := Aggr_Index_Typ (Dim); -- The index type for this dimension.xxx - Cond : Node_Id := Empty; + Cond : Node_Id; Assoc : Node_Id; Expr : Node_Id; @@ -6886,7 +6108,8 @@ package body Exp_Aggr is -- STEP 3 -- Delay expansion for nested aggregates: it will be taken care of when - -- the parent aggregate is expanded. + -- the parent aggregate is expanded, excluding container aggregates as + -- these are transformed into subprogram calls later. Parent_Node := Parent (N); Parent_Kind := Nkind (Parent_Node); @@ -6896,9 +6119,10 @@ package body Exp_Aggr is Parent_Kind := Nkind (Parent_Node); end if; - if Parent_Kind = N_Aggregate - or else Parent_Kind = N_Extension_Aggregate - or else Parent_Kind = N_Component_Association + if ((Parent_Kind = N_Component_Association + or else Parent_Kind = N_Aggregate + or else Parent_Kind = N_Extension_Aggregate) + and then not Is_Container_Aggregate (Parent_Node)) or else (Parent_Kind = N_Object_Declaration and then (Needs_Finalization (Typ) or else Is_Special_Return_Object @@ -6959,7 +6183,7 @@ package body Exp_Aggr is -- If this is an array of tasks, it will be expanded into build-in-place -- assignments. Build an activation chain for the tasks now. - if Has_Task (Etype (N)) then + if Has_Task (Typ) then Build_Activation_Chain_Entity (N); end if; @@ -7069,7 +6293,6 @@ package body Exp_Aggr is Defining_Identifier => Tmp, Object_Definition => New_Occurrence_Of (Typ, Loc)); Set_No_Initialization (Tmp_Decl, True); - Set_Warnings_Off (Tmp); -- If we are within a loop, the temporary will be pushed on the -- stack at each iteration. If the aggregate is the expression @@ -7081,6 +6304,15 @@ package body Exp_Aggr is and then Parent_Kind = N_Allocator then Establish_Transient_Scope (N, Manage_Sec_Stack => False); + + -- If the parent is an assignment for which no controlled actions + -- should take place, prevent the temporary from being finalized. + + elsif Parent_Kind = N_Assignment_Statement + and then No_Ctrl_Actions (Parent_Node) + then + Mutate_Ekind (Tmp, E_Variable); + Set_Is_Ignored_Transient (Tmp); end if; Insert_Action (N, Tmp_Decl); @@ -7139,20 +6371,20 @@ package body Exp_Aggr is (Storage_Model_Object (Etype (Prefix (Name (Parent_Node)))))) then - Aggr_Code := Build_Assignment_With_Temporary (Target, - Typ, New_Copy_Tree (N)); + Aggr_Code := Build_Assignment_With_Temporary + (Target, Typ, New_Copy_Tree (N)); + else if Maybe_In_Place_OK then return; end if; - Aggr_Code := - New_List ( - Make_Assignment_Statement (Loc, - Name => Target, - Expression => New_Copy_Tree (N))); - + Aggr_Code := New_List ( + Make_Assignment_Statement (Loc, + Name => Target, + Expression => New_Copy_Tree (N))); end if; + else Aggr_Code := Build_Array_Aggr_Code (N, @@ -7398,7 +6630,7 @@ package body Exp_Aggr is Comp : Node_Id; Choice : Node_Id; Lo, Hi : Node_Id; - Siz : Int := 0; + Siz : Int; procedure Add_Range_Size; -- Compute number of components specified by a component association @@ -7423,11 +6655,9 @@ package body Exp_Aggr is end Add_Range_Size; begin - -- Aggregate is either all positional or all named. + -- Aggregate is either all positional or all named - if Present (Expressions (N)) then - Siz := List_Length (Expressions (N)); - end if; + Siz := List_Length (Expressions (N)); if Present (Component_Associations (N)) then Comp := First (Component_Associations (N)); @@ -8702,11 +7932,7 @@ package body Exp_Aggr is return False; end if; - if Nkind (Expression (C)) = N_Qualified_Expression then - Expr_Q := Expression (Expression (C)); - else - Expr_Q := Expression (C); - end if; + Expr_Q := Unqualify (Expression (C)); -- Return False for array components whose bounds raise -- constraint error. @@ -9073,6 +8299,129 @@ package body Exp_Aggr is return False; end Has_Default_Init_Comps; + -------------------------- + -- Initialize_Component -- + -------------------------- + + procedure Initialize_Component + (N : Node_Id; + Comp : Node_Id; + Comp_Typ : Node_Id; + Init_Expr : Node_Id; + Stmts : List_Id) + is + Exceptions_OK : constant Boolean := + not Restriction_Active (No_Exception_Propagation); + Finalization_OK : constant Boolean := + Present (Comp_Typ) + and then Needs_Finalization (Comp_Typ); + Loc : constant Source_Ptr := Sloc (N); + + Blk_Stmts : List_Id; + Init_Stmt : Node_Id; + + begin + pragma Assert (Nkind (Init_Expr) in N_Subexpr); + + -- Protect the initialization statements from aborts. Generate: + + -- Abort_Defer; + + if Finalization_OK and Abort_Allowed then + if Exceptions_OK then + Blk_Stmts := New_List; + else + Blk_Stmts := Stmts; + end if; + + Append_To (Blk_Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer)); + + -- Otherwise aborts are not allowed. All generated code is added + -- directly to the input list. + + else + Blk_Stmts := Stmts; + end if; + + -- Initialize the component. Generate: + + -- Comp := Init_Expr; + + -- Note that the initialization expression is not duplicated because + -- either only a single component may be initialized by it (record) + -- or it has already been duplicated if need be (array). + + Init_Stmt := + Make_OK_Assignment_Statement (Loc, + Name => New_Copy_Tree (Comp), + Expression => Relocate_Node (Init_Expr)); + + Append_To (Blk_Stmts, Init_Stmt); + + -- Arrange for the component to be adjusted if need be (the call will be + -- generated by Make_Tag_Ctrl_Assignment). But, in the case of an array + -- aggregate, controlled subaggregates are not considered because each + -- of their individual elements will receive an adjustment of its own. + + if Finalization_OK + and then not Is_Limited_View (Comp_Typ) + and then not + (Is_Array_Type (Etype (N)) + and then Is_Array_Type (Comp_Typ) + and then Needs_Finalization (Component_Type (Comp_Typ)) + and then Nkind (Unqualify (Init_Expr)) = N_Aggregate) + then + Set_No_Finalize_Actions (Init_Stmt); + + -- Or else, only adjust the tag due to a possible view conversion + + else + Set_No_Ctrl_Actions (Init_Stmt); + + if Tagged_Type_Expansion and then Is_Tagged_Type (Comp_Typ) then + Append_To (Blk_Stmts, + Make_Tag_Assignment_From_Type + (Loc, New_Copy_Tree (Comp), Underlying_Type (Comp_Typ))); + end if; + end if; + + -- Complete the protection of the initialization statements + + if Finalization_OK and Abort_Allowed then + + -- Wrap the initialization statements in a block to catch a + -- potential exception. Generate: + + -- begin + -- Abort_Defer; + -- Comp := Init_Expr; + -- Comp._tag := Full_TypP; + -- [Deep_]Adjust (Comp); + -- at end + -- Abort_Undefer_Direct; + -- end; + + if Exceptions_OK then + Append_To (Stmts, + Build_Abort_Undefer_Block (Loc, + Stmts => Blk_Stmts, + Context => N)); + + -- Otherwise exceptions are not propagated. Generate: + + -- Abort_Defer; + -- Comp := Init_Expr; + -- Comp._tag := Full_TypP; + -- [Deep_]Adjust (Comp); + -- Abort_Undefer; + + else + Append_To (Blk_Stmts, + Build_Runtime_Call (Loc, RE_Abort_Undefer)); + end if; + end if; + end Initialize_Component; + ---------------------------------------- -- Is_Build_In_Place_Aggregate_Return -- ---------------------------------------- @@ -9105,17 +8454,11 @@ package body Exp_Aggr is -------------------------- function Is_Delayed_Aggregate (N : Node_Id) return Boolean is - Node : Node_Id := N; - Kind : Node_Kind := Nkind (Node); + Unqual_N : constant Node_Id := Unqualify (N); begin - if Kind = N_Qualified_Expression then - Node := Expression (Node); - Kind := Nkind (Node); - end if; - - return Kind in N_Aggregate | N_Extension_Aggregate - and then Expansion_Delayed (Node); + return Nkind (Unqual_N) in N_Aggregate | N_Extension_Aggregate + and then Expansion_Delayed (Unqual_N); end Is_Delayed_Aggregate; -------------------------------- @@ -9803,295 +9146,6 @@ package body Exp_Aggr is end if; end Must_Slide; - --------------------------------- - -- Process_Transient_Component -- - --------------------------------- - - procedure Process_Transient_Component - (Loc : Source_Ptr; - Comp_Typ : Entity_Id; - Init_Expr : Node_Id; - Fin_Call : out Node_Id; - Hook_Clear : out Node_Id; - Aggr : Node_Id := Empty; - Stmts : List_Id := No_List) - is - procedure Add_Item (Item : Node_Id); - -- Insert arbitrary node Item into the tree depending on the values of - -- Aggr and Stmts. - - -------------- - -- Add_Item -- - -------------- - - procedure Add_Item (Item : Node_Id) is - begin - if Present (Aggr) then - Insert_Action (Aggr, Item); - else - pragma Assert (Present (Stmts)); - Append_To (Stmts, Item); - end if; - end Add_Item; - - -- Local variables - - Hook_Assign : Node_Id; - Hook_Decl : Node_Id; - Ptr_Decl : Node_Id; - Res_Decl : Node_Id; - Res_Id : Entity_Id; - Res_Typ : Entity_Id; - - -- Start of processing for Process_Transient_Component - - begin - -- Add the access type, which provides a reference to the function - -- result. Generate: - - -- type Res_Typ is access all Comp_Typ; - - Res_Typ := Make_Temporary (Loc, 'A'); - Mutate_Ekind (Res_Typ, E_General_Access_Type); - Set_Directly_Designated_Type (Res_Typ, Comp_Typ); - - Add_Item - (Make_Full_Type_Declaration (Loc, - Defining_Identifier => Res_Typ, - Type_Definition => - Make_Access_To_Object_Definition (Loc, - All_Present => True, - Subtype_Indication => New_Occurrence_Of (Comp_Typ, Loc)))); - - -- Add the temporary which captures the result of the function call. - -- Generate: - - -- Res : constant Res_Typ := Init_Expr'Reference; - - -- Note that this temporary is effectively a transient object because - -- its lifetime is bounded by the current array or record component. - - Res_Id := Make_Temporary (Loc, 'R'); - Mutate_Ekind (Res_Id, E_Constant); - Set_Etype (Res_Id, Res_Typ); - - -- Mark the transient object as successfully processed to avoid double - -- finalization. - - Set_Is_Finalized_Transient (Res_Id); - - -- Signal the general finalization machinery that this transient object - -- should not be considered for finalization actions because its cleanup - -- will be performed by Process_Transient_Component_Completion. - - Set_Is_Ignored_Transient (Res_Id); - - Res_Decl := - Make_Object_Declaration (Loc, - Defining_Identifier => Res_Id, - Constant_Present => True, - Object_Definition => New_Occurrence_Of (Res_Typ, Loc), - Expression => - Make_Reference (Loc, New_Copy_Tree (Init_Expr))); - - Add_Item (Res_Decl); - - -- Construct all pieces necessary to hook and finalize the transient - -- result. - - Build_Transient_Object_Statements - (Obj_Decl => Res_Decl, - Fin_Call => Fin_Call, - Hook_Assign => Hook_Assign, - Hook_Clear => Hook_Clear, - Hook_Decl => Hook_Decl, - Ptr_Decl => Ptr_Decl); - - -- Add the access type which provides a reference to the transient - -- result. Generate: - - -- type Ptr_Typ is access all Comp_Typ; - - Add_Item (Ptr_Decl); - - -- Add the temporary which acts as a hook to the transient result. - -- Generate: - - -- Hook : Ptr_Typ := null; - - Add_Item (Hook_Decl); - - -- Attach the transient result to the hook. Generate: - - -- Hook := Ptr_Typ (Res); - - Add_Item (Hook_Assign); - - -- The original initialization expression now references the value of - -- the temporary function result. Generate: - - -- Res.all - - Rewrite (Init_Expr, - Make_Explicit_Dereference (Loc, - Prefix => New_Occurrence_Of (Res_Id, Loc))); - end Process_Transient_Component; - - -------------------------------------------- - -- Process_Transient_Component_Completion -- - -------------------------------------------- - - procedure Process_Transient_Component_Completion - (Loc : Source_Ptr; - Aggr : Node_Id; - Fin_Call : Node_Id; - Hook_Clear : Node_Id; - Stmts : List_Id) - is - Exceptions_OK : constant Boolean := - not Restriction_Active (No_Exception_Propagation); - - begin - pragma Assert (Present (Hook_Clear)); - - -- Generate the following code if exception propagation is allowed: - - -- declare - -- Abort : constant Boolean := Triggered_By_Abort; - -- <or> - -- Abort : constant Boolean := False; -- no abort - - -- E : Exception_Occurrence; - -- Raised : Boolean := False; - - -- begin - -- [Abort_Defer;] - - -- begin - -- Hook := null; - -- [Deep_]Finalize (Res.all); - - -- exception - -- when others => - -- if not Raised then - -- Raised := True; - -- Save_Occurrence (E, - -- Get_Curent_Excep.all.all); - -- end if; - -- end; - - -- [Abort_Undefer;] - - -- if Raised and then not Abort then - -- Raise_From_Controlled_Operation (E); - -- end if; - -- end; - - if Exceptions_OK then - Abort_And_Exception : declare - Blk_Decls : constant List_Id := New_List; - Blk_Stmts : constant List_Id := New_List; - Fin_Stmts : constant List_Id := New_List; - - Fin_Data : Finalization_Exception_Data; - - begin - -- Create the declarations of the two flags and the exception - -- occurrence. - - Build_Object_Declarations (Fin_Data, Blk_Decls, Loc); - - -- Generate: - -- Abort_Defer; - - if Abort_Allowed then - Append_To (Blk_Stmts, - Build_Runtime_Call (Loc, RE_Abort_Defer)); - end if; - - -- Wrap the hook clear and the finalization call in order to trap - -- a potential exception. - - Append_To (Fin_Stmts, Hook_Clear); - - if Present (Fin_Call) then - Append_To (Fin_Stmts, Fin_Call); - end if; - - Append_To (Blk_Stmts, - Make_Block_Statement (Loc, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => Fin_Stmts, - Exception_Handlers => New_List ( - Build_Exception_Handler (Fin_Data))))); - - -- Generate: - -- Abort_Undefer; - - if Abort_Allowed then - Append_To (Blk_Stmts, - Build_Runtime_Call (Loc, RE_Abort_Undefer)); - end if; - - -- Reraise the potential exception with a proper "upgrade" to - -- Program_Error if needed. - - Append_To (Blk_Stmts, Build_Raise_Statement (Fin_Data)); - - -- Wrap everything in a block - - Append_To (Stmts, - Make_Block_Statement (Loc, - Declarations => Blk_Decls, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => Blk_Stmts))); - end Abort_And_Exception; - - -- Generate the following code if exception propagation is not allowed - -- and aborts are allowed: - - -- begin - -- Abort_Defer; - -- Hook := null; - -- [Deep_]Finalize (Res.all); - -- at end - -- Abort_Undefer_Direct; - -- end; - - elsif Abort_Allowed then - Abort_Only : declare - Blk_Stmts : constant List_Id := New_List; - - begin - Append_To (Blk_Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer)); - Append_To (Blk_Stmts, Hook_Clear); - - if Present (Fin_Call) then - Append_To (Blk_Stmts, Fin_Call); - end if; - - Append_To (Stmts, - Build_Abort_Undefer_Block (Loc, - Stmts => Blk_Stmts, - Context => Aggr)); - end Abort_Only; - - -- Otherwise generate: - - -- Hook := null; - -- [Deep_]Finalize (Res.all); - - else - Append_To (Stmts, Hook_Clear); - - if Present (Fin_Call) then - Append_To (Stmts, Fin_Call); - end if; - end if; - end Process_Transient_Component_Completion; - --------------------- -- Sort_Case_Table -- --------------------- diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index aababd5..6b498eb 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -77,8 +77,55 @@ with Uname; use Uname; with Urealp; use Urealp; with Validsw; use Validsw; +with GNAT.HTable; + package body Exp_Attr is + package Cached_Streaming_Ops is + + Map_Size : constant := 63; + subtype Header_Num is Integer range 0 .. Map_Size - 1; + + function Streaming_Op_Hash (Id : Entity_Id) return Header_Num is + (Header_Num (Id mod Map_Size)); + + -- Cache used to avoid building duplicate subprograms for a single + -- type/streaming-attribute pair. + + package Read_Map is new GNAT.HTable.Simple_HTable + (Header_Num => Header_Num, + Key => Entity_Id, + Element => Entity_Id, + No_Element => Empty, + Hash => Streaming_Op_Hash, + Equal => "="); + + package Write_Map is new GNAT.HTable.Simple_HTable + (Header_Num => Header_Num, + Key => Entity_Id, + Element => Entity_Id, + No_Element => Empty, + Hash => Streaming_Op_Hash, + Equal => "="); + + package Input_Map is new GNAT.HTable.Simple_HTable + (Header_Num => Header_Num, + Key => Entity_Id, + Element => Entity_Id, + No_Element => Empty, + Hash => Streaming_Op_Hash, + Equal => "="); + + package Output_Map is new GNAT.HTable.Simple_HTable + (Header_Num => Header_Num, + Key => Entity_Id, + Element => Entity_Id, + No_Element => Empty, + Hash => Streaming_Op_Hash, + Equal => "="); + + end Cached_Streaming_Ops; + ----------------------- -- Local Subprograms -- ----------------------- @@ -210,13 +257,15 @@ package body Exp_Attr is -- is not a floating-point type. function Find_Stream_Subprogram - (Typ : Entity_Id; - Nam : TSS_Name_Type) return Entity_Id; + (Typ : Entity_Id; + Nam : TSS_Name_Type; + Attr_Ref : Node_Id) return Entity_Id; -- Returns the stream-oriented subprogram attribute for Typ. For tagged -- types, the corresponding primitive operation is looked up, else the -- appropriate TSS from the type itself, or from its closest ancestor -- defining it, is returned. In both cases, inheritance of representation - -- aspects is thus taken into account. + -- aspects is thus taken into account. Attr_Ref is used to identify the + -- point from which the function result will be referenced. function Full_Base (T : Entity_Id) return Entity_Id; -- The stream functions need to examine the underlying representation of @@ -1354,14 +1403,14 @@ package body Exp_Attr is -- Local variables - Pref : constant Node_Id := Prefix (N); - Base_Typ : constant Entity_Id := Base_Type (Etype (Pref)); - Exprs : constant List_Id := Expressions (N); + Pref : constant Node_Id := Prefix (N); + Base_Typ : constant Entity_Id := Base_Type (Etype (Pref)); + Exprs : constant List_Id := Expressions (N); + Loc : constant Source_Ptr := Sloc (N); Aux_Decl : Node_Id; Blk : Node_Id := Empty; Decls : List_Id; Installed : Boolean; - Loc : Source_Ptr; Loop_Id : Entity_Id; Loop_Stmt : Node_Id; Result : Node_Id := Empty; @@ -1402,8 +1451,6 @@ package body Exp_Attr is Loop_Id := Entity (Identifier (Loop_Stmt)); end if; - Loc := Sloc (Loop_Stmt); - -- Step 2: Transform the loop -- The loop has already been transformed during the expansion of a prior @@ -4117,18 +4164,19 @@ package body Exp_Attr is ----------- when Attribute_Input => Input : declare - P_Type : constant Entity_Id := Entity (Pref); - B_Type : constant Entity_Id := Base_Type (P_Type); - U_Type : constant Entity_Id := Underlying_Type (P_Type); - Strm : constant Node_Id := First (Exprs); - Fname : Entity_Id; - Decl : Node_Id; - Call : Node_Id; - Prag : Node_Id; - Arg2 : Node_Id; - Rfunc : Node_Id; + P_Type : constant Entity_Id := Entity (Pref); + B_Type : constant Entity_Id := Base_Type (P_Type); + U_Type : constant Entity_Id := Underlying_Type (P_Type); + Strm : constant Node_Id := First (Exprs); + Has_TSS : Boolean := False; + Fname : Entity_Id; + Decl : Node_Id; + Call : Node_Id; + Prag : Node_Id; + Arg2 : Node_Id; + Rfunc : Node_Id; - Cntrl : Node_Id := Empty; + Cntrl : Node_Id := Empty; -- Value for controlling argument in call. Always Empty except in -- the dispatching (class-wide type) case, where it is a reference -- to the dummy object initialized to the right internal tag. @@ -4194,10 +4242,10 @@ package body Exp_Attr is -- If there is a TSS for Input, just call it - Fname := Find_Stream_Subprogram (P_Type, TSS_Stream_Input); + Fname := Find_Stream_Subprogram (P_Type, TSS_Stream_Input, N); if Present (Fname) then - null; + Has_TSS := True; else -- If there is a Stream_Convert pragma, use it, we rewrite @@ -4254,7 +4302,7 @@ package body Exp_Attr is if Present (Find_Inherited_TSS (P_Type, TSS_Stream_Read)) then Build_Record_Or_Elementary_Input_Function - (Loc, P_Type, Decl, Fname); + (P_Type, Decl, Fname); Insert_Action (N, Decl); -- For normal cases, we call the I_xxx routine directly @@ -4268,7 +4316,7 @@ package body Exp_Attr is -- Array type case elsif Is_Array_Type (U_Type) then - Build_Array_Input_Function (Loc, U_Type, Decl, Fname); + Build_Array_Input_Function (U_Type, Decl, Fname); Compile_Stream_Body_In_Scope (N, Decl, U_Type); -- Dispatching case with class-wide type @@ -4397,7 +4445,7 @@ package body Exp_Attr is -- constrained discriminants (see Ada 2012 AI05-0192). Build_Record_Or_Elementary_Input_Function - (Loc, U_Type, Decl, Fname); + (U_Type, Decl, Fname); Insert_Action (N, Decl); if Nkind (Parent (N)) = N_Object_Declaration @@ -4415,7 +4463,7 @@ package body Exp_Attr is while Present (Comp) loop Func := Find_Stream_Subprogram - (Etype (Comp), TSS_Stream_Read); + (Etype (Comp), TSS_Stream_Read, N); if Present (Func) then Freeze_Stream_Subprogram (Func); @@ -4445,6 +4493,10 @@ package body Exp_Attr is if Nkind (Parent (N)) = N_Object_Declaration then Freeze_Stream_Subprogram (Fname); end if; + + if not Has_TSS then + Cached_Streaming_Ops.Input_Map.Set (P_Type, Fname); + end if; end Input; ------------------- @@ -4999,7 +5051,7 @@ package body Exp_Attr is if Present (Subp) then Ins_Nod := Subp; - -- General case where the postcondtion checks occur after the call + -- General case where the postcondition checks occur after the call -- to _Wrapped_Statements. else @@ -5281,13 +5333,14 @@ package body Exp_Attr is ------------ when Attribute_Output => Output : declare - P_Type : constant Entity_Id := Entity (Pref); - U_Type : constant Entity_Id := Underlying_Type (P_Type); - Pname : Entity_Id; - Decl : Node_Id; - Prag : Node_Id; - Arg3 : Node_Id; - Wfunc : Node_Id; + P_Type : constant Entity_Id := Entity (Pref); + U_Type : constant Entity_Id := Underlying_Type (P_Type); + Has_TSS : Boolean := False; + Pname : Entity_Id; + Decl : Node_Id; + Prag : Node_Id; + Arg3 : Node_Id; + Wfunc : Node_Id; begin -- If no underlying type, we have an error that will be diagnosed @@ -5312,10 +5365,10 @@ package body Exp_Attr is -- If TSS for Output is present, just call it - Pname := Find_Stream_Subprogram (P_Type, TSS_Stream_Output); + Pname := Find_Stream_Subprogram (P_Type, TSS_Stream_Output, N); if Present (Pname) then - null; + Has_TSS := True; else -- If there is a Stream_Convert pragma, use it, we rewrite @@ -5376,7 +5429,7 @@ package body Exp_Attr is if Present (Find_Inherited_TSS (P_Type, TSS_Stream_Write)) then Build_Record_Or_Elementary_Output_Procedure - (Loc, P_Type, Decl, Pname); + (P_Type, Decl, Pname); Insert_Action (N, Decl); -- For normal cases, we call the W_xxx routine directly @@ -5390,7 +5443,7 @@ package body Exp_Attr is -- Array type case elsif Is_Array_Type (U_Type) then - Build_Array_Output_Procedure (Loc, U_Type, Decl, Pname); + Build_Array_Output_Procedure (U_Type, Decl, Pname); Compile_Stream_Body_In_Scope (N, Decl, U_Type); -- Class-wide case, first output external tag, then dispatch @@ -5501,7 +5554,7 @@ package body Exp_Attr is end if; Build_Record_Or_Elementary_Output_Procedure - (Loc, Base_Type (U_Type), Decl, Pname); + (Base_Type (U_Type), Decl, Pname); Insert_Action (N, Decl); end if; end if; @@ -5509,6 +5562,10 @@ package body Exp_Attr is -- If we fall through, Pname is the name of the procedure to call Rewrite_Attribute_Proc_Call (Pname); + + if not Has_TSS then + Cached_Streaming_Ops.Output_Map.Set (P_Type, Pname); + end if; end Output; --------- @@ -5978,27 +6035,30 @@ package body Exp_Attr is when Attribute_Reduce => declare Loc : constant Source_Ptr := Sloc (N); - E1 : constant Node_Id := First (Expressions (N)); - E2 : constant Node_Id := Next (E1); - Bnn : constant Entity_Id := Make_Temporary (Loc, 'B', N); - Typ : constant Entity_Id := Etype (N); + E1 : constant Node_Id := First (Expressions (N)); + E2 : constant Node_Id := Next (E1); + Bnn : constant Entity_Id := Make_Temporary (Loc, 'B', N); - New_Loop : Node_Id; - Stat : Node_Id; + Accum_Typ : Entity_Id; + New_Loop : Node_Id; function Build_Stat (Comp : Node_Id) return Node_Id; -- The reducer can be a function, a procedure whose first -- parameter is in-out, or an attribute that is a function, -- which (for now) can only be Min/Max. This subprogram - -- builds the corresponding computation for the generated loop. + -- builds the corresponding computation for the generated loop + -- and retrieves the accumulator type as per RM 4.5.10(19/5). ---------------- -- Build_Stat -- ---------------- function Build_Stat (Comp : Node_Id) return Node_Id is + Stat : Node_Id; + begin if Nkind (E1) = N_Attribute_Reference then + Accum_Typ := Entity (Prefix (E1)); Stat := Make_Assignment_Statement (Loc, Name => New_Occurrence_Of (Bnn, Loc), Expression => Make_Attribute_Reference (Loc, @@ -6009,12 +6069,14 @@ package body Exp_Attr is Comp))); elsif Ekind (Entity (E1)) = E_Procedure then + Accum_Typ := Etype (First_Formal (Entity (E1))); Stat := Make_Procedure_Call_Statement (Loc, Name => New_Occurrence_Of (Entity (E1), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (Bnn, Loc), Comp)); else + Accum_Typ := Etype (Entity (E1)); Stat := Make_Assignment_Statement (Loc, Name => New_Occurrence_Of (Bnn, Loc), Expression => Make_Function_Call (Loc, @@ -6074,6 +6136,13 @@ package body Exp_Attr is End_Label => Empty, Statements => New_List (Build_Stat (Relocate_Node (Expr)))); + + -- If the reducer subprogram is a universal operator, then + -- we still look at the context to find the type for now. + + if Is_Universal_Numeric_Type (Accum_Typ) then + Accum_Typ := Etype (N); + end if; end; else @@ -6082,9 +6151,10 @@ package body Exp_Attr is -- a container with the proper aspects. declare - Iter : Node_Id; Elem : constant Entity_Id := Make_Temporary (Loc, 'E', N); + Iter : Node_Id; + begin Iter := Make_Iterator_Specification (Loc, @@ -6101,6 +6171,44 @@ package body Exp_Attr is End_Label => Empty, Statements => New_List ( Build_Stat (New_Occurrence_Of (Elem, Loc)))); + + -- If the reducer subprogram is a universal operator, then + -- we need to look at the prefix to find the type. This is + -- modeled on Analyze_Iterator_Specification in Sem_Ch5. + + if Is_Universal_Numeric_Type (Accum_Typ) then + declare + Ptyp : constant Entity_Id := + Base_Type (Etype (Prefix (N))); + + begin + if Is_Array_Type (Ptyp) then + Accum_Typ := Component_Type (Ptyp); + + elsif Has_Aspect (Ptyp, Aspect_Iterable) then + declare + Element : constant Entity_Id := + Get_Iterable_Type_Primitive + (Ptyp, Name_Element); + begin + if Present (Element) then + Accum_Typ := Etype (Element); + end if; + end; + + else + declare + Element : constant Node_Id := + Find_Value_Of_Aspect + (Ptyp, Aspect_Iterator_Element); + begin + if Present (Element) then + Accum_Typ := Entity (Element); + end if; + end; + end if; + end; + end if; end; end if; @@ -6110,10 +6218,11 @@ package body Exp_Attr is Make_Object_Declaration (Loc, Defining_Identifier => Bnn, Object_Definition => - New_Occurrence_Of (Typ, Loc), + New_Occurrence_Of (Accum_Typ, Loc), Expression => Relocate_Node (E2)), New_Loop), Expression => New_Occurrence_Of (Bnn, Loc))); - Analyze_And_Resolve (N, Typ); + + Analyze_And_Resolve (N, Accum_Typ); end; ---------- @@ -6121,16 +6230,17 @@ package body Exp_Attr is ---------- when Attribute_Read => Read : declare - P_Type : constant Entity_Id := Entity (Pref); - B_Type : constant Entity_Id := Base_Type (P_Type); - U_Type : constant Entity_Id := Underlying_Type (P_Type); - Pname : Entity_Id; - Decl : Node_Id; - Prag : Node_Id; - Arg2 : Node_Id; - Rfunc : Node_Id; - Lhs : Node_Id; - Rhs : Node_Id; + P_Type : constant Entity_Id := Entity (Pref); + B_Type : constant Entity_Id := Base_Type (P_Type); + U_Type : constant Entity_Id := Underlying_Type (P_Type); + Has_TSS : Boolean := False; + Pname : Entity_Id; + Decl : Node_Id; + Prag : Node_Id; + Arg2 : Node_Id; + Rfunc : Node_Id; + Lhs : Node_Id; + Rhs : Node_Id; begin -- If no underlying type, we have an error that will be diagnosed @@ -6155,10 +6265,10 @@ package body Exp_Attr is -- The simple case, if there is a TSS for Read, just call it - Pname := Find_Stream_Subprogram (P_Type, TSS_Stream_Read); + Pname := Find_Stream_Subprogram (P_Type, TSS_Stream_Read, N); if Present (Pname) then - null; + Has_TSS := True; else -- If there is a Stream_Convert pragma, use it, we rewrite @@ -6258,7 +6368,7 @@ package body Exp_Attr is -- Array type case elsif Is_Array_Type (U_Type) then - Build_Array_Read_Procedure (N, U_Type, Decl, Pname); + Build_Array_Read_Procedure (U_Type, Decl, Pname); Compile_Stream_Body_In_Scope (N, Decl, U_Type); -- Tagged type case, use the primitive Read function. Note that @@ -6292,10 +6402,10 @@ package body Exp_Attr is if Has_Defaulted_Discriminants (U_Type) then Build_Mutable_Record_Read_Procedure - (Loc, Full_Base (U_Type), Decl, Pname); + (Full_Base (U_Type), Decl, Pname); else Build_Record_Read_Procedure - (Loc, Full_Base (U_Type), Decl, Pname); + (Full_Base (U_Type), Decl, Pname); end if; Insert_Action (N, Decl); @@ -6303,6 +6413,10 @@ package body Exp_Attr is end if; Rewrite_Attribute_Proc_Call (Pname); + + if not Has_TSS then + Cached_Streaming_Ops.Read_Map.Set (P_Type, Pname); + end if; end Read; --------- @@ -7807,13 +7921,14 @@ package body Exp_Attr is ----------- when Attribute_Write => Write : declare - P_Type : constant Entity_Id := Entity (Pref); - U_Type : constant Entity_Id := Underlying_Type (P_Type); - Pname : Entity_Id; - Decl : Node_Id; - Prag : Node_Id; - Arg3 : Node_Id; - Wfunc : Node_Id; + P_Type : constant Entity_Id := Entity (Pref); + U_Type : constant Entity_Id := Underlying_Type (P_Type); + Has_TSS : Boolean := False; + Pname : Entity_Id; + Decl : Node_Id; + Prag : Node_Id; + Arg3 : Node_Id; + Wfunc : Node_Id; begin -- If no underlying type, we have an error that will be diagnosed @@ -7838,10 +7953,10 @@ package body Exp_Attr is -- The simple case, if there is a TSS for Write, just call it - Pname := Find_Stream_Subprogram (P_Type, TSS_Stream_Write); + Pname := Find_Stream_Subprogram (P_Type, TSS_Stream_Write, N); if Present (Pname) then - null; + Has_TSS := True; else -- If there is a Stream_Convert pragma, use it, we rewrite @@ -7901,7 +8016,7 @@ package body Exp_Attr is -- Array type case elsif Is_Array_Type (U_Type) then - Build_Array_Write_Procedure (N, U_Type, Decl, Pname); + Build_Array_Write_Procedure (U_Type, Decl, Pname); Compile_Stream_Body_In_Scope (N, Decl, U_Type); -- Tagged type case, use the primitive Write function. Note that @@ -7942,10 +8057,10 @@ package body Exp_Attr is if Has_Defaulted_Discriminants (U_Type) then Build_Mutable_Record_Write_Procedure - (Loc, Full_Base (U_Type), Decl, Pname); + (Full_Base (U_Type), Decl, Pname); else Build_Record_Write_Procedure - (Loc, Full_Base (U_Type), Decl, Pname); + (Full_Base (U_Type), Decl, Pname); end if; Insert_Action (N, Decl); @@ -7955,6 +8070,10 @@ package body Exp_Attr is -- If we fall through, Pname is the procedure to be called Rewrite_Attribute_Proc_Call (Pname); + + if not Has_TSS then + Cached_Streaming_Ops.Write_Map.Set (P_Type, Pname); + end if; end Write; -- The following attributes are handled by the back end (except that @@ -8526,16 +8645,102 @@ package body Exp_Attr is ---------------------------- function Find_Stream_Subprogram - (Typ : Entity_Id; - Nam : TSS_Name_Type) return Entity_Id + (Typ : Entity_Id; + Nam : TSS_Name_Type; + Attr_Ref : Node_Id) return Entity_Id is + + function In_Available_Context (Ent : Entity_Id) return Boolean; + -- Ent is a candidate result for Find_Stream_Subprogram. + -- If, for example, a subprogram is declared within a case + -- alternative then Gigi does not want to see a call to it from + -- outside of the case alternative. Compare placement of Ent and + -- Attr_Ref to prevent this situation (by returning False). + + -------------------------- + -- In_Available_Context -- + -------------------------- + + function In_Available_Context (Ent : Entity_Id) return Boolean is + Decl : Node_Id := Enclosing_Declaration (Ent); + begin + -- Enclosing_Declaration does not always return a declaration; + -- cope with this irregularity. + if Decl in N_Subprogram_Specification_Id + and then Nkind (Parent (Decl)) in + N_Subprogram_Body | N_Subprogram_Declaration + then + Decl := Parent (Decl); + end if; + + if Has_Declarations (Parent (Decl)) then + return In_Subtree (Attr_Ref, Root => Parent (Decl)); + elsif Is_List_Member (Decl) then + declare + List_Elem : Node_Id := Next (Decl); + begin + while Present (List_Elem) loop + if In_Subtree (Attr_Ref, Root => List_Elem) then + return True; + end if; + Next (List_Elem); + end loop; + return False; + end; + else + return False; -- Can this occur ??? + end if; + end In_Available_Context; + + -- Local declarations + Base_Typ : constant Entity_Id := Base_Type (Typ); - Ent : constant Entity_Id := TSS (Typ, Nam); + Ent : Entity_Id := TSS (Typ, Nam); + + -- Start of processing for Find_Stream_Subprogram + begin if Present (Ent) then return Ent; end if; + -- Everything after this point is an optimization. In other words, + -- there should be no *correctness* problems if we were to + -- unconditionally return Empty here. + + if Is_Unchecked_Union (Base_Typ) then + -- Conservatively avoid possible problems (e.g., Write behaves + -- differently for a U_U type when called by Output vs. when + -- called from elsewhere). + + return Empty; + end if; + + if Nam = TSS_Stream_Read then + Ent := Cached_Streaming_Ops.Read_Map.Get (Typ); + elsif Nam = TSS_Stream_Write then + Ent := Cached_Streaming_Ops.Write_Map.Get (Typ); + elsif Nam = TSS_Stream_Input then + Ent := Cached_Streaming_Ops.Input_Map.Get (Typ); + elsif Nam = TSS_Stream_Output then + Ent := Cached_Streaming_Ops.Output_Map.Get (Typ); + end if; + + if Present (Ent) then + -- Can't reuse Ent if it is no longer in scope + + if In_Open_Scopes (Scope (Ent)) + + -- The preceding In_Open_Scopes test may not suffice if + -- case alternatives are involved. + and then In_Available_Context (Ent) + then + return Ent; + else + Ent := Empty; + end if; + end if; + -- Stream attributes for strings are expanded into library calls. The -- following checks are disabled when the run-time is not available or -- when compiling predefined types due to bootstrap issues. As a result, diff --git a/gcc/ada/exp_ch11.adb b/gcc/ada/exp_ch11.adb index e2adefe..53f0753 100644 --- a/gcc/ada/exp_ch11.adb +++ b/gcc/ada/exp_ch11.adb @@ -1210,7 +1210,7 @@ package body Exp_Ch11 is declare Use_Test_And_Set_Flag : constant Boolean := - (not Global_No_Tasking) + not Global_No_Tasking and then RTE_Available (RE_Test_And_Set_Flag); Flag_Decl : Node_Id; @@ -1592,10 +1592,8 @@ package body Exp_Ch11 is else -- Bypass expansion to a run-time call when back-end exception - -- handling is active, unless the target is CodePeer or GNATprove. - -- In CodePeer, raising an exception is treated as an error, while in - -- GNATprove all code with exceptions falls outside the subset of - -- code which can be formally analyzed. + -- handling is active, unless the target is CodePeer, where + -- raising an exception is treated as an error. if not CodePeer_Mode then return; @@ -1604,7 +1602,7 @@ package body Exp_Ch11 is -- Find innermost enclosing exception handler (there must be one, -- since the semantics has already verified that this raise statement -- is valid, and a raise with no arguments is only permitted in the - -- context of an exception handler. + -- context of an exception handler). Ehand := Parent (N); while Nkind (Ehand) /= N_Exception_Handler loop @@ -1803,95 +1801,77 @@ package body Exp_Ch11 is -- Test for handled sequence of statements with at least one -- exception handler which might be the one we are looking for. - elsif Nkind (P) = N_Handled_Sequence_Of_Statements - and then Present (Exception_Handlers (P)) - then - -- Before we proceed we need to check if the node N is covered - -- by the statement part of P rather than one of its exception - -- handlers (an exception handler obviously does not cover its - -- own statements). - - -- This test is more delicate than might be thought. It is not - -- just a matter of checking the Statements (P), because the node - -- might be waiting to be wrapped in a transient scope, in which - -- case it will end up in the block statements, even though it - -- is not there now. - - if Is_List_Member (N) then - declare - LCN : constant List_Id := List_Containing (N); - - begin - if LCN = Statements (P) - or else - LCN = SSE.Actions_To_Be_Wrapped (Before) - or else - LCN = SSE.Actions_To_Be_Wrapped (After) - or else - LCN = SSE.Actions_To_Be_Wrapped (Cleanup) - then - -- Loop through exception handlers + -- We need to check if the node N is covered by the statement part of + -- P rather than one of its exception handlers (an exception handler + -- obviously does not cover its own statements). - H := First (Exception_Handlers (P)); - while Present (H) loop + -- This test is more delicate than might be thought. It is not just + -- a matter of checking the Statements (P), because the node might be + -- waiting to be wrapped in a transient scope, in which case it will + -- end up in the block statements, even though it is not there now. - -- Guard against other constructs appearing in the - -- list of exception handlers. + elsif Nkind (P) = N_Handled_Sequence_Of_Statements + and then Is_List_Member (N) + and then List_Containing (N) in Statements (P) + | SSE.Actions_To_Be_Wrapped (Before) + | SSE.Actions_To_Be_Wrapped (After) + | SSE.Actions_To_Be_Wrapped (Cleanup) + then + -- Loop through exception handlers and guard against pragmas + -- appearing among them. - if Nkind (H) = N_Exception_Handler then + H := First_Non_Pragma (Exception_Handlers (P)); + while Present (H) loop - -- Loop through choices in one handler + -- Guard against other constructs appearing in the list of + -- exception handlers. - C := First (Exception_Choices (H)); - while Present (C) loop + -- Loop through choices in one handler - -- Deal with others case + C := First (Exception_Choices (H)); + while Present (C) loop - if Nkind (C) = N_Others_Choice then + -- Deal with others case - -- Matching others handler, but we need - -- to ensure there is no choice parameter. - -- If there is, then we don't have a local - -- handler after all (since we do not allow - -- choice parameters for local handlers). + if Nkind (C) = N_Others_Choice then - if No (Choice_Parameter (H)) then - return H; - else - return Empty; - end if; + -- Matching others handler, but we need to ensure there + -- is no choice parameter. If there is, then we don't + -- have a local handler after all (since we do not allow + -- choice parameters for local handlers). - -- If not others must be entity name + if No (Choice_Parameter (H)) then + return H; + else + return Empty; + end if; - elsif Nkind (C) /= N_Others_Choice then - pragma Assert (Is_Entity_Name (C)); - pragma Assert (Present (Entity (C))); + -- If not others must be entity name - -- Get exception being handled, dealing with - -- renaming. + else + pragma Assert (Is_Entity_Name (C)); + pragma Assert (Present (Entity (C))); - EHandle := Get_Renamed_Entity (Entity (C)); + -- Get exception being handled, dealing with renaming - -- If match, then check choice parameter + EHandle := Get_Renamed_Entity (Entity (C)); - if ERaise = EHandle then - if No (Choice_Parameter (H)) then - return H; - else - return Empty; - end if; - end if; - end if; + -- If match, then check choice parameter - Next (C); - end loop; + if ERaise = EHandle then + if No (Choice_Parameter (H)) then + return H; + else + return Empty; end if; - - Next (H); - end loop; + end if; end if; - end; - end if; + + Next (C); + end loop; + + Next_Non_Pragma (H); + end loop; end if; N := P; diff --git a/gcc/ada/exp_ch11.ads b/gcc/ada/exp_ch11.ads index 483c759..8d5b998 100644 --- a/gcc/ada/exp_ch11.ads +++ b/gcc/ada/exp_ch11.ads @@ -59,7 +59,7 @@ package Exp_Ch11 is (Ename : Entity_Id; Nod : Node_Id) return Node_Id; -- This function searches for a local exception handler that will handle - -- the exception named by Ename. If such a local hander exists, then the + -- the exception named by Ename. If such a local handler exists, then the -- corresponding N_Exception_Handler is returned. If no such handler is -- found then Empty is returned. In order to match and return True, the -- handler may not have a choice parameter specification. Nod is the raise diff --git a/gcc/ada/exp_ch2.adb b/gcc/ada/exp_ch2.adb index 06a276b..edcb91c 100644 --- a/gcc/ada/exp_ch2.adb +++ b/gcc/ada/exp_ch2.adb @@ -464,9 +464,9 @@ package body Exp_Ch2 is -- disable if either variable or its type have sync disabled. else - Set := (not Atomic_Synchronization_Disabled (E)) + Set := not Atomic_Synchronization_Disabled (E) and then - (not Atomic_Synchronization_Disabled (Etype (E))); + not Atomic_Synchronization_Disabled (Etype (E)); end if; -- Set flag if required diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index abe71b2..7ac4680 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -583,10 +583,6 @@ package body Exp_Ch3 is Ptr : Entity_Id; begin - if not Expander_Active then - return; - end if; - -- Create List of actuals for indirect call. The last parameter of the -- subprogram declaration is the access value for the indirect call. @@ -2082,8 +2078,8 @@ package body Exp_Ch3 is Typ : constant Entity_Id := Underlying_Type (Etype (Id)); Adj_Call : Node_Id; - Exp : Node_Id := Default; - Kind : Node_Kind := Nkind (Default); + Exp : Node_Id; + Exp_Q : Node_Id; Lhs : Node_Id; Res : List_Id; @@ -2094,13 +2090,14 @@ package body Exp_Ch3 is Selector_Name => New_Occurrence_Of (Id, Default_Loc)); Set_Assignment_OK (Lhs); - -- Take a copy of Exp to ensure that later copies of this component + -- Take copy of Default to ensure that later copies of this component -- declaration in derived types see the original tree, not a node -- rewritten during expansion of the init_proc. If the copy contains -- itypes, the scope of the new itypes is the init_proc being built. declare Map : Elist_Id := No_Elist; + begin if Has_Late_Init_Comp then -- Map the type to the _Init parameter in order to @@ -2131,7 +2128,7 @@ package body Exp_Ch3 is end if; end if; - Exp := New_Copy_Tree (Exp, New_Scope => Proc_Id, Map => Map); + Exp := New_Copy_Tree (Default, New_Scope => Proc_Id, Map => Map); end; Res := New_List ( @@ -2141,6 +2138,8 @@ package body Exp_Ch3 is Set_No_Ctrl_Actions (First (Res)); + Exp_Q := Unqualify (Exp); + -- Adjust the tag if tagged (because of possible view conversions). -- Suppress the tag adjustment when not Tagged_Type_Expansion because -- tags are represented implicitly in objects, and when the record is @@ -2148,37 +2147,20 @@ package body Exp_Ch3 is if Is_Tagged_Type (Typ) and then Tagged_Type_Expansion - and then Nkind (Exp) /= N_Raise_Expression - and then (Nkind (Exp) /= N_Qualified_Expression - or else Nkind (Expression (Exp)) /= N_Raise_Expression) + and then Nkind (Exp_Q) /= N_Raise_Expression then Append_To (Res, - Make_Assignment_Statement (Default_Loc, - Name => - Make_Selected_Component (Default_Loc, - Prefix => - New_Copy_Tree (Lhs, New_Scope => Proc_Id), - Selector_Name => - New_Occurrence_Of - (First_Tag_Component (Typ), Default_Loc)), - - Expression => - Unchecked_Convert_To (RTE (RE_Tag), - New_Occurrence_Of - (Node (First_Elmt (Access_Disp_Table (Underlying_Type - (Typ)))), - Default_Loc)))); + Make_Tag_Assignment_From_Type + (Default_Loc, + New_Copy_Tree (Lhs, New_Scope => Proc_Id), + Underlying_Type (Typ))); end if; -- Adjust the component if controlled except if it is an aggregate -- that will be expanded inline. - if Kind = N_Qualified_Expression then - Kind := Nkind (Expression (Default)); - end if; - if Needs_Finalization (Typ) - and then Kind not in N_Aggregate | N_Extension_Aggregate + and then Nkind (Exp_Q) not in N_Aggregate | N_Extension_Aggregate and then not Is_Build_In_Place_Function_Call (Exp) then Adj_Call := @@ -2194,16 +2176,6 @@ package body Exp_Ch3 is end if; end if; - -- If a component type has a predicate, add check to the component - -- assignment. Discriminants are handled at the point of the call, - -- which provides for a better error message. - - if Comes_From_Source (Exp) - and then Predicate_Enabled (Typ) - then - Append (Make_Predicate_Check (Typ, Exp), Res); - end if; - return Res; exception @@ -2808,17 +2780,8 @@ package body Exp_Ch3 is -- Initialize the primary tag component Init_Tags_List := New_List ( - Make_Assignment_Statement (Loc, - Name => - Make_Selected_Component (Loc, - Prefix => Make_Identifier (Loc, Name_uInit), - Selector_Name => - New_Occurrence_Of - (First_Tag_Component (Rec_Type), Loc)), - Expression => - New_Occurrence_Of - (Node - (First_Elmt (Access_Disp_Table (Rec_Type))), Loc))); + Make_Tag_Assignment_From_Type + (Loc, Make_Identifier (Loc, Name_uInit), Rec_Type)); -- Ada 2005 (AI-251): Initialize the secondary tags components -- located at fixed positions (tags whose position depends on @@ -2897,17 +2860,8 @@ package body Exp_Ch3 is -- Initialize the primary tag Init_Tags_List := New_List ( - Make_Assignment_Statement (Loc, - Name => - Make_Selected_Component (Loc, - Prefix => Make_Identifier (Loc, Name_uInit), - Selector_Name => - New_Occurrence_Of - (First_Tag_Component (Rec_Type), Loc)), - Expression => - New_Occurrence_Of - (Node - (First_Elmt (Access_Disp_Table (Rec_Type))), Loc))); + Make_Tag_Assignment_From_Type + (Loc, Make_Identifier (Loc, Name_uInit), Rec_Type)); -- Ada 2005 (AI-251): Initialize the secondary tags components -- located at fixed positions (tags whose position depends on @@ -2946,8 +2900,8 @@ package body Exp_Ch3 is while Present (Next (Ins_Nod)) and then (Nkind (Ins_Nod) /= N_If_Statement - or else (Nkind (First (Then_Statements (Ins_Nod))) - /= N_Procedure_Call_Statement) + or else Nkind (First (Then_Statements (Ins_Nod))) + /= N_Procedure_Call_Statement or else not Is_Init_Proc (Name (First (Then_Statements (Ins_Nod))))) @@ -6910,6 +6864,12 @@ package body Exp_Ch3 is and then not Has_Predicates (Component_Type (Typ)) + -- Array default component value takes precedence over + -- Init_Or_Norm_Scalars. + + and then No (Find_Aspect (Typ, + Aspect_Default_Component_Value)) + -- The component type must have a single initialization value and then Simple_Initialization_OK (Component_Type (Typ)) @@ -7154,8 +7114,64 @@ package body Exp_Ch3 is function Make_Allocator_For_Return (Expr : Node_Id) return Node_Id is Alloc : Node_Id; Alloc_Expr : Entity_Id; + Alloc_Typ : Entity_Id; begin + -- If the return object's declaration does not include an expression, + -- then we use its subtype for the allocation. Likewise in the case + -- of a degenerate expression like a raise expression. + + if No (Expr) + or else Nkind (Original_Node (Expr)) = N_Raise_Expression + then + Alloc_Typ := Typ; + + -- If the return object's declaration includes an expression, then + -- there are two cases: either the nominal subtype of the object is + -- definite and we can use it for the allocation directly, or it is + -- not and Analyze_Object_Declaration should have built an actual + -- subtype from the expression. + + -- However, there are exceptions in the latter case for interfaces + -- (see Analyze_Object_Declaration), as well as class-wide types and + -- types with unknown discriminants if they are additionally limited + -- (see Expand_Subtype_From_Expr), so we must cope with them. + + elsif Is_Interface (Typ) then + pragma Assert (Is_Class_Wide_Type (Typ)); + + -- For interfaces, we use the type of the expression, except if + -- we need to put back a conversion that we have removed earlier + -- in the processing. + + if Is_Class_Wide_Type (Etype (Expr)) then + Alloc_Typ := Typ; + else + Alloc_Typ := Etype (Expr); + end if; + + elsif Is_Class_Wide_Type (Typ) then + + -- For class-wide types, we have to make sure that we use the + -- dynamic type of the expression for the allocation, either by + -- means of its (static) subtype or through the actual subtype. + + if Has_Tag_Of_Type (Expr) then + Alloc_Typ := Etype (Expr); + + else pragma Assert (Ekind (Typ) = E_Class_Wide_Subtype + and then Present (Equivalent_Type (Typ))); + + Alloc_Typ := Typ; + end if; + + else pragma Assert (Is_Definite_Subtype (Typ) + or else (Has_Unknown_Discriminants (Typ) + and then Is_Limited_View (Typ))); + + Alloc_Typ := Typ; + end if; + -- If the return object's declaration includes an expression and the -- declaration isn't marked as No_Initialization, then we generate an -- allocator with a qualified expression. Although this is necessary @@ -7181,35 +7197,22 @@ package body Exp_Ch3 is Alloc_Expr := New_Copy_Tree (Expr); - -- In the constrained array case, deal with a potential sliding. - -- In the interface case, put back a conversion that we may have - -- removed earlier in the processing. - - if (Ekind (Typ) = E_Array_Subtype - or else (Is_Interface (Typ) - and then Is_Class_Wide_Type (Etype (Alloc_Expr)))) - and then Typ /= Etype (Alloc_Expr) - then - Alloc_Expr := Convert_To (Typ, Alloc_Expr); + if Etype (Alloc_Expr) /= Alloc_Typ then + Alloc_Expr := Convert_To (Alloc_Typ, Alloc_Expr); end if; - -- We always use the type of the expression for the qualified - -- expression, rather than the return object's type. We cannot - -- always use the return object's type because the expression - -- might be of a specific type and the return object mignt not. - Alloc := Make_Allocator (Loc, Expression => Make_Qualified_Expression (Loc, Subtype_Mark => - New_Occurrence_Of (Etype (Alloc_Expr), Loc), + New_Occurrence_Of (Alloc_Typ, Loc), Expression => Alloc_Expr)); else Alloc := Make_Allocator (Loc, - Expression => New_Occurrence_Of (Typ, Loc)); + Expression => New_Occurrence_Of (Alloc_Typ, Loc)); -- If the return object requires default initialization, then it -- will happen later following the elaboration of the renaming. @@ -7338,7 +7341,7 @@ package body Exp_Ch3 is and then (Restriction_Active (No_Implicit_Heap_Allocations) or else Restriction_Active (No_Implicit_Task_Allocations)) and then not (Ekind (Typ) in E_Array_Type | E_Array_Subtype - and then (Has_Init_Expression (N))) + and then Has_Init_Expression (N)) then declare PS_Count, SS_Count : Int := 0; @@ -9251,9 +9254,13 @@ package body Exp_Ch3 is -- this is indeed the case, associate the Finalize_Address routine -- of the full view with the finalization masters of all pending -- access types. This scenario applies to anonymous access types as - -- well. + -- well. But the Finalize_Address routine is missing if the type is + -- class-wide and we are under restriction No_Dispatching_Calls, see + -- Expand_Freeze_Class_Wide_Type above for the rationale. elsif Needs_Finalization (Typ) + and then (not Is_Class_Wide_Type (Typ) + or else not Restriction_Active (No_Dispatching_Calls)) and then Present (Pending_Access_Types (Typ)) then E := First_Elmt (Pending_Access_Types (Typ)); @@ -11105,9 +11112,10 @@ package body Exp_Ch3 is Null_Record_Present => True); -- GNATprove will use expression of an expression function as an - -- implicit postcondition. GNAT will not benefit from expression - -- function (and would struggle if we add an expression function - -- to freezing actions). + -- implicit postcondition. GNAT will also benefit from expression + -- function to avoid premature freezing, but would struggle if we + -- added an expression function to freezing actions, so we create + -- the expanded form directly. if GNATprove_Mode then Func_Body := @@ -11126,6 +11134,7 @@ package body Exp_Ch3 is Statements => New_List ( Make_Simple_Return_Statement (Loc, Expression => Ext_Aggr)))); + Set_Was_Expression_Function (Func_Body); end if; Append_To (Body_List, Func_Body); @@ -11145,8 +11154,6 @@ package body Exp_Ch3 is -- is a wrapper's body in order to get check suppression right. Set_Corresponding_Spec (Func_Body, Func_Id); - - Override_Dispatching_Operation (Tag_Typ, Subp, New_Op => Func_Id); end if; <<Next_Prim>> @@ -11898,8 +11905,8 @@ package body Exp_Ch3 is -- Spec of Put_Image - if (not No_Run_Time_Mode) - and then RTE_Available (RE_Root_Buffer_Type) + if not No_Run_Time_Mode + and then RTE_Available (RE_Root_Buffer_Type) then -- No_Run_Time_Mode implies that the declaration of Tag_Typ -- (like any tagged type) will be rejected. Given this, avoid @@ -12085,13 +12092,11 @@ package body Exp_Ch3 is function Make_Tag_Assignment (N : Node_Id) return Node_Id is Loc : constant Source_Ptr := Sloc (N); - Def_If : constant Entity_Id := Defining_Identifier (N); + Def_Id : constant Entity_Id := Defining_Identifier (N); Expr : constant Node_Id := Expression (N); - Typ : constant Entity_Id := Etype (Def_If); + Typ : constant Entity_Id := Etype (Def_Id); Full_Typ : constant Entity_Id := Underlying_Type (Typ); - New_Ref : Node_Id; - begin -- This expansion activity is called during analysis @@ -12099,25 +12104,12 @@ package body Exp_Ch3 is and then not Is_Class_Wide_Type (Typ) and then not Is_CPP_Class (Typ) and then Tagged_Type_Expansion - and then Nkind (Expr) /= N_Aggregate - and then (Nkind (Expr) /= N_Qualified_Expression - or else Nkind (Expression (Expr)) /= N_Aggregate) + and then Nkind (Unqualify (Expr)) /= N_Aggregate then - New_Ref := - Make_Selected_Component (Loc, - Prefix => New_Occurrence_Of (Def_If, Loc), - Selector_Name => - New_Occurrence_Of (First_Tag_Component (Full_Typ), Loc)); - - Set_Assignment_OK (New_Ref); - return - Make_Assignment_Statement (Loc, - Name => New_Ref, - Expression => - Unchecked_Convert_To (RTE (RE_Tag), - New_Occurrence_Of - (Node (First_Elmt (Access_Disp_Table (Full_Typ))), Loc))); + Make_Tag_Assignment_From_Type + (Loc, New_Occurrence_Of (Def_Id, Loc), Full_Typ); + else return Empty; end if; @@ -12413,7 +12405,7 @@ package body Exp_Ch3 is -- Body of Put_Image if No (TSS (Tag_Typ, TSS_Put_Image)) - and then (not No_Run_Time_Mode) + and then not No_Run_Time_Mode and then RTE_Available (RE_Root_Buffer_Type) then Build_Record_Put_Image_Procedure (Loc, Tag_Typ, Decl, Ent); @@ -12429,14 +12421,14 @@ package body Exp_Ch3 is if Stream_Operation_OK (Tag_Typ, TSS_Stream_Read) and then No (TSS (Tag_Typ, TSS_Stream_Read)) then - Build_Record_Read_Procedure (Loc, Tag_Typ, Decl, Ent); + Build_Record_Read_Procedure (Tag_Typ, Decl, Ent); Append_To (Res, Decl); end if; if Stream_Operation_OK (Tag_Typ, TSS_Stream_Write) and then No (TSS (Tag_Typ, TSS_Stream_Write)) then - Build_Record_Write_Procedure (Loc, Tag_Typ, Decl, Ent); + Build_Record_Write_Procedure (Tag_Typ, Decl, Ent); Append_To (Res, Decl); end if; @@ -12448,14 +12440,14 @@ package body Exp_Ch3 is and then No (TSS (Tag_Typ, TSS_Stream_Input)) then Build_Record_Or_Elementary_Input_Function - (Loc, Tag_Typ, Decl, Ent); + (Tag_Typ, Decl, Ent); Append_To (Res, Decl); end if; if Stream_Operation_OK (Tag_Typ, TSS_Stream_Output) and then No (TSS (Tag_Typ, TSS_Stream_Output)) then - Build_Record_Or_Elementary_Output_Procedure (Loc, Tag_Typ, Decl, Ent); + Build_Record_Or_Elementary_Output_Procedure (Tag_Typ, Decl, Ent); Append_To (Res, Decl); end if; diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 31823ea..7b6e997 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -567,7 +567,6 @@ package body Exp_Ch4 is Adj_Call : Node_Id; Aggr_In_Place : Boolean; Node : Node_Id; - Tag_Assign : Node_Id; Temp : Entity_Id; Temp_Decl : Node_Id; @@ -923,30 +922,9 @@ package body Exp_Ch4 is end if; if Present (TagT) then - declare - Full_T : constant Entity_Id := Underlying_Type (TagT); - - begin - Tag_Assign := - Make_Assignment_Statement (Loc, - Name => - Make_Selected_Component (Loc, - Prefix => TagR, - Selector_Name => - New_Occurrence_Of - (First_Tag_Component (Full_T), Loc)), - - Expression => - Unchecked_Convert_To (RTE (RE_Tag), - New_Occurrence_Of - (Elists.Node - (First_Elmt (Access_Disp_Table (Full_T))), Loc))); - end; - - -- The previous assignment has to be done in any case - - Set_Assignment_OK (Name (Tag_Assign)); - Insert_Action (N, Tag_Assign); + Insert_Action (N, + Make_Tag_Assignment_From_Type + (Loc, TagR, Underlying_Type (TagT))); end if; -- Generate an Adjust call if the object will be moved. In Ada 2005, @@ -2536,7 +2514,7 @@ package body Exp_Ch4 is -- Reset to False if at least one operand is encountered which is known -- at compile time to be non-null. Used for handling the special case -- of setting the high bound to the last operand high bound for a null - -- result, thus ensuring a proper high bound in the super-flat case. + -- result, thus ensuring a proper high bound in the superflat case. N : constant Nat := List_Length (Opnds); -- Number of concatenation operands including possibly null operands @@ -2726,8 +2704,9 @@ package body Exp_Ch4 is -- Local Declarations Opnd_Typ : Entity_Id; - Slice_Rng : Entity_Id; - Subtyp_Ind : Entity_Id; + Slice_Rng : Node_Id; + Subtyp_Ind : Node_Id; + Subtyp_Rng : Node_Id; Ent : Entity_Id; Len : Unat; J : Nat; @@ -3184,7 +3163,7 @@ package body Exp_Ch4 is -- Handle the exceptional case where the result is null, in which case -- case the bounds come from the last operand (so that we get the proper - -- bounds if the last operand is super-flat). + -- bounds if the last operand is superflat). if Result_May_Be_Null then Low_Bound := @@ -3239,6 +3218,12 @@ package body Exp_Ch4 is Slice_Rng := Empty; end if; + Subtyp_Rng := Make_Range (Loc, Low_Bound, High_Bound); + + -- If the result cannot be null then the range cannot be superflat + + Set_Cannot_Be_Superflat (Subtyp_Rng, not Result_May_Be_Null); + -- Now we construct an array object with appropriate bounds. We mark -- the target as internal to prevent useless initialization when -- Initialize_Scalars is enabled. Also since this is the actual result @@ -3249,10 +3234,7 @@ package body Exp_Ch4 is Subtype_Mark => New_Occurrence_Of (Atyp, Loc), Constraint => Make_Index_Or_Discriminant_Constraint (Loc, - Constraints => New_List ( - Make_Range (Loc, - Low_Bound => Low_Bound, - High_Bound => High_Bound)))); + Constraints => New_List (Subtyp_Rng))); Ent := Make_Temporary (Loc, 'S'); Set_Is_Internal (Ent); @@ -3494,7 +3476,7 @@ package body Exp_Ch4 is -- Array case, slice assignment, skipped when argument is fixed -- length and known to be null. - elsif (not Is_Fixed_Length (J)) or else (Fixed_Length (J) > 0) then + elsif not Is_Fixed_Length (J) or else Fixed_Length (J) > 0 then declare Assign : Node_Id := Make_Assignment_Statement (Loc, @@ -4987,6 +4969,25 @@ package body Exp_Ch4 is Expand_N_Full_Type_Declaration (Parent (Base_Type (PtrT))); + -- When the allocator has a subtype indication then a + -- constraint is present and an itype has been added by + -- Analyze_Allocator as the subtype of this allocator. + + -- If an allocator with constraints is called in the + -- return statement of a function returning a general + -- access type, then propagate to the itype the master + -- of the general access type (since it is the master + -- associated with the returned object). + + elsif Is_Itype (PtrT) + and then Ekind (Current_Scope) = E_Function + and then Ekind (Etype (Current_Scope)) + = E_General_Access_Type + and then In_Return_Value (N) + then + Set_Master_Id (PtrT, + Master_Id (Etype (Current_Scope))); + -- The only other possibility is an itype. For this -- case, the master must exist in the context. This is -- the case when the allocator initializes an access @@ -5062,13 +5063,12 @@ package body Exp_Ch4 is -- Add discriminants if discriminated type declare - Dis : Boolean := False; - Typ : Entity_Id := Empty; + Dis : Boolean := False; + Typ : Entity_Id := T; begin if Has_Discriminants (T) then Dis := True; - Typ := T; -- Type may be a private type with no visible discriminants -- in which case check full view if in scope, or the @@ -5111,30 +5111,6 @@ package body Exp_Ch4 is Set_Expression (N, New_Occurrence_Of (Typ, Loc)); end if; - -- When the designated subtype is unconstrained and - -- the allocator specifies a constrained subtype (or - -- such a subtype has been created, such as above by - -- Build_Default_Subtype), associate that subtype with - -- the dereference of the allocator's access value. - -- This is needed by the back end for cases where - -- the access type has a Designated_Storage_Model, - -- to support allocation of a host object of the right - -- size for passing to the initialization procedure. - - if not Is_Constrained (Dtyp) - and then Is_Constrained (Typ) - then - declare - Init_Deref : constant Node_Id := - Unqual_Conv (Init_Arg1); - begin - pragma Assert - (Nkind (Init_Deref) = N_Explicit_Dereference); - - Set_Actual_Designated_Subtype (Init_Deref, Typ); - end; - end if; - Discr := First_Elmt (Discriminant_Constraint (Typ)); while Present (Discr) loop Nod := Node (Discr); @@ -5157,6 +5133,29 @@ package body Exp_Ch4 is Next_Elmt (Discr); end loop; end if; + + -- When the designated subtype is unconstrained and + -- the allocator specifies a constrained subtype (or + -- such a subtype has been created, such as above by + -- Build_Default_Subtype), associate that subtype with + -- the dereference of the allocator's access value. + -- This is needed by the expander for cases where the + -- access type has a Designated_Storage_Model in order + -- to support allocation of a host object of the right + -- size for passing to the initialization procedure. + + if not Is_Constrained (Dtyp) + and then Is_Constrained (Typ) + then + declare + Deref : constant Node_Id := Unqual_Conv (Init_Arg1); + + begin + pragma Assert (Nkind (Deref) = N_Explicit_Dereference); + + Set_Actual_Designated_Subtype (Deref, Typ); + end; + end if; end; -- We set the allocator as analyzed so that when we analyze @@ -5380,17 +5379,6 @@ package body Exp_Ch4 is -- when minimizing expressions with actions (e.g. when generating C -- code) since it allows us to do the optimization below in more cases. - -- Small optimization: when the case expression appears in the context - -- of a simple return statement, expand into - - -- case X is - -- when A => - -- return AX; - -- when B => - -- return BX; - -- ... - -- end case; - Case_Stmt := Make_Case_Statement (Loc, Expression => Expression (N), @@ -5404,17 +5392,29 @@ package body Exp_Ch4 is Set_From_Conditional_Expression (Case_Stmt); Acts := New_List; + -- Small optimization: when the case expression appears in the context + -- of a simple return statement, expand into + + -- case X is + -- when A => + -- return AX; + -- when B => + -- return BX; + -- ... + -- end case; + + -- This makes the expansion much easier when expressions are calls to + -- a BIP function. But do not perform it when the return statement is + -- within a predicate function, as this causes spurious errors. + + Optimize_Return_Stmt := + Nkind (Par) = N_Simple_Return_Statement and then not In_Predicate; + -- Scalar/Copy case if Is_Copy_Type (Typ) then Target_Typ := Typ; - -- Do not perform the optimization when the return statement is - -- within a predicate function, as this causes spurious errors. - - Optimize_Return_Stmt := - Nkind (Par) = N_Simple_Return_Statement and then not In_Predicate; - -- Otherwise create an access type to handle the general case using -- 'Unrestricted_Access. @@ -5478,16 +5478,6 @@ package body Exp_Ch4 is -- limited and unconstrained cases. -- Generate: - -- AX'Unrestricted_Access - - if not Is_Copy_Type (Typ) then - Alt_Expr := - Make_Attribute_Reference (Alt_Loc, - Prefix => Relocate_Node (Alt_Expr), - Attribute_Name => Name_Unrestricted_Access); - end if; - - -- Generate: -- return AX['Unrestricted_Access]; if Optimize_Return_Stmt then @@ -5499,6 +5489,13 @@ package body Exp_Ch4 is -- Target := AX['Unrestricted_Access]; else + if not Is_Copy_Type (Typ) then + Alt_Expr := + Make_Attribute_Reference (Alt_Loc, + Prefix => Relocate_Node (Alt_Expr), + Attribute_Name => Name_Unrestricted_Access); + end if; + LHS := New_Occurrence_Of (Target, Loc); Set_Assignment_OK (LHS); @@ -5651,14 +5648,17 @@ package body Exp_Ch4 is return Skip; -- Avoid processing temporary function results multiple times when - -- dealing with nested expression_with_actions. + -- dealing with nested expression_with_actions or nested blocks. -- Similarly, do not process temporary function results in loops. -- This is done by Expand_N_Loop_Statement and Build_Finalizer. -- Note that we used to wrongly return Abandon instead of Skip here: -- this is wrong since it means that we were ignoring lots of -- relevant subsequent statements. - elsif Nkind (Act) in N_Expression_With_Actions | N_Loop_Statement then + elsif Nkind (Act) in N_Expression_With_Actions + | N_Block_Statement + | N_Loop_Statement + then return Skip; end if; @@ -5723,6 +5723,11 @@ package body Exp_Ch4 is -- the usual forced evaluation to encapsulate potential aliasing. else + -- A check is also needed since the subtype of the EWA node and the + -- subtype of the expression may differ (for example, the EWA node + -- may have a null-excluding access subtype). + + Apply_Constraint_Check (Expression (N), Etype (N)); Force_Evaluation (Expression (N)); end if; @@ -5760,6 +5765,7 @@ package body Exp_Ch4 is Loc : constant Source_Ptr := Sloc (N); Thenx : constant Node_Id := Next (Cond); Elsex : constant Node_Id := Next (Thenx); + Par : constant Node_Id := Parent (N); Typ : constant Entity_Id := Etype (N); Force_Expand : constant Boolean := Is_Anonymous_Access_Actual (N); @@ -5792,6 +5798,10 @@ package body Exp_Ch4 is UI_Max (Hi1, Hi2) - UI_Min (Lo1, Lo2) < Too_Large_Length_For_Array; end OK_For_Single_Subtype; + Optimize_Return_Stmt : Boolean := False; + -- Flag set when the if expression can be optimized in the context of + -- a simple return statement. + -- Local variables Actions : List_Id; @@ -5883,6 +5893,50 @@ package body Exp_Ch4 is end; end if; + -- Small optimization: when the if expression appears in the context of + -- a simple return statement, expand into + + -- if cond then + -- return then-expr + -- else + -- return else-expr; + -- end if; + + -- This makes the expansion much easier when expressions are calls to + -- a BIP function. But do not perform it when the return statement is + -- within a predicate function, as this causes spurious errors. + + Optimize_Return_Stmt := + Nkind (Par) = N_Simple_Return_Statement + and then not (Ekind (Current_Scope) in E_Function | E_Procedure + and then Is_Predicate_Function (Current_Scope)); + + if Optimize_Return_Stmt then + -- When the "then" or "else" expressions involve controlled function + -- calls, generated temporaries are chained on the corresponding list + -- of actions. These temporaries need to be finalized after the if + -- expression is evaluated. + + Process_If_Case_Statements (N, Then_Actions (N)); + Process_If_Case_Statements (N, Else_Actions (N)); + + New_If := + Make_Implicit_If_Statement (N, + Condition => Relocate_Node (Cond), + Then_Statements => New_List ( + Make_Simple_Return_Statement (Sloc (Thenx), + Expression => Relocate_Node (Thenx))), + Else_Statements => New_List ( + Make_Simple_Return_Statement (Sloc (Elsex), + Expression => Relocate_Node (Elsex)))); + + -- Preserve the original context for which the if statement is + -- being generated. This is needed by the finalization machinery + -- to prevent the premature finalization of controlled objects + -- found within the if statement. + + Set_From_Conditional_Expression (New_If); + -- If the type is limited, and the back end does not handle limited -- types, then we expand as follows to avoid the possibility of -- improper copying. @@ -5902,7 +5956,7 @@ package body Exp_Ch4 is -- This special case can be skipped if the back end handles limited -- types properly and ensures that no incorrect copies are made. - if Is_By_Reference_Type (Typ) + elsif Is_By_Reference_Type (Typ) and then not Back_End_Handles_Limited_Types then -- When the "then" or "else" expressions involve controlled function @@ -6224,9 +6278,10 @@ package body Exp_Ch4 is -- Note that the test for being in an object declaration avoids doing an -- unnecessary expansion, and also avoids infinite recursion. - elsif Is_Array_Type (Typ) and then not Is_Constrained (Typ) - and then (Nkind (Parent (N)) /= N_Object_Declaration - or else Expression (Parent (N)) /= N) + elsif Is_Array_Type (Typ) + and then not Is_Constrained (Typ) + and then not (Nkind (Par) = N_Object_Declaration + and then Expression (Par) = N) then declare Cnn : constant Node_Id := Make_Temporary (Loc, 'C', N); @@ -6389,14 +6444,14 @@ package body Exp_Ch4 is -- in order to make sure that no branch is shared between the decisions. elsif Opt.Suppress_Control_Flow_Optimizations - and then Nkind (Original_Node (Parent (N))) in N_Case_Expression - | N_Case_Statement - | N_If_Expression - | N_If_Statement - | N_Goto_When_Statement - | N_Loop_Statement - | N_Return_When_Statement - | N_Short_Circuit + and then Nkind (Original_Node (Par)) in N_Case_Expression + | N_Case_Statement + | N_If_Expression + | N_If_Statement + | N_Goto_When_Statement + | N_Loop_Statement + | N_Return_When_Statement + | N_Short_Circuit then declare Cnn : constant Entity_Id := Make_Temporary (Loc, 'C'); @@ -6437,20 +6492,35 @@ package body Exp_Ch4 is -- change it to the SLOC of the expression which, after expansion, will -- correspond to what is being evaluated. - if Present (Parent (N)) and then Nkind (Parent (N)) = N_If_Statement then - Set_Sloc (New_If, Sloc (Parent (N))); - Set_Sloc (Parent (N), Loc); + if Present (Par) and then Nkind (Par) = N_If_Statement then + Set_Sloc (New_If, Sloc (Par)); + Set_Sloc (Par, Loc); end if; -- Move Then_Actions and Else_Actions, if any, to the new if statement - Insert_List_Before (First (Then_Statements (New_If)), Then_Actions (N)); - Insert_List_Before (First (Else_Statements (New_If)), Else_Actions (N)); + if Present (Then_Actions (N)) then + Prepend_List (Then_Actions (N), Then_Statements (New_If)); + end if; - Insert_Action (N, Decl); - Insert_Action (N, New_If); - Rewrite (N, New_N); - Analyze_And_Resolve (N, Typ); + if Present (Else_Actions (N)) then + Prepend_List (Else_Actions (N), Else_Statements (New_If)); + end if; + + -- Rewrite the parent return statement as an if statement + + if Optimize_Return_Stmt then + Rewrite (Par, New_If); + Analyze (Par); + + -- Otherwise rewrite the if expression itself + + else + Insert_Action (N, Decl); + Insert_Action (N, New_If); + Rewrite (N, New_N); + Analyze_And_Resolve (N, Typ); + end if; end Expand_N_If_Expression; ----------------- @@ -6482,34 +6552,16 @@ package body Exp_Ch4 is ---------------------------- function Is_OK_Object_Reference (Nod : Node_Id) return Boolean is - Obj_Ref : Node_Id; + Obj_Ref : constant Node_Id := Original_Node (Nod); + -- The original operand begin - -- Inspect the original operand - - Obj_Ref := Original_Node (Nod); - -- The object reference must be a source construct, otherwise the -- codefix suggestion may refer to nonexistent code from a user -- perspective. - if Comes_From_Source (Obj_Ref) then - loop - if Nkind (Obj_Ref) in - N_Type_Conversion | - N_Unchecked_Type_Conversion | - N_Qualified_Expression - then - Obj_Ref := Expression (Obj_Ref); - else - exit; - end if; - end loop; - - return Is_Object_Reference (Obj_Ref); - end if; - - return False; + return Comes_From_Source (Obj_Ref) + and then Is_Object_Reference (Unqual_Conv (Obj_Ref)); end Is_OK_Object_Reference; -- Start of processing for Substitute_Valid_Test @@ -6898,11 +6950,13 @@ package body Exp_Ch4 is -- If the null exclusion checks are not compatible, need to -- perform further checks. In other words, we cannot have - -- Ltyp including null and Typ excluding null. All other cases - -- are OK. + -- Ltyp including null or Lop being null, and Typ excluding + -- null. All other cases are OK. Check_Null_Exclusion := - Can_Never_Be_Null (Typ) and then not Can_Never_Be_Null (Ltyp); + Can_Never_Be_Null (Typ) + and then (not Can_Never_Be_Null (Ltyp) + or else Nkind (Lop) = N_Null); Typ := Designated_Type (Typ); end if; @@ -8415,8 +8469,8 @@ package body Exp_Ch4 is return Nkind (Sindic) in N_Expanded_Name | N_Identifier and then Is_Unchecked_Union (Base_Type (Etype (Sindic))) - and then (Ekind (Entity (Sindic)) in - E_Private_Type | E_Record_Type); + and then Ekind (Entity (Sindic)) in + E_Private_Type | E_Record_Type; end Unconstrained_UU_In_Component_Declaration; ----------------------------------------- @@ -9048,7 +9102,7 @@ package body Exp_Ch4 is end if; end if; - -- Deal with optimizing 2 ** expression to shift where possible + -- Optimize 2 ** expression to shift where possible -- Note: we used to check that Exptyp was an unsigned type. But that is -- an unnecessary check, since if Exp is negative, we have a run-time @@ -9063,14 +9117,8 @@ package body Exp_Ch4 is and then CRT_Safe_Compile_Time_Known_Value (Base) and then Expr_Value (Base) = Uint_2 - -- We only handle cases where the right type is a integer - - and then Is_Integer_Type (Root_Type (Exptyp)) - and then Esize (Root_Type (Exptyp)) <= Standard_Integer_Size - -- This transformation is not applicable for a modular type with a - -- nonbinary modulus because we do not handle modular reduction in - -- a correct manner if we attempt this transformation in this case. + -- nonbinary modulus because shifting makes no sense in that case. and then not Non_Binary_Modulus (Typ) then @@ -9107,61 +9155,26 @@ package body Exp_Ch4 is end if; end; - -- Here we just have 2 ** N on its own, so we can convert this to a - -- shift node. We are prepared to deal with overflow here, and we - -- also have to handle proper modular reduction for binary modular. + -- Here we have 2 ** N on its own, so we can convert this into a + -- shift. else - declare - OK : Boolean; - Lo : Uint; - Hi : Uint; - - MaxS : Uint; - -- Maximum shift count with no overflow - - TestS : Boolean; - -- Set True if we must test the shift count - - Test_Gt : Node_Id; - -- Node for test against TestS - - begin - -- Compute maximum shift based on the underlying size. For a - -- modular type this is one less than the size. - - if Is_Modular_Integer_Type (Typ) then + -- Op_Shift_Left (generated below) has modular-shift semantics; + -- therefore we might need to generate an overflow check here + -- if the type is signed. - -- For modular integer types, this is the size of the value - -- being shifted minus one. Any larger values will cause - -- modular reduction to a result of zero. Note that we do - -- want the RM_Size here (e.g. mod 2 ** 7, we want a result - -- of 6, since 2**7 should be reduced to zero). - - MaxS := RM_Size (Rtyp) - 1; - - -- For signed integer types, we use the size of the value - -- being shifted minus 2. Larger values cause overflow. - - else - MaxS := Esize (Rtyp) - 2; - end if; - - -- Determine range to see if it can be larger than MaxS - - Determine_Range (Exp, OK, Lo, Hi, Assume_Valid => True); - TestS := (not OK) or else Hi > MaxS; - - -- Signed integer case - - if Is_Signed_Integer_Type (Typ) then + if Is_Signed_Integer_Type (Typ) and then Ovflo then + declare + OK : Boolean; + Lo : Uint; + Hi : Uint; - -- Generate overflow check if overflow is active. Note that - -- we can simply ignore the possibility of overflow if the - -- flag is not set (means that overflow cannot happen or - -- that overflow checks are suppressed). + MaxS : constant Uint := Esize (Rtyp) - 2; + -- Maximum shift count with no overflow + begin + Determine_Range (Exp, OK, Lo, Hi, Assume_Valid => True); - if Ovflo and TestS then + if not OK or else Hi > MaxS then Insert_Action (N, Make_Raise_Constraint_Error (Loc, Condition => @@ -9170,56 +9183,18 @@ package body Exp_Ch4 is Right_Opnd => Make_Integer_Literal (Loc, MaxS)), Reason => CE_Overflow_Check_Failed)); end if; + end; + end if; - -- Now rewrite node as Shift_Left (1, right-operand) - - Rewrite (N, - Make_Op_Shift_Left (Loc, - Left_Opnd => Make_Integer_Literal (Loc, Uint_1), - Right_Opnd => Exp)); - - -- Modular integer case - - else pragma Assert (Is_Modular_Integer_Type (Typ)); - - -- If shift count can be greater than MaxS, we need to wrap - -- the shift in a test that will reduce the result value to - -- zero if this shift count is exceeded. - - if TestS then - - -- Note: build node for the comparison first, before we - -- reuse the Right_Opnd, so that we have proper parents - -- in place for the Duplicate_Subexpr call. - - Test_Gt := - Make_Op_Gt (Loc, - Left_Opnd => Duplicate_Subexpr (Exp), - Right_Opnd => Make_Integer_Literal (Loc, MaxS)); - - Rewrite (N, - Make_If_Expression (Loc, - Expressions => New_List ( - Test_Gt, - Make_Integer_Literal (Loc, Uint_0), - Make_Op_Shift_Left (Loc, - Left_Opnd => Make_Integer_Literal (Loc, Uint_1), - Right_Opnd => Exp)))); - - -- If we know shift count cannot be greater than MaxS, then - -- it is safe to just rewrite as a shift with no test. + -- Generate Shift_Left (1, Exp) - else - Rewrite (N, - Make_Op_Shift_Left (Loc, - Left_Opnd => Make_Integer_Literal (Loc, Uint_1), - Right_Opnd => Exp)); - end if; - end if; + Rewrite (N, + Make_Op_Shift_Left (Loc, + Left_Opnd => Make_Integer_Literal (Loc, Uint_1), + Right_Opnd => Exp)); - Analyze_And_Resolve (N, Typ); - return; - end; + Analyze_And_Resolve (N, Typ); + return; end if; end if; @@ -9634,6 +9609,13 @@ package body Exp_Ch4 is Typ : constant Entity_Id := Etype (N); DDC : constant Boolean := Do_Division_Check (N); + Is_Stoele_Mod : constant Boolean := + Is_RTE (Typ, RE_Address) + and then Nkind (Right_Opnd (N)) = N_Unchecked_Type_Conversion + and then + Is_RTE (Etype (Expression (Right_Opnd (N))), RE_Storage_Offset); + -- True if this is the special mod operator of System.Storage_Elements + Left : Node_Id; Right : Node_Id; @@ -9667,7 +9649,10 @@ package body Exp_Ch4 is end if; end if; - if Is_Integer_Type (Typ) then + -- For the special mod operator of System.Storage_Elements, the checks + -- are subsumed into the handling of the negative case below. + + if Is_Integer_Type (Typ) and then not Is_Stoele_Mod then Apply_Divide_Checks (N); -- All done if we don't have a MOD any more, which can happen as a @@ -9698,6 +9683,7 @@ package body Exp_Ch4 is and then ((Llo >= 0 and then Rlo >= 0) or else (Lhi <= 0 and then Rhi <= 0)) + and then not Is_Stoele_Mod then Rewrite (N, Make_Op_Rem (Sloc (N), @@ -9737,6 +9723,24 @@ package body Exp_Ch4 is return; end if; + -- The negative case makes no sense since it is a case of a mod where + -- the left argument is unsigned and the right argument is signed. In + -- accordance with the (spirit of the) permission of RM 13.7.1(16), + -- we raise CE, and also include the zero case here. Yes, the RM says + -- PE, but this really is so obviously more like a constraint error. + + if Is_Stoele_Mod and then (not ROK or else Rlo <= 0) then + Insert_Action (N, + Make_Raise_Constraint_Error (Loc, + Condition => + Make_Op_Le (Loc, + Left_Opnd => + Duplicate_Subexpr_No_Checks (Expression (Right)), + Right_Opnd => Make_Integer_Literal (Loc, 0)), + Reason => CE_Overflow_Check_Failed)); + return; + end if; + -- If we still have a mod operator and we are in Modify_Tree_For_C -- mode, and we have a signed integer type, then here is where we do -- the rewrite in terms of Rem. Note this rewrite bypasses the need @@ -9864,8 +9868,8 @@ package body Exp_Ch4 is Expr_Value (Type_Low_Bound (Base_Type (Underlying_Type (Etype (Left))))); - if ((not ROK) or else (Rlo <= (-1) and then (-1) <= Rhi)) - and then ((not LOK) or else (Llo = LLB)) + if (not ROK or else (Rlo <= (-1) and then (-1) <= Rhi)) + and then (not LOK or else Llo = LLB) and then not CodePeer_Mode then Rewrite (N, @@ -10193,14 +10197,6 @@ package body Exp_Ch4 is Left_Opnd => Left_Opnd (N), Right_Opnd => Right_Opnd (N))); - -- The level of parentheses is useless in GNATprove mode, and - -- bumping its level here leads to wrong columns being used in - -- check messages, hence skip it in this mode. - - if not GNATprove_Mode then - Set_Paren_Count (Right_Opnd (Neg), 1); - end if; - if Scope (Ne) /= Standard_Standard then Set_Entity (Right_Opnd (Neg), Corresponding_Equality (Ne)); end if; @@ -10621,10 +10617,10 @@ package body Exp_Ch4 is -- completely in this case. Determine_Range (Right, OK, Lo, Hi, Assume_Valid => True); - Lneg := (not OK) or else Lo < 0; + Lneg := not OK or else Lo < 0; Determine_Range (Left, OK, Lo, Hi, Assume_Valid => True); - Rneg := (not OK) or else Lo < 0; + Rneg := not OK or else Lo < 0; -- We won't mess with trying to find out if the left operand can really -- be the largest negative number (that's a pain in the case of private @@ -11120,6 +11116,32 @@ package body Exp_Ch4 is Freeze_Before (P, Etype (Var)); end; + -- For an expression of the form "for all/some X of F(...) => ...", + -- where F(...) is a function call that returns on the secondary stack, + -- we need to mark an enclosing scope as Uses_Sec_Stack. We must do + -- this before expansion, which can obscure the tree. Note that we + -- might be inside another quantified expression. Skip blocks and + -- loops that were generated by expansion. + + if Present (Iterator_Specification (N)) + and then Nkind (Name (Iterator_Specification (N))) = N_Function_Call + and then Needs_Secondary_Stack + (Etype (Name (Iterator_Specification (N)))) + then + declare + Source_Scope : Entity_Id := Current_Scope; + begin + while Ekind (Source_Scope) in E_Block | E_Loop + and then not Comes_From_Source (Source_Scope) + loop + Source_Scope := Scope (Source_Scope); + end loop; + + Set_Uses_Sec_Stack (Source_Scope); + Check_Restriction (No_Secondary_Stack, N); + end; + end if; + -- Create the declaration of the flag which tracks the status of the -- quantified expression. Generate: @@ -11268,8 +11290,8 @@ package body Exp_Ch4 is -- actually performed. else - if (not Is_Unchecked_Union - (Implementation_Base_Type (Etype (Prefix (N))))) + if not Is_Unchecked_Union + (Implementation_Base_Type (Etype (Prefix (N)))) and then not Is_Predefined_Unit (Get_Source_Unit (N)) then Error_Msg_N @@ -11514,9 +11536,9 @@ package body Exp_Ch4 is -- component or its type have sync disabled. elsif Is_Atomic (E) and then Is_Atomic (Etype (E)) then - Set := (not Atomic_Synchronization_Disabled (E)) + Set := not Atomic_Synchronization_Disabled (E) and then - (not Atomic_Synchronization_Disabled (Etype (E))); + not Atomic_Synchronization_Disabled (Etype (E)); else Set := False; @@ -12197,8 +12219,12 @@ package body Exp_Ch4 is Expr_Id : constant Entity_Id := Make_Temporary (Loc, 'T', Conv); Int_Typ : constant Entity_Id := Small_Integer_Type_For (RM_Size (Btyp), Uns => False); + Trunc : constant Boolean := Float_Truncate (Conv); begin + Conv := Convert_To (Int_Typ, Expression (Conv)); + Set_Float_Truncate (Conv, Trunc); + -- Generate a temporary with the integer value. Required in the -- CCG compiler to ensure that run-time checks reference this -- integer expression (instead of the resulting fixed-point @@ -12210,8 +12236,7 @@ package body Exp_Ch4 is Defining_Identifier => Expr_Id, Object_Definition => New_Occurrence_Of (Int_Typ, Loc), Constant_Present => True, - Expression => - Convert_To (Int_Typ, Expression (Conv)))); + Expression => Conv)); -- Create integer objects for range checking of result. @@ -12531,7 +12556,7 @@ package body Exp_Ch4 is -- Special case of converting from non-standard boolean type if Is_Boolean_Type (Operand_Type) - and then (Nonzero_Is_True (Operand_Type)) + and then Nonzero_Is_True (Operand_Type) then Adjust_Condition (Operand); Set_Etype (Operand, Standard_Boolean); @@ -13264,8 +13289,6 @@ package body Exp_Ch4 is procedure Expand_Set_Membership (N : Node_Id) is Lop : constant Node_Id := Left_Opnd (N); - Alt : Node_Id; - Res : Node_Id; function Make_Cond (Alt : Node_Id) return Node_Id; -- If the alternative is a subtype mark, create a simple membership @@ -13294,23 +13317,22 @@ package body Exp_Ch4 is return Cond; end Make_Cond; + -- Local variables + + Alt : Node_Id; + Res : Node_Id := Empty; + -- Start of processing for Expand_Set_Membership begin Remove_Side_Effects (Lop); - Alt := First (Alternatives (N)); - Res := Make_Cond (Alt); - Next (Alt); - -- We use left associativity as in the equivalent boolean case. This -- kind of canonicalization helps the optimizer of the code generator. + Alt := First (Alternatives (N)); while Present (Alt) loop - Res := - Make_Or_Else (Sloc (Alt), - Left_Opnd => Res, - Right_Opnd => Make_Cond (Alt)); + Evolve_Or_Else (Res, Make_Cond (Alt)); Next (Alt); end loop; @@ -15136,12 +15158,18 @@ package body Exp_Ch4 is -- <finalize Trans_Id> -- in Result end; - -- As a result, the finalization of any transient objects can safely - -- take place after the result capture. + -- As a result, the finalization of any transient objects can take place + -- just after the result is captured, except for the case of conditional + -- expressions in a simple return statement because the return statement + -- will be distributed into the conditional expressions (see the special + -- handling of simple return statements a few lines below). -- ??? could this be extended to elementary types? - if Is_Boolean_Type (Etype (Expr)) then + if Is_Boolean_Type (Etype (Expr)) + and then (Nkind (Expr) = N_Expression_With_Actions + or else Nkind (Parent (Expr)) /= N_Simple_Return_Statement) + then Fin_Context := Last (Stmts); -- Otherwise the immediate context may not be safe enough to carry diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 265e1a7..258459b 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -59,6 +59,7 @@ with Sem_Ch13; use Sem_Ch13; with Sem_Eval; use Sem_Eval; with Sem_Res; use Sem_Res; with Sem_Util; use Sem_Util; + use Sem_Util.Storage_Model_Support; with Snames; use Snames; with Stand; use Stand; with Stringt; use Stringt; @@ -180,14 +181,13 @@ package body Exp_Ch5 is procedure Expand_Iterator_Loop_Over_Container (N : Node_Id; - Isc : Node_Id; I_Spec : Node_Id; Container : Node_Id; Container_Typ : Entity_Id); -- Expand loop over containers that uses the form "for X of C" with an - -- optional subtype mark, or "for Y in C". Isc is the iteration scheme. - -- I_Spec is the iterator specification and Container is either the - -- Container (for OF) or the iterator (for IN). + -- optional subtype mark, or "for Y in C". I_Spec is the iterator + -- specification and Container is either the Container (for OF) or the + -- iterator (for IN). procedure Expand_Predicated_Loop (N : Node_Id); -- Expand for loop over predicated subtype @@ -808,7 +808,7 @@ package body Exp_Ch5 is -- if there is a change of representation since obviously two arrays -- with different representations cannot possibly overlap. - if (not Crep) and L_Slice and R_Slice then + if not Crep and L_Slice and R_Slice then Act_L_Array := Get_Referenced_Object (Prefix (Act_Lhs)); Act_R_Array := Get_Referenced_Object (Prefix (Act_Rhs)); @@ -951,6 +951,7 @@ package body Exp_Ch5 is and then Base_Type (L_Type) = Base_Type (R_Type) and then Ndim = 1 and then not No_Ctrl_Actions (N) + and then not No_Finalize_Actions (N) then declare Proc : constant Entity_Id := @@ -1096,8 +1097,8 @@ package body Exp_Ch5 is and then Base_Type (L_Type) = Base_Type (R_Type) and then Ndim = 1 and then not No_Ctrl_Actions (N) + and then not No_Finalize_Actions (N) then - -- Call TSS procedure for array assignment, passing the -- explicit bounds of right- and left-hand sides. @@ -1320,9 +1321,10 @@ package body Exp_Ch5 is Set_Assignment_OK (Name (Assign)); - -- Propagate the No_Ctrl_Actions flag to individual assignments + -- Propagate the No_{Ctrl,Finalize}_Actions flags to assignments - Set_No_Ctrl_Actions (Assign, No_Ctrl_Actions (N)); + Set_No_Ctrl_Actions (Assign, No_Ctrl_Actions (N)); + Set_No_Finalize_Actions (Assign, No_Finalize_Actions (N)); end; -- Now construct the loop from the inside out, with the last subscript @@ -2658,10 +2660,50 @@ package body Exp_Ch5 is Convert_Aggr_In_Assignment (N); Rewrite (N, Make_Null_Statement (Loc)); Analyze (N); - return; end if; + -- An assignment between nonnative storage models requires creating an + -- intermediate temporary on the host, which can potentially be large. + + if Nkind (Lhs) = N_Explicit_Dereference + and then Has_Designated_Storage_Model_Aspect (Etype (Prefix (Lhs))) + and then Present (Storage_Model_Copy_To + (Storage_Model_Object (Etype (Prefix (Lhs))))) + and then Nkind (Rhs) = N_Explicit_Dereference + and then Has_Designated_Storage_Model_Aspect (Etype (Prefix (Rhs))) + and then Present (Storage_Model_Copy_From + (Storage_Model_Object (Etype (Prefix (Rhs))))) + then + declare + Assign_Code : List_Id; + Tmp : Entity_Id; + + begin + Assign_Code := New_List; + + Tmp := Build_Temporary_On_Secondary_Stack (Loc, Typ, Assign_Code); + + Append_To (Assign_Code, + Make_Assignment_Statement (Loc, + Name => + Make_Explicit_Dereference (Loc, + Prefix => New_Occurrence_Of (Tmp, Loc)), + Expression => Relocate_Node (Rhs))); + + Append_To (Assign_Code, + Make_Assignment_Statement (Loc, + Name => Relocate_Node (Lhs), + Expression => + Make_Explicit_Dereference (Loc, + Prefix => New_Occurrence_Of (Tmp, Loc)))); + + Insert_Actions (N, Assign_Code); + Rewrite (N, Make_Null_Statement (Loc)); + return; + end; + end if; + -- Apply discriminant check if required. If Lhs is an access type to a -- designated type with discriminants, we must always check. If the -- type has unknown discriminants, more elaborate processing below. @@ -2672,7 +2714,7 @@ package body Exp_Ch5 is -- Skip discriminant check if change of representation. Will be -- done when the change of representation is expanded out. - if not Crep then + if not Crep and then not Suppress_Assignment_Checks (N) then Apply_Discriminant_Check (Rhs, Etype (Lhs), Lhs); end if; @@ -2712,7 +2754,9 @@ package body Exp_Ch5 is Set_Etype (Lhs, Ubt); Rewrite (Rhs, OK_Convert_To (Base_Type (Ubt), Rhs)); - Apply_Discriminant_Check (Rhs, Ubt, Lhs); + if not Suppress_Assignment_Checks (N) then + Apply_Discriminant_Check (Rhs, Ubt, Lhs); + end if; Set_Etype (Lhs, Lt); end; @@ -2732,12 +2776,16 @@ package body Exp_Ch5 is then Rewrite (Rhs, OK_Convert_To (Base_Type (Typ), Rhs)); Rewrite (Lhs, OK_Convert_To (Base_Type (Typ), Lhs)); - Apply_Discriminant_Check (Rhs, Typ, Lhs); + if not Suppress_Assignment_Checks (N) then + Apply_Discriminant_Check (Rhs, Typ, Lhs); + end if; elsif Is_Array_Type (Typ) and then Is_Constrained (Typ) then Rewrite (Rhs, OK_Convert_To (Base_Type (Typ), Rhs)); Rewrite (Lhs, OK_Convert_To (Base_Type (Typ), Lhs)); - Apply_Length_Check (Rhs, Typ); + if not Suppress_Assignment_Checks (N) then + Apply_Length_Check (Rhs, Typ); + end if; end if; -- In the access type case, we need the same discriminant check, and @@ -2745,6 +2793,7 @@ package body Exp_Ch5 is elsif Is_Access_Type (Etype (Lhs)) and then Is_Constrained (Designated_Type (Etype (Lhs))) + and then not Suppress_Assignment_Checks (N) then if Has_Discriminants (Designated_Type (Etype (Lhs))) then @@ -2915,7 +2964,9 @@ package body Exp_Ch5 is then Tagged_Case : declare L : List_Id := No_List; - Expand_Ctrl_Actions : constant Boolean := not No_Ctrl_Actions (N); + Expand_Ctrl_Actions : constant Boolean + := not No_Ctrl_Actions (N) + and then not No_Finalize_Actions (N); begin -- In the controlled case, we ensure that function calls are @@ -3115,10 +3166,20 @@ package body Exp_Ch5 is end if; end if; - Rewrite (N, - Make_Block_Statement (Loc, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, Statements => L))); + -- We will analyze the block statement with all checks suppressed + -- below, but we need elaboration checks for the primitives in the + -- case of an assignment created by the expansion of an aggregate. + + if No_Finalize_Actions (N) then + Rewrite (N, + Make_Unsuppress_Block (Loc, Name_Elaboration_Check, L)); + + else + Rewrite (N, + Make_Block_Statement (Loc, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, L))); + end if; -- If no restrictions on aborts, protect the whole assignment -- for controlled objects as per 9.8(11). @@ -3924,7 +3985,7 @@ package body Exp_Ch5 is Declarations : constant List_Id := New_List (Selector_Decl); - -- Start of processing for Expand_General_Case_Statment + -- Start of processing for Expand_General_Case_Statement begin if Present (Choice_Index_Decl) then @@ -4079,11 +4140,15 @@ package body Exp_Ch5 is -- If there is only a single alternative, just replace it with the -- sequence of statements since obviously that is what is going to - -- be executed in all cases. + -- be executed in all cases, except if it is the node to be wrapped + -- by a transient scope, because this would cause the sequence of + -- statements to be leaked out of the transient scope. Len := List_Length (Alternatives (N)); - if Len = 1 then + if Len = 1 + and then not (Scope_Is_Transient and then Node_To_Be_Wrapped = N) + then -- We still need to evaluate the expression if it has any side -- effects. @@ -4324,6 +4389,12 @@ package body Exp_Ch5 is Analyze (Init_Decl); Init_Name := Defining_Identifier (Init_Decl); + Reinit_Field_To_Zero (Init_Name, F_Has_Initial_Value, + Old_Ekind => (E_Variable => True, others => False)); + Reinit_Field_To_Zero (Init_Name, F_Is_Elaboration_Checks_OK_Id); + Reinit_Field_To_Zero (Init_Name, F_Is_Elaboration_Warnings_OK_Id); + Reinit_Field_To_Zero (Init_Name, F_SPARK_Pragma); + Reinit_Field_To_Zero (Init_Name, F_SPARK_Pragma_Inherited); Mutate_Ekind (Init_Name, E_Loop_Parameter); -- The cursor was marked as a loop parameter to prevent user assignments @@ -4689,7 +4760,6 @@ package body Exp_Ch5 is and then not Opt.Suppress_Control_Flow_Optimizations and then Nkind (N) = N_If_Statement and then No (Elsif_Parts (N)) - and then Present (Else_Statements (N)) and then List_Length (Then_Statements (N)) = 1 and then List_Length (Else_Statements (N)) = 1 then @@ -4765,7 +4835,7 @@ package body Exp_Ch5 is else Expand_Iterator_Loop_Over_Container - (N, Isc, I_Spec, Container, Container_Typ); + (N, I_Spec, Container, Container_Typ); end if; end Expand_Iterator_Loop; @@ -5062,7 +5132,6 @@ package body Exp_Ch5 is procedure Expand_Iterator_Loop_Over_Container (N : Node_Id; - Isc : Node_Id; I_Spec : Node_Id; Container : Node_Id; Container_Typ : Entity_Id) @@ -5526,16 +5595,15 @@ package body Exp_Ch5 is Set_Assignment_OK (Cursor_Decl); Insert_Action (N, Cursor_Decl); + Reinit_Field_To_Zero (Cursor, F_Has_Initial_Value, + Old_Ekind => (E_Variable => True, others => False)); + Reinit_Field_To_Zero (Cursor, F_Is_Elaboration_Checks_OK_Id); + Reinit_Field_To_Zero (Cursor, F_Is_Elaboration_Warnings_OK_Id); + Reinit_Field_To_Zero (Cursor, F_SPARK_Pragma); + Reinit_Field_To_Zero (Cursor, F_SPARK_Pragma_Inherited); Mutate_Ekind (Cursor, Id_Kind); end; - -- If the range of iteration is given by a function call that returns - -- a container, the finalization actions have been saved in the - -- Condition_Actions of the iterator. Insert them now at the head of - -- the loop. - - Insert_List_Before (N, Condition_Actions (Isc)); - Rewrite (N, New_Loop); Analyze (N); end Expand_Iterator_Loop_Over_Container; @@ -5610,6 +5678,7 @@ package body Exp_Ch5 is New_List (Make_If_Statement (Loc, Condition => Iterator_Filter (LPS), Then_Statements => Stats))); + Analyze_List (Statements (N)); end if; -- Deal with loop over predicates @@ -6177,12 +6246,20 @@ package body Exp_Ch5 is Res : constant List_Id := New_List; T : constant Entity_Id := Underlying_Type (Etype (L)); + Adj_Act : constant Boolean := Needs_Finalization (T) + and then not No_Ctrl_Actions (N); Comp_Asn : constant Boolean := Is_Fully_Repped_Tagged_Type (T); Ctrl_Act : constant Boolean := Needs_Finalization (T) - and then not No_Ctrl_Actions (N); + and then not No_Ctrl_Actions (N) + and then not No_Finalize_Actions (N); Save_Tag : constant Boolean := Is_Tagged_Type (T) and then not Comp_Asn and then not No_Ctrl_Actions (N) + and then not No_Finalize_Actions (N) + and then Tagged_Type_Expansion; + Set_Tag : constant Boolean := Is_Tagged_Type (T) + and then not Comp_Asn + and then not No_Ctrl_Actions (N) and then Tagged_Type_Expansion; Adj_Call : Node_Id; Fin_Call : Node_Id; @@ -6193,8 +6270,8 @@ package body Exp_Ch5 is -- We have two exceptions here: - -- 1. If we are in an init proc since it is an initialization more - -- than an assignment. + -- 1. If we are in an init proc or within an aggregate, since it is an + -- initialization more than an assignment. -- 2. If the left-hand side is a temporary that was not initialized -- (or the parent part of a temporary since it is the case in @@ -6203,7 +6280,7 @@ package body Exp_Ch5 is -- it may be a component of an entry formal, in which case it has -- been rewritten and does not appear to come from source either. - -- Case of init proc + -- Case of init proc or aggregate if not Ctrl_Act then null; @@ -6273,12 +6350,19 @@ package body Exp_Ch5 is Selector_Name => New_Occurrence_Of (First_Tag_Component (T), Loc)), Expression => New_Occurrence_Of (Tag_Id, Loc))); + + -- Or else just initialize it + + elsif Set_Tag then + Append_To (Res, + Make_Tag_Assignment_From_Type + (Loc, Duplicate_Subexpr_No_Checks (L), T)); end if; -- Adjust the target after the assignment when controlled (not in the -- init proc since it is an initialization more than an assignment). - if Ctrl_Act then + if Ctrl_Act or else Adj_Act then Adj_Call := Make_Adjust_Call (Obj_Ref => Duplicate_Subexpr_Move_Checks (L), diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 7abf25e..28d563f 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -70,6 +70,7 @@ with Sem_Mech; use Sem_Mech; with Sem_Res; use Sem_Res; with Sem_SCIL; use Sem_SCIL; with Sem_Util; use Sem_Util; + use Sem_Util.Storage_Model_Support; with Sinfo; use Sinfo; with Sinfo.Nodes; use Sinfo.Nodes; with Sinfo.Utils; use Sinfo.Utils; @@ -1936,8 +1937,14 @@ package body Exp_Ch6 is ---------------------------------- procedure Add_Simple_Call_By_Copy_Code (Force : Boolean) is + With_Storage_Model : constant Boolean := + Nkind (Actual) = N_Explicit_Dereference + and then + Has_Designated_Storage_Model_Aspect (Etype (Prefix (Actual))); + + Cpcod : List_Id; Decl : Node_Id; - F_Typ : Entity_Id := Etype (Formal); + F_Typ : Entity_Id; Incod : Node_Id; Indic : Node_Id; Lhs : Node_Id; @@ -1952,6 +1959,8 @@ package body Exp_Ch6 is return; end if; + F_Typ := Etype (Formal); + -- Handle formals whose type comes from the limited view if From_Limited_With (F_Typ) @@ -1961,11 +1970,11 @@ package body Exp_Ch6 is end if; -- Use formal type for temp, unless formal type is an unconstrained - -- array, in which case we don't have to worry about bounds checks, - -- and we use the actual type, since that has appropriate bounds. + -- composite, in which case we don't have to worry about checks and + -- we can use the actual type, since that has appropriate bounds. - if Is_Array_Type (F_Typ) and then not Is_Constrained (F_Typ) then - Indic := New_Occurrence_Of (Etype (Actual), Loc); + if Is_Composite_Type (F_Typ) and then not Is_Constrained (F_Typ) then + Indic := New_Occurrence_Of (Get_Actual_Subtype (Actual), Loc); else Indic := New_Occurrence_Of (F_Typ, Loc); end if; @@ -1974,7 +1983,6 @@ package body Exp_Ch6 is Reset_Packed_Prefix; - Temp := Make_Temporary (Loc, 'T', Actual); Incod := Relocate_Node (Actual); Outcod := New_Copy_Tree (Incod); @@ -1982,18 +1990,9 @@ package body Exp_Ch6 is -- with the input parameter unless we have an OUT formal or -- this is an initialization call. - -- If the formal is an out parameter with discriminants, the - -- discriminants must be captured even if the rest of the object - -- is in principle uninitialized, because the discriminants may - -- be read by the called subprogram. - if Ekind (Formal) = E_Out_Parameter then Incod := Empty; - if Has_Discriminants (F_Typ) then - Indic := New_Occurrence_Of (Etype (Actual), Loc); - end if; - elsif Inside_Init_Proc then -- Skip using the actual as the expression in Decl if we are in @@ -2017,15 +2016,31 @@ package body Exp_Ch6 is end if; end if; - Decl := - Make_Object_Declaration (Loc, - Defining_Identifier => Temp, - Object_Definition => Indic, - Expression => Incod); + Cpcod := New_List; + + if With_Storage_Model then + Temp := + Build_Temporary_On_Secondary_Stack (Loc, Entity (Indic), Cpcod); + + if Present (Incod) then + Append_To (Cpcod, + Make_Assignment_Statement (Loc, + Name => + Make_Explicit_Dereference (Loc, + Prefix => New_Occurrence_Of (Temp, Loc)), + Expression => Incod)); + Set_Suppress_Assignment_Checks (Last (Cpcod)); + end if; + + else + Temp := Make_Temporary (Loc, 'T', Actual); + + Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Temp, + Object_Definition => Indic, + Expression => Incod); - if Inside_Init_Proc - and then No (Incod) - then -- If the call is to initialize a component of a composite type, -- and the component does not depend on discriminants, use the -- actual type of the component. This is required in case the @@ -2035,23 +2050,42 @@ package body Exp_Ch6 is -- discriminant, the presence of the initialization in the -- declaration will generate an expression for the actual subtype. - Set_No_Initialization (Decl); - Set_Object_Definition (Decl, - New_Occurrence_Of (Etype (Actual), Loc)); + if Inside_Init_Proc and then No (Incod) then + Set_No_Initialization (Decl); + Set_Object_Definition (Decl, + New_Occurrence_Of (Etype (Actual), Loc)); + end if; + + Append_To (Cpcod, Decl); end if; - Insert_Action (N, Decl); + Insert_Actions (N, Cpcod); -- The actual is simply a reference to the temporary - Rewrite (Actual, New_Occurrence_Of (Temp, Loc)); + if With_Storage_Model then + Rewrite (Actual, + Make_Explicit_Dereference (Loc, + Prefix => New_Occurrence_Of (Temp, Loc))); + else + Rewrite (Actual, New_Occurrence_Of (Temp, Loc)); + end if; + + Analyze (Actual); -- Generate copy out if OUT or IN OUT parameter if Ekind (Formal) /= E_In_Parameter then Lhs := Outcod; - Rhs := New_Occurrence_Of (Temp, Loc); - Set_Is_True_Constant (Temp, False); + + if With_Storage_Model then + Rhs := + Make_Explicit_Dereference (Loc, + Prefix => New_Occurrence_Of (Temp, Loc)); + else + Rhs := New_Occurrence_Of (Temp, Loc); + Set_Is_True_Constant (Temp, False); + end if; -- Deal with conversion @@ -2064,6 +2098,7 @@ package body Exp_Ch6 is Make_Assignment_Statement (Loc, Name => Lhs, Expression => Rhs)); + Set_Suppress_Assignment_Checks (Last (Post_Call)); Set_Assignment_OK (Name (Last (Post_Call))); end if; end Add_Simple_Call_By_Copy_Code; @@ -2452,6 +2487,22 @@ package body Exp_Ch6 is elsif Is_Ref_To_Bit_Packed_Array (Actual) then Add_Simple_Call_By_Copy_Code (Force => True); + -- If the actual has a nonnative storage model, we need a copy + + elsif Nkind (Actual) = N_Explicit_Dereference + and then + Has_Designated_Storage_Model_Aspect (Etype (Prefix (Actual))) + and then + (Present (Storage_Model_Copy_To + (Storage_Model_Object (Etype (Prefix (Actual))))) + or else + (Ekind (Formal) = E_In_Out_Parameter + and then + Present (Storage_Model_Copy_From + (Storage_Model_Object (Etype (Prefix (Actual))))))) + then + Add_Simple_Call_By_Copy_Code (Force => True); + -- If a nonscalar actual is possibly bit-aligned, we need a copy -- because the back-end cannot cope with such objects. In other -- cases where alignment forces a copy, the back-end generates @@ -2598,6 +2649,17 @@ package body Exp_Ch6 is elsif Is_Ref_To_Bit_Packed_Array (Actual) then Add_Simple_Call_By_Copy_Code (Force => True); + -- If the actual has a nonnative storage model, we need a copy + + elsif Nkind (Actual) = N_Explicit_Dereference + and then + Has_Designated_Storage_Model_Aspect (Etype (Prefix (Actual))) + and then + Present (Storage_Model_Copy_From + (Storage_Model_Object (Etype (Prefix (Actual))))) + then + Add_Simple_Call_By_Copy_Code (Force => True); + -- If we have a C++ constructor call, we need to create the object elsif Is_CPP_Constructor_Call (Actual) then @@ -3028,7 +3090,7 @@ package body Exp_Ch6 is -- Start of processing for Insert_Level_Assign begin - -- Examine further nested condtionals + -- Examine further nested conditionals pragma Assert (Nkind (Branch) = N_Expression_With_Actions); @@ -3343,6 +3405,7 @@ package body Exp_Ch6 is or else No (Aspect) -- Do not fold if multiple applicable predicate aspects + or else Has_Ghost_Predicate_Aspect (Subt) or else Has_Aspect (Subt, Aspect_Static_Predicate) or else Has_Aspect (Subt, Aspect_Predicate) or else Augments_Other_Dynamic_Predicate (Aspect) @@ -5126,8 +5189,16 @@ package body Exp_Ch6 is -- Optimization: if the returned value is returned again, then no need -- to copy/readjust/finalize, we can just pass the value through (see -- Expand_N_Simple_Return_Statement), and thus no attachment is needed. + -- Note that simple return statements are distributed into conditional + -- expressions but we may be invoked before this distribution is done. - if Nkind (Par) = N_Simple_Return_Statement then + if Nkind (Par) = N_Simple_Return_Statement + or else (Nkind (Par) = N_If_Expression + and then Nkind (Parent (Par)) = N_Simple_Return_Statement) + or else (Nkind (Par) = N_Case_Expression_Alternative + and then + Nkind (Parent (Parent (Par))) = N_Simple_Return_Statement) + then return; end if; @@ -6182,10 +6253,13 @@ package body Exp_Ch6 is -- body subprogram points to itself. Proc := Current_Scope; - while Present (Proc) - and then Scope (Proc) /= Scop - loop + while Present (Proc) and then Scope (Proc) /= Scop loop Proc := Scope (Proc); + if Is_Subprogram (Proc) + and then Present (Protected_Subprogram (Proc)) + then + Proc := Protected_Subprogram (Proc); + end if; end loop; Corr := Protected_Body_Subprogram (Proc); @@ -6568,6 +6642,13 @@ package body Exp_Ch6 is if Is_Boolean_Type (Exp_Typ) and then Nonzero_Is_True (Exp_Typ) then Adjust_Condition (Exp); Adjust_Result_Type (Exp, Exp_Typ); + + -- The adjustment of the expression may have rewritten the return + -- statement itself, e.g. when it is turned into an if expression. + + if Nkind (N) /= N_Simple_Return_Statement then + return; + end if; end if; -- Do validity check if enabled for returns @@ -6815,7 +6896,7 @@ package body Exp_Ch6 is Temp := Make_Temporary (Loc, 'R', Alloc_Node); - Insert_List_Before_And_Analyze (N, New_List ( + Insert_Actions (Exp, New_List ( Make_Full_Type_Declaration (Loc, Defining_Identifier => Acc_Typ, Type_Definition => @@ -9240,7 +9321,7 @@ package body Exp_Ch6 is and then not No_Run_Time_Mode and then (Has_Task (Typ) or else (Is_Class_Wide_Type (Typ) - and then Is_Limited_Record (Etype (Typ)) + and then Is_Limited_Record (Typ) and then not Has_Aspect (Etype (Typ), Aspect_No_Task_Parts))); end Might_Have_Tasks; @@ -9352,9 +9433,14 @@ package body Exp_Ch6 is -- types, and those can be used to call primitives, so the formal needs -- to be passed to all such build-in-place functions, primitive or not. + -- We never use build-in-place if the function has foreign convention, + -- but note that it is OK for a build-in-place function to return a + -- type with a foreign convention because the machinery ensures there + -- is no copying. + return not Restriction_Active (No_Secondary_Stack) and then (Needs_Secondary_Stack (Typ) or else Is_Tagged_Type (Typ)) - and then not Has_Foreign_Convention (Typ); + and then not Has_Foreign_Convention (Func_Id); end Needs_BIP_Alloc_Form; ------------------------------------- diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index 7ea39f7..1b16839 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -281,29 +281,6 @@ package body Exp_Ch7 is -- does not contain the above constructs, the routine returns an empty -- list. - 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); - -- N may denote an accept statement, block, entry body, package body, - -- package spec, protected body, subprogram body, or a task body. Create - -- a procedure which contains finalization calls for all controlled objects - -- declared in the declarative or statement region of N. The calls are - -- built in reverse order relative to the original declarations. In the - -- case of a task body, the routine delays the creation of the finalizer - -- until all statements have been moved to the task body procedure. - -- Clean_Stmts may contain additional context-dependent code used to abort - -- asynchronous calls or complete tasks (see Build_Cleanup_Statements). - -- Mark_Id is the secondary stack used in the current context or Empty if - -- missing. Top_Decls is the list on which the declaration of the finalizer - -- is attached in the non-package case. Defer_Abort indicates that the - -- statements passed in perform actions that require abort to be deferred, - -- such as for task termination. Fin_Id is the finalizer declaration - -- entity. - 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 @@ -417,13 +394,9 @@ package body Exp_Ch7 is -- Check recursively whether a loop or block contains a subprogram that -- may need an activation record. - function Convert_View - (Proc : Entity_Id; - Arg : Node_Id; - Ind : Pos := 1) return Node_Id; + function Convert_View (Proc : Entity_Id; Arg : Node_Id) return Node_Id; -- Proc is one of the Initialize/Adjust/Finalize operations, and Arg is the - -- argument being passed to it. Ind indicates which formal of procedure - -- Proc we are trying to match. This function will, if necessary, generate + -- argument being passed to it. This function will, if necessary, generate -- a conversion between the partial and full view of Arg to match the type -- of the formal of Proc, or force a conversion to the class-wide type in -- the case where the operation is abstract. @@ -2138,6 +2111,9 @@ package body Exp_Ch7 is -- This variable is used to determine whether a nested package or -- instance contains at least one controlled object. + procedure Process_Package_Body (Decl : Node_Id); + -- Process an N_Package_Body node + procedure Processing_Actions (Has_No_Init : Boolean := False; Is_Protected : Boolean := False); @@ -2149,6 +2125,35 @@ package body Exp_Ch7 is -- Is_Protected should be set when the current declaration denotes a -- simple protected object. + -------------------------- + -- Process_Package_Body -- + -------------------------- + + procedure Process_Package_Body (Decl : Node_Id) is + begin + -- Do not inspect an ignored Ghost package body because all + -- code found within will not appear in the final tree. + + if Is_Ignored_Ghost_Entity (Defining_Entity (Decl)) then + null; + + elsif Ekind (Corresponding_Spec (Decl)) /= E_Generic_Package then + Old_Counter_Val := Counter_Val; + Process_Declarations (Declarations (Decl), Preprocess); + + -- The nested package body is the last construct to contain + -- a controlled object. + + if Preprocess + and then Top_Level + and then No (Last_Top_Level_Ctrl_Construct) + and then Counter_Val > Old_Counter_Val + then + Last_Top_Level_Ctrl_Construct := Decl; + end if; + end if; + end Process_Package_Body; + ------------------------ -- Processing_Actions -- ------------------------ @@ -2466,99 +2471,15 @@ package body Exp_Ch7 is end if; end if; - -- Call the xxx__finalize_body procedure of a library level - -- package instantiation if the body contains finalization - -- statements. - - if Present (Generic_Parent (Spec)) - and then Is_Library_Level_Entity (Pack_Id) - and then Present (Body_Entity (Generic_Parent (Spec))) - then - if Preprocess then - declare - P : Node_Id; - begin - P := Parent (Body_Entity (Generic_Parent (Spec))); - while Present (P) - and then Nkind (P) /= N_Package_Body - loop - P := Parent (P); - end loop; - - if Present (P) then - Old_Counter_Val := Counter_Val; - Process_Declarations (Declarations (P), Preprocess); - - -- Note that we are processing the generic body - -- template and not the actually instantiation - -- (which is generated too late for us to process - -- it), so there is no need to update in particular - -- Last_Top_Level_Ctrl_Construct here. - - if Counter_Val > Old_Counter_Val then - Counter_Val := Old_Counter_Val; - Set_Has_Controlled_Component (Pack_Id); - end if; - end if; - end; - - elsif Has_Controlled_Component (Pack_Id) then - - -- We import the xxx__finalize_body routine since the - -- generic body will be instantiated later. - - declare - Id : constant Node_Id := - Make_Defining_Identifier (Loc, - New_Finalizer_Name (Defining_Unit_Name (Spec), - For_Spec => False)); - - begin - Set_Has_Qualified_Name (Id); - Set_Has_Fully_Qualified_Name (Id); - Set_Is_Imported (Id); - Set_Has_Completion (Id); - Set_Interface_Name (Id, - Make_String_Literal (Loc, - Strval => Get_Name_String (Chars (Id)))); - - Append_New_To (Finalizer_Stmts, - Make_Subprogram_Declaration (Loc, - Make_Procedure_Specification (Loc, - Defining_Unit_Name => Id))); - Append_To (Finalizer_Stmts, - Make_Procedure_Call_Statement (Loc, - Name => New_Occurrence_Of (Id, Loc))); - end; - end if; - end if; - -- Nested package bodies, avoid generics elsif Nkind (Decl) = N_Package_Body then + Process_Package_Body (Decl); - -- Do not inspect an ignored Ghost package body because all - -- code found within will not appear in the final tree. - - if Is_Ignored_Ghost_Entity (Defining_Entity (Decl)) then - null; - - elsif Ekind (Corresponding_Spec (Decl)) /= E_Generic_Package - then - Old_Counter_Val := Counter_Val; - Process_Declarations (Declarations (Decl), Preprocess); - - -- The nested package body is the last construct to contain - -- a controlled object. - - if Preprocess - and then Top_Level - and then No (Last_Top_Level_Ctrl_Construct) - and then Counter_Val > Old_Counter_Val - then - Last_Top_Level_Ctrl_Construct := Decl; - end if; - end if; + elsif Nkind (Decl) = N_Package_Body_Stub + and then Present (Library_Unit (Decl)) + then + Process_Package_Body (Proper_Body (Unit (Library_Unit (Decl)))); -- Handle a rare case caused by a controlled transient object -- created as part of a record init proc. The variable is wrapped @@ -3526,28 +3447,15 @@ package body Exp_Ch7 is end if; end if; - -- Do not process nested packages since those are handled by the - -- enclosing scope's finalizer. Do not process non-expanded package - -- instantiations since those will be re-analyzed and re-expanded. + -- We do not need to process nested packages since they are handled by + -- the finalizer of the enclosing scope, including at library level. + -- And we do not build two finalizers for an instance without body that + -- is a library unit (see Analyze_Package_Instantiation). if For_Package - and then - (not Is_Library_Level_Entity (Spec_Id) - - -- Nested packages are library level entities, but do not need to - -- be processed separately. - - or else Scope_Depth (Spec_Id) /= Uint_1 - or else (Is_Generic_Instance (Spec_Id) - and then Package_Instantiation (Spec_Id) /= N)) - - -- Still need to process package body instantiations which may - -- contain objects requiring finalization. - - and then not - (For_Package_Body - and then Is_Library_Level_Entity (Spec_Id) - and then Is_Generic_Instance (Spec_Id)) + and then (not Is_Compilation_Unit (Spec_Id) + or else (Is_Generic_Instance (Spec_Id) + and then Package_Instantiation (Spec_Id) = N)) then return; end if; @@ -4490,22 +4398,12 @@ package body Exp_Ch7 is -- Convert_View -- ------------------ - function Convert_View - (Proc : Entity_Id; - Arg : Node_Id; - Ind : Pos := 1) return Node_Id - is - Fent : Entity_Id := First_Entity (Proc); - Ftyp : Entity_Id; + function Convert_View (Proc : Entity_Id; Arg : Node_Id) return Node_Id is + Ftyp : constant Entity_Id := Etype (First_Formal (Proc)); + Atyp : Entity_Id; begin - for J in 2 .. Ind loop - Next_Entity (Fent); - end loop; - - Ftyp := Etype (Fent); - if Nkind (Arg) in N_Type_Conversion | N_Unchecked_Type_Conversion then Atyp := Entity (Subtype_Mark (Arg)); else @@ -4515,11 +4413,13 @@ package body Exp_Ch7 is if Is_Abstract_Subprogram (Proc) and then Is_Tagged_Type (Ftyp) then return Unchecked_Convert_To (Class_Wide_Type (Ftyp), Arg); - elsif Ftyp /= Atyp - and then Present (Atyp) - and then (Is_Private_Type (Ftyp) or else Is_Private_Type (Atyp)) - and then Base_Type (Underlying_Type (Atyp)) = - Base_Type (Underlying_Type (Ftyp)) + elsif Present (Atyp) + and then Atyp /= Ftyp + and then (Is_Private_Type (Ftyp) + or else Is_Private_Type (Atyp) + or else Is_Private_Type (Base_Type (Atyp))) + and then Implementation_Base_Type (Atyp) = + Implementation_Base_Type (Ftyp) then return Unchecked_Convert_To (Ftyp, Arg); @@ -4564,10 +4464,10 @@ package body Exp_Ch7 is function Is_Package_Or_Subprogram (Id : Entity_Id) return Boolean; -- Determine whether arbitrary Id denotes a package or subprogram [body] - function Find_Enclosing_Transient_Scope return Entity_Id; + function Find_Enclosing_Transient_Scope return Int; -- Examine the scope stack looking for the nearest enclosing transient -- scope within the innermost enclosing package or subprogram. Return - -- Empty if no such scope exists. + -- its index in the table or else -1 if no such scope exists. function Find_Transient_Context (N : Node_Id) return Node_Id; -- Locate a suitable context for arbitrary node N which may need to be @@ -4693,7 +4593,7 @@ package body Exp_Ch7 is -- Find_Enclosing_Transient_Scope -- ------------------------------------ - function Find_Enclosing_Transient_Scope return Entity_Id is + function Find_Enclosing_Transient_Scope return Int is begin for Index in reverse Scope_Stack.First .. Scope_Stack.Last loop declare @@ -4708,12 +4608,12 @@ package body Exp_Ch7 is exit; elsif Scope.Is_Transient then - return Scope.Entity; + return Index; end if; end; end loop; - return Empty; + return -1; end Find_Enclosing_Transient_Scope; ---------------------------- @@ -4805,21 +4705,29 @@ package body Exp_Ch7 is return Curr; when N_Simple_Return_Statement => + declare + Fun_Id : constant Entity_Id := + Return_Applies_To (Return_Statement_Entity (Curr)); - -- A return statement is not a valid transient context when - -- the function itself requires transient scope management - -- because the result will be reclaimed too early. - - if Requires_Transient_Scope (Etype - (Return_Applies_To (Return_Statement_Entity (Curr)))) - then - return Empty; + begin + -- A transient context that must manage the secondary + -- stack cannot be a return statement of a function that + -- itself requires secondary stack management, because + -- the function's result would be reclaimed too early. + -- And returns of thunks never require transient scopes. + + if (Manage_Sec_Stack + and then Needs_Secondary_Stack (Etype (Fun_Id))) + or else Is_Thunk (Fun_Id) + then + return Empty; - -- General case for return statements + -- General case for return statements - else - return Curr; - end if; + else + return Curr; + end if; + end; -- Special @@ -4902,8 +4810,8 @@ package body Exp_Ch7 is -- Local variables - Trans_Id : constant Entity_Id := Find_Enclosing_Transient_Scope; - Context : Node_Id; + Trans_Idx : constant Int := Find_Enclosing_Transient_Scope; + Context : Node_Id; -- Start of processing for Establish_Transient_Scope @@ -4911,13 +4819,29 @@ package body Exp_Ch7 is -- Do not create a new transient scope if there is already an enclosing -- transient scope within the innermost enclosing package or subprogram. - if Present (Trans_Id) then + if Trans_Idx >= 0 then -- If the transient scope was requested for purposes of managing the - -- secondary stack, then the existing scope must perform this task. + -- secondary stack, then the existing scope must perform this task, + -- unless the node to be wrapped is a return statement of a function + -- that requires secondary stack management, because the function's + -- result would be reclaimed too early (see Find_Transient_Context). if Manage_Sec_Stack then - Set_Uses_Sec_Stack (Trans_Id); + declare + SE : Scope_Stack_Entry renames Scope_Stack.Table (Trans_Idx); + + begin + if Nkind (SE.Node_To_Be_Wrapped) /= N_Simple_Return_Statement + or else not + Needs_Secondary_Stack + (Etype + (Return_Applies_To + (Return_Statement_Entity (SE.Node_To_Be_Wrapped)))) + then + Set_Uses_Sec_Stack (SE.Entity); + end if; + end; end if; return; @@ -5033,16 +4957,6 @@ package body Exp_Ch7 is if not Actions_Required then return; - - -- If the current node is a rewritten task body and the descriptors have - -- not been delayed (due to some nested instantiations), do not generate - -- redundant cleanup actions. - - elsif Is_Task_Body - and then Nkind (N) = N_Subprogram_Body - and then not Delay_Subprogram_Descriptors (Corresponding_Spec (N)) - then - return; end if; -- If an extended return statement contains something like @@ -5177,7 +5091,9 @@ package body Exp_Ch7 is -- Encode entity names in package body procedure Expand_N_Package_Body (N : Node_Id) is + Id : constant Entity_Id := Defining_Entity (N); Spec_Id : constant Entity_Id := Corresponding_Spec (N); + Fin_Id : Entity_Id; begin @@ -5231,7 +5147,9 @@ package body Exp_Ch7 is Qualify_Entity_Names (N); - if Ekind (Spec_Id) /= E_Generic_Package then + if Ekind (Spec_Id) /= E_Generic_Package + and then not Delay_Cleanups (Id) + then Build_Finalizer (N => N, Clean_Stmts => No_List, @@ -5241,16 +5159,7 @@ package body Exp_Ch7 is Fin_Id => Fin_Id); if Present (Fin_Id) then - declare - Body_Ent : Node_Id := Defining_Unit_Name (N); - - begin - if Nkind (Body_Ent) = N_Defining_Program_Unit_Name then - Body_Ent := Defining_Identifier (Body_Ent); - end if; - - Set_Finalizer (Body_Ent, Fin_Id); - end; + Set_Finalizer (Defining_Entity (N), Fin_Id); end if; end if; end Expand_N_Package_Body; @@ -5367,7 +5276,9 @@ package body Exp_Ch7 is Qualify_Entity_Names (N); - if Ekind (Id) /= E_Generic_Package then + if Ekind (Id) /= E_Generic_Package + and then not Delay_Cleanups (Id) + then Build_Finalizer (N => N, Clean_Stmts => No_List, @@ -5376,7 +5287,9 @@ package body Exp_Ch7 is Defer_Abort => False, Fin_Id => Fin_Id); - Set_Finalizer (Id, Fin_Id); + if Present (Fin_Id) then + Set_Finalizer (Id, Fin_Id); + end if; end if; -- If this is a library-level package and unnesting is enabled, diff --git a/gcc/ada/exp_ch7.ads b/gcc/ada/exp_ch7.ads index 37754db..a131e55 100644 --- a/gcc/ada/exp_ch7.ads +++ b/gcc/ada/exp_ch7.ads @@ -118,6 +118,29 @@ package Exp_Ch7 is -- finalization master must be analyzed. Insertion_Node is the insertion -- point before which the master is to be inserted. + 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); + -- N may denote an accept statement, block, entry body, package body, + -- package spec, protected body, subprogram body, or a task body. Create + -- a procedure which contains finalization calls for all controlled objects + -- declared in the declarative or statement region of N. The calls are + -- built in reverse order relative to the original declarations. In the + -- case of a task body, the routine delays the creation of the finalizer + -- until all statements have been moved to the task body procedure. + -- Clean_Stmts may contain additional context-dependent code used to abort + -- asynchronous calls or complete tasks (see Build_Cleanup_Statements). + -- Mark_Id is the secondary stack used in the current context or Empty if + -- missing. Top_Decls is the list on which the declaration of the finalizer + -- is attached in the non-package case. Defer_Abort indicates that the + -- statements passed in perform actions that require abort to be deferred, + -- such as for task termination. Fin_Id is the finalizer declaration + -- entity. + procedure Build_Late_Proc (Typ : Entity_Id; Nam : Name_Id); -- Build one controlling procedure when a late body overrides one of the -- controlling operations. diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index 96e6880..b0e3632 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -154,8 +154,7 @@ package body Exp_Ch9 is -- N is the enclosing construct. function Build_Entry_Count_Expression - (Concurrent_Type : Node_Id; - Component_List : List_Id; + (Concurrent_Type : Entity_Id; Loc : Source_Ptr) return Node_Id; -- Compute number of entries for concurrent object. This is a count of -- simple entries, followed by an expression that computes the length @@ -618,7 +617,7 @@ package body Exp_Ch9 is Prev := First_Entity (Ttyp); while Chars (Prev) /= Chars (Ent) - or else (Ekind (Prev) /= Ekind (Ent)) + or else Ekind (Prev) /= Ekind (Ent) or else not Sem_Ch6.Type_Conformant (Ent, Prev) loop if Ekind (Prev) = E_Entry then @@ -1219,9 +1218,9 @@ package body Exp_Ch9 is then declare Ins_Nod : Node_Id; + Par_Nod : Node_Id; begin - Set_Has_Master_Entity (Master_Scope); Master_Decl := Build_Master_Declaration (Loc); -- Ensure that the master declaration is placed before its use @@ -1231,6 +1230,30 @@ package body Exp_Ch9 is Ins_Nod := Parent (Ins_Nod); end loop; + Par_Nod := Parent (List_Containing (Ins_Nod)); + + -- For internal blocks created by Wrap_Loop_Statement, Wrap_ + -- Statements_In_Block, and Build_Abort_Undefer_Block, remember + -- that they have a task master entity declaration; required by + -- Build_Master_Entity to avoid creating another master entity, + -- and also ensures that subsequent calls to Find_Master_Scope + -- return this scope as the master scope of Typ. + + if Is_Internal_Block (Par_Nod) then + Set_Has_Master_Entity (Entity (Identifier (Par_Nod))); + + elsif Nkind (Par_Nod) = N_Handled_Sequence_Of_Statements + and then Is_Internal_Block (Parent (Par_Nod)) + then + Set_Has_Master_Entity (Entity (Identifier (Parent (Par_Nod)))); + + -- Otherwise remember that this scope has an associated task + -- master entity declaration. + + else + Set_Has_Master_Entity (Master_Scope); + end if; + Insert_Before (First (List_Containing (Ins_Nod)), Master_Decl); Analyze (Master_Decl); @@ -1404,14 +1427,12 @@ package body Exp_Ch9 is ---------------------------------- function Build_Entry_Count_Expression - (Concurrent_Type : Node_Id; - Component_List : List_Id; + (Concurrent_Type : Entity_Id; Loc : Source_Ptr) return Node_Id is Eindx : Nat; Ent : Entity_Id; Ecount : Node_Id; - Comp : Node_Id; Lo : Node_Id; Hi : Node_Id; Typ : Entity_Id; @@ -1435,13 +1456,8 @@ package body Exp_Ch9 is -- Loop through entry families building the addition nodes Ent := First_Entity (Concurrent_Type); - Comp := First (Component_List); while Present (Ent) loop if Ekind (Ent) = E_Entry_Family then - while Chars (Ent) /= Chars (Defining_Identifier (Comp)) loop - Next (Comp); - end loop; - Typ := Entry_Index_Type (Ent); Hi := Type_High_Bound (Typ); Lo := Type_Low_Bound (Typ); @@ -3169,28 +3185,6 @@ package body Exp_Ch9 is Par := Parent (Obj_Or_Typ); end if; - -- For transient scopes check if the master entity is already defined - - if Is_Type (Obj_Or_Typ) - and then Ekind (Scope (Obj_Or_Typ)) = E_Block - and then Is_Internal (Scope (Obj_Or_Typ)) - then - declare - Master_Scope : constant Entity_Id := - Find_Master_Scope (Obj_Or_Typ); - begin - if Has_Master_Entity (Master_Scope) - or else Is_Finalizer (Master_Scope) - then - return; - end if; - - if Present (Current_Entity_In_Scope (Name_uMaster)) then - return; - end if; - end; - end if; - -- When creating a master for a record component which is either a task -- or access-to-task, the enclosing record is the master scope and the -- proper insertion point is the component list. @@ -3398,6 +3392,7 @@ package body Exp_Ch9 is Loc : constant Source_Ptr := Sloc (N); + Block_Id : Entity_Id; Bod_Id : Entity_Id; Bod_Spec : Node_Id; Bod_Stmts : List_Id; @@ -3456,11 +3451,12 @@ package body Exp_Ch9 is Analyze_Statements (Bod_Stmts); - Set_Scope (Entity (Identifier (First (Bod_Stmts))), - Protected_Body_Subprogram (Ent)); + Block_Id := Entity (Identifier (First (Bod_Stmts))); + + Set_Scope (Block_Id, Protected_Body_Subprogram (Ent)); + Set_Uses_Sec_Stack (Block_Id, Uses_Sec_Stack (Corresponding_Spec (N))); - Reset_Scopes_To - (First (Bod_Stmts), Entity (Identifier (First (Bod_Stmts)))); + Reset_Scopes_To (First (Bod_Stmts), Block_Id); case Corresponding_Runtime_Package (Pid) is when System_Tasking_Protected_Objects_Entries => @@ -5468,7 +5464,7 @@ package body Exp_Ch9 is Prev := First_Entity (Ttyp); while Chars (Prev) /= Chars (Ent) - or else (Ekind (Prev) /= Ekind (Ent)) + or else Ekind (Prev) /= Ekind (Ent) or else not Sem_Ch6.Type_Conformant (Ent, Prev) loop if Ekind (Prev) = E_Entry then @@ -7708,7 +7704,7 @@ package body Exp_Ch9 is -- or else K = Ada.Tags.TK_Tagged -- then -- <dispatching-call>; - -- <triggering-statements> + -- -- <triggering-statements> (code factorized after if-stmt) -- else -- S := @@ -7733,11 +7729,14 @@ package body Exp_Ch9 is -- <dispatching-call>; -- end if; - -- <triggering-statements> + -- -- <triggering-statements> (code factorized after if-stmt) -- else -- <else-statements> + -- goto L0; -- skip triggering statements -- end if; -- end if; + -- <triggering-statements> + -- L0: -- end; procedure Expand_N_Conditional_Entry_Call (N : Node_Id) is @@ -7753,6 +7752,8 @@ package body Exp_Ch9 is Decl : Node_Id; Decls : List_Id; Formals : List_Id; + Label : Node_Id; + Label_Id : Entity_Id := Empty; Lim_Typ_Stmts : List_Id; N_Stats : List_Id; Obj : Entity_Id; @@ -7879,12 +7880,13 @@ package body Exp_Ch9 is -- then -- <dispatching-call> -- end if; - -- <normal-statements> + -- -- <triggering-stataments> (code factorized after if-stmt) -- else -- <else-statements> + -- goto L0; -- skip triggering statements -- end if; - N_Stats := New_Copy_Separate_List (Statements (Alt)); + N_Stats := New_List; Prepend_To (N_Stats, Make_Implicit_If_Statement (N, @@ -7918,6 +7920,14 @@ package body Exp_Ch9 is Then_Statements => New_List (Blk))); + Label_Id := Make_Identifier (Loc, New_External_Name ('L', 0)); + Set_Entity (Label_Id, + Make_Defining_Identifier (Loc, Chars (Label_Id))); + + Append_To (Else_Statements (N), + Make_Goto_Statement (Loc, + Name => New_Occurrence_Of (Entity (Label_Id), Loc))); + Append_To (Conc_Typ_Stmts, Make_Implicit_If_Statement (N, Condition => New_Occurrence_Of (B, Loc), @@ -7926,15 +7936,14 @@ package body Exp_Ch9 is -- Generate: -- <dispatching-call>; - -- <triggering-statements> + -- -- <triggering-statements> (code factorized after if-stmt) - Lim_Typ_Stmts := New_Copy_Separate_List (Statements (Alt)); - Prepend_To (Lim_Typ_Stmts, New_Copy_Tree (Blk)); + Lim_Typ_Stmts := New_List (New_Copy_Tree (Blk)); -- Generate: -- if K = Ada.Tags.TK_Limited_Tagged -- or else K = Ada.Tags.TK_Tagged - -- then + -- then -- Lim_Typ_Stmts -- else -- Conc_Typ_Stmts @@ -7946,6 +7955,15 @@ package body Exp_Ch9 is Then_Statements => Lim_Typ_Stmts, Else_Statements => Conc_Typ_Stmts)); + Label := Make_Label (Loc, Label_Id); + Append_To (Decls, + Make_Implicit_Label_Declaration (Loc, + Defining_Identifier => Entity (Label_Id), + Label_Construct => Label)); + + Append_List_To (Stmts, Statements (Alt)); -- triggering-statements + Append_To (Stmts, Label); + Rewrite (N, Make_Block_Statement (Loc, Declarations => @@ -8393,9 +8411,11 @@ package body Exp_Ch9 is Current_Node : Node_Id; Disp_Op_Body : Node_Id; New_Op_Body : Node_Id; + New_Op_Spec : Node_Id; Op_Body : Node_Id; Op_Decl : Node_Id; Op_Id : Entity_Id; + Op_Spec : Entity_Id; function Build_Dispatching_Subprogram_Body (N : Node_Id; @@ -8512,11 +8532,12 @@ package body Exp_Ch9 is null; when N_Subprogram_Body => + Op_Spec := Corresponding_Spec (Op_Body); -- Do not create bodies for eliminated operations if not Is_Eliminated (Defining_Entity (Op_Body)) - and then not Is_Eliminated (Corresponding_Spec (Op_Body)) + and then not Is_Eliminated (Op_Spec) then if Lock_Free_Active then New_Op_Body := @@ -8531,68 +8552,67 @@ package body Exp_Ch9 is Current_Node := New_Op_Body; Analyze (New_Op_Body); - -- When the original protected body has nested subprograms, - -- the new body also has them, so set the flag accordingly - -- and reset the scopes of the top-level nested subprograms + New_Op_Spec := Corresponding_Spec (New_Op_Body); + + -- When the original subprogram body has nested subprograms, + -- the new body also has them, so set the flag accordingly. + + Set_Has_Nested_Subprogram + (New_Op_Spec, Has_Nested_Subprogram (New_Op_Spec)); + + -- Similarly, when the original subprogram body uses the + -- secondary stack, the new body also does. This is needed + -- when the cleanup actions of the subprogram are delayed + -- because it contains a package instance with a body. + + Set_Uses_Sec_Stack (New_Op_Spec, Uses_Sec_Stack (Op_Spec)); + + -- Now reset the scopes of the top-level nested subprograms -- and other declaration entities so that they now refer to - -- the new body's entity. (It would preferable to do this + -- the new body's entity (it would preferable to do this -- within Build_Protected_Sub_Specification, which is called -- from Build_Unprotected_Subprogram_Body, but the needed -- subprogram entity isn't available via Corresponding_Spec - -- until after the above Analyze call.) + -- until after the above Analyze call). - if Has_Nested_Subprogram (Corresponding_Spec (Op_Body)) then - Set_Has_Nested_Subprogram - (Corresponding_Spec (New_Op_Body)); - - Reset_Scopes_To - (New_Op_Body, Corresponding_Spec (New_Op_Body)); - end if; + Reset_Scopes_To (New_Op_Body, New_Op_Spec); -- Build the corresponding protected operation. This is -- needed only if this is a public or private operation of -- the type. - -- Why do we need to test for Corresponding_Spec being - -- present here when it's assumed to be set further above - -- in the Is_Eliminated test??? - - if Present (Corresponding_Spec (Op_Body)) then - Op_Decl := - Unit_Declaration_Node (Corresponding_Spec (Op_Body)); - - if Nkind (Parent (Op_Decl)) = N_Protected_Definition then - if Lock_Free_Active then - New_Op_Body := - Build_Lock_Free_Protected_Subprogram_Body - (Op_Body, Pid, Specification (New_Op_Body)); - else - New_Op_Body := - Build_Protected_Subprogram_Body ( - Op_Body, Pid, Specification (New_Op_Body)); - end if; - - Insert_After (Current_Node, New_Op_Body); - Analyze (New_Op_Body); - Current_Node := New_Op_Body; - - -- Generate an overriding primitive operation body for - -- this subprogram if the protected type implements - -- an interface. - - if Ada_Version >= Ada_2005 - and then Present (Interfaces ( - Corresponding_Record_Type (Pid))) - then - Disp_Op_Body := - Build_Dispatching_Subprogram_Body ( - Op_Body, Pid, New_Op_Body); - - Insert_After (Current_Node, Disp_Op_Body); - Analyze (Disp_Op_Body); - - Current_Node := Disp_Op_Body; - end if; + Op_Decl := Unit_Declaration_Node (Op_Spec); + + if Nkind (Parent (Op_Decl)) = N_Protected_Definition then + if Lock_Free_Active then + New_Op_Body := + Build_Lock_Free_Protected_Subprogram_Body + (Op_Body, Pid, Specification (New_Op_Body)); + else + New_Op_Body := + Build_Protected_Subprogram_Body + (Op_Body, Pid, Specification (New_Op_Body)); + end if; + + Insert_After (Current_Node, New_Op_Body); + Current_Node := New_Op_Body; + Analyze (New_Op_Body); + + -- Generate an overriding primitive operation body for + -- this subprogram if the protected type implements + -- an interface. + + if Ada_Version >= Ada_2005 + and then + Present (Interfaces (Corresponding_Record_Type (Pid))) + then + Disp_Op_Body := + Build_Dispatching_Subprogram_Body ( + Op_Body, Pid, New_Op_Body); + + Insert_After (Current_Node, Disp_Op_Body); + Current_Node := Disp_Op_Body; + Analyze (Disp_Op_Body); end if; end if; end if; @@ -9220,7 +9240,7 @@ package body Exp_Ch9 is declare Entry_Count_Expr : constant Node_Id := Build_Entry_Count_Expression - (Prot_Typ, Cdecls, Loc); + (Prot_Typ, Loc); Num_Attach_Handler : Nat := 0; Protection_Subtype : Node_Id; Ritem : Node_Id; @@ -14204,7 +14224,7 @@ package body Exp_Ch9 is Tdec : Node_Id; Tdef : Node_Id; Tnam : Name_Id; - Ttyp : Node_Id; + Ttyp : Entity_Id; begin Ttyp := Corresponding_Concurrent_Type (Task_Rec); @@ -14425,14 +14445,7 @@ package body Exp_Ch9 is -- where a,b... are the entry family names for the task definition - Ecount := - Build_Entry_Count_Expression - (Ttyp, - Component_Items - (Component_List - (Type_Definition - (Parent (Corresponding_Record_Type (Ttyp))))), - Loc); + Ecount := Build_Entry_Count_Expression (Ttyp, Loc); Append_To (Args, Ecount); -- Master parameter. This is a reference to the _Master parameter of diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index 7970b79..9381cee 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -1040,10 +1040,11 @@ package body Exp_Disp is -- Ada 2005 (AI-251): Abstract interface class-wide type - elsif Is_Interface (Ctrl_Typ) - and then Is_Class_Wide_Type (Ctrl_Typ) - then - Controlling_Tag := Duplicate_Subexpr (Ctrl_Arg); + elsif Is_Interface (Ctrl_Typ) and then Is_Class_Wide_Type (Ctrl_Typ) then + Controlling_Tag := + Make_Attribute_Reference (Loc, + Prefix => Duplicate_Subexpr (Ctrl_Arg), + Attribute_Name => Name_Tag); elsif Is_Access_Type (Ctrl_Typ) then Controlling_Tag := @@ -1132,18 +1133,36 @@ package body Exp_Disp is Set_SCIL_Controlling_Tag (SCIL_Node, Parent (Entity (Prefix (Controlling_Tag)))); - -- For a direct reference of the tag of the type the SCIL node - -- references the internal object declaration containing the tag - -- of the type. + -- Depending on whether a dereference is involved, the SCIL node + -- references the corresponding object/parameter declaration or + -- the internal object declaration containing the tag of the type. elsif Nkind (Controlling_Tag) = N_Attribute_Reference and then Attribute_Name (Controlling_Tag) = Name_Tag then - Set_SCIL_Controlling_Tag (SCIL_Node, - Parent - (Node - (First_Elmt - (Access_Disp_Table (Entity (Prefix (Controlling_Tag))))))); + declare + Prefix_Node : constant Node_Id := Prefix (Controlling_Tag); + Ent : constant Entity_Id := Entity + (if Nkind (Prefix_Node) = N_Explicit_Dereference then + Prefix (Prefix_Node) + else + Prefix_Node); + + begin + if Ekind (Ent) in E_Record_Type + | E_Record_Subtype + | E_Record_Type_With_Private + then + Set_SCIL_Controlling_Tag (SCIL_Node, + Parent + (Node + (First_Elmt + (Access_Disp_Table (Ent))))); + + else + Set_SCIL_Controlling_Tag (SCIL_Node, Parent (Ent)); + end if; + end; -- Interfaces are not supported. For now we leave the SCIL node -- decorated with the Controlling_Tag. More work needed here??? @@ -1222,9 +1241,93 @@ package body Exp_Disp is --------------------------------- procedure Expand_Interface_Conversion (N : Node_Id) is + + function Has_Dispatching_Constructor_Call + (Expr : Node_Id) return Boolean; + -- Determines if the expression has a dispatching constructor call + function Underlying_Record_Type (Typ : Entity_Id) return Entity_Id; -- Return the underlying record type of Typ + -------------------------------------- + -- Has_Dispatching_Constructor_Call -- + -------------------------------------- + + function Has_Dispatching_Constructor_Call (Expr : Node_Id) return Boolean + is + function Is_Dispatching_Constructor_Call (N : Node_Id) return Boolean; + -- Determines if N is a dispatching constructor call + + function Process (Nod : Node_Id) return Traverse_Result; + -- Traverse the expression searching for constructor calls + + ------------------------------------- + -- Is_Dispatching_Constructor_Call -- + ------------------------------------- + + function Is_Dispatching_Constructor_Call (N : Node_Id) return Boolean + is + Param : Node_Id; + Param_Type : Entity_Id; + Assoc_Node : Node_Id; + Gen_Func_Id : Entity_Id; + + begin + if Nkind (N) = N_Function_Call + and then Present (Parameter_Associations (N)) + then + Param := First (Parameter_Associations (N)); + + if Nkind (Param) = N_Parameter_Association then + Param := Selector_Name (Param); + end if; + + Param_Type := Etype (Param); + + if Is_Itype (Param_Type) then + Assoc_Node := Associated_Node_For_Itype (Param_Type); + + if Nkind (Assoc_Node) = N_Function_Specification + and then Present (Generic_Parent (Assoc_Node)) + then + Gen_Func_Id := Generic_Parent (Assoc_Node); + + if Is_Intrinsic_Subprogram (Gen_Func_Id) + and then Chars (Gen_Func_Id) + = Name_Generic_Dispatching_Constructor + then + return True; + end if; + end if; + end if; + end if; + + return False; + end Is_Dispatching_Constructor_Call; + + ------------- + -- Process -- + ------------- + + function Process (Nod : Node_Id) return Traverse_Result is + begin + if Nkind (Nod) = N_Function_Call + and then Is_Dispatching_Constructor_Call (Nod) + then + return Abandon; + end if; + + return OK; + end Process; + + function Traverse_Expression is new Traverse_Func (Process); + + -- Start of processing for Has_Dispatching_Constructor_Call + + begin + return Traverse_Expression (Expr) = Abandon; + end Has_Dispatching_Constructor_Call; + ---------------------------- -- Underlying_Record_Type -- ---------------------------- @@ -1327,16 +1430,16 @@ package body Exp_Disp is -- object to reference the corresponding secondary dispatch table -- (cf. Make_DT and Expand_Dispatching_Constructor_Call)). - -- At this stage we cannot identify whether the underlying object is - -- a BIP object and hence we cannot skip generating the code to try - -- displacing the pointer to the object. However, under configurable - -- runtime it is safe to skip generating code to displace the pointer - -- to the object, because generic dispatching constructors are not - -- supported. + -- Under regular runtime this is a minor optimization that improves + -- the generated code; under configurable runtime (where generic + -- dispatching constructors are not supported) this optimization + -- allows supporting this interface conversion, which otherwise + -- would require calling the runtime routine to displace the + -- pointer to the object. elsif Is_Interface (Iface_Typ) and then Is_Ancestor (Iface_Typ, Opnd, Use_Full_View => True) - and then not RTE_Available (RE_Displace) + and then not Has_Dispatching_Constructor_Call (Operand) then return; end if; @@ -1946,8 +2049,8 @@ package body Exp_Disp is then -- Generate: -- type T is access all <<type of the target formal>> - -- S : Storage_Offset := Storage_Offset!(Formal) - -- + Offset_To_Top (address!(Formal)) + -- S : constant Address := Address!(Formal) + -- + Offset_To_Top (Address!(Formal)) Decl_2 := Make_Full_Type_Declaration (Loc, @@ -1979,16 +2082,20 @@ package body Exp_Disp is Defining_Identifier => Make_Temporary (Loc, 'S'), Constant_Present => True, Object_Definition => - New_Occurrence_Of (RTE (RE_Storage_Offset), Loc), + New_Occurrence_Of (RTE (RE_Address), Loc), Expression => - Make_Op_Add (Loc, - Left_Opnd => - Unchecked_Convert_To - (RTE (RE_Storage_Offset), - New_Occurrence_Of - (Defining_Identifier (Formal), Loc)), - Right_Opnd => - Offset_To_Top)); + Make_Function_Call (Loc, + Name => + Make_Expanded_Name (Loc, + Chars => Name_Op_Add, + Prefix => + New_Occurrence_Of + (RTU_Entity (System_Storage_Elements), Loc), + Selector_Name => + Make_Identifier (Loc, Name_Op_Add)), + Parameter_Associations => New_List ( + New_Copy_Tree (New_Arg), + Offset_To_Top))); Append_To (Decl, Decl_2); Append_To (Decl, Decl_1); @@ -2004,16 +2111,15 @@ package body Exp_Disp is elsif Is_Controlling_Formal (Target_Formal) then -- Generate: - -- S1 : Storage_Offset := Storage_Offset!(Formal'Address) - -- + Offset_To_Top (Formal'Address) - -- S2 : Addr_Ptr := Addr_Ptr!(S1) + -- S1 : constant Address := Formal'Address + -- + Offset_To_Top (Formal'Address) + -- S2 : constant Addr_Ptr := Addr_Ptr!(S1) New_Arg := Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Defining_Identifier (Formal), Loc), - Attribute_Name => - Name_Address); + Attribute_Name => Name_Address); if not RTE_Available (RE_Offset_To_Top) then Offset_To_Top := @@ -2030,19 +2136,20 @@ package body Exp_Disp is Defining_Identifier => Make_Temporary (Loc, 'S'), Constant_Present => True, Object_Definition => - New_Occurrence_Of (RTE (RE_Storage_Offset), Loc), + New_Occurrence_Of (RTE (RE_Address), Loc), Expression => - Make_Op_Add (Loc, - Left_Opnd => - Unchecked_Convert_To - (RTE (RE_Storage_Offset), - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of - (Defining_Identifier (Formal), Loc), - Attribute_Name => Name_Address)), - Right_Opnd => - Offset_To_Top)); + Make_Function_Call (Loc, + Name => + Make_Expanded_Name (Loc, + Chars => Name_Op_Add, + Prefix => + New_Occurrence_Of + (RTU_Entity (System_Storage_Elements), Loc), + Selector_Name => + Make_Identifier (Loc, Name_Op_Add)), + Parameter_Associations => New_List ( + New_Copy_Tree (New_Arg), + Offset_To_Top))); Decl_2 := Make_Object_Declaration (Loc, @@ -2648,7 +2755,7 @@ package body Exp_Disp is Def_Id : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uDisp_Asynchronous_Select); - Params : constant List_Id := New_List; + Params : List_Id; begin pragma Assert (not Restriction_Active (No_Dispatching_Calls)); @@ -2663,7 +2770,7 @@ package body Exp_Disp is Set_Warnings_Off (B_Id); - Append_List_To (Params, New_List ( + Params := New_List ( Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_uT), @@ -2688,7 +2795,7 @@ package body Exp_Disp is Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_uF), Parameter_Type => New_Occurrence_Of (Standard_Boolean, Loc), - Out_Present => True))); + Out_Present => True)); return Make_Procedure_Specification (Loc, diff --git a/gcc/ada/exp_dist.adb b/gcc/ada/exp_dist.adb index 7805f74..f025b56 100644 --- a/gcc/ada/exp_dist.adb +++ b/gcc/ada/exp_dist.adb @@ -3118,8 +3118,8 @@ package body Exp_Dist is -- Start of processing for Add_RACW_Read_Attribute begin - Build_Stream_Procedure (Loc, - RACW_Type, Body_Node, Pnam, Statements, Outp => True); + Build_Stream_Procedure + (RACW_Type, Body_Node, Pnam, Statements, Outp => True); Proc_Decl := Make_Subprogram_Declaration (Loc, Copy_Specification (Loc, Specification (Body_Node))); @@ -3354,7 +3354,7 @@ package body Exp_Dist is begin Build_Stream_Procedure - (Loc, RACW_Type, Body_Node, Pnam, Statements, Outp => False); + (RACW_Type, Body_Node, Pnam, Statements, Outp => False); Proc_Decl := Make_Subprogram_Declaration (Loc, Copy_Specification (Loc, Specification (Body_Node))); @@ -5800,7 +5800,7 @@ package body Exp_Dist is begin Build_Stream_Procedure - (Loc, RACW_Type, Body_Node, Pnam, Statements, Outp => True); + (RACW_Type, Body_Node, Pnam, Statements, Outp => True); Proc_Decl := Make_Subprogram_Declaration (Loc, Copy_Specification (Loc, Specification (Body_Node))); @@ -6103,7 +6103,7 @@ package body Exp_Dist is begin Build_Stream_Procedure - (Loc, RACW_Type, Body_Node, Pnam, Statements, Outp => False); + (RACW_Type, Body_Node, Pnam, Statements, Outp => False); Proc_Decl := Make_Subprogram_Declaration (Loc, @@ -8304,7 +8304,7 @@ package body Exp_Dist is CI := Component_Items (Clist); VP := Variant_Part (Clist); - Item := First (CI); + Item := First_Non_Pragma (CI); while Present (Item) loop Def := Defining_Identifier (Item); @@ -8313,7 +8313,7 @@ package body Exp_Dist is (Stmts, Container, Counter, Rec, Def); end if; - Next (Item); + Next_Non_Pragma (Item); end loop; if Present (VP) then diff --git a/gcc/ada/exp_fixd.adb b/gcc/ada/exp_fixd.adb index 61c2f92..b7a996a 100644 --- a/gcc/ada/exp_fixd.adb +++ b/gcc/ada/exp_fixd.adb @@ -25,6 +25,7 @@ with Atree; use Atree; with Checks; use Checks; +with Debug; use Debug; with Einfo; use Einfo; with Einfo.Entities; use Einfo.Entities; with Einfo.Utils; use Einfo.Utils; @@ -1624,13 +1625,14 @@ package body Exp_Fixd is -- Fall through to use floating-point for the close result set case, -- as a result of the numerator or denominator of the small ratio not - -- being a sufficiently small integer. + -- being sufficiently small. See also Expand_Convert_Float_To_Fixed. Set_Result (N, Build_Multiply (N, Fpt_Value (Expr), Real_Literal (N, Small_Ratio)), - Rng_Check); + Rng_Check, + Trunc => not Rounded_Result (N)); end Expand_Convert_Fixed_To_Fixed; ----------------------------------- @@ -1769,23 +1771,23 @@ package body Exp_Fixd is if Small = Ureal_1 then Set_Result (N, Expr, Rng_Check, Trunc => True); - -- Normal case where multiply is required. Rounding is truncating - -- for decimal fixed point types only, see RM 4.6(29), except if the - -- conversion comes from an attribute reference 'Round (RM 3.5.10 (14)): - -- The attribute is implemented by means of a conversion that must - -- round. + -- Normal case where multiply is required. The conversion is truncating + -- for fixed-point types, see RM 4.6(29), except if the conversion comes + -- from an attribute reference 'Round (RM 3.5.10 (14)): the attribute is + -- implemented by means of a conversion that needs to round. However, if + -- the switch -gnatd.N is specified, we use rounding for ordinary fixed- + -- point types, for compatibility with earlier versions of the compiler. else - Set_Result - (N => N, - Expr => - Build_Multiply - (N => N, - L => Fpt_Value (Expr), - R => Real_Literal (N, Ureal_1 / Small)), - Rchk => Rng_Check, - Trunc => Is_Decimal_Fixed_Point_Type (Result_Type) - and not Rounded_Result (N)); + Set_Result (N, + Build_Multiply (N, + L => Fpt_Value (Expr), + R => Real_Literal (N, Ureal_1 / Small)), + Rchk => Rng_Check, + Trunc => not Rounded_Result (N) + and then not + (Debug_Flag_Dot_NN + and then Is_Ordinary_Fixed_Point_Type (Result_Type))); end if; end Expand_Convert_Float_To_Fixed; @@ -1852,13 +1854,14 @@ package body Exp_Fixd is -- Fall through to use floating-point for the close result set case, -- as a result of the numerator or denominator of the small value not - -- being a sufficiently small integer. + -- being sufficiently small. See also Expand_Convert_Float_To_Fixed. Set_Result (N, Build_Multiply (N, Fpt_Value (Expr), Real_Literal (N, Ureal_1 / Small)), - Rng_Check); + Rng_Check, + Trunc => not Rounded_Result (N)); end Expand_Convert_Integer_To_Fixed; -------------------------------- diff --git a/gcc/ada/exp_imgv.adb b/gcc/ada/exp_imgv.adb index 93fdb70..a31ce1d 100644 --- a/gcc/ada/exp_imgv.adb +++ b/gcc/ada/exp_imgv.adb @@ -762,7 +762,7 @@ package body Exp_Imgv is -- Snn (1 .. Pnn) then occurs as in the other cases. A special case is -- when pragma Discard_Names applies, in which case we replace expr by: - -- (rt'Pos (expr))'Img + -- (rt'Pos (expr))'Image -- So that the result is a space followed by the decimal value for the -- position of the enumeration value in the enumeration type. @@ -1211,8 +1211,8 @@ package body Exp_Imgv is or else No (Lit_Strings (Rtyp)) then -- When pragma Discard_Names applies to the first subtype, build - -- (Long_Long_Integer (Pref'Pos (Expr)))'Img. The conversion is - -- there to avoid applying 'Img directly in Universal_Integer, + -- (Long_Long_Integer (Pref'Pos (Expr)))'Image. The conversion is + -- there to avoid applying 'Image directly in Universal_Integer, -- which can be a very large type. See also the handling of 'Val. Rewrite (N, @@ -1223,8 +1223,7 @@ package body Exp_Imgv is Prefix => Pref, Attribute_Name => Name_Pos, Expressions => New_List (Expr))), - Attribute_Name => - Name_Img)); + Attribute_Name => Name_Image)); Analyze_And_Resolve (N, Standard_String); return; @@ -2498,12 +2497,31 @@ package body Exp_Imgv is Attr_Name : Name_Id; Str_Typ : Entity_Id) is + Ptyp : Entity_Id; + begin + Ptyp := Etype (Pref); + + -- If the prefix is a component that depends on a discriminant, then + -- create an actual subtype for it. + + if Nkind (Pref) = N_Selected_Component then + declare + Decl : constant Node_Id := + Build_Actual_Subtype_Of_Component (Ptyp, Pref); + begin + if Present (Decl) then + Insert_Action (N, Decl); + Ptyp := Defining_Identifier (Decl); + end if; + end; + end if; + Rewrite (N, Make_Attribute_Reference (Sloc (N), - Prefix => New_Occurrence_Of (Etype (Pref), Sloc (N)), + Prefix => New_Occurrence_Of (Ptyp, Sloc (N)), Attribute_Name => Attr_Name, - Expressions => New_List (Relocate_Node (Pref)))); + Expressions => New_List (Unchecked_Convert_To (Ptyp, Pref)))); Analyze_And_Resolve (N, Str_Typ); end Rewrite_Object_Image; diff --git a/gcc/ada/exp_intr.adb b/gcc/ada/exp_intr.adb index a1e5588..2eee892 100644 --- a/gcc/ada/exp_intr.adb +++ b/gcc/ada/exp_intr.adb @@ -102,6 +102,12 @@ package body Exp_Intr is -- N_Free_Statement and appropriate context. procedure Expand_To_Address (N : Node_Id); + -- Expand a call to corresponding function from System.Storage_Elements or + -- declared in an instance of System.Address_To_Access_Conversions. + + procedure Expand_To_Integer (N : Node_Id); + -- Expand a call to corresponding function from System.Storage_Elements + procedure Expand_To_Pointer (N : Node_Id); -- Expand a call to corresponding function, declared in an instance of -- System.Address_To_Access_Conversions. @@ -708,6 +714,9 @@ package body Exp_Intr is elsif Nam = Name_To_Address then Expand_To_Address (N); + elsif Nam = Name_To_Integer then + Expand_To_Integer (N); + elsif Nam = Name_To_Pointer then Expand_To_Pointer (N); @@ -1356,6 +1365,12 @@ package body Exp_Intr is Obj : Node_Id; begin + if Is_Modular_Integer_Type (Etype (Arg)) then + Rewrite (N, Unchecked_Convert_To (Etype (N), Arg)); + Analyze (N); + return; + end if; + Remove_Side_Effects (Arg); Obj := Make_Explicit_Dereference (Loc, Relocate_Node (Arg)); @@ -1375,6 +1390,18 @@ package body Exp_Intr is end Expand_To_Address; ----------------------- + -- Expand_To_Integer -- + ----------------------- + + procedure Expand_To_Integer (N : Node_Id) is + Arg : constant Node_Id := First_Actual (N); + + begin + Rewrite (N, Unchecked_Convert_To (Etype (N), Arg)); + Analyze (N); + end Expand_To_Integer; + + ----------------------- -- Expand_To_Pointer -- ----------------------- diff --git a/gcc/ada/exp_prag.adb b/gcc/ada/exp_prag.adb index ceb27848..1cc4653 100644 --- a/gcc/ada/exp_prag.adb +++ b/gcc/ada/exp_prag.adb @@ -269,6 +269,16 @@ package body Exp_Prag is end; end Expand_Pragma_Abort_Defer; + ------------------------------------- + -- Expand_Pragma_Always_Terminates -- + ------------------------------------- + + procedure Expand_Pragma_Always_Terminates (Prag : Node_Id) is + pragma Unreferenced (Prag); + begin + null; + end Expand_Pragma_Always_Terminates; + -------------------------- -- Expand_Pragma_Check -- -------------------------- @@ -564,6 +574,13 @@ package body Exp_Prag is then null; + -- For Subprogram_Variant suppress the warning altogether, because + -- for mutually recursive subprograms with multiple variant clauses + -- some of the clauses might have expressions that are only meant for + -- verification and would always fail when executed. + + elsif Nam = Name_Subprogram_Variant then + null; elsif Nam = Name_Assert then Error_Msg_N ("?.a?assertion will fail at run time", N); else @@ -1971,6 +1988,47 @@ package body Exp_Prag is In_Assertion_Expr := In_Assertion_Expr - 1; end Expand_Pragma_Contract_Cases; + ------------------------------------- + -- Expand_Pragma_Exceptional_Cases -- + ------------------------------------- + + -- Aspect Exceptional_Cases shoule be expanded in the following manner: + + -- Original declaration + + -- procedure P (...) with + -- Exceptional_Cases => + -- (Exp_1 => True, + -- Exp_2 => Post_4); + + -- Expanded body + + -- procedure P (...) is + -- begin + -- -- normal body of of P + -- declare + -- ... + -- end; + -- + -- exception + -- when Exp1 => + -- pragma Assert (True); + -- raise; + -- when E : Exp2 => + -- pragma Assert (Post_4); + -- raise; + -- when others => + -- pragma Assert (False); + -- raise; + -- end P; + + procedure Expand_Pragma_Exceptional_Cases (Prag : Node_Id) is + begin + -- Currently we don't expand this pragma + + Rewrite (Prag, Make_Null_Statement (Sloc (Prag))); + end Expand_Pragma_Exceptional_Cases; + --------------------------------------- -- Expand_Pragma_Import_Or_Interface -- --------------------------------------- diff --git a/gcc/ada/exp_prag.ads b/gcc/ada/exp_prag.ads index 27c537c..10ccaf7 100644 --- a/gcc/ada/exp_prag.ads +++ b/gcc/ada/exp_prag.ads @@ -31,6 +31,10 @@ package Exp_Prag is procedure Expand_N_Pragma (N : Node_Id); + procedure Expand_Pragma_Always_Terminates (Prag : Node_Id); + -- This routine only exists for consistency with other pragmas, since + -- Always_Terminates has no meaningful expansion. + procedure Expand_Pragma_Contract_Cases (CCs : Node_Id; Subp_Id : Entity_Id; @@ -42,6 +46,10 @@ package Exp_Prag is -- Subp_Id's body. All generated code is added to list Stmts. If Stmts is -- No_List on entry, a new list is created. + procedure Expand_Pragma_Exceptional_Cases (Prag : Node_Id); + -- Given pragma Exceptional_Cases Prag, create the circuitry needed to + -- catch exceptions and evaluate consequence expressions. + procedure Expand_Pragma_Initial_Condition (Pack_Id : Entity_Id; N : Node_Id); diff --git a/gcc/ada/exp_put_image.adb b/gcc/ada/exp_put_image.adb index 19e0415..9eda323 100644 --- a/gcc/ada/exp_put_image.adb +++ b/gcc/ada/exp_put_image.adb @@ -814,7 +814,7 @@ package body Exp_Put_Image is -- Start of processing for Build_Record_Put_Image_Procedure begin - if (Ada_Version < Ada_2022) + if Ada_Version < Ada_2022 or else not Enable_Put_Image (Btyp) then -- generate a very simple Put_Image implementation @@ -1126,7 +1126,9 @@ package body Exp_Put_Image is -- Attribute names that will be mapped to the corresponding result types -- and functions. - Attribute_Name_Id : constant Name_Id := Attribute_Name (N); + Attribute_Name_Id : constant Name_Id := + (if Attribute_Name (N) = Name_Img then Name_Image + else Attribute_Name (N)); Result_Typ : constant Entity_Id := (case Image_Name_Id'(Attribute_Name_Id) is diff --git a/gcc/ada/exp_sel.adb b/gcc/ada/exp_sel.adb index 66019be..39ebb91 100644 --- a/gcc/ada/exp_sel.adb +++ b/gcc/ada/exp_sel.adb @@ -27,10 +27,8 @@ with Einfo; use Einfo; with Einfo.Entities; use Einfo.Entities; with Nlists; use Nlists; with Nmake; use Nmake; -with Opt; use Opt; with Rtsfind; use Rtsfind; -with Sinfo; use Sinfo; -with Sinfo.Nodes; use Sinfo.Nodes; +with Sem_Util; use Sem_Util; with Snames; use Snames; with Stand; use Stand; with Tbuild; use Tbuild; @@ -151,18 +149,12 @@ package body Exp_Sel is Obj : Entity_Id) return Entity_Id is K : constant Entity_Id := Make_Temporary (Loc, 'K'); - Tag_Node : Node_Id; + Tag_Node : constant Node_Id := + Make_Attribute_Reference (Loc, + Prefix => New_Copy_Tree (Obj), + Attribute_Name => Name_Tag); begin - if Tagged_Type_Expansion then - Tag_Node := Unchecked_Convert_To (RTE (RE_Tag), Obj); - else - Tag_Node := - Make_Attribute_Reference (Loc, - Prefix => Obj, - Attribute_Name => Name_Tag); - end if; - Append_To (Decls, Make_Object_Declaration (Loc, Defining_Identifier => K, @@ -172,6 +164,7 @@ package body Exp_Sel is Make_Function_Call (Loc, Name => New_Occurrence_Of (RTE (RE_Get_Tagged_Kind), Loc), Parameter_Associations => New_List (Tag_Node)))); + return K; end Build_K; @@ -202,48 +195,18 @@ package body Exp_Sel is Obj : Entity_Id; Call_Ent : Entity_Id) return Node_Id is - Typ : constant Entity_Id := Etype (Obj); - begin - if Tagged_Type_Expansion then - return - Make_Assignment_Statement (Loc, - Name => New_Occurrence_Of (S, Loc), - Expression => - Make_Function_Call (Loc, - Name => New_Occurrence_Of (RTE (RE_Get_Offset_Index), Loc), - Parameter_Associations => New_List ( - Unchecked_Convert_To (RTE (RE_Tag), Obj), - Make_Integer_Literal (Loc, DT_Position (Call_Ent))))); - - -- VM targets - - else - return - Make_Assignment_Statement (Loc, - Name => New_Occurrence_Of (S, Loc), - Expression => - Make_Function_Call (Loc, - Name => New_Occurrence_Of (RTE (RE_Get_Offset_Index), Loc), - - Parameter_Associations => New_List ( - - -- Obj_Typ - - Make_Attribute_Reference (Loc, - Prefix => Obj, - Attribute_Name => Name_Tag), - - -- Iface_Typ - - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Typ, Loc), - Attribute_Name => Name_Tag), - - -- Position - - Make_Integer_Literal (Loc, DT_Position (Call_Ent))))); - end if; + return + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (S, Loc), + Expression => + Make_Function_Call (Loc, + Name => New_Occurrence_Of (RTE (RE_Get_Offset_Index), Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Copy_Tree (Obj), + Attribute_Name => Name_Tag), + Make_Integer_Literal (Loc, DT_Position (Call_Ent))))); end Build_S_Assignment; end Exp_Sel; diff --git a/gcc/ada/exp_spark.adb b/gcc/ada/exp_spark.adb index efa5c2c..c344dc1 100644 --- a/gcc/ada/exp_spark.adb +++ b/gcc/ada/exp_spark.adb @@ -101,7 +101,7 @@ package body Exp_SPARK is -- expanded body would compare the _parent component, which is -- intentionally not generated in the GNATprove mode. -- - -- We build the DIC procedure body here as well. + -- We build the DIC and Type_Invariant procedure bodies here as well. ------------------ -- Expand_SPARK -- @@ -920,15 +920,53 @@ package body Exp_SPARK is Set_Ghost_Mode (Typ); - -- When a DIC is inherited by a tagged type, it may need to be - -- specialized to the descendant type, hence build a separate DIC - -- procedure for it as done during regular expansion for compilation. + -- Generate the [spec and] body of the invariant procedure tasked with + -- the runtime verification of all invariants that pertain to the type. + -- This includes invariants on the partial and full view, inherited + -- class-wide invariants from parent types or interfaces, and invariants + -- on array elements or record components. But skip internal types. - if Has_DIC (Typ) and then Is_Tagged_Type (Typ) then - -- Why is this needed for DIC, but not for other aspects (such as - -- Type_Invariant)??? + if Is_Itype (Typ) then + null; + + elsif Is_Interface (Typ) 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 + -- interface receives only a "partial" invariant procedure which is + -- never called. + + if Has_Own_Invariants (Typ) then + Build_Invariant_Procedure_Body + (Typ => Typ, + Partial_Invariant => Is_Interface (Typ)); + end if; + + -- Non-interface types - Build_DIC_Procedure_Body (Typ); + -- Do not generate invariant procedure within other assertion + -- subprograms, which may involve local declarations of local + -- subtypes to which these checks do not apply. + + else + if Has_Invariants (Typ) then + if not Predicate_Check_In_Scope (Typ) + or else (Ekind (Current_Scope) = E_Function + and then Is_Predicate_Function (Current_Scope)) + then + null; + else + Build_Invariant_Procedure_Body (Typ); + end if; + end if; + + -- Generate the [spec and] body of the procedure tasked with the + -- run-time verification of pragma Default_Initial_Condition's + -- expression. + + if Has_DIC (Typ) then + Build_DIC_Procedure_Body (Typ); + end if; end if; if Ekind (Typ) = E_Record_Type diff --git a/gcc/ada/exp_strm.adb b/gcc/ada/exp_strm.adb index 2610584..f1203ad 100644 --- a/gcc/ada/exp_strm.adb +++ b/gcc/ada/exp_strm.adb @@ -51,20 +51,17 @@ package body Exp_Strm is ----------------------- procedure Build_Array_Read_Write_Procedure - (Nod : Node_Id; - Typ : Entity_Id; + (Typ : Entity_Id; Decl : out Node_Id; Pnam : Entity_Id; Nam : Name_Id); -- Common routine shared to build either an array Read procedure or an -- array Write procedure, Nam is Name_Read or Name_Write to select which. -- Pnam is the defining identifier for the constructed procedure. The - -- other parameters are as for Build_Array_Read_Procedure except that - -- the first parameter Nod supplies the Sloc to be used to generate code. + -- other parameters are as for Build_Array_Read_Procedure. procedure Build_Record_Read_Write_Procedure - (Loc : Source_Ptr; - Typ : Entity_Id; + (Typ : Entity_Id; Decl : out Node_Id; Pnam : Entity_Id; Nam : Name_Id); @@ -74,8 +71,7 @@ package body Exp_Strm is -- as for Build_Record_Read_Procedure. procedure Build_Stream_Function - (Loc : Source_Ptr; - Typ : Entity_Id; + (Typ : Entity_Id; Decl : out Node_Id; Fnam : Entity_Id; Decls : List_Id; @@ -140,11 +136,11 @@ package body Exp_Strm is -- reference, so the name must be unique. procedure Build_Array_Input_Function - (Loc : Source_Ptr; - Typ : Entity_Id; + (Typ : Entity_Id; Decl : out Node_Id; Fnam : out Entity_Id) is + Loc : constant Source_Ptr := Sloc (Typ); Dim : constant Pos := Number_Dimensions (Typ); Lnam : Name_Id; Hnam : Name_Id; @@ -235,7 +231,7 @@ package body Exp_Strm is Make_Defining_Identifier (Loc, Chars => Make_TSS_Name_Local (Typ, TSS_Stream_Input)); - Build_Stream_Function (Loc, Typ, Decl, Fnam, Decls, Stms); + Build_Stream_Function (Typ, Decl, Fnam, Decls, Stms); end Build_Array_Input_Function; ---------------------------------- @@ -243,11 +239,11 @@ package body Exp_Strm is ---------------------------------- procedure Build_Array_Output_Procedure - (Loc : Source_Ptr; - Typ : Entity_Id; + (Typ : Entity_Id; Decl : out Node_Id; Pnam : out Entity_Id) is + Loc : constant Source_Ptr := Sloc (Typ); Stms : List_Id; Indx : Node_Id; @@ -301,7 +297,7 @@ package body Exp_Strm is Make_Defining_Identifier (Loc, Chars => Make_TSS_Name_Local (Typ, TSS_Stream_Output)); - Build_Stream_Procedure (Loc, Typ, Decl, Pnam, Stms, Outp => False); + Build_Stream_Procedure (Typ, Decl, Pnam, Stms, Outp => False); end Build_Array_Output_Procedure; -------------------------------- @@ -309,18 +305,17 @@ package body Exp_Strm is -------------------------------- procedure Build_Array_Read_Procedure - (Nod : Node_Id; - Typ : Entity_Id; + (Typ : Entity_Id; Decl : out Node_Id; Pnam : out Entity_Id) is - Loc : constant Source_Ptr := Sloc (Nod); + Loc : constant Source_Ptr := Sloc (Typ); begin Pnam := Make_Defining_Identifier (Loc, Chars => Make_TSS_Name_Local (Typ, TSS_Stream_Read)); - Build_Array_Read_Write_Procedure (Nod, Typ, Decl, Pnam, Name_Read); + Build_Array_Read_Write_Procedure (Typ, Decl, Pnam, Name_Read); end Build_Array_Read_Procedure; -------------------------------------- @@ -345,13 +340,12 @@ package body Exp_Strm is -- The out keyword for V is supplied in the Read case procedure Build_Array_Read_Write_Procedure - (Nod : Node_Id; - Typ : Entity_Id; + (Typ : Entity_Id; Decl : out Node_Id; Pnam : Entity_Id; Nam : Name_Id) is - Loc : constant Source_Ptr := Sloc (Nod); + Loc : constant Source_Ptr := Sloc (Typ); Ndim : constant Pos := Number_Dimensions (Typ); Ctyp : constant Entity_Id := Component_Type (Typ); @@ -402,7 +396,7 @@ package body Exp_Strm is for J in 1 .. Ndim loop Stm := - Make_Implicit_Loop_Statement (Nod, + Make_Implicit_Loop_Statement (Typ, Iteration_Scheme => Make_Iteration_Scheme (Loc, Loop_Parameter_Specification => @@ -424,7 +418,7 @@ package body Exp_Strm is end loop; Build_Stream_Procedure - (Loc, Typ, Decl, Pnam, New_List (Stm), Outp => Nam = Name_Read); + (Typ, Decl, Pnam, New_List (Stm), Outp => Nam = Name_Read); end Build_Array_Read_Write_Procedure; --------------------------------- @@ -432,17 +426,16 @@ package body Exp_Strm is --------------------------------- procedure Build_Array_Write_Procedure - (Nod : Node_Id; - Typ : Entity_Id; + (Typ : Entity_Id; Decl : out Node_Id; Pnam : out Entity_Id) is - Loc : constant Source_Ptr := Sloc (Nod); + Loc : constant Source_Ptr := Sloc (Typ); begin Pnam := Make_Defining_Identifier (Loc, Chars => Make_TSS_Name_Local (Typ, TSS_Stream_Write)); - Build_Array_Read_Write_Procedure (Nod, Typ, Decl, Pnam, Name_Write); + Build_Array_Read_Write_Procedure (Typ, Decl, Pnam, Name_Write); end Build_Array_Write_Procedure; --------------------------------- @@ -894,11 +887,12 @@ package body Exp_Strm is ----------------------------------------- procedure Build_Mutable_Record_Read_Procedure - (Loc : Source_Ptr; - Typ : Entity_Id; + (Typ : Entity_Id; Decl : out Node_Id; Pnam : out Entity_Id) is + Loc : constant Source_Ptr := Sloc (Typ); + Out_Formal : Node_Id; -- Expression denoting the out formal parameter @@ -951,7 +945,7 @@ package body Exp_Strm is Make_Raise_Program_Error (Loc, Reason => PE_Unchecked_Union_Restriction)); - Build_Stream_Procedure (Loc, Typ, Decl, Pnam, Stms, Outp => True); + Build_Stream_Procedure (Typ, Decl, Pnam, Stms, Outp => True); return; end if; @@ -1007,7 +1001,7 @@ package body Exp_Strm is -- Generate reads for the components of the record (including those -- that depend on discriminants). - Build_Record_Read_Write_Procedure (Loc, Typ, Decl, Pnam, Name_Read); + Build_Record_Read_Write_Procedure (Typ, Decl, Pnam, Name_Read); -- Save original statement sequence for component assignments, and -- replace it with Stms. @@ -1066,11 +1060,11 @@ package body Exp_Strm is ------------------------------------------ procedure Build_Mutable_Record_Write_Procedure - (Loc : Source_Ptr; - Typ : Entity_Id; + (Typ : Entity_Id; Decl : out Node_Id; Pnam : out Entity_Id) is + Loc : constant Source_Ptr := Sloc (Typ); Stms : List_Id; Disc : Entity_Id; D_Ref : Node_Id; @@ -1111,7 +1105,7 @@ package body Exp_Strm is Pnam := Make_Defining_Identifier (Loc, Chars => Make_TSS_Name_Local (Typ, TSS_Stream_Write)); - Build_Record_Read_Write_Procedure (Loc, Typ, Decl, Pnam, Name_Write); + Build_Record_Read_Write_Procedure (Typ, Decl, Pnam, Name_Write); -- Write the discriminants before the rest of the components, so -- that discriminant values are properly set of variants, etc. @@ -1152,11 +1146,11 @@ package body Exp_Strm is -- an elementary type, then no Cn constants are defined. procedure Build_Record_Or_Elementary_Input_Function - (Loc : Source_Ptr; - Typ : Entity_Id; + (Typ : Entity_Id; Decl : out Node_Id; Fnam : out Entity_Id) is + Loc : constant Source_Ptr := Sloc (Typ); B_Typ : constant Entity_Id := Underlying_Type (Base_Type (Typ)); Cn : Name_Id; Constr : List_Id; @@ -1288,7 +1282,7 @@ package body Exp_Strm is Fnam := Make_Stream_Subprogram_Name (Loc, B_Typ, TSS_Stream_Input); - Build_Stream_Function (Loc, B_Typ, Decl, Fnam, Decls, Stms); + Build_Stream_Function (B_Typ, Decl, Fnam, Decls, Stms); end Build_Record_Or_Elementary_Input_Function; ------------------------------------------------- @@ -1296,11 +1290,11 @@ package body Exp_Strm is ------------------------------------------------- procedure Build_Record_Or_Elementary_Output_Procedure - (Loc : Source_Ptr; - Typ : Entity_Id; + (Typ : Entity_Id; Decl : out Node_Id; Pnam : out Entity_Id) is + Loc : constant Source_Ptr := Sloc (Typ); Stms : List_Id; Disc : Entity_Id; Disc_Ref : Node_Id; @@ -1356,7 +1350,7 @@ package body Exp_Strm is Pnam := Make_Stream_Subprogram_Name (Loc, Typ, TSS_Stream_Output); - Build_Stream_Procedure (Loc, Typ, Decl, Pnam, Stms, Outp => False); + Build_Stream_Procedure (Typ, Decl, Pnam, Stms, Outp => False); end Build_Record_Or_Elementary_Output_Procedure; --------------------------------- @@ -1364,14 +1358,14 @@ package body Exp_Strm is --------------------------------- procedure Build_Record_Read_Procedure - (Loc : Source_Ptr; - Typ : Entity_Id; + (Typ : Entity_Id; Decl : out Node_Id; Pnam : out Entity_Id) is + Loc : constant Source_Ptr := Sloc (Typ); begin Pnam := Make_Stream_Subprogram_Name (Loc, Typ, TSS_Stream_Read); - Build_Record_Read_Write_Procedure (Loc, Typ, Decl, Pnam, Name_Read); + Build_Record_Read_Write_Procedure (Typ, Decl, Pnam, Name_Read); end Build_Record_Read_Procedure; --------------------------------------- @@ -1407,12 +1401,12 @@ package body Exp_Strm is -- The out keyword for V is supplied in the Read case procedure Build_Record_Read_Write_Procedure - (Loc : Source_Ptr; - Typ : Entity_Id; + (Typ : Entity_Id; Decl : out Node_Id; Pnam : Entity_Id; Nam : Name_Id) is + Loc : constant Source_Ptr := Sloc (Typ); Rdef : Node_Id; Stms : List_Id; Typt : Entity_Id; @@ -1616,7 +1610,7 @@ package body Exp_Strm is end if; Build_Stream_Procedure - (Loc, Typ, Decl, Pnam, Stms, Outp => Nam = Name_Read); + (Typ, Decl, Pnam, Stms, Outp => Nam = Name_Read); end Build_Record_Read_Write_Procedure; ---------------------------------- @@ -1624,14 +1618,14 @@ package body Exp_Strm is ---------------------------------- procedure Build_Record_Write_Procedure - (Loc : Source_Ptr; - Typ : Entity_Id; + (Typ : Entity_Id; Decl : out Node_Id; Pnam : out Entity_Id) is + Loc : constant Source_Ptr := Sloc (Typ); begin Pnam := Make_Stream_Subprogram_Name (Loc, Typ, TSS_Stream_Write); - Build_Record_Read_Write_Procedure (Loc, Typ, Decl, Pnam, Name_Write); + Build_Record_Read_Write_Procedure (Typ, Decl, Pnam, Name_Write); end Build_Record_Write_Procedure; ------------------------------- @@ -1674,13 +1668,13 @@ package body Exp_Strm is --------------------------- procedure Build_Stream_Function - (Loc : Source_Ptr; - Typ : Entity_Id; + (Typ : Entity_Id; Decl : out Node_Id; Fnam : Entity_Id; Decls : List_Id; Stms : List_Id) is + Loc : constant Source_Ptr := Sloc (Typ); Spec : Node_Id; begin @@ -1719,13 +1713,13 @@ package body Exp_Strm is ---------------------------- procedure Build_Stream_Procedure - (Loc : Source_Ptr; - Typ : Entity_Id; + (Typ : Entity_Id; Decl : out Node_Id; Pnam : Entity_Id; Stms : List_Id; Outp : Boolean) is + Loc : constant Source_Ptr := Sloc (Typ); Spec : Node_Id; begin diff --git a/gcc/ada/exp_strm.ads b/gcc/ada/exp_strm.ads index e0d180a..d56a598 100644 --- a/gcc/ada/exp_strm.ads +++ b/gcc/ada/exp_strm.ads @@ -57,38 +57,31 @@ package Exp_Strm is -- results are the declaration and name (entity) of the subprogram. procedure Build_Array_Input_Function - (Loc : Source_Ptr; - Typ : Entity_Id; + (Typ : Entity_Id; Decl : out Node_Id; Fnam : out Entity_Id); -- Build function for Input attribute for array type procedure Build_Array_Output_Procedure - (Loc : Source_Ptr; - Typ : Entity_Id; + (Typ : Entity_Id; Decl : out Node_Id; Pnam : out Entity_Id); -- Build procedure for Output attribute for array type procedure Build_Array_Read_Procedure - (Nod : Node_Id; - Typ : Entity_Id; + (Typ : Entity_Id; Decl : out Node_Id; Pnam : out Entity_Id); - -- Build procedure for Read attribute for array type. Nod provides the - -- Sloc value for generated code. + -- Build procedure for Read attribute for array type. procedure Build_Array_Write_Procedure - (Nod : Node_Id; - Typ : Entity_Id; + (Typ : Entity_Id; Decl : out Node_Id; Pnam : out Entity_Id); - -- Build procedure for Write attribute for array type. Nod provides the - -- Sloc value for generated code. + -- Build procedure for Write attribute for array type. procedure Build_Mutable_Record_Read_Procedure - (Loc : Source_Ptr; - Typ : Entity_Id; + (Typ : Entity_Id; Decl : out Node_Id; Pnam : out Entity_Id); -- Build procedure to Read a record with default discriminants. @@ -96,8 +89,7 @@ package Exp_Strm is -- same manner as is done for 'Input. procedure Build_Mutable_Record_Write_Procedure - (Loc : Source_Ptr; - Typ : Entity_Id; + (Typ : Entity_Id; Decl : out Node_Id; Pnam : out Entity_Id); -- Build procedure to write a record with default discriminants. @@ -105,8 +97,7 @@ package Exp_Strm is -- the same manner as is done for 'Output. procedure Build_Record_Or_Elementary_Input_Function - (Loc : Source_Ptr; - Typ : Entity_Id; + (Typ : Entity_Id; Decl : out Node_Id; Fnam : out Entity_Id); -- Build function for Input attribute for record type or for an elementary @@ -115,8 +106,7 @@ package Exp_Strm is -- runtime library routine directly). procedure Build_Record_Or_Elementary_Output_Procedure - (Loc : Source_Ptr; - Typ : Entity_Id; + (Typ : Entity_Id; Decl : out Node_Id; Pnam : out Entity_Id); -- Build procedure for Output attribute for record type or for an @@ -125,22 +115,19 @@ package Exp_Strm is -- Output calls the appropriate runtime library routine directly. procedure Build_Record_Read_Procedure - (Loc : Source_Ptr; - Typ : Entity_Id; + (Typ : Entity_Id; Decl : out Node_Id; Pnam : out Entity_Id); -- Build procedure for Read attribute for record type procedure Build_Record_Write_Procedure - (Loc : Source_Ptr; - Typ : Entity_Id; + (Typ : Entity_Id; Decl : out Node_Id; Pnam : out Entity_Id); -- Build procedure for Write attribute for record type procedure Build_Stream_Procedure - (Loc : Source_Ptr; - Typ : Entity_Id; + (Typ : Entity_Id; Decl : out Node_Id; Pnam : Entity_Id; Stms : List_Id; diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 80c01bf..0d0ad8a 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -1853,7 +1853,15 @@ package body Exp_Util is begin pragma Assert (Present (DIC_Expr)); - Expr := New_Copy_Tree (DIC_Expr); + + -- We need to preanalyze the expression itself inside a generic to + -- be able to capture global references present in it. + + if Inside_A_Generic then + Expr := DIC_Expr; + else + Expr := New_Copy_Tree (DIC_Expr); + end if; -- Perform the following substitution: @@ -3111,7 +3119,14 @@ package body Exp_Util is return; end if; - Expr := New_Copy_Tree (Prag_Expr); + -- We need to preanalyze the expression itself inside a generic + -- to be able to capture global references present in it. + + if Inside_A_Generic then + Expr := Prag_Expr; + else + Expr := New_Copy_Tree (Prag_Expr); + end if; -- Substitute all references to type T with references to the -- _object formal parameter. @@ -4699,6 +4714,55 @@ package body Exp_Util is return Build_Task_Image_Function (Loc, Decls, Stats, Res); end Build_Task_Record_Image; + ---------------------------------------- + -- Build_Temporary_On_Secondary_Stack -- + ---------------------------------------- + + function Build_Temporary_On_Secondary_Stack + (Loc : Source_Ptr; + Typ : Entity_Id; + Code : List_Id) return Entity_Id + is + Acc_Typ : Entity_Id; + Alloc : Node_Id; + Alloc_Obj : Entity_Id; + + begin + pragma Assert (RTE_Available (RE_SS_Pool) + and then not Needs_Finalization (Typ)); + + Acc_Typ := Make_Temporary (Loc, 'A'); + Mutate_Ekind (Acc_Typ, E_Access_Type); + Set_Associated_Storage_Pool (Acc_Typ, RTE (RE_SS_Pool)); + + Append_To (Code, + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Acc_Typ, + Type_Definition => + Make_Access_To_Object_Definition (Loc, + All_Present => True, + Subtype_Indication => + New_Occurrence_Of (Typ, Loc)))); + + Alloc := + Make_Allocator (Loc, Expression => New_Occurrence_Of (Typ, Loc)); + Set_No_Initialization (Alloc); + + Alloc_Obj := Make_Temporary (Loc, 'R'); + + Append_To (Code, + Make_Object_Declaration (Loc, + Defining_Identifier => Alloc_Obj, + Constant_Present => True, + Object_Definition => + New_Occurrence_Of (Acc_Typ, Loc), + Expression => Alloc)); + + Set_Uses_Sec_Stack (Current_Scope); + + return Alloc_Obj; + end Build_Temporary_On_Secondary_Stack; + --------------------------------------- -- Build_Transient_Object_Statements -- --------------------------------------- @@ -7219,6 +7283,7 @@ package body Exp_Util is when N_Indexed_Component | N_Selected_Component | N_Aggregate + | N_Extension_Aggregate => return True; @@ -8274,6 +8339,13 @@ package body Exp_Util is function Is_Allocated (Trans_Id : Entity_Id) return Boolean; -- Determine whether transient object Trans_Id is allocated on the heap + function Is_Indexed_Container + (Trans_Id : Entity_Id; + First_Stmt : Node_Id) return Boolean; + -- Determine whether transient object Trans_Id denotes a container which + -- is in the process of being indexed in the statement list starting + -- from First_Stmt. + function Is_Iterated_Container (Trans_Id : Entity_Id; First_Stmt : Node_Id) return Boolean; @@ -8548,6 +8620,91 @@ package body Exp_Util is and then Nkind (Expr) = N_Allocator; end Is_Allocated; + -------------------------- + -- Is_Indexed_Container -- + -------------------------- + + function Is_Indexed_Container + (Trans_Id : Entity_Id; + First_Stmt : Node_Id) return Boolean + is + Aspect : Node_Id; + Call : Node_Id; + Index : Entity_Id; + Param : Node_Id; + Stmt : Node_Id; + Typ : Entity_Id; + + begin + -- It is not possible to iterate over containers in non-Ada 2012 code + + if Ada_Version < Ada_2012 then + return False; + end if; + + Typ := Etype (Trans_Id); + + -- Handle access type created for the reference below + + if Is_Access_Type (Typ) then + Typ := Designated_Type (Typ); + end if; + + -- Look for aspect Constant_Indexing. It may be part of a type + -- declaration for a container, or inherited from a base type + -- or parent type. + + Aspect := Find_Value_Of_Aspect (Typ, Aspect_Constant_Indexing); + + if Present (Aspect) then + Index := Entity (Aspect); + + -- Examine the statements following the container object and + -- look for a call to the default indexing routine where the + -- first parameter is the transient. Such a call appears as: + + -- It : Access_To_Constant_Reference_Type := + -- Constant_Indexing (Tran_Id.all, ...)'reference; + + Stmt := First_Stmt; + while Present (Stmt) loop + + -- Detect an object declaration which is initialized by a + -- controlled function call. + + if Nkind (Stmt) = N_Object_Declaration + and then Present (Expression (Stmt)) + and then Nkind (Expression (Stmt)) = N_Reference + and then Nkind (Prefix (Expression (Stmt))) = N_Function_Call + then + Call := Prefix (Expression (Stmt)); + + -- The call must invoke the default indexing routine of + -- the container and the transient object must appear as + -- the first actual parameter. Skip any calls whose names + -- are not entities. + + if Is_Entity_Name (Name (Call)) + and then Entity (Name (Call)) = Index + and then Present (Parameter_Associations (Call)) + then + Param := First (Parameter_Associations (Call)); + + if Nkind (Param) = N_Explicit_Dereference + and then Entity (Prefix (Param)) = Trans_Id + then + return True; + end if; + end if; + end if; + + Next (Stmt); + end loop; + end if; + + return False; + end Is_Indexed_Container; + --------------------------- -- Is_Iterated_Container -- --------------------------- @@ -8572,7 +8729,7 @@ package body Exp_Util is Typ := Etype (Trans_Id); - -- Handle access type created for secondary stack use + -- Handle access type created for the reference below if Is_Access_Type (Typ) then Typ := Designated_Type (Typ); @@ -8598,7 +8755,7 @@ package body Exp_Util is while Present (Stmt) loop -- Detect an object declaration which is initialized by a - -- secondary stack function call. + -- controlled function call. if Nkind (Stmt) = N_Object_Declaration and then Present (Expression (Stmt)) @@ -8717,7 +8874,11 @@ package body Exp_Util is -- transient objects must exist for as long as the loop is around, -- otherwise any operation carried out by the iterator will fail. - and then not Is_Iterated_Container (Obj_Id, Decl); + and then not Is_Iterated_Container (Obj_Id, Decl) + + -- Likewise for indexed containers in the context of iterator loops + + and then not Is_Indexed_Container (Obj_Id, Decl); end Is_Finalizable_Transient; --------------------------------- @@ -9945,6 +10106,8 @@ package body Exp_Util is -- Compute proper name to use, we need to get this right so that the -- right set of check policies apply to the Check pragma we are making. + -- The presence or not of a Ghost_Predicate does not influence the + -- choice of the applicable check policy. if Has_Dynamic_Predicate_Aspect (Typ) then Nam := Name_Dynamic_Predicate; @@ -10173,6 +10336,33 @@ package body Exp_Util is Constraints => List_Constr)); end Make_Subtype_From_Expr; + ----------------------------------- + -- Make_Tag_Assignment_From_Type -- + ----------------------------------- + + function Make_Tag_Assignment_From_Type + (Loc : Source_Ptr; + Target : Node_Id; + Typ : Entity_Id) return Node_Id + is + Nam : constant Node_Id := + Make_Selected_Component (Loc, + Prefix => Target, + Selector_Name => + New_Occurrence_Of (First_Tag_Component (Typ), Loc)); + + begin + Set_Assignment_OK (Nam); + + return + Make_Assignment_Statement (Loc, + Name => Nam, + Expression => + Unchecked_Convert_To (RTE (RE_Tag), + New_Occurrence_Of + (Node (First_Elmt (Access_Disp_Table (Typ))), Loc))); + end Make_Tag_Assignment_From_Type; + ----------------------------- -- Make_Variant_Comparison -- ----------------------------- @@ -11688,14 +11878,6 @@ package body Exp_Util is then return; - -- Nothing to do if prior expansion determined that a function call does - -- not require side effect removal. - - elsif Nkind (Exp) = N_Function_Call - and then No_Side_Effect_Removal (Exp) - then - return; - -- No action needed for side-effect free expressions elsif Check_Side_Effects @@ -14041,6 +14223,16 @@ package body Exp_Util is then return True; + -- Stop at contexts where temporaries may be contained + + elsif Nkind (Par) in N_Aggregate + | N_Delta_Aggregate + | N_Extension_Aggregate + | N_Block_Statement + | N_Loop_Statement + then + return False; + -- Prevent the search from going too far elsif Is_Body_Or_Package_Declaration (Par) then diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index 3dd10d7..02324d23 100644 --- a/gcc/ada/exp_util.ads +++ b/gcc/ada/exp_util.ads @@ -351,6 +351,18 @@ package Exp_Util is -- is false, the call is for a stand-alone object, and the generated -- function itself must do its own cleanups. + function Build_Temporary_On_Secondary_Stack + (Loc : Source_Ptr; + Typ : Entity_Id; + Code : List_Id) return Entity_Id; + -- Build a temporary of type Typ on the secondary stack, appending the + -- necessary actions to Code, and return a constant holding the access + -- value designating this temporary, under the assumption that Typ does + -- not need finalization. + + -- This should be used when Typ can potentially be large, to avoid putting + -- too much pressure on the primary stack, for example with storage models. + procedure Build_Transient_Object_Statements (Obj_Decl : Node_Id; Fin_Call : out Node_Id; @@ -360,9 +372,9 @@ package Exp_Util is Ptr_Decl : out Node_Id; Finalize_Obj : Boolean := True); -- Subsidiary to the processing of transient objects in transient scopes, - -- if expressions, case expressions, expression_with_action nodes, array - -- aggregates, and record aggregates. Obj_Decl denotes the declaration of - -- the transient object. Generate the following nodes: + -- if expressions, case expressions, and expression_with_action nodes. + -- Obj_Decl denotes the declaration of the transient object. Generate the + -- following nodes: -- -- * Fin_Call - the call to [Deep_]Finalize which cleans up the transient -- object if flag Finalize_Obj is set to True, or finalizes the hook when @@ -635,13 +647,6 @@ package Exp_Util is -- current declarative part to look for an address clause for the object -- being declared, and returns the clause if one is found, returns -- Empty otherwise. - -- - -- Note: this function can be costly and must be invoked with special care. - -- Possibly we could introduce a flag at parse time indicating the presence - -- of an address clause to speed this up??? - -- - -- Note: currently this function does not scan the private part, that seems - -- like a potential bug ??? type Force_Evaluation_Mode is (Relaxed, Strict); @@ -913,6 +918,13 @@ package Exp_Util is -- wide type. Set Related_Id to request an external name for the subtype -- rather than an internal temporary. + function Make_Tag_Assignment_From_Type + (Loc : Source_Ptr; + Target : Node_Id; + Typ : Entity_Id) return Node_Id; + -- Return an assignment of the tag of tagged type Typ to prefix Target, + -- which must be a record object of a descendant of Typ. + function Make_Variant_Comparison (Loc : Source_Ptr; Typ : Entity_Id; @@ -1221,7 +1233,9 @@ package Exp_Util is -- extension to verify legality rules on inherited conditions. function Within_Case_Or_If_Expression (N : Node_Id) return Boolean; - -- Determine whether arbitrary node N is within a case or an if expression + -- Determine whether arbitrary node N is immediately within a case or an if + -- expression. The criterion is whether temporaries created by the actions + -- attached to N need to outlive an enclosing case or if expression. private pragma Inline (Duplicate_Subexpr); diff --git a/gcc/ada/fe.h b/gcc/ada/fe.h index dd1ee51..f283064 100644 --- a/gcc/ada/fe.h +++ b/gcc/ada/fe.h @@ -220,8 +220,11 @@ extern Boolean In_Extended_Main_Code_Unit (Entity_Id); #define Unnest_Subprogram_Mode opt__unnest_subprogram_mode typedef enum { - Ada_83, Ada_95, Ada_2005, Ada_2012, Ada_2022, Ada_With_Extensions + Ada_83, Ada_95, Ada_2005, Ada_2012, Ada_2022 } Ada_Version_Type; +// Ada_With_Core_Extensions and Ada_With_All_Extensions (see opt.ads) are not +// used on the C side for now. If we decide to use them, we should import +// All_Extensions_Allowed and Core_Extensions_Allowed functions. extern Ada_Version_Type Ada_Version; extern Boolean Back_End_Inlining; @@ -297,8 +300,10 @@ extern Boolean Is_Derived_Type (Entity_Id); /* sem_eval: */ #define Compile_Time_Known_Value sem_eval__compile_time_known_value +#define Is_Null_Range sem_eval__is_null_range extern Boolean Compile_Time_Known_Value (Node_Id); +extern Boolean Is_Null_Range (Node_Id, Node_Id); /* sem_util: */ diff --git a/gcc/ada/fmap.adb b/gcc/ada/fmap.adb index 798db6e..6cc5ca2 100644 --- a/gcc/ada/fmap.adb +++ b/gcc/ada/fmap.adb @@ -319,7 +319,7 @@ package body Fmap is exit when First > Last; - if (Last < First + 2) or else (Src (Last - 1) /= '%') + if Last < First + 2 or else Src (Last - 1) /= '%' or else (Src (Last) /= 's' and then Src (Last) /= 'b') then Write_Line diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 8662200..83ce030 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -1555,7 +1555,6 @@ package body Freeze is Par_Prim : Entity_Id; Wrapped_Subp : Entity_Id) return Node_Id is - Par_Typ : constant Entity_Id := Find_Dispatching_Type (Par_Prim); Actuals : constant List_Id := Empty_List; Call : Node_Id; Formal : Entity_Id := First_Formal (Par_Prim); @@ -1571,12 +1570,10 @@ package body Freeze is -- If the controlling argument is inherited, add conversion to -- parent type for the call. - if Etype (Formal) = Par_Typ - and then Is_Controlling_Formal (Formal) - then + if Is_Controlling_Formal (Formal) then Append_To (Actuals, Make_Type_Conversion (Loc, - New_Occurrence_Of (Par_Typ, Loc), + New_Occurrence_Of (Etype (Formal), Loc), New_Occurrence_Of (New_Formal, Loc))); else Append_To (Actuals, New_Occurrence_Of (New_Formal, Loc)); @@ -1904,8 +1901,8 @@ package body Freeze is if Iface_Prim /= Par_Prim and then Chars (Iface_Prim) = Chars (Prim) and then Comes_From_Source (Iface_Prim) - and then (Is_Interface_Conformant - (R, Iface_Prim, Prim)) + and then Is_Interface_Conformant + (R, Iface_Prim, Prim) then Check_Same_Strub_Mode (Prim, Iface_Prim); end if; @@ -4113,9 +4110,10 @@ package body Freeze is procedure Check_Large_Modular_Array (Typ : Entity_Id); -- Check that the size of array type Typ can be computed without -- overflow, and generates a Storage_Error otherwise. This is only - -- relevant for array types whose index has System_Max_Integer_Size - -- bits, where wrap-around arithmetic might yield a meaningless value - -- for the length of the array, or its corresponding attribute. + -- relevant for array types whose index is a modular type with + -- Standard_Long_Long_Integer_Size bits: wrap-around arithmetic + -- might yield a meaningless value for the length of the array, + -- or its corresponding attribute. procedure Check_Pragma_Thread_Local_Storage (Var_Id : Entity_Id); -- Ensure that the initialization state of variable Var_Id subject @@ -4173,8 +4171,24 @@ package body Freeze is -- Storage_Error. if Is_Modular_Integer_Type (Idx_Typ) - and then RM_Size (Idx_Typ) = RM_Size (Standard_Long_Long_Integer) + and then RM_Size (Idx_Typ) = Standard_Long_Long_Integer_Size then + -- Ensure that the type of the object is elaborated before + -- the check itself is emitted to avoid elaboration issues + -- in the code generator at the library level. + + if Is_Itype (Etype (E)) + and then In_Open_Scopes (Scope (Etype (E))) + then + declare + Ref_Node : constant Node_Id := + Make_Itype_Reference (Obj_Loc); + begin + Set_Itype (Ref_Node, Etype (E)); + Insert_Action (Declaration_Node (E), Ref_Node); + end; + end if; + Insert_Action (Declaration_Node (E), Make_Raise_Storage_Error (Obj_Loc, Condition => @@ -5500,7 +5514,7 @@ package body Freeze is if Warn_On_Redundant_Constructs then Error_Msg_N -- CODEFIX - ("??pragma Pack has no effect, no unplaced components", + ("?r?pragma Pack has no effect, no unplaced components", Get_Rep_Pragma (Rec, Name_Pack)); end if; end if; @@ -6066,12 +6080,6 @@ package body Freeze is then -- Here we do the wrap - -- Note on calls to Copy_Separate_Tree. The trees we are copying - -- here are fully analyzed, but we definitely want fully syntactic - -- unanalyzed trees in the body we construct, so that the analysis - -- generates the right visibility, and that is exactly what the - -- calls to Copy_Separate_Tree give us. - Prag := Copy_Import_Pragma; -- Fix up spec so it is no longer imported and has convention Ada @@ -6127,11 +6135,10 @@ package body Freeze is Bod := Make_Subprogram_Body (Loc, - Specification => - Copy_Separate_Tree (Spec), + Specification => Copy_Subprogram_Spec (Spec), Declarations => New_List ( Make_Subprogram_Declaration (Loc, - Specification => Copy_Separate_Tree (Spec)), + Specification => Copy_Subprogram_Spec (Spec)), Prag), Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, @@ -6438,7 +6445,9 @@ package body Freeze is -- Check for needing to wrap imported subprogram - Wrap_Imported_Subprogram (E); + if not Inside_A_Generic then + Wrap_Imported_Subprogram (E); + end if; -- Freeze all parameter types and the return type (RM 13.14(14)). -- However skip this for internal subprograms. This is also where @@ -7286,10 +7295,20 @@ package body Freeze is elsif Is_Integer_Type (E) then Adjust_Esize_For_Alignment (E); - if Is_Modular_Integer_Type (E) - and then Warn_On_Suspicious_Modulus_Value - then - Check_Suspicious_Modulus (E); + if Is_Modular_Integer_Type (E) then + -- Standard_Address has been built with the assumption that its + -- modulus was System_Address_Size, but this is not a universal + -- property and may need to be corrected. + + if Is_RTE (E, RE_Address) then + Set_Modulus (Standard_Address, Modulus (E)); + Set_Intval + (High_Bound (Scalar_Range (Standard_Address)), + Modulus (E) - 1); + + elsif Warn_On_Suspicious_Modulus_Value then + Check_Suspicious_Modulus (E); + end if; end if; -- The pool applies to named and anonymous access types, but not @@ -8284,7 +8303,7 @@ package body Freeze is if Desig_Typ /= Empty and then (Is_Frozen (Desig_Typ) - or else (not Is_Fully_Defined (Desig_Typ))) + or else not Is_Fully_Defined (Desig_Typ)) then Desig_Typ := Empty; end if; @@ -8427,7 +8446,7 @@ package body Freeze is if not In_Spec_Expression and then Nkind (N) = N_Identifier - and then (Present (Entity (N))) + and then Present (Entity (N)) then -- We recognize the discriminant case by just looking for -- a reference to a discriminant. It can only be one for @@ -8712,17 +8731,19 @@ package body Freeze is -- The current scope may be that of a constrained component of -- an enclosing record declaration, or of a loop of an enclosing - -- quantified expression, which is above the current scope in the - -- scope stack. Indeed in the context of a quantified expression, - -- a scope is created and pushed above the current scope in order - -- to emulate the loop-like behavior of the quantified expression. + -- quantified expression or aggregate with an iterated component + -- in Ada 2022, which is above the current scope in the scope + -- stack. Indeed in the context of a quantified expression or + -- an aggregate with an iterated component, an internal scope is + -- created and pushed above the current scope in order to emulate + -- the loop-like behavior of the construct. -- If the expression is within a top-level pragma, as for a pre- -- condition on a library-level subprogram, nothing to do. if not Is_Compilation_Unit (Current_Scope) and then (Is_Record_Type (Scope (Current_Scope)) - or else Nkind (Parent (Current_Scope)) = - N_Quantified_Expression) + or else (Ekind (Current_Scope) = E_Loop + and then Is_Internal (Current_Scope))) then Pos := Pos - 1; end if; diff --git a/gcc/ada/frontend.adb b/gcc/ada/frontend.adb index d964acd..f2faa09 100644 --- a/gcc/ada/frontend.adb +++ b/gcc/ada/frontend.adb @@ -426,24 +426,17 @@ begin -- Cleanup processing after completing main analysis - -- In GNATprove_Mode we do not perform most expansions but body - -- instantiation is needed. + pragma Assert (Operating_Mode in Check_Semantics | Generate_Code); - pragma Assert - (Operating_Mode = Generate_Code - or else Operating_Mode = Check_Semantics); + if Operating_Mode = Generate_Code or else GNATprove_Mode then + + -- In GNATprove_Mode we do not perform most expansions but body + -- instantiation is needed. - if Operating_Mode = Generate_Code - or else GNATprove_Mode - then Instantiate_Bodies; - end if; - -- Analyze all inlined bodies, check access-before-elaboration - -- rules, and remove ignored Ghost code when generating code or - -- compiling for GNATprove. + -- Analyze inlined bodies if required - if Operating_Mode = Generate_Code or else GNATprove_Mode then if Inline_Processing_Required then Analyze_Inlined_Bodies; end if; @@ -455,6 +448,8 @@ begin Collect_Garbage_Entities; end if; + -- Check access-before-elaboration rules + if Legacy_Elaboration_Checks then Check_Elab_Calls; end if; diff --git a/gcc/ada/gcc-interface/Make-lang.in b/gcc/ada/gcc-interface/Make-lang.in index 9507f2f..364dea6 100644 --- a/gcc/ada/gcc-interface/Make-lang.in +++ b/gcc/ada/gcc-interface/Make-lang.in @@ -71,10 +71,11 @@ else ADAFLAGS=$(COMMON_ADAFLAGS) endif +ADA_CFLAGS = ALL_ADAFLAGS = \ - $(CFLAGS) $(ADA_CFLAGS) $(ADAFLAGS) $(CHECKING_ADAFLAGS) $(WARN_ADAFLAGS) + $(CFLAGS) $(ADA_CFLAGS) $(ADAFLAGS) $(CHECKING_ADAFLAGS) \ + $(WARN_ADAFLAGS) $(PICFLAG) FORCE_DEBUG_ADAFLAGS = -g -ADA_CFLAGS = COMMON_ADA_INCLUDES = -I- -I. -Iada/generated -Iada -I$(srcdir)/ada STAGE1_LIBS= @@ -536,6 +537,8 @@ GNAT_ADA_OBJS+= \ ada/libgnat/s-secsta.o \ ada/libgnat/s-soflin.o \ ada/libgnat/s-soliin.o \ + ada/libgnat/s-spark.o \ + ada/libgnat/s-spcuop.o \ ada/libgnat/s-stache.o \ ada/libgnat/s-stalib.o \ ada/libgnat/s-stoele.o \ @@ -1109,7 +1112,7 @@ ada/b_gnat1.adb : $(GNAT1_ADA_OBJS) ada/b_gnat1.o : ada/b_gnat1.adb # Do not use ADAFLAGS to get rid of -gnatg which generates a lot # of style messages. - $(CC) -c $(CFLAGS) $(ADA_CFLAGS) -gnatp -gnatws $(ADA_INCLUDES) \ + $(CC) -c $(CFLAGS) $(ADA_CFLAGS) $(PICFLAG) -gnatp -gnatws $(ADA_INCLUDES) \ $< $(ADA_OUTPUT_OPTION) ada/b_gnatb.adb : $(GNATBIND_OBJS) ada/gnatbind.o @@ -1118,7 +1121,7 @@ ada/b_gnatb.adb : $(GNATBIND_OBJS) ada/gnatbind.o $(MV) b_gnatb.adb b_gnatb.ads ada/ ada/b_gnatb.o : ada/b_gnatb.adb - $(CC) -c $(CFLAGS) $(ADA_CFLAGS) -gnatp -gnatws $(ADA_INCLUDES) \ + $(CC) -c $(CFLAGS) $(ADA_CFLAGS) $(PICFLAG) -gnatp -gnatws $(ADA_INCLUDES) \ $< $(ADA_OUTPUT_OPTION) include $(srcdir)/ada/Make-generated.in @@ -1172,17 +1175,6 @@ ada/gnatvsn.o : ada/gnatvsn.adb ada/generated/gnatvsn.ads $(CC) -c $(ALL_ADAFLAGS) $(ADA_INCLUDES) $< $(ADA_OUTPUT_OPTION) @$(ADA_DEPS) -# Dependencies for windows specific tool (mdll) - -ada/mdll.o : ada/mdll.adb ada/mdll.ads ada/mdll-fil.ads ada/mdll-utl.ads - $(CC) -c $(ALL_ADAFLAGS) $(ADA_INCLUDES) $< $(ADA_OUTPUT_OPTION) - -ada/mdll-fil.o : ada/mdll-fil.adb ada/mdll.ads ada/mdll-fil.ads - $(CC) -c $(ALL_ADAFLAGS) $(ADA_INCLUDES) $< $(ADA_OUTPUT_OPTION) - -ada/mdll-utl.o : ada/mdll-utl.adb ada/mdll.ads ada/mdll-utl.ads ada/sdefault.ads ada/types.ads - $(CC) -c $(ALL_ADAFLAGS) $(ADA_INCLUDES) $< $(ADA_OUTPUT_OPTION) - # All generated files. Perhaps we should build all of these in the same # subdirectory, and get rid of ada/bldtools. # Warning: the files starting with ada/gnat.ads are not really generated, diff --git a/gcc/ada/gcc-interface/Makefile.in b/gcc/ada/gcc-interface/Makefile.in index da6a56f..dc0e54f 100644 --- a/gcc/ada/gcc-interface/Makefile.in +++ b/gcc/ada/gcc-interface/Makefile.in @@ -91,6 +91,7 @@ LS = ls RANLIB = @RANLIB@ RANLIB_FLAGS = @ranlib_flags@ AWK = @AWK@ +PICFLAG = @PICFLAG@ COMPILER = $(CC) COMPILER_FLAGS = $(CFLAGS) @@ -239,7 +240,11 @@ ALL_CPPFLAGS = $(CPPFLAGS) ALL_COMPILERFLAGS = $(ALL_CFLAGS) # This is where we get libiberty.a from. +ifeq ($(PICFLAG),) LIBIBERTY = ../../libiberty/libiberty.a +else +LIBIBERTY = ../../libiberty/pic/libiberty.a +endif # We need to link against libbacktrace because diagnostic.c in # libcommon.a uses it. @@ -256,9 +261,6 @@ TOOLS_LIBS = ../version.o ../link.o ../targext.o ../../ggc-none.o \ $(LIBGNAT) $(LIBINTL) $(LIBICONV) ../$(LIBBACKTRACE) ../$(LIBIBERTY) \ $(SYSLIBS) $(TGT_LIB) -# Add -no-pie to TOOLS_LIBS since some of them are compiled with -fno-PIE. -TOOLS_LIBS += @NO_PIE_FLAG@ - # Specify the directories to be searched for header files. # Both . and srcdir are used, in that order, # so that tm.h and config.h will be found in the compilation diff --git a/gcc/ada/gcc-interface/decl.cc b/gcc/ada/gcc-interface/decl.cc index d24adf3..494b24e 100644 --- a/gcc/ada/gcc-interface/decl.cc +++ b/gcc/ada/gcc-interface/decl.cc @@ -785,7 +785,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) if ((TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE && No (gnat_renamed_obj)) || TYPE_IS_DUMMY_P (gnu_type) - || TREE_CODE (gnu_type) == VOID_TYPE) + || VOID_TYPE_P (gnu_type)) { gcc_assert (type_annotate_only); if (this_global) @@ -840,7 +840,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) if (TREE_CODE (gnu_expr) == COMPONENT_REF && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_expr, 0))) - && TREE_CODE (TREE_OPERAND (gnu_expr, 0)) == VAR_DECL + && VAR_P (TREE_OPERAND (gnu_expr, 0)) && (TREE_READONLY (TREE_OPERAND (gnu_expr, 0)) || DECL_READONLY_ONCE_ELAB (TREE_OPERAND (gnu_expr, 0)))) @@ -1076,9 +1076,13 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) || EXPRESSION_CLASS_P (inner) /* We need to detect the case where a temporary is created to hold the return value, since we cannot safely rename it at - top level as it lives only in the elaboration routine. */ - || (TREE_CODE (inner) == VAR_DECL - && DECL_RETURN_VALUE_P (inner)) + top level because it lives only in the elaboration routine. + But, at a lower level, an object initialized by a function + call may be (implicitly) renamed as this temporary by the + front-end and, in this case, we cannot make a copy. */ + || (VAR_P (inner) + && DECL_RETURN_VALUE_P (inner) + && global_bindings_p ()) /* We also need to detect the case where the front-end creates a dangling 'reference to a function call at top level and substitutes it in the renaming, for example: @@ -1092,12 +1096,14 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) q__b : boolean renames q__R1s.all.e (1); We cannot safely rename the rewritten expression since the - underlying object lives only in the elaboration routine. */ - || (TREE_CODE (inner) == INDIRECT_REF + underlying object lives only in the elaboration routine but, + as above, this cannot be done at a lower level. */ + || (INDIRECT_REF_P (inner) && (inner = remove_conversions (TREE_OPERAND (inner, 0), true)) - && TREE_CODE (inner) == VAR_DECL - && DECL_RETURN_VALUE_P (inner))) + && VAR_P (inner) + && DECL_RETURN_VALUE_P (inner) + && global_bindings_p ())) ; /* Otherwise, this is an lvalue being renamed, so it needs to be @@ -1156,7 +1162,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) gnu_expr = build_unary_op (ADDR_EXPR, gnu_type, gnu_expr); - create_var_decl (gnu_entity_name, gnu_ext_name, + create_var_decl (gnu_entity_name, NULL_TREE, TREE_TYPE (gnu_expr), gnu_expr, const_flag, Is_Public (gnat_entity), imported_p, static_flag, volatile_flag, @@ -1212,7 +1218,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) && (POINTER_TYPE_P (gnu_type) || TYPE_IS_FAT_POINTER_P (gnu_type)) && !gnu_expr && !Is_Imported (gnat_entity)) - gnu_expr = integer_zero_node; + gnu_expr = null_pointer_node; /* If we are defining the object and it has an Address clause, we must either get the address expression from the saved GCC tree for the @@ -1527,7 +1533,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) /* If this name is external or a name was specified, use it, but don't use the Interface_Name with an address clause (see cd30005). */ - if ((Is_Public (gnat_entity) && !Is_Imported (gnat_entity)) + if ((Is_Public (gnat_entity) && !imported_p) || (Present (Interface_Name (gnat_entity)) && No (Address_Clause (gnat_entity)))) gnu_ext_name = create_concat_name (gnat_entity, NULL); @@ -1611,7 +1617,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) and optimization isn't enabled, then force it in memory so that a register won't be allocated to it with possible subparts left uninitialized and reaching the register allocator. */ - else if (TREE_CODE (gnu_decl) == VAR_DECL + else if (VAR_P (gnu_decl) && !DECL_EXTERNAL (gnu_decl) && !TREE_STATIC (gnu_decl) && DECL_MODE (gnu_decl) != BLKmode @@ -2241,9 +2247,10 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) index += (convention_fortran_p ? - 1 : 1), gnat_index = Next_Index (gnat_index)) { + const Entity_Id gnat_index_type = Etype (gnat_index); const bool is_flb - = Is_Fixed_Lower_Bound_Index_Subtype (Etype (gnat_index)); - tree gnu_index_type = get_unpadded_type (Etype (gnat_index)); + = Is_Fixed_Lower_Bound_Index_Subtype (gnat_index_type); + tree gnu_index_type = get_unpadded_type (gnat_index_type); tree gnu_orig_min = TYPE_MIN_VALUE (gnu_index_type); tree gnu_orig_max = TYPE_MAX_VALUE (gnu_index_type); tree gnu_index_base_type = get_base_type (gnu_index_type); @@ -2479,6 +2486,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) const int ndim = Number_Dimensions (gnat_entity); tree gnu_base_type = gnu_type; tree *gnu_index_types = XALLOCAVEC (tree, ndim); + bool *gnu_null_ranges = XALLOCAVEC (bool, ndim); tree gnu_max_size = size_one_node; bool need_index_type_struct = false; int index; @@ -2494,7 +2502,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) gnat_index = Next_Index (gnat_index), gnat_base_index = Next_Index (gnat_base_index)) { - tree gnu_index_type = get_unpadded_type (Etype (gnat_index)); + const Entity_Id gnat_index_type = Etype (gnat_index); + tree gnu_index_type = get_unpadded_type (gnat_index_type); tree gnu_orig_min = TYPE_MIN_VALUE (gnu_index_type); tree gnu_orig_max = TYPE_MAX_VALUE (gnu_index_type); tree gnu_index_base_type = get_base_type (gnu_index_type); @@ -2671,6 +2680,13 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) = create_index_type (gnu_min, gnu_high, gnu_index_type, gnat_entity); + /* Record whether the range is known to be null at compile time + to disambiguate it from too large ranges. */ + const Entity_Id gnat_ui_type = Underlying_Type (gnat_index_type); + gnu_null_ranges[index] + = Is_Null_Range (Type_Low_Bound (gnat_ui_type), + Type_High_Bound (gnat_ui_type)); + /* We need special types for debugging information to point to the index types if they have variable bounds, are not integer types, are biased or are wider than sizetype. These are GNAT @@ -2737,7 +2753,14 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) if (array_type_has_nonaliased_component (gnu_type, gnat_entity)) set_nonaliased_component_on_array_type (gnu_type); - /* Kludge to remove the TREE_OVERFLOW flag for the sake of LTO + /* Clear the TREE_OVERFLOW flag, if any, for null arrays. */ + if (gnu_null_ranges[index]) + { + TYPE_SIZE (gnu_type) = bitsize_zero_node; + TYPE_SIZE_UNIT (gnu_type) = size_zero_node; + } + + /* Kludge to clear the TREE_OVERFLOW flag for the sake of LTO on maximally-sized array types designed by access types. */ if (integer_zerop (TYPE_SIZE (gnu_type)) && TREE_OVERFLOW (TYPE_SIZE (gnu_type)) @@ -3954,10 +3977,9 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) = gnu_ext_name_for_subprog (gnat_entity, gnu_entity_name); const enum inline_status_t inline_status = inline_status_for_subprog (gnat_entity); - bool public_flag = Is_Public (gnat_entity) || imported_p; /* Subprograms marked both Intrinsic and Always_Inline need not have a body of their own. */ - bool extern_flag + const bool extern_flag = ((Is_Public (gnat_entity) && !definition) || imported_p || (Is_Intrinsic_Subprogram (gnat_entity) @@ -4112,10 +4134,9 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) else gnu_decl = create_subprog_decl (gnu_entity_name, gnu_ext_name, - gnu_type, gnu_param_list, - inline_status, public_flag, - extern_flag, artificial_p, - debug_info_p, + gnu_type, gnu_param_list, inline_status, + Is_Public (gnat_entity) || imported_p, + extern_flag, artificial_p, debug_info_p, definition && imported_p, attr_list, gnat_entity); } @@ -4364,7 +4385,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) /* If the alignment has not already been processed and this is not an unconstrained array type, see if an alignment is specified. If not, we pick a default alignment for atomic objects. */ - if (align != 0 || TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE) + if (align > 0 || TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE) ; else if (Known_Alignment (gnat_entity)) { @@ -4653,6 +4674,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) /* If this is not an unconstrained array type, set some flags. */ if (TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE) { + bool align_clause; + /* Record the property that objects of tagged types are guaranteed to be properly aligned. This is necessary because conversions to the class-wide type are translated into conversions to the root type, @@ -4665,8 +4688,20 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) if (is_by_ref && !VOID_TYPE_P (gnu_type)) TYPE_BY_REFERENCE_P (gnu_type) = 1; - /* Record whether an alignment clause was specified. */ - if (Present (Alignment_Clause (gnat_entity))) + /* Record whether an alignment clause was specified. At this point + scalar types with a non-confirming clause have been wrapped into + a record type, so only scalar types with a confirming clause are + left untouched; we do not set the flag on them except if they are + types whose default alignment is specifically capped in order not + to lose the specified alignment. */ + if ((AGGREGATE_TYPE_P (gnu_type) + && Present (Alignment_Clause (gnat_entity))) + || (double_float_alignment > 0 + && is_double_float_or_array (gnat_entity, &align_clause) + && align_clause) + || (double_scalar_alignment > 0 + && is_double_scalar_or_array (gnat_entity, &align_clause) + && align_clause)) TYPE_USER_ALIGN (gnu_type) = 1; /* Record whether a pragma Universal_Aliasing was specified. */ @@ -6659,6 +6694,10 @@ range_cannot_be_superflat (Node_Id gnat_range) Node_Id gnat_scalar_range; tree gnu_lb, gnu_hb, gnu_lb_minus_one; + /* This is the easy case. */ + if (Cannot_Be_Superflat (gnat_range)) + return true; + /* If the low bound is not constant, take the worst case by finding an upper bound for its type, repeatedly if need be. */ while (Nkind (gnat_lb) != N_Integer_Literal @@ -6703,8 +6742,7 @@ range_cannot_be_superflat (Node_Id gnat_range) static bool constructor_address_p (tree gnu_expr) { - while (TREE_CODE (gnu_expr) == NOP_EXPR - || TREE_CODE (gnu_expr) == CONVERT_EXPR + while (CONVERT_EXPR_P (gnu_expr) || TREE_CODE (gnu_expr) == NON_LVALUE_EXPR) gnu_expr = TREE_OPERAND (gnu_expr, 0); @@ -7047,7 +7085,7 @@ elaborate_expression_1 (tree gnu_expr, Entity_Id gnat_entity, const char *s, expr_variable_p = !(inner - && TREE_CODE (inner) == VAR_DECL + && VAR_P (inner) && (TREE_READONLY (inner) || DECL_READONLY_ONCE_ELAB (inner))); } diff --git a/gcc/ada/gcc-interface/gigi.h b/gcc/ada/gcc-interface/gigi.h index fee0450..ec85ce4 100644 --- a/gcc/ada/gcc-interface/gigi.h +++ b/gcc/ada/gcc-interface/gigi.h @@ -245,11 +245,12 @@ extern void gigi (Node_Id gnat_root, struct List_Header *list_headers_ptr, Nat number_file, struct File_Info_Type *file_info_ptr, + Entity_Id standard_address, Entity_Id standard_boolean, - Entity_Id standard_integer, Entity_Id standard_character, - Entity_Id standard_long_long_float, Entity_Id standard_exception_type, + Entity_Id standard_integer, + Entity_Id standard_long_long_float, Int gigi_operating_mode); #ifdef __cplusplus diff --git a/gcc/ada/gcc-interface/misc.cc b/gcc/ada/gcc-interface/misc.cc index b18ca8c..30319ae 100644 --- a/gcc/ada/gcc-interface/misc.cc +++ b/gcc/ada/gcc-interface/misc.cc @@ -267,9 +267,6 @@ gnat_post_options (const char **pfilename ATTRIBUTE_UNUSED) /* No return type warnings for Ada. */ warn_return_type = 0; - /* No string overflow warnings for Ada. */ - warn_stringop_overflow = 0; - /* No caret by default for Ada. */ if (!OPTION_SET_P (flag_diagnostics_show_caret)) global_dc->show_caret = false; @@ -333,13 +330,23 @@ internal_error_function (diagnostic_context *context, const char *msgid, sp.Bounds = &temp; sp.Array = buffer; - xloc = expand_location (input_location); - if (context->show_column && xloc.column != 0) - loc = xasprintf ("%s:%d:%d", xloc.file, xloc.line, xloc.column); + if (input_location == UNKNOWN_LOCATION) + { + loc = NULL; + temp_loc.Low_Bound = 1; + temp_loc.High_Bound = 0; + } else - loc = xasprintf ("%s:%d", xloc.file, xloc.line); - temp_loc.Low_Bound = 1; - temp_loc.High_Bound = strlen (loc); + { + xloc = expand_location (input_location); + if (context->show_column && xloc.column != 0) + loc = xasprintf ("%s:%d:%d", xloc.file, xloc.line, xloc.column); + else + loc = xasprintf ("%s:%d", xloc.file, xloc.line); + temp_loc.Low_Bound = 1; + temp_loc.High_Bound = strlen (loc); + } + sp_loc.Bounds = &temp_loc; sp_loc.Array = loc; diff --git a/gcc/ada/gcc-interface/trans.cc b/gcc/ada/gcc-interface/trans.cc index 5fc1a26..ddc7b6d 100644 --- a/gcc/ada/gcc-interface/trans.cc +++ b/gcc/ada/gcc-interface/trans.cc @@ -290,11 +290,12 @@ gigi (Node_Id gnat_root, struct List_Header *list_headers_ptr, Nat number_file, struct File_Info_Type *file_info_ptr, + Entity_Id standard_address, Entity_Id standard_boolean, - Entity_Id standard_integer, Entity_Id standard_character, - Entity_Id standard_long_long_float, Entity_Id standard_exception_type, + Entity_Id standard_integer, + Entity_Id standard_long_long_float, Int gigi_operating_mode) { Node_Id gnat_iter; @@ -375,14 +376,19 @@ gigi (Node_Id gnat_root, double_float_alignment = get_target_double_float_alignment (); double_scalar_alignment = get_target_double_scalar_alignment (); - /* Record the builtin types. Define `integer' and `character' first so that - dbx will output them first. */ + /* Record the builtin types. */ + record_builtin_type ("address", pointer_sized_int_node, false); record_builtin_type ("integer", integer_type_node, false); record_builtin_type ("character", char_type_node, false); record_builtin_type ("boolean", boolean_type_node, false); record_builtin_type ("void", void_type_node, false); - /* Save the type we made for integer as the type for Standard.Integer. */ + /* Save the type we made for address as the type for Standard.Address. */ + save_gnu_tree (Base_Type (standard_address), + TYPE_NAME (pointer_sized_int_node), + false); + + /* Likewise for integer as the type for Standard.Integer. */ save_gnu_tree (Base_Type (standard_integer), TYPE_NAME (integer_type_node), false); @@ -1241,7 +1247,7 @@ Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p) /* Do the final dereference. */ gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result); - if ((TREE_CODE (gnu_result) == INDIRECT_REF + if ((INDIRECT_REF_P (gnu_result) || TREE_CODE (gnu_result) == UNCONSTRAINED_ARRAY_REF) && No (Address_Clause (gnat_entity))) TREE_THIS_NOTRAP (gnu_result) = 1; @@ -1708,12 +1714,17 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute) case Attr_Address: case Attr_Unrestricted_Access: /* Conversions don't change the address of references but can cause - build_unary_op to miss the references below, so strip them off. + build_unary_op to miss the references below so strip them off. + + Also remove the conversions applied to declarations as the intent is + to take the decls' address, not that of the copies that the + conversions may create. + On the contrary, if the address-of operation causes a temporary to be created, then it must be created with the proper type. */ gnu_expr = remove_conversions (gnu_prefix, !Must_Be_Byte_Aligned (gnat_node)); - if (REFERENCE_CLASS_P (gnu_expr)) + if (REFERENCE_CLASS_P (gnu_expr) || DECL_P (gnu_expr)) gnu_prefix = gnu_expr; /* If we are taking 'Address of an unconstrained object, this is the @@ -1939,24 +1950,20 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute) /* If this is a dereference and we have a special dynamic constrained subtype on the prefix, use it to compute the size; otherwise, use the designated subtype. */ - if (Nkind (gnat_prefix) == N_Explicit_Dereference) + if (Nkind (gnat_prefix) == N_Explicit_Dereference + && Present (Actual_Designated_Subtype (gnat_prefix))) { - Node_Id gnat_actual_subtype - = Actual_Designated_Subtype (gnat_prefix); + tree gnu_actual_obj_type + = gnat_to_gnu_type (Actual_Designated_Subtype (gnat_prefix)); tree gnu_ptr_type = TREE_TYPE (gnat_to_gnu (Prefix (gnat_prefix))); - if (TYPE_IS_FAT_OR_THIN_POINTER_P (gnu_ptr_type) - && Present (gnat_actual_subtype)) - { - tree gnu_actual_obj_type - = gnat_to_gnu_type (gnat_actual_subtype); - gnu_type - = build_unc_object_type_from_ptr (gnu_ptr_type, - gnu_actual_obj_type, - get_identifier ("SIZE"), - false); - } + if (TYPE_IS_FAT_OR_THIN_POINTER_P (gnu_ptr_type)) + gnu_type + = build_unc_object_type_from_ptr (gnu_ptr_type, + gnu_actual_obj_type, + get_identifier ("SIZE"), + false); } gnu_result = TYPE_SIZE (gnu_type); @@ -1971,7 +1978,8 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute) if (TREE_CODE (gnu_prefix) != TYPE_DECL) { gnu_result = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result, gnu_prefix); - if (Present (gnat_smo)) + if (Present (gnat_smo) + && Present (Storage_Model_Copy_From (gnat_smo))) gnu_result = INSTANTIATE_LOAD_IN_EXPR (gnu_result, gnat_smo); } else if (CONTAINS_PLACEHOLDER_P (gnu_result)) @@ -2204,7 +2212,8 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute) handling. Note that these attributes could not have been used on an unconstrained array type. */ gnu_result = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result, gnu_prefix); - if (Present (gnat_smo)) + if (Present (gnat_smo) + && Present (Storage_Model_Copy_From (gnat_smo))) gnu_result = INSTANTIATE_LOAD_IN_EXPR (gnu_result, gnat_smo); /* Cache the expression we have just computed. Since we want to do it @@ -2366,7 +2375,8 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute) /* If this has a PLACEHOLDER_EXPR, qualify it by the object we are handling. */ gnu_result = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result, gnu_prefix); - if (Present (gnat_smo)) + if (Present (gnat_smo) + && Present (Storage_Model_Copy_From (gnat_smo))) gnu_result = INSTANTIATE_LOAD_IN_EXPR (gnu_result, gnat_smo); break; } @@ -3391,7 +3401,7 @@ struct nrv_data static inline bool is_nrv_p (bitmap nrv, tree t) { - return TREE_CODE (t) == VAR_DECL && bitmap_bit_p (nrv, DECL_UID (t)); + return VAR_P (t) && bitmap_bit_p (nrv, DECL_UID (t)); } /* Helper function for walk_tree, used by finalize_nrv below. */ @@ -4136,7 +4146,7 @@ Subprogram_Body_to_gnu (Node_Id gnat_node) gnat_param = Next_Formal_With_Extras (gnat_param)) { tree gnu_param = get_gnu_tree (gnat_param); - bool is_var_decl = (TREE_CODE (gnu_param) == VAR_DECL); + bool is_var_decl = VAR_P (gnu_param); annotate_object (gnat_param, TREE_TYPE (gnu_param), NULL_TREE, DECL_BY_REF_P (gnu_param)); @@ -4254,8 +4264,16 @@ static inline bool node_is_component (Node_Id gnat_node) { const Node_Kind k = Nkind (gnat_node); - return - (k == N_Indexed_Component || k == N_Selected_Component || k == N_Slice); + return k == N_Indexed_Component || k == N_Selected_Component || k == N_Slice; +} + +/* Return true if GNAT_NODE is a type conversion. */ + +static inline bool +node_is_type_conversion (Node_Id gnat_node) +{ + const Node_Kind k = Nkind (gnat_node); + return k == N_Type_Conversion || k == N_Unchecked_Type_Conversion; } /* Compute whether GNAT_NODE requires atomic access and set TYPE to the type @@ -4306,8 +4324,7 @@ get_atomic_access (Node_Id gnat_node, atomic_acces_t *type, bool *sync) } /* Now strip any type conversion from GNAT_NODE. */ - if (Nkind (gnat_node) == N_Type_Conversion - || Nkind (gnat_node) == N_Unchecked_Type_Conversion) + if (node_is_type_conversion (gnat_node)) gnat_node = Expression (gnat_node); /* Up to Ada 2012, for Atomic itself, only reads and updates of the object as @@ -4392,21 +4409,44 @@ static void get_storage_model_access (Node_Id gnat_node, Entity_Id *gnat_smo) { const Node_Id gnat_parent = Parent (gnat_node); + *gnat_smo = Empty; - /* If we are the prefix of the parent, then the access is above us. */ - if (node_is_component (gnat_parent) && Prefix (gnat_parent) == gnat_node) + switch (Nkind (gnat_parent)) { - *gnat_smo = Empty; + case N_Attribute_Reference: + /* If the parent is an attribute reference that requires an lvalue and + gnat_node is the Prefix (i.e. not a parameter), we do not need to + actually access any storage. */ + if (lvalue_required_for_attribute_p (gnat_parent) + && Prefix (gnat_parent) == gnat_node) + return; + break; + + case N_Object_Renaming_Declaration: + /* Nothing to do for the identifier in an object renaming declaration, + the renaming itself does not need storage model access. */ return; + + default: + break; } - /* Now strip any type conversion from GNAT_NODE. */ - if (Nkind (gnat_node) == N_Type_Conversion - || Nkind (gnat_node) == N_Unchecked_Type_Conversion) - gnat_node = Expression (gnat_node); + /* If we are the prefix of the parent, then the access is above us. */ + if ((node_is_component (gnat_parent) && Prefix (gnat_parent) == gnat_node) + || (node_is_type_conversion (gnat_parent) + && node_is_component (Parent (gnat_parent)) + && Prefix (Parent (gnat_parent)) == gnat_parent)) + return; + /* Find the innermost prefix in GNAT_NODE, stripping any type conversion. */ + if (node_is_type_conversion (gnat_node)) + gnat_node = Expression (gnat_node); while (node_is_component (gnat_node)) - gnat_node = Prefix (gnat_node); + { + gnat_node = Prefix (gnat_node); + if (node_is_type_conversion (gnat_node)) + gnat_node = Expression (gnat_node); + } *gnat_smo = get_storage_model (gnat_node); } @@ -4536,14 +4576,13 @@ elaborate_profile (Entity_Id first_formal, Entity_Id result_type) N_Assignment_Statement and the result is to be placed into that object. ATOMIC_ACCESS is the type of atomic access to be used for the assignment to GNU_TARGET. If, in addition, ATOMIC_SYNC is true, then the assignment - to GNU_TARGET requires atomic synchronization. GNAT_STORAGE_MODEL is the - storage model object to be used for the assignment to GNU_TARGET or Empty - if there is none. */ + to GNU_TARGET requires atomic synchronization. GNAT_SMO is the storage + model object to be used for the assignment to GNU_TARGET or Empty if there + is none. */ static tree Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target, - atomic_acces_t atomic_access, bool atomic_sync, - Entity_Id gnat_storage_model) + atomic_acces_t atomic_access, bool atomic_sync, Entity_Id gnat_smo) { const bool function_call = (Nkind (gnat_node) == N_Function_Call); const bool returning_value = (function_call && !gnu_target); @@ -4556,7 +4595,7 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target, /* The FUNCTION_TYPE node giving the GCC type of the subprogram. */ tree gnu_subprog_type = TREE_TYPE (gnu_subprog); /* The return type of the FUNCTION_TYPE. */ - tree gnu_result_type;; + tree gnu_result_type; const bool frontend_builtin = (TREE_CODE (gnu_subprog) == FUNCTION_DECL && DECL_BUILT_IN_CLASS (gnu_subprog) == BUILT_IN_FRONTEND); @@ -4575,7 +4614,6 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target, Node_Id gnat_actual; atomic_acces_t aa_type; bool aa_sync; - Entity_Id gnat_smo; /* The only way we can make a call via an access type is if GNAT_NAME is an explicit dereference. In that case, get the list of formal args from the @@ -4639,7 +4677,7 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target, } /* We must elaborate the entire profile now because, if it references types - that were initially incomplete,, their elaboration changes the contents + that were initially incomplete, their elaboration changes the contents of GNU_SUBPROG_TYPE and, in particular, may change the result type. */ elaborate_profile (gnat_formal, gnat_result_type); @@ -4727,8 +4765,8 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target, != TYPE_SIZE (TREE_TYPE (gnu_target)) && type_is_padding_self_referential (gnu_result_type)) || (gnu_target - && Present (gnat_storage_model) - && Present (Storage_Model_Copy_To (gnat_storage_model))))) + && Present (gnat_smo) + && Present (Storage_Model_Copy_To (gnat_smo))))) { gnu_retval = create_temporary ("R", gnu_result_type); DECL_RETURN_VALUE_P (gnu_retval) = 1; @@ -4799,19 +4837,12 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target, = build_compound_expr (TREE_TYPE (gnu_name), init, gnu_name); } - get_storage_model_access (gnat_actual, &gnat_smo); - - /* If we are passing a non-addressable actual parameter by reference, - pass the address of a copy. Likewise if it needs to be accessed with - a storage model. In the In Out or Out case, set up to copy back out - after the call. */ + /* If we are passing a non-addressable parameter by reference, pass the + address of a copy. In the In Out or Out case, set up to copy back + out after the call. */ if (is_by_ref_formal_parm && (gnu_name_type = gnat_to_gnu_type (Etype (gnat_name))) - && (!addressable_p (gnu_name, gnu_name_type) - || (Present (gnat_smo) - && (Present (Storage_Model_Copy_From (gnat_smo)) - || (!in_param - && Present (Storage_Model_Copy_To (gnat_smo))))))) + && !addressable_p (gnu_name, gnu_name_type)) { tree gnu_orig = gnu_name, gnu_temp, gnu_stmt; @@ -4882,40 +4913,21 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target, } /* Create an explicit temporary holding the copy. */ - tree gnu_temp_type; - if (Nkind (gnat_actual) == N_Explicit_Dereference - && Present (Actual_Designated_Subtype (gnat_actual))) - gnu_temp_type - = gnat_to_gnu_type (Actual_Designated_Subtype (gnat_actual)); - else - gnu_temp_type = TREE_TYPE (gnu_name); /* Do not initialize it for the _Init parameter of an initialization procedure since no data is meant to be passed in. */ if (Ekind (gnat_formal) == E_Out_Parameter && Is_Entity_Name (gnat_subprog) && Is_Init_Proc (Entity (gnat_subprog))) - gnu_name = gnu_temp = create_temporary ("A", gnu_temp_type); + gnu_name = gnu_temp = create_temporary ("A", TREE_TYPE (gnu_name)); /* Initialize it on the fly like for an implicit temporary in the other cases, as we don't necessarily have a statement list. */ else { - if (Present (gnat_smo) - && Present (Storage_Model_Copy_From (gnat_smo))) - { - gnu_temp = create_temporary ("A", gnu_temp_type); - gnu_stmt - = build_storage_model_load (gnat_smo, gnu_temp, - gnu_name, - TYPE_SIZE_UNIT (gnu_temp_type)); - set_expr_location_from_node (gnu_stmt, gnat_actual); - } - else - gnu_temp = create_init_temporary ("A", gnu_name, &gnu_stmt, - gnat_actual); - - gnu_name = build_compound_expr (gnu_temp_type, gnu_stmt, + gnu_temp = create_init_temporary ("A", gnu_name, &gnu_stmt, + gnat_actual); + gnu_name = build_compound_expr (TREE_TYPE (gnu_name), gnu_stmt, gnu_temp); } @@ -4931,16 +4943,8 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target, (TREE_OPERAND (TREE_OPERAND (gnu_orig, 1), 1))) gnu_orig = TREE_OPERAND (gnu_orig, 2); - if (Present (gnat_smo) - && Present (Storage_Model_Copy_To (gnat_smo))) - gnu_stmt - = build_storage_model_store (gnat_smo, gnu_orig, - gnu_temp, - TYPE_SIZE_UNIT (gnu_temp_type)); - else - gnu_stmt - = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_orig, - gnu_temp); + gnu_stmt + = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_orig, gnu_temp); set_expr_location_from_node (gnu_stmt, gnat_node); append_to_statement_list (gnu_stmt, &gnu_after_list); @@ -4951,19 +4955,12 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target, tree gnu_actual = gnu_name; /* If atomic access is required for an In or In Out actual parameter, - build the atomic load. Or else, if storage model access is required, - build the special load. */ + build the atomic load. */ if (is_true_formal_parm && !is_by_ref_formal_parm - && Ekind (gnat_formal) != E_Out_Parameter) - { - if (simple_atomic_access_required_p (gnat_actual, &aa_sync)) - gnu_actual = build_atomic_load (gnu_actual, aa_sync); - - else if (Present (gnat_smo) - && Present (Storage_Model_Copy_From (gnat_smo))) - gnu_actual = build_storage_model_load (gnat_smo, gnu_actual); - } + && Ekind (gnat_formal) != E_Out_Parameter + && simple_atomic_access_required_p (gnat_actual, &aa_sync)) + gnu_actual = build_atomic_load (gnu_actual, aa_sync); /* If this was a procedure call, we may not have removed any padding. So do it here for the part we will use as an input, if any. */ @@ -5327,7 +5324,6 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target, } get_atomic_access (gnat_actual, &aa_type, &aa_sync); - get_storage_model_access (gnat_actual, &gnat_smo); /* If an outer atomic access is required for an actual parameter, build the load-modify-store sequence. */ @@ -5341,13 +5337,6 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target, gnu_result = build_atomic_store (gnu_actual, gnu_result, aa_sync); - /* Or else, if a storage model access is required, build the special - store. */ - else if (Present (gnat_smo) - && Present (Storage_Model_Copy_To (gnat_smo))) - gnu_result - = build_storage_model_store (gnat_smo, gnu_actual, gnu_result); - /* Otherwise build a regular assignment. */ else gnu_result = build_binary_op (MODIFY_EXPR, NULL_TREE, @@ -5422,11 +5411,10 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target, = build_load_modify_store (gnu_target, gnu_call, gnat_node); else if (atomic_access == SIMPLE_ATOMIC) gnu_call = build_atomic_store (gnu_target, gnu_call, atomic_sync); - else if (Present (gnat_storage_model) - && Present (Storage_Model_Copy_To (gnat_storage_model))) + else if (Present (gnat_smo) + && Present (Storage_Model_Copy_To (gnat_smo))) gnu_call - = build_storage_model_store (gnat_storage_model, gnu_target, - gnu_call); + = build_storage_model_store (gnat_smo, gnu_target, gnu_call); else gnu_call = build_binary_op (op_code, NULL_TREE, gnu_target, gnu_call); @@ -6139,16 +6127,9 @@ lhs_or_actual_p (Node_Id gnat_node) static bool present_in_lhs_or_actual_p (Node_Id gnat_node) { - if (lhs_or_actual_p (gnat_node)) - return true; - - const Node_Kind kind = Nkind (Parent (gnat_node)); - - if ((kind == N_Type_Conversion || kind == N_Unchecked_Type_Conversion) - && lhs_or_actual_p (Parent (gnat_node))) - return true; - - return false; + return lhs_or_actual_p (gnat_node) + || (node_is_type_conversion (Parent (gnat_node)) + && lhs_or_actual_p (Parent (gnat_node))); } /* Return true if GNAT_NODE, an unchecked type conversion, is a no-op as far @@ -6728,7 +6709,8 @@ gnat_to_gnu (Node_Id gnat_node) gnu_result = build_binary_op (ARRAY_REF, NULL_TREE, gnu_result, gnu_expr); - if (Present (gnat_smo)) + if (Present (gnat_smo) + && Present (Storage_Model_Copy_From (gnat_smo))) instantiate_load_in_array_ref (gnu_result, gnat_smo); } @@ -6773,7 +6755,8 @@ gnat_to_gnu (Node_Id gnat_node) gnu_result = build_binary_op (ARRAY_RANGE_REF, gnu_result_type, gnu_array_object, gnu_expr); - if (Present (gnat_smo)) + if (Present (gnat_smo) + && Present (Storage_Model_Copy_From (gnat_smo))) instantiate_load_in_array_ref (gnu_result, gnat_smo); /* If storage model access is required on the RHS, build the load. */ @@ -6908,7 +6891,7 @@ gnat_to_gnu (Node_Id gnat_node) && TYPE_CONTAINS_TEMPLATE_P (gnu_result_type)) gnu_aggr_type = TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (gnu_result_type))); - else if (TREE_CODE (gnu_result_type) == VECTOR_TYPE) + else if (VECTOR_TYPE_P (gnu_result_type)) gnu_aggr_type = TYPE_REPRESENTATIVE_ARRAY (gnu_result_type); else gnu_aggr_type = gnu_result_type; @@ -7127,9 +7110,9 @@ 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) + /* If the result type is larger than a word, then declare the + dependence on the libgcc routine. */ + if (TYPE_PRECISION (gnu_type) > BITS_PER_WORD) Check_Restriction_No_Dependence_On_System (Name_Gcc, gnat_node); } @@ -7146,7 +7129,7 @@ gnat_to_gnu (Node_Id 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) + && TYPE_PRECISION (gnu_type) > BITS_PER_WORD) Check_Restriction_No_Dependence_On_System (Name_Gcc, gnat_node); /* Pending generic support for efficient vector logical operations in @@ -7406,13 +7389,13 @@ gnat_to_gnu (Node_Id gnat_node) /* Otherwise we need to build the assignment statement manually. */ else { + const Node_Id gnat_name = Name (gnat_node); const Node_Id gnat_expr = Expression (gnat_node); const Node_Id gnat_inner = Nkind (gnat_expr) == N_Qualified_Expression ? Expression (gnat_expr) : gnat_expr; - const Entity_Id gnat_type - = Underlying_Type (Etype (Name (gnat_node))); + const Entity_Id gnat_type = Underlying_Type (Etype (gnat_name)); const bool use_memset_p = Is_Array_Type (gnat_type) && Nkind (gnat_inner) == N_Aggregate @@ -7437,8 +7420,8 @@ gnat_to_gnu (Node_Id gnat_node) gigi_checking_assert (!Do_Range_Check (gnat_expr)); - get_atomic_access (Name (gnat_node), &aa_type, &aa_sync); - get_storage_model_access (Name (gnat_node), &gnat_smo); + get_atomic_access (gnat_name, &aa_type, &aa_sync); + get_storage_model_access (gnat_name, &gnat_smo); /* If an outer atomic access is required on the LHS, build the load- modify-store sequence. */ @@ -7455,39 +7438,26 @@ gnat_to_gnu (Node_Id gnat_node) else if (Present (gnat_smo) && Present (Storage_Model_Copy_To (gnat_smo))) { + tree gnu_size; + /* We obviously cannot use memset in this case. */ gcc_assert (!use_memset_p); - tree t = remove_conversions (gnu_rhs, false); - - /* If a storage model load is present on the RHS then instantiate - the temporary associated with it now, lest it be of variable - size and thus could not be instantiated by gimplification. */ - if (TREE_CODE (t) == LOAD_EXPR) + /* If this is a dereference with a special dynamic constrained + subtype on the node, use it to compute the size. */ + if (Nkind (gnat_name) == N_Explicit_Dereference + && Present (Actual_Designated_Subtype (gnat_name))) { - t = TREE_OPERAND (t, 1); - gcc_assert (TREE_CODE (t) == CALL_EXPR); - - tree elem - = build_nonstandard_integer_type (BITS_PER_UNIT, 1); - tree size = fold_convert (sizetype, CALL_EXPR_ARG (t, 3)); - tree index = build_index_type (size); - tree temp - = create_temporary ("L", build_array_type (elem, index)); - tree arg = CALL_EXPR_ARG (t, 1); - CALL_EXPR_ARG (t, 1) - = build_unary_op (ADDR_EXPR, TREE_TYPE (arg), temp); - - start_stmt_group (); - add_stmt (t); - t = build_storage_model_store (gnat_smo, gnu_lhs, temp); - add_stmt (t); - gnu_result = end_stmt_group (); + tree gnu_actual_obj_type + = gnat_to_gnu_type (Actual_Designated_Subtype (gnat_name)); + gnu_size = TYPE_SIZE_UNIT (gnu_actual_obj_type); } - else - gnu_result - = build_storage_model_store (gnat_smo, gnu_lhs, gnu_rhs); + gnu_size = NULL_TREE; + + gnu_result + = build_storage_model_store (gnat_smo, gnu_lhs, gnu_rhs, + gnu_size); } /* Or else, use memset when the conditions are met. This has already @@ -7740,7 +7710,7 @@ gnat_to_gnu (Node_Id gnat_node) gnu_result = build2 (INIT_EXPR, void_type_node, gnu_ret_deref, gnu_ret_val); /* Avoid a useless copy with __builtin_return_slot. */ - if (TREE_CODE (gnu_ret_val) == INDIRECT_REF) + if (INDIRECT_REF_P (gnu_ret_val)) gnu_result = build3 (COND_EXPR, void_type_node, fold_build2 (NE_EXPR, boolean_type_node, @@ -8415,7 +8385,7 @@ gnat_to_gnu (Node_Id gnat_node) /* If we're supposed to return something of void_type, it means we have something we're elaborating for effect, so just return. */ - if (TREE_CODE (gnu_result_type) == VOID_TYPE) + if (VOID_TYPE_P (gnu_result_type)) return gnu_result; /* If the result is a constant that overflowed, raise Constraint_Error. */ @@ -8588,7 +8558,7 @@ gnat_to_gnu_external (Node_Id gnat_node) current_function_decl = NULL_TREE; /* Do not import locations from external units. */ - if (gnu_result && EXPR_P (gnu_result)) + if (CAN_HAVE_LOCATION_P (gnu_result)) SET_EXPR_LOCATION (gnu_result, UNKNOWN_LOCATION); return gnu_result; @@ -8722,7 +8692,7 @@ add_decl_expr (tree gnu_decl, Node_Id gnat_node) Note that walk_tree knows how to deal with TYPE_DECL, but neither VAR_DECL nor CONST_DECL. This appears to be somewhat arbitrary. */ MARK_VISITED (gnu_stmt); - if (TREE_CODE (gnu_decl) == VAR_DECL + if (VAR_P (gnu_decl) || TREE_CODE (gnu_decl) == CONST_DECL) { MARK_VISITED (DECL_SIZE (gnu_decl)); @@ -8739,7 +8709,7 @@ add_decl_expr (tree gnu_decl, Node_Id gnat_node) && !TYPE_FAT_POINTER_P (type)) MARK_VISITED (TYPE_ADA_SIZE (type)); - if (TREE_CODE (gnu_decl) == VAR_DECL && (gnu_init = DECL_INITIAL (gnu_decl))) + if (VAR_P (gnu_decl) && (gnu_init = DECL_INITIAL (gnu_decl))) { /* If this is a variable and an initializer is attached to it, it must be valid for the context. Similar to init_const in create_var_decl. */ @@ -9000,7 +8970,7 @@ gnat_gimplify_expr (tree *expr_p, gimple_seq *pre_p, /* The expressions for the RM bounds must be gimplified to ensure that they are properly elaborated. See gimplify_decl_expr. */ - if ((TREE_CODE (op) == TYPE_DECL || TREE_CODE (op) == VAR_DECL) + if ((TREE_CODE (op) == TYPE_DECL || VAR_P (op)) && !TYPE_SIZES_GIMPLIFIED (TREE_TYPE (op)) && (INTEGRAL_TYPE_P (TREE_TYPE (op)) || SCALAR_FLOAT_TYPE_P (TREE_TYPE (op)))) @@ -9032,7 +9002,7 @@ gnat_gimplify_expr (tree *expr_p, gimple_seq *pre_p, || TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE) *expr_p = build_unary_op (INDIRECT_REF, NULL_TREE, convert (build_pointer_type (type), - integer_zero_node)); + null_pointer_node)); /* Otherwise, just make a VAR_DECL. */ else diff --git a/gcc/ada/gcc-interface/utils.cc b/gcc/ada/gcc-interface/utils.cc index 392ec0b..8f1861b 100644 --- a/gcc/ada/gcc-interface/utils.cc +++ b/gcc/ada/gcc-interface/utils.cc @@ -1562,6 +1562,7 @@ maybe_pad_type (tree type, tree size, unsigned int align, at the RTL level when the stand-alone object is accessed as a whole. */ if (align > 0 && RECORD_OR_UNION_TYPE_P (type) + && !TYPE_IS_FAT_POINTER_P (type) && TYPE_MODE (type) == BLKmode && !TYPE_BY_REFERENCE_P (type) && TREE_CODE (orig_size) == INTEGER_CST @@ -2802,7 +2803,7 @@ create_var_decl (tree name, tree asm_name, tree type, tree init, if (TREE_CODE (inner) == ADDR_EXPR && ((TREE_CODE (TREE_OPERAND (inner, 0)) == CALL_EXPR && !call_is_atomic_load (TREE_OPERAND (inner, 0))) - || (TREE_CODE (TREE_OPERAND (inner, 0)) == VAR_DECL + || (VAR_P (TREE_OPERAND (inner, 0)) && DECL_RETURN_VALUE_P (TREE_OPERAND (inner, 0))))) DECL_RETURN_VALUE_P (var_decl) = 1; } @@ -2853,7 +2854,7 @@ create_var_decl (tree name, tree asm_name, tree type, tree init, support global BSS sections, uninitialized global variables would go in DATA instead, thus increasing the size of the executable. */ if (!flag_no_common - && TREE_CODE (var_decl) == VAR_DECL + && VAR_P (var_decl) && TREE_PUBLIC (var_decl) && !have_global_bss_p ()) DECL_COMMON (var_decl) = 1; @@ -2871,13 +2872,13 @@ create_var_decl (tree name, tree asm_name, tree type, tree init, DECL_IGNORED_P (var_decl) = 1; /* ??? Some attributes cannot be applied to CONST_DECLs. */ - if (TREE_CODE (var_decl) == VAR_DECL) + if (VAR_P (var_decl)) process_attributes (&var_decl, &attr_list, true, gnat_node); /* Add this decl to the current binding level. */ gnat_pushdecl (var_decl, gnat_node); - if (TREE_CODE (var_decl) == VAR_DECL && asm_name) + if (VAR_P (var_decl) && asm_name) { /* Let the target mangle the name if this isn't a verbatim asm. */ if (*IDENTIFIER_POINTER (asm_name) != '*') @@ -5543,7 +5544,7 @@ unchecked_convert (tree type, tree expr, bool notrunc_p) } } - /* Likewise if we are converting from a fixed-szie type to a type with self- + /* Likewise if we are converting from a fixed-size type to a type with self- referential size. We use the max size to do the padding in this case. */ else if (!INDIRECT_REF_P (expr) && TREE_CODE (expr) != STRING_CST diff --git a/gcc/ada/gcc-interface/utils2.cc b/gcc/ada/gcc-interface/utils2.cc index 6c17675..95bbce2 100644 --- a/gcc/ada/gcc-interface/utils2.cc +++ b/gcc/ada/gcc-interface/utils2.cc @@ -68,7 +68,7 @@ get_base_type (tree type) while (TREE_TYPE (type) && (TREE_CODE (type) == INTEGER_TYPE - || TREE_CODE (type) == REAL_TYPE)) + || SCALAR_FLOAT_TYPE_P (type))) type = TREE_TYPE (type); return type; @@ -692,13 +692,14 @@ build_atomic_load (tree src, bool sync) = build_int_cst (integer_type_node, sync ? MEMMODEL_SEQ_CST : MEMMODEL_RELAXED); tree orig_src = src; - tree t, addr, val; + tree type, t, addr, val; unsigned int size; int fncode; /* Remove conversions to get the address of the underlying object. */ src = remove_conversions (src, false); - size = resolve_atomic_size (TREE_TYPE (src)); + type = TREE_TYPE (src); + size = resolve_atomic_size (type); if (size == 0) return orig_src; @@ -710,7 +711,7 @@ build_atomic_load (tree src, bool sync) /* First reinterpret the loaded bits in the original type of the load, then convert to the expected result type. */ - t = fold_build1 (VIEW_CONVERT_EXPR, TREE_TYPE (src), val); + t = fold_build1 (VIEW_CONVERT_EXPR, type, val); return convert (TREE_TYPE (orig_src), t); } @@ -728,13 +729,14 @@ build_atomic_store (tree dest, tree src, bool sync) = build_int_cst (integer_type_node, sync ? MEMMODEL_SEQ_CST : MEMMODEL_RELAXED); tree orig_dest = dest; - tree t, int_type, addr; + tree type, t, int_type, addr; unsigned int size; int fncode; /* Remove conversions to get the address of the underlying object. */ dest = remove_conversions (dest, false); - size = resolve_atomic_size (TREE_TYPE (dest)); + type = TREE_TYPE (dest); + size = resolve_atomic_size (type); if (size == 0) return build_binary_op (MODIFY_EXPR, NULL_TREE, orig_dest, src); @@ -746,12 +748,11 @@ build_atomic_store (tree dest, tree src, bool sync) then reinterpret them in the effective type. But if the original type is a padded type with the same size, convert to the inner type instead, as we don't want to artificially introduce a CONSTRUCTOR here. */ - if (TYPE_IS_PADDING_P (TREE_TYPE (dest)) - && TYPE_SIZE (TREE_TYPE (dest)) - == TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (dest))))) - src = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (dest))), src); + if (TYPE_IS_PADDING_P (type) + && TYPE_SIZE (type) == TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (type)))) + src = convert (TREE_TYPE (TYPE_FIELDS (type)), src); else - src = convert (TREE_TYPE (dest), src); + src = convert (type, src); src = fold_build1 (VIEW_CONVERT_EXPR, int_type, src); addr = build_unary_op (ADDR_EXPR, ptr_type, dest); @@ -877,7 +878,8 @@ build_binary_op (enum tree_code op_code, tree result_type, them; we'll be putting them back below if needed. Likewise for conversions between record types, except for justified modular types. But don't do this if the right operand is not BLKmode (for packed - arrays) unless we are not changing the mode. */ + arrays) unless we are not changing the mode, or if both ooperands + are view conversions to the same type. */ while ((CONVERT_EXPR_P (left_operand) || TREE_CODE (left_operand) == VIEW_CONVERT_EXPR) && (((INTEGRAL_TYPE_P (left_type) @@ -889,7 +891,10 @@ build_binary_op (enum tree_code op_code, tree result_type, && TREE_CODE (operand_type (left_operand)) == RECORD_TYPE && (TYPE_MODE (right_type) == BLKmode || TYPE_MODE (left_type) - == TYPE_MODE (operand_type (left_operand)))))) + == TYPE_MODE (operand_type (left_operand))) + && !(TREE_CODE (left_operand) == VIEW_CONVERT_EXPR + && TREE_CODE (right_operand) == VIEW_CONVERT_EXPR + && left_type == right_type)))) { left_operand = TREE_OPERAND (left_operand, 0); left_type = TREE_TYPE (left_operand); @@ -986,7 +991,7 @@ build_binary_op (enum tree_code op_code, tree result_type, break; } - gcc_assert (TREE_CODE (result) == INDIRECT_REF + gcc_assert (INDIRECT_REF_P (result) || TREE_CODE (result) == NULL_EXPR || TREE_CODE (result) == SAVE_EXPR || DECL_P (result)); @@ -1423,7 +1428,7 @@ build_unary_op (enum tree_code op_code, tree result_type, tree operand) the corresponding address, e.g. for an allocator. However do it for a return value to expose it for later recognition. */ if (TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE - || (TREE_CODE (TREE_OPERAND (operand, 1)) == VAR_DECL + || (VAR_P (TREE_OPERAND (operand, 1)) && DECL_RETURN_VALUE_P (TREE_OPERAND (operand, 1)))) { result = build_unary_op (ADDR_EXPR, result_type, @@ -1597,11 +1602,11 @@ build_unary_op (enum tree_code op_code, tree result_type, tree operand) if (!TYPE_IS_FAT_POINTER_P (type) && TYPE_VOLATILE (TREE_TYPE (type))) { TREE_SIDE_EFFECTS (result) = 1; - if (TREE_CODE (result) == INDIRECT_REF) + if (INDIRECT_REF_P (result)) TREE_THIS_VOLATILE (result) = TYPE_VOLATILE (TREE_TYPE (result)); } - if ((TREE_CODE (result) == INDIRECT_REF + if ((INDIRECT_REF_P (result) || TREE_CODE (result) == UNCONSTRAINED_ARRAY_REF) && can_never_be_null) TREE_THIS_NOTRAP (result) = 1; @@ -2926,7 +2931,7 @@ gnat_protect_expr (tree exp) /* Likewise if we're indirectly referencing part of something. */ if (code == COMPONENT_REF - && TREE_CODE (TREE_OPERAND (exp, 0)) == INDIRECT_REF) + && INDIRECT_REF_P (TREE_OPERAND (exp, 0))) return build3 (code, type, gnat_protect_expr (TREE_OPERAND (exp, 0)), TREE_OPERAND (exp, 1), NULL_TREE); @@ -3263,7 +3268,7 @@ gnat_invariant_expr (tree expr) /* Look through temporaries created to capture values. */ while ((TREE_CODE (expr) == CONST_DECL - || (TREE_CODE (expr) == VAR_DECL && TREE_READONLY (expr))) + || (VAR_P (expr) && TREE_READONLY (expr))) && decl_function_context (expr) == current_function_decl && DECL_INITIAL (expr)) { @@ -3362,7 +3367,7 @@ object: if (TREE_CODE (t) == PARM_DECL) return fold_convert (type, expr); - if (TREE_CODE (t) == VAR_DECL + if (VAR_P (t) && (DECL_EXTERNAL (t) || decl_function_context (t) != current_function_decl)) return fold_convert (type, expr); diff --git a/gcc/ada/gen_il-fields.ads b/gcc/ada/gen_il-fields.ads index 458219c..a017f45 100644 --- a/gcc/ada/gen_il-fields.ads +++ b/gcc/ada/gen_il-fields.ads @@ -87,6 +87,7 @@ package Gen_IL.Fields is Body_Required, Body_To_Inline, Box_Present, + Cannot_Be_Superflat, Char_Literal_Value, Chars, Check_Address_Alignment, @@ -209,6 +210,7 @@ package Gen_IL.Fields is Has_Pragma_Suppress_All, Has_Private_View, Has_Relative_Deadline_Pragma, + Has_Secondary_Private_View, Has_Self_Reference, Has_SP_Choice, Has_Storage_Size_Pragma, @@ -320,9 +322,9 @@ package Gen_IL.Fields is No_Ctrl_Actions, No_Elaboration_Check, No_Entities_Ref_In_Spec, + No_Finalize_Actions, No_Initialization, No_Minimize_Eliminate, - No_Side_Effect_Removal, No_Truncation, Null_Excluding_Subtype, Null_Exclusion_Present, @@ -489,7 +491,6 @@ package Gen_IL.Fields is Default_Expressions_Processed, Default_Value, Delay_Cleanups, - Delay_Subprogram_Descriptors, Delta_Value, Dependent_Instances, Depends_On_Private, @@ -578,6 +579,7 @@ package Gen_IL.Fields is Has_Expanded_Contract, Has_Forward_Instantiation, Has_Fully_Qualified_Name, + Has_Ghost_Predicate_Aspect, Has_Gigi_Rep_Item, Has_Homonym, Has_Implicit_Dereference, @@ -751,6 +753,7 @@ package Gen_IL.Fields is Is_Package_Body_Entity, Is_Packed, Is_Packed_Array_Impl_Type, + Is_Not_Self_Hidden, Is_Param_Block_Component_Type, Is_Partial_Invariant_Procedure, Is_Potentially_Use_Visible, diff --git a/gcc/ada/gen_il-gen-gen_entities.adb b/gcc/ada/gen_il-gen-gen_entities.adb index 51d33d3..f980ba2 100644 --- a/gcc/ada/gen_il-gen-gen_entities.adb +++ b/gcc/ada/gen_il-gen-gen_entities.adb @@ -57,7 +57,6 @@ begin -- Gen_IL.Gen.Gen_Entities Sm (Debug_Info_Off, Flag), Sm (Default_Expressions_Processed, Flag), Sm (Delay_Cleanups, Flag), - Sm (Delay_Subprogram_Descriptors, Flag), Sm (Depends_On_Private, Flag), Sm (Disable_Controlled, Flag, Base_Type_Only), Sm (Discard_Names, Flag), @@ -177,6 +176,7 @@ begin -- Gen_IL.Gen.Gen_Entities Sm (Is_Package_Body_Entity, Flag), Sm (Is_Packed, Flag, Impl_Base_Type_Only), Sm (Is_Packed_Array_Impl_Type, Flag), + Sm (Is_Not_Self_Hidden, Flag), Sm (Is_Potentially_Use_Visible, Flag), Sm (Is_Preelaborated, Flag), Sm (Is_Private_Descendant, Flag), @@ -249,6 +249,8 @@ begin -- Gen_IL.Gen.Gen_Entities -- resolution on calls). (Sm (Alignment, Unat), Sm (Contract, Node_Id), + Sm (First_Entity, Node_Id), + Sm (Last_Entity, Node_Id), Sm (Is_Elaboration_Warnings_OK_Id, Flag), Sm (Original_Record_Component, Node_Id), Sm (Scope_Depth_Value, Unat), @@ -284,14 +286,12 @@ begin -- Gen_IL.Gen.Gen_Entities Sm (Esize, Uint), Sm (RM_Size, Uint), Sm (Extra_Formal, Node_Id), - Sm (First_Entity, Node_Id), Sm (Generic_Homonym, Node_Id), Sm (Generic_Renamings, Elist_Id), Sm (Handler_Records, List_Id), Sm (Has_Static_Discriminants, Flag), Sm (Inner_Instances, Elist_Id), Sm (Interface_Name, Node_Id), - Sm (Last_Entity, Node_Id), Sm (Next_Inlined_Subprogram, Node_Id), Sm (Renamed_Or_Alias, Node_Id), -- See Einfo.Utils Sm (Return_Applies_To, Node_Id), @@ -467,6 +467,8 @@ begin -- Gen_IL.Gen.Gen_Entities Sm (Predicates_Ignored, Flag), Sm (Esize, Uint), Sm (Finalize_Storage_Only, Flag, Base_Type_Only), + Sm (First_Entity, Node_Id), + Sm (Last_Entity, Node_Id), Sm (Full_View, Node_Id), Sm (Has_Completion_In_Body, Flag), Sm (Has_Constrained_Partial_View, Flag, Base_Type_Only), @@ -474,6 +476,7 @@ begin -- Gen_IL.Gen.Gen_Entities Sm (Has_Dispatch_Table, Flag, Pre => "Is_Tagged_Type (N)"), Sm (Has_Dynamic_Predicate_Aspect, Flag), + Sm (Has_Ghost_Predicate_Aspect, Flag), Sm (Has_Inheritable_Invariants, Flag, Base_Type_Only), Sm (Has_Inherited_DIC, Flag, Base_Type_Only), Sm (Has_Inherited_Invariants, Flag, Base_Type_Only), @@ -525,7 +528,8 @@ begin -- Gen_IL.Gen.Gen_Entities Sm (Subprograms_For_Type, Elist_Id), Sm (Suppress_Initialization, Flag), Sm (Universal_Aliasing, Flag, Impl_Base_Type_Only), - Sm (Renamed_Or_Alias, Node_Id))); + Sm (Renamed_Or_Alias, Node_Id), + Sm (Stored_Constraint, Elist_Id))); Ab (Elementary_Kind, Type_Kind); @@ -550,8 +554,7 @@ begin -- Gen_IL.Gen.Gen_Entities Cc (E_Enumeration_Type, Enumeration_Kind, -- Enumeration types, created by an enumeration type declaration - (Sm (Enum_Pos_To_Rep, Node_Id), - Sm (First_Entity, Node_Id))); + (Sm (Enum_Pos_To_Rep, Node_Id))); Cc (E_Enumeration_Subtype, Enumeration_Kind); -- Enumeration subtypes, created by an explicit or implicit subtype @@ -560,8 +563,7 @@ begin -- Gen_IL.Gen.Gen_Entities Ab (Integer_Kind, Discrete_Kind, (Sm (Has_Shift_Operator, Flag, Base_Type_Only))); - Ab (Signed_Integer_Kind, Integer_Kind, - (Sm (First_Entity, Node_Id))); + Ab (Signed_Integer_Kind, Integer_Kind); Cc (E_Signed_Integer_Type, Signed_Integer_Kind); -- Signed integer type, used for the anonymous base type of the @@ -669,10 +671,9 @@ begin -- Gen_IL.Gen.Gen_Entities -- context does not provide one, the backend will see Allocator_Type -- itself (which will already have been frozen). - Cc (E_General_Access_Type, Access_Kind, + Cc (E_General_Access_Type, Access_Kind); -- An access type created by an access type declaration with the all -- keyword present. - (Sm (First_Entity, Node_Id))); Ab (Access_Subprogram_Kind, Access_Kind); @@ -728,14 +729,12 @@ begin -- Gen_IL.Gen.Gen_Entities Cc (E_Array_Type, Array_Kind, -- An array type created by an array type declaration. Includes all -- cases of arrays, except for string types. - (Sm (First_Entity, Node_Id), - Sm (Static_Real_Or_String_Predicate, Node_Id))); + (Sm (Static_Real_Or_String_Predicate, Node_Id))); Cc (E_Array_Subtype, Array_Kind, -- An array subtype, created by an explicit array subtype declaration, -- or the use of an anonymous array subtype. (Sm (Predicated_Parent, Node_Id), - Sm (First_Entity, Node_Id), Sm (Static_Real_Or_String_Predicate, Node_Id))); Cc (E_String_Literal_Subtype, Array_Kind, @@ -747,16 +746,13 @@ begin -- Gen_IL.Gen.Gen_Entities Ab (Class_Wide_Kind, Aggregate_Kind, (Sm (C_Pass_By_Copy, Flag, Impl_Base_Type_Only), Sm (Equivalent_Type, Node_Id), - Sm (First_Entity, Node_Id), Sm (Has_Complex_Representation, Flag, Impl_Base_Type_Only), Sm (Has_Record_Rep_Clause, Flag, Impl_Base_Type_Only), Sm (Interfaces, Elist_Id), - Sm (Last_Entity, Node_Id), Sm (No_Reordering, Flag, Impl_Base_Type_Only), Sm (Non_Limited_View, Node_Id), Sm (Parent_Subtype, Node_Id, Base_Type_Only), - Sm (Reverse_Bit_Order, Flag, Base_Type_Only), - Sm (Stored_Constraint, Elist_Id))); + Sm (Reverse_Bit_Order, Flag, Base_Type_Only))); Cc (E_Class_Wide_Type, Class_Wide_Kind, -- A class wide type, created by any tagged type declaration (i.e. if @@ -778,15 +774,12 @@ begin -- Gen_IL.Gen.Gen_Entities Sm (Corresponding_Concurrent_Type, Node_Id), Sm (Corresponding_Remote_Type, Node_Id), Sm (Dispatch_Table_Wrappers, Elist_Id, Impl_Base_Type_Only), - Sm (First_Entity, Node_Id), Sm (Has_Complex_Representation, Flag, Impl_Base_Type_Only), Sm (Has_Record_Rep_Clause, Flag, Impl_Base_Type_Only), Sm (Interfaces, Elist_Id), - Sm (Last_Entity, Node_Id), Sm (No_Reordering, Flag, Impl_Base_Type_Only), Sm (Parent_Subtype, Node_Id, Base_Type_Only), Sm (Reverse_Bit_Order, Flag, Base_Type_Only), - Sm (Stored_Constraint, Elist_Id), Sm (Underlying_Record_View, Node_Id))); Cc (E_Record_Subtype, Aggregate_Kind, @@ -798,22 +791,16 @@ begin -- Gen_IL.Gen.Gen_Entities Sm (Corresponding_Remote_Type, Node_Id), Sm (Predicated_Parent, Node_Id), Sm (Dispatch_Table_Wrappers, Elist_Id, Impl_Base_Type_Only), - Sm (First_Entity, Node_Id), Sm (Has_Complex_Representation, Flag, Impl_Base_Type_Only), Sm (Has_Record_Rep_Clause, Flag, Impl_Base_Type_Only), Sm (Interfaces, Elist_Id), - Sm (Last_Entity, Node_Id), Sm (No_Reordering, Flag, Impl_Base_Type_Only), Sm (Parent_Subtype, Node_Id, Base_Type_Only), Sm (Reverse_Bit_Order, Flag, Base_Type_Only), - Sm (Stored_Constraint, Elist_Id), Sm (Underlying_Record_View, Node_Id))); Ab (Incomplete_Or_Private_Kind, Composite_Kind, - (Sm (First_Entity, Node_Id), - Sm (Last_Entity, Node_Id), - Sm (Private_Dependents, Elist_Id), - Sm (Stored_Constraint, Elist_Id))); + (Sm (Private_Dependents, Elist_Id))); Ab (Private_Kind, Incomplete_Or_Private_Kind, (Sm (Underlying_Full_View, Node_Id))); @@ -893,11 +880,8 @@ begin -- Gen_IL.Gen.Gen_Entities Ab (Concurrent_Kind, Composite_Kind, (Sm (Corresponding_Record_Type, Node_Id), - Sm (First_Entity, Node_Id), Sm (First_Private_Entity, Node_Id), - Sm (Last_Entity, Node_Id), - Sm (Scope_Depth_Value, Unat), - Sm (Stored_Constraint, Elist_Id))); + Sm (Scope_Depth_Value, Unat))); Ab (Task_Kind, Concurrent_Kind, (Sm (Has_Storage_Size_Clause, Flag, Impl_Base_Type_Only), @@ -951,8 +935,6 @@ begin -- Gen_IL.Gen.Gen_Entities (Sm (Access_Subprogram_Wrapper, Node_Id), Sm (Extra_Accessibility_Of_Result, Node_Id), Sm (Extra_Formals, Node_Id), - Sm (First_Entity, Node_Id), - Sm (Last_Entity, Node_Id), Sm (Needs_No_Actuals, Flag))); Ab (Overloadable_Kind, Entity_Kind, @@ -1243,6 +1225,7 @@ begin -- Gen_IL.Gen.Gen_Entities -- implicit label declaration, not the occurrence of the label itself, -- which is simply a direct name referring to the label. (Sm (Enclosing_Scope, Node_Id), + Sm (Entry_Cancel_Parameter, Node_Id), Sm (Reachable, Flag), Sm (Renamed_Or_Alias, Node_Id))); diff --git a/gcc/ada/gen_il-gen-gen_nodes.adb b/gcc/ada/gen_il-gen-gen_nodes.adb index 389c9a0..2ad6e60 100644 --- a/gcc/ada/gen_il-gen-gen_nodes.adb +++ b/gcc/ada/gen_il-gen-gen_nodes.adb @@ -170,13 +170,15 @@ begin -- Gen_IL.Gen.Gen_Nodes Sy (Selector_Name, Node_Id, Default_Empty), Sm (Atomic_Sync_Required, Flag), Sm (Has_Private_View, Flag), + Sm (Has_Secondary_Private_View, Flag), Sm (Is_Elaboration_Checks_OK_Node, Flag), Sm (Is_Elaboration_Warnings_OK_Node, Flag), Sm (Is_SPARK_Mode_On_Node, Flag), Sm (Redundant_Use, Flag))); Ab (N_Direct_Name, N_Has_Entity, - (Sm (Has_Private_View, Flag))); + (Sm (Has_Private_View, Flag), + Sm (Has_Secondary_Private_View, Flag))); Cc (N_Identifier, N_Direct_Name, (Sy (Chars, Name_Id, Default_No_Name), @@ -197,7 +199,8 @@ begin -- Gen_IL.Gen.Gen_Nodes Ab (N_Op, N_Has_Entity, (Sm (Do_Overflow_Check, Flag), - Sm (Has_Private_View, Flag))); + Sm (Has_Private_View, Flag), + Sm (Has_Secondary_Private_View, Flag))); Ab (N_Binary_Op, N_Op); @@ -401,8 +404,7 @@ begin -- Gen_IL.Gen.Gen_Nodes Cc (N_Function_Call, N_Subprogram_Call, (Sy (Name, Node_Id, Default_Empty), Sy (Parameter_Associations, List_Id, Default_No_List), - Sm (Is_Expanded_Build_In_Place_Call, Flag), - Sm (No_Side_Effect_Removal, Flag))); + Sm (Is_Expanded_Build_In_Place_Call, Flag))); Cc (N_Procedure_Call_Statement, N_Subprogram_Call, (Sy (Name, Node_Id, Default_Empty), @@ -531,7 +533,8 @@ begin -- Gen_IL.Gen.Gen_Nodes Cc (N_Range, N_Subexpr, (Sy (Low_Bound, Node_Id), Sy (High_Bound, Node_Id), - Sy (Includes_Infinities, Flag))); + Sm (Cannot_Be_Superflat, Flag), + Sm (Includes_Infinities, Flag))); Cc (N_Reference, N_Subexpr, (Sy (Prefix, Node_Id))); @@ -969,6 +972,7 @@ begin -- Gen_IL.Gen.Gen_Nodes Sm (Is_Elaboration_Code, Flag), Sm (Is_SPARK_Mode_On_Node, Flag), Sm (No_Ctrl_Actions, Flag), + Sm (No_Finalize_Actions, Flag), Sm (Suppress_Assignment_Checks, Flag))); Cc (N_Asynchronous_Select, N_Statement_Other_Than_Procedure_Call, @@ -1344,7 +1348,8 @@ begin -- Gen_IL.Gen.Gen_Nodes 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 (Activation_Chain_Entity, Node_Id), + Sm (Corresponding_Spec, Node_Id))); Cc (N_Entry_Call_Alternative, Node_Kind, (Sy (Entry_Call_Statement, Node_Id), @@ -1604,7 +1609,7 @@ begin -- Gen_IL.Gen.Gen_Nodes Sm (Dcheck_Function, Node_Id), Sm (Enclosing_Variant, Node_Id), Sm (Has_SP_Choice, Flag), - Sm (Present_Expr, Valid_Uint))); + Sm (Present_Expr, Uint))); Cc (N_Variant_Part, Node_Kind, (Sy (Name, Node_Id, Default_Empty), diff --git a/gcc/ada/get_targ.adb b/gcc/ada/get_targ.adb index b2b8932..3422899 100644 --- a/gcc/ada/get_targ.adb +++ b/gcc/ada/get_targ.adb @@ -279,15 +279,6 @@ package body Get_Targ is end Get_Back_End_Config_File; ----------------------------- - -- Get_Max_Unaligned_Field -- - ----------------------------- - - function Get_Max_Unaligned_Field return Pos is - begin - return 64; -- Can be different on some targets - end Get_Max_Unaligned_Field; - - ----------------------------- -- Register_Back_End_Types -- ----------------------------- diff --git a/gcc/ada/get_targ.ads b/gcc/ada/get_targ.ads index ef9c572..2520659 100644 --- a/gcc/ada/get_targ.ads +++ b/gcc/ada/get_targ.ads @@ -110,10 +110,6 @@ package Get_Targ is -- Other subprograms - function Get_Max_Unaligned_Field return Pos; - -- Returns the maximum supported size in bits for a field that is - -- not aligned on a storage unit boundary. - type C_String is array (0 .. 255) of aliased Character; pragma Convention (C, C_String); diff --git a/gcc/ada/ghost.adb b/gcc/ada/ghost.adb index 5b3cd89..6cf87ce 100644 --- a/gcc/ada/ghost.adb +++ b/gcc/ada/ghost.adb @@ -31,7 +31,6 @@ with Einfo.Entities; use Einfo.Entities; with Einfo.Utils; use Einfo.Utils; with Elists; use Elists; with Errout; use Errout; -with Namet; use Namet; with Nlists; use Nlists; with Nmake; use Nmake; with Sem; use Sem; @@ -101,11 +100,6 @@ package body Ghost is -- mode Mode. Mark all formals parameters when N denotes a subprogram or a -- body. - function Name_To_Ghost_Mode (Mode : Name_Id) return Ghost_Mode_Type; - pragma Inline (Name_To_Ghost_Mode); - -- Convert a Ghost mode denoted by name Mode into its respective enumerated - -- value. - procedure Record_Ignored_Ghost_Node (N : Node_Or_Entity_Id); -- Save ignored Ghost node or entity N in table Ignored_Ghost_Nodes for -- later elimination. @@ -490,13 +484,15 @@ package body Ghost is -- A reference to a Ghost entity can appear within an aspect -- specification (SPARK RM 6.9(10)). The precise checking will -- occur when analyzing the corresponding pragma. We make an - -- exception for predicate aspects that only allow referencing - -- a Ghost entity when the corresponding type declaration is - -- Ghost (SPARK RM 6.9(11)). + -- exception for predicate aspects other than Ghost_Predicate + -- that only allow referencing a Ghost entity when the + -- corresponding type declaration is Ghost (SPARK RM 6.9(11)). elsif Nkind (Par) = N_Aspect_Specification - and then not Same_Aspect - (Get_Aspect_Id (Par), Aspect_Predicate) + and then + (Get_Aspect_Id (Par) = Aspect_Ghost_Predicate + or else not Same_Aspect + (Get_Aspect_Id (Par), Aspect_Predicate)) then return True; @@ -659,7 +655,9 @@ package body Ghost is -- declaration and at the point of use match. if Is_OK_Ghost_Context (Ghost_Ref) then - Check_Ghost_Policy (Ghost_Id, Ghost_Ref); + if Present (Ghost_Id) then + Check_Ghost_Policy (Ghost_Id, Ghost_Ref); + end if; -- Otherwise the Ghost entity appears in a non-Ghost context and affects -- its behavior or value (SPARK RM 6.9(10,11)). @@ -677,6 +675,7 @@ package body Ghost is Ghost_Ref); Error_Msg_N ("\either make the type ghost " + & "or use a Ghost_Predicate " & "or use a type invariant on a private type", Ghost_Ref); end if; end if; @@ -1198,6 +1197,16 @@ package body Ghost is return False; end Is_Ghost_Assignment; + ---------------------------------- + -- Is_Ghost_Attribute_Reference -- + ---------------------------------- + + function Is_Ghost_Attribute_Reference (N : Node_Id) return Boolean is + begin + return Nkind (N) = N_Attribute_Reference + and then Attribute_Name (N) = Name_Initialized; + end Is_Ghost_Attribute_Reference; + -------------------------- -- Is_Ghost_Declaration -- -------------------------- @@ -1877,9 +1886,22 @@ package body Ghost is -- a Ghost entity. if Is_Checked_Ghost_Entity (Id) then - Set_Is_Checked_Ghost_Pragma (N); + Mark_Ghost_Pragma (N, Check); elsif Is_Ignored_Ghost_Entity (Id) then + Mark_Ghost_Pragma (N, Ignore); + end if; + end Mark_Ghost_Pragma; + + procedure Mark_Ghost_Pragma + (N : Node_Id; + Mode : Ghost_Mode_Type) + is + begin + if Mode = Check then + Set_Is_Checked_Ghost_Pragma (N); + + else Set_Is_Ignored_Ghost_Pragma (N); Set_Is_Ignored_Ghost_Node (N); Record_Ignored_Ghost_Node (N); diff --git a/gcc/ada/ghost.ads b/gcc/ada/ghost.ads index 67ef194..663e70c 100644 --- a/gcc/ada/ghost.ads +++ b/gcc/ada/ghost.ads @@ -26,6 +26,7 @@ -- This package contains routines that deal with the static and runtime -- semantics of Ghost entities. +with Namet; use Namet; with Opt; use Opt; with Types; use Types; @@ -110,6 +111,10 @@ package Ghost is -- Determine whether arbitrary node N denotes an assignment statement whose -- target is a Ghost entity. + function Is_Ghost_Attribute_Reference (N : Node_Id) return Boolean; + -- Determine whether arbitrary node N denotes an attribute reference which + -- denotes a Ghost attribute. + function Is_Ghost_Declaration (N : Node_Id) return Boolean; -- Determine whether arbitrary node N denotes a declaration which defines -- a Ghost entity. @@ -214,6 +219,11 @@ package Ghost is -- -- * The pragma is associated with Ghost entity Id + procedure Mark_Ghost_Pragma + (N : Node_Id; + Mode : Ghost_Mode_Type); + -- Mark pragma N as Ghost with the corresponding Mode + procedure Mark_Ghost_Renaming (N : Node_Id; Id : Entity_Id); @@ -221,6 +231,11 @@ package Ghost is -- -- * Renamed entity Id denotes a Ghost entity + function Name_To_Ghost_Mode (Mode : Name_Id) return Ghost_Mode_Type; + pragma Inline (Name_To_Ghost_Mode); + -- Convert a Ghost mode denoted by name Mode into its respective enumerated + -- value. + procedure Remove_Ignored_Ghost_Code; -- Remove all code marked as ignored Ghost from the trees of all qualifying -- units (SPARK RM 6.9(4)). diff --git a/gcc/ada/gnat-style.texi b/gcc/ada/gnat-style.texi index f3b1c29..5555bcd 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 5.1.1.@* +@*Generated by Sphinx 5.2.3.@* @end ifinfo @settitle GNAT Coding Style A Guide for GNAT Developers @defindex ge @@ -19,11 +19,11 @@ @copying @quotation -GNAT Coding Style: A Guide for GNAT Developers , Aug 25, 2022 +GNAT Coding Style: A Guide for GNAT Developers , May 09, 2023 AdaCore -Copyright @copyright{} 2008-2022, Free Software Foundation +Copyright @copyright{} 2008-2023, Free Software Foundation @end quotation @end copying diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb index 2386184..e74036e 100644 --- a/gcc/ada/gnat1drv.adb +++ b/gcc/ada/gnat1drv.adb @@ -1396,6 +1396,17 @@ begin Back_End_Mode := Skip; end if; + -- Ensure that we properly register a dependency on system.ads, since + -- even if we do not semantically depend on this, Targparm has read + -- system parameters from the system.ads file. + + Lib.Writ.Ensure_System_Dependency; + + -- Add dependencies, if any, on preprocessing data file and on + -- preprocessing definition file(s). + + Prepcomp.Add_Dependencies; + -- At this stage Back_End_Mode is set to indicate if the backend should -- be called to generate code. If it is Skip, then code generation has -- been turned off, even though code was requested by the original @@ -1542,17 +1553,6 @@ begin return; end if; - -- Ensure that we properly register a dependency on system.ads, since - -- even if we do not semantically depend on this, Targparm has read - -- system parameters from the system.ads file. - - Lib.Writ.Ensure_System_Dependency; - - -- Add dependencies, if any, on preprocessing data file and on - -- preprocessing definition file(s). - - Prepcomp.Add_Dependencies; - if GNATprove_Mode then -- In GNATprove mode we're writing the ALI much earlier than usual diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index 212ed3d..a5ee992 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -19,7 +19,7 @@ @copying @quotation -GNAT Reference Manual , Dec 01, 2022 +GNAT Reference Manual , Jun 01, 2023 AdaCore @@ -77,6 +77,7 @@ included in the section entitled @ref{1,,GNU Free Documentation License}. * Specialized Needs Annexes:: * Implementation of Specific Ada Features:: * Implementation of Ada 2012 Features:: +* GNAT language extensions:: * Security Hardening Features:: * Obsolescent Features:: * Compatibility and Porting Guide:: @@ -313,6 +314,7 @@ Implementation Defined Aspects * Aspect Extensions_Visible:: * Aspect Favor_Top_Level:: * Aspect Ghost:: +* Aspect Ghost_Predicate:: * Aspect Global:: * Aspect Initial_Condition:: * Aspect Initializes:: @@ -869,6 +871,28 @@ Code Generation for Array Aggregates * Aggregates with nonstatic bounds:: * Aggregates in assignment statements:: +GNAT language extensions + +* How to activate the extended GNAT Ada superset:: +* Curated Extensions:: +* Experimental Language Extensions:: + +Curated Extensions + +* Conditional when constructs:: +* Case pattern matching:: +* Fixed lower bounds for array types and subtypes:: +* Prefixed-view notation for calls to primitive subprograms of untagged types:: +* Expression defaults for generic formal functions:: +* String interpolation:: +* Constrained attribute for generic objects:: +* Static aspect on intrinsic functions:: + +Experimental Language Extensions + +* Pragma Storage_Model:: +* Simpler accessibility model:: + Security Hardening Features * Register Scrubbing:: @@ -3597,7 +3621,7 @@ for compiling System units, as explained in the GNAT User’s Guide. @node Pragma Extensions_Allowed,Pragma Extensions_Visible,Pragma Extend_System,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-extensions-allowed}@anchor{64} +@anchor{gnat_rm/implementation_defined_pragmas id12}@anchor{64}@anchor{gnat_rm/implementation_defined_pragmas pragma-extensions-allowed}@anchor{65} @section Pragma Extensions_Allowed @@ -3613,277 +3637,19 @@ pragma Extensions_Allowed (On | Off | All); This configuration pragma enables (via the “On” or “All” argument) or disables (via the “Off” argument) the implementation extension mode; the pragma takes -precedence over the `-gnatX' and `-gnatX0' command switches. - -If an argument of “All” is specified, the latest version of the Ada language -is implemented (currently Ada 2022) and, in addition, a number -of GNAT specific extensions are recognized. These extensions are listed -below. An argument of “On” has the same effect except that only -some, not all, of the listed extensions are enabled; those extensions -are identified below. - - -@itemize * - -@item -Constrained attribute for generic objects - -The @code{Constrained} attribute is permitted for objects of -generic types. The result indicates if the corresponding actual -is constrained. - -@item -@code{Static} aspect on intrinsic functions - -The Ada 202x @code{Static} aspect can be specified on Intrinsic imported -functions and the compiler will evaluate some of these intrinsic statically, -in particular the @code{Shift_Left} and @code{Shift_Right} intrinsics. - -An Extensions_Allowed pragma argument of “On” enables this extension. - -@item -@code{[]} aggregates - -This new aggregate syntax for arrays and containers is provided under -gnatX -to experiment and confirm this new language syntax. - -@item -Additional @code{when} constructs - -In addition to the @code{exit when CONDITION} control structure, several -additional constructs are allowed following this format. Including -@code{return when CONDITION}, @code{goto when CONDITION}, and -@code{raise [with EXCEPTION_MESSAGE] when CONDITION.} - -Some examples: - -@example -return Result when Variable > 10; - -raise Program_Error with "Element is null" when Element = null; - -goto End_Of_Subprogram when Variable = -1; -@end example - -@item -Casing on composite values (aka pattern matching) - -The selector for a case statement may be of a composite type, subject to -some restrictions (described below). Aggregate syntax is used for choices -of such a case statement; however, in cases where a “normal” aggregate would -require a discrete value, a discrete subtype may be used instead; box -notation can also be used to match all values. +precedence over the @code{-gnatX} and @code{-gnatX0} command switches. -Consider this example: +If an argument of @code{"On"} is specified, the latest version of the Ada language +is implemented (currently Ada 2022) and, in addition, a curated set of GNAT +specific extensions are recognized. (See the list here +@ref{66,,here}) -@example -type Rec is record - F1, F2 : Integer; -end record; - -procedure Caser_1 (X : Rec) is -begin - case X is - when (F1 => Positive, F2 => Positive) => - Do_This; - when (F1 => Natural, F2 => <>) | (F1 => <>, F2 => Natural) => - Do_That; - when others => - Do_The_Other_Thing; - end case; -end Caser_1; -@end example - -If Caser_1 is called and both components of X are positive, then -Do_This will be called; otherwise, if either component is nonnegative -then Do_That will be called; otherwise, Do_The_Other_Thing will be called. - -If the set of values that match the choice(s) of an earlier alternative -overlaps the corresponding set of a later alternative, then the first -set shall be a proper subset of the second (and the later alternative -will not be executed if the earlier alternative “matches”). All possible -values of the composite type shall be covered. The composite type of the -selector shall be an array or record type that is neither limited -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 -choice expression is a “box” component association (which matches all -possible values for the subcomponent). This restriction applies if - - -@itemize - - -@item -the component subtype is not a record, array, or discrete type; or - -@item -the component subtype is subject to a non-static constraint or -has a predicate; or - -@item -the component type is an enumeration type that is subject to an -enumeration representation clause; or - -@item -the component type is a multidimensional array type or an -array type with a nonstatic index subtype. -@end itemize - -Support for casing on arrays (and on records that contain arrays) is -currently subject to some restrictions. Non-positional -array aggregates are not supported as (or within) case choices. Likewise -for array type and subtype names. The current implementation exceeds -compile-time capacity limits in some annoyingly common scenarios; the -message generated in such cases is usually “Capacity exceeded in compiling -case statement with composite selector type”. - -In addition, pattern bindings are supported. This is a mechanism -for binding a name to a component of a matching value for use within -an alternative of a case statement. For a component association -that occurs within a case choice, the expression may be followed by -“is <identifier>”. In the special case of a “box” component association, -the identifier may instead be provided within the box. Either of these -indicates that the given identifer denotes (a constant view of) the matching -subcomponent of the case selector. Binding is not yet supported for arrays -or subcomponents thereof. - -Consider this example (which uses type Rec from the previous example): - -@example -procedure Caser_2 (X : Rec) is -begin - case X is - when (F1 => Positive is Abc, F2 => Positive) => - Do_This (Abc) - when (F1 => Natural is N1, F2 => <N2>) | - (F1 => <N2>, F2 => Natural is N1) => - Do_That (Param_1 => N1, Param_2 => N2); - when others => - Do_The_Other_Thing; - end case; -end Caser_2; -@end example - -This example is the same as the previous one with respect to -determining whether Do_This, Do_That, or Do_The_Other_Thing will -be called. But for this version, Do_This takes a parameter and Do_That -takes two parameters. If Do_This is called, the actual parameter in the -call will be X.F1. - -If Do_That is called, the situation is more complex because there are two -choices for that alternative. If Do_That is called because the first choice -matched (i.e., because X.F1 is nonnegative and either X.F1 or X.F2 is zero -or negative), then the actual parameters of the call will be (in order) -X.F1 and X.F2. If Do_That is called because the second choice matched (and -the first one did not), then the actual parameters will be reversed. - -Within the choice list for single alternative, each choice must -define the same set of bindings and the component subtypes for -for a given identifer must all statically match. Currently, the case -of a binding for a nondiscrete component is not implemented. - -An Extensions_Allowed pragma argument of “On” enables this extension. - -@item -Fixed lower bounds for array types and subtypes - -Unconstrained array types and subtypes can be specified with a lower bound -that is fixed to a certain value, by writing an index range that uses the -syntax “<lower-bound-expression> .. <>”. This guarantees that all objects -of the type or subtype will have the specified lower bound. - -For example, a matrix type with fixed lower bounds of zero for each -dimension can be declared by the following: - -@example -type Matrix is - array (Natural range 0 .. <>, Natural range 0 .. <>) of Integer; -@end example - -Objects of type Matrix declared with an index constraint must have index -ranges starting at zero: - -@example -M1 : Matrix (0 .. 9, 0 .. 19); -M2 : Matrix (2 .. 11, 3 .. 22); -- Warning about bounds; will raise CE -@end example - -Similarly, a subtype of String can be declared that specifies the lower -bound of objects of that subtype to be 1: - -@quotation - -@example -subtype String_1 is String (1 .. <>); -@end example -@end quotation - -If a string slice is passed to a formal of subtype String_1 in a call to -a subprogram S, the slice’s bounds will “slide” so that the lower bound -is 1. Within S, the lower bound of the formal is known to be 1, so, unlike -a normal unconstrained String formal, there is no need to worry about -accounting for other possible lower-bound values. Sliding of bounds also -occurs in other contexts, such as for object declarations with an -unconstrained subtype with fixed lower bound, as well as in subtype -conversions. - -Use of this feature increases safety by simplifying code, and can also -improve the efficiency of indexing operations, since the compiler statically -knows the lower bound of unconstrained array formals when the formal’s -subtype has index ranges with static fixed lower bounds. - -An Extensions_Allowed pragma argument of “On” enables this extension. - -@item -Prefixed-view notation for calls to primitive subprograms of untagged types - -Since Ada 2005, calls to primitive subprograms of a tagged type that -have a “prefixed view” (see RM 4.1.3(9.2)) have been allowed to be -written using the form of a selected_component, with the first actual -parameter given as the prefix and the name of the subprogram as a -selector. This prefixed-view notation for calls is extended so as to -also allow such syntax for calls to primitive subprograms of untagged -types. The primitives of an untagged type T that have a prefixed view -are those where the first formal parameter of the subprogram either -is of type T or is an anonymous access parameter whose designated type -is T. For a type that has a component that happens to have the same -simple name as one of the type’s primitive subprograms, where the -component is visible at the point of a selected_component using that -name, preference is given to the component in a selected_component -(as is currently the case for tagged types with such component names). - -An Extensions_Allowed pragma argument of “On” enables this extension. - -@item -Expression defaults for generic formal functions - -The declaration of a generic formal function is allowed to specify -an expression as a default, using the syntax of an expression function. - -Here is an example of this feature: - -@example -generic - type T is private; - with function Copy (Item : T) return T is (Item); -- Defaults to Item -package Stacks is - - type Stack is limited private; - - procedure Push (S : in out Stack; X : T); -- Calls Copy on X - - function Pop (S : in out Stack) return T; -- Calls Copy to return item - -private - -- ... -end Stacks; -@end example -@end itemize +An argument of @code{"All"} has the same effect except that some extra +experimental extensions are enabled (See the list here +@ref{67,,here}) @node Pragma Extensions_Visible,Pragma External,Pragma Extensions_Allowed,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id12}@anchor{65}@anchor{gnat_rm/implementation_defined_pragmas pragma-extensions-visible}@anchor{66} +@anchor{gnat_rm/implementation_defined_pragmas id13}@anchor{68}@anchor{gnat_rm/implementation_defined_pragmas pragma-extensions-visible}@anchor{69} @section Pragma Extensions_Visible @@ -3897,7 +3663,7 @@ For the semantics of this pragma, see the entry for aspect @code{Extensions_Visi in the SPARK 2014 Reference Manual, section 6.1.7. @node Pragma External,Pragma External_Name_Casing,Pragma Extensions_Visible,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-external}@anchor{67} +@anchor{gnat_rm/implementation_defined_pragmas pragma-external}@anchor{6a} @section Pragma External @@ -3918,7 +3684,7 @@ used this pragma for exactly the same purposes as pragma @code{Export} before the latter was standardized. @node Pragma External_Name_Casing,Pragma Fast_Math,Pragma External,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-external-name-casing}@anchor{68} +@anchor{gnat_rm/implementation_defined_pragmas pragma-external-name-casing}@anchor{6b} @section Pragma External_Name_Casing @@ -4007,7 +3773,7 @@ pragma External_Name_Casing (Uppercase, Uppercase); to enforce the upper casing of all external symbols. @node Pragma Fast_Math,Pragma Favor_Top_Level,Pragma External_Name_Casing,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-fast-math}@anchor{69} +@anchor{gnat_rm/implementation_defined_pragmas pragma-fast-math}@anchor{6c} @section Pragma Fast_Math @@ -4036,7 +3802,7 @@ under control of the pragma, rather than use the preinstantiated versions. @end table @node Pragma Favor_Top_Level,Pragma Finalize_Storage_Only,Pragma Fast_Math,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id13}@anchor{6a}@anchor{gnat_rm/implementation_defined_pragmas pragma-favor-top-level}@anchor{6b} +@anchor{gnat_rm/implementation_defined_pragmas id14}@anchor{6d}@anchor{gnat_rm/implementation_defined_pragmas pragma-favor-top-level}@anchor{6e} @section Pragma Favor_Top_Level @@ -4055,7 +3821,7 @@ When this pragma is used, dynamically generated trampolines may be used on some targets for nested subprograms. See restriction @code{No_Implicit_Dynamic_Code}. @node Pragma Finalize_Storage_Only,Pragma Float_Representation,Pragma Favor_Top_Level,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-finalize-storage-only}@anchor{6c} +@anchor{gnat_rm/implementation_defined_pragmas pragma-finalize-storage-only}@anchor{6f} @section Pragma Finalize_Storage_Only @@ -4075,7 +3841,7 @@ name. Note that this pragma does not suppress Finalize calls for library-level heap-allocated objects (see pragma @code{No_Heap_Finalization}). @node Pragma Float_Representation,Pragma Ghost,Pragma Finalize_Storage_Only,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-float-representation}@anchor{6d} +@anchor{gnat_rm/implementation_defined_pragmas pragma-float-representation}@anchor{70} @section Pragma Float_Representation @@ -4110,7 +3876,7 @@ No other value of digits is permitted. @end itemize @node Pragma Ghost,Pragma Global,Pragma Float_Representation,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id14}@anchor{6e}@anchor{gnat_rm/implementation_defined_pragmas pragma-ghost}@anchor{6f} +@anchor{gnat_rm/implementation_defined_pragmas id15}@anchor{71}@anchor{gnat_rm/implementation_defined_pragmas pragma-ghost}@anchor{72} @section Pragma Ghost @@ -4124,7 +3890,7 @@ For the semantics of this pragma, see the entry for aspect @code{Ghost} in the S 2014 Reference Manual, section 6.9. @node Pragma Global,Pragma Ident,Pragma Ghost,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id15}@anchor{70}@anchor{gnat_rm/implementation_defined_pragmas pragma-global}@anchor{71} +@anchor{gnat_rm/implementation_defined_pragmas id16}@anchor{73}@anchor{gnat_rm/implementation_defined_pragmas pragma-global}@anchor{74} @section Pragma Global @@ -4149,7 +3915,7 @@ For the semantics of this pragma, see the entry for aspect @code{Global} in the SPARK 2014 Reference Manual, section 6.1.4. @node Pragma Ident,Pragma Ignore_Pragma,Pragma Global,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-ident}@anchor{72} +@anchor{gnat_rm/implementation_defined_pragmas pragma-ident}@anchor{75} @section Pragma Ident @@ -4163,7 +3929,7 @@ This pragma is identical in effect to pragma @code{Comment}. It is provided for compatibility with other Ada compilers providing this pragma. @node Pragma Ignore_Pragma,Pragma Implementation_Defined,Pragma Ident,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-ignore-pragma}@anchor{73} +@anchor{gnat_rm/implementation_defined_pragmas pragma-ignore-pragma}@anchor{76} @section Pragma Ignore_Pragma @@ -4183,7 +3949,7 @@ pragma allows such pragmas to be ignored, which may be useful in CodePeer mode, or during porting of legacy code. @node Pragma Implementation_Defined,Pragma Implemented,Pragma Ignore_Pragma,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-implementation-defined}@anchor{74} +@anchor{gnat_rm/implementation_defined_pragmas pragma-implementation-defined}@anchor{77} @section Pragma Implementation_Defined @@ -4210,7 +3976,7 @@ for the purpose of implementing the No_Implementation_Identifiers restriction. @node Pragma Implemented,Pragma Implicit_Packing,Pragma Implementation_Defined,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-implemented}@anchor{75} +@anchor{gnat_rm/implementation_defined_pragmas pragma-implemented}@anchor{78} @section Pragma Implemented @@ -4256,7 +4022,7 @@ By_Any shares the behavior of By_Entry and By_Protected_Procedure depending on the target’s overriding subprogram kind. @node Pragma Implicit_Packing,Pragma Import_Function,Pragma Implemented,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-implicit-packing}@anchor{76} +@anchor{gnat_rm/implementation_defined_pragmas pragma-implicit-packing}@anchor{79} @section Pragma Implicit_Packing @@ -4310,7 +4076,7 @@ sufficient. The use of pragma Implicit_Packing allows this record declaration to compile without an explicit pragma Pack. @node Pragma Import_Function,Pragma Import_Object,Pragma Implicit_Packing,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-import-function}@anchor{77} +@anchor{gnat_rm/implementation_defined_pragmas pragma-import-function}@anchor{7a} @section Pragma Import_Function @@ -4375,7 +4141,7 @@ notation. If the mechanism is not specified, the default mechanism is used. @node Pragma Import_Object,Pragma Import_Procedure,Pragma Import_Function,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-import-object}@anchor{78} +@anchor{gnat_rm/implementation_defined_pragmas pragma-import-object}@anchor{7b} @section Pragma Import_Object @@ -4401,7 +4167,7 @@ point of view). @code{size} is syntax checked, but otherwise ignored by GNAT. @node Pragma Import_Procedure,Pragma Import_Valued_Procedure,Pragma Import_Object,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-import-procedure}@anchor{79} +@anchor{gnat_rm/implementation_defined_pragmas pragma-import-procedure}@anchor{7c} @section Pragma Import_Procedure @@ -4441,7 +4207,7 @@ applies to a procedure rather than a function and the parameters @code{Result_Type} and @code{Result_Mechanism} are not permitted. @node Pragma Import_Valued_Procedure,Pragma Independent,Pragma Import_Procedure,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-import-valued-procedure}@anchor{7a} +@anchor{gnat_rm/implementation_defined_pragmas pragma-import-valued-procedure}@anchor{7d} @section Pragma Import_Valued_Procedure @@ -4494,7 +4260,7 @@ pragma Import that specifies the desired convention, since otherwise the default convention is Ada, which is almost certainly not what is required. @node Pragma Independent,Pragma Independent_Components,Pragma Import_Valued_Procedure,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-independent}@anchor{7b} +@anchor{gnat_rm/implementation_defined_pragmas pragma-independent}@anchor{7e} @section Pragma Independent @@ -4516,7 +4282,7 @@ constraints on the representation of the object (for instance prohibiting tight packing). @node Pragma Independent_Components,Pragma Initial_Condition,Pragma Independent,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-independent-components}@anchor{7c} +@anchor{gnat_rm/implementation_defined_pragmas pragma-independent-components}@anchor{7f} @section Pragma Independent_Components @@ -4537,7 +4303,7 @@ constraints on the representation of the object (for instance prohibiting tight packing). @node Pragma Initial_Condition,Pragma Initialize_Scalars,Pragma Independent_Components,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id16}@anchor{7d}@anchor{gnat_rm/implementation_defined_pragmas pragma-initial-condition}@anchor{7e} +@anchor{gnat_rm/implementation_defined_pragmas id17}@anchor{80}@anchor{gnat_rm/implementation_defined_pragmas pragma-initial-condition}@anchor{81} @section Pragma Initial_Condition @@ -4551,7 +4317,7 @@ For the semantics of this pragma, see the entry for aspect @code{Initial_Conditi in the SPARK 2014 Reference Manual, section 7.1.6. @node Pragma Initialize_Scalars,Pragma Initializes,Pragma Initial_Condition,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-initialize-scalars}@anchor{7f} +@anchor{gnat_rm/implementation_defined_pragmas pragma-initialize-scalars}@anchor{82} @section Pragma Initialize_Scalars @@ -4660,7 +4426,7 @@ good idea to turn on stack checking (see description of stack checking in the GNAT User’s Guide) when using this pragma. @node Pragma Initializes,Pragma Inline_Always,Pragma Initialize_Scalars,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id17}@anchor{80}@anchor{gnat_rm/implementation_defined_pragmas pragma-initializes}@anchor{81} +@anchor{gnat_rm/implementation_defined_pragmas id18}@anchor{83}@anchor{gnat_rm/implementation_defined_pragmas pragma-initializes}@anchor{84} @section Pragma Initializes @@ -4687,7 +4453,7 @@ For the semantics of this pragma, see the entry for aspect @code{Initializes} in SPARK 2014 Reference Manual, section 7.1.5. @node Pragma Inline_Always,Pragma Inline_Generic,Pragma Initializes,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id18}@anchor{82}@anchor{gnat_rm/implementation_defined_pragmas pragma-inline-always}@anchor{83} +@anchor{gnat_rm/implementation_defined_pragmas id19}@anchor{85}@anchor{gnat_rm/implementation_defined_pragmas pragma-inline-always}@anchor{86} @section Pragma Inline_Always @@ -4706,7 +4472,7 @@ apply this pragma to a primitive operation of a tagged type. Thanks to such restrictions, the compiler is allowed to remove the out-of-line body of @code{NAME}. @node Pragma Inline_Generic,Pragma Interface,Pragma Inline_Always,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-inline-generic}@anchor{84} +@anchor{gnat_rm/implementation_defined_pragmas pragma-inline-generic}@anchor{87} @section Pragma Inline_Generic @@ -4724,7 +4490,7 @@ than to check that the given names are all names of generic units or generic instances. @node Pragma Interface,Pragma Interface_Name,Pragma Inline_Generic,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-interface}@anchor{85} +@anchor{gnat_rm/implementation_defined_pragmas pragma-interface}@anchor{88} @section Pragma Interface @@ -4751,7 +4517,7 @@ maintaining Ada 83/Ada 95 compatibility and is compatible with other Ada 83 compilers. @node Pragma Interface_Name,Pragma Interrupt_Handler,Pragma Interface,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-interface-name}@anchor{86} +@anchor{gnat_rm/implementation_defined_pragmas pragma-interface-name}@anchor{89} @section Pragma Interface_Name @@ -4770,7 +4536,7 @@ for an interfaced subprogram, and is provided for compatibility with Ada least one of @code{External_Name} or @code{Link_Name}. @node Pragma Interrupt_Handler,Pragma Interrupt_State,Pragma Interface_Name,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-interrupt-handler}@anchor{87} +@anchor{gnat_rm/implementation_defined_pragmas pragma-interrupt-handler}@anchor{8a} @section Pragma Interrupt_Handler @@ -4784,7 +4550,7 @@ This program unit pragma is supported for parameterless protected procedures as described in Annex C of the Ada Reference Manual. @node Pragma Interrupt_State,Pragma Invariant,Pragma Interrupt_Handler,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-interrupt-state}@anchor{88} +@anchor{gnat_rm/implementation_defined_pragmas pragma-interrupt-state}@anchor{8b} @section Pragma Interrupt_State @@ -4870,7 +4636,7 @@ with an application’s runtime behavior in the cases of the synchronous signals and in the case of the signal used to implement the @code{abort} statement. @node Pragma Invariant,Pragma Keep_Names,Pragma Interrupt_State,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id19}@anchor{89}@anchor{gnat_rm/implementation_defined_pragmas pragma-invariant}@anchor{8a} +@anchor{gnat_rm/implementation_defined_pragmas id20}@anchor{8c}@anchor{gnat_rm/implementation_defined_pragmas pragma-invariant}@anchor{8d} @section Pragma Invariant @@ -4909,7 +4675,7 @@ For further details on the use of this pragma, see the Ada 2012 documentation of the Type_Invariant aspect. @node Pragma Keep_Names,Pragma License,Pragma Invariant,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-keep-names}@anchor{8b} +@anchor{gnat_rm/implementation_defined_pragmas pragma-keep-names}@anchor{8e} @section Pragma Keep_Names @@ -4929,7 +4695,7 @@ use a @code{Discard_Names} pragma in the @code{gnat.adc} file, but you want to retain the names for specific enumeration types. @node Pragma License,Pragma Link_With,Pragma Keep_Names,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-license}@anchor{8c} +@anchor{gnat_rm/implementation_defined_pragmas pragma-license}@anchor{8f} @section Pragma License @@ -5024,7 +4790,7 @@ GPL, but no warning for @code{GNAT.Sockets} which is part of the GNAT run time, and is therefore licensed under the modified GPL. @node Pragma Link_With,Pragma Linker_Alias,Pragma License,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-link-with}@anchor{8d} +@anchor{gnat_rm/implementation_defined_pragmas pragma-link-with}@anchor{90} @section Pragma Link_With @@ -5048,7 +4814,7 @@ separate arguments to the linker. In addition pragma Link_With allows multiple arguments, with the same effect as successive pragmas. @node Pragma Linker_Alias,Pragma Linker_Constructor,Pragma Link_With,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-linker-alias}@anchor{8e} +@anchor{gnat_rm/implementation_defined_pragmas pragma-linker-alias}@anchor{91} @section Pragma Linker_Alias @@ -5089,7 +4855,7 @@ end p; @end example @node Pragma Linker_Constructor,Pragma Linker_Destructor,Pragma Linker_Alias,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-linker-constructor}@anchor{8f} +@anchor{gnat_rm/implementation_defined_pragmas pragma-linker-constructor}@anchor{92} @section Pragma Linker_Constructor @@ -5119,7 +4885,7 @@ listed above. Where possible, the use of Stand Alone Libraries is preferable to the use of this pragma. @node Pragma Linker_Destructor,Pragma Linker_Section,Pragma Linker_Constructor,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-linker-destructor}@anchor{90} +@anchor{gnat_rm/implementation_defined_pragmas pragma-linker-destructor}@anchor{93} @section Pragma Linker_Destructor @@ -5142,7 +4908,7 @@ See @code{pragma Linker_Constructor} for the set of restrictions that apply because of these specific contexts. @node Pragma Linker_Section,Pragma Lock_Free,Pragma Linker_Destructor,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id20}@anchor{91}@anchor{gnat_rm/implementation_defined_pragmas pragma-linker-section}@anchor{92} +@anchor{gnat_rm/implementation_defined_pragmas id21}@anchor{94}@anchor{gnat_rm/implementation_defined_pragmas pragma-linker-section}@anchor{95} @section Pragma Linker_Section @@ -5216,7 +4982,7 @@ end IO_Card; @end example @node Pragma Lock_Free,Pragma Loop_Invariant,Pragma Linker_Section,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id21}@anchor{93}@anchor{gnat_rm/implementation_defined_pragmas pragma-lock-free}@anchor{94} +@anchor{gnat_rm/implementation_defined_pragmas id22}@anchor{96}@anchor{gnat_rm/implementation_defined_pragmas pragma-lock-free}@anchor{97} @section Pragma Lock_Free @@ -5274,7 +5040,7 @@ 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} +@anchor{gnat_rm/implementation_defined_pragmas pragma-loop-invariant}@anchor{98} @section Pragma Loop_Invariant @@ -5307,7 +5073,7 @@ attribute can only be used within the expression of a @code{Loop_Invariant} pragma. For full details, see documentation of attribute @code{Loop_Entry}. @node Pragma Loop_Optimize,Pragma Loop_Variant,Pragma Loop_Invariant,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-loop-optimize}@anchor{96} +@anchor{gnat_rm/implementation_defined_pragmas pragma-loop-optimize}@anchor{99} @section Pragma Loop_Optimize @@ -5369,7 +5135,7 @@ compiler in order to enable the relevant optimizations, that is to say vectorization. @node Pragma Loop_Variant,Pragma Machine_Attribute,Pragma Loop_Optimize,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-loop-variant}@anchor{97} +@anchor{gnat_rm/implementation_defined_pragmas pragma-loop-variant}@anchor{9a} @section Pragma Loop_Variant @@ -5416,7 +5182,7 @@ The @code{Loop_Entry} attribute may be used within the expressions of the @code{Loop_Variant} pragma to refer to values on entry to the loop. @node Pragma Machine_Attribute,Pragma Main,Pragma Loop_Variant,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-machine-attribute}@anchor{98} +@anchor{gnat_rm/implementation_defined_pragmas pragma-machine-attribute}@anchor{9b} @section Pragma Machine_Attribute @@ -5442,7 +5208,7 @@ which may make this pragma unusable for some attributes. For further information see @cite{GNU Compiler Collection (GCC) Internals}. @node Pragma Main,Pragma Main_Storage,Pragma Machine_Attribute,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-main}@anchor{99} +@anchor{gnat_rm/implementation_defined_pragmas pragma-main}@anchor{9c} @section Pragma Main @@ -5462,7 +5228,7 @@ This pragma is provided for compatibility with OpenVMS VAX Systems. It has no effect in GNAT, other than being syntax checked. @node Pragma Main_Storage,Pragma Max_Queue_Length,Pragma Main,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-main-storage}@anchor{9a} +@anchor{gnat_rm/implementation_defined_pragmas pragma-main-storage}@anchor{9d} @section Pragma Main_Storage @@ -5481,7 +5247,7 @@ This pragma is provided for compatibility with OpenVMS VAX Systems. It has no effect in GNAT, other than being syntax checked. @node Pragma Max_Queue_Length,Pragma No_Body,Pragma Main_Storage,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id22}@anchor{9b}@anchor{gnat_rm/implementation_defined_pragmas pragma-max-queue-length}@anchor{9c} +@anchor{gnat_rm/implementation_defined_pragmas id23}@anchor{9e}@anchor{gnat_rm/implementation_defined_pragmas pragma-max-queue-length}@anchor{9f} @section Pragma Max_Queue_Length @@ -5499,7 +5265,7 @@ entry. A value of -1 represents no additional restriction on queue length. @node Pragma No_Body,Pragma No_Caching,Pragma Max_Queue_Length,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-no-body}@anchor{9d} +@anchor{gnat_rm/implementation_defined_pragmas pragma-no-body}@anchor{a0} @section Pragma No_Body @@ -5522,7 +5288,7 @@ dummy body with a No_Body pragma ensures that there is no interference from earlier versions of the package body. @node Pragma No_Caching,Pragma No_Component_Reordering,Pragma No_Body,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id23}@anchor{9e}@anchor{gnat_rm/implementation_defined_pragmas pragma-no-caching}@anchor{9f} +@anchor{gnat_rm/implementation_defined_pragmas id24}@anchor{a1}@anchor{gnat_rm/implementation_defined_pragmas pragma-no-caching}@anchor{a2} @section Pragma No_Caching @@ -5536,7 +5302,7 @@ For the semantics of this pragma, see the entry for aspect @code{No_Caching} in the SPARK 2014 Reference Manual, section 7.1.2. @node Pragma No_Component_Reordering,Pragma No_Elaboration_Code_All,Pragma No_Caching,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-no-component-reordering}@anchor{a0} +@anchor{gnat_rm/implementation_defined_pragmas pragma-no-component-reordering}@anchor{a3} @section Pragma No_Component_Reordering @@ -5555,7 +5321,7 @@ declared in units to which the pragma applies and there is a requirement that this pragma be used consistently within a partition. @node Pragma No_Elaboration_Code_All,Pragma No_Heap_Finalization,Pragma No_Component_Reordering,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id24}@anchor{a1}@anchor{gnat_rm/implementation_defined_pragmas pragma-no-elaboration-code-all}@anchor{a2} +@anchor{gnat_rm/implementation_defined_pragmas id25}@anchor{a4}@anchor{gnat_rm/implementation_defined_pragmas pragma-no-elaboration-code-all}@anchor{a5} @section Pragma No_Elaboration_Code_All @@ -5574,7 +5340,7 @@ current unit, it must also have the No_Elaboration_Code_All aspect set. It may be applied to package or subprogram specs or their generic versions. @node Pragma No_Heap_Finalization,Pragma No_Inline,Pragma No_Elaboration_Code_All,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-no-heap-finalization}@anchor{a3} +@anchor{gnat_rm/implementation_defined_pragmas pragma-no-heap-finalization}@anchor{a6} @section Pragma No_Heap_Finalization @@ -5606,7 +5372,7 @@ lose its @code{No_Heap_Finalization} pragma when the corresponding instance does appear at the library level. @node Pragma No_Inline,Pragma No_Return,Pragma No_Heap_Finalization,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id25}@anchor{a4}@anchor{gnat_rm/implementation_defined_pragmas pragma-no-inline}@anchor{a5} +@anchor{gnat_rm/implementation_defined_pragmas id26}@anchor{a7}@anchor{gnat_rm/implementation_defined_pragmas pragma-no-inline}@anchor{a8} @section Pragma No_Inline @@ -5624,7 +5390,7 @@ in particular it is not subject to the use of option `-gnatn' or pragma @code{Inline_Always} for the same @code{NAME}. @node Pragma No_Return,Pragma No_Strict_Aliasing,Pragma No_Inline,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-no-return}@anchor{a6} +@anchor{gnat_rm/implementation_defined_pragmas pragma-no-return}@anchor{a9} @section Pragma No_Return @@ -5651,7 +5417,7 @@ available in all earlier versions of Ada as an implementation-defined pragma. @node Pragma No_Strict_Aliasing,Pragma No_Tagged_Streams,Pragma No_Return,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-no-strict-aliasing}@anchor{a7} +@anchor{gnat_rm/implementation_defined_pragmas pragma-no-strict-aliasing}@anchor{aa} @section Pragma No_Strict_Aliasing @@ -5673,7 +5439,7 @@ in the @cite{GNAT User’s Guide}. This pragma currently has no effects on access to unconstrained array types. @node Pragma No_Tagged_Streams,Pragma Normalize_Scalars,Pragma No_Strict_Aliasing,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id26}@anchor{a8}@anchor{gnat_rm/implementation_defined_pragmas pragma-no-tagged-streams}@anchor{a9} +@anchor{gnat_rm/implementation_defined_pragmas id27}@anchor{ab}@anchor{gnat_rm/implementation_defined_pragmas pragma-no-tagged-streams}@anchor{ac} @section Pragma No_Tagged_Streams @@ -5712,7 +5478,7 @@ with empty strings. This is useful to avoid exposing entity names at binary level but has a negative impact on the debuggability of tagged types. @node Pragma Normalize_Scalars,Pragma Obsolescent,Pragma No_Tagged_Streams,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-normalize-scalars}@anchor{aa} +@anchor{gnat_rm/implementation_defined_pragmas pragma-normalize-scalars}@anchor{ad} @section Pragma Normalize_Scalars @@ -5794,7 +5560,7 @@ will always generate an invalid value if one exists. @end table @node Pragma Obsolescent,Pragma Optimize_Alignment,Pragma Normalize_Scalars,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id27}@anchor{ab}@anchor{gnat_rm/implementation_defined_pragmas pragma-obsolescent}@anchor{ac} +@anchor{gnat_rm/implementation_defined_pragmas id28}@anchor{ae}@anchor{gnat_rm/implementation_defined_pragmas pragma-obsolescent}@anchor{af} @section Pragma Obsolescent @@ -5890,7 +5656,7 @@ So if you specify @code{Entity =>} for the @code{Entity} argument, and a @code{M argument is present, it must be preceded by @code{Message =>}. @node Pragma Optimize_Alignment,Pragma Ordered,Pragma Obsolescent,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-optimize-alignment}@anchor{ad} +@anchor{gnat_rm/implementation_defined_pragmas pragma-optimize-alignment}@anchor{b0} @section Pragma Optimize_Alignment @@ -5976,7 +5742,7 @@ latter are compiled by default in pragma Optimize_Alignment (Off) mode if no pragma appears at the start of the file. @node Pragma Ordered,Pragma Overflow_Mode,Pragma Optimize_Alignment,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-ordered}@anchor{ae} +@anchor{gnat_rm/implementation_defined_pragmas pragma-ordered}@anchor{b1} @section Pragma Ordered @@ -6068,7 +5834,7 @@ For additional information please refer to the description of the `-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} +@anchor{gnat_rm/implementation_defined_pragmas pragma-overflow-mode}@anchor{b2} @section Pragma Overflow_Mode @@ -6107,7 +5873,7 @@ The pragma @code{Unsuppress (Overflow_Check)} unsuppresses (enables) overflow checking, but does not affect the overflow mode. @node Pragma Overriding_Renamings,Pragma Part_Of,Pragma Overflow_Mode,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-overriding-renamings}@anchor{b0} +@anchor{gnat_rm/implementation_defined_pragmas pragma-overriding-renamings}@anchor{b3} @section Pragma Overriding_Renamings @@ -6142,7 +5908,7 @@ RM 8.3 (15) stipulates that an overridden operation is not visible within the declaration of the overriding operation. @node Pragma Part_Of,Pragma Partition_Elaboration_Policy,Pragma Overriding_Renamings,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id28}@anchor{b1}@anchor{gnat_rm/implementation_defined_pragmas pragma-part-of}@anchor{b2} +@anchor{gnat_rm/implementation_defined_pragmas id29}@anchor{b4}@anchor{gnat_rm/implementation_defined_pragmas pragma-part-of}@anchor{b5} @section Pragma Part_Of @@ -6158,7 +5924,7 @@ For the semantics of this pragma, see the entry for aspect @code{Part_Of} in the SPARK 2014 Reference Manual, section 7.2.6. @node Pragma Partition_Elaboration_Policy,Pragma Passive,Pragma Part_Of,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-partition-elaboration-policy}@anchor{b3} +@anchor{gnat_rm/implementation_defined_pragmas pragma-partition-elaboration-policy}@anchor{b6} @section Pragma Partition_Elaboration_Policy @@ -6175,7 +5941,7 @@ versions of Ada as an implementation-defined pragma. See Ada 2012 Reference Manual for details. @node Pragma Passive,Pragma Persistent_BSS,Pragma Partition_Elaboration_Policy,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-passive}@anchor{b4} +@anchor{gnat_rm/implementation_defined_pragmas pragma-passive}@anchor{b7} @section Pragma Passive @@ -6199,7 +5965,7 @@ For more information on the subject of passive tasks, see the section ‘Passive Task Optimization’ in the GNAT Users Guide. @node Pragma Persistent_BSS,Pragma Post,Pragma Passive,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id29}@anchor{b5}@anchor{gnat_rm/implementation_defined_pragmas pragma-persistent-bss}@anchor{b6} +@anchor{gnat_rm/implementation_defined_pragmas id30}@anchor{b8}@anchor{gnat_rm/implementation_defined_pragmas pragma-persistent-bss}@anchor{b9} @section Pragma Persistent_BSS @@ -6230,7 +5996,7 @@ If this pragma is used on a target where this feature is not supported, then the pragma will be ignored. See also @code{pragma Linker_Section}. @node Pragma Post,Pragma Postcondition,Pragma Persistent_BSS,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-post}@anchor{b7} +@anchor{gnat_rm/implementation_defined_pragmas pragma-post}@anchor{ba} @section Pragma Post @@ -6255,7 +6021,7 @@ appear at the start of the declarations in a subprogram body (preceded only by other pragmas). @node Pragma Postcondition,Pragma Post_Class,Pragma Post,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-postcondition}@anchor{b8} +@anchor{gnat_rm/implementation_defined_pragmas pragma-postcondition}@anchor{bb} @section Pragma Postcondition @@ -6420,7 +6186,7 @@ Ada 2012, and has been retained in its original form for compatibility purposes. @node Pragma Post_Class,Pragma Pre,Pragma Postcondition,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-post-class}@anchor{b9} +@anchor{gnat_rm/implementation_defined_pragmas pragma-post-class}@anchor{bc} @section Pragma Post_Class @@ -6455,7 +6221,7 @@ policy that controls this pragma is @code{Post'Class}, not @code{Post_Class}. @node Pragma Pre,Pragma Precondition,Pragma Post_Class,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-pre}@anchor{ba} +@anchor{gnat_rm/implementation_defined_pragmas pragma-pre}@anchor{bd} @section Pragma Pre @@ -6480,7 +6246,7 @@ appear at the start of the declarations in a subprogram body (preceded only by other pragmas). @node Pragma Precondition,Pragma Predicate,Pragma Pre,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-precondition}@anchor{bb} +@anchor{gnat_rm/implementation_defined_pragmas pragma-precondition}@anchor{be} @section Pragma Precondition @@ -6539,7 +6305,7 @@ Ada 2012, and has been retained in its original form for compatibility purposes. @node Pragma Predicate,Pragma Predicate_Failure,Pragma Precondition,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id30}@anchor{bc}@anchor{gnat_rm/implementation_defined_pragmas pragma-predicate}@anchor{bd} +@anchor{gnat_rm/implementation_defined_pragmas id31}@anchor{bf}@anchor{gnat_rm/implementation_defined_pragmas pragma-predicate}@anchor{c0} @section Pragma Predicate @@ -6593,7 +6359,7 @@ defined for subtype B). When following this approach, the use of predicates should be avoided. @node Pragma Predicate_Failure,Pragma Preelaborable_Initialization,Pragma Predicate,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-predicate-failure}@anchor{be} +@anchor{gnat_rm/implementation_defined_pragmas pragma-predicate-failure}@anchor{c1} @section Pragma Predicate_Failure @@ -6610,7 +6376,7 @@ the language-defined @code{Predicate_Failure} aspect, and shares its restrictions and semantics. @node Pragma Preelaborable_Initialization,Pragma Prefix_Exception_Messages,Pragma Predicate_Failure,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-preelaborable-initialization}@anchor{bf} +@anchor{gnat_rm/implementation_defined_pragmas pragma-preelaborable-initialization}@anchor{c2} @section Pragma Preelaborable_Initialization @@ -6625,7 +6391,7 @@ versions of Ada as an implementation-defined pragma. See Ada 2012 Reference Manual for details. @node Pragma Prefix_Exception_Messages,Pragma Pre_Class,Pragma Preelaborable_Initialization,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-prefix-exception-messages}@anchor{c0} +@anchor{gnat_rm/implementation_defined_pragmas pragma-prefix-exception-messages}@anchor{c3} @section Pragma Prefix_Exception_Messages @@ -6656,7 +6422,7 @@ prefixing in this case, you can always call @code{GNAT.Source_Info.Enclosing_Entity} and prepend the string manually. @node Pragma Pre_Class,Pragma Priority_Specific_Dispatching,Pragma Prefix_Exception_Messages,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-pre-class}@anchor{c1} +@anchor{gnat_rm/implementation_defined_pragmas pragma-pre-class}@anchor{c4} @section Pragma Pre_Class @@ -6691,7 +6457,7 @@ policy that controls this pragma is @code{Pre'Class}, not @code{Pre_Class}. @node Pragma Priority_Specific_Dispatching,Pragma Profile,Pragma Pre_Class,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-priority-specific-dispatching}@anchor{c2} +@anchor{gnat_rm/implementation_defined_pragmas pragma-priority-specific-dispatching}@anchor{c5} @section Pragma Priority_Specific_Dispatching @@ -6715,7 +6481,7 @@ versions of Ada as an implementation-defined pragma. See Ada 2012 Reference Manual for details. @node Pragma Profile,Pragma Profile_Warnings,Pragma Priority_Specific_Dispatching,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-profile}@anchor{c3} +@anchor{gnat_rm/implementation_defined_pragmas pragma-profile}@anchor{c6} @section Pragma Profile @@ -6994,7 +6760,7 @@ conforming Ada constructs. The profile enables the following three pragmas: @end itemize @node Pragma Profile_Warnings,Pragma Propagate_Exceptions,Pragma Profile,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-profile-warnings}@anchor{c4} +@anchor{gnat_rm/implementation_defined_pragmas pragma-profile-warnings}@anchor{c7} @section Pragma Profile_Warnings @@ -7012,7 +6778,7 @@ violations of the profile generate warning messages instead of error messages. @node Pragma Propagate_Exceptions,Pragma Provide_Shift_Operators,Pragma Profile_Warnings,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-propagate-exceptions}@anchor{c5} +@anchor{gnat_rm/implementation_defined_pragmas pragma-propagate-exceptions}@anchor{c8} @section Pragma Propagate_Exceptions @@ -7031,7 +6797,7 @@ purposes. It used to be used in connection with optimization of a now-obsolete mechanism for implementation of exceptions. @node Pragma Provide_Shift_Operators,Pragma Psect_Object,Pragma Propagate_Exceptions,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-provide-shift-operators}@anchor{c6} +@anchor{gnat_rm/implementation_defined_pragmas pragma-provide-shift-operators}@anchor{c9} @section Pragma Provide_Shift_Operators @@ -7051,7 +6817,7 @@ including the function declarations for these five operators, together with the pragma Import (Intrinsic, …) statements. @node Pragma Psect_Object,Pragma Pure_Function,Pragma Provide_Shift_Operators,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-psect-object}@anchor{c7} +@anchor{gnat_rm/implementation_defined_pragmas pragma-psect-object}@anchor{ca} @section Pragma Psect_Object @@ -7071,7 +6837,7 @@ EXTERNAL_SYMBOL ::= This pragma is identical in effect to pragma @code{Common_Object}. @node Pragma Pure_Function,Pragma Rational,Pragma Psect_Object,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id31}@anchor{c8}@anchor{gnat_rm/implementation_defined_pragmas pragma-pure-function}@anchor{c9} +@anchor{gnat_rm/implementation_defined_pragmas id32}@anchor{cb}@anchor{gnat_rm/implementation_defined_pragmas pragma-pure-function}@anchor{cc} @section Pragma Pure_Function @@ -7133,7 +6899,7 @@ unit is not a Pure unit in the categorization sense. So for example, a function thus marked is free to @code{with} non-pure units. @node Pragma Rational,Pragma Ravenscar,Pragma Pure_Function,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-rational}@anchor{ca} +@anchor{gnat_rm/implementation_defined_pragmas pragma-rational}@anchor{cd} @section Pragma Rational @@ -7151,7 +6917,7 @@ pragma Profile (Rational); @end example @node Pragma Ravenscar,Pragma Refined_Depends,Pragma Rational,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-ravenscar}@anchor{cb} +@anchor{gnat_rm/implementation_defined_pragmas pragma-ravenscar}@anchor{ce} @section Pragma Ravenscar @@ -7171,7 +6937,7 @@ pragma Profile (Ravenscar); which is the preferred method of setting the @code{Ravenscar} profile. @node Pragma Refined_Depends,Pragma Refined_Global,Pragma Ravenscar,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id32}@anchor{cc}@anchor{gnat_rm/implementation_defined_pragmas pragma-refined-depends}@anchor{cd} +@anchor{gnat_rm/implementation_defined_pragmas id33}@anchor{cf}@anchor{gnat_rm/implementation_defined_pragmas pragma-refined-depends}@anchor{d0} @section Pragma Refined_Depends @@ -7204,7 +6970,7 @@ For the semantics of this pragma, see the entry for aspect @code{Refined_Depends the SPARK 2014 Reference Manual, section 6.1.5. @node Pragma Refined_Global,Pragma Refined_Post,Pragma Refined_Depends,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id33}@anchor{ce}@anchor{gnat_rm/implementation_defined_pragmas pragma-refined-global}@anchor{cf} +@anchor{gnat_rm/implementation_defined_pragmas id34}@anchor{d1}@anchor{gnat_rm/implementation_defined_pragmas pragma-refined-global}@anchor{d2} @section Pragma Refined_Global @@ -7229,7 +6995,7 @@ For the semantics of this pragma, see the entry for aspect @code{Refined_Global} the SPARK 2014 Reference Manual, section 6.1.4. @node Pragma Refined_Post,Pragma Refined_State,Pragma Refined_Global,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id34}@anchor{d0}@anchor{gnat_rm/implementation_defined_pragmas pragma-refined-post}@anchor{d1} +@anchor{gnat_rm/implementation_defined_pragmas id35}@anchor{d3}@anchor{gnat_rm/implementation_defined_pragmas pragma-refined-post}@anchor{d4} @section Pragma Refined_Post @@ -7243,7 +7009,7 @@ For the semantics of this pragma, see the entry for aspect @code{Refined_Post} i the SPARK 2014 Reference Manual, section 7.2.7. @node Pragma Refined_State,Pragma Relative_Deadline,Pragma Refined_Post,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id35}@anchor{d2}@anchor{gnat_rm/implementation_defined_pragmas pragma-refined-state}@anchor{d3} +@anchor{gnat_rm/implementation_defined_pragmas id36}@anchor{d5}@anchor{gnat_rm/implementation_defined_pragmas pragma-refined-state}@anchor{d6} @section Pragma Refined_State @@ -7269,7 +7035,7 @@ For the semantics of this pragma, see the entry for aspect @code{Refined_State} the SPARK 2014 Reference Manual, section 7.2.2. @node Pragma Relative_Deadline,Pragma Remote_Access_Type,Pragma Refined_State,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-relative-deadline}@anchor{d4} +@anchor{gnat_rm/implementation_defined_pragmas pragma-relative-deadline}@anchor{d7} @section Pragma Relative_Deadline @@ -7284,7 +7050,7 @@ versions of Ada as an implementation-defined pragma. See Ada 2012 Reference Manual for details. @node Pragma Remote_Access_Type,Pragma Rename_Pragma,Pragma Relative_Deadline,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id36}@anchor{d5}@anchor{gnat_rm/implementation_defined_pragmas pragma-remote-access-type}@anchor{d6} +@anchor{gnat_rm/implementation_defined_pragmas id37}@anchor{d8}@anchor{gnat_rm/implementation_defined_pragmas pragma-remote-access-type}@anchor{d9} @section Pragma Remote_Access_Type @@ -7310,7 +7076,7 @@ pertaining to remote access to class-wide types. At instantiation, the actual type must be a remote access to class-wide type. @node Pragma Rename_Pragma,Pragma Restricted_Run_Time,Pragma Remote_Access_Type,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-rename-pragma}@anchor{d7} +@anchor{gnat_rm/implementation_defined_pragmas pragma-rename-pragma}@anchor{da} @section Pragma Rename_Pragma @@ -7349,7 +7115,7 @@ Pragma Inline_Only will not necessarily mean the same thing as the other Ada compiler; it’s up to you to make sure the semantics are close enough. @node Pragma Restricted_Run_Time,Pragma Restriction_Warnings,Pragma Rename_Pragma,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-restricted-run-time}@anchor{d8} +@anchor{gnat_rm/implementation_defined_pragmas pragma-restricted-run-time}@anchor{db} @section Pragma Restricted_Run_Time @@ -7370,7 +7136,7 @@ which is the preferred method of setting the restricted run time profile. @node Pragma Restriction_Warnings,Pragma Reviewable,Pragma Restricted_Run_Time,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-restriction-warnings}@anchor{d9} +@anchor{gnat_rm/implementation_defined_pragmas pragma-restriction-warnings}@anchor{dc} @section Pragma Restriction_Warnings @@ -7408,7 +7174,7 @@ generating a warning, but any other use of implementation defined pragmas will cause a warning to be generated. @node Pragma Reviewable,Pragma Secondary_Stack_Size,Pragma Restriction_Warnings,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-reviewable}@anchor{da} +@anchor{gnat_rm/implementation_defined_pragmas pragma-reviewable}@anchor{dd} @section Pragma Reviewable @@ -7512,7 +7278,7 @@ comprehensive messages identifying possible problems based on this information. @node Pragma Secondary_Stack_Size,Pragma Share_Generic,Pragma Reviewable,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id37}@anchor{db}@anchor{gnat_rm/implementation_defined_pragmas pragma-secondary-stack-size}@anchor{dc} +@anchor{gnat_rm/implementation_defined_pragmas id38}@anchor{de}@anchor{gnat_rm/implementation_defined_pragmas pragma-secondary-stack-size}@anchor{df} @section Pragma Secondary_Stack_Size @@ -7548,7 +7314,7 @@ Note the pragma cannot appear when the restriction @code{No_Secondary_Stack} is in effect. @node Pragma Share_Generic,Pragma Shared,Pragma Secondary_Stack_Size,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-share-generic}@anchor{dd} +@anchor{gnat_rm/implementation_defined_pragmas pragma-share-generic}@anchor{e0} @section Pragma Share_Generic @@ -7566,7 +7332,7 @@ than to check that the given names are all names of generic units or generic instances. @node Pragma Shared,Pragma Short_Circuit_And_Or,Pragma Share_Generic,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id38}@anchor{de}@anchor{gnat_rm/implementation_defined_pragmas pragma-shared}@anchor{df} +@anchor{gnat_rm/implementation_defined_pragmas id39}@anchor{e1}@anchor{gnat_rm/implementation_defined_pragmas pragma-shared}@anchor{e2} @section Pragma Shared @@ -7574,7 +7340,7 @@ This pragma is provided for compatibility with Ada 83. The syntax and semantics are identical to pragma Atomic. @node Pragma Short_Circuit_And_Or,Pragma Short_Descriptors,Pragma Shared,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-short-circuit-and-or}@anchor{e0} +@anchor{gnat_rm/implementation_defined_pragmas pragma-short-circuit-and-or}@anchor{e3} @section Pragma Short_Circuit_And_Or @@ -7593,7 +7359,7 @@ within the file being compiled, it applies only to the file being compiled. There is no requirement that all units in a partition use this option. @node Pragma Short_Descriptors,Pragma Simple_Storage_Pool_Type,Pragma Short_Circuit_And_Or,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-short-descriptors}@anchor{e1} +@anchor{gnat_rm/implementation_defined_pragmas pragma-short-descriptors}@anchor{e4} @section Pragma Short_Descriptors @@ -7607,7 +7373,7 @@ This pragma is provided for compatibility with other Ada implementations. It is recognized but ignored by all current versions of GNAT. @node Pragma Simple_Storage_Pool_Type,Pragma Source_File_Name,Pragma Short_Descriptors,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id39}@anchor{e2}@anchor{gnat_rm/implementation_defined_pragmas pragma-simple-storage-pool-type}@anchor{e3} +@anchor{gnat_rm/implementation_defined_pragmas id40}@anchor{e5}@anchor{gnat_rm/implementation_defined_pragmas pragma-simple-storage-pool-type}@anchor{e6} @section Pragma Simple_Storage_Pool_Type @@ -7661,7 +7427,7 @@ storage-management discipline). An object of a simple storage pool type can be associated with an access type by specifying the attribute -@ref{e4,,Simple_Storage_Pool}. For example: +@ref{e7,,Simple_Storage_Pool}. For example: @example My_Pool : My_Simple_Storage_Pool_Type; @@ -7671,11 +7437,11 @@ type Acc is access My_Data_Type; for Acc'Simple_Storage_Pool use My_Pool; @end example -See attribute @ref{e4,,Simple_Storage_Pool} +See attribute @ref{e7,,Simple_Storage_Pool} for further details. @node Pragma Source_File_Name,Pragma Source_File_Name_Project,Pragma Simple_Storage_Pool_Type,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id40}@anchor{e5}@anchor{gnat_rm/implementation_defined_pragmas pragma-source-file-name}@anchor{e6} +@anchor{gnat_rm/implementation_defined_pragmas id41}@anchor{e8}@anchor{gnat_rm/implementation_defined_pragmas pragma-source-file-name}@anchor{e9} @section Pragma Source_File_Name @@ -7767,20 +7533,20 @@ aware of these pragmas, and so other tools that use the project file would not be aware of the intended naming conventions. If you are using project files, file naming is controlled by Source_File_Name_Project pragmas, which are usually supplied automatically by the project manager. A pragma -Source_File_Name cannot appear after a @ref{e7,,Pragma Source_File_Name_Project}. +Source_File_Name cannot appear after a @ref{ea,,Pragma Source_File_Name_Project}. For more details on the use of the @code{Source_File_Name} pragma, see the sections on @cite{Using Other File Names} and @cite{Alternative File Naming Schemes} in the @cite{GNAT User’s Guide}. @node Pragma Source_File_Name_Project,Pragma Source_Reference,Pragma Source_File_Name,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id41}@anchor{e8}@anchor{gnat_rm/implementation_defined_pragmas pragma-source-file-name-project}@anchor{e7} +@anchor{gnat_rm/implementation_defined_pragmas id42}@anchor{eb}@anchor{gnat_rm/implementation_defined_pragmas pragma-source-file-name-project}@anchor{ea} @section Pragma Source_File_Name_Project This pragma has the same syntax and semantics as pragma Source_File_Name. It is only allowed as a stand-alone configuration pragma. -It cannot appear after a @ref{e6,,Pragma Source_File_Name}, and +It cannot appear after a @ref{e9,,Pragma Source_File_Name}, and most importantly, once pragma Source_File_Name_Project appears, no further Source_File_Name pragmas are allowed. @@ -7792,7 +7558,7 @@ Source_File_Name or Source_File_Name_Project pragmas (which would not be known to the project manager). @node Pragma Source_Reference,Pragma SPARK_Mode,Pragma Source_File_Name_Project,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-source-reference}@anchor{e9} +@anchor{gnat_rm/implementation_defined_pragmas pragma-source-reference}@anchor{ec} @section Pragma Source_Reference @@ -7816,7 +7582,7 @@ string expression other than a string literal. This is because its value is needed for error messages issued by all phases of the compiler. @node Pragma SPARK_Mode,Pragma Static_Elaboration_Desired,Pragma Source_Reference,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id42}@anchor{ea}@anchor{gnat_rm/implementation_defined_pragmas pragma-spark-mode}@anchor{eb} +@anchor{gnat_rm/implementation_defined_pragmas id43}@anchor{ed}@anchor{gnat_rm/implementation_defined_pragmas pragma-spark-mode}@anchor{ee} @section Pragma SPARK_Mode @@ -7898,7 +7664,7 @@ SPARK_Mode (@code{Off}), then that pragma will need to be repeated in the package body. @node Pragma Static_Elaboration_Desired,Pragma Stream_Convert,Pragma SPARK_Mode,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-static-elaboration-desired}@anchor{ec} +@anchor{gnat_rm/implementation_defined_pragmas pragma-static-elaboration-desired}@anchor{ef} @section Pragma Static_Elaboration_Desired @@ -7922,7 +7688,7 @@ construction of larger aggregates with static components that include an others choice.) @node Pragma Stream_Convert,Pragma Style_Checks,Pragma Static_Elaboration_Desired,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-stream-convert}@anchor{ed} +@anchor{gnat_rm/implementation_defined_pragmas pragma-stream-convert}@anchor{f0} @section Pragma Stream_Convert @@ -7999,7 +7765,7 @@ the pragma is silently ignored, and the default implementation of the stream attributes is used instead. @node Pragma Style_Checks,Pragma Subtitle,Pragma Stream_Convert,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-style-checks}@anchor{ee} +@anchor{gnat_rm/implementation_defined_pragmas pragma-style-checks}@anchor{f1} @section Pragma Style_Checks @@ -8072,7 +7838,7 @@ Rf2 : Integer := ARG; -- OK, no error @end example @node Pragma Subtitle,Pragma Suppress,Pragma Style_Checks,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-subtitle}@anchor{ef} +@anchor{gnat_rm/implementation_defined_pragmas pragma-subtitle}@anchor{f2} @section Pragma Subtitle @@ -8086,7 +7852,7 @@ This pragma is recognized for compatibility with other Ada compilers but is ignored by GNAT. @node Pragma Suppress,Pragma Suppress_All,Pragma Subtitle,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-suppress}@anchor{f0} +@anchor{gnat_rm/implementation_defined_pragmas pragma-suppress}@anchor{f3} @section Pragma Suppress @@ -8159,7 +7925,7 @@ Of course, run-time checks are omitted whenever the compiler can prove that they will not fail, whether or not checks are suppressed. @node Pragma Suppress_All,Pragma Suppress_Debug_Info,Pragma Suppress,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-suppress-all}@anchor{f1} +@anchor{gnat_rm/implementation_defined_pragmas pragma-suppress-all}@anchor{f4} @section Pragma Suppress_All @@ -8178,7 +7944,7 @@ The use of the standard Ada pragma @code{Suppress (All_Checks)} as a normal configuration pragma is the preferred usage in GNAT. @node Pragma Suppress_Debug_Info,Pragma Suppress_Exception_Locations,Pragma Suppress_All,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id43}@anchor{f2}@anchor{gnat_rm/implementation_defined_pragmas pragma-suppress-debug-info}@anchor{f3} +@anchor{gnat_rm/implementation_defined_pragmas id44}@anchor{f5}@anchor{gnat_rm/implementation_defined_pragmas pragma-suppress-debug-info}@anchor{f6} @section Pragma Suppress_Debug_Info @@ -8193,7 +7959,7 @@ for the specified entity. It is intended primarily for use in debugging the debugger, and navigating around debugger problems. @node Pragma Suppress_Exception_Locations,Pragma Suppress_Initialization,Pragma Suppress_Debug_Info,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-suppress-exception-locations}@anchor{f4} +@anchor{gnat_rm/implementation_defined_pragmas pragma-suppress-exception-locations}@anchor{f7} @section Pragma Suppress_Exception_Locations @@ -8216,7 +7982,7 @@ a partition, so it is fine to have some units within a partition compiled with this pragma and others compiled in normal mode without it. @node Pragma Suppress_Initialization,Pragma Task_Name,Pragma Suppress_Exception_Locations,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id44}@anchor{f5}@anchor{gnat_rm/implementation_defined_pragmas pragma-suppress-initialization}@anchor{f6} +@anchor{gnat_rm/implementation_defined_pragmas id45}@anchor{f8}@anchor{gnat_rm/implementation_defined_pragmas pragma-suppress-initialization}@anchor{f9} @section Pragma Suppress_Initialization @@ -8261,7 +8027,7 @@ is suppressed, just as though its subtype had been given in a pragma Suppress_Initialization, as described above. @node Pragma Task_Name,Pragma Task_Storage,Pragma Suppress_Initialization,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-task-name}@anchor{f7} +@anchor{gnat_rm/implementation_defined_pragmas pragma-task-name}@anchor{fa} @section Pragma Task_Name @@ -8317,7 +8083,7 @@ end; @end example @node Pragma Task_Storage,Pragma Test_Case,Pragma Task_Name,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-task-storage}@anchor{f8} +@anchor{gnat_rm/implementation_defined_pragmas pragma-task-storage}@anchor{fb} @section Pragma Task_Storage @@ -8337,7 +8103,7 @@ created, depending on the target. This pragma can appear anywhere a type. @node Pragma Test_Case,Pragma Thread_Local_Storage,Pragma Task_Storage,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id45}@anchor{f9}@anchor{gnat_rm/implementation_defined_pragmas pragma-test-case}@anchor{fa} +@anchor{gnat_rm/implementation_defined_pragmas id46}@anchor{fc}@anchor{gnat_rm/implementation_defined_pragmas pragma-test-case}@anchor{fd} @section Pragma Test_Case @@ -8393,7 +8159,7 @@ postcondition. Mode @code{Robustness} indicates that the precondition and postcondition of the subprogram should be ignored for this test case. @node Pragma Thread_Local_Storage,Pragma Time_Slice,Pragma Test_Case,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id46}@anchor{fb}@anchor{gnat_rm/implementation_defined_pragmas pragma-thread-local-storage}@anchor{fc} +@anchor{gnat_rm/implementation_defined_pragmas id47}@anchor{fe}@anchor{gnat_rm/implementation_defined_pragmas pragma-thread-local-storage}@anchor{ff} @section Pragma Thread_Local_Storage @@ -8431,7 +8197,7 @@ If this pragma is used on a system where @code{TLS} is not supported, then an error message will be generated and the program will be rejected. @node Pragma Time_Slice,Pragma Title,Pragma Thread_Local_Storage,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-time-slice}@anchor{fd} +@anchor{gnat_rm/implementation_defined_pragmas pragma-time-slice}@anchor{100} @section Pragma Time_Slice @@ -8447,7 +8213,7 @@ It is ignored if it is used in a system that does not allow this control, or if it appears in other than the main program unit. @node Pragma Title,Pragma Type_Invariant,Pragma Time_Slice,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-title}@anchor{fe} +@anchor{gnat_rm/implementation_defined_pragmas pragma-title}@anchor{101} @section Pragma Title @@ -8472,7 +8238,7 @@ notation is used, and named and positional notation can be mixed following the normal rules for procedure calls in Ada. @node Pragma Type_Invariant,Pragma Type_Invariant_Class,Pragma Title,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-type-invariant}@anchor{ff} +@anchor{gnat_rm/implementation_defined_pragmas pragma-type-invariant}@anchor{102} @section Pragma Type_Invariant @@ -8493,7 +8259,7 @@ controlled by the assertion identifier @code{Type_Invariant} rather than @code{Invariant}. @node Pragma Type_Invariant_Class,Pragma Unchecked_Union,Pragma Type_Invariant,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id47}@anchor{100}@anchor{gnat_rm/implementation_defined_pragmas pragma-type-invariant-class}@anchor{101} +@anchor{gnat_rm/implementation_defined_pragmas id48}@anchor{103}@anchor{gnat_rm/implementation_defined_pragmas pragma-type-invariant-class}@anchor{104} @section Pragma Type_Invariant_Class @@ -8520,7 +8286,7 @@ policy that controls this pragma is @code{Type_Invariant'Class}, not @code{Type_Invariant_Class}. @node Pragma Unchecked_Union,Pragma Unevaluated_Use_Of_Old,Pragma Type_Invariant_Class,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-unchecked-union}@anchor{102} +@anchor{gnat_rm/implementation_defined_pragmas pragma-unchecked-union}@anchor{105} @section Pragma Unchecked_Union @@ -8540,7 +8306,7 @@ version in all language modes (Ada 83, Ada 95, and Ada 2005). For full details, consult the Ada 2012 Reference Manual, section B.3.3. @node Pragma Unevaluated_Use_Of_Old,Pragma Unimplemented_Unit,Pragma Unchecked_Union,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-unevaluated-use-of-old}@anchor{103} +@anchor{gnat_rm/implementation_defined_pragmas pragma-unevaluated-use-of-old}@anchor{106} @section Pragma Unevaluated_Use_Of_Old @@ -8595,7 +8361,7 @@ uses up to the end of the corresponding statement sequence or sequence of package declarations. @node Pragma Unimplemented_Unit,Pragma Universal_Aliasing,Pragma Unevaluated_Use_Of_Old,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-unimplemented-unit}@anchor{104} +@anchor{gnat_rm/implementation_defined_pragmas pragma-unimplemented-unit}@anchor{107} @section Pragma Unimplemented_Unit @@ -8615,7 +8381,7 @@ The abort only happens if code is being generated. Thus you can use specs of unimplemented packages in syntax or semantic checking mode. @node Pragma Universal_Aliasing,Pragma Unmodified,Pragma Unimplemented_Unit,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id48}@anchor{105}@anchor{gnat_rm/implementation_defined_pragmas pragma-universal-aliasing}@anchor{106} +@anchor{gnat_rm/implementation_defined_pragmas id49}@anchor{108}@anchor{gnat_rm/implementation_defined_pragmas pragma-universal-aliasing}@anchor{109} @section Pragma Universal_Aliasing @@ -8634,7 +8400,7 @@ situations in which it must be suppressed, see the section on @code{Optimization and Strict Aliasing} in the @cite{GNAT User’s Guide}. @node Pragma Unmodified,Pragma Unreferenced,Pragma Universal_Aliasing,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id49}@anchor{107}@anchor{gnat_rm/implementation_defined_pragmas pragma-unmodified}@anchor{108} +@anchor{gnat_rm/implementation_defined_pragmas id50}@anchor{10a}@anchor{gnat_rm/implementation_defined_pragmas pragma-unmodified}@anchor{10b} @section Pragma Unmodified @@ -8668,7 +8434,7 @@ Thus it is never necessary to use @code{pragma Unmodified} for such variables, though it is harmless to do so. @node Pragma Unreferenced,Pragma Unreferenced_Objects,Pragma Unmodified,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id50}@anchor{109}@anchor{gnat_rm/implementation_defined_pragmas pragma-unreferenced}@anchor{10a} +@anchor{gnat_rm/implementation_defined_pragmas id51}@anchor{10c}@anchor{gnat_rm/implementation_defined_pragmas pragma-unreferenced}@anchor{10d} @section Pragma Unreferenced @@ -8714,7 +8480,7 @@ Note that if a warning is desired for all calls to a given subprogram, regardless of whether they occur in the same unit as the subprogram declaration, then this pragma should not be used (calls from another unit would not be flagged); pragma Obsolescent can be used instead -for this purpose, see @ref{ac,,Pragma Obsolescent}. +for this purpose, see @ref{af,,Pragma Obsolescent}. The second form of pragma @code{Unreferenced} is used within a context clause. In this case the arguments must be unit names of units previously @@ -8730,7 +8496,7 @@ Thus it is never necessary to use @code{pragma Unreferenced} for such variables, though it is harmless to do so. @node Pragma Unreferenced_Objects,Pragma Unreserve_All_Interrupts,Pragma Unreferenced,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id51}@anchor{10b}@anchor{gnat_rm/implementation_defined_pragmas pragma-unreferenced-objects}@anchor{10c} +@anchor{gnat_rm/implementation_defined_pragmas id52}@anchor{10e}@anchor{gnat_rm/implementation_defined_pragmas pragma-unreferenced-objects}@anchor{10f} @section Pragma Unreferenced_Objects @@ -8755,7 +8521,7 @@ compiler will automatically suppress unwanted warnings about these variables not being referenced. @node Pragma Unreserve_All_Interrupts,Pragma Unsuppress,Pragma Unreferenced_Objects,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-unreserve-all-interrupts}@anchor{10d} +@anchor{gnat_rm/implementation_defined_pragmas pragma-unreserve-all-interrupts}@anchor{110} @section Pragma Unreserve_All_Interrupts @@ -8791,7 +8557,7 @@ handled, see pragma @code{Interrupt_State}, which subsumes the functionality of the @code{Unreserve_All_Interrupts} pragma. @node Pragma Unsuppress,Pragma Unused,Pragma Unreserve_All_Interrupts,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-unsuppress}@anchor{10e} +@anchor{gnat_rm/implementation_defined_pragmas pragma-unsuppress}@anchor{111} @section Pragma Unsuppress @@ -8827,7 +8593,7 @@ number of implementation-defined check names. See the description of pragma @code{Suppress} for full details. @node Pragma Unused,Pragma Use_VADS_Size,Pragma Unsuppress,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id52}@anchor{10f}@anchor{gnat_rm/implementation_defined_pragmas pragma-unused}@anchor{110} +@anchor{gnat_rm/implementation_defined_pragmas id53}@anchor{112}@anchor{gnat_rm/implementation_defined_pragmas pragma-unused}@anchor{113} @section Pragma Unused @@ -8861,7 +8627,7 @@ Thus it is never necessary to use @code{pragma Unused} for such variables, though it is harmless to do so. @node Pragma Use_VADS_Size,Pragma Validity_Checks,Pragma Unused,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-use-vads-size}@anchor{111} +@anchor{gnat_rm/implementation_defined_pragmas pragma-use-vads-size}@anchor{114} @section Pragma Use_VADS_Size @@ -8885,7 +8651,7 @@ as implemented in the VADS compiler. See description of the VADS_Size attribute for further details. @node Pragma Validity_Checks,Pragma Volatile,Pragma Use_VADS_Size,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-validity-checks}@anchor{112} +@anchor{gnat_rm/implementation_defined_pragmas pragma-validity-checks}@anchor{115} @section Pragma Validity_Checks @@ -8941,7 +8707,7 @@ A := C; -- C will be validity checked @end example @node Pragma Volatile,Pragma Volatile_Full_Access,Pragma Validity_Checks,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id53}@anchor{113}@anchor{gnat_rm/implementation_defined_pragmas pragma-volatile}@anchor{114} +@anchor{gnat_rm/implementation_defined_pragmas id54}@anchor{116}@anchor{gnat_rm/implementation_defined_pragmas pragma-volatile}@anchor{117} @section Pragma Volatile @@ -8959,7 +8725,7 @@ implementation of pragma Volatile is upwards compatible with the implementation in DEC Ada 83. @node Pragma Volatile_Full_Access,Pragma Volatile_Function,Pragma Volatile,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id54}@anchor{115}@anchor{gnat_rm/implementation_defined_pragmas pragma-volatile-full-access}@anchor{116} +@anchor{gnat_rm/implementation_defined_pragmas id55}@anchor{118}@anchor{gnat_rm/implementation_defined_pragmas pragma-volatile-full-access}@anchor{119} @section Pragma Volatile_Full_Access @@ -8985,7 +8751,7 @@ is not to the whole object; the compiler is allowed (and generally will) access only part of the object in this case. @node Pragma Volatile_Function,Pragma Warning_As_Error,Pragma Volatile_Full_Access,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id55}@anchor{117}@anchor{gnat_rm/implementation_defined_pragmas pragma-volatile-function}@anchor{118} +@anchor{gnat_rm/implementation_defined_pragmas id56}@anchor{11a}@anchor{gnat_rm/implementation_defined_pragmas pragma-volatile-function}@anchor{11b} @section Pragma Volatile_Function @@ -8999,7 +8765,7 @@ For the semantics of this pragma, see the entry for aspect @code{Volatile_Functi in the SPARK 2014 Reference Manual, section 7.1.2. @node Pragma Warning_As_Error,Pragma Warnings,Pragma Volatile_Function,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-warning-as-error}@anchor{119} +@anchor{gnat_rm/implementation_defined_pragmas pragma-warning-as-error}@anchor{11c} @section Pragma Warning_As_Error @@ -9039,7 +8805,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}. +warnings provided by the back end and mentioned in @ref{11d,,Pragma Warnings}. By using a single full `-Wxxx' switch in the pragma, such warnings can also be treated as errors. @@ -9089,7 +8855,7 @@ the tag is changed from “warning:” to “error:” and the string “[warning-as-error]” is appended to the end of the message. @node Pragma Warnings,Pragma Weak_External,Pragma Warning_As_Error,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id56}@anchor{11b}@anchor{gnat_rm/implementation_defined_pragmas pragma-warnings}@anchor{11a} +@anchor{gnat_rm/implementation_defined_pragmas id57}@anchor{11e}@anchor{gnat_rm/implementation_defined_pragmas pragma-warnings}@anchor{11d} @section Pragma Warnings @@ -9245,7 +9011,7 @@ selectively for each tool, and as a consequence to detect useless pragma Warnings with switch @code{-gnatw.w}. @node Pragma Weak_External,Pragma Wide_Character_Encoding,Pragma Warnings,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-weak-external}@anchor{11c} +@anchor{gnat_rm/implementation_defined_pragmas pragma-weak-external}@anchor{11f} @section Pragma Weak_External @@ -9296,7 +9062,7 @@ end External_Module; @end example @node Pragma Wide_Character_Encoding,,Pragma Weak_External,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-wide-character-encoding}@anchor{11d} +@anchor{gnat_rm/implementation_defined_pragmas pragma-wide-character-encoding}@anchor{120} @section Pragma Wide_Character_Encoding @@ -9327,7 +9093,7 @@ encoding within that file, and does not affect withed units, specs, or subunits. @node Implementation Defined Aspects,Implementation Defined Attributes,Implementation Defined Pragmas,Top -@anchor{gnat_rm/implementation_defined_aspects doc}@anchor{11e}@anchor{gnat_rm/implementation_defined_aspects id1}@anchor{11f}@anchor{gnat_rm/implementation_defined_aspects implementation-defined-aspects}@anchor{120} +@anchor{gnat_rm/implementation_defined_aspects doc}@anchor{121}@anchor{gnat_rm/implementation_defined_aspects id1}@anchor{122}@anchor{gnat_rm/implementation_defined_aspects implementation-defined-aspects}@anchor{123} @chapter Implementation Defined Aspects @@ -9398,6 +9164,7 @@ or attribute definition clause. * Aspect Extensions_Visible:: * Aspect Favor_Top_Level:: * Aspect Ghost:: +* Aspect Ghost_Predicate:: * Aspect Global:: * Aspect Initial_Condition:: * Aspect Initializes:: @@ -9447,7 +9214,7 @@ or attribute definition clause. @end menu @node Aspect Abstract_State,Aspect Annotate,,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-abstract-state}@anchor{121} +@anchor{gnat_rm/implementation_defined_aspects aspect-abstract-state}@anchor{124} @section Aspect Abstract_State @@ -9456,7 +9223,7 @@ or attribute definition clause. This aspect is equivalent to @ref{1e,,pragma Abstract_State}. @node Aspect Annotate,Aspect Async_Readers,Aspect Abstract_State,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-annotate}@anchor{122} +@anchor{gnat_rm/implementation_defined_aspects aspect-annotate}@anchor{125} @section Aspect Annotate @@ -9483,7 +9250,7 @@ Equivalent to @code{pragma Annotate (ID, ID @{, ARG@}, Entity => Name);} @end table @node Aspect Async_Readers,Aspect Async_Writers,Aspect Annotate,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-async-readers}@anchor{123} +@anchor{gnat_rm/implementation_defined_aspects aspect-async-readers}@anchor{126} @section Aspect Async_Readers @@ -9492,7 +9259,7 @@ Equivalent to @code{pragma Annotate (ID, ID @{, ARG@}, Entity => Name);} This boolean aspect is equivalent to @ref{30,,pragma Async_Readers}. @node Aspect Async_Writers,Aspect Constant_After_Elaboration,Aspect Async_Readers,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-async-writers}@anchor{124} +@anchor{gnat_rm/implementation_defined_aspects aspect-async-writers}@anchor{127} @section Aspect Async_Writers @@ -9501,7 +9268,7 @@ This boolean aspect is equivalent to @ref{30,,pragma Async_Readers}. This boolean aspect is equivalent to @ref{32,,pragma Async_Writers}. @node Aspect Constant_After_Elaboration,Aspect Contract_Cases,Aspect Async_Writers,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-constant-after-elaboration}@anchor{125} +@anchor{gnat_rm/implementation_defined_aspects aspect-constant-after-elaboration}@anchor{128} @section Aspect Constant_After_Elaboration @@ -9510,7 +9277,7 @@ This boolean aspect is equivalent to @ref{32,,pragma Async_Writers}. This aspect is equivalent to @ref{42,,pragma Constant_After_Elaboration}. @node Aspect Contract_Cases,Aspect Depends,Aspect Constant_After_Elaboration,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-contract-cases}@anchor{126} +@anchor{gnat_rm/implementation_defined_aspects aspect-contract-cases}@anchor{129} @section Aspect Contract_Cases @@ -9521,7 +9288,7 @@ of clauses being enclosed in parentheses so that syntactically it is an aggregate. @node Aspect Depends,Aspect Default_Initial_Condition,Aspect Contract_Cases,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-depends}@anchor{127} +@anchor{gnat_rm/implementation_defined_aspects aspect-depends}@anchor{12a} @section Aspect Depends @@ -9530,7 +9297,7 @@ aggregate. This aspect is equivalent to @ref{54,,pragma Depends}. @node Aspect Default_Initial_Condition,Aspect Dimension,Aspect Depends,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-default-initial-condition}@anchor{128} +@anchor{gnat_rm/implementation_defined_aspects aspect-default-initial-condition}@anchor{12b} @section Aspect Default_Initial_Condition @@ -9539,7 +9306,7 @@ This aspect is equivalent to @ref{54,,pragma Depends}. This aspect is equivalent to @ref{50,,pragma Default_Initial_Condition}. @node Aspect Dimension,Aspect Dimension_System,Aspect Default_Initial_Condition,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-dimension}@anchor{129} +@anchor{gnat_rm/implementation_defined_aspects aspect-dimension}@anchor{12c} @section Aspect Dimension @@ -9575,7 +9342,7 @@ Note that when the dimensioned type is an integer type, then any dimension value must be an integer literal. @node Aspect Dimension_System,Aspect Disable_Controlled,Aspect Dimension,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-dimension-system}@anchor{12a} +@anchor{gnat_rm/implementation_defined_aspects aspect-dimension-system}@anchor{12d} @section Aspect Dimension_System @@ -9635,7 +9402,7 @@ See section ‘Performing Dimensionality Analysis in GNAT’ in the GNAT Users Guide for detailed examples of use of the dimension system. @node Aspect Disable_Controlled,Aspect Effective_Reads,Aspect Dimension_System,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-disable-controlled}@anchor{12b} +@anchor{gnat_rm/implementation_defined_aspects aspect-disable-controlled}@anchor{12e} @section Aspect Disable_Controlled @@ -9648,7 +9415,7 @@ where for example you might want a record to be controlled or not depending on whether some run-time check is enabled or suppressed. @node Aspect Effective_Reads,Aspect Effective_Writes,Aspect Disable_Controlled,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-effective-reads}@anchor{12c} +@anchor{gnat_rm/implementation_defined_aspects aspect-effective-reads}@anchor{12f} @section Aspect Effective_Reads @@ -9657,7 +9424,7 @@ whether some run-time check is enabled or suppressed. This aspect is equivalent to @ref{59,,pragma Effective_Reads}. @node Aspect Effective_Writes,Aspect Extensions_Visible,Aspect Effective_Reads,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-effective-writes}@anchor{12d} +@anchor{gnat_rm/implementation_defined_aspects aspect-effective-writes}@anchor{130} @section Aspect Effective_Writes @@ -9666,92 +9433,105 @@ This aspect is equivalent to @ref{59,,pragma Effective_Reads}. This aspect is equivalent to @ref{5b,,pragma Effective_Writes}. @node Aspect Extensions_Visible,Aspect Favor_Top_Level,Aspect Effective_Writes,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-extensions-visible}@anchor{12e} +@anchor{gnat_rm/implementation_defined_aspects aspect-extensions-visible}@anchor{131} @section Aspect Extensions_Visible @geindex Extensions_Visible -This aspect is equivalent to @ref{66,,pragma Extensions_Visible}. +This aspect is equivalent to @ref{69,,pragma Extensions_Visible}. @node Aspect Favor_Top_Level,Aspect Ghost,Aspect Extensions_Visible,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-favor-top-level}@anchor{12f} +@anchor{gnat_rm/implementation_defined_aspects aspect-favor-top-level}@anchor{132} @section Aspect Favor_Top_Level @geindex Favor_Top_Level -This boolean aspect is equivalent to @ref{6b,,pragma Favor_Top_Level}. +This boolean aspect is equivalent to @ref{6e,,pragma Favor_Top_Level}. -@node Aspect Ghost,Aspect Global,Aspect Favor_Top_Level,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-ghost}@anchor{130} +@node Aspect Ghost,Aspect Ghost_Predicate,Aspect Favor_Top_Level,Implementation Defined Aspects +@anchor{gnat_rm/implementation_defined_aspects aspect-ghost}@anchor{133} @section Aspect Ghost @geindex Ghost -This aspect is equivalent to @ref{6f,,pragma Ghost}. +This aspect is equivalent to @ref{72,,pragma Ghost}. + +@node Aspect Ghost_Predicate,Aspect Global,Aspect Ghost,Implementation Defined Aspects +@anchor{gnat_rm/implementation_defined_aspects aspect-ghost-predicate}@anchor{134} +@section Aspect Ghost_Predicate + + +@geindex Ghost_Predicate + +This aspect introduces a subtype predicate that can reference ghost +entities. The subtype cannot appear as a subtype_mark in a membership test. -@node Aspect Global,Aspect Initial_Condition,Aspect Ghost,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-global}@anchor{131} +For the detailed semantics of this aspect, see the entry for subtype predicates +in the SPARK Reference Manual, section 3.2.4. + +@node Aspect Global,Aspect Initial_Condition,Aspect Ghost_Predicate,Implementation Defined Aspects +@anchor{gnat_rm/implementation_defined_aspects aspect-global}@anchor{135} @section Aspect Global @geindex Global -This aspect is equivalent to @ref{71,,pragma Global}. +This aspect is equivalent to @ref{74,,pragma Global}. @node Aspect Initial_Condition,Aspect Initializes,Aspect Global,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-initial-condition}@anchor{132} +@anchor{gnat_rm/implementation_defined_aspects aspect-initial-condition}@anchor{136} @section Aspect Initial_Condition @geindex Initial_Condition -This aspect is equivalent to @ref{7e,,pragma Initial_Condition}. +This aspect is equivalent to @ref{81,,pragma Initial_Condition}. @node Aspect Initializes,Aspect Inline_Always,Aspect Initial_Condition,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-initializes}@anchor{133} +@anchor{gnat_rm/implementation_defined_aspects aspect-initializes}@anchor{137} @section Aspect Initializes @geindex Initializes -This aspect is equivalent to @ref{81,,pragma Initializes}. +This aspect is equivalent to @ref{84,,pragma Initializes}. @node Aspect Inline_Always,Aspect Invariant,Aspect Initializes,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-inline-always}@anchor{134} +@anchor{gnat_rm/implementation_defined_aspects aspect-inline-always}@anchor{138} @section Aspect Inline_Always @geindex Inline_Always -This boolean aspect is equivalent to @ref{83,,pragma Inline_Always}. +This boolean aspect is equivalent to @ref{86,,pragma Inline_Always}. @node Aspect Invariant,Aspect Invariant’Class,Aspect Inline_Always,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-invariant}@anchor{135} +@anchor{gnat_rm/implementation_defined_aspects aspect-invariant}@anchor{139} @section Aspect Invariant @geindex Invariant -This aspect is equivalent to @ref{8a,,pragma Invariant}. It is a +This aspect is equivalent to @ref{8d,,pragma Invariant}. It is a synonym for the language defined aspect @code{Type_Invariant} except that it is separately controllable using pragma @code{Assertion_Policy}. @node Aspect Invariant’Class,Aspect Iterable,Aspect Invariant,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-invariant-class}@anchor{136} +@anchor{gnat_rm/implementation_defined_aspects aspect-invariant-class}@anchor{13a} @section Aspect Invariant’Class @geindex Invariant'Class -This aspect is equivalent to @ref{101,,pragma Type_Invariant_Class}. It is a +This aspect is equivalent to @ref{104,,pragma Type_Invariant_Class}. It is a synonym for the language defined aspect @code{Type_Invariant'Class} except that it is separately controllable using pragma @code{Assertion_Policy}. @node Aspect Iterable,Aspect Linker_Section,Aspect Invariant’Class,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-iterable}@anchor{137} +@anchor{gnat_rm/implementation_defined_aspects aspect-iterable}@anchor{13b} @section Aspect Iterable @@ -9835,73 +9615,73 @@ function Get_Element (Cont : Container; Position : Cursor) return Element_Type; This aspect is used in the GNAT-defined formal container packages. @node Aspect Linker_Section,Aspect Lock_Free,Aspect Iterable,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-linker-section}@anchor{138} +@anchor{gnat_rm/implementation_defined_aspects aspect-linker-section}@anchor{13c} @section Aspect Linker_Section @geindex Linker_Section -This aspect is equivalent to @ref{92,,pragma Linker_Section}. +This aspect is equivalent to @ref{95,,pragma Linker_Section}. @node Aspect Lock_Free,Aspect Max_Queue_Length,Aspect Linker_Section,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-lock-free}@anchor{139} +@anchor{gnat_rm/implementation_defined_aspects aspect-lock-free}@anchor{13d} @section Aspect Lock_Free @geindex Lock_Free -This boolean aspect is equivalent to @ref{94,,pragma Lock_Free}. +This boolean aspect is equivalent to @ref{97,,pragma Lock_Free}. @node Aspect Max_Queue_Length,Aspect No_Caching,Aspect Lock_Free,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-max-queue-length}@anchor{13a} +@anchor{gnat_rm/implementation_defined_aspects aspect-max-queue-length}@anchor{13e} @section Aspect Max_Queue_Length @geindex Max_Queue_Length -This aspect is equivalent to @ref{9c,,pragma Max_Queue_Length}. +This aspect is equivalent to @ref{9f,,pragma Max_Queue_Length}. @node Aspect No_Caching,Aspect No_Elaboration_Code_All,Aspect Max_Queue_Length,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-no-caching}@anchor{13b} +@anchor{gnat_rm/implementation_defined_aspects aspect-no-caching}@anchor{13f} @section Aspect No_Caching @geindex No_Caching -This boolean aspect is equivalent to @ref{9f,,pragma No_Caching}. +This boolean aspect is equivalent to @ref{a2,,pragma No_Caching}. @node Aspect No_Elaboration_Code_All,Aspect No_Inline,Aspect No_Caching,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-no-elaboration-code-all}@anchor{13c} +@anchor{gnat_rm/implementation_defined_aspects aspect-no-elaboration-code-all}@anchor{140} @section Aspect No_Elaboration_Code_All @geindex No_Elaboration_Code_All -This aspect is equivalent to @ref{a2,,pragma No_Elaboration_Code_All} +This aspect is equivalent to @ref{a5,,pragma No_Elaboration_Code_All} for a program unit. @node Aspect No_Inline,Aspect No_Tagged_Streams,Aspect No_Elaboration_Code_All,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-no-inline}@anchor{13d} +@anchor{gnat_rm/implementation_defined_aspects aspect-no-inline}@anchor{141} @section Aspect No_Inline @geindex No_Inline -This boolean aspect is equivalent to @ref{a5,,pragma No_Inline}. +This boolean aspect is equivalent to @ref{a8,,pragma No_Inline}. @node Aspect No_Tagged_Streams,Aspect No_Task_Parts,Aspect No_Inline,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-no-tagged-streams}@anchor{13e} +@anchor{gnat_rm/implementation_defined_aspects aspect-no-tagged-streams}@anchor{142} @section Aspect No_Tagged_Streams @geindex No_Tagged_Streams -This aspect is equivalent to @ref{a9,,pragma No_Tagged_Streams} with an +This aspect is equivalent to @ref{ac,,pragma No_Tagged_Streams} with an argument specifying a root tagged type (thus this aspect can only be applied to such a type). @node Aspect No_Task_Parts,Aspect Object_Size,Aspect No_Tagged_Streams,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-no-task-parts}@anchor{13f} +@anchor{gnat_rm/implementation_defined_aspects aspect-no-task-parts}@anchor{143} @section Aspect No_Task_Parts @@ -9917,51 +9697,51 @@ away certain tasking-related code that would otherwise be needed for T’Class, because descendants of T might contain tasks. @node Aspect Object_Size,Aspect Obsolescent,Aspect No_Task_Parts,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-object-size}@anchor{140} +@anchor{gnat_rm/implementation_defined_aspects aspect-object-size}@anchor{144} @section Aspect Object_Size @geindex Object_Size -This aspect is equivalent to @ref{141,,attribute Object_Size}. +This aspect is equivalent to @ref{145,,attribute Object_Size}. @node Aspect Obsolescent,Aspect Part_Of,Aspect Object_Size,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-obsolescent}@anchor{142} +@anchor{gnat_rm/implementation_defined_aspects aspect-obsolescent}@anchor{146} @section Aspect Obsolescent @geindex Obsolescent -This aspect is equivalent to @ref{ac,,pragma Obsolescent}. Note that the +This aspect is equivalent to @ref{af,,pragma Obsolescent}. Note that the evaluation of this aspect happens at the point of occurrence, it is not delayed until the freeze point. @node Aspect Part_Of,Aspect Persistent_BSS,Aspect Obsolescent,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-part-of}@anchor{143} +@anchor{gnat_rm/implementation_defined_aspects aspect-part-of}@anchor{147} @section Aspect Part_Of @geindex Part_Of -This aspect is equivalent to @ref{b2,,pragma Part_Of}. +This aspect is equivalent to @ref{b5,,pragma Part_Of}. @node Aspect Persistent_BSS,Aspect Predicate,Aspect Part_Of,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-persistent-bss}@anchor{144} +@anchor{gnat_rm/implementation_defined_aspects aspect-persistent-bss}@anchor{148} @section Aspect Persistent_BSS @geindex Persistent_BSS -This boolean aspect is equivalent to @ref{b6,,pragma Persistent_BSS}. +This boolean aspect is equivalent to @ref{b9,,pragma Persistent_BSS}. @node Aspect Predicate,Aspect Pure_Function,Aspect Persistent_BSS,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-predicate}@anchor{145} +@anchor{gnat_rm/implementation_defined_aspects aspect-predicate}@anchor{149} @section Aspect Predicate @geindex Predicate -This aspect is equivalent to @ref{bd,,pragma Predicate}. It is thus +This aspect is equivalent to @ref{c0,,pragma Predicate}. It is thus similar to the language defined aspects @code{Dynamic_Predicate} and @code{Static_Predicate} except that whether the resulting predicate is static or dynamic is controlled by the form of the @@ -9969,52 +9749,52 @@ expression. It is also separately controllable using pragma @code{Assertion_Policy}. @node Aspect Pure_Function,Aspect Refined_Depends,Aspect Predicate,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-pure-function}@anchor{146} +@anchor{gnat_rm/implementation_defined_aspects aspect-pure-function}@anchor{14a} @section Aspect Pure_Function @geindex Pure_Function -This boolean aspect is equivalent to @ref{c9,,pragma Pure_Function}. +This boolean aspect is equivalent to @ref{cc,,pragma Pure_Function}. @node Aspect Refined_Depends,Aspect Refined_Global,Aspect Pure_Function,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-refined-depends}@anchor{147} +@anchor{gnat_rm/implementation_defined_aspects aspect-refined-depends}@anchor{14b} @section Aspect Refined_Depends @geindex Refined_Depends -This aspect is equivalent to @ref{cd,,pragma Refined_Depends}. +This aspect is equivalent to @ref{d0,,pragma Refined_Depends}. @node Aspect Refined_Global,Aspect Refined_Post,Aspect Refined_Depends,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-refined-global}@anchor{148} +@anchor{gnat_rm/implementation_defined_aspects aspect-refined-global}@anchor{14c} @section Aspect Refined_Global @geindex Refined_Global -This aspect is equivalent to @ref{cf,,pragma Refined_Global}. +This aspect is equivalent to @ref{d2,,pragma Refined_Global}. @node Aspect Refined_Post,Aspect Refined_State,Aspect Refined_Global,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-refined-post}@anchor{149} +@anchor{gnat_rm/implementation_defined_aspects aspect-refined-post}@anchor{14d} @section Aspect Refined_Post @geindex Refined_Post -This aspect is equivalent to @ref{d1,,pragma Refined_Post}. +This aspect is equivalent to @ref{d4,,pragma Refined_Post}. @node Aspect Refined_State,Aspect Relaxed_Initialization,Aspect Refined_Post,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-refined-state}@anchor{14a} +@anchor{gnat_rm/implementation_defined_aspects aspect-refined-state}@anchor{14e} @section Aspect Refined_State @geindex Refined_State -This aspect is equivalent to @ref{d3,,pragma Refined_State}. +This aspect is equivalent to @ref{d6,,pragma Refined_State}. @node Aspect Relaxed_Initialization,Aspect Remote_Access_Type,Aspect Refined_State,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-relaxed-initialization}@anchor{14b} +@anchor{gnat_rm/implementation_defined_aspects aspect-relaxed-initialization}@anchor{14f} @section Aspect Relaxed_Initialization @@ -10024,187 +9804,187 @@ For the syntax and semantics of this aspect, see the SPARK 2014 Reference Manual, section 6.10. @node Aspect Remote_Access_Type,Aspect Secondary_Stack_Size,Aspect Relaxed_Initialization,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-remote-access-type}@anchor{14c} +@anchor{gnat_rm/implementation_defined_aspects aspect-remote-access-type}@anchor{150} @section Aspect Remote_Access_Type @geindex Remote_Access_Type -This aspect is equivalent to @ref{d6,,pragma Remote_Access_Type}. +This aspect is equivalent to @ref{d9,,pragma Remote_Access_Type}. @node Aspect Secondary_Stack_Size,Aspect Scalar_Storage_Order,Aspect Remote_Access_Type,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-secondary-stack-size}@anchor{14d} +@anchor{gnat_rm/implementation_defined_aspects aspect-secondary-stack-size}@anchor{151} @section Aspect Secondary_Stack_Size @geindex Secondary_Stack_Size -This aspect is equivalent to @ref{dc,,pragma Secondary_Stack_Size}. +This aspect is equivalent to @ref{df,,pragma Secondary_Stack_Size}. @node Aspect Scalar_Storage_Order,Aspect Shared,Aspect Secondary_Stack_Size,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-scalar-storage-order}@anchor{14e} +@anchor{gnat_rm/implementation_defined_aspects aspect-scalar-storage-order}@anchor{152} @section Aspect Scalar_Storage_Order @geindex Scalar_Storage_Order -This aspect is equivalent to a @ref{14f,,attribute Scalar_Storage_Order}. +This aspect is equivalent to a @ref{153,,attribute Scalar_Storage_Order}. @node Aspect Shared,Aspect Simple_Storage_Pool,Aspect Scalar_Storage_Order,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-shared}@anchor{150} +@anchor{gnat_rm/implementation_defined_aspects aspect-shared}@anchor{154} @section Aspect Shared @geindex Shared -This boolean aspect is equivalent to @ref{df,,pragma Shared} +This boolean aspect is equivalent to @ref{e2,,pragma Shared} and is thus a synonym for aspect @code{Atomic}. @node Aspect Simple_Storage_Pool,Aspect Simple_Storage_Pool_Type,Aspect Shared,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-simple-storage-pool}@anchor{151} +@anchor{gnat_rm/implementation_defined_aspects aspect-simple-storage-pool}@anchor{155} @section Aspect Simple_Storage_Pool @geindex Simple_Storage_Pool -This aspect is equivalent to @ref{e4,,attribute Simple_Storage_Pool}. +This aspect is equivalent to @ref{e7,,attribute Simple_Storage_Pool}. @node Aspect Simple_Storage_Pool_Type,Aspect SPARK_Mode,Aspect Simple_Storage_Pool,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-simple-storage-pool-type}@anchor{152} +@anchor{gnat_rm/implementation_defined_aspects aspect-simple-storage-pool-type}@anchor{156} @section Aspect Simple_Storage_Pool_Type @geindex Simple_Storage_Pool_Type -This boolean aspect is equivalent to @ref{e3,,pragma Simple_Storage_Pool_Type}. +This boolean aspect is equivalent to @ref{e6,,pragma Simple_Storage_Pool_Type}. @node Aspect SPARK_Mode,Aspect Suppress_Debug_Info,Aspect Simple_Storage_Pool_Type,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-spark-mode}@anchor{153} +@anchor{gnat_rm/implementation_defined_aspects aspect-spark-mode}@anchor{157} @section Aspect SPARK_Mode @geindex SPARK_Mode -This aspect is equivalent to @ref{eb,,pragma SPARK_Mode} and +This aspect is equivalent to @ref{ee,,pragma SPARK_Mode} and may be specified for either or both of the specification and body of a subprogram or package. @node Aspect Suppress_Debug_Info,Aspect Suppress_Initialization,Aspect SPARK_Mode,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-suppress-debug-info}@anchor{154} +@anchor{gnat_rm/implementation_defined_aspects aspect-suppress-debug-info}@anchor{158} @section Aspect Suppress_Debug_Info @geindex Suppress_Debug_Info -This boolean aspect is equivalent to @ref{f3,,pragma Suppress_Debug_Info}. +This boolean aspect is equivalent to @ref{f6,,pragma Suppress_Debug_Info}. @node Aspect Suppress_Initialization,Aspect Test_Case,Aspect Suppress_Debug_Info,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-suppress-initialization}@anchor{155} +@anchor{gnat_rm/implementation_defined_aspects aspect-suppress-initialization}@anchor{159} @section Aspect Suppress_Initialization @geindex Suppress_Initialization -This boolean aspect is equivalent to @ref{f6,,pragma Suppress_Initialization}. +This boolean aspect is equivalent to @ref{f9,,pragma Suppress_Initialization}. @node Aspect Test_Case,Aspect Thread_Local_Storage,Aspect Suppress_Initialization,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-test-case}@anchor{156} +@anchor{gnat_rm/implementation_defined_aspects aspect-test-case}@anchor{15a} @section Aspect Test_Case @geindex Test_Case -This aspect is equivalent to @ref{fa,,pragma Test_Case}. +This aspect is equivalent to @ref{fd,,pragma Test_Case}. @node Aspect Thread_Local_Storage,Aspect Universal_Aliasing,Aspect Test_Case,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-thread-local-storage}@anchor{157} +@anchor{gnat_rm/implementation_defined_aspects aspect-thread-local-storage}@anchor{15b} @section Aspect Thread_Local_Storage @geindex Thread_Local_Storage -This boolean aspect is equivalent to @ref{fc,,pragma Thread_Local_Storage}. +This boolean aspect is equivalent to @ref{ff,,pragma Thread_Local_Storage}. @node Aspect Universal_Aliasing,Aspect Unmodified,Aspect Thread_Local_Storage,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-universal-aliasing}@anchor{158} +@anchor{gnat_rm/implementation_defined_aspects aspect-universal-aliasing}@anchor{15c} @section Aspect Universal_Aliasing @geindex Universal_Aliasing -This boolean aspect is equivalent to @ref{106,,pragma Universal_Aliasing}. +This boolean aspect is equivalent to @ref{109,,pragma Universal_Aliasing}. @node Aspect Unmodified,Aspect Unreferenced,Aspect Universal_Aliasing,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-unmodified}@anchor{159} +@anchor{gnat_rm/implementation_defined_aspects aspect-unmodified}@anchor{15d} @section Aspect Unmodified @geindex Unmodified -This boolean aspect is equivalent to @ref{108,,pragma Unmodified}. +This boolean aspect is equivalent to @ref{10b,,pragma Unmodified}. @node Aspect Unreferenced,Aspect Unreferenced_Objects,Aspect Unmodified,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-unreferenced}@anchor{15a} +@anchor{gnat_rm/implementation_defined_aspects aspect-unreferenced}@anchor{15e} @section Aspect Unreferenced @geindex Unreferenced -This boolean aspect is equivalent to @ref{10a,,pragma Unreferenced}. +This boolean aspect is equivalent to @ref{10d,,pragma Unreferenced}. When using the @code{-gnat2022} switch, this aspect is also supported on formal parameters, which is in particular the only form possible for expression functions. @node Aspect Unreferenced_Objects,Aspect Value_Size,Aspect Unreferenced,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-unreferenced-objects}@anchor{15b} +@anchor{gnat_rm/implementation_defined_aspects aspect-unreferenced-objects}@anchor{15f} @section Aspect Unreferenced_Objects @geindex Unreferenced_Objects -This boolean aspect is equivalent to @ref{10c,,pragma Unreferenced_Objects}. +This boolean aspect is equivalent to @ref{10f,,pragma Unreferenced_Objects}. @node Aspect Value_Size,Aspect Volatile_Full_Access,Aspect Unreferenced_Objects,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-value-size}@anchor{15c} +@anchor{gnat_rm/implementation_defined_aspects aspect-value-size}@anchor{160} @section Aspect Value_Size @geindex Value_Size -This aspect is equivalent to @ref{15d,,attribute Value_Size}. +This aspect is equivalent to @ref{161,,attribute Value_Size}. @node Aspect Volatile_Full_Access,Aspect Volatile_Function,Aspect Value_Size,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-volatile-full-access}@anchor{15e} +@anchor{gnat_rm/implementation_defined_aspects aspect-volatile-full-access}@anchor{162} @section Aspect Volatile_Full_Access @geindex Volatile_Full_Access -This boolean aspect is equivalent to @ref{116,,pragma Volatile_Full_Access}. +This boolean aspect is equivalent to @ref{119,,pragma Volatile_Full_Access}. @node Aspect Volatile_Function,Aspect Warnings,Aspect Volatile_Full_Access,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-volatile-function}@anchor{15f} +@anchor{gnat_rm/implementation_defined_aspects aspect-volatile-function}@anchor{163} @section Aspect Volatile_Function @geindex Volatile_Function -This boolean aspect is equivalent to @ref{118,,pragma Volatile_Function}. +This boolean aspect is equivalent to @ref{11b,,pragma Volatile_Function}. @node Aspect Warnings,,Aspect Volatile_Function,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-warnings}@anchor{160} +@anchor{gnat_rm/implementation_defined_aspects aspect-warnings}@anchor{164} @section Aspect Warnings @geindex Warnings -This aspect is equivalent to the two argument form of @ref{11a,,pragma Warnings}, +This aspect is equivalent to the two argument form of @ref{11d,,pragma Warnings}, where the first argument is @code{ON} or @code{OFF} and the second argument is the entity. @node Implementation Defined Attributes,Standard and Implementation Defined Restrictions,Implementation Defined Aspects,Top -@anchor{gnat_rm/implementation_defined_attributes doc}@anchor{161}@anchor{gnat_rm/implementation_defined_attributes id1}@anchor{162}@anchor{gnat_rm/implementation_defined_attributes implementation-defined-attributes}@anchor{8} +@anchor{gnat_rm/implementation_defined_attributes doc}@anchor{165}@anchor{gnat_rm/implementation_defined_attributes id1}@anchor{166}@anchor{gnat_rm/implementation_defined_attributes implementation-defined-attributes}@anchor{8} @chapter Implementation Defined Attributes @@ -10310,7 +10090,7 @@ consideration, you should minimize the use of these attributes. @end menu @node Attribute Abort_Signal,Attribute Address_Size,,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-abort-signal}@anchor{163} +@anchor{gnat_rm/implementation_defined_attributes attribute-abort-signal}@anchor{167} @section Attribute Abort_Signal @@ -10324,7 +10104,7 @@ completely outside the normal semantics of Ada, for a user program to intercept the abort exception). @node Attribute Address_Size,Attribute Asm_Input,Attribute Abort_Signal,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-address-size}@anchor{164} +@anchor{gnat_rm/implementation_defined_attributes attribute-address-size}@anchor{168} @section Attribute Address_Size @@ -10340,7 +10120,7 @@ reference to System.Address’Size is nonstatic because Address is a private type. @node Attribute Asm_Input,Attribute Asm_Output,Attribute Address_Size,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-asm-input}@anchor{165} +@anchor{gnat_rm/implementation_defined_attributes attribute-asm-input}@anchor{169} @section Attribute Asm_Input @@ -10354,10 +10134,10 @@ to be a static expression, and is the constraint for the parameter, value to be used as the input argument. The possible values for the constant are the same as those used in the RTL, and are dependent on the configuration file used to built the GCC back end. -@ref{166,,Machine Code Insertions} +@ref{16a,,Machine Code Insertions} @node Attribute Asm_Output,Attribute Atomic_Always_Lock_Free,Attribute Asm_Input,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-asm-output}@anchor{167} +@anchor{gnat_rm/implementation_defined_attributes attribute-asm-output}@anchor{16b} @section Attribute Asm_Output @@ -10373,10 +10153,10 @@ result. The possible values for constraint are the same as those used in the RTL, and are dependent on the configuration file used to build the GCC back end. If there are no output operands, then this argument may either be omitted, or explicitly given as @code{No_Output_Operands}. -@ref{166,,Machine Code Insertions} +@ref{16a,,Machine Code Insertions} @node Attribute Atomic_Always_Lock_Free,Attribute Bit,Attribute Asm_Output,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-atomic-always-lock-free}@anchor{168} +@anchor{gnat_rm/implementation_defined_attributes attribute-atomic-always-lock-free}@anchor{16c} @section Attribute Atomic_Always_Lock_Free @@ -10388,7 +10168,7 @@ and False otherwise. The result indicate whether atomic operations are supported by the target for the given type. @node Attribute Bit,Attribute Bit_Position,Attribute Atomic_Always_Lock_Free,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-bit}@anchor{169} +@anchor{gnat_rm/implementation_defined_attributes attribute-bit}@anchor{16d} @section Attribute Bit @@ -10419,7 +10199,7 @@ This attribute is designed to be compatible with the DEC Ada 83 definition and implementation of the @code{Bit} attribute. @node Attribute Bit_Position,Attribute Code_Address,Attribute Bit,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-bit-position}@anchor{16a} +@anchor{gnat_rm/implementation_defined_attributes attribute-bit-position}@anchor{16e} @section Attribute Bit_Position @@ -10434,7 +10214,7 @@ type `universal_integer'. The value depends only on the field the containing record @code{R}. @node Attribute Code_Address,Attribute Compiler_Version,Attribute Bit_Position,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-code-address}@anchor{16b} +@anchor{gnat_rm/implementation_defined_attributes attribute-code-address}@anchor{16f} @section Attribute Code_Address @@ -10477,7 +10257,7 @@ the same value as is returned by the corresponding @code{'Address} attribute. @node Attribute Compiler_Version,Attribute Constrained,Attribute Code_Address,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-compiler-version}@anchor{16c} +@anchor{gnat_rm/implementation_defined_attributes attribute-compiler-version}@anchor{170} @section Attribute Compiler_Version @@ -10488,7 +10268,7 @@ prefix) yields a static string identifying the version of the compiler being used to compile the unit containing the attribute reference. @node Attribute Constrained,Attribute Default_Bit_Order,Attribute Compiler_Version,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-constrained}@anchor{16d} +@anchor{gnat_rm/implementation_defined_attributes attribute-constrained}@anchor{171} @section Attribute Constrained @@ -10503,7 +10283,7 @@ record type without discriminants is always @code{True}. This usage is compatible with older Ada compilers, including notably DEC Ada. @node Attribute Default_Bit_Order,Attribute Default_Scalar_Storage_Order,Attribute Constrained,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-default-bit-order}@anchor{16e} +@anchor{gnat_rm/implementation_defined_attributes attribute-default-bit-order}@anchor{172} @section Attribute Default_Bit_Order @@ -10520,7 +10300,7 @@ as a @code{Pos} value (0 for @code{High_Order_First}, 1 for @code{Default_Bit_Order} in package @code{System}. @node Attribute Default_Scalar_Storage_Order,Attribute Deref,Attribute Default_Bit_Order,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-default-scalar-storage-order}@anchor{16f} +@anchor{gnat_rm/implementation_defined_attributes attribute-default-scalar-storage-order}@anchor{173} @section Attribute Default_Scalar_Storage_Order @@ -10537,7 +10317,7 @@ equal to @code{Default_Bit_Order} if unspecified) as a @code{System.Bit_Order} value. This is a static attribute. @node Attribute Deref,Attribute Descriptor_Size,Attribute Default_Scalar_Storage_Order,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-deref}@anchor{170} +@anchor{gnat_rm/implementation_defined_attributes attribute-deref}@anchor{174} @section Attribute Deref @@ -10550,7 +10330,7 @@ a named access-to-@cite{typ} type, except that it yields a variable, so it can b used on the left side of an assignment. @node Attribute Descriptor_Size,Attribute Elaborated,Attribute Deref,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-descriptor-size}@anchor{171} +@anchor{gnat_rm/implementation_defined_attributes attribute-descriptor-size}@anchor{175} @section Attribute Descriptor_Size @@ -10579,7 +10359,7 @@ since @code{Positive} has an alignment of 4, the size of the descriptor is which yields a size of 32 bits, i.e. including 16 bits of padding. @node Attribute Elaborated,Attribute Elab_Body,Attribute Descriptor_Size,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-elaborated}@anchor{172} +@anchor{gnat_rm/implementation_defined_attributes attribute-elaborated}@anchor{176} @section Attribute Elaborated @@ -10594,7 +10374,7 @@ units has been completed. An exception is for units which need no elaboration, the value is always False for such units. @node Attribute Elab_Body,Attribute Elab_Spec,Attribute Elaborated,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-elab-body}@anchor{173} +@anchor{gnat_rm/implementation_defined_attributes attribute-elab-body}@anchor{177} @section Attribute Elab_Body @@ -10610,7 +10390,7 @@ e.g., if it is necessary to do selective re-elaboration to fix some error. @node Attribute Elab_Spec,Attribute Elab_Subp_Body,Attribute Elab_Body,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-elab-spec}@anchor{174} +@anchor{gnat_rm/implementation_defined_attributes attribute-elab-spec}@anchor{178} @section Attribute Elab_Spec @@ -10626,7 +10406,7 @@ Ada code, e.g., if it is necessary to do selective re-elaboration to fix some error. @node Attribute Elab_Subp_Body,Attribute Emax,Attribute Elab_Spec,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-elab-subp-body}@anchor{175} +@anchor{gnat_rm/implementation_defined_attributes attribute-elab-subp-body}@anchor{179} @section Attribute Elab_Subp_Body @@ -10640,7 +10420,7 @@ elaboration procedure by the binder in CodePeer mode only and is unrecognized otherwise. @node Attribute Emax,Attribute Enabled,Attribute Elab_Subp_Body,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-emax}@anchor{176} +@anchor{gnat_rm/implementation_defined_attributes attribute-emax}@anchor{17a} @section Attribute Emax @@ -10653,7 +10433,7 @@ the Ada 83 reference manual for an exact description of the semantics of this attribute. @node Attribute Enabled,Attribute Enum_Rep,Attribute Emax,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-enabled}@anchor{177} +@anchor{gnat_rm/implementation_defined_attributes attribute-enabled}@anchor{17b} @section Attribute Enabled @@ -10677,7 +10457,7 @@ a @code{pragma Suppress} or @code{pragma Unsuppress} before instantiating the package or subprogram, controlling whether the check will be present. @node Attribute Enum_Rep,Attribute Enum_Val,Attribute Enabled,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-enum-rep}@anchor{178} +@anchor{gnat_rm/implementation_defined_attributes attribute-enum-rep}@anchor{17c} @section Attribute Enum_Rep @@ -10717,7 +10497,7 @@ integer calculation is done at run time, then the call to @code{Enum_Rep} may raise @code{Constraint_Error}. @node Attribute Enum_Val,Attribute Epsilon,Attribute Enum_Rep,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-enum-val}@anchor{179} +@anchor{gnat_rm/implementation_defined_attributes attribute-enum-val}@anchor{17d} @section Attribute Enum_Val @@ -10743,7 +10523,7 @@ absence of an enumeration representation clause. This is a static attribute (i.e., the result is static if the argument is static). @node Attribute Epsilon,Attribute Fast_Math,Attribute Enum_Val,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-epsilon}@anchor{17a} +@anchor{gnat_rm/implementation_defined_attributes attribute-epsilon}@anchor{17e} @section Attribute Epsilon @@ -10756,7 +10536,7 @@ the Ada 83 reference manual for an exact description of the semantics of this attribute. @node Attribute Fast_Math,Attribute Finalization_Size,Attribute Epsilon,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-fast-math}@anchor{17b} +@anchor{gnat_rm/implementation_defined_attributes attribute-fast-math}@anchor{17f} @section Attribute Fast_Math @@ -10767,7 +10547,7 @@ prefix) yields a static Boolean value that is True if pragma @code{Fast_Math} is active, and False otherwise. @node Attribute Finalization_Size,Attribute Fixed_Value,Attribute Fast_Math,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-finalization-size}@anchor{17c} +@anchor{gnat_rm/implementation_defined_attributes attribute-finalization-size}@anchor{180} @section Attribute Finalization_Size @@ -10785,7 +10565,7 @@ class-wide type whose tag denotes a type with no controlled parts. Note that only heap-allocated objects contain finalization data. @node Attribute Fixed_Value,Attribute From_Any,Attribute Finalization_Size,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-fixed-value}@anchor{17d} +@anchor{gnat_rm/implementation_defined_attributes attribute-fixed-value}@anchor{181} @section Attribute Fixed_Value @@ -10812,7 +10592,7 @@ This attribute is primarily intended for use in implementation of the input-output functions for fixed-point values. @node Attribute From_Any,Attribute Has_Access_Values,Attribute Fixed_Value,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-from-any}@anchor{17e} +@anchor{gnat_rm/implementation_defined_attributes attribute-from-any}@anchor{182} @section Attribute From_Any @@ -10822,7 +10602,7 @@ This internal attribute is used for the generation of remote subprogram stubs in the context of the Distributed Systems Annex. @node Attribute Has_Access_Values,Attribute Has_Discriminants,Attribute From_Any,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-has-access-values}@anchor{17f} +@anchor{gnat_rm/implementation_defined_attributes attribute-has-access-values}@anchor{183} @section Attribute Has_Access_Values @@ -10840,7 +10620,7 @@ definitions. If the attribute is applied to a generic private type, it indicates whether or not the corresponding actual type has access values. @node Attribute Has_Discriminants,Attribute Has_Tagged_Values,Attribute Has_Access_Values,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-has-discriminants}@anchor{180} +@anchor{gnat_rm/implementation_defined_attributes attribute-has-discriminants}@anchor{184} @section Attribute Has_Discriminants @@ -10856,7 +10636,7 @@ definitions. If the attribute is applied to a generic private type, it indicates whether or not the corresponding actual type has discriminants. @node Attribute Has_Tagged_Values,Attribute Img,Attribute Has_Discriminants,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-has-tagged-values}@anchor{181} +@anchor{gnat_rm/implementation_defined_attributes attribute-has-tagged-values}@anchor{185} @section Attribute Has_Tagged_Values @@ -10873,7 +10653,7 @@ definitions. If the attribute is applied to a generic private type, it indicates whether or not the corresponding actual type has access values. @node Attribute Img,Attribute Initialized,Attribute Has_Tagged_Values,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-img}@anchor{182} +@anchor{gnat_rm/implementation_defined_attributes attribute-img}@anchor{186} @section Attribute Img @@ -10903,7 +10683,7 @@ that returns the appropriate string when called. This means that in an instantiation as a function parameter. @node Attribute Initialized,Attribute Integer_Value,Attribute Img,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-initialized}@anchor{183} +@anchor{gnat_rm/implementation_defined_attributes attribute-initialized}@anchor{187} @section Attribute Initialized @@ -10913,7 +10693,7 @@ For the syntax and semantics of this attribute, see the SPARK 2014 Reference Manual, section 6.10. @node Attribute Integer_Value,Attribute Invalid_Value,Attribute Initialized,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-integer-value}@anchor{184} +@anchor{gnat_rm/implementation_defined_attributes attribute-integer-value}@anchor{188} @section Attribute Integer_Value @@ -10941,7 +10721,7 @@ This attribute is primarily intended for use in implementation of the standard input-output functions for fixed-point values. @node Attribute Invalid_Value,Attribute Iterable,Attribute Integer_Value,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-invalid-value}@anchor{185} +@anchor{gnat_rm/implementation_defined_attributes attribute-invalid-value}@anchor{189} @section Attribute Invalid_Value @@ -10955,7 +10735,7 @@ including the ability to modify the value with the binder -Sxx flag and relevant environment variables at run time. @node Attribute Iterable,Attribute Large,Attribute Invalid_Value,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-iterable}@anchor{186} +@anchor{gnat_rm/implementation_defined_attributes attribute-iterable}@anchor{18a} @section Attribute Iterable @@ -10964,7 +10744,7 @@ relevant environment variables at run time. Equivalent to Aspect Iterable. @node Attribute Large,Attribute Library_Level,Attribute Iterable,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-large}@anchor{187} +@anchor{gnat_rm/implementation_defined_attributes attribute-large}@anchor{18b} @section Attribute Large @@ -10977,7 +10757,7 @@ the Ada 83 reference manual for an exact description of the semantics of this attribute. @node Attribute Library_Level,Attribute Loop_Entry,Attribute Large,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-library-level}@anchor{188} +@anchor{gnat_rm/implementation_defined_attributes attribute-library-level}@anchor{18c} @section Attribute Library_Level @@ -11003,7 +10783,7 @@ end Gen; @end example @node Attribute Loop_Entry,Attribute Machine_Size,Attribute Library_Level,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-loop-entry}@anchor{189} +@anchor{gnat_rm/implementation_defined_attributes attribute-loop-entry}@anchor{18d} @section Attribute Loop_Entry @@ -11036,7 +10816,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{18a} +@anchor{gnat_rm/implementation_defined_attributes attribute-machine-size}@anchor{18e} @section Attribute Machine_Size @@ -11046,7 +10826,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{18b} +@anchor{gnat_rm/implementation_defined_attributes attribute-mantissa}@anchor{18f} @section Attribute Mantissa @@ -11059,7 +10839,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{18c}@anchor{gnat_rm/implementation_defined_attributes id2}@anchor{18d} +@anchor{gnat_rm/implementation_defined_attributes attribute-maximum-alignment}@anchor{190}@anchor{gnat_rm/implementation_defined_attributes id2}@anchor{191} @section Attribute Maximum_Alignment @@ -11075,7 +10855,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{18e} +@anchor{gnat_rm/implementation_defined_attributes attribute-max-integer-size}@anchor{192} @section Attribute Max_Integer_Size @@ -11086,7 +10866,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{18f} +@anchor{gnat_rm/implementation_defined_attributes attribute-mechanism-code}@anchor{193} @section Attribute Mechanism_Code @@ -11117,7 +10897,7 @@ by reference @end table @node Attribute Null_Parameter,Attribute Object_Size,Attribute Mechanism_Code,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-null-parameter}@anchor{190} +@anchor{gnat_rm/implementation_defined_attributes attribute-null-parameter}@anchor{194} @section Attribute Null_Parameter @@ -11142,7 +10922,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{191} +@anchor{gnat_rm/implementation_defined_attributes attribute-object-size}@anchor{145}@anchor{gnat_rm/implementation_defined_attributes id3}@anchor{195} @section Attribute Object_Size @@ -11212,7 +10992,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{192} +@anchor{gnat_rm/implementation_defined_attributes attribute-old}@anchor{196} @section Attribute Old @@ -11227,7 +11007,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{193} +@anchor{gnat_rm/implementation_defined_attributes attribute-passed-by-reference}@anchor{197} @section Attribute Passed_By_Reference @@ -11243,7 +11023,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{194} +@anchor{gnat_rm/implementation_defined_attributes attribute-pool-address}@anchor{198} @section Attribute Pool_Address @@ -11265,7 +11045,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{195} +@anchor{gnat_rm/implementation_defined_attributes attribute-range-length}@anchor{199} @section Attribute Range_Length @@ -11278,7 +11058,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{196} +@anchor{gnat_rm/implementation_defined_attributes attribute-restriction-set}@anchor{19a} @section Attribute Restriction_Set @@ -11348,7 +11128,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{197} +@anchor{gnat_rm/implementation_defined_attributes attribute-result}@anchor{19b} @section Attribute Result @@ -11361,7 +11141,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{198} +@anchor{gnat_rm/implementation_defined_attributes attribute-safe-emax}@anchor{19c} @section Attribute Safe_Emax @@ -11374,7 +11154,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{199} +@anchor{gnat_rm/implementation_defined_attributes attribute-safe-large}@anchor{19d} @section Attribute Safe_Large @@ -11387,7 +11167,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{19a} +@anchor{gnat_rm/implementation_defined_attributes attribute-safe-small}@anchor{19e} @section Attribute Safe_Small @@ -11400,7 +11180,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{19b} +@anchor{gnat_rm/implementation_defined_attributes attribute-scalar-storage-order}@anchor{153}@anchor{gnat_rm/implementation_defined_attributes id4}@anchor{19f} @section Attribute Scalar_Storage_Order @@ -11563,7 +11343,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{19c} +@anchor{gnat_rm/implementation_defined_attributes attribute-simple-storage-pool}@anchor{e7}@anchor{gnat_rm/implementation_defined_attributes id5}@anchor{1a0} @section Attribute Simple_Storage_Pool @@ -11626,7 +11406,7 @@ as defined in section 13.11.2 of the Ada Reference Manual, except that the term `simple storage pool' is substituted for `storage pool'. @node Attribute Small,Attribute Small_Denominator,Attribute Simple_Storage_Pool,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-small}@anchor{19d} +@anchor{gnat_rm/implementation_defined_attributes attribute-small}@anchor{1a1} @section Attribute Small @@ -11642,7 +11422,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{19e} +@anchor{gnat_rm/implementation_defined_attributes attribute-small-denominator}@anchor{1a2} @section Attribute Small_Denominator @@ -11655,7 +11435,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{19f} +@anchor{gnat_rm/implementation_defined_attributes attribute-small-numerator}@anchor{1a3} @section Attribute Small_Numerator @@ -11668,7 +11448,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{1a0} +@anchor{gnat_rm/implementation_defined_attributes attribute-storage-unit}@anchor{1a4} @section Attribute Storage_Unit @@ -11678,7 +11458,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{1a1} +@anchor{gnat_rm/implementation_defined_attributes attribute-stub-type}@anchor{1a5} @section Attribute Stub_Type @@ -11702,7 +11482,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{1a2} +@anchor{gnat_rm/implementation_defined_attributes attribute-system-allocator-alignment}@anchor{1a6} @section Attribute System_Allocator_Alignment @@ -11719,7 +11499,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{1a3} +@anchor{gnat_rm/implementation_defined_attributes attribute-target-name}@anchor{1a7} @section Attribute Target_Name @@ -11732,7 +11512,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{1a4} +@anchor{gnat_rm/implementation_defined_attributes attribute-to-address}@anchor{1a8} @section Attribute To_Address @@ -11755,7 +11535,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{1a5} +@anchor{gnat_rm/implementation_defined_attributes attribute-to-any}@anchor{1a9} @section Attribute To_Any @@ -11765,7 +11545,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{1a6} +@anchor{gnat_rm/implementation_defined_attributes attribute-type-class}@anchor{1aa} @section Attribute Type_Class @@ -11795,7 +11575,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{1a7} +@anchor{gnat_rm/implementation_defined_attributes attribute-type-key}@anchor{1ab} @section Attribute Type_Key @@ -11807,7 +11587,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{1a8} +@anchor{gnat_rm/implementation_defined_attributes attribute-typecode}@anchor{1ac} @section Attribute TypeCode @@ -11817,7 +11597,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{1a9} +@anchor{gnat_rm/implementation_defined_attributes attribute-unconstrained-array}@anchor{1ad} @section Attribute Unconstrained_Array @@ -11831,7 +11611,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{1aa} +@anchor{gnat_rm/implementation_defined_attributes attribute-universal-literal-string}@anchor{1ae} @section Attribute Universal_Literal_String @@ -11859,7 +11639,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{1ab} +@anchor{gnat_rm/implementation_defined_attributes attribute-unrestricted-access}@anchor{1af} @section Attribute Unrestricted_Access @@ -12046,7 +11826,7 @@ In general this is a risky approach. It may appear to “work” but such uses o of GNAT to another, so are best avoided if possible. @node Attribute Update,Attribute Valid_Value,Attribute Unrestricted_Access,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-update}@anchor{1ac} +@anchor{gnat_rm/implementation_defined_attributes attribute-update}@anchor{1b0} @section Attribute Update @@ -12127,7 +11907,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_Value,Attribute Valid_Scalars,Attribute Update,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-valid-value}@anchor{1ad} +@anchor{gnat_rm/implementation_defined_attributes attribute-valid-value}@anchor{1b1} @section Attribute Valid_Value @@ -12139,7 +11919,7 @@ a String, and returns Boolean. @code{T'Valid_Value (S)} returns True if and only if @code{T'Value (S)} would not raise Constraint_Error. @node Attribute Valid_Scalars,Attribute VADS_Size,Attribute Valid_Value,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-valid-scalars}@anchor{1ae} +@anchor{gnat_rm/implementation_defined_attributes attribute-valid-scalars}@anchor{1b2} @section Attribute Valid_Scalars @@ -12173,7 +11953,7 @@ write a function with a single use of the attribute, and then call that function from multiple places. @node Attribute VADS_Size,Attribute Value_Size,Attribute Valid_Scalars,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-vads-size}@anchor{1af} +@anchor{gnat_rm/implementation_defined_attributes attribute-vads-size}@anchor{1b3} @section Attribute VADS_Size @@ -12193,7 +11973,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{1b0} +@anchor{gnat_rm/implementation_defined_attributes attribute-value-size}@anchor{161}@anchor{gnat_rm/implementation_defined_attributes id6}@anchor{1b4} @section Attribute Value_Size @@ -12207,7 +11987,7 @@ a value of the given subtype. It is the same as @code{type'Size}, but, unlike @code{Size}, may be set for non-first subtypes. @node Attribute Wchar_T_Size,Attribute Word_Size,Attribute Value_Size,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-wchar-t-size}@anchor{1b1} +@anchor{gnat_rm/implementation_defined_attributes attribute-wchar-t-size}@anchor{1b5} @section Attribute Wchar_T_Size @@ -12219,7 +11999,7 @@ primarily for constructing the definition of this type in package @code{Interfaces.C}. The result is a static constant. @node Attribute Word_Size,,Attribute Wchar_T_Size,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-word-size}@anchor{1b2} +@anchor{gnat_rm/implementation_defined_attributes attribute-word-size}@anchor{1b6} @section Attribute Word_Size @@ -12230,7 +12010,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{1b3}@anchor{gnat_rm/standard_and_implementation_defined_restrictions id1}@anchor{1b4}@anchor{gnat_rm/standard_and_implementation_defined_restrictions standard-and-implementation-defined-restrictions}@anchor{9} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions doc}@anchor{1b7}@anchor{gnat_rm/standard_and_implementation_defined_restrictions id1}@anchor{1b8}@anchor{gnat_rm/standard_and_implementation_defined_restrictions standard-and-implementation-defined-restrictions}@anchor{9} @chapter Standard and Implementation Defined Restrictions @@ -12259,7 +12039,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{1b5}@anchor{gnat_rm/standard_and_implementation_defined_restrictions partition-wide-restrictions}@anchor{1b6} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions id2}@anchor{1b9}@anchor{gnat_rm/standard_and_implementation_defined_restrictions partition-wide-restrictions}@anchor{1ba} @section Partition-Wide Restrictions @@ -12350,7 +12130,7 @@ then all compilation units in the partition must obey the restriction). @end menu @node Immediate_Reclamation,Max_Asynchronous_Select_Nesting,,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions immediate-reclamation}@anchor{1b7} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions immediate-reclamation}@anchor{1bb} @subsection Immediate_Reclamation @@ -12362,7 +12142,7 @@ deallocation, any storage reserved at run time for an object is immediately reclaimed when the object no longer exists. @node Max_Asynchronous_Select_Nesting,Max_Entry_Queue_Length,Immediate_Reclamation,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-asynchronous-select-nesting}@anchor{1b8} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-asynchronous-select-nesting}@anchor{1bc} @subsection Max_Asynchronous_Select_Nesting @@ -12374,7 +12154,7 @@ detected at compile time. Violations of this restriction with values other than zero cause Storage_Error to be raised. @node Max_Entry_Queue_Length,Max_Protected_Entries,Max_Asynchronous_Select_Nesting,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-entry-queue-length}@anchor{1b9} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-entry-queue-length}@anchor{1bd} @subsection Max_Entry_Queue_Length @@ -12395,7 +12175,7 @@ compatibility purposes (and a warning will be generated for its use if warnings on obsolescent features are activated). @node Max_Protected_Entries,Max_Select_Alternatives,Max_Entry_Queue_Length,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-protected-entries}@anchor{1ba} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-protected-entries}@anchor{1be} @subsection Max_Protected_Entries @@ -12406,7 +12186,7 @@ bounds of every entry family of a protected unit shall be static, or shall be defined by a discriminant of a subtype whose corresponding bound is static. @node Max_Select_Alternatives,Max_Storage_At_Blocking,Max_Protected_Entries,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-select-alternatives}@anchor{1bb} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-select-alternatives}@anchor{1bf} @subsection Max_Select_Alternatives @@ -12415,7 +12195,7 @@ defined by a discriminant of a subtype whose corresponding bound is static. [RM D.7] Specifies the maximum number of alternatives in a selective accept. @node Max_Storage_At_Blocking,Max_Task_Entries,Max_Select_Alternatives,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-storage-at-blocking}@anchor{1bc} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-storage-at-blocking}@anchor{1c0} @subsection Max_Storage_At_Blocking @@ -12426,7 +12206,7 @@ Storage_Size that can be retained by a blocked task. A violation of this restriction causes Storage_Error to be raised. @node Max_Task_Entries,Max_Tasks,Max_Storage_At_Blocking,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-task-entries}@anchor{1bd} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-task-entries}@anchor{1c1} @subsection Max_Task_Entries @@ -12439,7 +12219,7 @@ defined by a discriminant of a subtype whose corresponding bound is static. @node Max_Tasks,No_Abort_Statements,Max_Task_Entries,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-tasks}@anchor{1be} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-tasks}@anchor{1c2} @subsection Max_Tasks @@ -12452,7 +12232,7 @@ time. Violations of this restriction with values other than zero cause Storage_Error to be raised. @node No_Abort_Statements,No_Access_Parameter_Allocators,Max_Tasks,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-abort-statements}@anchor{1bf} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-abort-statements}@anchor{1c3} @subsection No_Abort_Statements @@ -12462,7 +12242,7 @@ Storage_Error to be raised. no calls to Task_Identification.Abort_Task. @node No_Access_Parameter_Allocators,No_Access_Subprograms,No_Abort_Statements,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-access-parameter-allocators}@anchor{1c0} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-access-parameter-allocators}@anchor{1c4} @subsection No_Access_Parameter_Allocators @@ -12473,7 +12253,7 @@ occurrences of an allocator as the actual parameter to an access parameter. @node No_Access_Subprograms,No_Allocators,No_Access_Parameter_Allocators,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-access-subprograms}@anchor{1c1} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-access-subprograms}@anchor{1c5} @subsection No_Access_Subprograms @@ -12483,7 +12263,7 @@ parameter. declarations of access-to-subprogram types. @node No_Allocators,No_Anonymous_Allocators,No_Access_Subprograms,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-allocators}@anchor{1c2} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-allocators}@anchor{1c6} @subsection No_Allocators @@ -12493,7 +12273,7 @@ declarations of access-to-subprogram types. occurrences of an allocator. @node No_Anonymous_Allocators,No_Asynchronous_Control,No_Allocators,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-anonymous-allocators}@anchor{1c3} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-anonymous-allocators}@anchor{1c7} @subsection No_Anonymous_Allocators @@ -12503,7 +12283,7 @@ occurrences of an allocator. occurrences of an allocator of anonymous access type. @node No_Asynchronous_Control,No_Calendar,No_Anonymous_Allocators,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-asynchronous-control}@anchor{1c4} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-asynchronous-control}@anchor{1c8} @subsection No_Asynchronous_Control @@ -12513,7 +12293,7 @@ occurrences of an allocator of anonymous access type. dependences on the predefined package Asynchronous_Task_Control. @node No_Calendar,No_Coextensions,No_Asynchronous_Control,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-calendar}@anchor{1c5} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-calendar}@anchor{1c9} @subsection No_Calendar @@ -12523,7 +12303,7 @@ dependences on the predefined package Asynchronous_Task_Control. dependences on package Calendar. @node No_Coextensions,No_Default_Initialization,No_Calendar,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-coextensions}@anchor{1c6} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-coextensions}@anchor{1ca} @subsection No_Coextensions @@ -12533,7 +12313,7 @@ dependences on package Calendar. coextensions. See 3.10.2. @node No_Default_Initialization,No_Delay,No_Coextensions,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-default-initialization}@anchor{1c7} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-default-initialization}@anchor{1cb} @subsection No_Default_Initialization @@ -12550,7 +12330,7 @@ is to prohibit all cases of variables declared without a specific initializer (including the case of OUT scalar parameters). @node No_Delay,No_Dependence,No_Default_Initialization,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-delay}@anchor{1c8} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-delay}@anchor{1cc} @subsection No_Delay @@ -12560,7 +12340,7 @@ initializer (including the case of OUT scalar parameters). delay statements and no semantic dependences on package Calendar. @node No_Dependence,No_Direct_Boolean_Operators,No_Delay,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dependence}@anchor{1c9} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dependence}@anchor{1cd} @subsection No_Dependence @@ -12569,10 +12349,41 @@ delay statements and no semantic dependences on package Calendar. [RM 13.12.1] This restriction ensures at compile time that there are no 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. +to support specific constructs of the language. Here are some examples: + + +@itemize * + +@item +@code{System.Arith_64}: 64-bit arithmetics for 32-bit platforms, + +@item +@code{System.Arith_128}: 128-bit arithmetics for 64-bit platforms, + +@item +@code{System.Memory}: heap memory allocation routines, + +@item +@code{System.Memory_Compare}: memory comparison routine (aka @code{memcmp} for C), + +@item +@code{System.Memory_Copy}: memory copy routine (aka @code{memcpy} for C), + +@item +@code{System.Memory_Move}: memoy move routine (aka @code{memmove} for C), + +@item +@code{System.Memory_Set}: memory set routine (aka @code{memset} for C), + +@item +@code{System.Stack_Checking[.Operations]}: stack checking without MMU, + +@item +@code{System.GCC}: support routines from the GCC library. +@end itemize @node No_Direct_Boolean_Operators,No_Dispatch,No_Dependence,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-direct-boolean-operators}@anchor{1ca} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-direct-boolean-operators}@anchor{1ce} @subsection No_Direct_Boolean_Operators @@ -12585,7 +12396,7 @@ protocol requires the use of short-circuit (and then, or else) forms for all composite boolean operations. @node No_Dispatch,No_Dispatching_Calls,No_Direct_Boolean_Operators,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dispatch}@anchor{1cb} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dispatch}@anchor{1cf} @subsection No_Dispatch @@ -12595,7 +12406,7 @@ composite boolean operations. occurrences of @code{T'Class}, for any (tagged) subtype @code{T}. @node No_Dispatching_Calls,No_Dynamic_Attachment,No_Dispatch,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dispatching-calls}@anchor{1cc} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dispatching-calls}@anchor{1d0} @subsection No_Dispatching_Calls @@ -12656,7 +12467,7 @@ end Example; @end example @node No_Dynamic_Attachment,No_Dynamic_Priorities,No_Dispatching_Calls,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dynamic-attachment}@anchor{1cd} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dynamic-attachment}@anchor{1d1} @subsection No_Dynamic_Attachment @@ -12675,7 +12486,7 @@ compatibility purposes (and a warning will be generated for its use if warnings on obsolescent features are activated). @node No_Dynamic_Priorities,No_Entry_Calls_In_Elaboration_Code,No_Dynamic_Attachment,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dynamic-priorities}@anchor{1ce} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dynamic-priorities}@anchor{1d2} @subsection No_Dynamic_Priorities @@ -12684,7 +12495,7 @@ warnings on obsolescent features are activated). [RM D.7] There are no semantic dependencies on the package Dynamic_Priorities. @node No_Entry_Calls_In_Elaboration_Code,No_Enumeration_Maps,No_Dynamic_Priorities,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-entry-calls-in-elaboration-code}@anchor{1cf} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-entry-calls-in-elaboration-code}@anchor{1d3} @subsection No_Entry_Calls_In_Elaboration_Code @@ -12696,7 +12507,7 @@ restriction, the compiler can assume that no code past an accept statement in a task can be executed at elaboration time. @node No_Enumeration_Maps,No_Exception_Handlers,No_Entry_Calls_In_Elaboration_Code,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-enumeration-maps}@anchor{1d0} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-enumeration-maps}@anchor{1d4} @subsection No_Enumeration_Maps @@ -12707,7 +12518,7 @@ enumeration maps are used (that is Image and Value attributes applied to enumeration types). @node No_Exception_Handlers,No_Exception_Propagation,No_Enumeration_Maps,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-exception-handlers}@anchor{1d1} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-exception-handlers}@anchor{1d5} @subsection No_Exception_Handlers @@ -12732,7 +12543,7 @@ statement generated by the compiler). The Line parameter when nonzero represents the line number in the source program where the raise occurs. @node No_Exception_Propagation,No_Exception_Registration,No_Exception_Handlers,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-exception-propagation}@anchor{1d2} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-exception-propagation}@anchor{1d6} @subsection No_Exception_Propagation @@ -12749,7 +12560,7 @@ the package GNAT.Current_Exception is not permitted, and reraise statements (raise with no operand) are not permitted. @node No_Exception_Registration,No_Exceptions,No_Exception_Propagation,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-exception-registration}@anchor{1d3} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-exception-registration}@anchor{1d7} @subsection No_Exception_Registration @@ -12763,7 +12574,7 @@ code is simplified by omitting the otherwise-required global registration of exceptions when they are declared. @node No_Exceptions,No_Finalization,No_Exception_Registration,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-exceptions}@anchor{1d4} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-exceptions}@anchor{1d8} @subsection No_Exceptions @@ -12774,7 +12585,7 @@ raise statements and no exception handlers and also suppresses the generation of language-defined run-time checks. @node No_Finalization,No_Fixed_Point,No_Exceptions,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-finalization}@anchor{1d5} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-finalization}@anchor{1d9} @subsection No_Finalization @@ -12815,7 +12626,7 @@ object or a nested component, either declared on the stack or on the heap. The deallocation of a controlled object no longer finalizes its contents. @node No_Fixed_Point,No_Floating_Point,No_Finalization,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-fixed-point}@anchor{1d6} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-fixed-point}@anchor{1da} @subsection No_Fixed_Point @@ -12825,7 +12636,7 @@ deallocation of a controlled object no longer finalizes its contents. occurrences of fixed point types and operations. @node No_Floating_Point,No_Implicit_Conditionals,No_Fixed_Point,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-floating-point}@anchor{1d7} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-floating-point}@anchor{1db} @subsection No_Floating_Point @@ -12835,7 +12646,7 @@ occurrences of fixed point types and operations. occurrences of floating point types and operations. @node No_Implicit_Conditionals,No_Implicit_Dynamic_Code,No_Floating_Point,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-conditionals}@anchor{1d8} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-conditionals}@anchor{1dc} @subsection No_Implicit_Conditionals @@ -12851,7 +12662,7 @@ normal manner. Constructs generating implicit conditionals include comparisons of composite objects and the Max/Min attributes. @node No_Implicit_Dynamic_Code,No_Implicit_Heap_Allocations,No_Implicit_Conditionals,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-dynamic-code}@anchor{1d9} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-dynamic-code}@anchor{1dd} @subsection No_Implicit_Dynamic_Code @@ -12881,7 +12692,7 @@ foreign-language convention; primitive operations of nested tagged types. @node No_Implicit_Heap_Allocations,No_Implicit_Protected_Object_Allocations,No_Implicit_Dynamic_Code,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-heap-allocations}@anchor{1da} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-heap-allocations}@anchor{1de} @subsection No_Implicit_Heap_Allocations @@ -12890,7 +12701,7 @@ types. [RM D.7] No constructs are allowed to cause implicit heap allocation. @node No_Implicit_Protected_Object_Allocations,No_Implicit_Task_Allocations,No_Implicit_Heap_Allocations,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-protected-object-allocations}@anchor{1db} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-protected-object-allocations}@anchor{1df} @subsection No_Implicit_Protected_Object_Allocations @@ -12900,7 +12711,7 @@ types. protected object. @node No_Implicit_Task_Allocations,No_Initialize_Scalars,No_Implicit_Protected_Object_Allocations,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-task-allocations}@anchor{1dc} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-task-allocations}@anchor{1e0} @subsection No_Implicit_Task_Allocations @@ -12909,7 +12720,7 @@ protected object. [GNAT] No constructs are allowed to cause implicit heap allocation of a task. @node No_Initialize_Scalars,No_IO,No_Implicit_Task_Allocations,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-initialize-scalars}@anchor{1dd} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-initialize-scalars}@anchor{1e1} @subsection No_Initialize_Scalars @@ -12921,7 +12732,7 @@ code, and in particular eliminates dummy null initialization routines that are otherwise generated for some record and array types. @node No_IO,No_Local_Allocators,No_Initialize_Scalars,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-io}@anchor{1de} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-io}@anchor{1e2} @subsection No_IO @@ -12932,7 +12743,7 @@ dependences on any of the library units Sequential_IO, Direct_IO, Text_IO, Wide_Text_IO, Wide_Wide_Text_IO, or Stream_IO. @node No_Local_Allocators,No_Local_Protected_Objects,No_IO,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-local-allocators}@anchor{1df} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-local-allocators}@anchor{1e3} @subsection No_Local_Allocators @@ -12943,7 +12754,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{1e0} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-local-protected-objects}@anchor{1e4} @subsection No_Local_Protected_Objects @@ -12953,7 +12764,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{1e1} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-local-tagged-types}@anchor{1e5} @subsection No_Local_Tagged_Types @@ -12963,7 +12774,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{1e2} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-local-timing-events}@anchor{1e6} @subsection No_Local_Timing_Events @@ -12973,7 +12784,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{1e3} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-long-long-integers}@anchor{1e7} @subsection No_Long_Long_Integers @@ -12985,7 +12796,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{1e4} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-multiple-elaboration}@anchor{1e8} @subsection No_Multiple_Elaboration @@ -13001,7 +12812,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{1e5} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-nested-finalization}@anchor{1e9} @subsection No_Nested_Finalization @@ -13010,7 +12821,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{1e6} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-protected-type-allocators}@anchor{1ea} @subsection No_Protected_Type_Allocators @@ -13020,7 +12831,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{1e7} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-protected-types}@anchor{1eb} @subsection No_Protected_Types @@ -13030,7 +12841,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{1e8} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-recursion}@anchor{1ec} @subsection No_Recursion @@ -13040,7 +12851,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{1e9} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-reentrancy}@anchor{1ed} @subsection No_Reentrancy @@ -13050,7 +12861,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{1ea} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-relative-delay}@anchor{1ee} @subsection No_Relative_Delay @@ -13061,7 +12872,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{1eb} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-requeue-statements}@anchor{1ef} @subsection No_Requeue_Statements @@ -13079,7 +12890,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{1ec} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-secondary-stack}@anchor{1f0} @subsection No_Secondary_Stack @@ -13092,7 +12903,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{1ed} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-select-statements}@anchor{1f1} @subsection No_Select_Statements @@ -13102,7 +12913,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{1ee} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-specific-termination-handlers}@anchor{1f2} @subsection No_Specific_Termination_Handlers @@ -13112,7 +12923,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{1ef} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-specification-of-aspect}@anchor{1f3} @subsection No_Specification_of_Aspect @@ -13123,7 +12934,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{1f0} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-standard-allocators-after-elaboration}@anchor{1f4} @subsection No_Standard_Allocators_After_Elaboration @@ -13135,7 +12946,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{1f1} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-standard-storage-pools}@anchor{1f5} @subsection No_Standard_Storage_Pools @@ -13147,7 +12958,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{1f2} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-stream-optimizations}@anchor{1f6} @subsection No_Stream_Optimizations @@ -13160,7 +12971,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{1f3} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-streams}@anchor{1f7} @subsection No_Streams @@ -13181,7 +12992,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{1f4} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-tagged-type-registration}@anchor{1f8} @subsection No_Tagged_Type_Registration @@ -13196,7 +13007,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{1f5} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-task-allocators}@anchor{1f9} @subsection No_Task_Allocators @@ -13206,7 +13017,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{1f6} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-task-at-interrupt-priority}@anchor{1fa} @subsection No_Task_At_Interrupt_Priority @@ -13218,7 +13029,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{1f7} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-task-attributes-package}@anchor{1fb} @subsection No_Task_Attributes_Package @@ -13235,7 +13046,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{1f8} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-task-hierarchy}@anchor{1fc} @subsection No_Task_Hierarchy @@ -13245,7 +13056,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{1f9} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-task-termination}@anchor{1fd} @subsection No_Task_Termination @@ -13254,7 +13065,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{1fa} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-tasking}@anchor{1fe} @subsection No_Tasking @@ -13267,7 +13078,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{1fb} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-terminate-alternatives}@anchor{1ff} @subsection No_Terminate_Alternatives @@ -13276,7 +13087,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{1fc} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-unchecked-access}@anchor{200} @subsection No_Unchecked_Access @@ -13286,7 +13097,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{1fd} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-unchecked-conversion}@anchor{201} @subsection No_Unchecked_Conversion @@ -13296,7 +13107,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{1fe} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-unchecked-deallocation}@anchor{202} @subsection No_Unchecked_Deallocation @@ -13306,7 +13117,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{1ff} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-use-of-entity}@anchor{203} @subsection No_Use_Of_Entity @@ -13326,7 +13137,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{200} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions pure-barriers}@anchor{204} @subsection Pure_Barriers @@ -13377,7 +13188,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{201} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions simple-barriers}@anchor{205} @subsection Simple_Barriers @@ -13396,7 +13207,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{202} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions static-priorities}@anchor{206} @subsection Static_Priorities @@ -13407,7 +13218,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{203} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions static-storage-size}@anchor{207} @subsection Static_Storage_Size @@ -13417,7 +13228,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{204}@anchor{gnat_rm/standard_and_implementation_defined_restrictions program-unit-level-restrictions}@anchor{205} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions id3}@anchor{208}@anchor{gnat_rm/standard_and_implementation_defined_restrictions program-unit-level-restrictions}@anchor{209} @section Program Unit Level Restrictions @@ -13448,7 +13259,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{206} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-elaboration-code}@anchor{20a} @subsection No_Elaboration_Code @@ -13504,7 +13315,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{207} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dynamic-accessibility-checks}@anchor{20b} @subsection No_Dynamic_Accessibility_Checks @@ -13553,7 +13364,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{208} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dynamic-sized-objects}@anchor{20c} @subsection No_Dynamic_Sized_Objects @@ -13571,7 +13382,7 @@ access discriminants. It is often a good idea to combine this restriction with No_Secondary_Stack. @node No_Entry_Queue,No_Implementation_Aspect_Specifications,No_Dynamic_Sized_Objects,Program Unit Level Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-entry-queue}@anchor{209} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-entry-queue}@anchor{20d} @subsection No_Entry_Queue @@ -13584,7 +13395,7 @@ checked at compile time. A program execution is erroneous if an attempt is made to queue a second task on such an entry. @node No_Implementation_Aspect_Specifications,No_Implementation_Attributes,No_Entry_Queue,Program Unit Level Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-aspect-specifications}@anchor{20a} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-aspect-specifications}@anchor{20e} @subsection No_Implementation_Aspect_Specifications @@ -13595,7 +13406,7 @@ GNAT-defined aspects are present. With this restriction, the only aspects that can be used are those defined in the Ada Reference Manual. @node No_Implementation_Attributes,No_Implementation_Identifiers,No_Implementation_Aspect_Specifications,Program Unit Level Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-attributes}@anchor{20b} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-attributes}@anchor{20f} @subsection No_Implementation_Attributes @@ -13607,7 +13418,7 @@ attributes that can be used are those defined in the Ada Reference Manual. @node No_Implementation_Identifiers,No_Implementation_Pragmas,No_Implementation_Attributes,Program Unit Level Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-identifiers}@anchor{20c} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-identifiers}@anchor{210} @subsection No_Implementation_Identifiers @@ -13618,7 +13429,7 @@ implementation-defined identifiers (marked with pragma Implementation_Defined) occur within language-defined packages. @node No_Implementation_Pragmas,No_Implementation_Restrictions,No_Implementation_Identifiers,Program Unit Level Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-pragmas}@anchor{20d} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-pragmas}@anchor{211} @subsection No_Implementation_Pragmas @@ -13629,7 +13440,7 @@ GNAT-defined pragmas are present. With this restriction, the only pragmas that can be used are those defined in the Ada Reference Manual. @node No_Implementation_Restrictions,No_Implementation_Units,No_Implementation_Pragmas,Program Unit Level Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-restrictions}@anchor{20e} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-restrictions}@anchor{212} @subsection No_Implementation_Restrictions @@ -13641,7 +13452,7 @@ are present. With this restriction, the only other restriction identifiers that can be used are those defined in the Ada Reference Manual. @node No_Implementation_Units,No_Implicit_Aliasing,No_Implementation_Restrictions,Program Unit Level Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-units}@anchor{20f} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-units}@anchor{213} @subsection No_Implementation_Units @@ -13652,7 +13463,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{210} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-aliasing}@anchor{214} @subsection No_Implicit_Aliasing @@ -13667,7 +13478,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{211} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-loops}@anchor{215} @subsection No_Implicit_Loops @@ -13684,7 +13495,7 @@ arrays larger than about 5000 scalar components. Note that if this restriction is set in the spec of a package, it will not apply to its body. @node No_Obsolescent_Features,No_Wide_Characters,No_Implicit_Loops,Program Unit Level Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-obsolescent-features}@anchor{212} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-obsolescent-features}@anchor{216} @subsection No_Obsolescent_Features @@ -13694,7 +13505,7 @@ is set in the spec of a package, it will not apply to its body. features are used, as defined in Annex J of the Ada Reference Manual. @node No_Wide_Characters,Static_Dispatch_Tables,No_Obsolescent_Features,Program Unit Level Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-wide-characters}@anchor{213} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-wide-characters}@anchor{217} @subsection No_Wide_Characters @@ -13708,7 +13519,7 @@ appear in the program (that is literals representing characters not in type @code{Character}). @node Static_Dispatch_Tables,SPARK_05,No_Wide_Characters,Program Unit Level Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions static-dispatch-tables}@anchor{214} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions static-dispatch-tables}@anchor{218} @subsection Static_Dispatch_Tables @@ -13718,7 +13529,7 @@ type @code{Character}). associated with dispatch tables can be placed in read-only memory. @node SPARK_05,,Static_Dispatch_Tables,Program Unit Level Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions spark-05}@anchor{215} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions spark-05}@anchor{219} @subsection SPARK_05 @@ -13741,7 +13552,7 @@ gnatprove -P project.gpr --mode=check_all @end example @node Implementation Advice,Implementation Defined Characteristics,Standard and Implementation Defined Restrictions,Top -@anchor{gnat_rm/implementation_advice doc}@anchor{216}@anchor{gnat_rm/implementation_advice id1}@anchor{217}@anchor{gnat_rm/implementation_advice implementation-advice}@anchor{a} +@anchor{gnat_rm/implementation_advice doc}@anchor{21a}@anchor{gnat_rm/implementation_advice id1}@anchor{21b}@anchor{gnat_rm/implementation_advice implementation-advice}@anchor{a} @chapter Implementation Advice @@ -13839,7 +13650,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{218} +@anchor{gnat_rm/implementation_advice rm-1-1-3-20-error-detection}@anchor{21c} @section RM 1.1.3(20): Error Detection @@ -13856,7 +13667,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{219} +@anchor{gnat_rm/implementation_advice rm-1-1-3-31-child-units}@anchor{21d} @section RM 1.1.3(31): Child Units @@ -13872,7 +13683,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{21a} +@anchor{gnat_rm/implementation_advice rm-1-1-5-12-bounded-errors}@anchor{21e} @section RM 1.1.5(12): Bounded Errors @@ -13889,7 +13700,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{21b}@anchor{gnat_rm/implementation_advice rm-2-8-16-pragmas}@anchor{21c} +@anchor{gnat_rm/implementation_advice id2}@anchor{21f}@anchor{gnat_rm/implementation_advice rm-2-8-16-pragmas}@anchor{220} @section RM 2.8(16): Pragmas @@ -14002,7 +13813,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{21d} +@anchor{gnat_rm/implementation_advice rm-2-8-17-19-pragmas}@anchor{221} @section RM 2.8(17-19): Pragmas @@ -14023,14 +13834,14 @@ replacing @code{library_items}.” @end itemize @end quotation -See @ref{21c,,RM 2.8(16); Pragmas}. +See @ref{220,,RM 2.8(16); Pragmas}. @geindex Character Sets @geindex Alternative Character Sets @node RM 3 5 2 5 Alternative Character Sets,RM 3 5 4 28 Integer Types,RM 2 8 17-19 Pragmas,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-3-5-2-5-alternative-character-sets}@anchor{21e} +@anchor{gnat_rm/implementation_advice rm-3-5-2-5-alternative-character-sets}@anchor{222} @section RM 3.5.2(5): Alternative Character Sets @@ -14058,7 +13869,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{21f} +@anchor{gnat_rm/implementation_advice rm-3-5-4-28-integer-types}@anchor{223} @section RM 3.5.4(28): Integer Types @@ -14077,7 +13888,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{220} +@anchor{gnat_rm/implementation_advice rm-3-5-4-29-integer-types}@anchor{224} @section RM 3.5.4(29): Integer Types @@ -14093,7 +13904,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{221} +@anchor{gnat_rm/implementation_advice rm-3-5-5-8-enumeration-values}@anchor{225} @section RM 3.5.5(8): Enumeration Values @@ -14113,7 +13924,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{222} +@anchor{gnat_rm/implementation_advice rm-3-5-7-17-float-types}@anchor{226} @section RM 3.5.7(17): Float Types @@ -14143,7 +13954,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{223} +@anchor{gnat_rm/implementation_advice rm-3-6-2-11-multidimensional-arrays}@anchor{227} @section RM 3.6.2(11): Multidimensional Arrays @@ -14161,7 +13972,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{224} +@anchor{gnat_rm/implementation_advice rm-9-6-30-31-duration-small}@anchor{228} @section RM 9.6(30-31): Duration’Small @@ -14182,7 +13993,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{225} +@anchor{gnat_rm/implementation_advice rm-10-2-1-12-consistent-representation}@anchor{229} @section RM 10.2.1(12): Consistent Representation @@ -14204,7 +14015,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{226} +@anchor{gnat_rm/implementation_advice rm-11-4-1-19-exception-information}@anchor{22a} @section RM 11.4.1(19): Exception Information @@ -14235,7 +14046,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{227} +@anchor{gnat_rm/implementation_advice rm-11-5-28-suppression-of-checks}@anchor{22b} @section RM 11.5(28): Suppression of Checks @@ -14250,7 +14061,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{228} +@anchor{gnat_rm/implementation_advice rm-13-1-21-24-representation-clauses}@anchor{22c} @section RM 13.1 (21-24): Representation Clauses @@ -14299,7 +14110,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{229} +@anchor{gnat_rm/implementation_advice rm-13-2-6-8-packed-types}@anchor{22d} @section RM 13.2(6-8): Packed Types @@ -14330,7 +14141,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{22a} +@anchor{gnat_rm/implementation_advice rm-13-3-14-19-address-clauses}@anchor{22e} @section RM 13.3(14-19): Address Clauses @@ -14383,7 +14194,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{22b} +@anchor{gnat_rm/implementation_advice rm-13-3-29-35-alignment-clauses}@anchor{22f} @section RM 13.3(29-35): Alignment Clauses @@ -14440,7 +14251,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{22c} +@anchor{gnat_rm/implementation_advice rm-13-3-42-43-size-clauses}@anchor{230} @section RM 13.3(42-43): Size Clauses @@ -14458,7 +14269,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{22d} +@anchor{gnat_rm/implementation_advice rm-13-3-50-56-size-clauses}@anchor{231} @section RM 13.3(50-56): Size Clauses @@ -14509,7 +14320,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{22e} +@anchor{gnat_rm/implementation_advice rm-13-3-71-73-component-size-clauses}@anchor{232} @section RM 13.3(71-73): Component Size Clauses @@ -14543,7 +14354,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{22f} +@anchor{gnat_rm/implementation_advice rm-13-4-9-10-enumeration-representation-clauses}@anchor{233} @section RM 13.4(9-10): Enumeration Representation Clauses @@ -14565,7 +14376,7 @@ Followed. @geindex records @node RM 13 5 1 17-22 Record Representation Clauses,RM 13 5 2 5 Storage Place Attributes,RM 13 4 9-10 Enumeration Representation Clauses,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-13-5-1-17-22-record-representation-clauses}@anchor{230} +@anchor{gnat_rm/implementation_advice rm-13-5-1-17-22-record-representation-clauses}@anchor{234} @section RM 13.5.1(17-22): Record Representation Clauses @@ -14625,7 +14436,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{231} +@anchor{gnat_rm/implementation_advice rm-13-5-2-5-storage-place-attributes}@anchor{235} @section RM 13.5.2(5): Storage Place Attributes @@ -14645,7 +14456,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{232} +@anchor{gnat_rm/implementation_advice rm-13-5-3-7-8-bit-ordering}@anchor{236} @section RM 13.5.3(7-8): Bit Ordering @@ -14665,7 +14476,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{233} +@anchor{gnat_rm/implementation_advice rm-13-7-37-address-as-private}@anchor{237} @section RM 13.7(37): Address as Private @@ -14683,7 +14494,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{234} +@anchor{gnat_rm/implementation_advice rm-13-7-1-16-address-operations}@anchor{238} @section RM 13.7.1(16): Address Operations @@ -14701,7 +14512,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{235} +@anchor{gnat_rm/implementation_advice rm-13-9-14-17-unchecked-conversion}@anchor{239} @section RM 13.9(14-17): Unchecked Conversion @@ -14745,7 +14556,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{236} +@anchor{gnat_rm/implementation_advice rm-13-11-23-25-implicit-heap-usage}@anchor{23a} @section RM 13.11(23-25): Implicit Heap Usage @@ -14796,7 +14607,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{237} +@anchor{gnat_rm/implementation_advice rm-13-11-2-17-unchecked-deallocation}@anchor{23b} @section RM 13.11.2(17): Unchecked Deallocation @@ -14811,7 +14622,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{238} +@anchor{gnat_rm/implementation_advice rm-13-13-2-1-6-stream-oriented-attributes}@anchor{23c} @section RM 13.13.2(1.6): Stream Oriented Attributes @@ -14842,7 +14653,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{239} +@anchor{gnat_rm/implementation_advice rm-a-1-52-names-of-predefined-numeric-types}@anchor{23d} @section RM A.1(52): Names of Predefined Numeric Types @@ -14860,7 +14671,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{23a} +@anchor{gnat_rm/implementation_advice rm-a-3-2-49-ada-characters-handling}@anchor{23e} @section RM A.3.2(49): @code{Ada.Characters.Handling} @@ -14877,7 +14688,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{23b} +@anchor{gnat_rm/implementation_advice rm-a-4-4-106-bounded-length-string-handling}@anchor{23f} @section RM A.4.4(106): Bounded-Length String Handling @@ -14892,7 +14703,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{23c} +@anchor{gnat_rm/implementation_advice rm-a-5-2-46-47-random-number-generation}@anchor{240} @section RM A.5.2(46-47): Random Number Generation @@ -14921,7 +14732,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{23d} +@anchor{gnat_rm/implementation_advice rm-a-10-7-23-get-immediate}@anchor{241} @section RM A.10.7(23): @code{Get_Immediate} @@ -14945,7 +14756,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{23e} +@anchor{gnat_rm/implementation_advice rm-a-18-containers}@anchor{242} @section RM A.18: @code{Containers} @@ -14966,7 +14777,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{23f} +@anchor{gnat_rm/implementation_advice rm-b-1-39-41-pragma-export}@anchor{243} @section RM B.1(39-41): Pragma @code{Export} @@ -15014,7 +14825,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{240} +@anchor{gnat_rm/implementation_advice rm-b-2-12-13-package-interfaces}@anchor{244} @section RM B.2(12-13): Package @code{Interfaces} @@ -15044,7 +14855,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{241} +@anchor{gnat_rm/implementation_advice rm-b-3-63-71-interfacing-with-c}@anchor{245} @section RM B.3(63-71): Interfacing with C @@ -15132,7 +14943,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{242} +@anchor{gnat_rm/implementation_advice rm-b-4-95-98-interfacing-with-cobol}@anchor{246} @section RM B.4(95-98): Interfacing with COBOL @@ -15173,7 +14984,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{243} +@anchor{gnat_rm/implementation_advice rm-b-5-22-26-interfacing-with-fortran}@anchor{247} @section RM B.5(22-26): Interfacing with Fortran @@ -15224,7 +15035,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{244} +@anchor{gnat_rm/implementation_advice rm-c-1-3-5-access-to-machine-operations}@anchor{248} @section RM C.1(3-5): Access to Machine Operations @@ -15259,7 +15070,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{245} +@anchor{gnat_rm/implementation_advice rm-c-1-10-16-access-to-machine-operations}@anchor{249} @section RM C.1(10-16): Access to Machine Operations @@ -15320,7 +15131,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{246} +@anchor{gnat_rm/implementation_advice rm-c-3-28-interrupt-support}@anchor{24a} @section RM C.3(28): Interrupt Support @@ -15338,7 +15149,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{247} +@anchor{gnat_rm/implementation_advice rm-c-3-1-20-21-protected-procedure-handlers}@anchor{24b} @section RM C.3.1(20-21): Protected Procedure Handlers @@ -15364,7 +15175,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{248} +@anchor{gnat_rm/implementation_advice rm-c-3-2-25-package-interrupts}@anchor{24c} @section RM C.3.2(25): Package @code{Interrupts} @@ -15382,7 +15193,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{249} +@anchor{gnat_rm/implementation_advice rm-c-4-14-pre-elaboration-requirements}@anchor{24d} @section RM C.4(14): Pre-elaboration Requirements @@ -15398,7 +15209,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{24a} +@anchor{gnat_rm/implementation_advice rm-c-5-8-pragma-discard-names}@anchor{24e} @section RM C.5(8): Pragma @code{Discard_Names} @@ -15416,7 +15227,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{24b} +@anchor{gnat_rm/implementation_advice rm-c-7-2-30-the-package-task-attributes}@anchor{24f} @section RM C.7.2(30): The Package Task_Attributes @@ -15437,7 +15248,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{24c} +@anchor{gnat_rm/implementation_advice rm-d-3-17-locking-policies}@anchor{250} @section RM D.3(17): Locking Policies @@ -15454,7 +15265,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{24d} +@anchor{gnat_rm/implementation_advice rm-d-4-16-entry-queuing-policies}@anchor{251} @section RM D.4(16): Entry Queuing Policies @@ -15469,7 +15280,7 @@ Followed. No such implementation-defined queuing policies exist. @geindex Preemptive abort @node RM D 6 9-10 Preemptive Abort,RM D 7 21 Tasking Restrictions,RM D 4 16 Entry Queuing Policies,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-d-6-9-10-preemptive-abort}@anchor{24e} +@anchor{gnat_rm/implementation_advice rm-d-6-9-10-preemptive-abort}@anchor{252} @section RM D.6(9-10): Preemptive Abort @@ -15495,7 +15306,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{24f} +@anchor{gnat_rm/implementation_advice rm-d-7-21-tasking-restrictions}@anchor{253} @section RM D.7(21): Tasking Restrictions @@ -15514,7 +15325,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{250} +@anchor{gnat_rm/implementation_advice rm-d-8-47-49-monotonic-time}@anchor{254} @section RM D.8(47-49): Monotonic Time @@ -15549,7 +15360,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{251} +@anchor{gnat_rm/implementation_advice rm-e-5-28-29-partition-communication-subsystem}@anchor{255} @section RM E.5(28-29): Partition Communication Subsystem @@ -15577,7 +15388,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{252} +@anchor{gnat_rm/implementation_advice rm-f-7-cobol-support}@anchor{256} @section RM F(7): COBOL Support @@ -15597,7 +15408,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{253} +@anchor{gnat_rm/implementation_advice rm-f-1-2-decimal-radix-support}@anchor{257} @section RM F.1(2): Decimal Radix Support @@ -15613,7 +15424,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{254} +@anchor{gnat_rm/implementation_advice rm-g-numerics}@anchor{258} @section RM G: Numerics @@ -15633,7 +15444,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{255} +@anchor{gnat_rm/implementation_advice rm-g-1-1-56-58-complex-types}@anchor{259} @section RM G.1.1(56-58): Complex Types @@ -15695,7 +15506,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{256} +@anchor{gnat_rm/implementation_advice rm-g-1-2-49-complex-elementary-functions}@anchor{25a} @section RM G.1.2(49): Complex Elementary Functions @@ -15717,7 +15528,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{257} +@anchor{gnat_rm/implementation_advice rm-g-2-4-19-accuracy-requirements}@anchor{25b} @section RM G.2.4(19): Accuracy Requirements @@ -15741,7 +15552,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{258} +@anchor{gnat_rm/implementation_advice rm-g-2-6-15-complex-arithmetic-accuracy}@anchor{25c} @section RM G.2.6(15): Complex Arithmetic Accuracy @@ -15759,7 +15570,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{259} +@anchor{gnat_rm/implementation_advice rm-h-6-15-2-pragma-partition-elaboration-policy}@anchor{25d} @section RM H.6(15/2): Pragma Partition_Elaboration_Policy @@ -15774,7 +15585,7 @@ immediately terminated.” Not followed. @node Implementation Defined Characteristics,Intrinsic Subprograms,Implementation Advice,Top -@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} +@anchor{gnat_rm/implementation_defined_characteristics doc}@anchor{25e}@anchor{gnat_rm/implementation_defined_characteristics id1}@anchor{25f}@anchor{gnat_rm/implementation_defined_characteristics implementation-defined-characteristics}@anchor{b} @chapter Implementation Defined Characteristics @@ -16623,7 +16434,7 @@ See separate section on data representations. such aspects and the legality rules for such aspects. See 13.1.1(38).” @end itemize -See @ref{120,,Implementation Defined Aspects}. +See @ref{123,,Implementation Defined Aspects}. @itemize * @@ -17069,7 +16880,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{25c,,GNAT.Regexp (g-regexp.ads)}. +See @ref{260,,GNAT.Regexp (g-regexp.ads)}. @itemize * @@ -17097,9 +16908,13 @@ This definition is determined by the underlying operating system. @item “The circumstances where an environment variable cannot be defined. See A.17(16).” +@end itemize There are no such implementation-defined circumstances. + +@itemize * + @item “Environment names for which Set has the effect of Clear. See A.17(17).” @end itemize @@ -17762,10 +17577,14 @@ Execution is erroneous in that case. @item “Whether the use of pragma Restrictions results in a reduction in program code or data size or execution time. See D.7(20).” +@end itemize Yes it can, but the precise circumstances and properties of such reductions are difficult to characterize. + +@itemize * + @item “The value of Barrier_Limit’Last in Synchronous_Barriers. See D.10.1(4).” @end itemize @@ -18159,7 +17978,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{25d}@anchor{gnat_rm/intrinsic_subprograms id1}@anchor{25e}@anchor{gnat_rm/intrinsic_subprograms intrinsic-subprograms}@anchor{c} +@anchor{gnat_rm/intrinsic_subprograms doc}@anchor{261}@anchor{gnat_rm/intrinsic_subprograms id1}@anchor{262}@anchor{gnat_rm/intrinsic_subprograms intrinsic-subprograms}@anchor{c} @chapter Intrinsic Subprograms @@ -18197,7 +18016,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{25f}@anchor{gnat_rm/intrinsic_subprograms intrinsic-operators}@anchor{260} +@anchor{gnat_rm/intrinsic_subprograms id2}@anchor{263}@anchor{gnat_rm/intrinsic_subprograms intrinsic-operators}@anchor{264} @section Intrinsic Operators @@ -18228,7 +18047,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{261}@anchor{gnat_rm/intrinsic_subprograms id3}@anchor{262} +@anchor{gnat_rm/intrinsic_subprograms compilation-iso-date}@anchor{265}@anchor{gnat_rm/intrinsic_subprograms id3}@anchor{266} @section Compilation_ISO_Date @@ -18242,7 +18061,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{263}@anchor{gnat_rm/intrinsic_subprograms id4}@anchor{264} +@anchor{gnat_rm/intrinsic_subprograms compilation-date}@anchor{267}@anchor{gnat_rm/intrinsic_subprograms id4}@anchor{268} @section Compilation_Date @@ -18252,7 +18071,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{265}@anchor{gnat_rm/intrinsic_subprograms id5}@anchor{266} +@anchor{gnat_rm/intrinsic_subprograms compilation-time}@anchor{269}@anchor{gnat_rm/intrinsic_subprograms id5}@anchor{26a} @section Compilation_Time @@ -18266,7 +18085,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{267}@anchor{gnat_rm/intrinsic_subprograms id6}@anchor{268} +@anchor{gnat_rm/intrinsic_subprograms enclosing-entity}@anchor{26b}@anchor{gnat_rm/intrinsic_subprograms id6}@anchor{26c} @section Enclosing_Entity @@ -18280,7 +18099,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{269}@anchor{gnat_rm/intrinsic_subprograms id7}@anchor{26a} +@anchor{gnat_rm/intrinsic_subprograms exception-information}@anchor{26d}@anchor{gnat_rm/intrinsic_subprograms id7}@anchor{26e} @section Exception_Information @@ -18294,7 +18113,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{26b}@anchor{gnat_rm/intrinsic_subprograms id8}@anchor{26c} +@anchor{gnat_rm/intrinsic_subprograms exception-message}@anchor{26f}@anchor{gnat_rm/intrinsic_subprograms id8}@anchor{270} @section Exception_Message @@ -18308,7 +18127,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{26d}@anchor{gnat_rm/intrinsic_subprograms id9}@anchor{26e} +@anchor{gnat_rm/intrinsic_subprograms exception-name}@anchor{271}@anchor{gnat_rm/intrinsic_subprograms id9}@anchor{272} @section Exception_Name @@ -18322,7 +18141,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{26f}@anchor{gnat_rm/intrinsic_subprograms id10}@anchor{270} +@anchor{gnat_rm/intrinsic_subprograms file}@anchor{273}@anchor{gnat_rm/intrinsic_subprograms id10}@anchor{274} @section File @@ -18336,7 +18155,7 @@ application program should simply call the function file. @node Line,Shifts and Rotates,File,Intrinsic Subprograms -@anchor{gnat_rm/intrinsic_subprograms id11}@anchor{271}@anchor{gnat_rm/intrinsic_subprograms line}@anchor{272} +@anchor{gnat_rm/intrinsic_subprograms id11}@anchor{275}@anchor{gnat_rm/intrinsic_subprograms line}@anchor{276} @section Line @@ -18350,7 +18169,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{273}@anchor{gnat_rm/intrinsic_subprograms shifts-and-rotates}@anchor{274} +@anchor{gnat_rm/intrinsic_subprograms id12}@anchor{277}@anchor{gnat_rm/intrinsic_subprograms shifts-and-rotates}@anchor{278} @section Shifts and Rotates @@ -18393,7 +18212,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{275}@anchor{gnat_rm/intrinsic_subprograms source-location}@anchor{276} +@anchor{gnat_rm/intrinsic_subprograms id13}@anchor{279}@anchor{gnat_rm/intrinsic_subprograms source-location}@anchor{27a} @section Source_Location @@ -18407,7 +18226,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{277}@anchor{gnat_rm/representation_clauses_and_pragmas id1}@anchor{278}@anchor{gnat_rm/representation_clauses_and_pragmas representation-clauses-and-pragmas}@anchor{d} +@anchor{gnat_rm/representation_clauses_and_pragmas doc}@anchor{27b}@anchor{gnat_rm/representation_clauses_and_pragmas id1}@anchor{27c}@anchor{gnat_rm/representation_clauses_and_pragmas representation-clauses-and-pragmas}@anchor{d} @chapter Representation Clauses and Pragmas @@ -18453,7 +18272,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{279}@anchor{gnat_rm/representation_clauses_and_pragmas id2}@anchor{27a} +@anchor{gnat_rm/representation_clauses_and_pragmas alignment-clauses}@anchor{27d}@anchor{gnat_rm/representation_clauses_and_pragmas id2}@anchor{27e} @section Alignment Clauses @@ -18475,7 +18294,7 @@ For elementary types, the alignment is the minimum of the actual size of objects of the type divided by @code{Storage_Unit}, and the maximum alignment supported by the target. (This maximum alignment is given by the GNAT-specific attribute -@code{Standard'Maximum_Alignment}; see @ref{18c,,Attribute Maximum_Alignment}.) +@code{Standard'Maximum_Alignment}; see @ref{190,,Attribute Maximum_Alignment}.) @geindex Maximum_Alignment attribute @@ -18584,7 +18403,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{27b}@anchor{gnat_rm/representation_clauses_and_pragmas size-clauses}@anchor{27c} +@anchor{gnat_rm/representation_clauses_and_pragmas id3}@anchor{27f}@anchor{gnat_rm/representation_clauses_and_pragmas size-clauses}@anchor{280} @section Size Clauses @@ -18661,7 +18480,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{27d}@anchor{gnat_rm/representation_clauses_and_pragmas storage-size-clauses}@anchor{27e} +@anchor{gnat_rm/representation_clauses_and_pragmas id4}@anchor{281}@anchor{gnat_rm/representation_clauses_and_pragmas storage-size-clauses}@anchor{282} @section Storage_Size Clauses @@ -18734,7 +18553,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{27f}@anchor{gnat_rm/representation_clauses_and_pragmas size-of-variant-record-objects}@anchor{280} +@anchor{gnat_rm/representation_clauses_and_pragmas id5}@anchor{283}@anchor{gnat_rm/representation_clauses_and_pragmas size-of-variant-record-objects}@anchor{284} @section Size of Variant Record Objects @@ -18844,7 +18663,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{281}@anchor{gnat_rm/representation_clauses_and_pragmas id6}@anchor{282} +@anchor{gnat_rm/representation_clauses_and_pragmas biased-representation}@anchor{285}@anchor{gnat_rm/representation_clauses_and_pragmas id6}@anchor{286} @section Biased Representation @@ -18882,7 +18701,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{283}@anchor{gnat_rm/representation_clauses_and_pragmas value-size-and-object-size-clauses}@anchor{284} +@anchor{gnat_rm/representation_clauses_and_pragmas id7}@anchor{287}@anchor{gnat_rm/representation_clauses_and_pragmas value-size-and-object-size-clauses}@anchor{288} @section Value_Size and Object_Size Clauses @@ -19198,7 +19017,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{285}@anchor{gnat_rm/representation_clauses_and_pragmas id8}@anchor{286} +@anchor{gnat_rm/representation_clauses_and_pragmas component-size-clauses}@anchor{289}@anchor{gnat_rm/representation_clauses_and_pragmas id8}@anchor{28a} @section Component_Size Clauses @@ -19246,7 +19065,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{287}@anchor{gnat_rm/representation_clauses_and_pragmas id9}@anchor{288} +@anchor{gnat_rm/representation_clauses_and_pragmas bit-order-clauses}@anchor{28b}@anchor{gnat_rm/representation_clauses_and_pragmas id9}@anchor{28c} @section Bit_Order Clauses @@ -19352,7 +19171,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{289}@anchor{gnat_rm/representation_clauses_and_pragmas id10}@anchor{28a} +@anchor{gnat_rm/representation_clauses_and_pragmas effect-of-bit-order-on-byte-ordering}@anchor{28d}@anchor{gnat_rm/representation_clauses_and_pragmas id10}@anchor{28e} @section Effect of Bit_Order on Byte Ordering @@ -19609,7 +19428,7 @@ to set the boolean constant @code{Master_Byte_First} in an appropriate manner. @node Pragma Pack for Arrays,Pragma Pack for Records,Effect of Bit_Order on Byte Ordering,Representation Clauses and Pragmas -@anchor{gnat_rm/representation_clauses_and_pragmas id11}@anchor{28b}@anchor{gnat_rm/representation_clauses_and_pragmas pragma-pack-for-arrays}@anchor{28c} +@anchor{gnat_rm/representation_clauses_and_pragmas id11}@anchor{28f}@anchor{gnat_rm/representation_clauses_and_pragmas pragma-pack-for-arrays}@anchor{290} @section Pragma Pack for Arrays @@ -19729,7 +19548,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{28d}@anchor{gnat_rm/representation_clauses_and_pragmas pragma-pack-for-records}@anchor{28e} +@anchor{gnat_rm/representation_clauses_and_pragmas id12}@anchor{291}@anchor{gnat_rm/representation_clauses_and_pragmas pragma-pack-for-records}@anchor{292} @section Pragma Pack for Records @@ -19813,7 +19632,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{28f}@anchor{gnat_rm/representation_clauses_and_pragmas record-representation-clauses}@anchor{290} +@anchor{gnat_rm/representation_clauses_and_pragmas id13}@anchor{293}@anchor{gnat_rm/representation_clauses_and_pragmas record-representation-clauses}@anchor{294} @section Record Representation Clauses @@ -19892,7 +19711,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{291}@anchor{gnat_rm/representation_clauses_and_pragmas id14}@anchor{292} +@anchor{gnat_rm/representation_clauses_and_pragmas handling-of-records-with-holes}@anchor{295}@anchor{gnat_rm/representation_clauses_and_pragmas id14}@anchor{296} @section Handling of Records with Holes @@ -19968,7 +19787,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{293}@anchor{gnat_rm/representation_clauses_and_pragmas id15}@anchor{294} +@anchor{gnat_rm/representation_clauses_and_pragmas enumeration-clauses}@anchor{297}@anchor{gnat_rm/representation_clauses_and_pragmas id15}@anchor{298} @section Enumeration Clauses @@ -20011,7 +19830,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{295}@anchor{gnat_rm/representation_clauses_and_pragmas id16}@anchor{296} +@anchor{gnat_rm/representation_clauses_and_pragmas address-clauses}@anchor{299}@anchor{gnat_rm/representation_clauses_and_pragmas id16}@anchor{29a} @section Address Clauses @@ -20351,7 +20170,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{297}@anchor{gnat_rm/representation_clauses_and_pragmas use-of-address-clauses-for-memory-mapped-i-o}@anchor{298} +@anchor{gnat_rm/representation_clauses_and_pragmas id17}@anchor{29b}@anchor{gnat_rm/representation_clauses_and_pragmas use-of-address-clauses-for-memory-mapped-i-o}@anchor{29c} @section Use of Address Clauses for Memory-Mapped I/O @@ -20409,7 +20228,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{299}@anchor{gnat_rm/representation_clauses_and_pragmas id18}@anchor{29a} +@anchor{gnat_rm/representation_clauses_and_pragmas effect-of-convention-on-representation}@anchor{29d}@anchor{gnat_rm/representation_clauses_and_pragmas id18}@anchor{29e} @section Effect of Convention on Representation @@ -20487,7 +20306,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{29b}@anchor{gnat_rm/representation_clauses_and_pragmas id19}@anchor{29c} +@anchor{gnat_rm/representation_clauses_and_pragmas conventions-and-anonymous-access-types}@anchor{29f}@anchor{gnat_rm/representation_clauses_and_pragmas id19}@anchor{2a0} @section Conventions and Anonymous Access Types @@ -20563,7 +20382,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{29d}@anchor{gnat_rm/representation_clauses_and_pragmas id20}@anchor{29e} +@anchor{gnat_rm/representation_clauses_and_pragmas determining-the-representations-chosen-by-gnat}@anchor{2a1}@anchor{gnat_rm/representation_clauses_and_pragmas id20}@anchor{2a2} @section Determining the Representations chosen by GNAT @@ -20715,7 +20534,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{29f}@anchor{gnat_rm/standard_library_routines id1}@anchor{2a0}@anchor{gnat_rm/standard_library_routines standard-library-routines}@anchor{e} +@anchor{gnat_rm/standard_library_routines doc}@anchor{2a3}@anchor{gnat_rm/standard_library_routines id1}@anchor{2a4}@anchor{gnat_rm/standard_library_routines standard-library-routines}@anchor{e} @chapter Standard Library Routines @@ -21539,7 +21358,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{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} +@anchor{gnat_rm/the_implementation_of_standard_i_o doc}@anchor{2a5}@anchor{gnat_rm/the_implementation_of_standard_i_o id1}@anchor{2a6}@anchor{gnat_rm/the_implementation_of_standard_i_o the-implementation-of-standard-i-o}@anchor{f} @chapter The Implementation of Standard I/O @@ -21591,7 +21410,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{2a3}@anchor{gnat_rm/the_implementation_of_standard_i_o standard-i-o-packages}@anchor{2a4} +@anchor{gnat_rm/the_implementation_of_standard_i_o id2}@anchor{2a7}@anchor{gnat_rm/the_implementation_of_standard_i_o standard-i-o-packages}@anchor{2a8} @section Standard I/O Packages @@ -21662,7 +21481,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{2a5}@anchor{gnat_rm/the_implementation_of_standard_i_o id3}@anchor{2a6} +@anchor{gnat_rm/the_implementation_of_standard_i_o form-strings}@anchor{2a9}@anchor{gnat_rm/the_implementation_of_standard_i_o id3}@anchor{2aa} @section FORM Strings @@ -21688,7 +21507,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{2a7}@anchor{gnat_rm/the_implementation_of_standard_i_o id4}@anchor{2a8} +@anchor{gnat_rm/the_implementation_of_standard_i_o direct-io}@anchor{2ab}@anchor{gnat_rm/the_implementation_of_standard_i_o id4}@anchor{2ac} @section Direct_IO @@ -21708,7 +21527,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{2a9}@anchor{gnat_rm/the_implementation_of_standard_i_o sequential-io}@anchor{2aa} +@anchor{gnat_rm/the_implementation_of_standard_i_o id5}@anchor{2ad}@anchor{gnat_rm/the_implementation_of_standard_i_o sequential-io}@anchor{2ae} @section Sequential_IO @@ -21755,7 +21574,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{2ab}@anchor{gnat_rm/the_implementation_of_standard_i_o text-io}@anchor{2ac} +@anchor{gnat_rm/the_implementation_of_standard_i_o id6}@anchor{2af}@anchor{gnat_rm/the_implementation_of_standard_i_o text-io}@anchor{2b0} @section Text_IO @@ -21838,7 +21657,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{2ad}@anchor{gnat_rm/the_implementation_of_standard_i_o stream-pointer-positioning}@anchor{2ae} +@anchor{gnat_rm/the_implementation_of_standard_i_o id7}@anchor{2b1}@anchor{gnat_rm/the_implementation_of_standard_i_o stream-pointer-positioning}@anchor{2b2} @subsection Stream Pointer Positioning @@ -21874,7 +21693,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{2af}@anchor{gnat_rm/the_implementation_of_standard_i_o reading-and-writing-non-regular-files}@anchor{2b0} +@anchor{gnat_rm/the_implementation_of_standard_i_o id8}@anchor{2b3}@anchor{gnat_rm/the_implementation_of_standard_i_o reading-and-writing-non-regular-files}@anchor{2b4} @subsection Reading and Writing Non-Regular Files @@ -21925,7 +21744,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{2b1}@anchor{gnat_rm/the_implementation_of_standard_i_o id9}@anchor{2b2} +@anchor{gnat_rm/the_implementation_of_standard_i_o get-immediate}@anchor{2b5}@anchor{gnat_rm/the_implementation_of_standard_i_o id9}@anchor{2b6} @subsection Get_Immediate @@ -21943,7 +21762,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{2b3}@anchor{gnat_rm/the_implementation_of_standard_i_o treating-text-io-files-as-streams}@anchor{2b4} +@anchor{gnat_rm/the_implementation_of_standard_i_o id10}@anchor{2b7}@anchor{gnat_rm/the_implementation_of_standard_i_o treating-text-io-files-as-streams}@anchor{2b8} @subsection Treating Text_IO Files as Streams @@ -21959,7 +21778,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{2b5}@anchor{gnat_rm/the_implementation_of_standard_i_o text-io-extensions}@anchor{2b6} +@anchor{gnat_rm/the_implementation_of_standard_i_o id11}@anchor{2b9}@anchor{gnat_rm/the_implementation_of_standard_i_o text-io-extensions}@anchor{2ba} @subsection Text_IO Extensions @@ -21987,7 +21806,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{2b7}@anchor{gnat_rm/the_implementation_of_standard_i_o text-io-facilities-for-unbounded-strings}@anchor{2b8} +@anchor{gnat_rm/the_implementation_of_standard_i_o id12}@anchor{2bb}@anchor{gnat_rm/the_implementation_of_standard_i_o text-io-facilities-for-unbounded-strings}@anchor{2bc} @subsection Text_IO Facilities for Unbounded Strings @@ -22035,7 +21854,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{2b9}@anchor{gnat_rm/the_implementation_of_standard_i_o wide-text-io}@anchor{2ba} +@anchor{gnat_rm/the_implementation_of_standard_i_o id13}@anchor{2bd}@anchor{gnat_rm/the_implementation_of_standard_i_o wide-text-io}@anchor{2be} @section Wide_Text_IO @@ -22282,12 +22101,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{2bb}@anchor{gnat_rm/the_implementation_of_standard_i_o stream-pointer-positioning-1}@anchor{2bc} +@anchor{gnat_rm/the_implementation_of_standard_i_o id14}@anchor{2bf}@anchor{gnat_rm/the_implementation_of_standard_i_o stream-pointer-positioning-1}@anchor{2c0} @subsection Stream Pointer Positioning @code{Ada.Wide_Text_IO} is similar to @code{Ada.Text_IO} in its handling -of stream pointer positioning (@ref{2ac,,Text_IO}). There is one additional +of stream pointer positioning (@ref{2b0,,Text_IO}). There is one additional case: If @code{Ada.Wide_Text_IO.Look_Ahead} reads a character outside the @@ -22306,7 +22125,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{2bd}@anchor{gnat_rm/the_implementation_of_standard_i_o reading-and-writing-non-regular-files-1}@anchor{2be} +@anchor{gnat_rm/the_implementation_of_standard_i_o id15}@anchor{2c1}@anchor{gnat_rm/the_implementation_of_standard_i_o reading-and-writing-non-regular-files-1}@anchor{2c2} @subsection Reading and Writing Non-Regular Files @@ -22317,7 +22136,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{2bf}@anchor{gnat_rm/the_implementation_of_standard_i_o wide-wide-text-io}@anchor{2c0} +@anchor{gnat_rm/the_implementation_of_standard_i_o id16}@anchor{2c3}@anchor{gnat_rm/the_implementation_of_standard_i_o wide-wide-text-io}@anchor{2c4} @section Wide_Wide_Text_IO @@ -22486,12 +22305,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{2c1}@anchor{gnat_rm/the_implementation_of_standard_i_o stream-pointer-positioning-2}@anchor{2c2} +@anchor{gnat_rm/the_implementation_of_standard_i_o id17}@anchor{2c5}@anchor{gnat_rm/the_implementation_of_standard_i_o stream-pointer-positioning-2}@anchor{2c6} @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{2ac,,Text_IO}). There is one additional +of stream pointer positioning (@ref{2b0,,Text_IO}). There is one additional case: If @code{Ada.Wide_Wide_Text_IO.Look_Ahead} reads a character outside the @@ -22510,7 +22329,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{2c3}@anchor{gnat_rm/the_implementation_of_standard_i_o reading-and-writing-non-regular-files-2}@anchor{2c4} +@anchor{gnat_rm/the_implementation_of_standard_i_o id18}@anchor{2c7}@anchor{gnat_rm/the_implementation_of_standard_i_o reading-and-writing-non-regular-files-2}@anchor{2c8} @subsection Reading and Writing Non-Regular Files @@ -22521,7 +22340,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{2c5}@anchor{gnat_rm/the_implementation_of_standard_i_o stream-io}@anchor{2c6} +@anchor{gnat_rm/the_implementation_of_standard_i_o id19}@anchor{2c9}@anchor{gnat_rm/the_implementation_of_standard_i_o stream-io}@anchor{2ca} @section Stream_IO @@ -22543,7 +22362,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{2c7}@anchor{gnat_rm/the_implementation_of_standard_i_o text-translation}@anchor{2c8} +@anchor{gnat_rm/the_implementation_of_standard_i_o id20}@anchor{2cb}@anchor{gnat_rm/the_implementation_of_standard_i_o text-translation}@anchor{2cc} @section Text Translation @@ -22577,7 +22396,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{2c9}@anchor{gnat_rm/the_implementation_of_standard_i_o shared-files}@anchor{2ca} +@anchor{gnat_rm/the_implementation_of_standard_i_o id21}@anchor{2cd}@anchor{gnat_rm/the_implementation_of_standard_i_o shared-files}@anchor{2ce} @section Shared Files @@ -22640,7 +22459,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{2cb}@anchor{gnat_rm/the_implementation_of_standard_i_o id22}@anchor{2cc} +@anchor{gnat_rm/the_implementation_of_standard_i_o filenames-encoding}@anchor{2cf}@anchor{gnat_rm/the_implementation_of_standard_i_o id22}@anchor{2d0} @section Filenames encoding @@ -22680,7 +22499,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{2cd}@anchor{gnat_rm/the_implementation_of_standard_i_o id23}@anchor{2ce} +@anchor{gnat_rm/the_implementation_of_standard_i_o file-content-encoding}@anchor{2d1}@anchor{gnat_rm/the_implementation_of_standard_i_o id23}@anchor{2d2} @section File content encoding @@ -22713,7 +22532,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{2cf}@anchor{gnat_rm/the_implementation_of_standard_i_o open-modes}@anchor{2d0} +@anchor{gnat_rm/the_implementation_of_standard_i_o id24}@anchor{2d3}@anchor{gnat_rm/the_implementation_of_standard_i_o open-modes}@anchor{2d4} @section Open Modes @@ -22816,7 +22635,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{2d1}@anchor{gnat_rm/the_implementation_of_standard_i_o operations-on-c-streams}@anchor{2d2} +@anchor{gnat_rm/the_implementation_of_standard_i_o id25}@anchor{2d5}@anchor{gnat_rm/the_implementation_of_standard_i_o operations-on-c-streams}@anchor{2d6} @section Operations on C Streams @@ -22976,7 +22795,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{2d3}@anchor{gnat_rm/the_implementation_of_standard_i_o interfacing-to-c-streams}@anchor{2d4} +@anchor{gnat_rm/the_implementation_of_standard_i_o id26}@anchor{2d7}@anchor{gnat_rm/the_implementation_of_standard_i_o interfacing-to-c-streams}@anchor{2d8} @section Interfacing to C Streams @@ -23069,7 +22888,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{2d5}@anchor{gnat_rm/the_gnat_library id1}@anchor{2d6}@anchor{gnat_rm/the_gnat_library the-gnat-library}@anchor{10} +@anchor{gnat_rm/the_gnat_library doc}@anchor{2d9}@anchor{gnat_rm/the_gnat_library id1}@anchor{2da}@anchor{gnat_rm/the_gnat_library the-gnat-library}@anchor{10} @chapter The GNAT Library @@ -23255,7 +23074,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{2d7}@anchor{gnat_rm/the_gnat_library id2}@anchor{2d8} +@anchor{gnat_rm/the_gnat_library ada-characters-latin-9-a-chlat9-ads}@anchor{2db}@anchor{gnat_rm/the_gnat_library id2}@anchor{2dc} @section @code{Ada.Characters.Latin_9} (@code{a-chlat9.ads}) @@ -23272,7 +23091,7 @@ is specifically authorized by the Ada Reference Manual (RM A.3.3(27)). @node Ada Characters Wide_Latin_1 a-cwila1 ads,Ada Characters Wide_Latin_9 a-cwila9 ads,Ada Characters Latin_9 a-chlat9 ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library ada-characters-wide-latin-1-a-cwila1-ads}@anchor{2d9}@anchor{gnat_rm/the_gnat_library id3}@anchor{2da} +@anchor{gnat_rm/the_gnat_library ada-characters-wide-latin-1-a-cwila1-ads}@anchor{2dd}@anchor{gnat_rm/the_gnat_library id3}@anchor{2de} @section @code{Ada.Characters.Wide_Latin_1} (@code{a-cwila1.ads}) @@ -23289,7 +23108,7 @@ is specifically authorized by the Ada Reference Manual (RM A.3.3(27)). @node Ada Characters Wide_Latin_9 a-cwila9 ads,Ada Characters Wide_Wide_Latin_1 a-chzla1 ads,Ada Characters Wide_Latin_1 a-cwila1 ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library ada-characters-wide-latin-9-a-cwila9-ads}@anchor{2db}@anchor{gnat_rm/the_gnat_library id4}@anchor{2dc} +@anchor{gnat_rm/the_gnat_library ada-characters-wide-latin-9-a-cwila9-ads}@anchor{2df}@anchor{gnat_rm/the_gnat_library id4}@anchor{2e0} @section @code{Ada.Characters.Wide_Latin_9} (@code{a-cwila9.ads}) @@ -23306,7 +23125,7 @@ is specifically authorized by the Ada Reference Manual (RM A.3.3(27)). @node Ada Characters Wide_Wide_Latin_1 a-chzla1 ads,Ada Characters Wide_Wide_Latin_9 a-chzla9 ads,Ada Characters Wide_Latin_9 a-cwila9 ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library ada-characters-wide-wide-latin-1-a-chzla1-ads}@anchor{2dd}@anchor{gnat_rm/the_gnat_library id5}@anchor{2de} +@anchor{gnat_rm/the_gnat_library ada-characters-wide-wide-latin-1-a-chzla1-ads}@anchor{2e1}@anchor{gnat_rm/the_gnat_library id5}@anchor{2e2} @section @code{Ada.Characters.Wide_Wide_Latin_1} (@code{a-chzla1.ads}) @@ -23323,7 +23142,7 @@ is specifically authorized by the Ada Reference Manual (RM A.3.3(27)). @node Ada Characters Wide_Wide_Latin_9 a-chzla9 ads,Ada Containers Bounded_Holders a-coboho ads,Ada Characters Wide_Wide_Latin_1 a-chzla1 ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library ada-characters-wide-wide-latin-9-a-chzla9-ads}@anchor{2df}@anchor{gnat_rm/the_gnat_library id6}@anchor{2e0} +@anchor{gnat_rm/the_gnat_library ada-characters-wide-wide-latin-9-a-chzla9-ads}@anchor{2e3}@anchor{gnat_rm/the_gnat_library id6}@anchor{2e4} @section @code{Ada.Characters.Wide_Wide_Latin_9} (@code{a-chzla9.ads}) @@ -23340,7 +23159,7 @@ is specifically authorized by the Ada Reference Manual (RM A.3.3(27)). @node Ada Containers Bounded_Holders a-coboho ads,Ada Command_Line Environment a-colien ads,Ada Characters Wide_Wide_Latin_9 a-chzla9 ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library ada-containers-bounded-holders-a-coboho-ads}@anchor{2e1}@anchor{gnat_rm/the_gnat_library id7}@anchor{2e2} +@anchor{gnat_rm/the_gnat_library ada-containers-bounded-holders-a-coboho-ads}@anchor{2e5}@anchor{gnat_rm/the_gnat_library id7}@anchor{2e6} @section @code{Ada.Containers.Bounded_Holders} (@code{a-coboho.ads}) @@ -23352,7 +23171,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{2e3}@anchor{gnat_rm/the_gnat_library id8}@anchor{2e4} +@anchor{gnat_rm/the_gnat_library ada-command-line-environment-a-colien-ads}@anchor{2e7}@anchor{gnat_rm/the_gnat_library id8}@anchor{2e8} @section @code{Ada.Command_Line.Environment} (@code{a-colien.ads}) @@ -23365,7 +23184,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{2e5}@anchor{gnat_rm/the_gnat_library id9}@anchor{2e6} +@anchor{gnat_rm/the_gnat_library ada-command-line-remove-a-colire-ads}@anchor{2e9}@anchor{gnat_rm/the_gnat_library id9}@anchor{2ea} @section @code{Ada.Command_Line.Remove} (@code{a-colire.ads}) @@ -23383,7 +23202,7 @@ to further calls to the subprograms in @code{Ada.Command_Line}. These calls will not see the removed argument. @node Ada Command_Line Response_File a-clrefi ads,Ada Direct_IO C_Streams a-diocst ads,Ada Command_Line Remove a-colire ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library ada-command-line-response-file-a-clrefi-ads}@anchor{2e7}@anchor{gnat_rm/the_gnat_library id10}@anchor{2e8} +@anchor{gnat_rm/the_gnat_library ada-command-line-response-file-a-clrefi-ads}@anchor{2eb}@anchor{gnat_rm/the_gnat_library id10}@anchor{2ec} @section @code{Ada.Command_Line.Response_File} (@code{a-clrefi.ads}) @@ -23403,7 +23222,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{2e9}@anchor{gnat_rm/the_gnat_library id11}@anchor{2ea} +@anchor{gnat_rm/the_gnat_library ada-direct-io-c-streams-a-diocst-ads}@anchor{2ed}@anchor{gnat_rm/the_gnat_library id11}@anchor{2ee} @section @code{Ada.Direct_IO.C_Streams} (@code{a-diocst.ads}) @@ -23418,7 +23237,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{2eb}@anchor{gnat_rm/the_gnat_library id12}@anchor{2ec} +@anchor{gnat_rm/the_gnat_library ada-exceptions-is-null-occurrence-a-einuoc-ads}@anchor{2ef}@anchor{gnat_rm/the_gnat_library id12}@anchor{2f0} @section @code{Ada.Exceptions.Is_Null_Occurrence} (@code{a-einuoc.ads}) @@ -23432,7 +23251,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{2ed}@anchor{gnat_rm/the_gnat_library id13}@anchor{2ee} +@anchor{gnat_rm/the_gnat_library ada-exceptions-last-chance-handler-a-elchha-ads}@anchor{2f1}@anchor{gnat_rm/the_gnat_library id13}@anchor{2f2} @section @code{Ada.Exceptions.Last_Chance_Handler} (@code{a-elchha.ads}) @@ -23446,7 +23265,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{2ef}@anchor{gnat_rm/the_gnat_library id14}@anchor{2f0} +@anchor{gnat_rm/the_gnat_library ada-exceptions-traceback-a-exctra-ads}@anchor{2f3}@anchor{gnat_rm/the_gnat_library id14}@anchor{2f4} @section @code{Ada.Exceptions.Traceback} (@code{a-exctra.ads}) @@ -23459,7 +23278,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{2f1}@anchor{gnat_rm/the_gnat_library id15}@anchor{2f2} +@anchor{gnat_rm/the_gnat_library ada-sequential-io-c-streams-a-siocst-ads}@anchor{2f5}@anchor{gnat_rm/the_gnat_library id15}@anchor{2f6} @section @code{Ada.Sequential_IO.C_Streams} (@code{a-siocst.ads}) @@ -23474,7 +23293,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{2f3}@anchor{gnat_rm/the_gnat_library id16}@anchor{2f4} +@anchor{gnat_rm/the_gnat_library ada-streams-stream-io-c-streams-a-ssicst-ads}@anchor{2f7}@anchor{gnat_rm/the_gnat_library id16}@anchor{2f8} @section @code{Ada.Streams.Stream_IO.C_Streams} (@code{a-ssicst.ads}) @@ -23489,7 +23308,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{2f5}@anchor{gnat_rm/the_gnat_library id17}@anchor{2f6} +@anchor{gnat_rm/the_gnat_library ada-strings-unbounded-text-io-a-suteio-ads}@anchor{2f9}@anchor{gnat_rm/the_gnat_library id17}@anchor{2fa} @section @code{Ada.Strings.Unbounded.Text_IO} (@code{a-suteio.ads}) @@ -23506,7 +23325,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{2f7}@anchor{gnat_rm/the_gnat_library id18}@anchor{2f8} +@anchor{gnat_rm/the_gnat_library ada-strings-wide-unbounded-wide-text-io-a-swuwti-ads}@anchor{2fb}@anchor{gnat_rm/the_gnat_library id18}@anchor{2fc} @section @code{Ada.Strings.Wide_Unbounded.Wide_Text_IO} (@code{a-swuwti.ads}) @@ -23523,7 +23342,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{2f9}@anchor{gnat_rm/the_gnat_library id19}@anchor{2fa} +@anchor{gnat_rm/the_gnat_library ada-strings-wide-wide-unbounded-wide-wide-text-io-a-szuzti-ads}@anchor{2fd}@anchor{gnat_rm/the_gnat_library id19}@anchor{2fe} @section @code{Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO} (@code{a-szuzti.ads}) @@ -23540,7 +23359,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{2fb}@anchor{gnat_rm/the_gnat_library id20}@anchor{2fc} +@anchor{gnat_rm/the_gnat_library ada-task-initialization-a-tasini-ads}@anchor{2ff}@anchor{gnat_rm/the_gnat_library id20}@anchor{300} @section @code{Ada.Task_Initialization} (@code{a-tasini.ads}) @@ -23552,7 +23371,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{2fd}@anchor{gnat_rm/the_gnat_library id21}@anchor{2fe} +@anchor{gnat_rm/the_gnat_library ada-text-io-c-streams-a-tiocst-ads}@anchor{301}@anchor{gnat_rm/the_gnat_library id21}@anchor{302} @section @code{Ada.Text_IO.C_Streams} (@code{a-tiocst.ads}) @@ -23567,7 +23386,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{2ff}@anchor{gnat_rm/the_gnat_library id22}@anchor{300} +@anchor{gnat_rm/the_gnat_library ada-text-io-reset-standard-files-a-tirsfi-ads}@anchor{303}@anchor{gnat_rm/the_gnat_library id22}@anchor{304} @section @code{Ada.Text_IO.Reset_Standard_Files} (@code{a-tirsfi.ads}) @@ -23582,7 +23401,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{301}@anchor{gnat_rm/the_gnat_library id23}@anchor{302} +@anchor{gnat_rm/the_gnat_library ada-wide-characters-unicode-a-wichun-ads}@anchor{305}@anchor{gnat_rm/the_gnat_library id23}@anchor{306} @section @code{Ada.Wide_Characters.Unicode} (@code{a-wichun.ads}) @@ -23595,7 +23414,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{303}@anchor{gnat_rm/the_gnat_library id24}@anchor{304} +@anchor{gnat_rm/the_gnat_library ada-wide-text-io-c-streams-a-wtcstr-ads}@anchor{307}@anchor{gnat_rm/the_gnat_library id24}@anchor{308} @section @code{Ada.Wide_Text_IO.C_Streams} (@code{a-wtcstr.ads}) @@ -23610,7 +23429,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{305}@anchor{gnat_rm/the_gnat_library id25}@anchor{306} +@anchor{gnat_rm/the_gnat_library ada-wide-text-io-reset-standard-files-a-wrstfi-ads}@anchor{309}@anchor{gnat_rm/the_gnat_library id25}@anchor{30a} @section @code{Ada.Wide_Text_IO.Reset_Standard_Files} (@code{a-wrstfi.ads}) @@ -23625,7 +23444,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{307}@anchor{gnat_rm/the_gnat_library id26}@anchor{308} +@anchor{gnat_rm/the_gnat_library ada-wide-wide-characters-unicode-a-zchuni-ads}@anchor{30b}@anchor{gnat_rm/the_gnat_library id26}@anchor{30c} @section @code{Ada.Wide_Wide_Characters.Unicode} (@code{a-zchuni.ads}) @@ -23638,7 +23457,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{309}@anchor{gnat_rm/the_gnat_library id27}@anchor{30a} +@anchor{gnat_rm/the_gnat_library ada-wide-wide-text-io-c-streams-a-ztcstr-ads}@anchor{30d}@anchor{gnat_rm/the_gnat_library id27}@anchor{30e} @section @code{Ada.Wide_Wide_Text_IO.C_Streams} (@code{a-ztcstr.ads}) @@ -23653,7 +23472,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{30b}@anchor{gnat_rm/the_gnat_library id28}@anchor{30c} +@anchor{gnat_rm/the_gnat_library ada-wide-wide-text-io-reset-standard-files-a-zrstfi-ads}@anchor{30f}@anchor{gnat_rm/the_gnat_library id28}@anchor{310} @section @code{Ada.Wide_Wide_Text_IO.Reset_Standard_Files} (@code{a-zrstfi.ads}) @@ -23668,7 +23487,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{30d}@anchor{gnat_rm/the_gnat_library id29}@anchor{30e} +@anchor{gnat_rm/the_gnat_library gnat-altivec-g-altive-ads}@anchor{311}@anchor{gnat_rm/the_gnat_library id29}@anchor{312} @section @code{GNAT.Altivec} (@code{g-altive.ads}) @@ -23681,7 +23500,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{30f}@anchor{gnat_rm/the_gnat_library id30}@anchor{310} +@anchor{gnat_rm/the_gnat_library gnat-altivec-conversions-g-altcon-ads}@anchor{313}@anchor{gnat_rm/the_gnat_library id30}@anchor{314} @section @code{GNAT.Altivec.Conversions} (@code{g-altcon.ads}) @@ -23692,7 +23511,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{311}@anchor{gnat_rm/the_gnat_library id31}@anchor{312} +@anchor{gnat_rm/the_gnat_library gnat-altivec-vector-operations-g-alveop-ads}@anchor{315}@anchor{gnat_rm/the_gnat_library id31}@anchor{316} @section @code{GNAT.Altivec.Vector_Operations} (@code{g-alveop.ads}) @@ -23706,7 +23525,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{313}@anchor{gnat_rm/the_gnat_library id32}@anchor{314} +@anchor{gnat_rm/the_gnat_library gnat-altivec-vector-types-g-alvety-ads}@anchor{317}@anchor{gnat_rm/the_gnat_library id32}@anchor{318} @section @code{GNAT.Altivec.Vector_Types} (@code{g-alvety.ads}) @@ -23718,7 +23537,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{315}@anchor{gnat_rm/the_gnat_library id33}@anchor{316} +@anchor{gnat_rm/the_gnat_library gnat-altivec-vector-views-g-alvevi-ads}@anchor{319}@anchor{gnat_rm/the_gnat_library id33}@anchor{31a} @section @code{GNAT.Altivec.Vector_Views} (@code{g-alvevi.ads}) @@ -23733,7 +23552,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{317}@anchor{gnat_rm/the_gnat_library id34}@anchor{318} +@anchor{gnat_rm/the_gnat_library gnat-array-split-g-arrspl-ads}@anchor{31b}@anchor{gnat_rm/the_gnat_library id34}@anchor{31c} @section @code{GNAT.Array_Split} (@code{g-arrspl.ads}) @@ -23746,7 +23565,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{319}@anchor{gnat_rm/the_gnat_library id35}@anchor{31a} +@anchor{gnat_rm/the_gnat_library gnat-awk-g-awk-ads}@anchor{31d}@anchor{gnat_rm/the_gnat_library id35}@anchor{31e} @section @code{GNAT.AWK} (@code{g-awk.ads}) @@ -23761,7 +23580,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{31b}@anchor{gnat_rm/the_gnat_library id36}@anchor{31c} +@anchor{gnat_rm/the_gnat_library gnat-binary-search-g-binsea-ads}@anchor{31f}@anchor{gnat_rm/the_gnat_library id36}@anchor{320} @section @code{GNAT.Binary_Search} (@code{g-binsea.ads}) @@ -23773,7 +23592,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{31d}@anchor{gnat_rm/the_gnat_library id37}@anchor{31e} +@anchor{gnat_rm/the_gnat_library gnat-bind-environment-g-binenv-ads}@anchor{321}@anchor{gnat_rm/the_gnat_library id37}@anchor{322} @section @code{GNAT.Bind_Environment} (@code{g-binenv.ads}) @@ -23786,7 +23605,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{31f}@anchor{gnat_rm/the_gnat_library id38}@anchor{320} +@anchor{gnat_rm/the_gnat_library gnat-branch-prediction-g-brapre-ads}@anchor{323}@anchor{gnat_rm/the_gnat_library id38}@anchor{324} @section @code{GNAT.Branch_Prediction} (@code{g-brapre.ads}) @@ -23797,7 +23616,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{321}@anchor{gnat_rm/the_gnat_library id39}@anchor{322} +@anchor{gnat_rm/the_gnat_library gnat-bounded-buffers-g-boubuf-ads}@anchor{325}@anchor{gnat_rm/the_gnat_library id39}@anchor{326} @section @code{GNAT.Bounded_Buffers} (@code{g-boubuf.ads}) @@ -23812,7 +23631,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{323}@anchor{gnat_rm/the_gnat_library id40}@anchor{324} +@anchor{gnat_rm/the_gnat_library gnat-bounded-mailboxes-g-boumai-ads}@anchor{327}@anchor{gnat_rm/the_gnat_library id40}@anchor{328} @section @code{GNAT.Bounded_Mailboxes} (@code{g-boumai.ads}) @@ -23825,7 +23644,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{325}@anchor{gnat_rm/the_gnat_library id41}@anchor{326} +@anchor{gnat_rm/the_gnat_library gnat-bubble-sort-g-bubsor-ads}@anchor{329}@anchor{gnat_rm/the_gnat_library id41}@anchor{32a} @section @code{GNAT.Bubble_Sort} (@code{g-bubsor.ads}) @@ -23840,7 +23659,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{327}@anchor{gnat_rm/the_gnat_library id42}@anchor{328} +@anchor{gnat_rm/the_gnat_library gnat-bubble-sort-a-g-busora-ads}@anchor{32b}@anchor{gnat_rm/the_gnat_library id42}@anchor{32c} @section @code{GNAT.Bubble_Sort_A} (@code{g-busora.ads}) @@ -23856,7 +23675,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{329}@anchor{gnat_rm/the_gnat_library id43}@anchor{32a} +@anchor{gnat_rm/the_gnat_library gnat-bubble-sort-g-g-busorg-ads}@anchor{32d}@anchor{gnat_rm/the_gnat_library id43}@anchor{32e} @section @code{GNAT.Bubble_Sort_G} (@code{g-busorg.ads}) @@ -23872,7 +23691,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{32b}@anchor{gnat_rm/the_gnat_library id44}@anchor{32c} +@anchor{gnat_rm/the_gnat_library gnat-byte-order-mark-g-byorma-ads}@anchor{32f}@anchor{gnat_rm/the_gnat_library id44}@anchor{330} @section @code{GNAT.Byte_Order_Mark} (@code{g-byorma.ads}) @@ -23888,7 +23707,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{32d}@anchor{gnat_rm/the_gnat_library id45}@anchor{32e} +@anchor{gnat_rm/the_gnat_library gnat-byte-swapping-g-bytswa-ads}@anchor{331}@anchor{gnat_rm/the_gnat_library id45}@anchor{332} @section @code{GNAT.Byte_Swapping} (@code{g-bytswa.ads}) @@ -23902,7 +23721,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{32f}@anchor{gnat_rm/the_gnat_library id46}@anchor{330} +@anchor{gnat_rm/the_gnat_library gnat-calendar-g-calend-ads}@anchor{333}@anchor{gnat_rm/the_gnat_library id46}@anchor{334} @section @code{GNAT.Calendar} (@code{g-calend.ads}) @@ -23916,7 +23735,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{331}@anchor{gnat_rm/the_gnat_library id47}@anchor{332} +@anchor{gnat_rm/the_gnat_library gnat-calendar-time-io-g-catiio-ads}@anchor{335}@anchor{gnat_rm/the_gnat_library id47}@anchor{336} @section @code{GNAT.Calendar.Time_IO} (@code{g-catiio.ads}) @@ -23927,7 +23746,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{333}@anchor{gnat_rm/the_gnat_library id48}@anchor{334} +@anchor{gnat_rm/the_gnat_library gnat-crc32-g-crc32-ads}@anchor{337}@anchor{gnat_rm/the_gnat_library id48}@anchor{338} @section @code{GNAT.CRC32} (@code{g-crc32.ads}) @@ -23944,7 +23763,7 @@ of this algorithm see Aug. 1988. Sarwate, D.V. @node GNAT Case_Util g-casuti ads,GNAT CGI g-cgi ads,GNAT CRC32 g-crc32 ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-case-util-g-casuti-ads}@anchor{335}@anchor{gnat_rm/the_gnat_library id49}@anchor{336} +@anchor{gnat_rm/the_gnat_library gnat-case-util-g-casuti-ads}@anchor{339}@anchor{gnat_rm/the_gnat_library id49}@anchor{33a} @section @code{GNAT.Case_Util} (@code{g-casuti.ads}) @@ -23959,7 +23778,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{337}@anchor{gnat_rm/the_gnat_library id50}@anchor{338} +@anchor{gnat_rm/the_gnat_library gnat-cgi-g-cgi-ads}@anchor{33b}@anchor{gnat_rm/the_gnat_library id50}@anchor{33c} @section @code{GNAT.CGI} (@code{g-cgi.ads}) @@ -23974,7 +23793,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{339}@anchor{gnat_rm/the_gnat_library id51}@anchor{33a} +@anchor{gnat_rm/the_gnat_library gnat-cgi-cookie-g-cgicoo-ads}@anchor{33d}@anchor{gnat_rm/the_gnat_library id51}@anchor{33e} @section @code{GNAT.CGI.Cookie} (@code{g-cgicoo.ads}) @@ -23989,7 +23808,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{33b}@anchor{gnat_rm/the_gnat_library id52}@anchor{33c} +@anchor{gnat_rm/the_gnat_library gnat-cgi-debug-g-cgideb-ads}@anchor{33f}@anchor{gnat_rm/the_gnat_library id52}@anchor{340} @section @code{GNAT.CGI.Debug} (@code{g-cgideb.ads}) @@ -24001,7 +23820,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{33d}@anchor{gnat_rm/the_gnat_library id53}@anchor{33e} +@anchor{gnat_rm/the_gnat_library gnat-command-line-g-comlin-ads}@anchor{341}@anchor{gnat_rm/the_gnat_library id53}@anchor{342} @section @code{GNAT.Command_Line} (@code{g-comlin.ads}) @@ -24014,7 +23833,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{33f}@anchor{gnat_rm/the_gnat_library id54}@anchor{340} +@anchor{gnat_rm/the_gnat_library gnat-compiler-version-g-comver-ads}@anchor{343}@anchor{gnat_rm/the_gnat_library id54}@anchor{344} @section @code{GNAT.Compiler_Version} (@code{g-comver.ads}) @@ -24032,7 +23851,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{341}@anchor{gnat_rm/the_gnat_library id55}@anchor{342} +@anchor{gnat_rm/the_gnat_library gnat-ctrl-c-g-ctrl-c-ads}@anchor{345}@anchor{gnat_rm/the_gnat_library id55}@anchor{346} @section @code{GNAT.Ctrl_C} (@code{g-ctrl_c.ads}) @@ -24043,7 +23862,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{343}@anchor{gnat_rm/the_gnat_library id56}@anchor{344} +@anchor{gnat_rm/the_gnat_library gnat-current-exception-g-curexc-ads}@anchor{347}@anchor{gnat_rm/the_gnat_library id56}@anchor{348} @section @code{GNAT.Current_Exception} (@code{g-curexc.ads}) @@ -24060,7 +23879,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{345}@anchor{gnat_rm/the_gnat_library id57}@anchor{346} +@anchor{gnat_rm/the_gnat_library gnat-debug-pools-g-debpoo-ads}@anchor{349}@anchor{gnat_rm/the_gnat_library id57}@anchor{34a} @section @code{GNAT.Debug_Pools} (@code{g-debpoo.ads}) @@ -24077,7 +23896,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{347}@anchor{gnat_rm/the_gnat_library id58}@anchor{348} +@anchor{gnat_rm/the_gnat_library gnat-debug-utilities-g-debuti-ads}@anchor{34b}@anchor{gnat_rm/the_gnat_library id58}@anchor{34c} @section @code{GNAT.Debug_Utilities} (@code{g-debuti.ads}) @@ -24090,7 +23909,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{349}@anchor{gnat_rm/the_gnat_library id59}@anchor{34a} +@anchor{gnat_rm/the_gnat_library gnat-decode-string-g-decstr-ads}@anchor{34d}@anchor{gnat_rm/the_gnat_library id59}@anchor{34e} @section @code{GNAT.Decode_String} (@code{g-decstr.ads}) @@ -24114,7 +23933,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{34b}@anchor{gnat_rm/the_gnat_library id60}@anchor{34c} +@anchor{gnat_rm/the_gnat_library gnat-decode-utf8-string-g-deutst-ads}@anchor{34f}@anchor{gnat_rm/the_gnat_library id60}@anchor{350} @section @code{GNAT.Decode_UTF8_String} (@code{g-deutst.ads}) @@ -24135,7 +23954,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{34d}@anchor{gnat_rm/the_gnat_library id61}@anchor{34e} +@anchor{gnat_rm/the_gnat_library gnat-directory-operations-g-dirope-ads}@anchor{351}@anchor{gnat_rm/the_gnat_library id61}@anchor{352} @section @code{GNAT.Directory_Operations} (@code{g-dirope.ads}) @@ -24148,7 +23967,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{34f}@anchor{gnat_rm/the_gnat_library id62}@anchor{350} +@anchor{gnat_rm/the_gnat_library gnat-directory-operations-iteration-g-diopit-ads}@anchor{353}@anchor{gnat_rm/the_gnat_library id62}@anchor{354} @section @code{GNAT.Directory_Operations.Iteration} (@code{g-diopit.ads}) @@ -24160,7 +23979,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{351}@anchor{gnat_rm/the_gnat_library id63}@anchor{352} +@anchor{gnat_rm/the_gnat_library gnat-dynamic-htables-g-dynhta-ads}@anchor{355}@anchor{gnat_rm/the_gnat_library id63}@anchor{356} @section @code{GNAT.Dynamic_HTables} (@code{g-dynhta.ads}) @@ -24178,7 +23997,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{353}@anchor{gnat_rm/the_gnat_library id64}@anchor{354} +@anchor{gnat_rm/the_gnat_library gnat-dynamic-tables-g-dyntab-ads}@anchor{357}@anchor{gnat_rm/the_gnat_library id64}@anchor{358} @section @code{GNAT.Dynamic_Tables} (@code{g-dyntab.ads}) @@ -24198,7 +24017,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{355}@anchor{gnat_rm/the_gnat_library id65}@anchor{356} +@anchor{gnat_rm/the_gnat_library gnat-encode-string-g-encstr-ads}@anchor{359}@anchor{gnat_rm/the_gnat_library id65}@anchor{35a} @section @code{GNAT.Encode_String} (@code{g-encstr.ads}) @@ -24220,7 +24039,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{357}@anchor{gnat_rm/the_gnat_library id66}@anchor{358} +@anchor{gnat_rm/the_gnat_library gnat-encode-utf8-string-g-enutst-ads}@anchor{35b}@anchor{gnat_rm/the_gnat_library id66}@anchor{35c} @section @code{GNAT.Encode_UTF8_String} (@code{g-enutst.ads}) @@ -24241,7 +24060,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{359}@anchor{gnat_rm/the_gnat_library id67}@anchor{35a} +@anchor{gnat_rm/the_gnat_library gnat-exception-actions-g-excact-ads}@anchor{35d}@anchor{gnat_rm/the_gnat_library id67}@anchor{35e} @section @code{GNAT.Exception_Actions} (@code{g-excact.ads}) @@ -24254,7 +24073,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{35b}@anchor{gnat_rm/the_gnat_library id68}@anchor{35c} +@anchor{gnat_rm/the_gnat_library gnat-exception-traces-g-exctra-ads}@anchor{35f}@anchor{gnat_rm/the_gnat_library id68}@anchor{360} @section @code{GNAT.Exception_Traces} (@code{g-exctra.ads}) @@ -24268,7 +24087,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{35d}@anchor{gnat_rm/the_gnat_library id69}@anchor{35e} +@anchor{gnat_rm/the_gnat_library gnat-exceptions-g-except-ads}@anchor{361}@anchor{gnat_rm/the_gnat_library id69}@anchor{362} @section @code{GNAT.Exceptions} (@code{g-except.ads}) @@ -24289,7 +24108,7 @@ predefined exceptions, and for example allows raising @code{Constraint_Error} with a message from a pure subprogram. @node GNAT Expect g-expect ads,GNAT Expect TTY g-exptty ads,GNAT Exceptions g-except ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-expect-g-expect-ads}@anchor{35f}@anchor{gnat_rm/the_gnat_library id70}@anchor{360} +@anchor{gnat_rm/the_gnat_library gnat-expect-g-expect-ads}@anchor{363}@anchor{gnat_rm/the_gnat_library id70}@anchor{364} @section @code{GNAT.Expect} (@code{g-expect.ads}) @@ -24305,7 +24124,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{361}@anchor{gnat_rm/the_gnat_library id71}@anchor{362} +@anchor{gnat_rm/the_gnat_library gnat-expect-tty-g-exptty-ads}@anchor{365}@anchor{gnat_rm/the_gnat_library id71}@anchor{366} @section @code{GNAT.Expect.TTY} (@code{g-exptty.ads}) @@ -24317,7 +24136,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{363}@anchor{gnat_rm/the_gnat_library id72}@anchor{364} +@anchor{gnat_rm/the_gnat_library gnat-float-control-g-flocon-ads}@anchor{367}@anchor{gnat_rm/the_gnat_library id72}@anchor{368} @section @code{GNAT.Float_Control} (@code{g-flocon.ads}) @@ -24331,7 +24150,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{365}@anchor{gnat_rm/the_gnat_library id73}@anchor{366} +@anchor{gnat_rm/the_gnat_library gnat-formatted-string-g-forstr-ads}@anchor{369}@anchor{gnat_rm/the_gnat_library id73}@anchor{36a} @section @code{GNAT.Formatted_String} (@code{g-forstr.ads}) @@ -24346,7 +24165,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{367}@anchor{gnat_rm/the_gnat_library id74}@anchor{368} +@anchor{gnat_rm/the_gnat_library gnat-generic-fast-math-functions-g-gfmafu-ads}@anchor{36b}@anchor{gnat_rm/the_gnat_library id74}@anchor{36c} @section @code{GNAT.Generic_Fast_Math_Functions} (@code{g-gfmafu.ads}) @@ -24364,7 +24183,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{369}@anchor{gnat_rm/the_gnat_library id75}@anchor{36a} +@anchor{gnat_rm/the_gnat_library gnat-heap-sort-g-heasor-ads}@anchor{36d}@anchor{gnat_rm/the_gnat_library id75}@anchor{36e} @section @code{GNAT.Heap_Sort} (@code{g-heasor.ads}) @@ -24378,7 +24197,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{36b}@anchor{gnat_rm/the_gnat_library id76}@anchor{36c} +@anchor{gnat_rm/the_gnat_library gnat-heap-sort-a-g-hesora-ads}@anchor{36f}@anchor{gnat_rm/the_gnat_library id76}@anchor{370} @section @code{GNAT.Heap_Sort_A} (@code{g-hesora.ads}) @@ -24394,7 +24213,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{36d}@anchor{gnat_rm/the_gnat_library id77}@anchor{36e} +@anchor{gnat_rm/the_gnat_library gnat-heap-sort-g-g-hesorg-ads}@anchor{371}@anchor{gnat_rm/the_gnat_library id77}@anchor{372} @section @code{GNAT.Heap_Sort_G} (@code{g-hesorg.ads}) @@ -24408,7 +24227,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{36f}@anchor{gnat_rm/the_gnat_library id78}@anchor{370} +@anchor{gnat_rm/the_gnat_library gnat-htable-g-htable-ads}@anchor{373}@anchor{gnat_rm/the_gnat_library id78}@anchor{374} @section @code{GNAT.HTable} (@code{g-htable.ads}) @@ -24421,7 +24240,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{371}@anchor{gnat_rm/the_gnat_library id79}@anchor{372} +@anchor{gnat_rm/the_gnat_library gnat-io-g-io-ads}@anchor{375}@anchor{gnat_rm/the_gnat_library id79}@anchor{376} @section @code{GNAT.IO} (@code{g-io.ads}) @@ -24437,7 +24256,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{373}@anchor{gnat_rm/the_gnat_library id80}@anchor{374} +@anchor{gnat_rm/the_gnat_library gnat-io-aux-g-io-aux-ads}@anchor{377}@anchor{gnat_rm/the_gnat_library id80}@anchor{378} @section @code{GNAT.IO_Aux} (@code{g-io_aux.ads}) @@ -24451,7 +24270,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{375}@anchor{gnat_rm/the_gnat_library id81}@anchor{376} +@anchor{gnat_rm/the_gnat_library gnat-lock-files-g-locfil-ads}@anchor{379}@anchor{gnat_rm/the_gnat_library id81}@anchor{37a} @section @code{GNAT.Lock_Files} (@code{g-locfil.ads}) @@ -24465,7 +24284,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{377}@anchor{gnat_rm/the_gnat_library id82}@anchor{378} +@anchor{gnat_rm/the_gnat_library gnat-mbbs-discrete-random-g-mbdira-ads}@anchor{37b}@anchor{gnat_rm/the_gnat_library id82}@anchor{37c} @section @code{GNAT.MBBS_Discrete_Random} (@code{g-mbdira.ads}) @@ -24477,7 +24296,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{379}@anchor{gnat_rm/the_gnat_library id83}@anchor{37a} +@anchor{gnat_rm/the_gnat_library gnat-mbbs-float-random-g-mbflra-ads}@anchor{37d}@anchor{gnat_rm/the_gnat_library id83}@anchor{37e} @section @code{GNAT.MBBS_Float_Random} (@code{g-mbflra.ads}) @@ -24489,7 +24308,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{37b}@anchor{gnat_rm/the_gnat_library id84}@anchor{37c} +@anchor{gnat_rm/the_gnat_library gnat-md5-g-md5-ads}@anchor{37f}@anchor{gnat_rm/the_gnat_library id84}@anchor{380} @section @code{GNAT.MD5} (@code{g-md5.ads}) @@ -24502,7 +24321,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{37d}@anchor{gnat_rm/the_gnat_library id85}@anchor{37e} +@anchor{gnat_rm/the_gnat_library gnat-memory-dump-g-memdum-ads}@anchor{381}@anchor{gnat_rm/the_gnat_library id85}@anchor{382} @section @code{GNAT.Memory_Dump} (@code{g-memdum.ads}) @@ -24515,7 +24334,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{37f}@anchor{gnat_rm/the_gnat_library id86}@anchor{380} +@anchor{gnat_rm/the_gnat_library gnat-most-recent-exception-g-moreex-ads}@anchor{383}@anchor{gnat_rm/the_gnat_library id86}@anchor{384} @section @code{GNAT.Most_Recent_Exception} (@code{g-moreex.ads}) @@ -24529,7 +24348,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{381}@anchor{gnat_rm/the_gnat_library id87}@anchor{382} +@anchor{gnat_rm/the_gnat_library gnat-os-lib-g-os-lib-ads}@anchor{385}@anchor{gnat_rm/the_gnat_library id87}@anchor{386} @section @code{GNAT.OS_Lib} (@code{g-os_lib.ads}) @@ -24545,7 +24364,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{383}@anchor{gnat_rm/the_gnat_library id88}@anchor{384} +@anchor{gnat_rm/the_gnat_library gnat-perfect-hash-generators-g-pehage-ads}@anchor{387}@anchor{gnat_rm/the_gnat_library id88}@anchor{388} @section @code{GNAT.Perfect_Hash_Generators} (@code{g-pehage.ads}) @@ -24563,7 +24382,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{385}@anchor{gnat_rm/the_gnat_library id89}@anchor{386} +@anchor{gnat_rm/the_gnat_library gnat-random-numbers-g-rannum-ads}@anchor{389}@anchor{gnat_rm/the_gnat_library id89}@anchor{38a} @section @code{GNAT.Random_Numbers} (@code{g-rannum.ads}) @@ -24575,7 +24394,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{25c}@anchor{gnat_rm/the_gnat_library id90}@anchor{387} +@anchor{gnat_rm/the_gnat_library gnat-regexp-g-regexp-ads}@anchor{260}@anchor{gnat_rm/the_gnat_library id90}@anchor{38b} @section @code{GNAT.Regexp} (@code{g-regexp.ads}) @@ -24591,7 +24410,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{388}@anchor{gnat_rm/the_gnat_library id91}@anchor{389} +@anchor{gnat_rm/the_gnat_library gnat-registry-g-regist-ads}@anchor{38c}@anchor{gnat_rm/the_gnat_library id91}@anchor{38d} @section @code{GNAT.Registry} (@code{g-regist.ads}) @@ -24605,7 +24424,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{38a}@anchor{gnat_rm/the_gnat_library id92}@anchor{38b} +@anchor{gnat_rm/the_gnat_library gnat-regpat-g-regpat-ads}@anchor{38e}@anchor{gnat_rm/the_gnat_library id92}@anchor{38f} @section @code{GNAT.Regpat} (@code{g-regpat.ads}) @@ -24620,7 +24439,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{38c}@anchor{gnat_rm/the_gnat_library id93}@anchor{38d} +@anchor{gnat_rm/the_gnat_library gnat-rewrite-data-g-rewdat-ads}@anchor{390}@anchor{gnat_rm/the_gnat_library id93}@anchor{391} @section @code{GNAT.Rewrite_Data} (@code{g-rewdat.ads}) @@ -24634,7 +24453,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{38e}@anchor{gnat_rm/the_gnat_library id94}@anchor{38f} +@anchor{gnat_rm/the_gnat_library gnat-secondary-stack-info-g-sestin-ads}@anchor{392}@anchor{gnat_rm/the_gnat_library id94}@anchor{393} @section @code{GNAT.Secondary_Stack_Info} (@code{g-sestin.ads}) @@ -24646,7 +24465,7 @@ Provides the capability to query the high water mark of the current task’s secondary stack. @node GNAT Semaphores g-semaph ads,GNAT Serial_Communications g-sercom ads,GNAT Secondary_Stack_Info g-sestin ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-semaphores-g-semaph-ads}@anchor{390}@anchor{gnat_rm/the_gnat_library id95}@anchor{391} +@anchor{gnat_rm/the_gnat_library gnat-semaphores-g-semaph-ads}@anchor{394}@anchor{gnat_rm/the_gnat_library id95}@anchor{395} @section @code{GNAT.Semaphores} (@code{g-semaph.ads}) @@ -24657,7 +24476,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{392}@anchor{gnat_rm/the_gnat_library id96}@anchor{393} +@anchor{gnat_rm/the_gnat_library gnat-serial-communications-g-sercom-ads}@anchor{396}@anchor{gnat_rm/the_gnat_library id96}@anchor{397} @section @code{GNAT.Serial_Communications} (@code{g-sercom.ads}) @@ -24669,7 +24488,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{394}@anchor{gnat_rm/the_gnat_library id97}@anchor{395} +@anchor{gnat_rm/the_gnat_library gnat-sha1-g-sha1-ads}@anchor{398}@anchor{gnat_rm/the_gnat_library id97}@anchor{399} @section @code{GNAT.SHA1} (@code{g-sha1.ads}) @@ -24682,7 +24501,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{396}@anchor{gnat_rm/the_gnat_library id98}@anchor{397} +@anchor{gnat_rm/the_gnat_library gnat-sha224-g-sha224-ads}@anchor{39a}@anchor{gnat_rm/the_gnat_library id98}@anchor{39b} @section @code{GNAT.SHA224} (@code{g-sha224.ads}) @@ -24695,7 +24514,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{398}@anchor{gnat_rm/the_gnat_library id99}@anchor{399} +@anchor{gnat_rm/the_gnat_library gnat-sha256-g-sha256-ads}@anchor{39c}@anchor{gnat_rm/the_gnat_library id99}@anchor{39d} @section @code{GNAT.SHA256} (@code{g-sha256.ads}) @@ -24708,7 +24527,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{39a}@anchor{gnat_rm/the_gnat_library id100}@anchor{39b} +@anchor{gnat_rm/the_gnat_library gnat-sha384-g-sha384-ads}@anchor{39e}@anchor{gnat_rm/the_gnat_library id100}@anchor{39f} @section @code{GNAT.SHA384} (@code{g-sha384.ads}) @@ -24721,7 +24540,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{39c}@anchor{gnat_rm/the_gnat_library id101}@anchor{39d} +@anchor{gnat_rm/the_gnat_library gnat-sha512-g-sha512-ads}@anchor{3a0}@anchor{gnat_rm/the_gnat_library id101}@anchor{3a1} @section @code{GNAT.SHA512} (@code{g-sha512.ads}) @@ -24734,7 +24553,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{39e}@anchor{gnat_rm/the_gnat_library id102}@anchor{39f} +@anchor{gnat_rm/the_gnat_library gnat-signals-g-signal-ads}@anchor{3a2}@anchor{gnat_rm/the_gnat_library id102}@anchor{3a3} @section @code{GNAT.Signals} (@code{g-signal.ads}) @@ -24746,7 +24565,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{3a0}@anchor{gnat_rm/the_gnat_library id103}@anchor{3a1} +@anchor{gnat_rm/the_gnat_library gnat-sockets-g-socket-ads}@anchor{3a4}@anchor{gnat_rm/the_gnat_library id103}@anchor{3a5} @section @code{GNAT.Sockets} (@code{g-socket.ads}) @@ -24761,7 +24580,7 @@ on all native GNAT ports and on VxWorks cross ports. It is not implemented for the LynxOS cross port. @node GNAT Source_Info g-souinf ads,GNAT Spelling_Checker g-speche ads,GNAT Sockets g-socket ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-source-info-g-souinf-ads}@anchor{3a2}@anchor{gnat_rm/the_gnat_library id104}@anchor{3a3} +@anchor{gnat_rm/the_gnat_library gnat-source-info-g-souinf-ads}@anchor{3a6}@anchor{gnat_rm/the_gnat_library id104}@anchor{3a7} @section @code{GNAT.Source_Info} (@code{g-souinf.ads}) @@ -24775,7 +24594,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{3a4}@anchor{gnat_rm/the_gnat_library id105}@anchor{3a5} +@anchor{gnat_rm/the_gnat_library gnat-spelling-checker-g-speche-ads}@anchor{3a8}@anchor{gnat_rm/the_gnat_library id105}@anchor{3a9} @section @code{GNAT.Spelling_Checker} (@code{g-speche.ads}) @@ -24787,7 +24606,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{3a6}@anchor{gnat_rm/the_gnat_library id106}@anchor{3a7} +@anchor{gnat_rm/the_gnat_library gnat-spelling-checker-generic-g-spchge-ads}@anchor{3aa}@anchor{gnat_rm/the_gnat_library id106}@anchor{3ab} @section @code{GNAT.Spelling_Checker_Generic} (@code{g-spchge.ads}) @@ -24800,7 +24619,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{3a8}@anchor{gnat_rm/the_gnat_library id107}@anchor{3a9} +@anchor{gnat_rm/the_gnat_library gnat-spitbol-patterns-g-spipat-ads}@anchor{3ac}@anchor{gnat_rm/the_gnat_library id107}@anchor{3ad} @section @code{GNAT.Spitbol.Patterns} (@code{g-spipat.ads}) @@ -24816,7 +24635,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{3aa}@anchor{gnat_rm/the_gnat_library id108}@anchor{3ab} +@anchor{gnat_rm/the_gnat_library gnat-spitbol-g-spitbo-ads}@anchor{3ae}@anchor{gnat_rm/the_gnat_library id108}@anchor{3af} @section @code{GNAT.Spitbol} (@code{g-spitbo.ads}) @@ -24831,7 +24650,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{3ac}@anchor{gnat_rm/the_gnat_library id109}@anchor{3ad} +@anchor{gnat_rm/the_gnat_library gnat-spitbol-table-boolean-g-sptabo-ads}@anchor{3b0}@anchor{gnat_rm/the_gnat_library id109}@anchor{3b1} @section @code{GNAT.Spitbol.Table_Boolean} (@code{g-sptabo.ads}) @@ -24846,7 +24665,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{3ae}@anchor{gnat_rm/the_gnat_library id110}@anchor{3af} +@anchor{gnat_rm/the_gnat_library gnat-spitbol-table-integer-g-sptain-ads}@anchor{3b2}@anchor{gnat_rm/the_gnat_library id110}@anchor{3b3} @section @code{GNAT.Spitbol.Table_Integer} (@code{g-sptain.ads}) @@ -24863,7 +24682,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{3b0}@anchor{gnat_rm/the_gnat_library id111}@anchor{3b1} +@anchor{gnat_rm/the_gnat_library gnat-spitbol-table-vstring-g-sptavs-ads}@anchor{3b4}@anchor{gnat_rm/the_gnat_library id111}@anchor{3b5} @section @code{GNAT.Spitbol.Table_VString} (@code{g-sptavs.ads}) @@ -24880,7 +24699,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{3b2}@anchor{gnat_rm/the_gnat_library id112}@anchor{3b3} +@anchor{gnat_rm/the_gnat_library gnat-sse-g-sse-ads}@anchor{3b6}@anchor{gnat_rm/the_gnat_library id112}@anchor{3b7} @section @code{GNAT.SSE} (@code{g-sse.ads}) @@ -24892,7 +24711,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{3b4}@anchor{gnat_rm/the_gnat_library id113}@anchor{3b5} +@anchor{gnat_rm/the_gnat_library gnat-sse-vector-types-g-ssvety-ads}@anchor{3b8}@anchor{gnat_rm/the_gnat_library id113}@anchor{3b9} @section @code{GNAT.SSE.Vector_Types} (@code{g-ssvety.ads}) @@ -24901,7 +24720,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{3b6}@anchor{gnat_rm/the_gnat_library id114}@anchor{3b7} +@anchor{gnat_rm/the_gnat_library gnat-string-hash-g-strhas-ads}@anchor{3ba}@anchor{gnat_rm/the_gnat_library id114}@anchor{3bb} @section @code{GNAT.String_Hash} (@code{g-strhas.ads}) @@ -24913,7 +24732,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{3b8}@anchor{gnat_rm/the_gnat_library id115}@anchor{3b9} +@anchor{gnat_rm/the_gnat_library gnat-strings-g-string-ads}@anchor{3bc}@anchor{gnat_rm/the_gnat_library id115}@anchor{3bd} @section @code{GNAT.Strings} (@code{g-string.ads}) @@ -24923,7 +24742,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{3ba}@anchor{gnat_rm/the_gnat_library id116}@anchor{3bb} +@anchor{gnat_rm/the_gnat_library gnat-string-split-g-strspl-ads}@anchor{3be}@anchor{gnat_rm/the_gnat_library id116}@anchor{3bf} @section @code{GNAT.String_Split} (@code{g-strspl.ads}) @@ -24937,7 +24756,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{3bc}@anchor{gnat_rm/the_gnat_library id117}@anchor{3bd} +@anchor{gnat_rm/the_gnat_library gnat-table-g-table-ads}@anchor{3c0}@anchor{gnat_rm/the_gnat_library id117}@anchor{3c1} @section @code{GNAT.Table} (@code{g-table.ads}) @@ -24957,7 +24776,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{3be}@anchor{gnat_rm/the_gnat_library id118}@anchor{3bf} +@anchor{gnat_rm/the_gnat_library gnat-task-lock-g-tasloc-ads}@anchor{3c2}@anchor{gnat_rm/the_gnat_library id118}@anchor{3c3} @section @code{GNAT.Task_Lock} (@code{g-tasloc.ads}) @@ -24974,7 +24793,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{3c0}@anchor{gnat_rm/the_gnat_library id119}@anchor{3c1} +@anchor{gnat_rm/the_gnat_library gnat-time-stamp-g-timsta-ads}@anchor{3c4}@anchor{gnat_rm/the_gnat_library id119}@anchor{3c5} @section @code{GNAT.Time_Stamp} (@code{g-timsta.ads}) @@ -24989,7 +24808,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{3c2}@anchor{gnat_rm/the_gnat_library id120}@anchor{3c3} +@anchor{gnat_rm/the_gnat_library gnat-threads-g-thread-ads}@anchor{3c6}@anchor{gnat_rm/the_gnat_library id120}@anchor{3c7} @section @code{GNAT.Threads} (@code{g-thread.ads}) @@ -25006,7 +24825,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{3c4}@anchor{gnat_rm/the_gnat_library id121}@anchor{3c5} +@anchor{gnat_rm/the_gnat_library gnat-traceback-g-traceb-ads}@anchor{3c8}@anchor{gnat_rm/the_gnat_library id121}@anchor{3c9} @section @code{GNAT.Traceback} (@code{g-traceb.ads}) @@ -25018,7 +24837,7 @@ Provides a facility for obtaining non-symbolic traceback information, useful in various debugging situations. @node GNAT Traceback Symbolic g-trasym ads,GNAT UTF_32 g-utf_32 ads,GNAT Traceback g-traceb ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-traceback-symbolic-g-trasym-ads}@anchor{3c6}@anchor{gnat_rm/the_gnat_library id122}@anchor{3c7} +@anchor{gnat_rm/the_gnat_library gnat-traceback-symbolic-g-trasym-ads}@anchor{3ca}@anchor{gnat_rm/the_gnat_library id122}@anchor{3cb} @section @code{GNAT.Traceback.Symbolic} (@code{g-trasym.ads}) @@ -25027,7 +24846,7 @@ in various debugging situations. @geindex Trace back facilities @node GNAT UTF_32 g-utf_32 ads,GNAT UTF_32_Spelling_Checker g-u3spch ads,GNAT Traceback Symbolic g-trasym ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-utf-32-g-utf-32-ads}@anchor{3c8}@anchor{gnat_rm/the_gnat_library id123}@anchor{3c9} +@anchor{gnat_rm/the_gnat_library gnat-utf-32-g-utf-32-ads}@anchor{3cc}@anchor{gnat_rm/the_gnat_library id123}@anchor{3cd} @section @code{GNAT.UTF_32} (@code{g-utf_32.ads}) @@ -25046,7 +24865,7 @@ lower case to upper case fold routine corresponding to the Ada 2005 rules for identifier equivalence. @node GNAT UTF_32_Spelling_Checker g-u3spch ads,GNAT Wide_Spelling_Checker g-wispch ads,GNAT UTF_32 g-utf_32 ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-utf-32-spelling-checker-g-u3spch-ads}@anchor{3ca}@anchor{gnat_rm/the_gnat_library id124}@anchor{3cb} +@anchor{gnat_rm/the_gnat_library gnat-utf-32-spelling-checker-g-u3spch-ads}@anchor{3ce}@anchor{gnat_rm/the_gnat_library id124}@anchor{3cf} @section @code{GNAT.UTF_32_Spelling_Checker} (@code{g-u3spch.ads}) @@ -25059,7 +24878,7 @@ near misspelling of another wide wide string, where the strings are represented using the UTF_32_String type defined in System.Wch_Cnv. @node GNAT Wide_Spelling_Checker g-wispch ads,GNAT Wide_String_Split g-wistsp ads,GNAT UTF_32_Spelling_Checker g-u3spch ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-wide-spelling-checker-g-wispch-ads}@anchor{3cc}@anchor{gnat_rm/the_gnat_library id125}@anchor{3cd} +@anchor{gnat_rm/the_gnat_library gnat-wide-spelling-checker-g-wispch-ads}@anchor{3d0}@anchor{gnat_rm/the_gnat_library id125}@anchor{3d1} @section @code{GNAT.Wide_Spelling_Checker} (@code{g-wispch.ads}) @@ -25071,7 +24890,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{3ce}@anchor{gnat_rm/the_gnat_library id126}@anchor{3cf} +@anchor{gnat_rm/the_gnat_library gnat-wide-string-split-g-wistsp-ads}@anchor{3d2}@anchor{gnat_rm/the_gnat_library id126}@anchor{3d3} @section @code{GNAT.Wide_String_Split} (@code{g-wistsp.ads}) @@ -25085,7 +24904,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{3d0}@anchor{gnat_rm/the_gnat_library id127}@anchor{3d1} +@anchor{gnat_rm/the_gnat_library gnat-wide-wide-spelling-checker-g-zspche-ads}@anchor{3d4}@anchor{gnat_rm/the_gnat_library id127}@anchor{3d5} @section @code{GNAT.Wide_Wide_Spelling_Checker} (@code{g-zspche.ads}) @@ -25097,7 +24916,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{3d2}@anchor{gnat_rm/the_gnat_library id128}@anchor{3d3} +@anchor{gnat_rm/the_gnat_library gnat-wide-wide-string-split-g-zistsp-ads}@anchor{3d6}@anchor{gnat_rm/the_gnat_library id128}@anchor{3d7} @section @code{GNAT.Wide_Wide_String_Split} (@code{g-zistsp.ads}) @@ -25111,7 +24930,7 @@ to the resulting slices. This package is instantiated from @code{GNAT.Array_Split}. @node Interfaces C Extensions i-cexten ads,Interfaces C Streams i-cstrea ads,GNAT Wide_Wide_String_Split g-zistsp ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id129}@anchor{3d4}@anchor{gnat_rm/the_gnat_library interfaces-c-extensions-i-cexten-ads}@anchor{3d5} +@anchor{gnat_rm/the_gnat_library id129}@anchor{3d8}@anchor{gnat_rm/the_gnat_library interfaces-c-extensions-i-cexten-ads}@anchor{3d9} @section @code{Interfaces.C.Extensions} (@code{i-cexten.ads}) @@ -25122,7 +24941,7 @@ for use with either manually or automatically generated bindings to C libraries. @node Interfaces C Streams i-cstrea ads,Interfaces Packed_Decimal i-pacdec ads,Interfaces C Extensions i-cexten ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id130}@anchor{3d6}@anchor{gnat_rm/the_gnat_library interfaces-c-streams-i-cstrea-ads}@anchor{3d7} +@anchor{gnat_rm/the_gnat_library id130}@anchor{3da}@anchor{gnat_rm/the_gnat_library interfaces-c-streams-i-cstrea-ads}@anchor{3db} @section @code{Interfaces.C.Streams} (@code{i-cstrea.ads}) @@ -25135,7 +24954,7 @@ This package is a binding for the most commonly used operations on C streams. @node Interfaces Packed_Decimal i-pacdec ads,Interfaces VxWorks i-vxwork ads,Interfaces C Streams i-cstrea ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id131}@anchor{3d8}@anchor{gnat_rm/the_gnat_library interfaces-packed-decimal-i-pacdec-ads}@anchor{3d9} +@anchor{gnat_rm/the_gnat_library id131}@anchor{3dc}@anchor{gnat_rm/the_gnat_library interfaces-packed-decimal-i-pacdec-ads}@anchor{3dd} @section @code{Interfaces.Packed_Decimal} (@code{i-pacdec.ads}) @@ -25150,7 +24969,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 id132}@anchor{3da}@anchor{gnat_rm/the_gnat_library interfaces-vxworks-i-vxwork-ads}@anchor{3db} +@anchor{gnat_rm/the_gnat_library id132}@anchor{3de}@anchor{gnat_rm/the_gnat_library interfaces-vxworks-i-vxwork-ads}@anchor{3df} @section @code{Interfaces.VxWorks} (@code{i-vxwork.ads}) @@ -25166,7 +24985,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 id133}@anchor{3dc}@anchor{gnat_rm/the_gnat_library interfaces-vxworks-int-connection-i-vxinco-ads}@anchor{3dd} +@anchor{gnat_rm/the_gnat_library id133}@anchor{3e0}@anchor{gnat_rm/the_gnat_library interfaces-vxworks-int-connection-i-vxinco-ads}@anchor{3e1} @section @code{Interfaces.VxWorks.Int_Connection} (@code{i-vxinco.ads}) @@ -25182,7 +25001,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 id134}@anchor{3de}@anchor{gnat_rm/the_gnat_library interfaces-vxworks-io-i-vxwoio-ads}@anchor{3df} +@anchor{gnat_rm/the_gnat_library id134}@anchor{3e2}@anchor{gnat_rm/the_gnat_library interfaces-vxworks-io-i-vxwoio-ads}@anchor{3e3} @section @code{Interfaces.VxWorks.IO} (@code{i-vxwoio.ads}) @@ -25205,7 +25024,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 id135}@anchor{3e0}@anchor{gnat_rm/the_gnat_library system-address-image-s-addima-ads}@anchor{3e1} +@anchor{gnat_rm/the_gnat_library id135}@anchor{3e4}@anchor{gnat_rm/the_gnat_library system-address-image-s-addima-ads}@anchor{3e5} @section @code{System.Address_Image} (@code{s-addima.ads}) @@ -25221,7 +25040,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 id136}@anchor{3e2}@anchor{gnat_rm/the_gnat_library system-assertions-s-assert-ads}@anchor{3e3} +@anchor{gnat_rm/the_gnat_library id136}@anchor{3e6}@anchor{gnat_rm/the_gnat_library system-assertions-s-assert-ads}@anchor{3e7} @section @code{System.Assertions} (@code{s-assert.ads}) @@ -25237,7 +25056,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 id137}@anchor{3e4}@anchor{gnat_rm/the_gnat_library system-atomic-counters-s-atocou-ads}@anchor{3e5} +@anchor{gnat_rm/the_gnat_library id137}@anchor{3e8}@anchor{gnat_rm/the_gnat_library system-atomic-counters-s-atocou-ads}@anchor{3e9} @section @code{System.Atomic_Counters} (@code{s-atocou.ads}) @@ -25251,7 +25070,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 id138}@anchor{3e6}@anchor{gnat_rm/the_gnat_library system-memory-s-memory-ads}@anchor{3e7} +@anchor{gnat_rm/the_gnat_library id138}@anchor{3ea}@anchor{gnat_rm/the_gnat_library system-memory-s-memory-ads}@anchor{3eb} @section @code{System.Memory} (@code{s-memory.ads}) @@ -25269,7 +25088,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 id139}@anchor{3e8}@anchor{gnat_rm/the_gnat_library system-multiprocessors-s-multip-ads}@anchor{3e9} +@anchor{gnat_rm/the_gnat_library id139}@anchor{3ec}@anchor{gnat_rm/the_gnat_library system-multiprocessors-s-multip-ads}@anchor{3ed} @section @code{System.Multiprocessors} (@code{s-multip.ads}) @@ -25282,7 +25101,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 id140}@anchor{3ea}@anchor{gnat_rm/the_gnat_library system-multiprocessors-dispatching-domains-s-mudido-ads}@anchor{3eb} +@anchor{gnat_rm/the_gnat_library id140}@anchor{3ee}@anchor{gnat_rm/the_gnat_library system-multiprocessors-dispatching-domains-s-mudido-ads}@anchor{3ef} @section @code{System.Multiprocessors.Dispatching_Domains} (@code{s-mudido.ads}) @@ -25295,7 +25114,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 id141}@anchor{3ec}@anchor{gnat_rm/the_gnat_library system-partition-interface-s-parint-ads}@anchor{3ed} +@anchor{gnat_rm/the_gnat_library id141}@anchor{3f0}@anchor{gnat_rm/the_gnat_library system-partition-interface-s-parint-ads}@anchor{3f1} @section @code{System.Partition_Interface} (@code{s-parint.ads}) @@ -25308,7 +25127,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 id142}@anchor{3ee}@anchor{gnat_rm/the_gnat_library system-pool-global-s-pooglo-ads}@anchor{3ef} +@anchor{gnat_rm/the_gnat_library id142}@anchor{3f2}@anchor{gnat_rm/the_gnat_library system-pool-global-s-pooglo-ads}@anchor{3f3} @section @code{System.Pool_Global} (@code{s-pooglo.ads}) @@ -25325,7 +25144,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 id143}@anchor{3f0}@anchor{gnat_rm/the_gnat_library system-pool-local-s-pooloc-ads}@anchor{3f1} +@anchor{gnat_rm/the_gnat_library id143}@anchor{3f4}@anchor{gnat_rm/the_gnat_library system-pool-local-s-pooloc-ads}@anchor{3f5} @section @code{System.Pool_Local} (@code{s-pooloc.ads}) @@ -25342,7 +25161,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 id144}@anchor{3f2}@anchor{gnat_rm/the_gnat_library system-restrictions-s-restri-ads}@anchor{3f3} +@anchor{gnat_rm/the_gnat_library id144}@anchor{3f6}@anchor{gnat_rm/the_gnat_library system-restrictions-s-restri-ads}@anchor{3f7} @section @code{System.Restrictions} (@code{s-restri.ads}) @@ -25358,7 +25177,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 id145}@anchor{3f4}@anchor{gnat_rm/the_gnat_library system-rident-s-rident-ads}@anchor{3f5} +@anchor{gnat_rm/the_gnat_library id145}@anchor{3f8}@anchor{gnat_rm/the_gnat_library system-rident-s-rident-ads}@anchor{3f9} @section @code{System.Rident} (@code{s-rident.ads}) @@ -25374,7 +25193,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 id146}@anchor{3f6}@anchor{gnat_rm/the_gnat_library system-strings-stream-ops-s-ststop-ads}@anchor{3f7} +@anchor{gnat_rm/the_gnat_library id146}@anchor{3fa}@anchor{gnat_rm/the_gnat_library system-strings-stream-ops-s-ststop-ads}@anchor{3fb} @section @code{System.Strings.Stream_Ops} (@code{s-ststop.ads}) @@ -25390,7 +25209,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 id147}@anchor{3f8}@anchor{gnat_rm/the_gnat_library system-unsigned-types-s-unstyp-ads}@anchor{3f9} +@anchor{gnat_rm/the_gnat_library id147}@anchor{3fc}@anchor{gnat_rm/the_gnat_library system-unsigned-types-s-unstyp-ads}@anchor{3fd} @section @code{System.Unsigned_Types} (@code{s-unstyp.ads}) @@ -25403,7 +25222,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 id148}@anchor{3fa}@anchor{gnat_rm/the_gnat_library system-wch-cnv-s-wchcnv-ads}@anchor{3fb} +@anchor{gnat_rm/the_gnat_library id148}@anchor{3fe}@anchor{gnat_rm/the_gnat_library system-wch-cnv-s-wchcnv-ads}@anchor{3ff} @section @code{System.Wch_Cnv} (@code{s-wchcnv.ads}) @@ -25424,7 +25243,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 id149}@anchor{3fc}@anchor{gnat_rm/the_gnat_library system-wch-con-s-wchcon-ads}@anchor{3fd} +@anchor{gnat_rm/the_gnat_library id149}@anchor{400}@anchor{gnat_rm/the_gnat_library system-wch-con-s-wchcon-ads}@anchor{401} @section @code{System.Wch_Con} (@code{s-wchcon.ads}) @@ -25436,7 +25255,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{3fe}@anchor{gnat_rm/interfacing_to_other_languages id1}@anchor{3ff}@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-other-languages}@anchor{11} +@anchor{gnat_rm/interfacing_to_other_languages doc}@anchor{402}@anchor{gnat_rm/interfacing_to_other_languages id1}@anchor{403}@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-other-languages}@anchor{11} @chapter Interfacing to Other Languages @@ -25454,7 +25273,7 @@ provided. @end menu @node Interfacing to C,Interfacing to C++,,Interfacing to Other Languages -@anchor{gnat_rm/interfacing_to_other_languages id2}@anchor{400}@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-c}@anchor{401} +@anchor{gnat_rm/interfacing_to_other_languages id2}@anchor{404}@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-c}@anchor{405} @section Interfacing to C @@ -25594,7 +25413,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{402} +@anchor{gnat_rm/interfacing_to_other_languages id3}@anchor{47}@anchor{gnat_rm/interfacing_to_other_languages id4}@anchor{406} @section Interfacing to C++ @@ -25651,7 +25470,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{403}@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-cobol}@anchor{404} +@anchor{gnat_rm/interfacing_to_other_languages id5}@anchor{407}@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-cobol}@anchor{408} @section Interfacing to COBOL @@ -25659,7 +25478,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{405}@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-fortran}@anchor{406} +@anchor{gnat_rm/interfacing_to_other_languages id6}@anchor{409}@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-fortran}@anchor{40a} @section Interfacing to Fortran @@ -25669,7 +25488,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{407}@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-non-gnat-ada-code}@anchor{408} +@anchor{gnat_rm/interfacing_to_other_languages id7}@anchor{40b}@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-non-gnat-ada-code}@anchor{40c} @section Interfacing to non-GNAT Ada code @@ -25693,7 +25512,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{409}@anchor{gnat_rm/specialized_needs_annexes id1}@anchor{40a}@anchor{gnat_rm/specialized_needs_annexes specialized-needs-annexes}@anchor{12} +@anchor{gnat_rm/specialized_needs_annexes doc}@anchor{40d}@anchor{gnat_rm/specialized_needs_annexes id1}@anchor{40e}@anchor{gnat_rm/specialized_needs_annexes specialized-needs-annexes}@anchor{12} @chapter Specialized Needs Annexes @@ -25734,7 +25553,7 @@ in Ada 2005) is fully implemented. @end table @node Implementation of Specific Ada Features,Implementation of Ada 2012 Features,Specialized Needs Annexes,Top -@anchor{gnat_rm/implementation_of_specific_ada_features doc}@anchor{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} +@anchor{gnat_rm/implementation_of_specific_ada_features doc}@anchor{40f}@anchor{gnat_rm/implementation_of_specific_ada_features id1}@anchor{410}@anchor{gnat_rm/implementation_of_specific_ada_features implementation-of-specific-ada-features}@anchor{13} @chapter Implementation of Specific Ada Features @@ -25753,7 +25572,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{40d}@anchor{gnat_rm/implementation_of_specific_ada_features machine-code-insertions}@anchor{166} +@anchor{gnat_rm/implementation_of_specific_ada_features id2}@anchor{411}@anchor{gnat_rm/implementation_of_specific_ada_features machine-code-insertions}@anchor{16a} @section Machine Code Insertions @@ -25921,7 +25740,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{40e}@anchor{gnat_rm/implementation_of_specific_ada_features id3}@anchor{40f} +@anchor{gnat_rm/implementation_of_specific_ada_features gnat-implementation-of-tasking}@anchor{412}@anchor{gnat_rm/implementation_of_specific_ada_features id3}@anchor{413} @section GNAT Implementation of Tasking @@ -25937,7 +25756,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{410}@anchor{gnat_rm/implementation_of_specific_ada_features mapping-ada-tasks-onto-the-underlying-kernel-threads}@anchor{411} +@anchor{gnat_rm/implementation_of_specific_ada_features id4}@anchor{414}@anchor{gnat_rm/implementation_of_specific_ada_features mapping-ada-tasks-onto-the-underlying-kernel-threads}@anchor{415} @subsection Mapping Ada Tasks onto the Underlying Kernel Threads @@ -26006,7 +25825,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{412}@anchor{gnat_rm/implementation_of_specific_ada_features id5}@anchor{413} +@anchor{gnat_rm/implementation_of_specific_ada_features ensuring-compliance-with-the-real-time-annex}@anchor{416}@anchor{gnat_rm/implementation_of_specific_ada_features id5}@anchor{417} @subsection Ensuring Compliance with the Real-Time Annex @@ -26057,7 +25876,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{414} +@anchor{gnat_rm/implementation_of_specific_ada_features support-for-locking-policies}@anchor{418} @subsection Support for Locking Policies @@ -26091,7 +25910,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{415}@anchor{gnat_rm/implementation_of_specific_ada_features id6}@anchor{416} +@anchor{gnat_rm/implementation_of_specific_ada_features gnat-implementation-of-shared-passive-packages}@anchor{419}@anchor{gnat_rm/implementation_of_specific_ada_features id6}@anchor{41a} @section GNAT Implementation of Shared Passive Packages @@ -26189,7 +26008,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{417}@anchor{gnat_rm/implementation_of_specific_ada_features id7}@anchor{418} +@anchor{gnat_rm/implementation_of_specific_ada_features code-generation-for-array-aggregates}@anchor{41b}@anchor{gnat_rm/implementation_of_specific_ada_features id7}@anchor{41c} @section Code Generation for Array Aggregates @@ -26220,7 +26039,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{419}@anchor{gnat_rm/implementation_of_specific_ada_features static-constant-aggregates-with-static-bounds}@anchor{41a} +@anchor{gnat_rm/implementation_of_specific_ada_features id8}@anchor{41d}@anchor{gnat_rm/implementation_of_specific_ada_features static-constant-aggregates-with-static-bounds}@anchor{41e} @subsection Static constant aggregates with static bounds @@ -26267,7 +26086,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{41b}@anchor{gnat_rm/implementation_of_specific_ada_features id9}@anchor{41c} +@anchor{gnat_rm/implementation_of_specific_ada_features constant-aggregates-with-unconstrained-nominal-types}@anchor{41f}@anchor{gnat_rm/implementation_of_specific_ada_features id9}@anchor{420} @subsection Constant aggregates with unconstrained nominal types @@ -26282,7 +26101,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{41d}@anchor{gnat_rm/implementation_of_specific_ada_features id10}@anchor{41e} +@anchor{gnat_rm/implementation_of_specific_ada_features aggregates-with-static-bounds}@anchor{421}@anchor{gnat_rm/implementation_of_specific_ada_features id10}@anchor{422} @subsection Aggregates with static bounds @@ -26310,7 +26129,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{41f}@anchor{gnat_rm/implementation_of_specific_ada_features id11}@anchor{420} +@anchor{gnat_rm/implementation_of_specific_ada_features aggregates-with-nonstatic-bounds}@anchor{423}@anchor{gnat_rm/implementation_of_specific_ada_features id11}@anchor{424} @subsection Aggregates with nonstatic bounds @@ -26321,7 +26140,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{421}@anchor{gnat_rm/implementation_of_specific_ada_features id12}@anchor{422} +@anchor{gnat_rm/implementation_of_specific_ada_features aggregates-in-assignment-statements}@anchor{425}@anchor{gnat_rm/implementation_of_specific_ada_features id12}@anchor{426} @subsection Aggregates in assignment statements @@ -26363,7 +26182,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{423}@anchor{gnat_rm/implementation_of_specific_ada_features the-size-of-discriminated-records-with-default-discriminants}@anchor{424} +@anchor{gnat_rm/implementation_of_specific_ada_features id13}@anchor{427}@anchor{gnat_rm/implementation_of_specific_ada_features the-size-of-discriminated-records-with-default-discriminants}@anchor{428} @section The Size of Discriminated Records with Default Discriminants @@ -26443,7 +26262,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{425}@anchor{gnat_rm/implementation_of_specific_ada_features image-values-for-nonscalar-types}@anchor{426} +@anchor{gnat_rm/implementation_of_specific_ada_features id14}@anchor{429}@anchor{gnat_rm/implementation_of_specific_ada_features image-values-for-nonscalar-types}@anchor{42a} @section Image Values For Nonscalar Types @@ -26463,7 +26282,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{427}@anchor{gnat_rm/implementation_of_specific_ada_features strict-conformance-to-the-ada-reference-manual}@anchor{428} +@anchor{gnat_rm/implementation_of_specific_ada_features id15}@anchor{42b}@anchor{gnat_rm/implementation_of_specific_ada_features strict-conformance-to-the-ada-reference-manual}@anchor{42c} @section Strict Conformance to the Ada Reference Manual @@ -26489,8 +26308,8 @@ machines that are not fully compliant with this standard, such as Alpha, the behavior (although at the cost of a significant performance penalty), so infinite and NaN values are properly generated. -@node Implementation of Ada 2012 Features,Security Hardening Features,Implementation of Specific Ada Features,Top -@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} +@node Implementation of Ada 2012 Features,GNAT language extensions,Implementation of Specific Ada Features,Top +@anchor{gnat_rm/implementation_of_ada_2012_features doc}@anchor{42d}@anchor{gnat_rm/implementation_of_ada_2012_features id1}@anchor{42e}@anchor{gnat_rm/implementation_of_ada_2012_features implementation-of-ada-2012-features}@anchor{14} @chapter Implementation of Ada 2012 Features @@ -28655,8 +28474,657 @@ where the type of the returned value is an anonymous access type. 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{42b}@anchor{gnat_rm/security_hardening_features id1}@anchor{42c}@anchor{gnat_rm/security_hardening_features security-hardening-features}@anchor{15} +@node GNAT language extensions,Security Hardening Features,Implementation of Ada 2012 Features,Top +@anchor{gnat_rm/gnat_language_extensions doc}@anchor{42f}@anchor{gnat_rm/gnat_language_extensions gnat-language-extensions}@anchor{430}@anchor{gnat_rm/gnat_language_extensions id1}@anchor{431} +@chapter GNAT language extensions + + +The GNAT compiler implements a certain number of language extensions on top of +the latest Ada standard, implementing its own extended superset of Ada. + +There are two sets of language extensions: + + +@itemize * + +@item +The first is the curated set. The features in that set are features that we +consider being worthy additions to the Ada language, and that we want to make +available to users early on. + +@item +The second is the experimental set. It includes the first, but also +experimental features, that are here because they’re still in an early +prototyping phase. +@end itemize + +@menu +* How to activate the extended GNAT Ada superset:: +* Curated Extensions:: +* Experimental Language Extensions:: + +@end menu + +@node How to activate the extended GNAT Ada superset,Curated Extensions,,GNAT language extensions +@anchor{gnat_rm/gnat_language_extensions how-to-activate-the-extended-gnat-ada-superset}@anchor{432} +@section How to activate the extended GNAT Ada superset + + +There are two ways to activate the extended GNAT Ada superset: + + +@itemize * + +@item +The @ref{65,,Pragma Extensions_Allowed}. To activate +the curated set of extensions, you should use +@end itemize + +@example +pragma Extensions_Allowed (On) +@end example + +As a configuration pragma, you can either put it at the beginning of a source +file, or in a @code{.adc} file corresponding to your project. + + +@itemize * + +@item +The @code{-gnatX} option, that you can pass to the compiler directly, will +activate the curated subset of extensions. +@end itemize + +@cartouche +@quotation Attention +You can activate the extended set of extensions by using either +the @code{-gnatX0} command line flag, or the pragma @code{Extensions_Allowed} with +@code{All} as an argument. However, it is not recommended you use this subset +for serious projects, and is only means as a playground/technology preview. +@end quotation +@end cartouche + +@node Curated Extensions,Experimental Language Extensions,How to activate the extended GNAT Ada superset,GNAT language extensions +@anchor{gnat_rm/gnat_language_extensions curated-extensions}@anchor{433}@anchor{gnat_rm/gnat_language_extensions curated-language-extensions}@anchor{66} +@section Curated Extensions + + +@menu +* Conditional when constructs:: +* Case pattern matching:: +* Fixed lower bounds for array types and subtypes:: +* Prefixed-view notation for calls to primitive subprograms of untagged types:: +* Expression defaults for generic formal functions:: +* String interpolation:: +* Constrained attribute for generic objects:: +* Static aspect on intrinsic functions:: + +@end menu + +@node Conditional when constructs,Case pattern matching,,Curated Extensions +@anchor{gnat_rm/gnat_language_extensions conditional-when-constructs}@anchor{434} +@subsection Conditional when constructs + + +This feature extends the use of @code{when} as a way to condition a control-flow +related statement, to all control-flow related statements. + +To do a conditional return in a procedure the following syntax should be used: + +@example +procedure P (Condition : Boolean) is +begin + return when Condition; +end; +@end example + +This will return from the procedure if @code{Condition} is true. + +When being used in a function the conditional part comes after the return value: + +@example +function Is_Null (I : Integer) return Boolean is +begin + return True when I = 0; + return False; +end; +@end example + +In a similar way to the @code{exit when} a @code{goto ... when} can be employed: + +@example +procedure Low_Level_Optimized is + Flags : Bitmapping; +begin + Do_1 (Flags); + goto Cleanup when Flags (1); + + Do_2 (Flags); + goto Cleanup when Flags (32); + + -- ... + +<<Cleanup>> + -- ... +end; +@end example + +@c code-block + +To use a conditional raise construct: + +@example +procedure Foo is +begin + raise Error when Imported_C_Func /= 0; +end; +@end example + +An exception message can also be added: + +@example +procedure Foo is +begin + raise Error with "Unix Error" + when Imported_C_Func /= 0; +end; +@end example + +Link to the original RFC: +@indicateurl{https://github.com/AdaCore/ada-spark-rfcs/blob/master/prototyped/rfc-conditional-when-constructs.rst} + +@node Case pattern matching,Fixed lower bounds for array types and subtypes,Conditional when constructs,Curated Extensions +@anchor{gnat_rm/gnat_language_extensions case-pattern-matching}@anchor{435} +@subsection Case pattern matching + + +The selector for a case statement (but not yet for a case expression) may be of a composite type, subject to +some restrictions (described below). Aggregate syntax is used for choices +of such a case statement; however, in cases where a “normal” aggregate would +require a discrete value, a discrete subtype may be used instead; box +notation can also be used to match all values. + +Consider this example: + +@example +type Rec is record + F1, F2 : Integer; +end record; + +procedure Caser_1 (X : Rec) is +begin + case X is + when (F1 => Positive, F2 => Positive) => + Do_This; + when (F1 => Natural, F2 => <>) | (F1 => <>, F2 => Natural) => + Do_That; + when others => + Do_The_Other_Thing; + end case; +end Caser_1; +@end example + +If @code{Caser_1} is called and both components of X are positive, then +@code{Do_This} will be called; otherwise, if either component is nonnegative +then @code{Do_That} will be called; otherwise, @code{Do_The_Other_Thing} will be +called. + +In addition, pattern bindings are supported. This is a mechanism +for binding a name to a component of a matching value for use within +an alternative of a case statement. For a component association +that occurs within a case choice, the expression may be followed by +@code{is <identifier>}. In the special case of a “box” component association, +the identifier may instead be provided within the box. Either of these +indicates that the given identifier denotes (a constant view of) the matching +subcomponent of the case selector. + +@cartouche +@quotation Attention +Binding is not yet supported for arrays or subcomponents +thereof. +@end quotation +@end cartouche + +Consider this example (which uses type @code{Rec} from the previous example): + +@example +procedure Caser_2 (X : Rec) is +begin + case X is + when (F1 => Positive is Abc, F2 => Positive) => + Do_This (Abc) + when (F1 => Natural is N1, F2 => <N2>) | + (F1 => <N2>, F2 => Natural is N1) => + Do_That (Param_1 => N1, Param_2 => N2); + when others => + Do_The_Other_Thing; + end case; +end Caser_2; +@end example + +This example is the same as the previous one with respect to determining +whether @code{Do_This}, @code{Do_That}, or @code{Do_The_Other_Thing} will be called. But +for this version, @code{Do_This} takes a parameter and @code{Do_That} takes two +parameters. If @code{Do_This} is called, the actual parameter in the call will be +@code{X.F1}. + +If @code{Do_That} is called, the situation is more complex because there are two +choices for that alternative. If @code{Do_That} is called because the first choice +matched (i.e., because @code{X.F1} is nonnegative and either @code{X.F1} or @code{X.F2} +is zero or negative), then the actual parameters of the call will be (in order) +@code{X.F1} and @code{X.F2}. If @code{Do_That} is called because the second choice +matched (and the first one did not), then the actual parameters will be +reversed. + +Within the choice list for single alternative, each choice must define the same +set of bindings and the component subtypes for for a given identifer must all +statically match. Currently, the case of a binding for a nondiscrete component +is not implemented. + +If the set of values that match the choice(s) of an earlier alternative +overlaps the corresponding set of a later alternative, then the first set shall +be a proper subset of the second (and the later alternative will not be +executed if the earlier alternative “matches”). All possible values of the +composite type shall be covered. The composite type of the selector shall be an +array or record type that is neither limited nor 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 choice expression +is a “box” component association (which matches all possible values for the +subcomponent). This restriction applies if: + + +@itemize - + +@item +the component subtype is not a record, array, or discrete type; or + +@item +the component subtype is subject to a non-static constraint or has a +predicate; or: + +@item +the component type is an enumeration type that is subject to an enumeration +representation clause; or + +@item +the component type is a multidimensional array type or an array type with a +nonstatic index subtype. +@end itemize + +Support for casing on arrays (and on records that contain arrays) is +currently subject to some restrictions. Non-positional +array aggregates are not supported as (or within) case choices. Likewise +for array type and subtype names. The current implementation exceeds +compile-time capacity limits in some annoyingly common scenarios; the +message generated in such cases is usually “Capacity exceeded in compiling +case statement with composite selector type”. + +Link to the original RFC: +@indicateurl{https://github.com/AdaCore/ada-spark-rfcs/blob/master/prototyped/rfc-pattern-matching.rst} + +@node Fixed lower bounds for array types and subtypes,Prefixed-view notation for calls to primitive subprograms of untagged types,Case pattern matching,Curated Extensions +@anchor{gnat_rm/gnat_language_extensions fixed-lower-bounds-for-array-types-and-subtypes}@anchor{436} +@subsection Fixed lower bounds for array types and subtypes + + +Unconstrained array types and subtypes can be specified with a lower bound that +is fixed to a certain value, by writing an index range that uses the syntax +@code{<lower-bound-expression> .. <>}. This guarantees that all objects of the +type or subtype will have the specified lower bound. + +For example, a matrix type with fixed lower bounds of zero for each dimension +can be declared by the following: + +@example +type Matrix is + array (Natural range 0 .. <>, Natural range 0 .. <>) of Integer; +@end example + +Objects of type @code{Matrix} declared with an index constraint must have index +ranges starting at zero: + +@example +M1 : Matrix (0 .. 9, 0 .. 19); +M2 : Matrix (2 .. 11, 3 .. 22); -- Warning about bounds; will raise CE +@end example + +Similarly, a subtype of @code{String} can be declared that specifies the lower +bound of objects of that subtype to be @code{1}: + +@quotation + +@example +subtype String_1 is String (1 .. <>); +@end example +@end quotation + +If a string slice is passed to a formal of subtype @code{String_1} in a call to a +subprogram @code{S}, the slice’s bounds will “slide” so that the lower bound is +@code{1}. + +Within @code{S}, the lower bound of the formal is known to be @code{1}, so, unlike a +normal unconstrained @code{String} formal, there is no need to worry about +accounting for other possible lower-bound values. Sliding of bounds also occurs +in other contexts, such as for object declarations with an unconstrained +subtype with fixed lower bound, as well as in subtype conversions. + +Use of this feature increases safety by simplifying code, and can also improve +the efficiency of indexing operations, since the compiler statically knows the +lower bound of unconstrained array formals when the formal’s subtype has index +ranges with static fixed lower bounds. + +Link to the original RFC: +@indicateurl{https://github.com/AdaCore/ada-spark-rfcs/blob/master/prototyped/rfc-fixed-lower-bound.rst} + +@node Prefixed-view notation for calls to primitive subprograms of untagged types,Expression defaults for generic formal functions,Fixed lower bounds for array types and subtypes,Curated Extensions +@anchor{gnat_rm/gnat_language_extensions prefixed-view-notation-for-calls-to-primitive-subprograms-of-untagged-types}@anchor{437} +@subsection Prefixed-view notation for calls to primitive subprograms of untagged types + + +When operating on an untagged type, if it has any primitive operations, and the +first parameter of an operation is of the type (or is an access parameter with +an anonymous type that designates the type), you may invoke these operations +using an @code{object.op(...)} notation, where the parameter that would normally be +the first parameter is brought out front, and the remaining parameters (if any) +appear within parentheses after the name of the primitive operation. + +This same notation is already available for tagged types. This extension allows +for untagged types. It is allowed for all primitive operations of the type +independent of whether they were originally declared in a package spec or its +private part, or were inherited and/or overridden as part of a derived type +declaration occuring anywhere, so long as the first parameter is of the type, +or an access parameter designating the type. + +For example: + +@example +generic + type Elem_Type is private; +package Vectors is + type Vector is private; + procedure Add_Element (V : in out Vector; Elem : Elem_Type); + function Nth_Element (V : Vector; N : Positive) return Elem_Type; + function Length (V : Vector) return Natural; +private + function Capacity (V : Vector) return Natural; + -- Return number of elements that may be added without causing + -- any new allocation of space + + type Vector is ... + with Type_Invariant => Vector.Length <= Vector.Capacity; + ... +end Vectors; + +package Int_Vecs is new Vectors(Integer); + +V : Int_Vecs.Vector; +... +V.Add_Element(42); +V.Add_Element(-33); + +pragma Assert (V.Length = 2); +pragma Assert (V.Nth_Element(1) = 42); +@end example + +Link to the original RFC: +@indicateurl{https://github.com/AdaCore/ada-spark-rfcs/blob/master/prototyped/rfc-prefixed-untagged.rst} + +@node Expression defaults for generic formal functions,String interpolation,Prefixed-view notation for calls to primitive subprograms of untagged types,Curated Extensions +@anchor{gnat_rm/gnat_language_extensions expression-defaults-for-generic-formal-functions}@anchor{438} +@subsection Expression defaults for generic formal functions + + +The declaration of a generic formal function is allowed to specify +an expression as a default, using the syntax of an expression function. + +Here is an example of this feature: + +@example +generic + type T is private; + with function Copy (Item : T) return T is (Item); -- Defaults to Item +package Stacks is + + type Stack is limited private; + + procedure Push (S : in out Stack; X : T); -- Calls Copy on X + function Pop (S : in out Stack) return T; -- Calls Copy to return item + +private + -- ... +end Stacks; +@end example + +Link to the original RFC: +@indicateurl{https://github.com/AdaCore/ada-spark-rfcs/blob/master/prototyped/rfc-expression-functions-as-default-for-generic-formal-function-parameters.rst} + +@node String interpolation,Constrained attribute for generic objects,Expression defaults for generic formal functions,Curated Extensions +@anchor{gnat_rm/gnat_language_extensions string-interpolation}@anchor{439} +@subsection String interpolation + + +The syntax for string literals is extended to support string interpolation. + +Within an interpolated string literal, an arbitrary expression, when +enclosed in @code{@{ ... @}}, is expanded at run time into the result of calling +@code{'Image} on the result of evaluating the expression enclosed by the brace +characters, unless it is already a string or a single character. + +Here is an example of this feature where the expressions @code{Name} and @code{X + Y} +will be evaluated and included in the string. + +@example +procedure Test_Interpolation is + X : Integer := 12; + Y : Integer := 15; + Name : String := "Leo"; +begin + Put_Line (f"The name is @{Name@} and the sum is @{X + Y@}."); +end Test_Interpolation; +@end example + +In addition, an escape character (@code{\}) is provided for inserting certain +standard control characters (such as @code{\t} for tabulation or @code{\n} for +newline) or to escape characters with special significance to the +interpolated string syntax, namely @code{"}, @code{@{}, @code{@}},and @code{\} itself. + + +@multitable {xxxxxxxxxxxxxxxxxxx} {xxxxxxxxxxxxxxxxxxxxxx} +@item + +escaped_character + +@tab + +meaning + +@item + +@code{\a} + +@tab + +ALERT + +@item + +@code{\b} + +@tab + +BACKSPACE + +@item + +@code{\f} + +@tab + +FORM FEED + +@item + +@code{\n} + +@tab + +LINE FEED + +@item + +@code{\r} + +@tab + +CARRIAGE RETURN + +@item + +@code{\t} + +@tab + +CHARACTER TABULATION + +@item + +@code{\v} + +@tab + +LINE TABULATION + +@item + +@code{\0} + +@tab + +NUL + +@item + +@code{\\} + +@tab + +@code{\} + +@item + +@code{\"} + +@tab + +@code{"} + +@item + +@code{\@{} + +@tab + +@code{@{} + +@item + +@code{\@}} + +@tab + +@code{@}} + +@end multitable + + +Note that, unlike normal string literals, doubled characters have no +special significance. So to include a double-quote or a brace character +in an interpolated string, they must be preceded by a @code{\}. +For example: + +@example +Put_Line + (f"X = @{X@} and Y = @{Y@} and X+Y = @{X+Y@};\n" & + f" a double quote is \" and" & + f" an open brace is \@{"); +@end example + +Finally, a syntax is provided for creating multi-line string literals, +without having to explicitly use an escape sequence such as @code{\n}. For +example: + +@example +Put_Line + (f"This is a multi-line" + "string literal" + "There is no ambiguity about how many" + "spaces are included in each line"); +@end example + +Here is a link to the original RFC : +@indicateurl{https://github.com/AdaCore/ada-spark-rfcs/blob/master/prototyped/rfc-string-interpolation.rst} + +@node Constrained attribute for generic objects,Static aspect on intrinsic functions,String interpolation,Curated Extensions +@anchor{gnat_rm/gnat_language_extensions constrained-attribute-for-generic-objects}@anchor{43a} +@subsection Constrained attribute for generic objects + + +The @code{Constrained} attribute is permitted for objects of generic types. The +result indicates whether the corresponding actual is constrained. + +@node Static aspect on intrinsic functions,,Constrained attribute for generic objects,Curated Extensions +@anchor{gnat_rm/gnat_language_extensions static-aspect-on-intrinsic-functions}@anchor{43b} +@subsection @code{Static} aspect on intrinsic functions + + +The Ada 202x @code{Static} aspect can be specified on Intrinsic imported functions +and the compiler will evaluate some of these intrinsics statically, in +particular the @code{Shift_Left} and @code{Shift_Right} intrinsics. + +@node Experimental Language Extensions,,Curated Extensions,GNAT language extensions +@anchor{gnat_rm/gnat_language_extensions experimental-language-extensions}@anchor{67}@anchor{gnat_rm/gnat_language_extensions id2}@anchor{43c} +@section Experimental Language Extensions + + +@menu +* Pragma Storage_Model:: +* Simpler accessibility model:: + +@end menu + +@node Pragma Storage_Model,Simpler accessibility model,,Experimental Language Extensions +@anchor{gnat_rm/gnat_language_extensions pragma-storage-model}@anchor{43d} +@subsection Pragma Storage_Model + + +This feature proposes to redesign the concepts of Storage Pools into a more +efficient model allowing higher performances and easier integration with low +footprint embedded run-times. + +It also extends it to support distributed memory models, in particular to +support interactions with GPU. + +Here is a link to the full RFC: +@indicateurl{https://github.com/AdaCore/ada-spark-rfcs/blob/master/prototyped/rfc-storage-model.rst} + +@node Simpler accessibility model,,Pragma Storage_Model,Experimental Language Extensions +@anchor{gnat_rm/gnat_language_extensions simpler-accessibility-model}@anchor{43e} +@subsection Simpler accessibility model + + +The goal of this feature is to restore a common understanding of accessibility +rules for implementers and users alike. The new rules should both be effective +at preventing errors and feel natural and compatible in an Ada environment +while removing dynamic accessibility checking. + +Here is a link to the full RFC: +@indicateurl{https://github.com/AdaCore/ada-spark-rfcs/blob/master/prototyped/rfc-simpler-accessibility.md} + +@node Security Hardening Features,Obsolescent Features,GNAT language extensions,Top +@anchor{gnat_rm/security_hardening_features doc}@anchor{43f}@anchor{gnat_rm/security_hardening_features id1}@anchor{440}@anchor{gnat_rm/security_hardening_features security-hardening-features}@anchor{15} @chapter Security Hardening Features @@ -28678,7 +29146,7 @@ change. @end menu @node Register Scrubbing,Stack Scrubbing,,Security Hardening Features -@anchor{gnat_rm/security_hardening_features register-scrubbing}@anchor{42d} +@anchor{gnat_rm/security_hardening_features register-scrubbing}@anchor{441} @section Register Scrubbing @@ -28708,7 +29176,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{42e} +@anchor{gnat_rm/security_hardening_features stack-scrubbing}@anchor{442} @section Stack Scrubbing @@ -28852,7 +29320,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{42f} +@anchor{gnat_rm/security_hardening_features hardened-conditionals}@anchor{443} @section Hardened Conditionals @@ -28942,7 +29410,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{430} +@anchor{gnat_rm/security_hardening_features hardened-booleans}@anchor{444} @section Hardened Booleans @@ -29003,7 +29471,7 @@ and more details on that attribute, see @cite{Using the GNU Compiler Collection @c Control Flow Redundancy: @node Control Flow Redundancy,,Hardened Booleans,Security Hardening Features -@anchor{gnat_rm/security_hardening_features control-flow-redundancy}@anchor{431} +@anchor{gnat_rm/security_hardening_features control-flow-redundancy}@anchor{445} @section Control Flow Redundancy @@ -29163,7 +29631,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{432}@anchor{gnat_rm/obsolescent_features id1}@anchor{433}@anchor{gnat_rm/obsolescent_features obsolescent-features}@anchor{16} +@anchor{gnat_rm/obsolescent_features doc}@anchor{446}@anchor{gnat_rm/obsolescent_features id1}@anchor{447}@anchor{gnat_rm/obsolescent_features obsolescent-features}@anchor{16} @chapter Obsolescent Features @@ -29182,7 +29650,7 @@ compatibility purposes. @end menu @node pragma No_Run_Time,pragma Ravenscar,,Obsolescent Features -@anchor{gnat_rm/obsolescent_features id2}@anchor{434}@anchor{gnat_rm/obsolescent_features pragma-no-run-time}@anchor{435} +@anchor{gnat_rm/obsolescent_features id2}@anchor{448}@anchor{gnat_rm/obsolescent_features pragma-no-run-time}@anchor{449} @section pragma No_Run_Time @@ -29195,7 +29663,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{436}@anchor{gnat_rm/obsolescent_features pragma-ravenscar}@anchor{437} +@anchor{gnat_rm/obsolescent_features id3}@anchor{44a}@anchor{gnat_rm/obsolescent_features pragma-ravenscar}@anchor{44b} @section pragma Ravenscar @@ -29204,7 +29672,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{438}@anchor{gnat_rm/obsolescent_features pragma-restricted-run-time}@anchor{439} +@anchor{gnat_rm/obsolescent_features id4}@anchor{44c}@anchor{gnat_rm/obsolescent_features pragma-restricted-run-time}@anchor{44d} @section pragma Restricted_Run_Time @@ -29214,7 +29682,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{43a}@anchor{gnat_rm/obsolescent_features pragma-task-info}@anchor{43b} +@anchor{gnat_rm/obsolescent_features id5}@anchor{44e}@anchor{gnat_rm/obsolescent_features pragma-task-info}@anchor{44f} @section pragma Task_Info @@ -29240,7 +29708,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{43c}@anchor{gnat_rm/obsolescent_features package-system-task-info-s-tasinf-ads}@anchor{43d} +@anchor{gnat_rm/obsolescent_features package-system-task-info}@anchor{450}@anchor{gnat_rm/obsolescent_features package-system-task-info-s-tasinf-ads}@anchor{451} @section package System.Task_Info (@code{s-tasinf.ads}) @@ -29250,7 +29718,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{43e}@anchor{gnat_rm/compatibility_and_porting_guide compatibility-and-porting-guide}@anchor{17}@anchor{gnat_rm/compatibility_and_porting_guide id1}@anchor{43f} +@anchor{gnat_rm/compatibility_and_porting_guide doc}@anchor{452}@anchor{gnat_rm/compatibility_and_porting_guide compatibility-and-porting-guide}@anchor{17}@anchor{gnat_rm/compatibility_and_porting_guide id1}@anchor{453} @chapter Compatibility and Porting Guide @@ -29272,7 +29740,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{440}@anchor{gnat_rm/compatibility_and_porting_guide writing-portable-fixed-point-declarations}@anchor{441} +@anchor{gnat_rm/compatibility_and_porting_guide id2}@anchor{454}@anchor{gnat_rm/compatibility_and_porting_guide writing-portable-fixed-point-declarations}@anchor{455} @section Writing Portable Fixed-Point Declarations @@ -29394,7 +29862,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{442}@anchor{gnat_rm/compatibility_and_porting_guide id3}@anchor{443} +@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-ada-83}@anchor{456}@anchor{gnat_rm/compatibility_and_porting_guide id3}@anchor{457} @section Compatibility with Ada 83 @@ -29422,7 +29890,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{444}@anchor{gnat_rm/compatibility_and_porting_guide legal-ada-83-programs-that-are-illegal-in-ada-95}@anchor{445} +@anchor{gnat_rm/compatibility_and_porting_guide id4}@anchor{458}@anchor{gnat_rm/compatibility_and_porting_guide legal-ada-83-programs-that-are-illegal-in-ada-95}@anchor{459} @subsection Legal Ada 83 programs that are illegal in Ada 95 @@ -29522,7 +29990,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{446}@anchor{gnat_rm/compatibility_and_porting_guide more-deterministic-semantics}@anchor{447} +@anchor{gnat_rm/compatibility_and_porting_guide id5}@anchor{45a}@anchor{gnat_rm/compatibility_and_porting_guide more-deterministic-semantics}@anchor{45b} @subsection More deterministic semantics @@ -29550,7 +30018,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{448}@anchor{gnat_rm/compatibility_and_porting_guide id6}@anchor{449} +@anchor{gnat_rm/compatibility_and_porting_guide changed-semantics}@anchor{45c}@anchor{gnat_rm/compatibility_and_porting_guide id6}@anchor{45d} @subsection Changed semantics @@ -29592,7 +30060,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{44a}@anchor{gnat_rm/compatibility_and_porting_guide other-language-compatibility-issues}@anchor{44b} +@anchor{gnat_rm/compatibility_and_porting_guide id7}@anchor{45e}@anchor{gnat_rm/compatibility_and_porting_guide other-language-compatibility-issues}@anchor{45f} @subsection Other language compatibility issues @@ -29625,7 +30093,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{44c}@anchor{gnat_rm/compatibility_and_porting_guide id8}@anchor{44d} +@anchor{gnat_rm/compatibility_and_porting_guide compatibility-between-ada-95-and-ada-2005}@anchor{460}@anchor{gnat_rm/compatibility_and_porting_guide id8}@anchor{461} @section Compatibility between Ada 95 and Ada 2005 @@ -29697,7 +30165,7 @@ can declare a function returning a value from an anonymous access type. @end itemize @node Implementation-dependent characteristics,Compatibility with Other Ada Systems,Compatibility between Ada 95 and Ada 2005,Compatibility and Porting Guide -@anchor{gnat_rm/compatibility_and_porting_guide id9}@anchor{44e}@anchor{gnat_rm/compatibility_and_porting_guide implementation-dependent-characteristics}@anchor{44f} +@anchor{gnat_rm/compatibility_and_porting_guide id9}@anchor{462}@anchor{gnat_rm/compatibility_and_porting_guide implementation-dependent-characteristics}@anchor{463} @section Implementation-dependent characteristics @@ -29720,7 +30188,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{450}@anchor{gnat_rm/compatibility_and_porting_guide implementation-defined-pragmas}@anchor{451} +@anchor{gnat_rm/compatibility_and_porting_guide id10}@anchor{464}@anchor{gnat_rm/compatibility_and_porting_guide implementation-defined-pragmas}@anchor{465} @subsection Implementation-defined pragmas @@ -29742,7 +30210,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{452}@anchor{gnat_rm/compatibility_and_porting_guide implementation-defined-attributes}@anchor{453} +@anchor{gnat_rm/compatibility_and_porting_guide id11}@anchor{466}@anchor{gnat_rm/compatibility_and_porting_guide implementation-defined-attributes}@anchor{467} @subsection Implementation-defined attributes @@ -29756,7 +30224,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{454}@anchor{gnat_rm/compatibility_and_porting_guide libraries}@anchor{455} +@anchor{gnat_rm/compatibility_and_porting_guide id12}@anchor{468}@anchor{gnat_rm/compatibility_and_porting_guide libraries}@anchor{469} @subsection Libraries @@ -29785,7 +30253,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{456}@anchor{gnat_rm/compatibility_and_porting_guide id13}@anchor{457} +@anchor{gnat_rm/compatibility_and_porting_guide elaboration-order}@anchor{46a}@anchor{gnat_rm/compatibility_and_porting_guide id13}@anchor{46b} @subsection Elaboration order @@ -29821,7 +30289,7 @@ pragmas either globally (as an effect of the `-gnatE' switch) or locally @end itemize @node Target-specific aspects,,Elaboration order,Implementation-dependent characteristics -@anchor{gnat_rm/compatibility_and_porting_guide id14}@anchor{458}@anchor{gnat_rm/compatibility_and_porting_guide target-specific-aspects}@anchor{459} +@anchor{gnat_rm/compatibility_and_porting_guide id14}@anchor{46c}@anchor{gnat_rm/compatibility_and_porting_guide target-specific-aspects}@anchor{46d} @subsection Target-specific aspects @@ -29834,10 +30302,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{45a,,Representation Clauses}. +GNAT’s approach to these issues is described in @ref{46e,,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{45b}@anchor{gnat_rm/compatibility_and_porting_guide id15}@anchor{45c} +@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-other-ada-systems}@anchor{46f}@anchor{gnat_rm/compatibility_and_porting_guide id15}@anchor{470} @section Compatibility with Other Ada Systems @@ -29880,7 +30348,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{45d}@anchor{gnat_rm/compatibility_and_porting_guide representation-clauses}@anchor{45a} +@anchor{gnat_rm/compatibility_and_porting_guide id16}@anchor{471}@anchor{gnat_rm/compatibility_and_porting_guide representation-clauses}@anchor{46e} @section Representation Clauses @@ -29973,7 +30441,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{45e}@anchor{gnat_rm/compatibility_and_porting_guide id17}@anchor{45f} +@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-hp-ada-83}@anchor{472}@anchor{gnat_rm/compatibility_and_porting_guide id17}@anchor{473} @section Compatibility with HP Ada 83 @@ -30003,7 +30471,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{460}@anchor{share/gnu_free_documentation_license gnu-fdl}@anchor{1}@anchor{share/gnu_free_documentation_license gnu-free-documentation-license}@anchor{461} +@anchor{share/gnu_free_documentation_license doc}@anchor{474}@anchor{share/gnu_free_documentation_license gnu-fdl}@anchor{1}@anchor{share/gnu_free_documentation_license gnu-free-documentation-license}@anchor{475} @chapter GNU Free Documentation License diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index a1daff9..b85711b 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -19,7 +19,7 @@ @copying @quotation -GNAT User's Guide for Native Platforms , Jan 03, 2023 +GNAT User's Guide for Native Platforms , Jun 16, 2023 AdaCore @@ -198,6 +198,7 @@ Mixed Language Programming * Interfacing to C:: * Calling Conventions:: * Building Mixed Ada and C++ Programs:: +* Partition-Wide Settings:: * Generating Ada Bindings for C and C++ headers:: * Generating C Headers for Ada Specifications:: @@ -431,6 +432,7 @@ Specifying a Run-Time Library GNU/Linux Topics * Required Packages on GNU/Linux:: +* Position Independent Executable (PIE) Enabled by Default on Linux: Position Independent Executable PIE Enabled by Default on Linux. * A GNU/Linux Debug Quirk:: Microsoft Windows Topics @@ -589,12 +591,12 @@ using the GNU make utility with GNAT. @item @ref{b,,GNAT Utility Programs} explains the various utility programs that -are included in the GNAT environment +are included in the GNAT environment. @item @ref{c,,GNAT and Program Execution} covers a number of topics related to -running, debugging, and tuning the performace of programs developed -with GNAT +running, debugging, and tuning the performance of programs developed +with GNAT. @end itemize Appendices cover several additional topics: @@ -605,7 +607,7 @@ Appendices cover several additional topics: @item @ref{d,,Platform-Specific Information} describes the different run-time library implementations and also presents information on how to use -GNAT on several specific platforms +GNAT on several specific platforms. @item @ref{e,,Example of Binder Output File} shows the source code for the binder @@ -1287,7 +1289,7 @@ lowercase equivalence. @item `ISO 8859-15 (Latin-9)' ISO 8859-15 (Latin-9) letters allowed in identifiers, with uppercase and -lowercase equivalence +lowercase equivalence. @end table @geindex code page 437 (IBM PC) @@ -3230,8 +3232,8 @@ default, that contains calls to the elaboration procedures of those compilation unit that require them, followed by a call to the main program. This Ada program is compiled to generate the object file for the main program. The name of -the Ada file is @code{b~xxx}.adb` (with the corresponding spec -@code{b~xxx}.ads`) where @code{xxx} is the name of the +the Ada file is @code{b~xxx.adb} (with the corresponding spec +@code{b~xxx.ads}) where @code{xxx} is the name of the main program unit. Finally, the linker is used to build the resulting executable program, @@ -3469,7 +3471,7 @@ process (see the `Installing a Library with Project Files' section of the When project files are not an option, it is also possible, but not recommended, to install the library so that the sources needed to use the library are on the Ada source path and the ALI files & libraries be on the Ada Object path (see -@ref{73,,Search Paths and the Run-Time Library (RTL)}. Alternatively, the system +@ref{73,,Search Paths and the Run-Time Library (RTL)}). Alternatively, the system administrator can place general-purpose libraries in the default compiler paths, by specifying the libraries’ location in the configuration files @code{ada_source_path} and @code{ada_object_path}. These configuration files @@ -5085,6 +5087,7 @@ with a focus on combining Ada with C or C++. * Interfacing to C:: * Calling Conventions:: * Building Mixed Ada and C++ Programs:: +* Partition-Wide Settings:: * Generating Ada Bindings for C and C++ headers:: * Generating C Headers for Ada Specifications:: @@ -5365,7 +5368,7 @@ elaboration of the GNAT components. Consult the documentation of the other Ada compiler for further details on elaboration. However, it is not possible to mix the tasking run time of GNAT and -HP Ada 83, All the tasking operations must either be entirely within +HP Ada 83, all the tasking operations must either be entirely within GNAT compiled sections of the program, or entirely within HP Ada 83 compiled sections of the program. @end table @@ -5536,24 +5539,20 @@ 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 to perform dimensional checks: -@end itemize @example - type Distance is new Long_Float; - type Time is new Long_Float; - type Velocity is new Long_Float; - function "/" (D : Distance; T : Time) - return Velocity; - pragma Import (Intrinsic, "/"); +type Distance is new Long_Float; +type Time is new Long_Float; +type Velocity is new Long_Float; +function "/" (D : Distance; T : Time) + return Velocity; +pragma Import (Intrinsic, "/"); +@end example This common idiom is often programmed with a generic definition and an explicit body. The pragma makes it simpler to introduce such declarations. It incurs no overhead in compilation time or code size, because it is implemented as a single machine instruction. -@end example - - -@itemize * @item General subprogram entities. This is used to bind an Ada subprogram @@ -5641,7 +5640,7 @@ And from now on the identifier Fortran77 may be used as a convention identifier (for example in an @code{Import} pragma) with the same meaning as Fortran. -@node Building Mixed Ada and C++ Programs,Generating Ada Bindings for C and C++ headers,Calling Conventions,Mixed Language Programming +@node Building Mixed Ada and C++ Programs,Partition-Wide Settings,Calling Conventions,Mixed Language Programming @anchor{gnat_ugn/the_gnat_compilation_model building-mixed-ada-and-c-programs}@anchor{a3}@anchor{gnat_ugn/the_gnat_compilation_model id64}@anchor{a4} @subsection Building Mixed Ada and C++ Programs @@ -5723,7 +5722,10 @@ $ gnatmake ada_unit -largs file1.o file2.o --LINK=g++ @item Using GNAT and G++ from two different GCC installations: If both -compilers are on the :envvar`PATH`, the previous method may be used. It is +compilers are on the +@geindex PATH +@geindex environment variable; PATH +@code{PATH}, the previous method may be used. It is important to note that environment variables such as @geindex C_INCLUDE_PATH @geindex environment variable; C_INCLUDE_PATH @@ -6377,8 +6379,68 @@ int main () @} @end example -@node Generating Ada Bindings for C and C++ headers,Generating C Headers for Ada Specifications,Building Mixed Ada and C++ Programs,Mixed Language Programming -@anchor{gnat_ugn/the_gnat_compilation_model generating-ada-bindings-for-c-and-c-headers}@anchor{a7}@anchor{gnat_ugn/the_gnat_compilation_model id70}@anchor{b0} +@node Partition-Wide Settings,Generating Ada Bindings for C and C++ headers,Building Mixed Ada and C++ Programs,Mixed Language Programming +@anchor{gnat_ugn/the_gnat_compilation_model id70}@anchor{b0}@anchor{gnat_ugn/the_gnat_compilation_model partition-wide-settings}@anchor{b1} +@subsection Partition-Wide Settings + + +When building a mixed-language application it is important to be aware that +Ada enforces some partition-wide settings that may implicitly impact the +behavior of the other languages. + +This is the case of certain signals that are reserved to the +implementation to implement proper Ada semantics (such as the behavior +of @code{abort} statements). + +It means that the Ada part of the application may override signal handlers +that were previously installed by either the system or by other user code. + +If your application requires that either system or user signals be preserved +then you need to instruct the Ada part not to install its own signal handler. +This is done using @code{pragma Interrupt_State} that provides a general +mechanism for overriding such uses of interrupts. + +The set of interrupts for which the Ada run-time library sets a specific signal +handler is the following: + + +@itemize * + +@item +Ada.Interrupts.Names.SIGSEGV + +@item +Ada.Interrupts.Names.SIGBUS + +@item +Ada.Interrupts.Names.SIGFPE + +@item +Ada.Interrupts.Names.SIGILL + +@item +Ada.Interrupts.Names.SIGABRT +@end itemize + +The run-time library can be instructed not to install its signal handler for a +particular signal by using the configuration pragma @code{Interrupt_State} in the +Ada code. For example: + +@example +pragma Interrupt_State (Ada.Interrupts.Names.SIGSEGV, System); +pragma Interrupt_State (Ada.Interrupts.Names.SIGBUS, System); +pragma Interrupt_State (Ada.Interrupts.Names.SIGFPE, System); +pragma Interrupt_State (Ada.Interrupts.Names.SIGILL, System); +pragma Interrupt_State (Ada.Interrupts.Names.SIGABRT, System); +@end example + +Obviously, if the Ada run-time system cannot set these handlers it comes with the +drawback of not fully preserving Ada semantics. @code{SIGSEGV}, @code{SIGBUS}, @code{SIGFPE} +and @code{SIGILL} are used to raise corresponding Ada exceptions in the application, +while @code{SIGABRT} is used to asynchronously abort an action or a task. + +@node Generating Ada Bindings for C and C++ headers,Generating C Headers for Ada Specifications,Partition-Wide Settings,Mixed Language Programming +@anchor{gnat_ugn/the_gnat_compilation_model generating-ada-bindings-for-c-and-c-headers}@anchor{a7}@anchor{gnat_ugn/the_gnat_compilation_model id71}@anchor{b2} @subsection Generating Ada Bindings for C and C++ headers @@ -6429,7 +6491,7 @@ even if your code is compiled using earlier versions of Ada (e.g. @code{-gnat95} @end menu @node Running the Binding Generator,Generating Bindings for C++ Headers,,Generating Ada Bindings for C and C++ headers -@anchor{gnat_ugn/the_gnat_compilation_model id71}@anchor{b1}@anchor{gnat_ugn/the_gnat_compilation_model running-the-binding-generator}@anchor{b2} +@anchor{gnat_ugn/the_gnat_compilation_model id72}@anchor{b3}@anchor{gnat_ugn/the_gnat_compilation_model running-the-binding-generator}@anchor{b4} @subsubsection Running the Binding Generator @@ -6495,7 +6557,7 @@ $ gcc -c -fdump-ada-spec readline1.h @end example @node Generating Bindings for C++ Headers,Switches,Running the Binding Generator,Generating Ada Bindings for C and C++ headers -@anchor{gnat_ugn/the_gnat_compilation_model generating-bindings-for-c-headers}@anchor{b3}@anchor{gnat_ugn/the_gnat_compilation_model id72}@anchor{b4} +@anchor{gnat_ugn/the_gnat_compilation_model generating-bindings-for-c-headers}@anchor{b5}@anchor{gnat_ugn/the_gnat_compilation_model id73}@anchor{b6} @subsubsection Generating Bindings for C++ Headers @@ -6596,7 +6658,7 @@ use Class_Dog; @end example @node Switches,,Generating Bindings for C++ Headers,Generating Ada Bindings for C and C++ headers -@anchor{gnat_ugn/the_gnat_compilation_model switches}@anchor{b5}@anchor{gnat_ugn/the_gnat_compilation_model switches-for-ada-binding-generation}@anchor{b6} +@anchor{gnat_ugn/the_gnat_compilation_model switches}@anchor{b7}@anchor{gnat_ugn/the_gnat_compilation_model switches-for-ada-binding-generation}@anchor{b8} @subsubsection Switches @@ -6644,7 +6706,7 @@ Extract comments from headers and generate Ada comments in the Ada spec files. @end table @node Generating C Headers for Ada Specifications,,Generating Ada Bindings for C and C++ headers,Mixed Language Programming -@anchor{gnat_ugn/the_gnat_compilation_model generating-c-headers-for-ada-specifications}@anchor{b7}@anchor{gnat_ugn/the_gnat_compilation_model id73}@anchor{b8} +@anchor{gnat_ugn/the_gnat_compilation_model generating-c-headers-for-ada-specifications}@anchor{b9}@anchor{gnat_ugn/the_gnat_compilation_model id74}@anchor{ba} @subsection Generating C Headers for Ada Specifications @@ -6687,7 +6749,7 @@ Subprogram declarations @end menu @node Running the C Header Generator,,,Generating C Headers for Ada Specifications -@anchor{gnat_ugn/the_gnat_compilation_model running-the-c-header-generator}@anchor{b9} +@anchor{gnat_ugn/the_gnat_compilation_model running-the-c-header-generator}@anchor{bb} @subsubsection Running the C Header Generator @@ -6755,7 +6817,7 @@ You can then @code{include} @code{pack1.h} from a C source file and use the type call subprograms, reference objects, and constants. @node GNAT and Other Compilation Models,Using GNAT Files with External Tools,Mixed Language Programming,The GNAT Compilation Model -@anchor{gnat_ugn/the_gnat_compilation_model gnat-and-other-compilation-models}@anchor{2d}@anchor{gnat_ugn/the_gnat_compilation_model id74}@anchor{ba} +@anchor{gnat_ugn/the_gnat_compilation_model gnat-and-other-compilation-models}@anchor{2d}@anchor{gnat_ugn/the_gnat_compilation_model id75}@anchor{bc} @section GNAT and Other Compilation Models @@ -6771,7 +6833,7 @@ used for Ada 83. @end menu @node Comparison between GNAT and C/C++ Compilation Models,Comparison between GNAT and Conventional Ada Library Models,,GNAT and Other Compilation Models -@anchor{gnat_ugn/the_gnat_compilation_model comparison-between-gnat-and-c-c-compilation-models}@anchor{bb}@anchor{gnat_ugn/the_gnat_compilation_model id75}@anchor{bc} +@anchor{gnat_ugn/the_gnat_compilation_model comparison-between-gnat-and-c-c-compilation-models}@anchor{bd}@anchor{gnat_ugn/the_gnat_compilation_model id76}@anchor{be} @subsection Comparison between GNAT and C/C++ Compilation Models @@ -6805,7 +6867,7 @@ elaboration, a C++ compiler would simply construct a program that malfunctioned at run time. @node Comparison between GNAT and Conventional Ada Library Models,,Comparison between GNAT and C/C++ Compilation Models,GNAT and Other Compilation Models -@anchor{gnat_ugn/the_gnat_compilation_model comparison-between-gnat-and-conventional-ada-library-models}@anchor{bd}@anchor{gnat_ugn/the_gnat_compilation_model id76}@anchor{be} +@anchor{gnat_ugn/the_gnat_compilation_model comparison-between-gnat-and-conventional-ada-library-models}@anchor{bf}@anchor{gnat_ugn/the_gnat_compilation_model id77}@anchor{c0} @subsection Comparison between GNAT and Conventional Ada Library Models @@ -6873,7 +6935,7 @@ of rules saying what source files must be present when a file is compiled. @node Using GNAT Files with External Tools,,GNAT and Other Compilation Models,The GNAT Compilation Model -@anchor{gnat_ugn/the_gnat_compilation_model id77}@anchor{bf}@anchor{gnat_ugn/the_gnat_compilation_model using-gnat-files-with-external-tools}@anchor{2e} +@anchor{gnat_ugn/the_gnat_compilation_model id78}@anchor{c1}@anchor{gnat_ugn/the_gnat_compilation_model using-gnat-files-with-external-tools}@anchor{2e} @section Using GNAT Files with External Tools @@ -6887,7 +6949,7 @@ used with tools designed for other languages. @end menu @node Using Other Utility Programs with GNAT,The External Symbol Naming Scheme of GNAT,,Using GNAT Files with External Tools -@anchor{gnat_ugn/the_gnat_compilation_model id78}@anchor{c0}@anchor{gnat_ugn/the_gnat_compilation_model using-other-utility-programs-with-gnat}@anchor{c1} +@anchor{gnat_ugn/the_gnat_compilation_model id79}@anchor{c2}@anchor{gnat_ugn/the_gnat_compilation_model using-other-utility-programs-with-gnat}@anchor{c3} @subsection Using Other Utility Programs with GNAT @@ -6902,7 +6964,7 @@ gprof (a profiling program), gdb (the FSF debugger), and utilities such as Purify. @node The External Symbol Naming Scheme of GNAT,,Using Other Utility Programs with GNAT,Using GNAT Files with External Tools -@anchor{gnat_ugn/the_gnat_compilation_model id79}@anchor{c2}@anchor{gnat_ugn/the_gnat_compilation_model the-external-symbol-naming-scheme-of-gnat}@anchor{c3} +@anchor{gnat_ugn/the_gnat_compilation_model id80}@anchor{c4}@anchor{gnat_ugn/the_gnat_compilation_model the-external-symbol-naming-scheme-of-gnat}@anchor{c5} @subsection The External Symbol Naming Scheme of GNAT @@ -6961,19 +7023,19 @@ the external name of this procedure will be @code{_ada_hello}. @c -- Example: A |withing| unit has a |with| clause, it |withs| a |withed| unit @node Building Executable Programs with GNAT,GNAT Utility Programs,The GNAT Compilation Model,Top -@anchor{gnat_ugn/building_executable_programs_with_gnat doc}@anchor{c4}@anchor{gnat_ugn/building_executable_programs_with_gnat building-executable-programs-with-gnat}@anchor{a}@anchor{gnat_ugn/building_executable_programs_with_gnat id1}@anchor{c5} +@anchor{gnat_ugn/building_executable_programs_with_gnat doc}@anchor{c6}@anchor{gnat_ugn/building_executable_programs_with_gnat building-executable-programs-with-gnat}@anchor{a}@anchor{gnat_ugn/building_executable_programs_with_gnat id1}@anchor{c7} @chapter Building Executable Programs with GNAT This chapter describes first the gnatmake tool -(@ref{c6,,Building with gnatmake}), +(@ref{c8,,Building with gnatmake}), which automatically determines the set of sources needed by an Ada compilation unit and executes the necessary (re)compilations, binding and linking. It also explains how to use each tool individually: the -compiler (gcc, see @ref{c7,,Compiling with gcc}), -binder (gnatbind, see @ref{c8,,Binding with gnatbind}), -and linker (gnatlink, see @ref{c9,,Linking with gnatlink}) +compiler (gcc, see @ref{c9,,Compiling with gcc}), +binder (gnatbind, see @ref{ca,,Binding with gnatbind}), +and linker (gnatlink, see @ref{cb,,Linking with gnatlink}) to build executable programs. Finally, this chapter provides examples of how to make use of the general GNU make mechanism @@ -6992,7 +7054,7 @@ in a GNAT context (see @ref{70,,Using the GNU make Utility}). @end menu @node Building with gnatmake,Compiling with gcc,,Building Executable Programs with GNAT -@anchor{gnat_ugn/building_executable_programs_with_gnat building-with-gnatmake}@anchor{ca}@anchor{gnat_ugn/building_executable_programs_with_gnat the-gnat-make-program-gnatmake}@anchor{c6} +@anchor{gnat_ugn/building_executable_programs_with_gnat building-with-gnatmake}@anchor{cc}@anchor{gnat_ugn/building_executable_programs_with_gnat the-gnat-make-program-gnatmake}@anchor{c8} @section Building with @code{gnatmake} @@ -7056,7 +7118,7 @@ to @code{gnatmake}. @end menu @node Running gnatmake,Switches for gnatmake,,Building with gnatmake -@anchor{gnat_ugn/building_executable_programs_with_gnat id2}@anchor{cb}@anchor{gnat_ugn/building_executable_programs_with_gnat running-gnatmake}@anchor{cc} +@anchor{gnat_ugn/building_executable_programs_with_gnat id2}@anchor{cd}@anchor{gnat_ugn/building_executable_programs_with_gnat running-gnatmake}@anchor{ce} @subsection Running @code{gnatmake} @@ -7091,7 +7153,7 @@ All @code{gnatmake} output (except when you specify @code{-M}) is sent to @code{-M} switch is sent to @code{stdout}. @node Switches for gnatmake,Mode Switches for gnatmake,Running gnatmake,Building with gnatmake -@anchor{gnat_ugn/building_executable_programs_with_gnat id3}@anchor{cd}@anchor{gnat_ugn/building_executable_programs_with_gnat switches-for-gnatmake}@anchor{ce} +@anchor{gnat_ugn/building_executable_programs_with_gnat id3}@anchor{cf}@anchor{gnat_ugn/building_executable_programs_with_gnat switches-for-gnatmake}@anchor{d0} @subsection Switches for @code{gnatmake} @@ -7733,7 +7795,7 @@ Verbosity level High. Equivalent to -v. @item @code{-vP`x'} Indicate the verbosity of the parsing of GNAT project files. -See @ref{cf,,Switches Related to Project Files}. +See @ref{d1,,Switches Related to Project Files}. @end table @geindex -x (gnatmake) @@ -7757,7 +7819,7 @@ command line need to be sources of a project file. Indicate that external variable @code{name} has the value @code{value}. The Project Manager will use this value for occurrences of @code{external(name)} when parsing the project file. -@ref{cf,,Switches Related to Project Files}. +@ref{d1,,Switches Related to Project Files}. @end table @geindex -z (gnatmake) @@ -7928,7 +7990,7 @@ The selected path is handled like a normal RTS path. @end table @node Mode Switches for gnatmake,Notes on the Command Line,Switches for gnatmake,Building with gnatmake -@anchor{gnat_ugn/building_executable_programs_with_gnat id4}@anchor{d0}@anchor{gnat_ugn/building_executable_programs_with_gnat mode-switches-for-gnatmake}@anchor{d1} +@anchor{gnat_ugn/building_executable_programs_with_gnat id4}@anchor{d2}@anchor{gnat_ugn/building_executable_programs_with_gnat mode-switches-for-gnatmake}@anchor{d3} @subsection Mode Switches for @code{gnatmake} @@ -7988,7 +8050,7 @@ or @code{-largs}. @end table @node Notes on the Command Line,How gnatmake Works,Mode Switches for gnatmake,Building with gnatmake -@anchor{gnat_ugn/building_executable_programs_with_gnat id5}@anchor{d2}@anchor{gnat_ugn/building_executable_programs_with_gnat notes-on-the-command-line}@anchor{d3} +@anchor{gnat_ugn/building_executable_programs_with_gnat id5}@anchor{d4}@anchor{gnat_ugn/building_executable_programs_with_gnat notes-on-the-command-line}@anchor{d5} @subsection Notes on the Command Line @@ -8058,7 +8120,7 @@ that the debugging information may be out of date. @end itemize @node How gnatmake Works,Examples of gnatmake Usage,Notes on the Command Line,Building with gnatmake -@anchor{gnat_ugn/building_executable_programs_with_gnat how-gnatmake-works}@anchor{d4}@anchor{gnat_ugn/building_executable_programs_with_gnat id6}@anchor{d5} +@anchor{gnat_ugn/building_executable_programs_with_gnat how-gnatmake-works}@anchor{d6}@anchor{gnat_ugn/building_executable_programs_with_gnat id6}@anchor{d7} @subsection How @code{gnatmake} Works @@ -8105,20 +8167,20 @@ by @code{gnatmake}. It may be necessary to use the switch -f. @node Examples of gnatmake Usage,,How gnatmake Works,Building with gnatmake -@anchor{gnat_ugn/building_executable_programs_with_gnat examples-of-gnatmake-usage}@anchor{d6}@anchor{gnat_ugn/building_executable_programs_with_gnat id7}@anchor{d7} +@anchor{gnat_ugn/building_executable_programs_with_gnat examples-of-gnatmake-usage}@anchor{d8}@anchor{gnat_ugn/building_executable_programs_with_gnat id7}@anchor{d9} @subsection Examples of @code{gnatmake} Usage @table @asis -@item `gnatmake hello.adb' +@item @code{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 `gnatmake main1 main2 main3' +@item @code{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} @@ -8127,7 +8189,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 `gnatmake -q Main_Unit -cargs -O2 -bargs -l' +@item @code{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 @@ -8137,7 +8199,7 @@ displaying commands it is executing. @end table @node Compiling with gcc,Compiler Switches,Building with gnatmake,Building Executable Programs with GNAT -@anchor{gnat_ugn/building_executable_programs_with_gnat compiling-with-gcc}@anchor{c7}@anchor{gnat_ugn/building_executable_programs_with_gnat id8}@anchor{d8} +@anchor{gnat_ugn/building_executable_programs_with_gnat compiling-with-gcc}@anchor{c9}@anchor{gnat_ugn/building_executable_programs_with_gnat id8}@anchor{da} @section Compiling with @code{gcc} @@ -8154,7 +8216,7 @@ that can be used to control the behavior of the compiler. @end menu @node Compiling Programs,Search Paths and the Run-Time Library RTL,,Compiling with gcc -@anchor{gnat_ugn/building_executable_programs_with_gnat compiling-programs}@anchor{d9}@anchor{gnat_ugn/building_executable_programs_with_gnat id9}@anchor{da} +@anchor{gnat_ugn/building_executable_programs_with_gnat compiling-programs}@anchor{db}@anchor{gnat_ugn/building_executable_programs_with_gnat id9}@anchor{dc} @subsection Compiling Programs @@ -8190,7 +8252,7 @@ the spec of a library unit which has a body subunits @end itemize -because they are compiled as part of compiling related units. GNAT +because they are compiled as part of compiling related units. GNAT compiles package specs when the corresponding body is compiled, and subunits when the parent is compiled. @@ -8240,8 +8302,6 @@ 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`NN'} switch - @geindex gnat1 @code{gcc} is actually a driver program that looks at the extensions of @@ -8267,11 +8327,11 @@ calls @code{gnat1} (the Ada compiler) twice to compile @code{x.adb} and The compiler generates two object files @code{x.o} and @code{y.o} and the two ALI files @code{x.ali} and @code{y.ali}. -Any switches apply to all the files listed, see @ref{db,,Compiler Switches} for a +Any switches apply to all the files listed, see @ref{dd,,Compiler Switches} for a list of available @code{gcc} switches. @node Search Paths and the Run-Time Library RTL,Order of Compilation Issues,Compiling Programs,Compiling with gcc -@anchor{gnat_ugn/building_executable_programs_with_gnat id10}@anchor{dc}@anchor{gnat_ugn/building_executable_programs_with_gnat search-paths-and-the-run-time-library-rtl}@anchor{73} +@anchor{gnat_ugn/building_executable_programs_with_gnat id10}@anchor{de}@anchor{gnat_ugn/building_executable_programs_with_gnat search-paths-and-the-run-time-library-rtl}@anchor{73} @subsection Search Paths and the Run-Time Library (RTL) @@ -8328,7 +8388,7 @@ names separated by colons (semicolons when working with the NT version). The content of the @code{ada_source_path} file which is part of the GNAT installation tree and is used to store standard libraries such as the GNAT Run Time Library (RTL) source files. -@ref{72,,Installing a library} +See also @ref{72,,Installing a library}. @end itemize Specifying the switch @code{-I-} @@ -8370,7 +8430,7 @@ in compiling sources from multiple directories. This can make development environments much more flexible. @node Order of Compilation Issues,Examples,Search Paths and the Run-Time Library RTL,Compiling with gcc -@anchor{gnat_ugn/building_executable_programs_with_gnat id11}@anchor{dd}@anchor{gnat_ugn/building_executable_programs_with_gnat order-of-compilation-issues}@anchor{de} +@anchor{gnat_ugn/building_executable_programs_with_gnat id11}@anchor{df}@anchor{gnat_ugn/building_executable_programs_with_gnat order-of-compilation-issues}@anchor{e0} @subsection Order of Compilation Issues @@ -8411,7 +8471,7 @@ described above), or you will receive a fatal error message. @end itemize @node Examples,,Order of Compilation Issues,Compiling with gcc -@anchor{gnat_ugn/building_executable_programs_with_gnat examples}@anchor{df}@anchor{gnat_ugn/building_executable_programs_with_gnat id12}@anchor{e0} +@anchor{gnat_ugn/building_executable_programs_with_gnat examples}@anchor{e1}@anchor{gnat_ugn/building_executable_programs_with_gnat id12}@anchor{e2} @subsection Examples @@ -8428,7 +8488,7 @@ $ gcc -c -O2 -gnata xyz-def.adb @end example Compile the child unit package in file @code{xyz-def.adb} with extensive -optimizations, and pragma @code{Assert}/@cite{Debug} statements +optimizations, and pragma @code{Assert}/@code{Debug} statements enabled. @example @@ -8439,7 +8499,7 @@ Compile the subunit in file @code{abc-def.adb} in semantic-checking-only mode. @node Compiler Switches,Linker Switches,Compiling with gcc,Building Executable Programs with GNAT -@anchor{gnat_ugn/building_executable_programs_with_gnat compiler-switches}@anchor{e1}@anchor{gnat_ugn/building_executable_programs_with_gnat switches-for-gcc}@anchor{db} +@anchor{gnat_ugn/building_executable_programs_with_gnat compiler-switches}@anchor{e3}@anchor{gnat_ugn/building_executable_programs_with_gnat switches-for-gcc}@anchor{dd} @section Compiler Switches @@ -8478,7 +8538,7 @@ compilation units. @end menu @node Alphabetical List of All Switches,Output and Error Message Control,,Compiler Switches -@anchor{gnat_ugn/building_executable_programs_with_gnat alphabetical-list-of-all-switches}@anchor{e2}@anchor{gnat_ugn/building_executable_programs_with_gnat id13}@anchor{e3} +@anchor{gnat_ugn/building_executable_programs_with_gnat alphabetical-list-of-all-switches}@anchor{e4}@anchor{gnat_ugn/building_executable_programs_with_gnat id13}@anchor{e5} @subsection Alphabetical List of All Switches @@ -8598,7 +8658,7 @@ This can also speed up the compilation of big programs and reduce the size of the executable, compared with a traditional per-unit compilation with inlining across units enabled by the @code{-gnatn} switch. The drawback of this approach is that it may require more memory and that -the debugging information generated by -g with it might be hardly usable. +the debugging information generated by @code{-g} with it might be hardly usable. The switch, as well as the accompanying @code{-Ox} switches, must be specified both for the compilation and the link phases. If the @code{n} parameter is specified, the optimization and final code @@ -8676,7 +8736,7 @@ and thus producing inferior code. Causes the compiler to avoid assumptions regarding non-aliasing of objects of different types. See -@ref{e4,,Optimization and Strict Aliasing} for details. +@ref{e6,,Optimization and Strict Aliasing} for details. @end table @geindex -fno-strict-overflow (gcc) @@ -8702,7 +8762,7 @@ for very peculiar cases of low-level programming. @item @code{-fstack-check} Activates stack checking. -See @ref{e5,,Stack Overflow Checking} for details. +See @ref{e7,,Stack Overflow Checking} for details. @end table @geindex -fstack-usage (gcc) @@ -8713,7 +8773,7 @@ See @ref{e5,,Stack Overflow Checking} for details. @item @code{-fstack-usage} Makes the compiler output stack usage information for the program, on a -per-subprogram basis. See @ref{e6,,Static Stack Usage Analysis} for details. +per-subprogram basis. See @ref{e8,,Static Stack Usage Analysis} for details. @end table @geindex -g (gcc) @@ -8853,7 +8913,7 @@ Generate brief messages to @code{stderr} even if verbose mode set. @item @code{-gnatB} Assume no invalid (bad) values except for ‘Valid attribute use -(@ref{e7,,Validity Checking}). +(@ref{e9,,Validity Checking}). @end table @geindex -gnatc (gcc) @@ -8885,7 +8945,7 @@ Generate CodePeer intermediate format (no code generation attempted). This switch will generate an intermediate representation suitable for use by CodePeer (@code{.scil} files). This switch is not compatible with code generation (it will, among other things, disable some switches such -as -gnatn, and enable others such as -gnata). +as @code{-gnatn}, and enable others such as @code{-gnata}). @end table @geindex -gnatd (gcc) @@ -8899,9 +8959,9 @@ Specify debug options for the compiler. The string of characters after the @code{-gnatd} specifies the specific debug options. The possible characters are 0-9, a-z, A-Z, optionally preceded by a dot or underscore. See compiler source file @code{debug.adb} for details of the implemented -debug options. Certain debug options are relevant to applications +debug options. Certain debug options are relevant to application programmers, and these are documented at appropriate points in this -users guide. +user’s guide. @end table @geindex -gnatD[nn] (gcc) @@ -8914,7 +8974,7 @@ users guide. Create expanded source files for source level debugging. This switch also suppresses generation of cross-reference information (see @code{-gnatx}). Note that this switch is not allowed if a previous --gnatR switch has been given, since these two switches are not compatible. +@code{-gnatR} switch has been given, since these two switches are not compatible. @end table @geindex -gnateA (gcc) @@ -9063,7 +9123,7 @@ for unconstrained predefined types. See description of pragma The @code{-gnatc} switch must always be specified before this switch, e.g. @code{-gnatceg}. Generate a C header from the Ada input file. See -@ref{b7,,Generating C Headers for Ada Specifications} for more +@ref{b9,,Generating C Headers for Ada Specifications} for more information. @end quotation @@ -9077,6 +9137,18 @@ information. Save result of preprocessing in a text file. @end table +@geindex -gnateH (gcc) + + +@table @asis + +@item @code{-gnateH} + +Set the threshold from which the RM 13.5.1(13.3/2) clause applies to 64. +This is useful only on 64-bit plaforms where this threshold is 128, but +used to be 64 in earlier versions of the compiler. +@end table + @geindex -gnatei (gcc) @@ -9113,7 +9185,7 @@ messages showing where implicit @code{pragma Elaborate} and @code{pragma Elaborate_All} are generated. This is useful in diagnosing elaboration circularities caused by these implicit pragmas when using the static elaboration -model. See See the section in this guide on elaboration checking for +model. See the section in this guide on elaboration checking for further details. These messages are not generated by default, and are intended only for temporary use when debugging circularity problems. @end table @@ -9137,7 +9209,7 @@ This switch turns off the info messages about implicit elaboration pragmas. Specify a mapping file (the equal sign is optional) -(@ref{e8,,Units to Sources Mapping Files}). +(@ref{ea,,Units to Sources Mapping Files}). @end table @geindex -gnatep (gcc) @@ -9349,7 +9421,7 @@ support this switch. @item @code{-gnateV} Check that all actual parameters of a subprogram call are valid according to -the rules of validity checking (@ref{e7,,Validity Checking}). +the rules of validity checking (@ref{e9,,Validity Checking}). @end table @geindex -gnateY (gcc) @@ -9701,7 +9773,7 @@ overflow checking is enabled. Note that division by zero is a separate check that is not controlled by this switch (divide-by-zero checking is on by default). -See also @ref{e9,,Specifying the Desired Mode}. +See also @ref{eb,,Specifying the Desired Mode}. @end table @geindex -gnatp (gcc) @@ -9711,7 +9783,7 @@ See also @ref{e9,,Specifying the Desired Mode}. @item @code{-gnatp} -Suppress all checks. See @ref{ea,,Run-Time Checks} for details. This switch +Suppress all checks. See @ref{ec,,Run-Time Checks} for details. This switch has no effect if cancelled by a subsequent @code{-gnat-p} switch. @end table @@ -9837,7 +9909,7 @@ Verbose mode. Full error output with source lines to @code{stdout}. @item @code{-gnatV} -Control level of validity checking (@ref{e7,,Validity Checking}). +Control level of validity checking (@ref{e9,,Validity Checking}). @end table @geindex -gnatw (gcc) @@ -9850,7 +9922,7 @@ Control level of validity checking (@ref{e7,,Validity Checking}). Warning mode where @code{xxx} is a string of option letters that denotes the exact warnings that -are enabled or disabled (@ref{eb,,Warning Message Control}). +are enabled or disabled (@ref{ed,,Warning Message Control}). @end table @geindex -gnatW (gcc) @@ -9901,7 +9973,7 @@ Enable all GNAT implementation extensions and latest Ada version. @item @code{-gnaty} -Enable built-in style checks (@ref{ec,,Style Checking}). +Enable built-in style checks (@ref{ee,,Style Checking}). @end table @geindex -gnatz (gcc) @@ -10044,7 +10116,7 @@ Optimize space usage @end multitable -See also @ref{ed,,Optimization Levels}. +See also @ref{ef,,Optimization Levels}. @end table @geindex -pass-exit-codes (gcc) @@ -10066,7 +10138,7 @@ exit status. @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}). +equivalent @code{gnatmake} flag (@ref{d0,,Switches for gnatmake}). @end table @geindex -S (gcc) @@ -10192,7 +10264,7 @@ as warning mode modifiers (see description of @code{-gnatw}). @item Once a ‘V’ appears in the string (that is a use of the @code{-gnatV} switch), then all further characters in the switch are interpreted -as validity checking options (@ref{e7,,Validity Checking}). +as validity checking options (@ref{e9,,Validity Checking}). @item Option ‘em’, ‘ec’, ‘ep’, ‘l=’ and ‘R’ must be the last options in @@ -10200,7 +10272,7 @@ a combined list of options. @end itemize @node Output and Error Message Control,Warning Message Control,Alphabetical List of All Switches,Compiler Switches -@anchor{gnat_ugn/building_executable_programs_with_gnat id14}@anchor{ee}@anchor{gnat_ugn/building_executable_programs_with_gnat output-and-error-message-control}@anchor{ef} +@anchor{gnat_ugn/building_executable_programs_with_gnat id14}@anchor{f0}@anchor{gnat_ugn/building_executable_programs_with_gnat output-and-error-message-control}@anchor{f1} @subsection Output and Error Message Control @@ -10495,7 +10567,7 @@ since ALI files are never generated if @code{-gnats} is set. @end table @node Warning Message Control,Debugging and Assertion Control,Output and Error Message Control,Compiler Switches -@anchor{gnat_ugn/building_executable_programs_with_gnat id15}@anchor{f0}@anchor{gnat_ugn/building_executable_programs_with_gnat warning-message-control}@anchor{eb} +@anchor{gnat_ugn/building_executable_programs_with_gnat id15}@anchor{f2}@anchor{gnat_ugn/building_executable_programs_with_gnat warning-message-control}@anchor{ed} @subsection Warning Message Control @@ -10742,6 +10814,9 @@ switch are: @code{-gnatw.s} (overridden size clause) @item +@code{-gnatw_s} (ineffective predicate test) + +@item @code{-gnatwt} (tracking of deleted conditional code) @item @@ -10835,7 +10910,7 @@ RM 3.10.2 (14). @item @code{-gnatw_A} -`Supress warnings on anonymous allocators.' +`Suppress warnings on anonymous allocators.' @geindex Anonymous allocators @@ -11018,7 +11093,7 @@ The default is that such warnings are generated. `Suppress warnings on unknown condition in Compile_Time_Warning.' -This switch supresses warnings on a pragma Compile_Time_Warning +This switch suppresses warnings on a pragma Compile_Time_Warning or Compile_Time_Error whose condition has a value that is not known at compile time. @end table @@ -11498,7 +11573,7 @@ This switch disables warnings on variables that could be declared constants. This switch activates warnings for declarations that declare a name that is defined in package Standard. Such declarations can be confusing, especially since the names in package Standard continue to be directly -visible, meaning that use visibiliy on such redeclared names does not +visible, meaning that use visibility on such redeclared names does not work as expected. Names of discriminants and components in records are not included in this check. @end table @@ -12154,6 +12229,36 @@ representation clauses that override size clauses, and similar warnings when an array component size overrides a size clause. @end table +@geindex -gnatw_s (gcc) + +@geindex Warnings + + +@table @asis + +@item @code{-gnatw_s} + +`Activate warnings on ineffective predicate tests.' + +This switch activates warnings on Static_Predicate aspect +specifications that test for values that do not belong to +the parent subtype. Not all such ineffective tests are detected. +@end table + +@geindex -gnatw_S (gcc) + + +@table @asis + +@item @code{-gnatw_S} + +`Suppress warnings on ineffective predicate tests.' + +This switch suppresses warnings on Static_Predicate aspect +specifications that test for values that do not belong to +the parent subtype. +@end table + @geindex -gnatwt (gcc) @geindex Deactivated code @@ -12666,7 +12771,7 @@ used in conjunction with an optimization level greater than zero. @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. +See @ref{e8,,Static Stack Usage Analysis} for details. @end table @geindex -Wall (gcc) @@ -12867,7 +12972,7 @@ When no switch @code{-gnatw} is used, this is equivalent to: @end quotation @node Debugging and Assertion Control,Validity Checking,Warning Message Control,Compiler Switches -@anchor{gnat_ugn/building_executable_programs_with_gnat debugging-and-assertion-control}@anchor{f1}@anchor{gnat_ugn/building_executable_programs_with_gnat id16}@anchor{f2} +@anchor{gnat_ugn/building_executable_programs_with_gnat debugging-and-assertion-control}@anchor{f3}@anchor{gnat_ugn/building_executable_programs_with_gnat id16}@anchor{f4} @subsection Debugging and Assertion Control @@ -12972,7 +13077,7 @@ is @code{False}, the exception @code{Assert_Failure} is raised. @end table @node Validity Checking,Style Checking,Debugging and Assertion Control,Compiler Switches -@anchor{gnat_ugn/building_executable_programs_with_gnat id17}@anchor{f3}@anchor{gnat_ugn/building_executable_programs_with_gnat validity-checking}@anchor{e7} +@anchor{gnat_ugn/building_executable_programs_with_gnat id17}@anchor{f5}@anchor{gnat_ugn/building_executable_programs_with_gnat validity-checking}@anchor{e9} @subsection Validity Checking @@ -13270,7 +13375,7 @@ the validity checking mode at the program source level, and also allows for temporary disabling of validity checks. @node Style Checking,Run-Time Checks,Validity Checking,Compiler Switches -@anchor{gnat_ugn/building_executable_programs_with_gnat id18}@anchor{f4}@anchor{gnat_ugn/building_executable_programs_with_gnat style-checking}@anchor{ec} +@anchor{gnat_ugn/building_executable_programs_with_gnat id18}@anchor{f6}@anchor{gnat_ugn/building_executable_programs_with_gnat style-checking}@anchor{ee} @subsection Style Checking @@ -13278,7 +13383,7 @@ temporary disabling of validity checks. @geindex -gnaty (gcc) -The @code{-gnatyx} switch causes the compiler to +The @code{-gnaty} switch causes the compiler to enforce specified style rules. A limited set of style rules has been used in writing the GNAT sources themselves. This switch allows user programs to activate all or some of these checks. If the source program fails a @@ -13535,9 +13640,9 @@ in the source text. 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 -incorporated into GNAT. Currently this is equivalent to @code{-gnatyydISux}) -but additional style switches may be added to this set in the future without -advance notice. +incorporated into GNAT. Currently this is equivalent to +@code{-gnatyydISuxz}) but additional style switches may be added to this +set in the future without advance notice. @end table @geindex -gnatyh (gcc) @@ -13931,9 +14036,9 @@ one blank line occurs in sequence. `Check extra parentheses.' -Unnecessary extra level of parentheses (C-style) are not allowed -around conditions in @code{if} statements, @code{while} statements and -@code{exit} statements. +Unnecessary extra levels of parentheses (C-style) are not allowed +around conditions (or selection expressions) in @code{if}, @code{while}, +@code{case}, and @code{exit} statements, as well as part of ranges. @end table @geindex -gnatyy (gcc) @@ -13951,6 +14056,19 @@ options enabled with the exception of @code{-gnatyB}, @code{-gnatyd}, @code{-gnatyS}, @code{-gnatyu}, and @code{-gnatyx}. @end table +@geindex -gnatyz (gcc) + + +@table @asis + +@item @code{-gnatyz} + +`Check extra parentheses (operator precedence).' + +Extra levels of parentheses that are not required by operator precedence +rules are flagged. See also @code{-gnatyx}. +@end table + @geindex -gnaty- (gcc) @@ -14010,7 +14128,7 @@ built-in standard style check options are enabled. The switch @code{-gnatyN} clears any previously set style checks. @node Run-Time Checks,Using gcc for Syntax Checking,Style Checking,Compiler Switches -@anchor{gnat_ugn/building_executable_programs_with_gnat id19}@anchor{f5}@anchor{gnat_ugn/building_executable_programs_with_gnat run-time-checks}@anchor{ea} +@anchor{gnat_ugn/building_executable_programs_with_gnat id19}@anchor{f7}@anchor{gnat_ugn/building_executable_programs_with_gnat run-time-checks}@anchor{ec} @subsection Run-Time Checks @@ -14204,7 +14322,7 @@ on subprogram calls and generic instantiations. Note that @code{-gnatE} is not necessary for safety, because in the default mode, GNAT ensures statically that the checks would not fail. For full details of the effect and use of this switch, -@ref{c7,,Compiling with gcc}. +@ref{c9,,Compiling with gcc}. @end table @geindex -fstack-check (gcc) @@ -14220,7 +14338,7 @@ For full details of the effect and use of this switch, @item @code{-fstack-check} Activates stack overflow checking. For full details of the effect and use of -this switch see @ref{e5,,Stack Overflow Checking}. +this switch see @ref{e7,,Stack Overflow Checking}. @end table @geindex Unsuppress @@ -14231,7 +14349,7 @@ checks) or @code{Unsuppress} (to add back suppressed checks) pragmas in the program source. @node Using gcc for Syntax Checking,Using gcc for Semantic Checking,Run-Time Checks,Compiler Switches -@anchor{gnat_ugn/building_executable_programs_with_gnat id20}@anchor{f6}@anchor{gnat_ugn/building_executable_programs_with_gnat using-gcc-for-syntax-checking}@anchor{f7} +@anchor{gnat_ugn/building_executable_programs_with_gnat id20}@anchor{f8}@anchor{gnat_ugn/building_executable_programs_with_gnat using-gcc-for-syntax-checking}@anchor{f9} @subsection Using @code{gcc} for Syntax Checking @@ -14288,7 +14406,7 @@ together. This is primarily used by the @code{gnatchop} utility @end table @node Using gcc for Semantic Checking,Compiling Different Versions of Ada,Using gcc for Syntax Checking,Compiler Switches -@anchor{gnat_ugn/building_executable_programs_with_gnat id21}@anchor{f8}@anchor{gnat_ugn/building_executable_programs_with_gnat using-gcc-for-semantic-checking}@anchor{f9} +@anchor{gnat_ugn/building_executable_programs_with_gnat id21}@anchor{fa}@anchor{gnat_ugn/building_executable_programs_with_gnat using-gcc-for-semantic-checking}@anchor{fb} @subsection Using @code{gcc} for Semantic Checking @@ -14335,7 +14453,7 @@ and specifications where a separate body is present). @end table @node Compiling Different Versions of Ada,Character Set Control,Using gcc for Semantic Checking,Compiler Switches -@anchor{gnat_ugn/building_executable_programs_with_gnat compiling-different-versions-of-ada}@anchor{6}@anchor{gnat_ugn/building_executable_programs_with_gnat id22}@anchor{fa} +@anchor{gnat_ugn/building_executable_programs_with_gnat compiling-different-versions-of-ada}@anchor{6}@anchor{gnat_ugn/building_executable_programs_with_gnat id22}@anchor{fc} @subsection Compiling Different Versions of Ada @@ -14500,7 +14618,7 @@ extensions enabled by this switch, see the GNAT reference manual @end table @node Character Set Control,File Naming Control,Compiling Different Versions of Ada,Compiler Switches -@anchor{gnat_ugn/building_executable_programs_with_gnat character-set-control}@anchor{31}@anchor{gnat_ugn/building_executable_programs_with_gnat id23}@anchor{fb} +@anchor{gnat_ugn/building_executable_programs_with_gnat character-set-control}@anchor{31}@anchor{gnat_ugn/building_executable_programs_with_gnat id23}@anchor{fd} @subsection Character Set Control @@ -14727,7 +14845,7 @@ comments are ended by an appropriate (CR, or CR/LF, or LF) line terminator. This is a common mode for many programs with foreign language comments. @node File Naming Control,Subprogram Inlining Control,Character Set Control,Compiler Switches -@anchor{gnat_ugn/building_executable_programs_with_gnat file-naming-control}@anchor{fc}@anchor{gnat_ugn/building_executable_programs_with_gnat id24}@anchor{fd} +@anchor{gnat_ugn/building_executable_programs_with_gnat file-naming-control}@anchor{fe}@anchor{gnat_ugn/building_executable_programs_with_gnat id24}@anchor{ff} @subsection File Naming Control @@ -14747,7 +14865,7 @@ For the source file naming rules, @ref{3b,,File Naming Rules}. @end table @node Subprogram Inlining Control,Auxiliary Output Control,File Naming Control,Compiler Switches -@anchor{gnat_ugn/building_executable_programs_with_gnat id25}@anchor{fe}@anchor{gnat_ugn/building_executable_programs_with_gnat subprogram-inlining-control}@anchor{ff} +@anchor{gnat_ugn/building_executable_programs_with_gnat id25}@anchor{100}@anchor{gnat_ugn/building_executable_programs_with_gnat subprogram-inlining-control}@anchor{101} @subsection Subprogram Inlining Control @@ -14780,7 +14898,7 @@ If you specify this switch the compiler will access these bodies, creating an extra source dependency for the resulting object file, and where possible, the call will be inlined. For further details on when inlining is possible -see @ref{100,,Inlining of Subprograms}. +see @ref{102,,Inlining of Subprograms}. @end table @geindex -gnatN (gcc) @@ -14800,7 +14918,7 @@ inlining, but that is no longer the case. @end table @node Auxiliary Output Control,Debugging Control,Subprogram Inlining Control,Compiler Switches -@anchor{gnat_ugn/building_executable_programs_with_gnat auxiliary-output-control}@anchor{101}@anchor{gnat_ugn/building_executable_programs_with_gnat id26}@anchor{102} +@anchor{gnat_ugn/building_executable_programs_with_gnat auxiliary-output-control}@anchor{103}@anchor{gnat_ugn/building_executable_programs_with_gnat id26}@anchor{104} @subsection Auxiliary Output Control @@ -14870,7 +14988,7 @@ An object file has been generated for every source file. @end table @node Debugging Control,Exception Handling Control,Auxiliary Output Control,Compiler Switches -@anchor{gnat_ugn/building_executable_programs_with_gnat debugging-control}@anchor{103}@anchor{gnat_ugn/building_executable_programs_with_gnat id27}@anchor{104} +@anchor{gnat_ugn/building_executable_programs_with_gnat debugging-control}@anchor{105}@anchor{gnat_ugn/building_executable_programs_with_gnat id27}@anchor{106} @subsection Debugging Control @@ -15219,7 +15337,7 @@ encodings for the rest. @end table @node Exception Handling Control,Units to Sources Mapping Files,Debugging Control,Compiler Switches -@anchor{gnat_ugn/building_executable_programs_with_gnat exception-handling-control}@anchor{105}@anchor{gnat_ugn/building_executable_programs_with_gnat id28}@anchor{106} +@anchor{gnat_ugn/building_executable_programs_with_gnat exception-handling-control}@anchor{107}@anchor{gnat_ugn/building_executable_programs_with_gnat id28}@anchor{108} @subsection Exception Handling Control @@ -15287,11 +15405,11 @@ is available for the target in use, otherwise it will generate an error. The same option @code{--RTS} must be used both for @code{gcc} and @code{gnatbind}. Passing this option to @code{gnatmake} -(@ref{ce,,Switches for gnatmake}) will ensure the required consistency +(@ref{d0,,Switches for gnatmake}) will ensure the required consistency through the compilation and binding steps. @node Units to Sources Mapping Files,Code Generation Control,Exception Handling Control,Compiler Switches -@anchor{gnat_ugn/building_executable_programs_with_gnat id29}@anchor{107}@anchor{gnat_ugn/building_executable_programs_with_gnat units-to-sources-mapping-files}@anchor{e8} +@anchor{gnat_ugn/building_executable_programs_with_gnat id29}@anchor{109}@anchor{gnat_ugn/building_executable_programs_with_gnat units-to-sources-mapping-files}@anchor{ea} @subsection Units to Sources Mapping Files @@ -15343,7 +15461,7 @@ mapping file and communicates it to the compiler using this switch. @end table @node Code Generation Control,,Units to Sources Mapping Files,Compiler Switches -@anchor{gnat_ugn/building_executable_programs_with_gnat code-generation-control}@anchor{108}@anchor{gnat_ugn/building_executable_programs_with_gnat id30}@anchor{109} +@anchor{gnat_ugn/building_executable_programs_with_gnat code-generation-control}@anchor{10a}@anchor{gnat_ugn/building_executable_programs_with_gnat id30}@anchor{10b} @subsection Code Generation Control @@ -15372,7 +15490,7 @@ there is no point in using @code{-m} switches to improve performance unless you actually see a performance improvement. @node Linker Switches,Binding with gnatbind,Compiler Switches,Building Executable Programs with GNAT -@anchor{gnat_ugn/building_executable_programs_with_gnat id31}@anchor{10a}@anchor{gnat_ugn/building_executable_programs_with_gnat linker-switches}@anchor{10b} +@anchor{gnat_ugn/building_executable_programs_with_gnat id31}@anchor{10c}@anchor{gnat_ugn/building_executable_programs_with_gnat linker-switches}@anchor{10d} @section Linker Switches @@ -15393,7 +15511,7 @@ platforms. @end table @node Binding with gnatbind,Linking with gnatlink,Linker Switches,Building Executable Programs with GNAT -@anchor{gnat_ugn/building_executable_programs_with_gnat binding-with-gnatbind}@anchor{c8}@anchor{gnat_ugn/building_executable_programs_with_gnat id32}@anchor{10c} +@anchor{gnat_ugn/building_executable_programs_with_gnat binding-with-gnatbind}@anchor{ca}@anchor{gnat_ugn/building_executable_programs_with_gnat id32}@anchor{10e} @section Binding with @code{gnatbind} @@ -15444,7 +15562,7 @@ to be read by the @code{gnatlink} utility used to link the Ada application. @end menu @node Running gnatbind,Switches for gnatbind,,Binding with gnatbind -@anchor{gnat_ugn/building_executable_programs_with_gnat id33}@anchor{10d}@anchor{gnat_ugn/building_executable_programs_with_gnat running-gnatbind}@anchor{10e} +@anchor{gnat_ugn/building_executable_programs_with_gnat id33}@anchor{10f}@anchor{gnat_ugn/building_executable_programs_with_gnat running-gnatbind}@anchor{110} @subsection Running @code{gnatbind} @@ -15529,7 +15647,7 @@ Ada code provided the @code{-g} switch is used for @code{gnatbind} and @code{gnatlink}. @node Switches for gnatbind,Command-Line Access,Running gnatbind,Binding with gnatbind -@anchor{gnat_ugn/building_executable_programs_with_gnat id34}@anchor{10f}@anchor{gnat_ugn/building_executable_programs_with_gnat switches-for-gnatbind}@anchor{110} +@anchor{gnat_ugn/building_executable_programs_with_gnat id34}@anchor{111}@anchor{gnat_ugn/building_executable_programs_with_gnat switches-for-gnatbind}@anchor{112} @subsection Switches for @code{gnatbind} @@ -15724,7 +15842,7 @@ Currently the same as @code{-Ea}. @item @code{-f`elab-order'} -Force elaboration order. For further details see @ref{111,,Elaboration Control} +Force elaboration order. For further details see @ref{113,,Elaboration Control} and @ref{f,,Elaboration Order Handling in GNAT}. @end table @@ -15773,7 +15891,7 @@ Legacy elaboration order model enabled. For further details see @item @code{-H32} Use 32-bit allocations for @code{__gnat_malloc} (and thus for access types). -For further details see @ref{112,,Dynamic Allocation Control}. +For further details see @ref{114,,Dynamic Allocation Control}. @end table @geindex -H64 (gnatbind) @@ -15786,7 +15904,7 @@ For further details see @ref{112,,Dynamic Allocation Control}. @item @code{-H64} Use 64-bit allocations for @code{__gnat_malloc} (and thus for access types). -For further details see @ref{112,,Dynamic Allocation Control}. +For further details see @ref{114,,Dynamic Allocation Control}. @geindex -I (gnatbind) @@ -15900,7 +16018,7 @@ Do not look for library files in the system default directory. @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}). +equivalent @code{gnatmake} flag (@ref{d0,,Switches for gnatmake}). @geindex -o (gnatbind) @@ -15996,7 +16114,7 @@ one bits. For floating-point, a large value is set The underlying scalar is set to a value consisting of repeated bytes, whose value corresponds to the given value. For example if @code{BF} is given, -then a 32-bit scalar value will be set to the bit patterm @code{16#BFBFBFBF#}. +then a 32-bit scalar value will be set to the bit pattern @code{16#BFBFBFBF#}. @end itemize @geindex GNAT_INIT_SCALARS @@ -16054,7 +16172,7 @@ Enable dynamic stack usage, with @code{n} results stored and displayed at program termination. A result is generated when a task terminates. Results that can’t be stored are displayed on the fly, at task termination. This option is currently not supported on Itanium -platforms. (See @ref{113,,Dynamic Stack Usage Analysis} for details.) +platforms. (See @ref{115,,Dynamic Stack Usage Analysis} for details.) @geindex -v (gnatbind) @@ -16134,7 +16252,7 @@ no arguments. @end menu @node Consistency-Checking Modes,Binder Error Message Control,,Switches for gnatbind -@anchor{gnat_ugn/building_executable_programs_with_gnat consistency-checking-modes}@anchor{114}@anchor{gnat_ugn/building_executable_programs_with_gnat id35}@anchor{115} +@anchor{gnat_ugn/building_executable_programs_with_gnat consistency-checking-modes}@anchor{116}@anchor{gnat_ugn/building_executable_programs_with_gnat id35}@anchor{117} @subsubsection Consistency-Checking Modes @@ -16188,7 +16306,7 @@ case the checking against sources has already been performed by @end table @node Binder Error Message Control,Elaboration Control,Consistency-Checking Modes,Switches for gnatbind -@anchor{gnat_ugn/building_executable_programs_with_gnat binder-error-message-control}@anchor{116}@anchor{gnat_ugn/building_executable_programs_with_gnat id36}@anchor{117} +@anchor{gnat_ugn/building_executable_programs_with_gnat binder-error-message-control}@anchor{118}@anchor{gnat_ugn/building_executable_programs_with_gnat id36}@anchor{119} @subsubsection Binder Error Message Control @@ -16298,7 +16416,7 @@ with extreme care. @end table @node Elaboration Control,Output Control,Binder Error Message Control,Switches for gnatbind -@anchor{gnat_ugn/building_executable_programs_with_gnat elaboration-control}@anchor{111}@anchor{gnat_ugn/building_executable_programs_with_gnat id37}@anchor{118} +@anchor{gnat_ugn/building_executable_programs_with_gnat elaboration-control}@anchor{113}@anchor{gnat_ugn/building_executable_programs_with_gnat id37}@anchor{11a} @subsubsection Elaboration Control @@ -16383,7 +16501,7 @@ debugging/experimental use. @end table @node Output Control,Dynamic Allocation Control,Elaboration Control,Switches for gnatbind -@anchor{gnat_ugn/building_executable_programs_with_gnat id38}@anchor{119}@anchor{gnat_ugn/building_executable_programs_with_gnat output-control}@anchor{11a} +@anchor{gnat_ugn/building_executable_programs_with_gnat id38}@anchor{11b}@anchor{gnat_ugn/building_executable_programs_with_gnat output-control}@anchor{11c} @subsubsection Output Control @@ -16464,7 +16582,7 @@ be used to improve code generation in some cases. @end table @node Dynamic Allocation Control,Binding with Non-Ada Main Programs,Output Control,Switches for gnatbind -@anchor{gnat_ugn/building_executable_programs_with_gnat dynamic-allocation-control}@anchor{112}@anchor{gnat_ugn/building_executable_programs_with_gnat id39}@anchor{11b} +@anchor{gnat_ugn/building_executable_programs_with_gnat dynamic-allocation-control}@anchor{114}@anchor{gnat_ugn/building_executable_programs_with_gnat id39}@anchor{11d} @subsubsection Dynamic Allocation Control @@ -16490,7 +16608,7 @@ unless explicitly overridden by a @code{'Size} clause on the access type. These switches are only effective on VMS platforms. @node Binding with Non-Ada Main Programs,Binding Programs with No Main Subprogram,Dynamic Allocation Control,Switches for gnatbind -@anchor{gnat_ugn/building_executable_programs_with_gnat binding-with-non-ada-main-programs}@anchor{a0}@anchor{gnat_ugn/building_executable_programs_with_gnat id40}@anchor{11c} +@anchor{gnat_ugn/building_executable_programs_with_gnat binding-with-non-ada-main-programs}@anchor{a0}@anchor{gnat_ugn/building_executable_programs_with_gnat id40}@anchor{11e} @subsubsection Binding with Non-Ada Main Programs @@ -16586,7 +16704,7 @@ side effect is that this could be the wrong mode for the foreign code where floating point computation could be broken after this call. @node Binding Programs with No Main Subprogram,,Binding with Non-Ada Main Programs,Switches for gnatbind -@anchor{gnat_ugn/building_executable_programs_with_gnat binding-programs-with-no-main-subprogram}@anchor{11d}@anchor{gnat_ugn/building_executable_programs_with_gnat id41}@anchor{11e} +@anchor{gnat_ugn/building_executable_programs_with_gnat binding-programs-with-no-main-subprogram}@anchor{11f}@anchor{gnat_ugn/building_executable_programs_with_gnat id41}@anchor{120} @subsubsection Binding Programs with No Main Subprogram @@ -16617,7 +16735,7 @@ the binder switch @end table @node Command-Line Access,Search Paths for gnatbind,Switches for gnatbind,Binding with gnatbind -@anchor{gnat_ugn/building_executable_programs_with_gnat command-line-access}@anchor{11f}@anchor{gnat_ugn/building_executable_programs_with_gnat id42}@anchor{120} +@anchor{gnat_ugn/building_executable_programs_with_gnat command-line-access}@anchor{121}@anchor{gnat_ugn/building_executable_programs_with_gnat id42}@anchor{122} @subsection Command-Line Access @@ -16647,7 +16765,7 @@ required, your main program must set @code{gnat_argc} and it. @node Search Paths for gnatbind,Examples of gnatbind Usage,Command-Line Access,Binding with gnatbind -@anchor{gnat_ugn/building_executable_programs_with_gnat id43}@anchor{121}@anchor{gnat_ugn/building_executable_programs_with_gnat search-paths-for-gnatbind}@anchor{76} +@anchor{gnat_ugn/building_executable_programs_with_gnat id43}@anchor{123}@anchor{gnat_ugn/building_executable_programs_with_gnat search-paths-for-gnatbind}@anchor{76} @subsection Search Paths for @code{gnatbind} @@ -16751,7 +16869,7 @@ in compiling sources from multiple directories. This can make development environments much more flexible. @node Examples of gnatbind Usage,,Search Paths for gnatbind,Binding with gnatbind -@anchor{gnat_ugn/building_executable_programs_with_gnat examples-of-gnatbind-usage}@anchor{122}@anchor{gnat_ugn/building_executable_programs_with_gnat id44}@anchor{123} +@anchor{gnat_ugn/building_executable_programs_with_gnat examples-of-gnatbind-usage}@anchor{124}@anchor{gnat_ugn/building_executable_programs_with_gnat id44}@anchor{125} @subsection Examples of @code{gnatbind} Usage @@ -16780,7 +16898,7 @@ since gnatlink will not be able to find the generated file. @end quotation @node Linking with gnatlink,Using the GNU make Utility,Binding with gnatbind,Building Executable Programs with GNAT -@anchor{gnat_ugn/building_executable_programs_with_gnat id45}@anchor{124}@anchor{gnat_ugn/building_executable_programs_with_gnat linking-with-gnatlink}@anchor{c9} +@anchor{gnat_ugn/building_executable_programs_with_gnat id45}@anchor{126}@anchor{gnat_ugn/building_executable_programs_with_gnat linking-with-gnatlink}@anchor{cb} @section Linking with @code{gnatlink} @@ -16801,7 +16919,7 @@ generated by the @code{gnatbind} to determine this list. @end menu @node Running gnatlink,Switches for gnatlink,,Linking with gnatlink -@anchor{gnat_ugn/building_executable_programs_with_gnat id46}@anchor{125}@anchor{gnat_ugn/building_executable_programs_with_gnat running-gnatlink}@anchor{126} +@anchor{gnat_ugn/building_executable_programs_with_gnat id46}@anchor{127}@anchor{gnat_ugn/building_executable_programs_with_gnat running-gnatlink}@anchor{128} @subsection Running @code{gnatlink} @@ -16860,8 +16978,8 @@ $ gnatlink my_prog -Wl,-Map,MAPFILE Using @code{linker options} it is possible to set the program stack and heap size. -See @ref{127,,Setting Stack Size from gnatlink} and -@ref{128,,Setting Heap Size from gnatlink}. +See @ref{129,,Setting Stack Size from gnatlink} and +@ref{12a,,Setting Heap Size from gnatlink}. @code{gnatlink} determines the list of objects required by the Ada program and prepends them to the list of objects passed to the linker. @@ -16870,7 +16988,7 @@ program and prepends them to the list of objects passed to the linker. presented to the linker. @node Switches for gnatlink,,Running gnatlink,Linking with gnatlink -@anchor{gnat_ugn/building_executable_programs_with_gnat id47}@anchor{129}@anchor{gnat_ugn/building_executable_programs_with_gnat switches-for-gnatlink}@anchor{12a} +@anchor{gnat_ugn/building_executable_programs_with_gnat id47}@anchor{12b}@anchor{gnat_ugn/building_executable_programs_with_gnat switches-for-gnatlink}@anchor{12c} @subsection Switches for @code{gnatlink} @@ -17065,7 +17183,7 @@ switch. @end table @node Using the GNU make Utility,,Linking with gnatlink,Building Executable Programs with GNAT -@anchor{gnat_ugn/building_executable_programs_with_gnat id48}@anchor{12b}@anchor{gnat_ugn/building_executable_programs_with_gnat using-the-gnu-make-utility}@anchor{70} +@anchor{gnat_ugn/building_executable_programs_with_gnat id48}@anchor{12d}@anchor{gnat_ugn/building_executable_programs_with_gnat using-the-gnu-make-utility}@anchor{70} @section Using the GNU @code{make} Utility @@ -17074,7 +17192,7 @@ switch. This chapter offers some examples of makefiles that solve specific problems. It does not explain how to write a makefile, nor does it try to replace the -@code{gnatmake} utility (@ref{c6,,Building with gnatmake}). +@code{gnatmake} utility (@ref{c8,,Building with gnatmake}). All the examples in this section are specific to the GNU version of make. Although @code{make} is a standard utility, and the basic language @@ -17090,7 +17208,7 @@ is the same, these examples use some advanced features found only in @end menu @node Using gnatmake in a Makefile,Automatically Creating a List of Directories,,Using the GNU make Utility -@anchor{gnat_ugn/building_executable_programs_with_gnat id49}@anchor{12c}@anchor{gnat_ugn/building_executable_programs_with_gnat using-gnatmake-in-a-makefile}@anchor{12d} +@anchor{gnat_ugn/building_executable_programs_with_gnat id49}@anchor{12e}@anchor{gnat_ugn/building_executable_programs_with_gnat using-gnatmake-in-a-makefile}@anchor{12f} @subsection Using gnatmake in a Makefile @@ -17109,7 +17227,7 @@ the appropriate directories. Note that you should also read the example on how to automatically create the list of directories -(@ref{12e,,Automatically Creating a List of Directories}) +(@ref{130,,Automatically Creating a List of Directories}) which might help you in case your project has a lot of subdirectories. @example @@ -17189,7 +17307,7 @@ clean:: @end example @node Automatically Creating a List of Directories,Generating the Command Line Switches,Using gnatmake in a Makefile,Using the GNU make Utility -@anchor{gnat_ugn/building_executable_programs_with_gnat automatically-creating-a-list-of-directories}@anchor{12e}@anchor{gnat_ugn/building_executable_programs_with_gnat id50}@anchor{12f} +@anchor{gnat_ugn/building_executable_programs_with_gnat automatically-creating-a-list-of-directories}@anchor{130}@anchor{gnat_ugn/building_executable_programs_with_gnat id50}@anchor{131} @subsection Automatically Creating a List of Directories @@ -17262,12 +17380,12 @@ DIRS := $@{shell find $@{ROOT_DIRECTORY@} -type d -print@} @end example @node Generating the Command Line Switches,Overcoming Command Line Length Limits,Automatically Creating a List of Directories,Using the GNU make Utility -@anchor{gnat_ugn/building_executable_programs_with_gnat generating-the-command-line-switches}@anchor{130}@anchor{gnat_ugn/building_executable_programs_with_gnat id51}@anchor{131} +@anchor{gnat_ugn/building_executable_programs_with_gnat generating-the-command-line-switches}@anchor{132}@anchor{gnat_ugn/building_executable_programs_with_gnat id51}@anchor{133} @subsection Generating the Command Line Switches Once you have created the list of directories as explained in the -previous section (@ref{12e,,Automatically Creating a List of Directories}), +previous section (@ref{130,,Automatically Creating a List of Directories}), you can easily generate the command line arguments to pass to gnatmake. For the sake of completeness, this example assumes that the source path @@ -17288,7 +17406,7 @@ all: @end example @node Overcoming Command Line Length Limits,,Generating the Command Line Switches,Using the GNU make Utility -@anchor{gnat_ugn/building_executable_programs_with_gnat id52}@anchor{132}@anchor{gnat_ugn/building_executable_programs_with_gnat overcoming-command-line-length-limits}@anchor{133} +@anchor{gnat_ugn/building_executable_programs_with_gnat id52}@anchor{134}@anchor{gnat_ugn/building_executable_programs_with_gnat overcoming-command-line-length-limits}@anchor{135} @subsection Overcoming Command Line Length Limits @@ -17303,7 +17421,7 @@ even none on most systems). It assumes that you have created a list of directories in your Makefile, using one of the methods presented in -@ref{12e,,Automatically Creating a List of Directories}. +@ref{130,,Automatically Creating a List of Directories}. For the sake of completeness, we assume that the object path (where the ALI files are found) is different from the sources patch. @@ -17346,7 +17464,7 @@ all: @end example @node GNAT Utility Programs,GNAT and Program Execution,Building Executable Programs with GNAT,Top -@anchor{gnat_ugn/gnat_utility_programs doc}@anchor{134}@anchor{gnat_ugn/gnat_utility_programs gnat-utility-programs}@anchor{b}@anchor{gnat_ugn/gnat_utility_programs id1}@anchor{135} +@anchor{gnat_ugn/gnat_utility_programs doc}@anchor{136}@anchor{gnat_ugn/gnat_utility_programs gnat-utility-programs}@anchor{b}@anchor{gnat_ugn/gnat_utility_programs id1}@anchor{137} @chapter GNAT Utility Programs @@ -17357,10 +17475,10 @@ This chapter describes a number of utility programs: @itemize * @item -@ref{136,,The File Cleanup Utility gnatclean} +@ref{138,,The File Cleanup Utility gnatclean} @item -@ref{137,,The GNAT Library Browser gnatls} +@ref{139,,The GNAT Library Browser gnatls} @end itemize Other GNAT utilities are described elsewhere in this manual: @@ -17388,7 +17506,7 @@ Other GNAT utilities are described elsewhere in this manual: @end menu @node The File Cleanup Utility gnatclean,The GNAT Library Browser gnatls,,GNAT Utility Programs -@anchor{gnat_ugn/gnat_utility_programs id2}@anchor{138}@anchor{gnat_ugn/gnat_utility_programs the-file-cleanup-utility-gnatclean}@anchor{136} +@anchor{gnat_ugn/gnat_utility_programs id2}@anchor{13a}@anchor{gnat_ugn/gnat_utility_programs the-file-cleanup-utility-gnatclean}@anchor{138} @section The File Cleanup Utility @code{gnatclean} @@ -17408,7 +17526,7 @@ generated files and executable files. @end menu @node Running gnatclean,Switches for gnatclean,,The File Cleanup Utility gnatclean -@anchor{gnat_ugn/gnat_utility_programs id3}@anchor{139}@anchor{gnat_ugn/gnat_utility_programs running-gnatclean}@anchor{13a} +@anchor{gnat_ugn/gnat_utility_programs id3}@anchor{13b}@anchor{gnat_ugn/gnat_utility_programs running-gnatclean}@anchor{13c} @subsection Running @code{gnatclean} @@ -17432,7 +17550,7 @@ the linker. In informative-only mode, specified by switch normal mode is listed, but no file is actually deleted. @node Switches for gnatclean,,Running gnatclean,The File Cleanup Utility gnatclean -@anchor{gnat_ugn/gnat_utility_programs id4}@anchor{13b}@anchor{gnat_ugn/gnat_utility_programs switches-for-gnatclean}@anchor{13c} +@anchor{gnat_ugn/gnat_utility_programs id4}@anchor{13d}@anchor{gnat_ugn/gnat_utility_programs switches-for-gnatclean}@anchor{13e} @subsection Switches for @code{gnatclean} @@ -17583,7 +17701,7 @@ Verbose mode. @item @code{-vP`x'} Indicates the verbosity of the parsing of GNAT project files. -@ref{cf,,Switches Related to Project Files}. +@ref{d1,,Switches Related to Project Files}. @end table @geindex -X (gnatclean) @@ -17596,7 +17714,7 @@ Indicates the verbosity of the parsing of GNAT project files. Indicates that external variable @code{name} has the value @code{value}. The Project Manager will use this value for occurrences of @code{external(name)} when parsing the project file. -See @ref{cf,,Switches Related to Project Files}. +See @ref{d1,,Switches Related to Project Files}. @end table @geindex -aO (gnatclean) @@ -17634,7 +17752,7 @@ where @code{gnatclean} was invoked. @end table @node The GNAT Library Browser gnatls,,The File Cleanup Utility gnatclean,GNAT Utility Programs -@anchor{gnat_ugn/gnat_utility_programs id5}@anchor{13d}@anchor{gnat_ugn/gnat_utility_programs the-gnat-library-browser-gnatls}@anchor{137} +@anchor{gnat_ugn/gnat_utility_programs id5}@anchor{13f}@anchor{gnat_ugn/gnat_utility_programs the-gnat-library-browser-gnatls}@anchor{139} @section The GNAT Library Browser @code{gnatls} @@ -17655,7 +17773,7 @@ as well as various characteristics. @end menu @node Running gnatls,Switches for gnatls,,The GNAT Library Browser gnatls -@anchor{gnat_ugn/gnat_utility_programs id6}@anchor{13e}@anchor{gnat_ugn/gnat_utility_programs running-gnatls}@anchor{13f} +@anchor{gnat_ugn/gnat_utility_programs id6}@anchor{140}@anchor{gnat_ugn/gnat_utility_programs running-gnatls}@anchor{141} @subsection Running @code{gnatls} @@ -17735,7 +17853,7 @@ version of the same source that has been modified. @end table @node Switches for gnatls,Example of gnatls Usage,Running gnatls,The GNAT Library Browser gnatls -@anchor{gnat_ugn/gnat_utility_programs id7}@anchor{140}@anchor{gnat_ugn/gnat_utility_programs switches-for-gnatls}@anchor{141} +@anchor{gnat_ugn/gnat_utility_programs id7}@anchor{142}@anchor{gnat_ugn/gnat_utility_programs switches-for-gnatls}@anchor{143} @subsection Switches for @code{gnatls} @@ -17850,7 +17968,7 @@ Several such switches may be specified simultaneously. @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}). +flags (@ref{d0,,Switches for gnatmake}). @end table @geindex -aP (gnatls) @@ -17871,7 +17989,7 @@ Add @code{dir} at the beginning of the project search dir. @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}). +equivalent @code{gnatmake} flag (@ref{d0,,Switches for gnatmake}). @end table @geindex -v (gnatls) @@ -17917,7 +18035,7 @@ by the user. @end table @node Example of gnatls Usage,,Switches for gnatls,The GNAT Library Browser gnatls -@anchor{gnat_ugn/gnat_utility_programs example-of-gnatls-usage}@anchor{142}@anchor{gnat_ugn/gnat_utility_programs id8}@anchor{143} +@anchor{gnat_ugn/gnat_utility_programs example-of-gnatls-usage}@anchor{144}@anchor{gnat_ugn/gnat_utility_programs id8}@anchor{145} @subsection Example of @code{gnatls} Usage @@ -18003,7 +18121,7 @@ instr.ads @c -- Example: A |withing| unit has a |with| clause, it |withs| a |withed| unit @node GNAT and Program Execution,Platform-Specific Information,GNAT Utility Programs,Top -@anchor{gnat_ugn/gnat_and_program_execution doc}@anchor{144}@anchor{gnat_ugn/gnat_and_program_execution gnat-and-program-execution}@anchor{c}@anchor{gnat_ugn/gnat_and_program_execution id1}@anchor{145} +@anchor{gnat_ugn/gnat_and_program_execution doc}@anchor{146}@anchor{gnat_ugn/gnat_and_program_execution gnat-and-program-execution}@anchor{c}@anchor{gnat_ugn/gnat_and_program_execution id1}@anchor{147} @chapter GNAT and Program Execution @@ -18013,25 +18131,25 @@ This chapter covers several topics: @itemize * @item -@ref{146,,Running and Debugging Ada Programs} +@ref{148,,Running and Debugging Ada Programs} @item -@ref{147,,Profiling} +@ref{149,,Profiling} @item -@ref{148,,Improving Performance} +@ref{14a,,Improving Performance} @item -@ref{149,,Overflow Check Handling in GNAT} +@ref{14b,,Overflow Check Handling in GNAT} @item -@ref{14a,,Performing Dimensionality Analysis in GNAT} +@ref{14c,,Performing Dimensionality Analysis in GNAT} @item -@ref{14b,,Stack Related Facilities} +@ref{14d,,Stack Related Facilities} @item -@ref{14c,,Memory Management Issues} +@ref{14e,,Memory Management Issues} @end itemize @menu @@ -18046,7 +18164,7 @@ This chapter covers several topics: @end menu @node Running and Debugging Ada Programs,Profiling,,GNAT and Program Execution -@anchor{gnat_ugn/gnat_and_program_execution id2}@anchor{146}@anchor{gnat_ugn/gnat_and_program_execution running-and-debugging-ada-programs}@anchor{14d} +@anchor{gnat_ugn/gnat_and_program_execution id2}@anchor{148}@anchor{gnat_ugn/gnat_and_program_execution running-and-debugging-ada-programs}@anchor{14f} @section Running and Debugging Ada Programs @@ -18100,7 +18218,7 @@ the incorrect user program. @end menu @node The GNAT Debugger GDB,Running GDB,,Running and Debugging Ada Programs -@anchor{gnat_ugn/gnat_and_program_execution id3}@anchor{14e}@anchor{gnat_ugn/gnat_and_program_execution the-gnat-debugger-gdb}@anchor{14f} +@anchor{gnat_ugn/gnat_and_program_execution id3}@anchor{150}@anchor{gnat_ugn/gnat_and_program_execution the-gnat-debugger-gdb}@anchor{151} @subsection The GNAT Debugger GDB @@ -18157,7 +18275,7 @@ the debugging information and can respond to user commands to inspect variables, and more generally to report on the state of execution. @node Running GDB,Introduction to GDB Commands,The GNAT Debugger GDB,Running and Debugging Ada Programs -@anchor{gnat_ugn/gnat_and_program_execution id4}@anchor{150}@anchor{gnat_ugn/gnat_and_program_execution running-gdb}@anchor{151} +@anchor{gnat_ugn/gnat_and_program_execution id4}@anchor{152}@anchor{gnat_ugn/gnat_and_program_execution running-gdb}@anchor{153} @subsection Running GDB @@ -18184,7 +18302,7 @@ exactly as if the debugger were not present. The following section describes some of the additional commands that can be given to @code{GDB}. @node Introduction to GDB Commands,Using Ada Expressions,Running GDB,Running and Debugging Ada Programs -@anchor{gnat_ugn/gnat_and_program_execution id5}@anchor{152}@anchor{gnat_ugn/gnat_and_program_execution introduction-to-gdb-commands}@anchor{153} +@anchor{gnat_ugn/gnat_and_program_execution id5}@anchor{154}@anchor{gnat_ugn/gnat_and_program_execution introduction-to-gdb-commands}@anchor{155} @subsection Introduction to GDB Commands @@ -18392,7 +18510,7 @@ Note that most commands can be abbreviated (for example, c for continue, bt for backtrace). @node Using Ada Expressions,Calling User-Defined Subprograms,Introduction to GDB Commands,Running and Debugging Ada Programs -@anchor{gnat_ugn/gnat_and_program_execution id6}@anchor{154}@anchor{gnat_ugn/gnat_and_program_execution using-ada-expressions}@anchor{155} +@anchor{gnat_ugn/gnat_and_program_execution id6}@anchor{156}@anchor{gnat_ugn/gnat_and_program_execution using-ada-expressions}@anchor{157} @subsection Using Ada Expressions @@ -18430,7 +18548,7 @@ their packages, regardless of context. Where this causes ambiguity, For details on the supported Ada syntax, see @cite{Debugging with GDB}. @node Calling User-Defined Subprograms,Using the next Command in a Function,Using Ada Expressions,Running and Debugging Ada Programs -@anchor{gnat_ugn/gnat_and_program_execution calling-user-defined-subprograms}@anchor{156}@anchor{gnat_ugn/gnat_and_program_execution id7}@anchor{157} +@anchor{gnat_ugn/gnat_and_program_execution calling-user-defined-subprograms}@anchor{158}@anchor{gnat_ugn/gnat_and_program_execution id7}@anchor{159} @subsection Calling User-Defined Subprograms @@ -18489,7 +18607,7 @@ elements directly from GDB, you can write a callable procedure that prints the elements in the desired format. @node Using the next Command in a Function,Stopping When Ada Exceptions Are Raised,Calling User-Defined Subprograms,Running and Debugging Ada Programs -@anchor{gnat_ugn/gnat_and_program_execution id8}@anchor{158}@anchor{gnat_ugn/gnat_and_program_execution using-the-next-command-in-a-function}@anchor{159} +@anchor{gnat_ugn/gnat_and_program_execution id8}@anchor{15a}@anchor{gnat_ugn/gnat_and_program_execution using-the-next-command-in-a-function}@anchor{15b} @subsection Using the `next' Command in a Function @@ -18512,7 +18630,7 @@ The value returned is always that from the first return statement that was stepped through. @node Stopping When Ada Exceptions Are Raised,Ada Tasks,Using the next Command in a Function,Running and Debugging Ada Programs -@anchor{gnat_ugn/gnat_and_program_execution id9}@anchor{15a}@anchor{gnat_ugn/gnat_and_program_execution stopping-when-ada-exceptions-are-raised}@anchor{15b} +@anchor{gnat_ugn/gnat_and_program_execution id9}@anchor{15c}@anchor{gnat_ugn/gnat_and_program_execution stopping-when-ada-exceptions-are-raised}@anchor{15d} @subsection Stopping When Ada Exceptions Are Raised @@ -18569,7 +18687,7 @@ argument, prints out only those exceptions whose name matches `regexp'. @geindex Tasks (in gdb) @node Ada Tasks,Debugging Generic Units,Stopping When Ada Exceptions Are Raised,Running and Debugging Ada Programs -@anchor{gnat_ugn/gnat_and_program_execution ada-tasks}@anchor{15c}@anchor{gnat_ugn/gnat_and_program_execution id10}@anchor{15d} +@anchor{gnat_ugn/gnat_and_program_execution ada-tasks}@anchor{15e}@anchor{gnat_ugn/gnat_and_program_execution id10}@anchor{15f} @subsection Ada Tasks @@ -18656,7 +18774,7 @@ see @cite{Debugging with GDB}. @geindex Generics @node Debugging Generic Units,Remote Debugging with gdbserver,Ada Tasks,Running and Debugging Ada Programs -@anchor{gnat_ugn/gnat_and_program_execution debugging-generic-units}@anchor{15e}@anchor{gnat_ugn/gnat_and_program_execution id11}@anchor{15f} +@anchor{gnat_ugn/gnat_and_program_execution debugging-generic-units}@anchor{160}@anchor{gnat_ugn/gnat_and_program_execution id11}@anchor{161} @subsection Debugging Generic Units @@ -18715,7 +18833,7 @@ other units. @geindex Remote Debugging with gdbserver @node Remote Debugging with gdbserver,GNAT Abnormal Termination or Failure to Terminate,Debugging Generic Units,Running and Debugging Ada Programs -@anchor{gnat_ugn/gnat_and_program_execution id12}@anchor{160}@anchor{gnat_ugn/gnat_and_program_execution remote-debugging-with-gdbserver}@anchor{161} +@anchor{gnat_ugn/gnat_and_program_execution id12}@anchor{162}@anchor{gnat_ugn/gnat_and_program_execution remote-debugging-with-gdbserver}@anchor{163} @subsection Remote Debugging with gdbserver @@ -18773,7 +18891,7 @@ GNAT provides support for gdbserver on x86-linux, x86-windows and x86_64-linux. @geindex Abnormal Termination or Failure to Terminate @node GNAT Abnormal Termination or Failure to Terminate,Naming Conventions for GNAT Source Files,Remote Debugging with gdbserver,Running and Debugging Ada Programs -@anchor{gnat_ugn/gnat_and_program_execution gnat-abnormal-termination-or-failure-to-terminate}@anchor{162}@anchor{gnat_ugn/gnat_and_program_execution id13}@anchor{163} +@anchor{gnat_ugn/gnat_and_program_execution gnat-abnormal-termination-or-failure-to-terminate}@anchor{164}@anchor{gnat_ugn/gnat_and_program_execution id13}@anchor{165} @subsection GNAT Abnormal Termination or Failure to Terminate @@ -18828,7 +18946,7 @@ Finally, you can start @code{gdb} directly on the @code{gnat1} executable. @code{gnat1} is the front-end of GNAT, and can be run independently (normally it is just called from @code{gcc}). You can use @code{gdb} on @code{gnat1} as you -would on a C program (but @ref{14f,,The GNAT Debugger GDB} for caveats). The +would on a C program (but @ref{151,,The GNAT Debugger GDB} for caveats). The @code{where} command is the first line of attack; the variable @code{lineno} (seen by @code{print lineno}), used by the second phase of @code{gnat1} and by the @code{gcc} backend, indicates the source line at @@ -18837,7 +18955,7 @@ the source file. @end itemize @node Naming Conventions for GNAT Source Files,Getting Internal Debugging Information,GNAT Abnormal Termination or Failure to Terminate,Running and Debugging Ada Programs -@anchor{gnat_ugn/gnat_and_program_execution id14}@anchor{164}@anchor{gnat_ugn/gnat_and_program_execution naming-conventions-for-gnat-source-files}@anchor{165} +@anchor{gnat_ugn/gnat_and_program_execution id14}@anchor{166}@anchor{gnat_ugn/gnat_and_program_execution naming-conventions-for-gnat-source-files}@anchor{167} @subsection Naming Conventions for GNAT Source Files @@ -18918,7 +19036,7 @@ the other @code{.c} files are modifications of common @code{gcc} files. @end itemize @node Getting Internal Debugging Information,Stack Traceback,Naming Conventions for GNAT Source Files,Running and Debugging Ada Programs -@anchor{gnat_ugn/gnat_and_program_execution getting-internal-debugging-information}@anchor{166}@anchor{gnat_ugn/gnat_and_program_execution id15}@anchor{167} +@anchor{gnat_ugn/gnat_and_program_execution getting-internal-debugging-information}@anchor{168}@anchor{gnat_ugn/gnat_and_program_execution id15}@anchor{169} @subsection Getting Internal Debugging Information @@ -18946,7 +19064,7 @@ are replaced with run-time calls. @geindex stack unwinding @node Stack Traceback,Pretty-Printers for the GNAT runtime,Getting Internal Debugging Information,Running and Debugging Ada Programs -@anchor{gnat_ugn/gnat_and_program_execution id16}@anchor{168}@anchor{gnat_ugn/gnat_and_program_execution stack-traceback}@anchor{169} +@anchor{gnat_ugn/gnat_and_program_execution id16}@anchor{16a}@anchor{gnat_ugn/gnat_and_program_execution stack-traceback}@anchor{16b} @subsection Stack Traceback @@ -18975,7 +19093,7 @@ is enabled, and no exception is raised during program execution. @end menu @node Non-Symbolic Traceback,Symbolic Traceback,,Stack Traceback -@anchor{gnat_ugn/gnat_and_program_execution id17}@anchor{16a}@anchor{gnat_ugn/gnat_and_program_execution non-symbolic-traceback}@anchor{16b} +@anchor{gnat_ugn/gnat_and_program_execution id17}@anchor{16c}@anchor{gnat_ugn/gnat_and_program_execution non-symbolic-traceback}@anchor{16d} @subsubsection Non-Symbolic Traceback @@ -18991,7 +19109,7 @@ 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 translate this information using the @code{addr2line} tool, provided that -the program is compiled with debugging options (see @ref{db,,Compiler Switches}) +the program is compiled with debugging options (see @ref{dd,,Compiler Switches}) and linked at a fixed position with @code{-no-pie}. Here is a simple example with @code{gnatmake}: @@ -19108,7 +19226,7 @@ $ addr2line -e stb -a -f -p --demangle=gnat 0x401373 0x40138b 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 +call to the main program. @ref{110,,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 @@ -19296,7 +19414,7 @@ addresses need to be specified in C format, with a leading ‘0x’). @geindex symbolic @node Symbolic Traceback,,Non-Symbolic Traceback,Stack Traceback -@anchor{gnat_ugn/gnat_and_program_execution id18}@anchor{16c}@anchor{gnat_ugn/gnat_and_program_execution symbolic-traceback}@anchor{16d} +@anchor{gnat_ugn/gnat_and_program_execution id18}@anchor{16e}@anchor{gnat_ugn/gnat_and_program_execution symbolic-traceback}@anchor{16f} @subsubsection Symbolic Traceback @@ -19415,7 +19533,7 @@ which will also be printed if an unhandled exception terminates the program. @node Pretty-Printers for the GNAT runtime,,Stack Traceback,Running and Debugging Ada Programs -@anchor{gnat_ugn/gnat_and_program_execution id19}@anchor{16e}@anchor{gnat_ugn/gnat_and_program_execution pretty-printers-for-the-gnat-runtime}@anchor{16f} +@anchor{gnat_ugn/gnat_and_program_execution id19}@anchor{170}@anchor{gnat_ugn/gnat_and_program_execution pretty-printers-for-the-gnat-runtime}@anchor{171} @subsection Pretty-Printers for the GNAT runtime @@ -19522,7 +19640,7 @@ for more information. @geindex Profiling @node Profiling,Improving Performance,Running and Debugging Ada Programs,GNAT and Program Execution -@anchor{gnat_ugn/gnat_and_program_execution id20}@anchor{170}@anchor{gnat_ugn/gnat_and_program_execution profiling}@anchor{147} +@anchor{gnat_ugn/gnat_and_program_execution id20}@anchor{172}@anchor{gnat_ugn/gnat_and_program_execution profiling}@anchor{149} @section Profiling @@ -19538,7 +19656,7 @@ This section describes how to use the @code{gprof} profiler tool on Ada programs @end menu @node Profiling an Ada Program with gprof,,,Profiling -@anchor{gnat_ugn/gnat_and_program_execution id21}@anchor{171}@anchor{gnat_ugn/gnat_and_program_execution profiling-an-ada-program-with-gprof}@anchor{172} +@anchor{gnat_ugn/gnat_and_program_execution id21}@anchor{173}@anchor{gnat_ugn/gnat_and_program_execution profiling-an-ada-program-with-gprof}@anchor{174} @subsection Profiling an Ada Program with gprof @@ -19592,7 +19710,7 @@ to interpret the results. @end menu @node Compilation for profiling,Program execution,,Profiling an Ada Program with gprof -@anchor{gnat_ugn/gnat_and_program_execution compilation-for-profiling}@anchor{173}@anchor{gnat_ugn/gnat_and_program_execution id22}@anchor{174} +@anchor{gnat_ugn/gnat_and_program_execution compilation-for-profiling}@anchor{175}@anchor{gnat_ugn/gnat_and_program_execution id22}@anchor{176} @subsubsection Compilation for profiling @@ -19623,7 +19741,7 @@ Note that on Windows, gprof does not support PIE. The @code{-no-pie} switch should be added to the linker flags to disable this feature. @node Program execution,Running gprof,Compilation for profiling,Profiling an Ada Program with gprof -@anchor{gnat_ugn/gnat_and_program_execution id23}@anchor{175}@anchor{gnat_ugn/gnat_and_program_execution program-execution}@anchor{176} +@anchor{gnat_ugn/gnat_and_program_execution id23}@anchor{177}@anchor{gnat_ugn/gnat_and_program_execution program-execution}@anchor{178} @subsubsection Program execution @@ -19638,7 +19756,7 @@ generated in the directory where the program was launched from. If this file already exists, it will be overwritten. @node Running gprof,Interpretation of profiling results,Program execution,Profiling an Ada Program with gprof -@anchor{gnat_ugn/gnat_and_program_execution id24}@anchor{177}@anchor{gnat_ugn/gnat_and_program_execution running-gprof}@anchor{178} +@anchor{gnat_ugn/gnat_and_program_execution id24}@anchor{179}@anchor{gnat_ugn/gnat_and_program_execution running-gprof}@anchor{17a} @subsubsection Running gprof @@ -19751,7 +19869,7 @@ may be given; only one @code{function_name} may be indicated with each @end table @node Interpretation of profiling results,,Running gprof,Profiling an Ada Program with gprof -@anchor{gnat_ugn/gnat_and_program_execution id25}@anchor{179}@anchor{gnat_ugn/gnat_and_program_execution interpretation-of-profiling-results}@anchor{17a} +@anchor{gnat_ugn/gnat_and_program_execution id25}@anchor{17b}@anchor{gnat_ugn/gnat_and_program_execution interpretation-of-profiling-results}@anchor{17c} @subsubsection Interpretation of profiling results @@ -19768,7 +19886,7 @@ and the subprograms that it calls. It also provides an estimate of the time spent in each of those callers/called subprograms. @node Improving Performance,Overflow Check Handling in GNAT,Profiling,GNAT and Program Execution -@anchor{gnat_ugn/gnat_and_program_execution id26}@anchor{148}@anchor{gnat_ugn/gnat_and_program_execution improving-performance}@anchor{17b} +@anchor{gnat_ugn/gnat_and_program_execution id26}@anchor{14a}@anchor{gnat_ugn/gnat_and_program_execution improving-performance}@anchor{17d} @section Improving Performance @@ -19789,7 +19907,7 @@ which can reduce the size of program executables. @end menu @node Performance Considerations,Text_IO Suggestions,,Improving Performance -@anchor{gnat_ugn/gnat_and_program_execution id27}@anchor{17c}@anchor{gnat_ugn/gnat_and_program_execution performance-considerations}@anchor{17d} +@anchor{gnat_ugn/gnat_and_program_execution id27}@anchor{17e}@anchor{gnat_ugn/gnat_and_program_execution performance-considerations}@anchor{17f} @subsection Performance Considerations @@ -19850,7 +19968,7 @@ some guidelines on debugging optimized code. @end menu @node Controlling Run-Time Checks,Use of Restrictions,,Performance Considerations -@anchor{gnat_ugn/gnat_and_program_execution controlling-run-time-checks}@anchor{17e}@anchor{gnat_ugn/gnat_and_program_execution id28}@anchor{17f} +@anchor{gnat_ugn/gnat_and_program_execution controlling-run-time-checks}@anchor{180}@anchor{gnat_ugn/gnat_and_program_execution id28}@anchor{181} @subsubsection Controlling Run-Time Checks @@ -19864,7 +19982,7 @@ necessary checking is done at compile time. @geindex -gnato (gcc) The gnat switch, @code{-gnatp} allows this default to be modified. See -@ref{ea,,Run-Time Checks}. +@ref{ec,,Run-Time Checks}. Our experience is that the default is suitable for most development purposes. @@ -19902,7 +20020,7 @@ remove checks) or @code{pragma Unsuppress} (to add back suppressed checks) in the program source. @node Use of Restrictions,Optimization Levels,Controlling Run-Time Checks,Performance Considerations -@anchor{gnat_ugn/gnat_and_program_execution id29}@anchor{180}@anchor{gnat_ugn/gnat_and_program_execution use-of-restrictions}@anchor{181} +@anchor{gnat_ugn/gnat_and_program_execution id29}@anchor{182}@anchor{gnat_ugn/gnat_and_program_execution use-of-restrictions}@anchor{183} @subsubsection Use of Restrictions @@ -19937,7 +20055,7 @@ that this also means that you can write code without worrying about the possibility of an immediate abort at any point. @node Optimization Levels,Debugging Optimized Code,Use of Restrictions,Performance Considerations -@anchor{gnat_ugn/gnat_and_program_execution id30}@anchor{182}@anchor{gnat_ugn/gnat_and_program_execution optimization-levels}@anchor{ed} +@anchor{gnat_ugn/gnat_and_program_execution id30}@anchor{184}@anchor{gnat_ugn/gnat_and_program_execution optimization-levels}@anchor{ef} @subsubsection Optimization Levels @@ -20018,7 +20136,7 @@ the slowest compilation time. Full optimization as in @code{-O2}; also uses more aggressive automatic inlining of subprograms within a unit -(@ref{100,,Inlining of Subprograms}) and attempts to vectorize loops. +(@ref{102,,Inlining of Subprograms}) and attempts to vectorize loops. @end table @item @@ -20058,10 +20176,10 @@ levels. Note regarding the use of @code{-O3}: The use of this optimization level ought not to be automatically preferred over that of level @code{-O2}, since it often results in larger executables which may run more slowly. -See further discussion of this point in @ref{100,,Inlining of Subprograms}. +See further discussion of this point in @ref{102,,Inlining of Subprograms}. @node Debugging Optimized Code,Inlining of Subprograms,Optimization Levels,Performance Considerations -@anchor{gnat_ugn/gnat_and_program_execution debugging-optimized-code}@anchor{183}@anchor{gnat_ugn/gnat_and_program_execution id31}@anchor{184} +@anchor{gnat_ugn/gnat_and_program_execution debugging-optimized-code}@anchor{185}@anchor{gnat_ugn/gnat_and_program_execution id31}@anchor{186} @subsubsection Debugging Optimized Code @@ -20189,7 +20307,7 @@ on the resulting executable, which removes both debugging information and global symbols. @node Inlining of Subprograms,Floating Point Operations,Debugging Optimized Code,Performance Considerations -@anchor{gnat_ugn/gnat_and_program_execution id32}@anchor{185}@anchor{gnat_ugn/gnat_and_program_execution inlining-of-subprograms}@anchor{100} +@anchor{gnat_ugn/gnat_and_program_execution id32}@anchor{187}@anchor{gnat_ugn/gnat_and_program_execution inlining-of-subprograms}@anchor{102} @subsubsection Inlining of Subprograms @@ -20328,7 +20446,7 @@ indeed you should use @code{-O3} only if tests show that it actually improves performance for your program. @node Floating Point Operations,Vectorization of loops,Inlining of Subprograms,Performance Considerations -@anchor{gnat_ugn/gnat_and_program_execution floating-point-operations}@anchor{186}@anchor{gnat_ugn/gnat_and_program_execution id33}@anchor{187} +@anchor{gnat_ugn/gnat_and_program_execution floating-point-operations}@anchor{188}@anchor{gnat_ugn/gnat_and_program_execution id33}@anchor{189} @subsubsection Floating Point Operations @@ -20376,7 +20494,7 @@ so it is permissible to mix units compiled with and without these switches. @node Vectorization of loops,Other Optimization Switches,Floating Point Operations,Performance Considerations -@anchor{gnat_ugn/gnat_and_program_execution id34}@anchor{188}@anchor{gnat_ugn/gnat_and_program_execution vectorization-of-loops}@anchor{189} +@anchor{gnat_ugn/gnat_and_program_execution id34}@anchor{18a}@anchor{gnat_ugn/gnat_and_program_execution vectorization-of-loops}@anchor{18b} @subsubsection Vectorization of loops @@ -20527,7 +20645,7 @@ placed immediately within the loop will tell the compiler that it can safely omit the non-vectorized version of the loop as well as the run-time test. @node Other Optimization Switches,Optimization and Strict Aliasing,Vectorization of loops,Performance Considerations -@anchor{gnat_ugn/gnat_and_program_execution id35}@anchor{18a}@anchor{gnat_ugn/gnat_and_program_execution other-optimization-switches}@anchor{18b} +@anchor{gnat_ugn/gnat_and_program_execution id35}@anchor{18c}@anchor{gnat_ugn/gnat_and_program_execution other-optimization-switches}@anchor{18d} @subsubsection Other Optimization Switches @@ -20544,7 +20662,7 @@ the `Submodel Options' section in the `Hardware Models and Configurations' chapter of @cite{Using the GNU Compiler Collection (GCC)}. @node Optimization and Strict Aliasing,Aliased Variables and Optimization,Other Optimization Switches,Performance Considerations -@anchor{gnat_ugn/gnat_and_program_execution id36}@anchor{18c}@anchor{gnat_ugn/gnat_and_program_execution optimization-and-strict-aliasing}@anchor{e4} +@anchor{gnat_ugn/gnat_and_program_execution id36}@anchor{18e}@anchor{gnat_ugn/gnat_and_program_execution optimization-and-strict-aliasing}@anchor{e6} @subsubsection Optimization and Strict Aliasing @@ -20784,7 +20902,7 @@ review any uses of unchecked conversion of access types, particularly if you are getting the warnings described above. @node Aliased Variables and Optimization,Atomic Variables and Optimization,Optimization and Strict Aliasing,Performance Considerations -@anchor{gnat_ugn/gnat_and_program_execution aliased-variables-and-optimization}@anchor{18d}@anchor{gnat_ugn/gnat_and_program_execution id37}@anchor{18e} +@anchor{gnat_ugn/gnat_and_program_execution aliased-variables-and-optimization}@anchor{18f}@anchor{gnat_ugn/gnat_and_program_execution id37}@anchor{190} @subsubsection Aliased Variables and Optimization @@ -20842,7 +20960,7 @@ This means that the above example will in fact “work” reliably, that is, it will produce the expected results. @node Atomic Variables and Optimization,Passive Task Optimization,Aliased Variables and Optimization,Performance Considerations -@anchor{gnat_ugn/gnat_and_program_execution atomic-variables-and-optimization}@anchor{18f}@anchor{gnat_ugn/gnat_and_program_execution id38}@anchor{190} +@anchor{gnat_ugn/gnat_and_program_execution atomic-variables-and-optimization}@anchor{191}@anchor{gnat_ugn/gnat_and_program_execution id38}@anchor{192} @subsubsection Atomic Variables and Optimization @@ -20923,7 +21041,7 @@ such synchronization code is not required, it may be useful to disable it. @node Passive Task Optimization,,Atomic Variables and Optimization,Performance Considerations -@anchor{gnat_ugn/gnat_and_program_execution id39}@anchor{191}@anchor{gnat_ugn/gnat_and_program_execution passive-task-optimization}@anchor{192} +@anchor{gnat_ugn/gnat_and_program_execution id39}@anchor{193}@anchor{gnat_ugn/gnat_and_program_execution passive-task-optimization}@anchor{194} @subsubsection Passive Task Optimization @@ -20968,7 +21086,7 @@ that typically clients of the tasks who call entries, will not have to be modified, only the task definition itself. @node Text_IO Suggestions,Reducing Size of Executables with Unused Subprogram/Data Elimination,Performance Considerations,Improving Performance -@anchor{gnat_ugn/gnat_and_program_execution id40}@anchor{193}@anchor{gnat_ugn/gnat_and_program_execution text-io-suggestions}@anchor{194} +@anchor{gnat_ugn/gnat_and_program_execution id40}@anchor{195}@anchor{gnat_ugn/gnat_and_program_execution text-io-suggestions}@anchor{196} @subsection @code{Text_IO} Suggestions @@ -20991,7 +21109,7 @@ of the standard output file, or change the standard output file to be buffered using @code{Interfaces.C_Streams.setvbuf}. @node Reducing Size of Executables with Unused Subprogram/Data Elimination,,Text_IO Suggestions,Improving Performance -@anchor{gnat_ugn/gnat_and_program_execution id41}@anchor{195}@anchor{gnat_ugn/gnat_and_program_execution reducing-size-of-executables-with-unused-subprogram-data-elimination}@anchor{196} +@anchor{gnat_ugn/gnat_and_program_execution id41}@anchor{197}@anchor{gnat_ugn/gnat_and_program_execution reducing-size-of-executables-with-unused-subprogram-data-elimination}@anchor{198} @subsection Reducing Size of Executables with Unused Subprogram/Data Elimination @@ -21008,7 +21126,7 @@ your executable just by setting options at compilation time. @end menu @node About unused subprogram/data elimination,Compilation options,,Reducing Size of Executables with Unused Subprogram/Data Elimination -@anchor{gnat_ugn/gnat_and_program_execution about-unused-subprogram-data-elimination}@anchor{197}@anchor{gnat_ugn/gnat_and_program_execution id42}@anchor{198} +@anchor{gnat_ugn/gnat_and_program_execution about-unused-subprogram-data-elimination}@anchor{199}@anchor{gnat_ugn/gnat_and_program_execution id42}@anchor{19a} @subsubsection About unused subprogram/data elimination @@ -21024,7 +21142,7 @@ architecture and on all cross platforms using the ELF binary file format. In both cases GNU binutils version 2.16 or later are required to enable it. @node Compilation options,Example of unused subprogram/data elimination,About unused subprogram/data elimination,Reducing Size of Executables with Unused Subprogram/Data Elimination -@anchor{gnat_ugn/gnat_and_program_execution compilation-options}@anchor{199}@anchor{gnat_ugn/gnat_and_program_execution id43}@anchor{19a} +@anchor{gnat_ugn/gnat_and_program_execution compilation-options}@anchor{19b}@anchor{gnat_ugn/gnat_and_program_execution id43}@anchor{19c} @subsubsection Compilation options @@ -21063,7 +21181,7 @@ The GNAT static library is now compiled with -ffunction-sections and and data of the GNAT library from your executable. @node Example of unused subprogram/data elimination,,Compilation options,Reducing Size of Executables with Unused Subprogram/Data Elimination -@anchor{gnat_ugn/gnat_and_program_execution example-of-unused-subprogram-data-elimination}@anchor{19b}@anchor{gnat_ugn/gnat_and_program_execution id44}@anchor{19c} +@anchor{gnat_ugn/gnat_and_program_execution example-of-unused-subprogram-data-elimination}@anchor{19d}@anchor{gnat_ugn/gnat_and_program_execution id44}@anchor{19e} @subsubsection Example of unused subprogram/data elimination @@ -21133,7 +21251,7 @@ appropriate options. @geindex Checks (overflow) @node Overflow Check Handling in GNAT,Performing Dimensionality Analysis in GNAT,Improving Performance,GNAT and Program Execution -@anchor{gnat_ugn/gnat_and_program_execution id45}@anchor{149}@anchor{gnat_ugn/gnat_and_program_execution overflow-check-handling-in-gnat}@anchor{19d} +@anchor{gnat_ugn/gnat_and_program_execution id45}@anchor{14b}@anchor{gnat_ugn/gnat_and_program_execution overflow-check-handling-in-gnat}@anchor{19f} @section Overflow Check Handling in GNAT @@ -21149,7 +21267,7 @@ This section explains how to control the handling of overflow checks. @end menu @node Background,Management of Overflows in GNAT,,Overflow Check Handling in GNAT -@anchor{gnat_ugn/gnat_and_program_execution background}@anchor{19e}@anchor{gnat_ugn/gnat_and_program_execution id46}@anchor{19f} +@anchor{gnat_ugn/gnat_and_program_execution background}@anchor{1a0}@anchor{gnat_ugn/gnat_and_program_execution id46}@anchor{1a1} @subsection Background @@ -21275,7 +21393,7 @@ exception raised because of the intermediate overflow (and we really would prefer this precondition to be considered True at run time). @node Management of Overflows in GNAT,Specifying the Desired Mode,Background,Overflow Check Handling in GNAT -@anchor{gnat_ugn/gnat_and_program_execution id47}@anchor{1a0}@anchor{gnat_ugn/gnat_and_program_execution management-of-overflows-in-gnat}@anchor{1a1} +@anchor{gnat_ugn/gnat_and_program_execution id47}@anchor{1a2}@anchor{gnat_ugn/gnat_and_program_execution management-of-overflows-in-gnat}@anchor{1a3} @subsection Management of Overflows in GNAT @@ -21389,7 +21507,7 @@ out in the normal manner (with infinite values always failing all range checks). @node Specifying the Desired Mode,Default Settings,Management of Overflows in GNAT,Overflow Check Handling in GNAT -@anchor{gnat_ugn/gnat_and_program_execution id48}@anchor{1a2}@anchor{gnat_ugn/gnat_and_program_execution specifying-the-desired-mode}@anchor{e9} +@anchor{gnat_ugn/gnat_and_program_execution id48}@anchor{1a4}@anchor{gnat_ugn/gnat_and_program_execution specifying-the-desired-mode}@anchor{eb} @subsection Specifying the Desired Mode @@ -21513,7 +21631,7 @@ causing all intermediate operations to be computed using the base type (@code{STRICT} mode). @node Default Settings,Implementation Notes,Specifying the Desired Mode,Overflow Check Handling in GNAT -@anchor{gnat_ugn/gnat_and_program_execution default-settings}@anchor{1a3}@anchor{gnat_ugn/gnat_and_program_execution id49}@anchor{1a4} +@anchor{gnat_ugn/gnat_and_program_execution default-settings}@anchor{1a5}@anchor{gnat_ugn/gnat_and_program_execution id49}@anchor{1a6} @subsection Default Settings @@ -21526,30 +21644,8 @@ General => Strict @end example @end quotation -which causes all computations both inside and outside assertions to use -the base type. - -This retains compatibility with previous versions of -GNAT which suppressed overflow checks by default and always -used the base type for computation of intermediate results. - -@c Sphinx allows no emphasis within :index: role. As a workaround we -@c point the index to "switch" and use emphasis for "-gnato". - -The -@geindex -gnato (gcc) -switch @code{-gnato} (with no digits following) -is equivalent to - -@quotation - -@example -General => Strict -@end example -@end quotation - -which causes overflow checking of all intermediate overflows -both inside and outside assertions against the base type. +which causes all computations both inside and outside assertions to use the +base type, and is equivalent to @code{-gnato} (with no digits following). The pragma @code{Suppress (Overflow_Check)} disables overflow checking, but it has no effect on the method used for computing @@ -21560,7 +21656,7 @@ checking, but it has no effect on the method used for computing intermediate results. @node Implementation Notes,,Default Settings,Overflow Check Handling in GNAT -@anchor{gnat_ugn/gnat_and_program_execution id50}@anchor{1a5}@anchor{gnat_ugn/gnat_and_program_execution implementation-notes}@anchor{1a6} +@anchor{gnat_ugn/gnat_and_program_execution id50}@anchor{1a7}@anchor{gnat_ugn/gnat_and_program_execution implementation-notes}@anchor{1a8} @subsection Implementation Notes @@ -21569,7 +21665,7 @@ reasonably efficient, and can be generally used. It also helps to ensure compatibility with code imported from some other compiler to GNAT. -Setting all intermediate overflows checking (@code{CHECKED} mode) +Setting all intermediate overflows checking (@code{STRICT} mode) makes sense if you want to make sure that your code is compatible with any other possible Ada implementation. This may be useful in ensuring portability @@ -21608,7 +21704,7 @@ platforms for which @code{Long_Long_Integer} is 64-bits (nearly all GNAT platforms). @node Performing Dimensionality Analysis in GNAT,Stack Related Facilities,Overflow Check Handling in GNAT,GNAT and Program Execution -@anchor{gnat_ugn/gnat_and_program_execution id51}@anchor{14a}@anchor{gnat_ugn/gnat_and_program_execution performing-dimensionality-analysis-in-gnat}@anchor{1a7} +@anchor{gnat_ugn/gnat_and_program_execution id51}@anchor{14c}@anchor{gnat_ugn/gnat_and_program_execution performing-dimensionality-analysis-in-gnat}@anchor{1a9} @section Performing Dimensionality Analysis in GNAT @@ -21995,7 +22091,7 @@ passing (the dimension vector for the actual parameter must be equal to the dimension vector for the formal parameter). @node Stack Related Facilities,Memory Management Issues,Performing Dimensionality Analysis in GNAT,GNAT and Program Execution -@anchor{gnat_ugn/gnat_and_program_execution id52}@anchor{14b}@anchor{gnat_ugn/gnat_and_program_execution stack-related-facilities}@anchor{1a8} +@anchor{gnat_ugn/gnat_and_program_execution id52}@anchor{14d}@anchor{gnat_ugn/gnat_and_program_execution stack-related-facilities}@anchor{1aa} @section Stack Related Facilities @@ -22011,7 +22107,7 @@ particular, it deals with dynamic and static stack usage measurements. @end menu @node Stack Overflow Checking,Static Stack Usage Analysis,,Stack Related Facilities -@anchor{gnat_ugn/gnat_and_program_execution id53}@anchor{1a9}@anchor{gnat_ugn/gnat_and_program_execution stack-overflow-checking}@anchor{e5} +@anchor{gnat_ugn/gnat_and_program_execution id53}@anchor{1ab}@anchor{gnat_ugn/gnat_and_program_execution stack-overflow-checking}@anchor{e7} @subsection Stack Overflow Checking @@ -22048,7 +22144,7 @@ If the space is exceeded, then a @code{Storage_Error} exception is raised. For declared tasks, the default stack size is defined by the GNAT runtime, whose size may be modified at bind time through the @code{-d} bind switch -(@ref{110,,Switches for gnatbind}). Task specific stack sizes may be set using the +(@ref{112,,Switches for gnatbind}). Task specific stack sizes may be set using the @code{Storage_Size} pragma. For the environment task, the stack size is determined by the operating system. @@ -22056,7 +22152,7 @@ Consequently, to modify the size of the environment task please refer to your operating system documentation. @node Static Stack Usage Analysis,Dynamic Stack Usage Analysis,Stack Overflow Checking,Stack Related Facilities -@anchor{gnat_ugn/gnat_and_program_execution id54}@anchor{1aa}@anchor{gnat_ugn/gnat_and_program_execution static-stack-usage-analysis}@anchor{e6} +@anchor{gnat_ugn/gnat_and_program_execution id54}@anchor{1ac}@anchor{gnat_ugn/gnat_and_program_execution static-stack-usage-analysis}@anchor{e8} @subsection Static Stack Usage Analysis @@ -22105,7 +22201,7 @@ subprogram whose stack usage might be larger than the specified amount of bytes. The wording is in keeping with the qualifier documented above. @node Dynamic Stack Usage Analysis,,Static Stack Usage Analysis,Stack Related Facilities -@anchor{gnat_ugn/gnat_and_program_execution dynamic-stack-usage-analysis}@anchor{113}@anchor{gnat_ugn/gnat_and_program_execution id55}@anchor{1ab} +@anchor{gnat_ugn/gnat_and_program_execution dynamic-stack-usage-analysis}@anchor{115}@anchor{gnat_ugn/gnat_and_program_execution id55}@anchor{1ad} @subsection Dynamic Stack Usage Analysis @@ -22187,7 +22283,7 @@ The package @code{GNAT.Task_Stack_Usage} provides facilities to get stack-usage reports at run time. See its body for the details. @node Memory Management Issues,,Stack Related Facilities,GNAT and Program Execution -@anchor{gnat_ugn/gnat_and_program_execution id56}@anchor{14c}@anchor{gnat_ugn/gnat_and_program_execution memory-management-issues}@anchor{1ac} +@anchor{gnat_ugn/gnat_and_program_execution id56}@anchor{14e}@anchor{gnat_ugn/gnat_and_program_execution memory-management-issues}@anchor{1ae} @section Memory Management Issues @@ -22203,7 +22299,7 @@ incorrect uses of access values (including ‘dangling references’). @end menu @node Some Useful Memory Pools,The GNAT Debug Pool Facility,,Memory Management Issues -@anchor{gnat_ugn/gnat_and_program_execution id57}@anchor{1ad}@anchor{gnat_ugn/gnat_and_program_execution some-useful-memory-pools}@anchor{1ae} +@anchor{gnat_ugn/gnat_and_program_execution id57}@anchor{1af}@anchor{gnat_ugn/gnat_and_program_execution some-useful-memory-pools}@anchor{1b0} @subsection Some Useful Memory Pools @@ -22255,12 +22351,12 @@ procedure Pooloc1 is for A'Storage_Pool use X; v : A; begin - for I in 1 .. 50 loop + for I in 1 .. 50 loop v := new Integer; end loop; end Internal; begin - for I in 1 .. 100 loop + for I in 1 .. 100 loop Internal; end loop; end Pooloc1; @@ -22284,7 +22380,7 @@ for T1'Storage_Size use 10_000; @end quotation @node The GNAT Debug Pool Facility,,Some Useful Memory Pools,Memory Management Issues -@anchor{gnat_ugn/gnat_and_program_execution id58}@anchor{1af}@anchor{gnat_ugn/gnat_and_program_execution the-gnat-debug-pool-facility}@anchor{1b0} +@anchor{gnat_ugn/gnat_and_program_execution id58}@anchor{1b1}@anchor{gnat_ugn/gnat_and_program_execution the-gnat-debug-pool-facility}@anchor{1b2} @subsection The GNAT Debug Pool Facility @@ -22447,7 +22543,7 @@ Debug Pool info: @c -- E.g. Ada |nbsp| 95 @node Platform-Specific Information,Example of Binder Output File,GNAT and Program Execution,Top -@anchor{gnat_ugn/platform_specific_information doc}@anchor{1b1}@anchor{gnat_ugn/platform_specific_information id1}@anchor{1b2}@anchor{gnat_ugn/platform_specific_information platform-specific-information}@anchor{d} +@anchor{gnat_ugn/platform_specific_information doc}@anchor{1b3}@anchor{gnat_ugn/platform_specific_information id1}@anchor{1b4}@anchor{gnat_ugn/platform_specific_information platform-specific-information}@anchor{d} @chapter Platform-Specific Information @@ -22465,7 +22561,7 @@ related to the GNAT implementation on specific Operating Systems. @end menu @node Run-Time Libraries,Specifying a Run-Time Library,,Platform-Specific Information -@anchor{gnat_ugn/platform_specific_information id2}@anchor{1b3}@anchor{gnat_ugn/platform_specific_information run-time-libraries}@anchor{1b4} +@anchor{gnat_ugn/platform_specific_information id2}@anchor{1b5}@anchor{gnat_ugn/platform_specific_information run-time-libraries}@anchor{1b6} @section Run-Time Libraries @@ -22526,7 +22622,7 @@ are supplied on various GNAT platforms. @end menu @node Summary of Run-Time Configurations,,,Run-Time Libraries -@anchor{gnat_ugn/platform_specific_information id3}@anchor{1b5}@anchor{gnat_ugn/platform_specific_information summary-of-run-time-configurations}@anchor{1b6} +@anchor{gnat_ugn/platform_specific_information id3}@anchor{1b7}@anchor{gnat_ugn/platform_specific_information summary-of-run-time-configurations}@anchor{1b8} @subsection Summary of Run-Time Configurations @@ -22626,7 +22722,7 @@ ZCX @node Specifying a Run-Time Library,GNU/Linux Topics,Run-Time Libraries,Platform-Specific Information -@anchor{gnat_ugn/platform_specific_information id4}@anchor{1b7}@anchor{gnat_ugn/platform_specific_information specifying-a-run-time-library}@anchor{1b8} +@anchor{gnat_ugn/platform_specific_information id4}@anchor{1b9}@anchor{gnat_ugn/platform_specific_information specifying-a-run-time-library}@anchor{1ba} @section Specifying a Run-Time Library @@ -22713,7 +22809,7 @@ Alternatively, you can specify @code{rts-sjlj/adainclude} in the file Selecting another run-time library temporarily can be achieved by using the @code{--RTS} switch, e.g., @code{--RTS=sjlj} -@anchor{gnat_ugn/platform_specific_information choosing-the-scheduling-policy}@anchor{1b9} +@anchor{gnat_ugn/platform_specific_information choosing-the-scheduling-policy}@anchor{1bb} @geindex SCHED_FIFO scheduling policy @geindex SCHED_RR scheduling policy @@ -22726,7 +22822,7 @@ achieved by using the @code{--RTS} switch, e.g., @code{--RTS=sjlj} @end menu @node Choosing the Scheduling Policy,,,Specifying a Run-Time Library -@anchor{gnat_ugn/platform_specific_information id5}@anchor{1ba} +@anchor{gnat_ugn/platform_specific_information id5}@anchor{1bc} @subsection Choosing the Scheduling Policy @@ -22788,7 +22884,7 @@ have sufficient priviledge for running the container image. @geindex GNU/Linux @node GNU/Linux Topics,Microsoft Windows Topics,Specifying a Run-Time Library,Platform-Specific Information -@anchor{gnat_ugn/platform_specific_information gnu-linux-topics}@anchor{1bb}@anchor{gnat_ugn/platform_specific_information id6}@anchor{1bc} +@anchor{gnat_ugn/platform_specific_information gnu-linux-topics}@anchor{1bd}@anchor{gnat_ugn/platform_specific_information id6}@anchor{1be} @section GNU/Linux Topics @@ -22796,12 +22892,13 @@ This section describes topics that are specific to GNU/Linux platforms. @menu * Required Packages on GNU/Linux:: +* Position Independent Executable (PIE) Enabled by Default on Linux: Position Independent Executable PIE Enabled by Default on Linux. * A GNU/Linux Debug Quirk:: @end menu -@node Required Packages on GNU/Linux,A GNU/Linux Debug Quirk,,GNU/Linux Topics -@anchor{gnat_ugn/platform_specific_information id7}@anchor{1bd}@anchor{gnat_ugn/platform_specific_information required-packages-on-gnu-linux}@anchor{1be} +@node Required Packages on GNU/Linux,Position Independent Executable PIE Enabled by Default on Linux,,GNU/Linux Topics +@anchor{gnat_ugn/platform_specific_information id7}@anchor{1bf}@anchor{gnat_ugn/platform_specific_information required-packages-on-gnu-linux}@anchor{1c0} @subsection Required Packages on GNU/Linux @@ -22837,8 +22934,52 @@ Debian, Ubuntu: @code{libc6:i386}, @code{libc6-dev:i386}, @code{lib32ncursesw5} Other GNU/Linux distributions might be choosing a different name for those packages. -@node A GNU/Linux Debug Quirk,,Required Packages on GNU/Linux,GNU/Linux Topics -@anchor{gnat_ugn/platform_specific_information a-gnu-linux-debug-quirk}@anchor{1bf}@anchor{gnat_ugn/platform_specific_information id8}@anchor{1c0} +@node Position Independent Executable PIE Enabled by Default on Linux,A GNU/Linux Debug Quirk,Required Packages on GNU/Linux,GNU/Linux Topics +@anchor{gnat_ugn/platform_specific_information pie-enabled-by-default-on-linux}@anchor{1c1}@anchor{gnat_ugn/platform_specific_information position-independent-executable-pie-enabled-by-default-on-linux}@anchor{1c2} +@subsection Position Independent Executable (PIE) Enabled by Default on Linux + + +GNAT generates Position Independent Executable (PIE) code by default. +PIE binaries are loaded into random memory locations, introducing +an additional layer of protection against attacks. + +Building PIE binaries requires that all of their dependencies also be +built as Position Independent. If the link of your project fails with +an error like: + +@example +/[...]/ld: /path/to/object/file: relocation R_X86_64_32S against symbol +`symbol name' can not be used when making a PIE object; +recompile with -fPIE +@end example + +it means the identified object file has not been built as Position +Independent. + +If you are not interested in building PIE binaries, you can simply +turn this feature off by first compiling your code with @code{-fno-pie} +and then by linking with @code{-no-pie} (note the subtle but important +difference in the names of the options – the linker option does `not' +have an @cite{f} after the dash!). When using gprbuild, this is +achieved by updating the `Required_Switches' attribute in package @cite{Compiler} +and, depending on your type of project, either attribute `Switches' +or attribute `Library_Options' in package @cite{Linker}. + +On the other hand, if you would like to build PIE binaries and you are +getting the error above, a quick and easy workaround to allow linking +to succeed again is to disable PIE during the link, thus temporarily +lifting the requirement that all dependencies also be Position +Independent code. To do so, you simply need to add @code{-no-pie} to +the list of switches passed to the linker. As part of this workaround, +there is no need to adjust the compiler switches. + +From there, to be able to link your binaries with PIE and therefore +drop the @code{-no-pie} workaround, you’ll need to get the identified +dependencies rebuilt with PIE enabled (compiled with @code{-fPIE} +and linked with @code{-pie}). + +@node A GNU/Linux Debug Quirk,,Position Independent Executable PIE Enabled by Default on Linux,GNU/Linux Topics +@anchor{gnat_ugn/platform_specific_information a-gnu-linux-debug-quirk}@anchor{1c3}@anchor{gnat_ugn/platform_specific_information id8}@anchor{1c4} @subsection A GNU/Linux Debug Quirk @@ -22858,7 +22999,7 @@ the symptoms most commonly observed. @geindex Windows @node Microsoft Windows Topics,Mac OS Topics,GNU/Linux Topics,Platform-Specific Information -@anchor{gnat_ugn/platform_specific_information id9}@anchor{1c1}@anchor{gnat_ugn/platform_specific_information microsoft-windows-topics}@anchor{1c2} +@anchor{gnat_ugn/platform_specific_information id9}@anchor{1c5}@anchor{gnat_ugn/platform_specific_information microsoft-windows-topics}@anchor{1c6} @section Microsoft Windows Topics @@ -22879,7 +23020,7 @@ platforms. @end menu @node Using GNAT on Windows,Using a network installation of GNAT,,Microsoft Windows Topics -@anchor{gnat_ugn/platform_specific_information id10}@anchor{1c3}@anchor{gnat_ugn/platform_specific_information using-gnat-on-windows}@anchor{1c4} +@anchor{gnat_ugn/platform_specific_information id10}@anchor{1c7}@anchor{gnat_ugn/platform_specific_information using-gnat-on-windows}@anchor{1c8} @subsection Using GNAT on Windows @@ -22956,7 +23097,7 @@ uninstall or integrate different GNAT products. @end itemize @node Using a network installation of GNAT,CONSOLE and WINDOWS subsystems,Using GNAT on Windows,Microsoft Windows Topics -@anchor{gnat_ugn/platform_specific_information id11}@anchor{1c5}@anchor{gnat_ugn/platform_specific_information using-a-network-installation-of-gnat}@anchor{1c6} +@anchor{gnat_ugn/platform_specific_information id11}@anchor{1c9}@anchor{gnat_ugn/platform_specific_information using-a-network-installation-of-gnat}@anchor{1ca} @subsection Using a network installation of GNAT @@ -22983,7 +23124,7 @@ transfer of large amounts of data across the network and will likely cause serious performance penalty. @node CONSOLE and WINDOWS subsystems,Temporary Files,Using a network installation of GNAT,Microsoft Windows Topics -@anchor{gnat_ugn/platform_specific_information console-and-windows-subsystems}@anchor{1c7}@anchor{gnat_ugn/platform_specific_information id12}@anchor{1c8} +@anchor{gnat_ugn/platform_specific_information console-and-windows-subsystems}@anchor{1cb}@anchor{gnat_ugn/platform_specific_information id12}@anchor{1cc} @subsection CONSOLE and WINDOWS subsystems @@ -23008,7 +23149,7 @@ $ gnatmake winprog -largs -mwindows @end quotation @node Temporary Files,Disabling Command Line Argument Expansion,CONSOLE and WINDOWS subsystems,Microsoft Windows Topics -@anchor{gnat_ugn/platform_specific_information id13}@anchor{1c9}@anchor{gnat_ugn/platform_specific_information temporary-files}@anchor{1ca} +@anchor{gnat_ugn/platform_specific_information id13}@anchor{1cd}@anchor{gnat_ugn/platform_specific_information temporary-files}@anchor{1ce} @subsection Temporary Files @@ -23047,7 +23188,7 @@ environments where you may not have write access to some directories. @node Disabling Command Line Argument Expansion,Windows Socket Timeouts,Temporary Files,Microsoft Windows Topics -@anchor{gnat_ugn/platform_specific_information disabling-command-line-argument-expansion}@anchor{1cb} +@anchor{gnat_ugn/platform_specific_information disabling-command-line-argument-expansion}@anchor{1cf} @subsection Disabling Command Line Argument Expansion @@ -23118,7 +23259,7 @@ Ada.Command_Line.Argument (1) -> "'*.txt'" @end example @node Windows Socket Timeouts,Mixed-Language Programming on Windows,Disabling Command Line Argument Expansion,Microsoft Windows Topics -@anchor{gnat_ugn/platform_specific_information windows-socket-timeouts}@anchor{1cc} +@anchor{gnat_ugn/platform_specific_information windows-socket-timeouts}@anchor{1d0} @subsection Windows Socket Timeouts @@ -23164,7 +23305,7 @@ shorter than 500 ms is needed on these Windows versions, a call to Check_Selector should be added before any socket read or write operations. @node Mixed-Language Programming on Windows,Windows Specific Add-Ons,Windows Socket Timeouts,Microsoft Windows Topics -@anchor{gnat_ugn/platform_specific_information id14}@anchor{1cd}@anchor{gnat_ugn/platform_specific_information mixed-language-programming-on-windows}@anchor{1ce} +@anchor{gnat_ugn/platform_specific_information id14}@anchor{1d1}@anchor{gnat_ugn/platform_specific_information mixed-language-programming-on-windows}@anchor{1d2} @subsection Mixed-Language Programming on Windows @@ -23186,12 +23327,12 @@ to use the Microsoft tools for your C++ code, you have two choices: Encapsulate your C++ code in a DLL to be linked with your Ada application. In this case, use the Microsoft or whatever environment to build the DLL and use GNAT to build your executable -(@ref{1cf,,Using DLLs with GNAT}). +(@ref{1d3,,Using DLLs with GNAT}). @item Or you can encapsulate your Ada code in a DLL to be linked with the other part of your application. In this case, use GNAT to build the DLL -(@ref{1d0,,Building DLLs with GNAT Project files}) and use the Microsoft +(@ref{1d4,,Building DLLs with GNAT Project files}) and use the Microsoft or whatever environment to build your executable. @end itemize @@ -23248,7 +23389,7 @@ native SEH support is used. @end menu @node Windows Calling Conventions,Introduction to Dynamic Link Libraries DLLs,,Mixed-Language Programming on Windows -@anchor{gnat_ugn/platform_specific_information id15}@anchor{1d1}@anchor{gnat_ugn/platform_specific_information windows-calling-conventions}@anchor{1d2} +@anchor{gnat_ugn/platform_specific_information id15}@anchor{1d5}@anchor{gnat_ugn/platform_specific_information windows-calling-conventions}@anchor{1d6} @subsubsection Windows Calling Conventions @@ -23293,7 +23434,7 @@ are available for Windows: @end menu @node C Calling Convention,Stdcall Calling Convention,,Windows Calling Conventions -@anchor{gnat_ugn/platform_specific_information c-calling-convention}@anchor{1d3}@anchor{gnat_ugn/platform_specific_information id16}@anchor{1d4} +@anchor{gnat_ugn/platform_specific_information c-calling-convention}@anchor{1d7}@anchor{gnat_ugn/platform_specific_information id16}@anchor{1d8} @subsubsection @code{C} Calling Convention @@ -23335,10 +23476,10 @@ is missing, as in the above example, this parameter is set to be the When importing a variable defined in C, you should always use the @code{C} calling convention unless the object containing the variable is part of a DLL (in which case you should use the @code{Stdcall} calling -convention, @ref{1d5,,Stdcall Calling Convention}). +convention, @ref{1d9,,Stdcall Calling Convention}). @node Stdcall Calling Convention,Win32 Calling Convention,C Calling Convention,Windows Calling Conventions -@anchor{gnat_ugn/platform_specific_information id17}@anchor{1d6}@anchor{gnat_ugn/platform_specific_information stdcall-calling-convention}@anchor{1d5} +@anchor{gnat_ugn/platform_specific_information id17}@anchor{1da}@anchor{gnat_ugn/platform_specific_information stdcall-calling-convention}@anchor{1d9} @subsubsection @code{Stdcall} Calling Convention @@ -23435,7 +23576,7 @@ Note that to ease building cross-platform bindings this convention will be handled as a @code{C} calling convention on non-Windows platforms. @node Win32 Calling Convention,DLL Calling Convention,Stdcall Calling Convention,Windows Calling Conventions -@anchor{gnat_ugn/platform_specific_information id18}@anchor{1d7}@anchor{gnat_ugn/platform_specific_information win32-calling-convention}@anchor{1d8} +@anchor{gnat_ugn/platform_specific_information id18}@anchor{1db}@anchor{gnat_ugn/platform_specific_information win32-calling-convention}@anchor{1dc} @subsubsection @code{Win32} Calling Convention @@ -23443,7 +23584,7 @@ This convention, which is GNAT-specific is fully equivalent to the @code{Stdcall} calling convention described above. @node DLL Calling Convention,,Win32 Calling Convention,Windows Calling Conventions -@anchor{gnat_ugn/platform_specific_information dll-calling-convention}@anchor{1d9}@anchor{gnat_ugn/platform_specific_information id19}@anchor{1da} +@anchor{gnat_ugn/platform_specific_information dll-calling-convention}@anchor{1dd}@anchor{gnat_ugn/platform_specific_information id19}@anchor{1de} @subsubsection @code{DLL} Calling Convention @@ -23451,7 +23592,7 @@ This convention, which is GNAT-specific is fully equivalent to the @code{Stdcall} calling convention described above. @node Introduction to Dynamic Link Libraries DLLs,Using DLLs with GNAT,Windows Calling Conventions,Mixed-Language Programming on Windows -@anchor{gnat_ugn/platform_specific_information id20}@anchor{1db}@anchor{gnat_ugn/platform_specific_information introduction-to-dynamic-link-libraries-dlls}@anchor{1dc} +@anchor{gnat_ugn/platform_specific_information id20}@anchor{1df}@anchor{gnat_ugn/platform_specific_information introduction-to-dynamic-link-libraries-dlls}@anchor{1e0} @subsubsection Introduction to Dynamic Link Libraries (DLLs) @@ -23535,10 +23676,10 @@ As a side note, an interesting difference between Microsoft DLLs and Unix shared libraries, is the fact that on most Unix systems all public routines are exported by default in a Unix shared library, while under Windows it is possible (but not required) to list exported routines in -a definition file (see @ref{1dd,,The Definition File}). +a definition file (see @ref{1e1,,The Definition File}). @node Using DLLs with GNAT,Building DLLs with GNAT Project files,Introduction to Dynamic Link Libraries DLLs,Mixed-Language Programming on Windows -@anchor{gnat_ugn/platform_specific_information id21}@anchor{1de}@anchor{gnat_ugn/platform_specific_information using-dlls-with-gnat}@anchor{1cf} +@anchor{gnat_ugn/platform_specific_information id21}@anchor{1e2}@anchor{gnat_ugn/platform_specific_information using-dlls-with-gnat}@anchor{1d3} @subsubsection Using DLLs with GNAT @@ -23629,7 +23770,7 @@ example a fictitious DLL called @code{API.dll}. @end menu @node Creating an Ada Spec for the DLL Services,Creating an Import Library,,Using DLLs with GNAT -@anchor{gnat_ugn/platform_specific_information creating-an-ada-spec-for-the-dll-services}@anchor{1df}@anchor{gnat_ugn/platform_specific_information id22}@anchor{1e0} +@anchor{gnat_ugn/platform_specific_information creating-an-ada-spec-for-the-dll-services}@anchor{1e3}@anchor{gnat_ugn/platform_specific_information id22}@anchor{1e4} @subsubsection Creating an Ada Spec for the DLL Services @@ -23669,7 +23810,7 @@ end API; @end quotation @node Creating an Import Library,,Creating an Ada Spec for the DLL Services,Using DLLs with GNAT -@anchor{gnat_ugn/platform_specific_information creating-an-import-library}@anchor{1e1}@anchor{gnat_ugn/platform_specific_information id23}@anchor{1e2} +@anchor{gnat_ugn/platform_specific_information creating-an-import-library}@anchor{1e5}@anchor{gnat_ugn/platform_specific_information id23}@anchor{1e6} @subsubsection Creating an Import Library @@ -23683,7 +23824,7 @@ as in this case it is possible to link directly against the DLL. Otherwise read on. @geindex Definition file -@anchor{gnat_ugn/platform_specific_information the-definition-file}@anchor{1dd} +@anchor{gnat_ugn/platform_specific_information the-definition-file}@anchor{1e1} @subsubheading The Definition File @@ -23731,17 +23872,17 @@ EXPORTS @end table Note that you must specify the correct suffix (@code{@@@var{nn}}) -(see @ref{1d2,,Windows Calling Conventions}) for a Stdcall +(see @ref{1d6,,Windows Calling Conventions}) for a Stdcall calling convention function in the exported symbols list. There can actually be other sections in a definition file, but these sections are not relevant to the discussion at hand. -@anchor{gnat_ugn/platform_specific_information create-def-file-automatically}@anchor{1e3} +@anchor{gnat_ugn/platform_specific_information create-def-file-automatically}@anchor{1e7} @subsubheading Creating a Definition File Automatically You can automatically create the definition file @code{API.def} -(see @ref{1dd,,The Definition File}) from a DLL. +(see @ref{1e1,,The Definition File}) from a DLL. For that use the @code{dlltool} program as follows: @quotation @@ -23751,7 +23892,7 @@ $ dlltool API.dll -z API.def --export-all-symbols @end example Note that if some routines in the DLL have the @code{Stdcall} convention -(@ref{1d2,,Windows Calling Conventions}) with stripped @code{@@@var{nn}} +(@ref{1d6,,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. @@ -23775,13 +23916,13 @@ tells you what symbol is expected. You just have to go back to the definition file and add the right suffix. @end itemize @end quotation -@anchor{gnat_ugn/platform_specific_information gnat-style-import-library}@anchor{1e4} +@anchor{gnat_ugn/platform_specific_information gnat-style-import-library}@anchor{1e8} @subsubheading GNAT-Style Import Library To create a static import library from @code{API.dll} with the GNAT tools you should create the .def file, then use @code{gnatdll} tool -(see @ref{1e5,,Using gnatdll}) as follows: +(see @ref{1e9,,Using gnatdll}) as follows: @quotation @@ -23797,15 +23938,15 @@ definition file name is @code{xyz.def}, the import library name will be @code{libxyz.a}. Note that in the previous example option @code{-e} could have been removed because the name of the definition file (before the @code{.def} suffix) is the same as the name of the -DLL (@ref{1e5,,Using gnatdll} for more information about @code{gnatdll}). +DLL (@ref{1e9,,Using gnatdll} for more information about @code{gnatdll}). @end quotation -@anchor{gnat_ugn/platform_specific_information msvs-style-import-library}@anchor{1e6} +@anchor{gnat_ugn/platform_specific_information msvs-style-import-library}@anchor{1ea} @subsubheading Microsoft-Style Import Library A Microsoft import library is needed only if you plan to make an Ada DLL available to applications developed with Microsoft -tools (@ref{1ce,,Mixed-Language Programming on Windows}). +tools (@ref{1d2,,Mixed-Language Programming on Windows}). To create a Microsoft-style import library for @code{API.dll} you should create the .def file, then build the actual import library using @@ -23829,7 +23970,7 @@ See the Microsoft documentation for further details about the usage of @end quotation @node Building DLLs with GNAT Project files,Building DLLs with GNAT,Using DLLs with GNAT,Mixed-Language Programming on Windows -@anchor{gnat_ugn/platform_specific_information building-dlls-with-gnat-project-files}@anchor{1d0}@anchor{gnat_ugn/platform_specific_information id24}@anchor{1e7} +@anchor{gnat_ugn/platform_specific_information building-dlls-with-gnat-project-files}@anchor{1d4}@anchor{gnat_ugn/platform_specific_information id24}@anchor{1eb} @subsubsection Building DLLs with GNAT Project files @@ -23845,7 +23986,7 @@ when inside the @code{DllMain} routine which is used for auto-initialization of shared libraries, so it is not possible to have library level tasks in SALs. @node Building DLLs with GNAT,Building DLLs with gnatdll,Building DLLs with GNAT Project files,Mixed-Language Programming on Windows -@anchor{gnat_ugn/platform_specific_information building-dlls-with-gnat}@anchor{1e8}@anchor{gnat_ugn/platform_specific_information id25}@anchor{1e9} +@anchor{gnat_ugn/platform_specific_information building-dlls-with-gnat}@anchor{1ec}@anchor{gnat_ugn/platform_specific_information id25}@anchor{1ed} @subsubsection Building DLLs with GNAT @@ -23876,7 +24017,7 @@ $ gcc -shared -shared-libgcc -o api.dll obj1.o obj2.o ... It is important to note that in this case all symbols found in the object files are automatically exported. It is possible to restrict the set of symbols to export by passing to @code{gcc} a definition -file (see @ref{1dd,,The Definition File}). +file (see @ref{1e1,,The Definition File}). For example: @example @@ -23914,7 +24055,7 @@ $ gnatmake main -Iapilib -bargs -shared -largs -Lapilib -lAPI @end quotation @node Building DLLs with gnatdll,Ada DLLs and Finalization,Building DLLs with GNAT,Mixed-Language Programming on Windows -@anchor{gnat_ugn/platform_specific_information building-dlls-with-gnatdll}@anchor{1ea}@anchor{gnat_ugn/platform_specific_information id26}@anchor{1eb} +@anchor{gnat_ugn/platform_specific_information building-dlls-with-gnatdll}@anchor{1ee}@anchor{gnat_ugn/platform_specific_information id26}@anchor{1ef} @subsubsection Building DLLs with gnatdll @@ -23922,8 +24063,8 @@ $ gnatmake main -Iapilib -bargs -shared -largs -Lapilib -lAPI @geindex building Note that it is preferred to use GNAT Project files -(@ref{1d0,,Building DLLs with GNAT Project files}) or the built-in GNAT -DLL support (@ref{1e8,,Building DLLs with GNAT}) or to build DLLs. +(@ref{1d4,,Building DLLs with GNAT Project files}) or the built-in GNAT +DLL support (@ref{1ec,,Building DLLs with GNAT}) or to build DLLs. This section explains how to build DLLs containing Ada code using @code{gnatdll}. These DLLs will be referred to as Ada DLLs in the @@ -23939,20 +24080,20 @@ non-Ada applications are as follows: You need to mark each Ada entity exported by the DLL with a @code{C} or @code{Stdcall} calling convention to avoid any Ada name mangling for the entities exported by the DLL -(see @ref{1ec,,Exporting Ada Entities}). You can +(see @ref{1f0,,Exporting Ada Entities}). You can skip this step if you plan to use the Ada DLL only from Ada applications. @item Your Ada code must export an initialization routine which calls the routine @code{adainit} generated by @code{gnatbind} to perform the elaboration of -the Ada code in the DLL (@ref{1ed,,Ada DLLs and Elaboration}). The initialization +the Ada code in the DLL (@ref{1f1,,Ada DLLs and Elaboration}). The initialization routine exported by the Ada DLL must be invoked by the clients of the DLL to initialize the DLL. @item When useful, the DLL should also export a finalization routine which calls routine @code{adafinal} generated by @code{gnatbind} to perform the -finalization of the Ada code in the DLL (@ref{1ee,,Ada DLLs and Finalization}). +finalization of the Ada code in the DLL (@ref{1f2,,Ada DLLs and Finalization}). The finalization routine exported by the Ada DLL must be invoked by the clients of the DLL when the DLL services are no further needed. @@ -23962,11 +24103,11 @@ of the programming languages to which you plan to make the DLL available. @item You must provide a definition file listing the exported entities -(@ref{1dd,,The Definition File}). +(@ref{1e1,,The Definition File}). @item Finally you must use @code{gnatdll} to produce the DLL and the import -library (@ref{1e5,,Using gnatdll}). +library (@ref{1e9,,Using gnatdll}). @end itemize Note that a relocatable DLL stripped using the @code{strip} @@ -23986,7 +24127,7 @@ chapter of the `GPRbuild User’s Guide'. @end menu @node Limitations When Using Ada DLLs from Ada,Exporting Ada Entities,,Building DLLs with gnatdll -@anchor{gnat_ugn/platform_specific_information limitations-when-using-ada-dlls-from-ada}@anchor{1ef} +@anchor{gnat_ugn/platform_specific_information limitations-when-using-ada-dlls-from-ada}@anchor{1f3} @subsubsection Limitations When Using Ada DLLs from Ada @@ -24007,7 +24148,7 @@ It is completely safe to exchange plain elementary, array or record types, Windows object handles, etc. @node Exporting Ada Entities,Ada DLLs and Elaboration,Limitations When Using Ada DLLs from Ada,Building DLLs with gnatdll -@anchor{gnat_ugn/platform_specific_information exporting-ada-entities}@anchor{1ec}@anchor{gnat_ugn/platform_specific_information id27}@anchor{1f0} +@anchor{gnat_ugn/platform_specific_information exporting-ada-entities}@anchor{1f0}@anchor{gnat_ugn/platform_specific_information id27}@anchor{1f4} @subsubsection Exporting Ada Entities @@ -24107,10 +24248,10 @@ end API; Note that if you do not export the Ada entities with a @code{C} or @code{Stdcall} convention you will have to provide the mangled Ada names in the definition file of the Ada DLL -(@ref{1f1,,Creating the Definition File}). +(@ref{1f5,,Creating the Definition File}). @node Ada DLLs and Elaboration,,Exporting Ada Entities,Building DLLs with gnatdll -@anchor{gnat_ugn/platform_specific_information ada-dlls-and-elaboration}@anchor{1ed}@anchor{gnat_ugn/platform_specific_information id28}@anchor{1f2} +@anchor{gnat_ugn/platform_specific_information ada-dlls-and-elaboration}@anchor{1f1}@anchor{gnat_ugn/platform_specific_information id28}@anchor{1f6} @subsubsection Ada DLLs and Elaboration @@ -24128,7 +24269,7 @@ the Ada elaboration routine @code{adainit} generated by the GNAT binder (@ref{a0,,Binding with Non-Ada Main Programs}). See the body of @code{Initialize_Api} for an example. Note that the GNAT binder is automatically invoked during the DLL build process by the @code{gnatdll} -tool (@ref{1e5,,Using gnatdll}). +tool (@ref{1e9,,Using gnatdll}). When a DLL is loaded, Windows systematically invokes a routine called @code{DllMain}. It would therefore be possible to call @code{adainit} @@ -24141,7 +24282,7 @@ time), which means that the GNAT run-time will deadlock waiting for the newly created task to complete its initialization. @node Ada DLLs and Finalization,Creating a Spec for Ada DLLs,Building DLLs with gnatdll,Mixed-Language Programming on Windows -@anchor{gnat_ugn/platform_specific_information ada-dlls-and-finalization}@anchor{1ee}@anchor{gnat_ugn/platform_specific_information id29}@anchor{1f3} +@anchor{gnat_ugn/platform_specific_information ada-dlls-and-finalization}@anchor{1f2}@anchor{gnat_ugn/platform_specific_information id29}@anchor{1f7} @subsubsection Ada DLLs and Finalization @@ -24156,10 +24297,10 @@ routine @code{adafinal} generated by the GNAT binder See the body of @code{Finalize_Api} for an example. As already pointed out the GNAT binder is automatically invoked during the DLL build process by the @code{gnatdll} tool -(@ref{1e5,,Using gnatdll}). +(@ref{1e9,,Using gnatdll}). @node Creating a Spec for Ada DLLs,GNAT and Windows Resources,Ada DLLs and Finalization,Mixed-Language Programming on Windows -@anchor{gnat_ugn/platform_specific_information creating-a-spec-for-ada-dlls}@anchor{1f4}@anchor{gnat_ugn/platform_specific_information id30}@anchor{1f5} +@anchor{gnat_ugn/platform_specific_information creating-a-spec-for-ada-dlls}@anchor{1f8}@anchor{gnat_ugn/platform_specific_information id30}@anchor{1f9} @subsubsection Creating a Spec for Ada DLLs @@ -24217,7 +24358,7 @@ end API; @end menu @node Creating the Definition File,Using gnatdll,,Creating a Spec for Ada DLLs -@anchor{gnat_ugn/platform_specific_information creating-the-definition-file}@anchor{1f1}@anchor{gnat_ugn/platform_specific_information id31}@anchor{1f6} +@anchor{gnat_ugn/platform_specific_information creating-the-definition-file}@anchor{1f5}@anchor{gnat_ugn/platform_specific_information id31}@anchor{1fa} @subsubsection Creating the Definition File @@ -24253,7 +24394,7 @@ EXPORTS @end quotation @node Using gnatdll,,Creating the Definition File,Creating a Spec for Ada DLLs -@anchor{gnat_ugn/platform_specific_information id32}@anchor{1f7}@anchor{gnat_ugn/platform_specific_information using-gnatdll}@anchor{1e5} +@anchor{gnat_ugn/platform_specific_information id32}@anchor{1fb}@anchor{gnat_ugn/platform_specific_information using-gnatdll}@anchor{1e9} @subsubsection Using @code{gnatdll} @@ -24464,7 +24605,7 @@ asks @code{gnatlink} to generate the routines @code{DllMain} and is loaded into memory. @item -@code{gnatdll} uses @code{dlltool} (see @ref{1f8,,Using dlltool}) to build the +@code{gnatdll} uses @code{dlltool} (see @ref{1fc,,Using dlltool}) to build the export table (@code{api.exp}). The export table contains the relocation information in a form which can be used during the final link to ensure that the Windows loader is able to place the DLL anywhere in memory. @@ -24503,7 +24644,7 @@ $ gnatbind -n api $ gnatlink api api.exp -o api.dll -mdll @end example @end itemize -@anchor{gnat_ugn/platform_specific_information using-dlltool}@anchor{1f8} +@anchor{gnat_ugn/platform_specific_information using-dlltool}@anchor{1fc} @subsubheading Using @code{dlltool} @@ -24562,7 +24703,7 @@ DLL in the static import library generated by @code{dlltool} with switch @item @code{-k} Kill @code{@@@var{nn}} from exported names -(@ref{1d2,,Windows Calling Conventions} +(@ref{1d6,,Windows Calling Conventions} for a discussion about @code{Stdcall}-style symbols). @end table @@ -24618,7 +24759,7 @@ Use @code{assembler-name} as the assembler. The default is @code{as}. @end table @node GNAT and Windows Resources,Using GNAT DLLs from Microsoft Visual Studio Applications,Creating a Spec for Ada DLLs,Mixed-Language Programming on Windows -@anchor{gnat_ugn/platform_specific_information gnat-and-windows-resources}@anchor{1f9}@anchor{gnat_ugn/platform_specific_information id33}@anchor{1fa} +@anchor{gnat_ugn/platform_specific_information gnat-and-windows-resources}@anchor{1fd}@anchor{gnat_ugn/platform_specific_information id33}@anchor{1fe} @subsubsection GNAT and Windows Resources @@ -24713,7 +24854,7 @@ the corresponding Microsoft documentation. @end menu @node Building Resources,Compiling Resources,,GNAT and Windows Resources -@anchor{gnat_ugn/platform_specific_information building-resources}@anchor{1fb}@anchor{gnat_ugn/platform_specific_information id34}@anchor{1fc} +@anchor{gnat_ugn/platform_specific_information building-resources}@anchor{1ff}@anchor{gnat_ugn/platform_specific_information id34}@anchor{200} @subsubsection Building Resources @@ -24733,7 +24874,7 @@ complete description of the resource script language can be found in the Microsoft documentation. @node Compiling Resources,Using Resources,Building Resources,GNAT and Windows Resources -@anchor{gnat_ugn/platform_specific_information compiling-resources}@anchor{1fd}@anchor{gnat_ugn/platform_specific_information id35}@anchor{1fe} +@anchor{gnat_ugn/platform_specific_information compiling-resources}@anchor{201}@anchor{gnat_ugn/platform_specific_information id35}@anchor{202} @subsubsection Compiling Resources @@ -24775,7 +24916,7 @@ $ windres -i myres.res -o myres.o @end quotation @node Using Resources,,Compiling Resources,GNAT and Windows Resources -@anchor{gnat_ugn/platform_specific_information id36}@anchor{1ff}@anchor{gnat_ugn/platform_specific_information using-resources}@anchor{200} +@anchor{gnat_ugn/platform_specific_information id36}@anchor{203}@anchor{gnat_ugn/platform_specific_information using-resources}@anchor{204} @subsubsection Using Resources @@ -24795,7 +24936,7 @@ $ gnatmake myprog -largs myres.o @end quotation @node Using GNAT DLLs from Microsoft Visual Studio Applications,Debugging a DLL,GNAT and Windows Resources,Mixed-Language Programming on Windows -@anchor{gnat_ugn/platform_specific_information using-gnat-dll-from-msvs}@anchor{201}@anchor{gnat_ugn/platform_specific_information using-gnat-dlls-from-microsoft-visual-studio-applications}@anchor{202} +@anchor{gnat_ugn/platform_specific_information using-gnat-dll-from-msvs}@anchor{205}@anchor{gnat_ugn/platform_specific_information using-gnat-dlls-from-microsoft-visual-studio-applications}@anchor{206} @subsubsection Using GNAT DLLs from Microsoft Visual Studio Applications @@ -24829,7 +24970,7 @@ $ gprbuild -p mylib.gpr @item Produce a .def file for the symbols you need to interface with, either by hand or automatically with possibly some manual adjustments -(see @ref{1e3,,Creating Definition File Automatically}): +(see @ref{1e7,,Creating Definition File Automatically}): @end enumerate @quotation @@ -24846,7 +24987,7 @@ $ dlltool libmylib.dll -z libmylib.def --export-all-symbols Make sure that MSVS command-line tools are accessible on the path. @item -Create the Microsoft-style import library (see @ref{1e6,,MSVS-Style Import Library}): +Create the Microsoft-style import library (see @ref{1ea,,MSVS-Style Import Library}): @end enumerate @quotation @@ -24888,7 +25029,7 @@ or copy the DLL into into the directory containing the .exe. @end enumerate @node Debugging a DLL,Setting Stack Size from gnatlink,Using GNAT DLLs from Microsoft Visual Studio Applications,Mixed-Language Programming on Windows -@anchor{gnat_ugn/platform_specific_information debugging-a-dll}@anchor{203}@anchor{gnat_ugn/platform_specific_information id37}@anchor{204} +@anchor{gnat_ugn/platform_specific_information debugging-a-dll}@anchor{207}@anchor{gnat_ugn/platform_specific_information id37}@anchor{208} @subsubsection Debugging a DLL @@ -24926,7 +25067,7 @@ tools suite used to build the DLL. @end menu @node Program and DLL Both Built with GCC/GNAT,Program Built with Foreign Tools and DLL Built with GCC/GNAT,,Debugging a DLL -@anchor{gnat_ugn/platform_specific_information id38}@anchor{205}@anchor{gnat_ugn/platform_specific_information program-and-dll-both-built-with-gcc-gnat}@anchor{206} +@anchor{gnat_ugn/platform_specific_information id38}@anchor{209}@anchor{gnat_ugn/platform_specific_information program-and-dll-both-built-with-gcc-gnat}@anchor{20a} @subsubsection Program and DLL Both Built with GCC/GNAT @@ -24936,7 +25077,7 @@ the process. Let’s suppose here that the main procedure is named @code{ada_main} and that in the DLL there is an entry point named @code{ada_dll}. -The DLL (@ref{1dc,,Introduction to Dynamic Link Libraries (DLLs)}) and +The DLL (@ref{1e0,,Introduction to Dynamic Link Libraries (DLLs)}) and program must have been built with the debugging information (see GNAT -g switch). Here are the step-by-step instructions for debugging it: @@ -24973,10 +25114,10 @@ Set a breakpoint inside the DLL At this stage a breakpoint is set inside the DLL. From there on you can use the standard approach to debug the whole program -(@ref{14d,,Running and Debugging Ada Programs}). +(@ref{14f,,Running and Debugging Ada Programs}). @node Program Built with Foreign Tools and DLL Built with GCC/GNAT,,Program and DLL Both Built with GCC/GNAT,Debugging a DLL -@anchor{gnat_ugn/platform_specific_information id39}@anchor{207}@anchor{gnat_ugn/platform_specific_information program-built-with-foreign-tools-and-dll-built-with-gcc-gnat}@anchor{208} +@anchor{gnat_ugn/platform_specific_information id39}@anchor{20b}@anchor{gnat_ugn/platform_specific_information program-built-with-foreign-tools-and-dll-built-with-gcc-gnat}@anchor{20c} @subsubsection Program Built with Foreign Tools and DLL Built with GCC/GNAT @@ -24993,7 +25134,7 @@ example some C code built with Microsoft Visual C) and that there is a DLL named @code{test.dll} containing an Ada entry point named @code{ada_dll}. -The DLL (see @ref{1dc,,Introduction to Dynamic Link Libraries (DLLs)}) must have +The DLL (see @ref{1e0,,Introduction to Dynamic Link Libraries (DLLs)}) must have been built with debugging information (see the GNAT @code{-g} option). @subsubheading Debugging the DLL Directly @@ -25059,7 +25200,7 @@ Continue the program. This will run the program until it reaches the breakpoint that has been set. From that point you can use the standard way to debug a program -as described in (@ref{14d,,Running and Debugging Ada Programs}). +as described in (@ref{14f,,Running and Debugging Ada Programs}). @end itemize It is also possible to debug the DLL by attaching to a running process. @@ -25129,10 +25270,10 @@ Continue process execution. This last step will resume the process execution, and stop at the breakpoint we have set. From there you can use the standard approach to debug a program as described in -@ref{14d,,Running and Debugging Ada Programs}. +@ref{14f,,Running and Debugging Ada Programs}. @node Setting Stack Size from gnatlink,Setting Heap Size from gnatlink,Debugging a DLL,Mixed-Language Programming on Windows -@anchor{gnat_ugn/platform_specific_information id40}@anchor{209}@anchor{gnat_ugn/platform_specific_information setting-stack-size-from-gnatlink}@anchor{127} +@anchor{gnat_ugn/platform_specific_information id40}@anchor{20d}@anchor{gnat_ugn/platform_specific_information setting-stack-size-from-gnatlink}@anchor{129} @subsubsection Setting Stack Size from @code{gnatlink} @@ -25175,7 +25316,7 @@ because the comma is a separator for this option. @end itemize @node Setting Heap Size from gnatlink,,Setting Stack Size from gnatlink,Mixed-Language Programming on Windows -@anchor{gnat_ugn/platform_specific_information id41}@anchor{20a}@anchor{gnat_ugn/platform_specific_information setting-heap-size-from-gnatlink}@anchor{128} +@anchor{gnat_ugn/platform_specific_information id41}@anchor{20e}@anchor{gnat_ugn/platform_specific_information setting-heap-size-from-gnatlink}@anchor{12a} @subsubsection Setting Heap Size from @code{gnatlink} @@ -25208,7 +25349,7 @@ because the comma is a separator for this option. @end itemize @node Windows Specific Add-Ons,,Mixed-Language Programming on Windows,Microsoft Windows Topics -@anchor{gnat_ugn/platform_specific_information win32-specific-addons}@anchor{20b}@anchor{gnat_ugn/platform_specific_information windows-specific-add-ons}@anchor{20c} +@anchor{gnat_ugn/platform_specific_information win32-specific-addons}@anchor{20f}@anchor{gnat_ugn/platform_specific_information windows-specific-add-ons}@anchor{210} @subsection Windows Specific Add-Ons @@ -25221,7 +25362,7 @@ This section describes the Windows specific add-ons. @end menu @node Win32Ada,wPOSIX,,Windows Specific Add-Ons -@anchor{gnat_ugn/platform_specific_information id42}@anchor{20d}@anchor{gnat_ugn/platform_specific_information win32ada}@anchor{20e} +@anchor{gnat_ugn/platform_specific_information id42}@anchor{211}@anchor{gnat_ugn/platform_specific_information win32ada}@anchor{212} @subsubsection Win32Ada @@ -25252,7 +25393,7 @@ gprbuild p.gpr @end quotation @node wPOSIX,,Win32Ada,Windows Specific Add-Ons -@anchor{gnat_ugn/platform_specific_information id43}@anchor{20f}@anchor{gnat_ugn/platform_specific_information wposix}@anchor{210} +@anchor{gnat_ugn/platform_specific_information id43}@anchor{213}@anchor{gnat_ugn/platform_specific_information wposix}@anchor{214} @subsubsection wPOSIX @@ -25285,7 +25426,7 @@ gprbuild p.gpr @end quotation @node Mac OS Topics,,Microsoft Windows Topics,Platform-Specific Information -@anchor{gnat_ugn/platform_specific_information id44}@anchor{211}@anchor{gnat_ugn/platform_specific_information mac-os-topics}@anchor{212} +@anchor{gnat_ugn/platform_specific_information id44}@anchor{215}@anchor{gnat_ugn/platform_specific_information mac-os-topics}@anchor{216} @section Mac OS Topics @@ -25300,7 +25441,7 @@ platform. @end menu @node Codesigning the Debugger,,,Mac OS Topics -@anchor{gnat_ugn/platform_specific_information codesigning-the-debugger}@anchor{213} +@anchor{gnat_ugn/platform_specific_information codesigning-the-debugger}@anchor{217} @subsection Codesigning the Debugger @@ -25381,7 +25522,7 @@ the location where you installed GNAT. Also, be sure that users are in the Unix group @code{_developer}. @node Example of Binder Output File,Elaboration Order Handling in GNAT,Platform-Specific Information,Top -@anchor{gnat_ugn/example_of_binder_output doc}@anchor{214}@anchor{gnat_ugn/example_of_binder_output example-of-binder-output-file}@anchor{e}@anchor{gnat_ugn/example_of_binder_output id1}@anchor{215} +@anchor{gnat_ugn/example_of_binder_output doc}@anchor{218}@anchor{gnat_ugn/example_of_binder_output example-of-binder-output-file}@anchor{e}@anchor{gnat_ugn/example_of_binder_output id1}@anchor{219} @chapter Example of Binder Output File @@ -26133,7 +26274,7 @@ elaboration code in your own application). @c -- Example: A |withing| unit has a |with| clause, it |withs| a |withed| unit @node Elaboration Order Handling in GNAT,Inline Assembler,Example of Binder Output File,Top -@anchor{gnat_ugn/elaboration_order_handling_in_gnat doc}@anchor{216}@anchor{gnat_ugn/elaboration_order_handling_in_gnat elaboration-order-handling-in-gnat}@anchor{f}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id1}@anchor{217} +@anchor{gnat_ugn/elaboration_order_handling_in_gnat doc}@anchor{21a}@anchor{gnat_ugn/elaboration_order_handling_in_gnat elaboration-order-handling-in-gnat}@anchor{f}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id1}@anchor{21b} @chapter Elaboration Order Handling in GNAT @@ -26163,7 +26304,7 @@ GNAT, either automatically or with explicit programming features. @end menu @node Elaboration Code,Elaboration Order,,Elaboration Order Handling in GNAT -@anchor{gnat_ugn/elaboration_order_handling_in_gnat elaboration-code}@anchor{218}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id2}@anchor{219} +@anchor{gnat_ugn/elaboration_order_handling_in_gnat elaboration-code}@anchor{21c}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id2}@anchor{21d} @section Elaboration Code @@ -26311,7 +26452,7 @@ elaborated. @end itemize @node Elaboration Order,Checking the Elaboration Order,Elaboration Code,Elaboration Order Handling in GNAT -@anchor{gnat_ugn/elaboration_order_handling_in_gnat elaboration-order}@anchor{21a}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id3}@anchor{21b} +@anchor{gnat_ugn/elaboration_order_handling_in_gnat elaboration-order}@anchor{21e}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id3}@anchor{21f} @section Elaboration Order @@ -26480,7 +26621,7 @@ however a compiler may not always find such an order due to complications with respect to control and data flow. @node Checking the Elaboration Order,Controlling the Elaboration Order in Ada,Elaboration Order,Elaboration Order Handling in GNAT -@anchor{gnat_ugn/elaboration_order_handling_in_gnat checking-the-elaboration-order}@anchor{21c}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id4}@anchor{21d} +@anchor{gnat_ugn/elaboration_order_handling_in_gnat checking-the-elaboration-order}@anchor{220}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id4}@anchor{221} @section Checking the Elaboration Order @@ -26541,7 +26682,7 @@ order. @end itemize @node Controlling the Elaboration Order in Ada,Controlling the Elaboration Order in GNAT,Checking the Elaboration Order,Elaboration Order Handling in GNAT -@anchor{gnat_ugn/elaboration_order_handling_in_gnat controlling-the-elaboration-order-in-ada}@anchor{21e}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id5}@anchor{21f} +@anchor{gnat_ugn/elaboration_order_handling_in_gnat controlling-the-elaboration-order-in-ada}@anchor{222}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id5}@anchor{223} @section Controlling the Elaboration Order in Ada @@ -26869,7 +27010,7 @@ is that the program continues to stay in the last state (one or more correct orders exist) even if maintenance changes the bodies of targets. @node Controlling the Elaboration Order in GNAT,Mixing Elaboration Models,Controlling the Elaboration Order in Ada,Elaboration Order Handling in GNAT -@anchor{gnat_ugn/elaboration_order_handling_in_gnat controlling-the-elaboration-order-in-gnat}@anchor{220}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id6}@anchor{221} +@anchor{gnat_ugn/elaboration_order_handling_in_gnat controlling-the-elaboration-order-in-gnat}@anchor{224}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id6}@anchor{225} @section Controlling the Elaboration Order in GNAT @@ -26999,7 +27140,7 @@ The dynamic, legacy, and static models can be relaxed using compiler switch may not diagnose certain elaboration issues or install run-time checks. @node Mixing Elaboration Models,ABE Diagnostics,Controlling the Elaboration Order in GNAT,Elaboration Order Handling in GNAT -@anchor{gnat_ugn/elaboration_order_handling_in_gnat id7}@anchor{222}@anchor{gnat_ugn/elaboration_order_handling_in_gnat mixing-elaboration-models}@anchor{223} +@anchor{gnat_ugn/elaboration_order_handling_in_gnat id7}@anchor{226}@anchor{gnat_ugn/elaboration_order_handling_in_gnat mixing-elaboration-models}@anchor{227} @section Mixing Elaboration Models @@ -27046,7 +27187,7 @@ warning: "y.ads" which has static elaboration checks The warnings can be suppressed by binder switch @code{-ws}. @node ABE Diagnostics,SPARK Diagnostics,Mixing Elaboration Models,Elaboration Order Handling in GNAT -@anchor{gnat_ugn/elaboration_order_handling_in_gnat abe-diagnostics}@anchor{224}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id8}@anchor{225} +@anchor{gnat_ugn/elaboration_order_handling_in_gnat abe-diagnostics}@anchor{228}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id8}@anchor{229} @section ABE Diagnostics @@ -27153,7 +27294,7 @@ declaration @code{Safe} because the body of function @code{ABE} has already been elaborated at that point. @node SPARK Diagnostics,Elaboration Circularities,ABE Diagnostics,Elaboration Order Handling in GNAT -@anchor{gnat_ugn/elaboration_order_handling_in_gnat id9}@anchor{226}@anchor{gnat_ugn/elaboration_order_handling_in_gnat spark-diagnostics}@anchor{227} +@anchor{gnat_ugn/elaboration_order_handling_in_gnat id9}@anchor{22a}@anchor{gnat_ugn/elaboration_order_handling_in_gnat spark-diagnostics}@anchor{22b} @section SPARK Diagnostics @@ -27179,7 +27320,7 @@ rules. @end quotation @node Elaboration Circularities,Resolving Elaboration Circularities,SPARK Diagnostics,Elaboration Order Handling in GNAT -@anchor{gnat_ugn/elaboration_order_handling_in_gnat elaboration-circularities}@anchor{228}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id10}@anchor{229} +@anchor{gnat_ugn/elaboration_order_handling_in_gnat elaboration-circularities}@anchor{22c}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id10}@anchor{22d} @section Elaboration Circularities @@ -27279,7 +27420,7 @@ This section enumerates various tactics for eliminating the circularity. @end itemize @node Resolving Elaboration Circularities,Elaboration-related Compiler Switches,Elaboration Circularities,Elaboration Order Handling in GNAT -@anchor{gnat_ugn/elaboration_order_handling_in_gnat id11}@anchor{22a}@anchor{gnat_ugn/elaboration_order_handling_in_gnat resolving-elaboration-circularities}@anchor{22b} +@anchor{gnat_ugn/elaboration_order_handling_in_gnat id11}@anchor{22e}@anchor{gnat_ugn/elaboration_order_handling_in_gnat resolving-elaboration-circularities}@anchor{22f} @section Resolving Elaboration Circularities @@ -27551,7 +27692,7 @@ Use the relaxed dynamic-elaboration model, with compiler switches @end itemize @node Elaboration-related Compiler Switches,Summary of Procedures for Elaboration Control,Resolving Elaboration Circularities,Elaboration Order Handling in GNAT -@anchor{gnat_ugn/elaboration_order_handling_in_gnat elaboration-related-compiler-switches}@anchor{22c}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id12}@anchor{22d} +@anchor{gnat_ugn/elaboration_order_handling_in_gnat elaboration-related-compiler-switches}@anchor{230}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id12}@anchor{231} @section Elaboration-related Compiler Switches @@ -27732,7 +27873,7 @@ checks. The example above will still fail at run time with an ABE. @end table @node Summary of Procedures for Elaboration Control,Inspecting the Chosen Elaboration Order,Elaboration-related Compiler Switches,Elaboration Order Handling in GNAT -@anchor{gnat_ugn/elaboration_order_handling_in_gnat id13}@anchor{22e}@anchor{gnat_ugn/elaboration_order_handling_in_gnat summary-of-procedures-for-elaboration-control}@anchor{22f} +@anchor{gnat_ugn/elaboration_order_handling_in_gnat id13}@anchor{232}@anchor{gnat_ugn/elaboration_order_handling_in_gnat summary-of-procedures-for-elaboration-control}@anchor{233} @section Summary of Procedures for Elaboration Control @@ -27790,7 +27931,7 @@ Use the relaxed dynamic elaboration model, with compiler switches @end itemize @node Inspecting the Chosen Elaboration Order,,Summary of Procedures for Elaboration Control,Elaboration Order Handling in GNAT -@anchor{gnat_ugn/elaboration_order_handling_in_gnat id14}@anchor{230}@anchor{gnat_ugn/elaboration_order_handling_in_gnat inspecting-the-chosen-elaboration-order}@anchor{231} +@anchor{gnat_ugn/elaboration_order_handling_in_gnat id14}@anchor{234}@anchor{gnat_ugn/elaboration_order_handling_in_gnat inspecting-the-chosen-elaboration-order}@anchor{235} @section Inspecting the Chosen Elaboration Order @@ -27933,7 +28074,7 @@ gdbstr (body) @end quotation @node Inline Assembler,GNU Free Documentation License,Elaboration Order Handling in GNAT,Top -@anchor{gnat_ugn/inline_assembler doc}@anchor{232}@anchor{gnat_ugn/inline_assembler id1}@anchor{233}@anchor{gnat_ugn/inline_assembler inline-assembler}@anchor{10} +@anchor{gnat_ugn/inline_assembler doc}@anchor{236}@anchor{gnat_ugn/inline_assembler id1}@anchor{237}@anchor{gnat_ugn/inline_assembler inline-assembler}@anchor{10} @chapter Inline Assembler @@ -27992,7 +28133,7 @@ and with assembly language programming. @end menu @node Basic Assembler Syntax,A Simple Example of Inline Assembler,,Inline Assembler -@anchor{gnat_ugn/inline_assembler basic-assembler-syntax}@anchor{234}@anchor{gnat_ugn/inline_assembler id2}@anchor{235} +@anchor{gnat_ugn/inline_assembler basic-assembler-syntax}@anchor{238}@anchor{gnat_ugn/inline_assembler id2}@anchor{239} @section Basic Assembler Syntax @@ -28108,7 +28249,7 @@ Intel: Destination first; for example @code{mov eax, 4}@w{ } @node A Simple Example of Inline Assembler,Output Variables in Inline Assembler,Basic Assembler Syntax,Inline Assembler -@anchor{gnat_ugn/inline_assembler a-simple-example-of-inline-assembler}@anchor{236}@anchor{gnat_ugn/inline_assembler id3}@anchor{237} +@anchor{gnat_ugn/inline_assembler a-simple-example-of-inline-assembler}@anchor{23a}@anchor{gnat_ugn/inline_assembler id3}@anchor{23b} @section A Simple Example of Inline Assembler @@ -28257,7 +28398,7 @@ If there are no errors, @code{as} will generate an object file @code{nothing.out}. @node Output Variables in Inline Assembler,Input Variables in Inline Assembler,A Simple Example of Inline Assembler,Inline Assembler -@anchor{gnat_ugn/inline_assembler id4}@anchor{238}@anchor{gnat_ugn/inline_assembler output-variables-in-inline-assembler}@anchor{239} +@anchor{gnat_ugn/inline_assembler id4}@anchor{23c}@anchor{gnat_ugn/inline_assembler output-variables-in-inline-assembler}@anchor{23d} @section Output Variables in Inline Assembler @@ -28624,7 +28765,7 @@ end Get_Flags_3; @end quotation @node Input Variables in Inline Assembler,Inlining Inline Assembler Code,Output Variables in Inline Assembler,Inline Assembler -@anchor{gnat_ugn/inline_assembler id5}@anchor{23a}@anchor{gnat_ugn/inline_assembler input-variables-in-inline-assembler}@anchor{23b} +@anchor{gnat_ugn/inline_assembler id5}@anchor{23e}@anchor{gnat_ugn/inline_assembler input-variables-in-inline-assembler}@anchor{23f} @section Input Variables in Inline Assembler @@ -28713,7 +28854,7 @@ _increment__incr.1: @end quotation @node Inlining Inline Assembler Code,Other Asm Functionality,Input Variables in Inline Assembler,Inline Assembler -@anchor{gnat_ugn/inline_assembler id6}@anchor{23c}@anchor{gnat_ugn/inline_assembler inlining-inline-assembler-code}@anchor{23d} +@anchor{gnat_ugn/inline_assembler id6}@anchor{240}@anchor{gnat_ugn/inline_assembler inlining-inline-assembler-code}@anchor{241} @section Inlining Inline Assembler Code @@ -28784,7 +28925,7 @@ movl %esi,%eax thus saving the overhead of stack frame setup and an out-of-line call. @node Other Asm Functionality,,Inlining Inline Assembler Code,Inline Assembler -@anchor{gnat_ugn/inline_assembler id7}@anchor{23e}@anchor{gnat_ugn/inline_assembler other-asm-functionality}@anchor{23f} +@anchor{gnat_ugn/inline_assembler id7}@anchor{242}@anchor{gnat_ugn/inline_assembler other-asm-functionality}@anchor{243} @section Other @code{Asm} Functionality @@ -28799,7 +28940,7 @@ and @code{Volatile}, which inhibits unwanted optimizations. @end menu @node The Clobber Parameter,The Volatile Parameter,,Other Asm Functionality -@anchor{gnat_ugn/inline_assembler id8}@anchor{240}@anchor{gnat_ugn/inline_assembler the-clobber-parameter}@anchor{241} +@anchor{gnat_ugn/inline_assembler id8}@anchor{244}@anchor{gnat_ugn/inline_assembler the-clobber-parameter}@anchor{245} @subsection The @code{Clobber} Parameter @@ -28863,7 +29004,7 @@ Use ‘register’ name @code{memory} if you changed a memory location @end itemize @node The Volatile Parameter,,The Clobber Parameter,Other Asm Functionality -@anchor{gnat_ugn/inline_assembler id9}@anchor{242}@anchor{gnat_ugn/inline_assembler the-volatile-parameter}@anchor{243} +@anchor{gnat_ugn/inline_assembler id9}@anchor{246}@anchor{gnat_ugn/inline_assembler the-volatile-parameter}@anchor{247} @subsection The @code{Volatile} Parameter @@ -28899,7 +29040,7 @@ to @code{True} only if the compiler’s optimizations have created problems. @node GNU Free Documentation License,Index,Inline Assembler,Top -@anchor{share/gnu_free_documentation_license doc}@anchor{244}@anchor{share/gnu_free_documentation_license gnu-fdl}@anchor{1}@anchor{share/gnu_free_documentation_license gnu-free-documentation-license}@anchor{245} +@anchor{share/gnu_free_documentation_license doc}@anchor{248}@anchor{share/gnu_free_documentation_license gnu-fdl}@anchor{1}@anchor{share/gnu_free_documentation_license gnu-free-documentation-license}@anchor{249} @chapter GNU Free Documentation License @@ -29387,8 +29528,8 @@ to permit their use in free software. @printindex ge +@anchor{d1}@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/gnatls.adb b/gcc/ada/gnatls.adb index a29205c..a9e88af 100644 --- a/gcc/ada/gnatls.adb +++ b/gcc/ada/gnatls.adb @@ -1414,7 +1414,7 @@ procedure Gnatls is First := 3; loop while First <= Name_Len - and then (Name_Buffer (First) = Path_Separator) + and then Name_Buffer (First) = Path_Separator loop First := First + 1; end loop; @@ -2170,7 +2170,7 @@ begin First := Prj_Path'First; loop while First <= Prj_Path'Last - and then (Prj_Path (First) = Path_Separator) + and then Prj_Path (First) = Path_Separator loop First := First + 1; end loop; diff --git a/gcc/ada/gnatvsn.ads b/gcc/ada/gnatvsn.ads index b6edc9d..a0e61e1 100644 --- a/gcc/ada/gnatvsn.ads +++ b/gcc/ada/gnatvsn.ads @@ -32,7 +32,7 @@ package Gnatvsn is -- Static string identifying this version, that can be used as an argument -- to e.g. pragma Ident. - Library_Version : constant String := "13"; + Library_Version : constant String := "14"; -- Library version. It needs to be updated whenever the major version -- number is changed. -- diff --git a/gcc/ada/gprep.adb b/gcc/ada/gprep.adb index 7c6c09f..5b58955 100644 --- a/gcc/ada/gprep.adb +++ b/gcc/ada/gprep.adb @@ -228,7 +228,7 @@ package body GPrep is -- the deleted lines are not put as comment, we must output them as -- blank lines. - if Source_Ref_Pragma and (not Opt.Comment_Deleted_Lines) then + if Source_Ref_Pragma and not Opt.Comment_Deleted_Lines then Opt.Blank_Deleted_Lines := True; end if; diff --git a/gcc/ada/init.c b/gcc/ada/init.c index 5212a38..53ca142 100644 --- a/gcc/ada/init.c +++ b/gcc/ada/init.c @@ -248,7 +248,7 @@ __gnat_error_handler (int sig, switch (sig) { case SIGSEGV: - /* FIXME: we need to detect the case of a *real* SIGSEGV. */ + /* ??? we need to detect the case of a *real* SIGSEGV. */ exception = &storage_error; msg = "stack overflow or erroneous memory access"; break; @@ -340,7 +340,7 @@ __gnat_error_handler (int sig, siginfo_t *si ATTRIBUTE_UNUSED, void *ucontext) switch (sig) { case SIGSEGV: - /* FIXME: we need to detect the case of a *real* SIGSEGV. */ + /* ??? we need to detect the case of a *real* SIGSEGV. */ exception = &storage_error; msg = "stack overflow or erroneous memory access"; break; diff --git a/gcc/ada/inline.adb b/gcc/ada/inline.adb index c3911cf..edb90a9 100644 --- a/gcc/ada/inline.adb +++ b/gcc/ada/inline.adb @@ -312,9 +312,11 @@ package body Inline is -- Remove all aspects and/or pragmas that have no meaning in inlined body -- Body_Decl. The analysis of these items is performed on the non-inlined -- body. The items currently removed are: + -- Always_Terminates -- Contract_Cases -- Global -- Depends + -- Exceptional_Cases -- Postcondition -- Precondition -- Refined_Global @@ -333,17 +335,17 @@ package body Inline is -- Deferred Cleanup Actions -- ------------------------------ - -- The cleanup actions for scopes that contain instantiations is delayed - -- until after expansion of those instantiations, because they may contain - -- finalizable objects or tasks that affect the cleanup code. A scope - -- that contains instantiations only needs to be finalized once, even - -- if it contains more than one instance. We keep a list of scopes - -- that must still be finalized, and call cleanup_actions after all - -- the instantiations have been completed. + -- The cleanup actions for scopes that contain package instantiations with + -- a body are delayed until after the package body is instantiated. because + -- the body may contain finalizable objects or other constructs that affect + -- the cleanup code. A scope that contains such instantiations only needs + -- to be finalized once, even though it may contain more than one instance. + -- We keep a list of scopes that must still be finalized and Cleanup_Scopes + -- will be invoked after all the body instantiations have been completed. To_Clean : Elist_Id; - procedure Add_Scope_To_Clean (Inst : Entity_Id); + procedure Add_Scope_To_Clean (Scop : Entity_Id); -- Build set of scopes on which cleanup actions must be performed procedure Cleanup_Scopes; @@ -782,7 +784,11 @@ package body Inline is -- Add_Pending_Instantiation -- -------------------------------- - procedure Add_Pending_Instantiation (Inst : Node_Id; Act_Decl : Node_Id) is + procedure Add_Pending_Instantiation + (Inst : Node_Id; + Act_Decl : Node_Id; + Fin_Scop : Node_Id := Empty) + is Act_Decl_Id : Entity_Id; Index : Int; @@ -801,11 +807,12 @@ package body Inline is -- for later processing by Instantiate_Bodies. Pending_Instantiations.Append - ((Act_Decl => Act_Decl, + ((Inst_Node => Inst, + Act_Decl => Act_Decl, + Fin_Scop => Fin_Scop, Config_Switches => Save_Config_Switches, Current_Sem_Unit => Current_Sem_Unit, Expander_Status => Expander_Active, - Inst_Node => Inst, Local_Suppress_Stack_Top => Local_Suppress_Stack_Top, Scope_Suppress => Scope_Suppress, Warnings => Save_Warnings)); @@ -837,37 +844,10 @@ package body Inline is -- Add_Scope_To_Clean -- ------------------------ - procedure Add_Scope_To_Clean (Inst : Entity_Id) is - Scop : constant Entity_Id := Enclosing_Dynamic_Scope (Inst); + procedure Add_Scope_To_Clean (Scop : Entity_Id) is Elmt : Elmt_Id; begin - -- If the instance appears in a library-level package declaration, - -- all finalization is global, and nothing needs doing here. - - if Scop = Standard_Standard then - return; - end if; - - -- If the instance is within a generic unit, no finalization code - -- can be generated. Note that at this point all bodies have been - -- analyzed, and the scope stack itself is not present, and the flag - -- Inside_A_Generic is not set. - - declare - S : Entity_Id; - - begin - S := Scope (Inst); - while Present (S) and then S /= Standard_Standard loop - if Is_Generic_Unit (S) then - return; - end if; - - S := Scope (S); - end loop; - end; - Elmt := First_Elmt (To_Clean); while Present (Elmt) loop if Node (Elmt) = Scop then @@ -2815,37 +2795,19 @@ package body Inline is -------------------- procedure Cleanup_Scopes is - Elmt : Elmt_Id; Decl : Node_Id; + Elmt : Elmt_Id; + Fin : Entity_Id; + Kind : Entity_Kind; Scop : Entity_Id; begin Elmt := First_Elmt (To_Clean); while Present (Elmt) loop Scop := Node (Elmt); + Kind := Ekind (Scop); - if Ekind (Scop) = E_Entry then - Scop := Protected_Body_Subprogram (Scop); - - elsif Is_Subprogram (Scop) - and then Is_Protected_Type (Underlying_Type (Scope (Scop))) - and then Present (Protected_Body_Subprogram (Scop)) - then - -- If a protected operation contains an instance, its cleanup - -- operations have been delayed, and the subprogram has been - -- rewritten in the expansion of the enclosing protected body. It - -- is the corresponding subprogram that may require the cleanup - -- operations, so propagate the information that triggers cleanup - -- activity. - - Set_Uses_Sec_Stack - (Protected_Body_Subprogram (Scop), - Uses_Sec_Stack (Scop)); - - Scop := Protected_Body_Subprogram (Scop); - end if; - - if Ekind (Scop) = E_Block then + if Kind = E_Block then Decl := Parent (Block_Node (Scop)); else @@ -2859,14 +2821,55 @@ package body Inline is end if; end if; - Push_Scope (Scop); - Expand_Cleanup_Actions (Decl); - End_Scope; + -- Finalizers are built only for package specs and bodies that are + -- compilation units, so check that we do not have anything else. + -- Moreover, they must be built at most once for each entity during + -- the compilation of the main unit. However, if other units are + -- later compiled for inlining purposes, they may also contain body + -- instances and, therefore, appear again here, so we need to make + -- sure that we do not build two finalizers for them (note that the + -- contents of the finalizer for these units is irrelevant since it + -- is not output in the generated code). + + if Kind in E_Package | E_Package_Body then + declare + Unit_Entity : constant Entity_Id := + (if Kind = E_Package then Scop else Spec_Entity (Scop)); + + begin + pragma Assert (Is_Compilation_Unit (Unit_Entity) + and then (No (Finalizer (Scop)) + or else Unit_Entity /= Main_Unit_Entity)); + + if No (Finalizer (Scop)) then + Build_Finalizer + (N => Decl, + Clean_Stmts => No_List, + Mark_Id => Empty, + Top_Decls => No_List, + Defer_Abort => False, + Fin_Id => Fin); + + if Present (Fin) then + Set_Finalizer (Scop, Fin); + end if; + end if; + end; + + else + Push_Scope (Scop); + Expand_Cleanup_Actions (Decl); + End_Scope; + end if; Next_Elmt (Elmt); end loop; end Cleanup_Scopes; + ----------------------------------------------- + -- Establish_Actual_Mapping_For_Inlined_Call -- + ----------------------------------------------- + procedure Establish_Actual_Mapping_For_Inlined_Call (N : Node_Id; Subp : Entity_Id; @@ -4851,6 +4854,8 @@ package body Inline is ------------------------ procedure Instantiate_Body (Info : Pending_Body_Info) is + Scop : Entity_Id; + begin -- If the instantiation node is absent, it has been removed as part -- of unreachable code. @@ -4865,9 +4870,47 @@ package body Inline is elsif Nkind (Info.Inst_Node) = N_Package_Body then null; - elsif Nkind (Info.Act_Decl) = N_Package_Declaration then + -- For other package instances, instantiate the body and register the + -- finalization scope, if any, for subsequent generation of cleanups. + + elsif Nkind (Info.Inst_Node) = N_Package_Instantiation then + + -- If the enclosing finalization scope is a package body, set the + -- In_Package_Body flag on its spec. This is required, in the case + -- where the body contains other package instantiations that have + -- a body, for Analyze_Package_Instantiation to compute a correct + -- finalization scope. + + if Present (Info.Fin_Scop) + and then Ekind (Info.Fin_Scop) = E_Package_Body + then + Set_In_Package_Body (Spec_Entity (Info.Fin_Scop), True); + end if; + Instantiate_Package_Body (Info); - Add_Scope_To_Clean (Defining_Entity (Info.Act_Decl)); + + if Present (Info.Fin_Scop) then + Scop := Info.Fin_Scop; + + -- If the enclosing finalization scope is dynamic, the instance + -- may have been relocated, for example if it was declared in a + -- protected entry, protected subprogram, or task body. + + if Is_Dynamic_Scope (Scop) then + Scop := + Enclosing_Dynamic_Scope (Defining_Entity (Info.Act_Decl)); + end if; + + Add_Scope_To_Clean (Scop); + + -- Reset the In_Package_Body flag if it was set above + + if Ekind (Info.Fin_Scop) = E_Package_Body then + Set_In_Package_Body (Spec_Entity (Info.Fin_Scop), False); + end if; + end if; + + -- For subprogram instances, always instantiate the body else Instantiate_Subprogram_Body (Info); @@ -5183,9 +5226,11 @@ package body Inline is end if; if Present (Item_Id) - and then Chars (Item_Id) in Name_Contract_Cases + and then Chars (Item_Id) in Name_Always_Terminates + | Name_Contract_Cases | Name_Global | Name_Depends + | Name_Exceptional_Cases | Name_Postcondition | Name_Precondition | Name_Refined_Global diff --git a/gcc/ada/inline.ads b/gcc/ada/inline.ads index 9d83617..65c0968 100644 --- a/gcc/ada/inline.ads +++ b/gcc/ada/inline.ads @@ -61,9 +61,15 @@ package Inline is -- See full description in body of Sem_Ch12 for more details type Pending_Body_Info is record + Inst_Node : Node_Id; + -- Node for instantiation that requires the body + Act_Decl : Node_Id; -- Declaration for package or subprogram spec for instantiation + Fin_Scop : Node_Id; + -- Enclosing finalization scope for package instantiation + Config_Switches : Config_Switches_Type; -- Capture the values of configuration switches @@ -76,9 +82,6 @@ package Inline is -- If the body is instantiated only for semantic checking, expansion -- must be inhibited. - Inst_Node : Node_Id; - -- Node for instantiation that requires the body - Scope_Suppress : Suppress_Record; Local_Suppress_Stack_Top : Suppress_Stack_Entry_Ptr; -- Save suppress information at the point of instantiation. Used to @@ -119,7 +122,10 @@ package Inline is -- Add E's enclosing unit to Inlined_Bodies so that E can be subsequently -- retrieved and analyzed. N is the node giving rise to the call to E. - procedure Add_Pending_Instantiation (Inst : Node_Id; Act_Decl : Node_Id); + procedure Add_Pending_Instantiation + (Inst : Node_Id; + Act_Decl : Node_Id; + Fin_Scop : Node_Id := Empty); -- Add an entry in the table of generic bodies to be instantiated. procedure Analyze_Inlined_Bodies; diff --git a/gcc/ada/lib-load.adb b/gcc/ada/lib-load.adb index d79ee43..72196b4 100644 --- a/gcc/ada/lib-load.adb +++ b/gcc/ada/lib-load.adb @@ -645,11 +645,16 @@ package body Lib.Load is if Is_Predefined_File_Name (Fname) then Error_Msg_Unit_1 := Uname_Actual; Error_Msg - ("$$ is not a language defined unit", Load_Msg_Sloc); + ("$$ is not a language defined unit", + Load_Msg_Sloc, + Error_Node); else Error_Msg_File_1 := Fname; Error_Msg_Unit_1 := Uname_Actual; - Error_Msg ("file{ does not contain unit$", Load_Msg_Sloc); + Error_Msg + ("file{ does not contain unit$", + Load_Msg_Sloc, + Error_Node); end if; Write_Dependency_Chain; @@ -697,7 +702,8 @@ package body Lib.Load is end if; if Present (Error_Node) then - Error_Msg ("circular unit dependency", Load_Msg_Sloc); + Error_Msg + ("circular unit dependency", Load_Msg_Sloc, Error_Node); Write_Dependency_Chain; else Load_Stack.Decrement_Last; @@ -798,11 +804,14 @@ package body Lib.Load is then Error_Msg_File_1 := Unit_File_Name (Corr_Body); Error_Msg - ("cannot compile subprogram in file {!", Load_Msg_Sloc); + ("cannot compile subprogram in file {!", + Load_Msg_Sloc, + Error_Node); Error_Msg_File_1 := Unit_File_Name (Unum); Error_Msg ("\incorrect spec in file { must be removed first!", - Load_Msg_Sloc); + Load_Msg_Sloc, + Error_Node); Unum := No_Unit; goto Done; end if; @@ -879,15 +888,21 @@ package body Lib.Load is Error_Msg_Unit_1 := Uname_Actual; Error_Msg -- CODEFIX - ("$$ is not a predefined library unit", Load_Msg_Sloc); + ("$$ is not a predefined library unit", + Load_Msg_Sloc, + Error_Node); else Error_Msg_File_1 := Fname; if Src_Ind = No_Access_To_Source_File then - Error_Msg ("no read access to file{", Load_Msg_Sloc); + Error_Msg + ("no read access to file{", + Load_Msg_Sloc, + Error_Node + ); else - Error_Msg ("file{ not found", Load_Msg_Sloc); + Error_Msg ("file{ not found", Load_Msg_Sloc, Error_Node); end if; end if; diff --git a/gcc/ada/lib-writ.adb b/gcc/ada/lib-writ.adb index deecfc0..23b6266 100644 --- a/gcc/ada/lib-writ.adb +++ b/gcc/ada/lib-writ.adb @@ -50,6 +50,7 @@ with Rident; use Rident; with Stand; use Stand; with Scn; use Scn; with Sem_Eval; use Sem_Eval; +with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; with Sinfo.Nodes; use Sinfo.Nodes; with Sinfo.Utils; use Sinfo.Utils; @@ -524,10 +525,20 @@ package body Lib.Writ is Write_Info_Str (" O"); Write_Info_Char (OA_Setting (Unit_Num)); - if Ekind (Uent) in E_Package | E_Package_Body - and then Present (Finalizer (Uent)) - then - Write_Info_Str (" PF"); + -- For a package instance with a body that is a library unit, the two + -- compilation units share Cunit_Entity so we cannot rely on Uent. + + if Ukind in N_Package_Declaration | N_Package_Body then + declare + E : constant Entity_Id := Defining_Entity (Unit (Unode)); + + begin + if Ekind (E) in E_Package | E_Package_Body + and then Present (Finalizer (E)) + then + Write_Info_Str (" PF"); + end if; + end; end if; if Is_Preelaborated (Uent) then diff --git a/gcc/ada/lib-xref.adb b/gcc/ada/lib-xref.adb index b45c601..3d6b298 100644 --- a/gcc/ada/lib-xref.adb +++ b/gcc/ada/lib-xref.adb @@ -706,7 +706,7 @@ package body Lib.Xref is Set_Referenced (E); -- For the case where the entity is on the left hand side of an - -- assignment statment, we do nothing here. + -- assignment statement, we do nothing here. -- The processing for Analyze_Assignment_Statement will set the -- Referenced_As_LHS flag. diff --git a/gcc/ada/libgnarl/a-reatim.ads b/gcc/ada/libgnarl/a-reatim.ads index c5009d2..a616d57 100644 --- a/gcc/ada/libgnarl/a-reatim.ads +++ b/gcc/ada/libgnarl/a-reatim.ads @@ -39,9 +39,9 @@ pragma Elaborate_All (System.Task_Primitives.Operations); package Ada.Real_Time with SPARK_Mode, Abstract_State => (Clock_Time with Synchronous), - Initializes => Clock_Time + Initializes => Clock_Time, + Always_Terminates is - pragma Annotate (GNATprove, Always_Return, Real_Time); pragma Compile_Time_Error (Duration'Size /= 64, diff --git a/gcc/ada/libgnarl/a-tasatt.adb b/gcc/ada/libgnarl/a-tasatt.adb index fb3ca68..6111f29 100644 --- a/gcc/ada/libgnarl/a-tasatt.adb +++ b/gcc/ada/libgnarl/a-tasatt.adb @@ -29,6 +29,7 @@ -- -- ------------------------------------------------------------------------------ +with System.Storage_Elements; with System.Tasking; with System.Tasking.Initialization; with System.Tasking.Task_Attributes; @@ -43,6 +44,7 @@ with Ada.Unchecked_Deallocation; package body Ada.Task_Attributes is use System, + System.Storage_Elements, System.Tasking.Initialization, System.Tasking, System.Tasking.Task_Attributes; @@ -75,34 +77,32 @@ package body Ada.Task_Attributes is -- System.Tasking.Task_Attributes.Attribute_Record and to allow unchecked -- conversions between Attribute_Access and Real_Attribute_Access. - function New_Attribute (Val : Attribute) return Atomic_Address; + function New_Attribute (Val : Attribute) return System.Address; -- Create a new Real_Attribute using Val, and return its address. The -- returned value can be converted via To_Real_Attribute. - procedure Deallocate (Ptr : Atomic_Address); + procedure Deallocate (Ptr : System.Address); -- Free memory associated with Ptr, a Real_Attribute_Access in reality function To_Real_Attribute is new - Ada.Unchecked_Conversion (Atomic_Address, Real_Attribute_Access); + Ada.Unchecked_Conversion (System.Address, Real_Attribute_Access); pragma Warnings (Off); -- Kill warning about possible size mismatch function To_Address is new - Ada.Unchecked_Conversion (Attribute, Atomic_Address); + Ada.Unchecked_Conversion (Attribute, System.Address); function To_Attribute is new - Ada.Unchecked_Conversion (Atomic_Address, Attribute); + Ada.Unchecked_Conversion (System.Address, Attribute); type Unsigned is mod 2 ** Integer'Size; - function To_Address is new - Ada.Unchecked_Conversion (Attribute, System.Address); function To_Unsigned is new Ada.Unchecked_Conversion (Attribute, Unsigned); pragma Warnings (On); function To_Address is new - Ada.Unchecked_Conversion (Real_Attribute_Access, Atomic_Address); + Ada.Unchecked_Conversion (Real_Attribute_Access, System.Address); pragma Warnings (Off); -- Kill warning about possible aliasing @@ -121,12 +121,12 @@ package body Ada.Task_Attributes is Fast_Path : constant Boolean := (Attribute'Size = Integer'Size - and then Attribute'Alignment <= Atomic_Address'Alignment + and then Attribute'Alignment <= System.Address'Alignment and then To_Unsigned (Initial_Value) = 0) or else (Attribute'Size = System.Address'Size - and then Attribute'Alignment <= Atomic_Address'Alignment - and then To_Address (Initial_Value) = System.Null_Address); - -- If the attribute fits in an Atomic_Address (both size and alignment) + and then Attribute'Alignment <= System.Address'Alignment + and then To_Address (Initial_Value) = Null_Address); + -- If the attribute fits in a System.Address (both size and alignment) -- and Initial_Value is 0 (or null), then we will map the attribute -- directly into ATCB.Attributes (Index), otherwise we will create -- a level of indirection and instead use Attributes (Index) as a @@ -153,11 +153,11 @@ package body Ada.Task_Attributes is while C /= null loop STPO.Write_Lock (C); - if C.Attributes (Index) /= 0 + if C.Attributes (Index) /= Null_Address and then Require_Finalization (Index) then Deallocate (C.Attributes (Index)); - C.Attributes (Index) := 0; + C.Attributes (Index) := Null_Address; end if; STPO.Unlock (C); @@ -173,7 +173,7 @@ package body Ada.Task_Attributes is -- Deallocate -- ---------------- - procedure Deallocate (Ptr : Atomic_Address) is + procedure Deallocate (Ptr : System.Address) is Obj : Real_Attribute_Access := To_Real_Attribute (Ptr); begin Free (Obj); @@ -183,7 +183,7 @@ package body Ada.Task_Attributes is -- New_Attribute -- ------------------- - function New_Attribute (Val : Attribute) return Atomic_Address is + function New_Attribute (Val : Attribute) return System.Address is Tmp : Real_Attribute_Access; begin Tmp := new Real_Attribute'(Free => Deallocate'Unrestricted_Access, @@ -223,7 +223,7 @@ package body Ada.Task_Attributes is Self_Id := STPO.Self; Task_Lock (Self_Id); - if TT.Attributes (Index) = 0 then + if TT.Attributes (Index) = Null_Address then TT.Attributes (Index) := New_Attribute (Initial_Value); end if; @@ -266,11 +266,11 @@ package body Ada.Task_Attributes is Task_Lock (Self_Id); declare - Attr : Atomic_Address renames TT.Attributes (Index); + Attr : System.Address renames TT.Attributes (Index); begin - if Attr /= 0 then + if Attr /= Null_Address then Deallocate (Attr); - Attr := 0; + Attr := Null_Address; end if; end; @@ -304,7 +304,8 @@ package body Ada.Task_Attributes is -- No finalization needed, simply set to Val if Attribute'Size = Integer'Size then - TT.Attributes (Index) := Atomic_Address (To_Unsigned (Val)); + TT.Attributes (Index) := + To_Address (Integer_Address (To_Unsigned (Val))); else TT.Attributes (Index) := To_Address (Val); end if; @@ -314,10 +315,10 @@ package body Ada.Task_Attributes is Task_Lock (Self_Id); declare - Attr : Atomic_Address renames TT.Attributes (Index); + Attr : System.Address renames TT.Attributes (Index); begin - if Attr /= 0 then + if Attr /= Null_Address then Deallocate (Attr); end if; @@ -357,10 +358,10 @@ package body Ada.Task_Attributes is Task_Lock (Self_Id); declare - Attr : Atomic_Address renames TT.Attributes (Index); + Attr : System.Address renames TT.Attributes (Index); begin - if Attr = 0 then + if Attr = Null_Address then Task_Unlock (Self_Id); return Initial_Value; diff --git a/gcc/ada/libgnarl/s-interr.adb b/gcc/ada/libgnarl/s-interr.adb index d28c8f9..7a23168 100644 --- a/gcc/ada/libgnarl/s-interr.adb +++ b/gcc/ada/libgnarl/s-interr.adb @@ -187,20 +187,23 @@ package body System.Interrupts is -- needed to accomplish locking per Interrupt base. Also is needed to -- decide whether to create a new Server_Task. - -- Type and Head, Tail of the list containing Registered Interrupt - -- Handlers. These definitions are used to register the handlers - -- specified by the pragma Interrupt_Handler. + -- Type and the list containing Registered Interrupt Handlers. These + -- definitions are used to register the handlers specified by the pragma + -- Interrupt_Handler. + + -------------------------- + -- Handler Registration -- + -------------------------- type Registered_Handler; type R_Link is access all Registered_Handler; type Registered_Handler is record - H : System.Address := System.Null_Address; - Next : R_Link := null; + H : System.Address; + Next : R_Link; end record; - Registered_Handler_Head : R_Link := null; - Registered_Handler_Tail : R_Link := null; + Registered_Handlers : R_Link := null; Access_Hold : Server_Task_Access; -- Variable used to allocate Server_Task using "new" @@ -254,7 +257,6 @@ package body System.Interrupts is is Interrupt : constant Interrupt_ID := Interrupt_ID (Storage_Elements.To_Integer (Int_Ref)); - begin if Is_Reserved (Interrupt) then raise Program_Error with @@ -538,6 +540,7 @@ package body System.Interrupts is ------------------- function Is_Registered (Handler : Parameterless_Handler) return Boolean is + Ptr : R_Link := Registered_Handlers; type Acc_Proc is access procedure; @@ -549,7 +552,6 @@ package body System.Interrupts is function To_Fat_Ptr is new Ada.Unchecked_Conversion (Parameterless_Handler, Fat_Ptr); - Ptr : R_Link; Fat : Fat_Ptr; begin @@ -559,7 +561,6 @@ package body System.Interrupts is Fat := To_Fat_Ptr (Handler); - Ptr := Registered_Handler_Head; while Ptr /= null loop if Ptr.H = Fat.Handler_Addr.all'Address then return True; @@ -600,8 +601,6 @@ package body System.Interrupts is --------------------------------- procedure Register_Interrupt_Handler (Handler_Addr : System.Address) is - New_Node_Ptr : R_Link; - begin -- This routine registers the Handler as usable for Dynamic Interrupt -- Handler. Routines attaching and detaching Handler dynamically should @@ -615,17 +614,8 @@ package body System.Interrupts is pragma Assert (Handler_Addr /= System.Null_Address); - New_Node_Ptr := new Registered_Handler; - New_Node_Ptr.H := Handler_Addr; - - if Registered_Handler_Head = null then - Registered_Handler_Head := New_Node_Ptr; - Registered_Handler_Tail := New_Node_Ptr; - - else - Registered_Handler_Tail.Next := New_Node_Ptr; - Registered_Handler_Tail := New_Node_Ptr; - end if; + Registered_Handlers := + new Registered_Handler'(H => Handler_Addr, Next => Registered_Handlers); end Register_Interrupt_Handler; ----------------------- diff --git a/gcc/ada/libgnarl/s-interr__hwint.adb b/gcc/ada/libgnarl/s-interr__hwint.adb index 4410835..eb2e5a2 100644 --- a/gcc/ada/libgnarl/s-interr__hwint.adb +++ b/gcc/ada/libgnarl/s-interr__hwint.adb @@ -141,20 +141,23 @@ package body System.Interrupts is pragma Volatile_Components (User_Entry); -- Holds the task and entry index (if any) for each interrupt - -- Type and Head, Tail of the list containing Registered Interrupt - -- Handlers. These definitions are used to register the handlers - -- specified by the pragma Interrupt_Handler. + -- Type and the list containing Registered Interrupt Handlers. These + -- definitions are used to register the handlers specified by the pragma + -- Interrupt_Handler. + + -------------------------- + -- Handler Registration -- + -------------------------- type Registered_Handler; type R_Link is access all Registered_Handler; type Registered_Handler is record - H : System.Address := System.Null_Address; - Next : R_Link := null; + H : System.Address; + Next : R_Link; end record; - Registered_Handler_Head : R_Link := null; - Registered_Handler_Tail : R_Link := null; + Registered_Handlers : R_Link := null; Server_ID : array (Interrupt_ID) of System.Tasking.Task_Id := (others => System.Tasking.Null_Task); @@ -543,6 +546,7 @@ package body System.Interrupts is ------------------- function Is_Registered (Handler : Parameterless_Handler) return Boolean is + Ptr : R_Link := Registered_Handlers; type Acc_Proc is access procedure; @@ -554,7 +558,6 @@ package body System.Interrupts is function To_Fat_Ptr is new Ada.Unchecked_Conversion (Parameterless_Handler, Fat_Ptr); - Ptr : R_Link; Fat : Fat_Ptr; begin @@ -564,7 +567,6 @@ package body System.Interrupts is Fat := To_Fat_Ptr (Handler); - Ptr := Registered_Handler_Head; while Ptr /= null loop if Ptr.H = Fat.Handler_Addr.all'Address then return True; @@ -635,8 +637,6 @@ package body System.Interrupts is -------------------------------- procedure Register_Interrupt_Handler (Handler_Addr : System.Address) is - New_Node_Ptr : R_Link; - begin -- This routine registers a handler as usable for dynamic interrupt -- handler association. Routines attaching and detaching handlers @@ -650,16 +650,8 @@ package body System.Interrupts is pragma Assert (Handler_Addr /= System.Null_Address); - New_Node_Ptr := new Registered_Handler; - New_Node_Ptr.H := Handler_Addr; - - if Registered_Handler_Head = null then - Registered_Handler_Head := New_Node_Ptr; - Registered_Handler_Tail := New_Node_Ptr; - else - Registered_Handler_Tail.Next := New_Node_Ptr; - Registered_Handler_Tail := New_Node_Ptr; - end if; + Registered_Handlers := + new Registered_Handler'(H => Handler_Addr, Next => Registered_Handlers); end Register_Interrupt_Handler; ----------------------- @@ -882,7 +874,7 @@ package body System.Interrupts is To_System (Interrupt_Access_Hold.all'Identity); end if; - if (New_Handler = null) and then Old_Handler /= null then + if New_Handler = null and then Old_Handler /= null then -- Restore default handler diff --git a/gcc/ada/libgnarl/s-interr__sigaction.adb b/gcc/ada/libgnarl/s-interr__sigaction.adb index 9691674..c0398e4 100644 --- a/gcc/ada/libgnarl/s-interr__sigaction.adb +++ b/gcc/ada/libgnarl/s-interr__sigaction.adb @@ -91,9 +91,9 @@ package body System.Interrupts is pragma Convention (C, Signal_Handler); -- This procedure is used to handle all the signals - -- Type and Head, Tail of the list containing Registered Interrupt - -- Handlers. These definitions are used to register the handlers - -- specified by the pragma Interrupt_Handler. + -- Type and the list containing Registered Interrupt Handlers. These + -- definitions are used to register the handlers specified by the pragma + -- Interrupt_Handler. -------------------------- -- Handler Registration -- @@ -103,8 +103,8 @@ package body System.Interrupts is type R_Link is access all Registered_Handler; type Registered_Handler is record - H : System.Address := System.Null_Address; - Next : R_Link := null; + H : System.Address; + Next : R_Link; end record; Registered_Handlers : R_Link := null; @@ -471,6 +471,18 @@ package body System.Interrupts is procedure Register_Interrupt_Handler (Handler_Addr : System.Address) is begin + -- This routine registers a handler as usable for dynamic interrupt + -- handler association. Routines attaching and detaching handlers + -- dynamically should determine whether the handler is registered. + -- Program_Error should be raised if it is not registered. + + -- Pragma Interrupt_Handler can only appear in a library level PO + -- definition and instantiation. Therefore, we do not need to implement + -- an unregister operation. Nor do we need to protect the queue + -- structure with a lock. + + pragma Assert (Handler_Addr /= System.Null_Address); + Registered_Handlers := new Registered_Handler'(H => Handler_Addr, Next => Registered_Handlers); end Register_Interrupt_Handler; diff --git a/gcc/ada/libgnarl/s-interr__vxworks.adb b/gcc/ada/libgnarl/s-interr__vxworks.adb index 329020d..93afcc5 100644 --- a/gcc/ada/libgnarl/s-interr__vxworks.adb +++ b/gcc/ada/libgnarl/s-interr__vxworks.adb @@ -164,20 +164,23 @@ package body System.Interrupts is pragma Volatile_Components (User_Entry); -- Holds the task and entry index (if any) for each interrupt / signal - -- Type and Head, Tail of the list containing Registered Interrupt - -- Handlers. These definitions are used to register the handlers - -- specified by the pragma Interrupt_Handler. + -- Type and the list containing Registered Interrupt Handlers. These + -- definitions are used to register the handlers specified by the pragma + -- Interrupt_Handler. + + -------------------------- + -- Handler Registration -- + -------------------------- type Registered_Handler; type R_Link is access all Registered_Handler; type Registered_Handler is record - H : System.Address := System.Null_Address; - Next : R_Link := null; + H : System.Address; + Next : R_Link; end record; - Registered_Handler_Head : R_Link := null; - Registered_Handler_Tail : R_Link := null; + Registered_Handlers : R_Link := null; Server_ID : array (Interrupt_ID) of System.Tasking.Task_Id := (others => System.Tasking.Null_Task); @@ -583,6 +586,7 @@ package body System.Interrupts is ------------------- function Is_Registered (Handler : Parameterless_Handler) return Boolean is + Ptr : R_Link := Registered_Handlers; type Acc_Proc is access procedure; @@ -594,7 +598,6 @@ package body System.Interrupts is function To_Fat_Ptr is new Ada.Unchecked_Conversion (Parameterless_Handler, Fat_Ptr); - Ptr : R_Link; Fat : Fat_Ptr; begin @@ -604,7 +607,6 @@ package body System.Interrupts is Fat := To_Fat_Ptr (Handler); - Ptr := Registered_Handler_Head; while Ptr /= null loop if Ptr.H = Fat.Handler_Addr.all'Address then return True; @@ -675,8 +677,6 @@ package body System.Interrupts is -------------------------------- procedure Register_Interrupt_Handler (Handler_Addr : System.Address) is - New_Node_Ptr : R_Link; - begin -- This routine registers a handler as usable for dynamic interrupt -- handler association. Routines attaching and detaching handlers @@ -690,16 +690,8 @@ package body System.Interrupts is pragma Assert (Handler_Addr /= System.Null_Address); - New_Node_Ptr := new Registered_Handler; - New_Node_Ptr.H := Handler_Addr; - - if Registered_Handler_Head = null then - Registered_Handler_Head := New_Node_Ptr; - Registered_Handler_Tail := New_Node_Ptr; - else - Registered_Handler_Tail.Next := New_Node_Ptr; - Registered_Handler_Tail := New_Node_Ptr; - end if; + Registered_Handlers := + new Registered_Handler'(H => Handler_Addr, Next => Registered_Handlers); end Register_Interrupt_Handler; ----------------------- @@ -922,7 +914,7 @@ package body System.Interrupts is To_System (Interrupt_Access_Hold.all'Identity); end if; - if (New_Handler = null) and then Old_Handler /= null then + if New_Handler = null and then Old_Handler /= null then -- Restore default handler diff --git a/gcc/ada/libgnarl/s-mudido.ads b/gcc/ada/libgnarl/s-mudido.ads index 06e48bd..cc97463 100644 --- a/gcc/ada/libgnarl/s-mudido.ads +++ b/gcc/ada/libgnarl/s-mudido.ads @@ -20,10 +20,6 @@ with Ada.Task_Identification; private with System.Tasking; package System.Multiprocessors.Dispatching_Domains is - -- pragma Preelaborate (Dispatching_Domains); - -- ??? According to AI 167 this unit should be preelaborate, but it cannot - -- be preelaborate because it depends on Ada.Real_Time which is not - -- preelaborate. Dispatching_Domain_Error : exception; diff --git a/gcc/ada/libgnarl/s-osinte__qnx.adb b/gcc/ada/libgnarl/s-osinte__qnx.adb index bf08ecb..127d179 100644 --- a/gcc/ada/libgnarl/s-osinte__qnx.adb +++ b/gcc/ada/libgnarl/s-osinte__qnx.adb @@ -87,7 +87,7 @@ package body System.OS_Interface is (Prio : System.Any_Priority) return Interfaces.C.int is begin - return Interfaces.C.int (Prio) + 1; + return Interfaces.C.int (Prio); end To_Target_Priority; ----------------- diff --git a/gcc/ada/libgnarl/s-osinte__qnx.ads b/gcc/ada/libgnarl/s-osinte__qnx.ads index 3aa727f..3282abe 100644 --- a/gcc/ada/libgnarl/s-osinte__qnx.ads +++ b/gcc/ada/libgnarl/s-osinte__qnx.ads @@ -562,8 +562,10 @@ package System.OS_Interface is private - type sigset_t is array (1 .. 2) of Interfaces.Unsigned_32; + type sigset_t is + array (0 .. OS_Constants.SIZEOF_sigset - 1) of unsigned_char; pragma Convention (C, sigset_t); + for sigset_t'Alignment use Interfaces.C.unsigned_long'Alignment; type pid_t is new int; diff --git a/gcc/ada/libgnarl/s-tasini.adb b/gcc/ada/libgnarl/s-tasini.adb index 24f4ba2..2000543 100644 --- a/gcc/ada/libgnarl/s-tasini.adb +++ b/gcc/ada/libgnarl/s-tasini.adb @@ -758,7 +758,7 @@ package body System.Tasking.Initialization is ------------------------- procedure Finalize_Attributes (T : Task_Id) is - Attr : Atomic_Address; + Attr : System.Address; begin for J in T.Attributes'Range loop diff --git a/gcc/ada/libgnarl/s-taskin.ads b/gcc/ada/libgnarl/s-taskin.ads index 47c5ca2..5aa3e37 100644 --- a/gcc/ada/libgnarl/s-taskin.ads +++ b/gcc/ada/libgnarl/s-taskin.ads @@ -958,11 +958,10 @@ package System.Tasking is type Entry_Call_Array is array (ATC_Level_Index) of aliased Entry_Call_Record; - type Atomic_Address is mod Memory_Size; - pragma Atomic (Atomic_Address); type Attribute_Array is - array (1 .. Parameters.Max_Attribute_Count) of Atomic_Address; - -- Array of task attributes. The value (Atomic_Address) will either be + array (1 .. Parameters.Max_Attribute_Count) of System.Address; + pragma Atomic_Components (Attribute_Array); + -- Array of task attributes. The value (System.Address) will either be -- converted to a task attribute if it fits, or to a pointer to a record -- by Ada.Task_Attributes. @@ -1157,7 +1156,7 @@ package System.Tasking is -- non-terminated task so that the associated storage is automatically -- reclaimed when the task terminates. - Attributes : Attribute_Array := [others => 0]; + Attributes : Attribute_Array := [others => Null_Address]; -- Task attributes -- IMPORTANT Note: the Entry_Queues field is last for efficiency of diff --git a/gcc/ada/libgnarl/s-tataat.ads b/gcc/ada/libgnarl/s-tataat.ads index 002a7ce..e6d597c 100644 --- a/gcc/ada/libgnarl/s-tataat.ads +++ b/gcc/ada/libgnarl/s-tataat.ads @@ -35,7 +35,7 @@ with Ada.Unchecked_Conversion; package System.Tasking.Task_Attributes is - type Deallocator is access procedure (Ptr : Atomic_Address); + type Deallocator is access procedure (Ptr : System.Address); pragma Favor_Top_Level (Deallocator); type Attribute_Record is record @@ -48,7 +48,7 @@ package System.Tasking.Task_Attributes is pragma No_Strict_Aliasing (Attribute_Access); function To_Attribute is new - Ada.Unchecked_Conversion (Atomic_Address, Attribute_Access); + Ada.Unchecked_Conversion (System.Address, Attribute_Access); function Next_Index (Require_Finalization : Boolean) return Integer; -- Return the next attribute index available. Require_Finalization is True diff --git a/gcc/ada/libgnat/a-calend.ads b/gcc/ada/libgnat/a-calend.ads index 2771cb5..d67bf07 100644 --- a/gcc/ada/libgnat/a-calend.ads +++ b/gcc/ada/libgnat/a-calend.ads @@ -102,16 +102,16 @@ is function "+" (Left : Time; Right : Duration) return Time with - Global => null; + SPARK_Mode => Off; function "+" (Left : Duration; Right : Time) return Time with - Global => null; + SPARK_Mode => Off; function "-" (Left : Time; Right : Duration) return Time with - Global => null; + SPARK_Mode => Off; function "-" (Left : Time; Right : Time) return Duration with - Global => null; + SPARK_Mode => Off; -- The first three functions will raise Time_Error if the resulting time -- value is less than the start of Ada time in UTC or greater than the -- end of Ada time in UTC. The last function will raise Time_Error if the diff --git a/gcc/ada/libgnat/a-calfor.adb b/gcc/ada/libgnat/a-calfor.adb index 3325e56..18f4e73 100644 --- a/gcc/ada/libgnat/a-calfor.adb +++ b/gcc/ada/libgnat/a-calfor.adb @@ -590,10 +590,6 @@ package body Ada.Calendar.Formatting is Leap_Second : Boolean := False; Time_Zone : Time_Zones.Time_Offset := 0) return Time is - Adj_Year : Year_Number := Year; - Adj_Month : Month_Number := Month; - Adj_Day : Day_Number := Day; - H : constant Integer := 1; M : constant Integer := 1; Se : constant Integer := 1; @@ -612,32 +608,11 @@ package body Ada.Calendar.Formatting is raise Constraint_Error; end if; - -- A Seconds value of 86_400 denotes a new day. This case requires an - -- adjustment to the input values. - - if Seconds = 86_400.0 then - if Day < Days_In_Month (Month) - or else (Is_Leap (Year) - and then Month = 2) - then - Adj_Day := Day + 1; - else - Adj_Day := 1; - - if Month < 12 then - Adj_Month := Month + 1; - else - Adj_Month := 1; - Adj_Year := Year + 1; - end if; - end if; - end if; - return Formatting_Operations.Time_Of - (Year => Adj_Year, - Month => Adj_Month, - Day => Adj_Day, + (Year => Year, + Month => Month, + Day => Day, Day_Secs => Seconds, Hour => H, Minute => M, diff --git a/gcc/ada/libgnat/a-cbdlli.ads b/gcc/ada/libgnat/a-cbdlli.ads index 961a007..b881053 100644 --- a/gcc/ada/libgnat/a-cbdlli.ads +++ b/gcc/ada/libgnat/a-cbdlli.ads @@ -276,12 +276,12 @@ private type Node_Array is array (Count_Type range <>) of Node_Type; type List (Capacity : Count_Type) is tagged record - Nodes : Node_Array (1 .. Capacity); Free : Count_Type'Base := -1; First : Count_Type := 0; Last : Count_Type := 0; Length : Count_Type := 0; TC : aliased Tamper_Counts; + Nodes : Node_Array (1 .. Capacity); end record with Put_Image => Put_Image; procedure Put_Image diff --git a/gcc/ada/libgnat/a-chahan.ads b/gcc/ada/libgnat/a-chahan.ads index 159cd70..89b2d68 100644 --- a/gcc/ada/libgnat/a-chahan.ads +++ b/gcc/ada/libgnat/a-chahan.ads @@ -40,14 +40,13 @@ pragma Assertion_Policy (Post => Ignore); with Ada.Characters.Latin_1; -package Ada.Characters.Handling - with SPARK_Mode +package Ada.Characters.Handling with + SPARK_Mode, + Always_Terminates is pragma Pure; -- In accordance with Ada 2005 AI-362 - pragma Annotate (GNATprove, Always_Return, Handling); - ---------------------------------------- -- Character Classification Functions -- ---------------------------------------- diff --git a/gcc/ada/libgnat/a-cidlli.adb b/gcc/ada/libgnat/a-cidlli.adb index 65582d1..9e6ad70 100644 --- a/gcc/ada/libgnat/a-cidlli.adb +++ b/gcc/ada/libgnat/a-cidlli.adb @@ -1283,22 +1283,19 @@ is is First_Time : Boolean := True; use System.Put_Images; + begin + Array_Before (S); - procedure Put_Elem (Position : Cursor); - procedure Put_Elem (Position : Cursor) is - begin + for X of V loop if First_Time then First_Time := False; else Simple_Array_Between (S); end if; - Element_Type'Put_Image (S, Element (Position)); - end Put_Elem; + Element_Type'Put_Image (S, X); + end loop; - begin - Array_Before (S); - Iterate (V, Put_Elem'Access); Array_After (S); end Put_Image; diff --git a/gcc/ada/libgnat/a-coinho__shared.adb b/gcc/ada/libgnat/a-coinho__shared.adb index 3670890..f49ac4a 100644 --- a/gcc/ada/libgnat/a-coinho__shared.adb +++ b/gcc/ada/libgnat/a-coinho__shared.adb @@ -149,8 +149,6 @@ package body Ada.Containers.Indefinite_Holders is raise Constraint_Error with "container is empty"; end if; - Detach (Container); - declare Ref : constant Constant_Reference_Type := (Element => Container.Reference.Element.all'Access, @@ -305,8 +303,6 @@ package body Ada.Containers.Indefinite_Holders is raise Constraint_Error with "container is empty"; end if; - Detach (Container); - B := B + 1; begin diff --git a/gcc/ada/libgnat/a-coinve.adb b/gcc/ada/libgnat/a-coinve.adb index 846f819..dd0e8cd 100644 --- a/gcc/ada/libgnat/a-coinve.adb +++ b/gcc/ada/libgnat/a-coinve.adb @@ -2679,22 +2679,19 @@ is is First_Time : Boolean := True; use System.Put_Images; + begin + Array_Before (S); - procedure Put_Elem (Position : Cursor); - procedure Put_Elem (Position : Cursor) is - begin + for X of V loop if First_Time then First_Time := False; else Simple_Array_Between (S); end if; - Element_Type'Put_Image (S, Element (Position)); - end Put_Elem; + Element_Type'Put_Image (S, X); + end loop; - begin - Array_Before (S); - Iterate (V, Put_Elem'Access); Array_After (S); end Put_Image; diff --git a/gcc/ada/libgnat/a-costso.adb b/gcc/ada/libgnat/a-costso.adb index fcdd7aa..fb4da32 100644 --- a/gcc/ada/libgnat/a-costso.adb +++ b/gcc/ada/libgnat/a-costso.adb @@ -124,7 +124,7 @@ package body Ada.Containers.Stable_Sorting is -- Start of processing for Merge_Parts begin - while (P1.Length /= 0) or (P2.Length /= 0) loop + while P1.Length /= 0 or P2.Length /= 0 loop if P1.Length = 0 then Take_From_P2 := True; elsif P2.Length = 0 then diff --git a/gcc/ada/libgnat/a-crdlli.ads b/gcc/ada/libgnat/a-crdlli.ads index d9c4517..fa4fe15 100644 --- a/gcc/ada/libgnat/a-crdlli.ads +++ b/gcc/ada/libgnat/a-crdlli.ads @@ -314,11 +314,11 @@ private type Node_Array is array (Count_Type range <>) of Node_Type; type List (Capacity : Count_Type) is tagged limited record - Nodes : Node_Array (1 .. Capacity); Free : Count_Type'Base := -1; First : Count_Type := 0; Last : Count_Type := 0; Length : Count_Type := 0; + Nodes : Node_Array (1 .. Capacity); end record; type List_Access is access all List; diff --git a/gcc/ada/libgnat/a-dhfina.adb b/gcc/ada/libgnat/a-dhfina.adb index a7e9e386b..9435cc0 100644 --- a/gcc/ada/libgnat/a-dhfina.adb +++ b/gcc/ada/libgnat/a-dhfina.adb @@ -307,7 +307,7 @@ package body Ada.Directories.Hierarchical_File_Names is -- Check that directory is valid if Separated_Dir /= "" - and then (not Is_Valid_Path_Name (Separated_Dir & Relative_Name)) + and then not Is_Valid_Path_Name (Separated_Dir & Relative_Name) then raise Name_Error with "invalid path composition """ & Separated_Dir & Relative_Name & '"'; diff --git a/gcc/ada/libgnat/a-direct.adb b/gcc/ada/libgnat/a-direct.adb index d660b69..4b08d41 100644 --- a/gcc/ada/libgnat/a-direct.adb +++ b/gcc/ada/libgnat/a-direct.adb @@ -176,9 +176,7 @@ package body Ada.Directories is raise Name_Error with "invalid directory path name """ & Containing_Directory & '"'; - elsif - Extension'Length = 0 and then (not Is_Valid_Simple_Name (Name)) - then + elsif Extension'Length = 0 and then not Is_Valid_Simple_Name (Name) then raise Name_Error with "invalid simple name """ & Name & '"'; diff --git a/gcc/ada/libgnat/a-excach.adb b/gcc/ada/libgnat/a-excach.adb index 840da0c..784194d 100644 --- a/gcc/ada/libgnat/a-excach.adb +++ b/gcc/ada/libgnat/a-excach.adb @@ -66,8 +66,8 @@ begin (Traceback => Excep.Tracebacks, Max_Len => Max_Tracebacks, Len => Excep.Num_Tracebacks, - Exclude_Min => Code_Address_For_AAA, - Exclude_Max => Code_Address_For_ZZZ, + Exclude_Min => AAA'Code_Address, + Exclude_Max => ZZZ'Code_Address, Skip_Frames => 3); end if; diff --git a/gcc/ada/libgnat/a-except.adb b/gcc/ada/libgnat/a-except.adb index 7d728d6..20a7736 100644 --- a/gcc/ada/libgnat/a-except.adb +++ b/gcc/ada/libgnat/a-except.adb @@ -65,29 +65,32 @@ package body Ada.Exceptions is -- from C clients using the given external name, even though they are not -- technically visible in the Ada sense. - function Code_Address_For_AAA return System.Address; - function Code_Address_For_ZZZ return System.Address; - -- Return start and end of procedures in this package + procedure AAA; + procedure ZZZ; + -- Start and end of procedures in this package -- - -- These procedures are used to provide exclusion bounds in - -- calls to Call_Chain at exception raise points from this unit. The - -- purpose is to arrange for the exception tracebacks not to include - -- frames from subprograms involved in the raise process, as these are - -- meaningless from the user's standpoint. + -- These procedures are used to provide exclusion bounds in calls to + -- Call_Chain at exception raise points from this unit. The purpose is + -- to arrange for the exception tracebacks not to include frames from + -- subprograms involved in the raise process, as these are meaningless + -- from the user's standpoint. -- -- For these bounds to be meaningful, we need to ensure that the object - -- code for the subprograms involved in processing a raise is located - -- after the object code Code_Address_For_AAA and before the object - -- code Code_Address_For_ZZZ. This will indeed be the case as long as - -- the following rules are respected: + -- code for the subprograms involved in processing a raise is located after + -- the object code AAA and before the object code ZZZ. This will indeed be + -- the case as long as the following rules are respected: -- -- 1) The bodies of the subprograms involved in processing a raise - -- are located after the body of Code_Address_For_AAA and before the - -- body of Code_Address_For_ZZZ. + -- are located after the body of AAA and before the body of ZZZ. -- -- 2) No pragma Inline applies to any of these subprograms, as this -- could delay the corresponding assembly output until the end of -- the unit. + -- + -- To obtain the address of AAA and ZZZ, use the Code_Address attribute + -- instead of the Address attribute as the latter will return the address + -- of a stub or descriptor on some platforms. This include IA-64, + -- PowerPC/AIX, big-endian PowerPC64 and HPUX. procedure Call_Chain (Excep : EOA); -- Store up to Max_Tracebacks in Excep, corresponding to the current @@ -771,24 +774,15 @@ package body Ada.Exceptions is Rmsg_36 : constant String := "stream operation not allowed" & NUL; Rmsg_37 : constant String := "build-in-place mismatch" & NUL; - -------------------------- - -- Code_Address_For_AAA -- - -------------------------- + --------- + -- AAA -- + --------- -- This function gives us the start of the PC range for addresses within -- the exception unit itself. We hope that gigi/gcc keep all the procedures -- in their original order. - function Code_Address_For_AAA return System.Address is - begin - -- We are using a label instead of Code_Address_For_AAA'Address because - -- on some platforms the latter does not yield the address we want, but - -- the address of a stub or of a descriptor instead. This is the case at - -- least on PA-HPUX. - - <<Start_Of_AAA>> - return Start_Of_AAA'Address; - end Code_Address_For_AAA; + procedure AAA is null; ---------------- -- Call_Chain -- @@ -1816,18 +1810,14 @@ package body Ada.Exceptions is return W (1 .. L); end Wide_Wide_Exception_Name; - -------------------------- - -- Code_Address_For_ZZZ -- - -------------------------- + --------- + -- ZZZ -- + --------- -- This function gives us the end of the PC range for addresses -- within the exception unit itself. We hope that gigi/gcc keeps all the -- procedures in their original order. - function Code_Address_For_ZZZ return System.Address is - begin - <<Start_Of_ZZZ>> - return Start_Of_ZZZ'Address; - end Code_Address_For_ZZZ; + procedure ZZZ is null; end Ada.Exceptions; diff --git a/gcc/ada/libgnat/a-nbnbig.ads b/gcc/ada/libgnat/a-nbnbig.ads index 3979f14..382a7b6 100644 --- a/gcc/ada/libgnat/a-nbnbig.ads +++ b/gcc/ada/libgnat/a-nbnbig.ads @@ -30,9 +30,9 @@ pragma Assertion_Policy (Ghost => Ignore); package Ada.Numerics.Big_Numbers.Big_Integers_Ghost with SPARK_Mode, Ghost, - Pure + Pure, + Always_Terminates is - pragma Annotate (GNATprove, Always_Return, Big_Integers_Ghost); type Big_Integer is private with Integer_Literal => From_Universal_Image; @@ -75,13 +75,13 @@ is with Dynamic_Predicate => (if Is_Valid (Big_Positive) then Big_Positive > To_Big_Integer (0)), - Predicate_Failure => (raise Constraint_Error); + Predicate_Failure => raise Constraint_Error; subtype Big_Natural is Big_Integer with Dynamic_Predicate => (if Is_Valid (Big_Natural) then Big_Natural >= To_Big_Integer (0)), - Predicate_Failure => (raise Constraint_Error); + Predicate_Failure => raise Constraint_Error; function In_Range (Arg : Valid_Big_Integer; Low, High : Big_Integer) return Boolean @@ -96,7 +96,7 @@ is Pre => In_Range (Arg, Low => To_Big_Integer (Integer'First), High => To_Big_Integer (Integer'Last)) - or else (raise Constraint_Error), + or else raise Constraint_Error, Global => null; generic @@ -112,7 +112,7 @@ is Pre => In_Range (Arg, Low => To_Big_Integer (Int'First), High => To_Big_Integer (Int'Last)) - or else (raise Constraint_Error), + or else raise Constraint_Error, Global => null; end Signed_Conversions; @@ -129,7 +129,7 @@ is Pre => In_Range (Arg, Low => To_Big_Integer (Int'First), High => To_Big_Integer (Int'Last)) - or else (raise Constraint_Error), + or else raise Constraint_Error, Global => null; end Unsigned_Conversions; @@ -207,7 +207,7 @@ is with Import, Pre => (L /= To_Big_Integer (0) and R /= To_Big_Integer (0)) - or else (raise Constraint_Error), + or else raise Constraint_Error, Global => null; private diff --git a/gcc/ada/libgnat/a-nbnbin.adb b/gcc/ada/libgnat/a-nbnbin.adb index edfd04e..090f408 100644 --- a/gcc/ada/libgnat/a-nbnbin.adb +++ b/gcc/ada/libgnat/a-nbnbin.adb @@ -160,7 +160,7 @@ package body Ada.Numerics.Big_Numbers.Big_Integers is function To_Integer (Arg : Valid_Big_Integer) return Integer is begin - return Integer (From_Bignum (Get_Bignum (Arg))); + return Integer (Long_Long_Integer'(From_Bignum (Get_Bignum (Arg)))); end To_Integer; ------------------------ @@ -186,7 +186,7 @@ package body Ada.Numerics.Big_Numbers.Big_Integers is function From_Big_Integer (Arg : Valid_Big_Integer) return Int is begin - return Int (From_Bignum (Get_Bignum (Arg))); + return Int (Long_Long_Long_Integer'(From_Bignum (Get_Bignum (Arg)))); end From_Big_Integer; end Signed_Conversions; @@ -214,7 +214,7 @@ package body Ada.Numerics.Big_Numbers.Big_Integers is function From_Big_Integer (Arg : Valid_Big_Integer) return Int is begin - return Int (From_Bignum (Get_Bignum (Arg))); + return Int (Unsigned_128'(From_Bignum (Get_Bignum (Arg)))); end From_Big_Integer; end Unsigned_Conversions; diff --git a/gcc/ada/libgnat/a-nbnbin.ads b/gcc/ada/libgnat/a-nbnbin.ads index ffb96d4..c4d74ee 100644 --- a/gcc/ada/libgnat/a-nbnbin.ads +++ b/gcc/ada/libgnat/a-nbnbin.ads @@ -18,10 +18,10 @@ with Ada.Strings.Text_Buffers; use Ada.Strings.Text_Buffers; private with Ada.Finalization; private with System; -package Ada.Numerics.Big_Numbers.Big_Integers - with Preelaborate +package Ada.Numerics.Big_Numbers.Big_Integers with + Preelaborate, + Always_Terminates is - pragma Annotate (GNATprove, Always_Return, Big_Integers); type Big_Integer is private with Integer_Literal => From_Universal_Image, diff --git a/gcc/ada/libgnat/a-nbnbre.ads b/gcc/ada/libgnat/a-nbnbre.ads index 350d049..d342eeb 100644 --- a/gcc/ada/libgnat/a-nbnbre.ads +++ b/gcc/ada/libgnat/a-nbnbre.ads @@ -17,10 +17,10 @@ with Ada.Numerics.Big_Numbers.Big_Integers; with Ada.Strings.Text_Buffers; use Ada.Strings.Text_Buffers; -package Ada.Numerics.Big_Numbers.Big_Reals - with Preelaborate +package Ada.Numerics.Big_Numbers.Big_Reals with + Preelaborate, + Always_Terminates is - pragma Annotate (GNATprove, Always_Return, Big_Reals); type Big_Real is private with Real_Literal => From_Universal_Image, diff --git a/gcc/ada/libgnat/a-ngelfu.ads b/gcc/ada/libgnat/a-ngelfu.ads index f6d6c96..444d1a3 100644 --- a/gcc/ada/libgnat/a-ngelfu.ads +++ b/gcc/ada/libgnat/a-ngelfu.ads @@ -37,10 +37,10 @@ generic type Float_Type is digits <>; package Ada.Numerics.Generic_Elementary_Functions with - SPARK_Mode => On + SPARK_Mode => On, + Always_Terminates is pragma Pure; - pragma Annotate (GNATprove, Always_Return, Generic_Elementary_Functions); -- Preconditions in this unit are meant for analysis only, not for run-time -- checking, so that the expected exceptions are raised when calling diff --git a/gcc/ada/libgnat/a-nlelfu.ads b/gcc/ada/libgnat/a-nlelfu.ads index b3afd1f..10b33e9 100644 --- a/gcc/ada/libgnat/a-nlelfu.ads +++ b/gcc/ada/libgnat/a-nlelfu.ads @@ -19,4 +19,3 @@ package Ada.Numerics.Long_Elementary_Functions is new Ada.Numerics.Generic_Elementary_Functions (Long_Float); pragma Pure (Long_Elementary_Functions); -pragma Annotate (GNATprove, Always_Return, Long_Elementary_Functions); diff --git a/gcc/ada/libgnat/a-nllefu.ads b/gcc/ada/libgnat/a-nllefu.ads index e137c67..7089fc3 100644 --- a/gcc/ada/libgnat/a-nllefu.ads +++ b/gcc/ada/libgnat/a-nllefu.ads @@ -19,4 +19,3 @@ package Ada.Numerics.Long_Long_Elementary_Functions is new Ada.Numerics.Generic_Elementary_Functions (Long_Long_Float); pragma Pure (Long_Long_Elementary_Functions); -pragma Annotate (GNATprove, Always_Return, Long_Long_Elementary_Functions); diff --git a/gcc/ada/libgnat/a-nselfu.ads b/gcc/ada/libgnat/a-nselfu.ads index 6797efd..10b04ac 100644 --- a/gcc/ada/libgnat/a-nselfu.ads +++ b/gcc/ada/libgnat/a-nselfu.ads @@ -19,4 +19,3 @@ package Ada.Numerics.Short_Elementary_Functions is new Ada.Numerics.Generic_Elementary_Functions (Short_Float); pragma Pure (Short_Elementary_Functions); -pragma Annotate (GNATprove, Always_Return, Short_Elementary_Functions); diff --git a/gcc/ada/libgnat/a-nuelfu.ads b/gcc/ada/libgnat/a-nuelfu.ads index d4fe745..149939b 100644 --- a/gcc/ada/libgnat/a-nuelfu.ads +++ b/gcc/ada/libgnat/a-nuelfu.ads @@ -19,4 +19,3 @@ package Ada.Numerics.Elementary_Functions is new Ada.Numerics.Generic_Elementary_Functions (Float); pragma Pure (Elementary_Functions); -pragma Annotate (GNATprove, Always_Return, Elementary_Functions); diff --git a/gcc/ada/libgnat/a-rbtgbo.adb b/gcc/ada/libgnat/a-rbtgbo.adb index 773e71a..2f96579 100644 --- a/gcc/ada/libgnat/a-rbtgbo.adb +++ b/gcc/ada/libgnat/a-rbtgbo.adb @@ -207,21 +207,21 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations is pragma Assert (Tree.Last /= 0); pragma Assert (Parent (N (Tree.Root)) = 0); - pragma Assert ((Tree.Length > 1) + pragma Assert (Tree.Length > 1 or else (Tree.First = Tree.Last and then Tree.First = Tree.Root)); - pragma Assert ((Left (N (Node)) = 0) - or else (Parent (N (Left (N (Node)))) = Node)); + pragma Assert (Left (N (Node)) = 0 + or else Parent (N (Left (N (Node)))) = Node); - pragma Assert ((Right (N (Node)) = 0) - or else (Parent (N (Right (N (Node)))) = Node)); + pragma Assert (Right (N (Node)) = 0 + or else Parent (N (Right (N (Node)))) = Node); - pragma Assert (((Parent (N (Node)) = 0) and then (Tree.Root = Node)) - or else ((Parent (N (Node)) /= 0) and then - ((Left (N (Parent (N (Node)))) = Node) + pragma Assert ((Parent (N (Node)) = 0 and then Tree.Root = Node) + or else (Parent (N (Node)) /= 0 and then + (Left (N (Parent (N (Node)))) = Node or else - (Right (N (Parent (N (Node)))) = Node)))); + Right (N (Parent (N (Node)))) = Node))); if Left (N (Z)) = 0 then if Right (N (Z)) = 0 then diff --git a/gcc/ada/libgnat/a-strbou.ads b/gcc/ada/libgnat/a-strbou.ads index 0ada787..ea0cc3f 100644 --- a/gcc/ada/libgnat/a-strbou.ads +++ b/gcc/ada/libgnat/a-strbou.ads @@ -47,9 +47,11 @@ with Ada.Strings.Maps; use type Ada.Strings.Maps.Character_Mapping_Function; with Ada.Strings.Superbounded; with Ada.Strings.Search; -package Ada.Strings.Bounded with SPARK_Mode is +package Ada.Strings.Bounded with + SPARK_Mode, + Always_Terminates +is pragma Preelaborate; - pragma Annotate (GNATprove, Always_Return, Bounded); generic Max : Positive; @@ -57,7 +59,8 @@ package Ada.Strings.Bounded with SPARK_Mode is package Generic_Bounded_Length with SPARK_Mode, Initial_Condition => Length (Null_Bounded_String) = 0, - Abstract_State => null + Abstract_State => null, + Always_Terminates is -- Preconditions in this unit are meant for analysis only, not for -- run-time checking, so that the expected exceptions are raised. This @@ -69,7 +72,6 @@ package Ada.Strings.Bounded with SPARK_Mode is Post => Ignore, Contract_Cases => Ignore, Ghost => Ignore); - pragma Annotate (GNATprove, Always_Return, Generic_Bounded_Length); Max_Length : constant Positive := Max; @@ -1341,6 +1343,9 @@ package Ada.Strings.Bounded with SPARK_Mode is (for all K in 1 .. Length (Source) => Element (Translate'Result, K) = Mapping (Element (Source, K))), Global => null; + pragma Annotate (GNATprove, False_Positive, + "call via access-to-subprogram", + "function Mapping must always terminate"); procedure Translate (Source : in out Bounded_String; @@ -1352,6 +1357,9 @@ package Ada.Strings.Bounded with SPARK_Mode is (for all K in 1 .. Length (Source) => Element (Source, K) = Mapping (Element (Source'Old, K))), Global => null; + pragma Annotate (GNATprove, False_Positive, + "call via access-to-subprogram", + "function Mapping must always terminate"); --------------------------------------- -- String Transformation Subprograms -- diff --git a/gcc/ada/libgnat/a-strfix.adb b/gcc/ada/libgnat/a-strfix.adb index 7e8ac1c..ace705d 100644 --- a/gcc/ada/libgnat/a-strfix.adb +++ b/gcc/ada/libgnat/a-strfix.adb @@ -773,12 +773,18 @@ package body Ada.Strings.Fixed with SPARK_Mode is do for J in Source'Range loop Result (J - (Source'First - 1)) := Mapping.all (Source (J)); + pragma Annotate (GNATprove, False_Positive, + "call via access-to-subprogram", + "function Mapping must always terminate"); pragma Loop_Invariant (for all K in Source'First .. J => Result (K - (Source'First - 1))'Initialized); pragma Loop_Invariant (for all K in Source'First .. J => Result (K - (Source'First - 1)) = Mapping (Source (K))); + pragma Annotate (GNATprove, False_Positive, + "call via access-to-subprogram", + "function Mapping must always terminate"); end loop; end return; end Translate; @@ -791,9 +797,15 @@ package body Ada.Strings.Fixed with SPARK_Mode is begin for J in Source'Range loop Source (J) := Mapping.all (Source (J)); + pragma Annotate (GNATprove, False_Positive, + "call via access-to-subprogram", + "function Mapping must always terminate"); pragma Loop_Invariant (for all K in Source'First .. J => Source (K) = Mapping (Source'Loop_Entry (K))); + pragma Annotate (GNATprove, False_Positive, + "call via access-to-subprogram", + "function Mapping must always terminate"); end loop; end Translate; diff --git a/gcc/ada/libgnat/a-strfix.ads b/gcc/ada/libgnat/a-strfix.ads index dee64ab..9d5e9d9 100644 --- a/gcc/ada/libgnat/a-strfix.ads +++ b/gcc/ada/libgnat/a-strfix.ads @@ -46,7 +46,10 @@ pragma Assertion_Policy (Pre => Ignore, with Ada.Strings.Maps; use type Ada.Strings.Maps.Character_Mapping_Function; with Ada.Strings.Search; -package Ada.Strings.Fixed with SPARK_Mode is +package Ada.Strings.Fixed with + SPARK_Mode, + Always_Terminates +is pragma Preelaborate; -------------------------------------------------------------- @@ -60,11 +63,9 @@ package Ada.Strings.Fixed with SPARK_Mode is Justify : Alignment := Left; Pad : Character := Space) with - - -- Incomplete contract - - Global => null, - Annotate => (GNATprove, Might_Not_Return); + Global => null, + Exceptional_Cases => + (Length_Error => Target'Length'Old < Source'Length and Drop = Error); -- The Move procedure copies characters from Source to Target. If Source -- has the same length as Target, then the effect is to assign Source to -- Target. If Source is shorter than Target then: @@ -169,8 +170,7 @@ package Ada.Strings.Fixed with SPARK_Mode is others => Index'Result = 0), - Global => null, - Annotate => (GNATprove, Always_Return); + Global => null; pragma Ada_05 (Index); function Index @@ -233,8 +233,7 @@ package Ada.Strings.Fixed with SPARK_Mode is others => Index'Result = 0), - Global => null, - Annotate => (GNATprove, Always_Return); + Global => null; pragma Ada_05 (Index); -- Each Index function searches, starting from From, for a slice of @@ -303,8 +302,7 @@ package Ada.Strings.Fixed with SPARK_Mode is others => Index'Result = 0), - Global => null, - Annotate => (GNATprove, Always_Return); + Global => null; function Index (Source : String; @@ -359,8 +357,7 @@ package Ada.Strings.Fixed with SPARK_Mode is others => Index'Result = 0), - Global => null, - Annotate => (GNATprove, Always_Return); + Global => null; -- If Going = Forward, returns: -- @@ -413,8 +410,7 @@ package Ada.Strings.Fixed with SPARK_Mode is and then (J < Index'Result) = (Going = Forward) then (Test = Inside) /= Ada.Strings.Maps.Is_In (Source (J), Set)))), - Global => null, - Annotate => (GNATprove, Always_Return); + Global => null; function Index (Source : String; @@ -470,8 +466,7 @@ package Ada.Strings.Fixed with SPARK_Mode is or else (J > From) = (Going = Forward)) then (Test = Inside) /= Ada.Strings.Maps.Is_In (Source (J), Set)))), - Global => null, - Annotate => (GNATprove, Always_Return); + Global => null; pragma Ada_05 (Index); -- Index searches for the first or last occurrence of any of a set of -- characters (when Test=Inside), or any of the complement of a set of @@ -531,8 +526,7 @@ package Ada.Strings.Fixed with SPARK_Mode is and then (J = From or else (J > From) = (Going = Forward)) then Source (J) = ' '))), - Global => null, - Annotate => (GNATprove, Always_Return); + Global => null; pragma Ada_05 (Index_Non_Blank); -- Returns Index (Source, Maps.To_Set(Space), From, Outside, Going) @@ -570,8 +564,7 @@ package Ada.Strings.Fixed with SPARK_Mode is and then (J < Index_Non_Blank'Result) = (Going = Forward) then Source (J) = ' '))), - Global => null, - Annotate => (GNATprove, Always_Return); + Global => null; -- Returns Index (Source, Maps.To_Set(Space), Outside, Going) function Count @@ -579,18 +572,16 @@ package Ada.Strings.Fixed with SPARK_Mode is Pattern : String; Mapping : Maps.Character_Mapping := Maps.Identity) return Natural with - Pre => Pattern'Length /= 0, - Global => null, - Annotate => (GNATprove, Always_Return); + Pre => Pattern'Length /= 0, + Global => null; function Count (Source : String; Pattern : String; Mapping : Maps.Character_Mapping_Function) return Natural with - Pre => Pattern'Length /= 0 and then Mapping /= null, - Global => null, - Annotate => (GNATprove, Always_Return); + Pre => Pattern'Length /= 0 and then Mapping /= null, + Global => null; -- Returns the maximum number of nonoverlapping slices of Source that match -- Pattern with respect to Mapping. If Pattern is the null string then @@ -600,8 +591,7 @@ package Ada.Strings.Fixed with SPARK_Mode is (Source : String; Set : Maps.Character_Set) return Natural with - Global => null, - Annotate => (GNATprove, Always_Return); + Global => null; -- Returns the number of occurrences in Source of characters that are in -- Set. @@ -659,8 +649,7 @@ package Ada.Strings.Fixed with SPARK_Mode is then (Test = Inside) /= Ada.Strings.Maps.Is_In (Source (Last + 1), Set))), - Global => null, - Annotate => (GNATprove, Always_Return); + Global => null; pragma Ada_2012 (Find_Token); -- If Source is not the null string and From is not in Source'Range, then -- Index_Error is raised. Otherwise, First is set to the index of the first @@ -722,8 +711,7 @@ package Ada.Strings.Fixed with SPARK_Mode is then (Test = Inside) /= Ada.Strings.Maps.Is_In (Source (Last + 1), Set))), - Global => null, - Annotate => (GNATprove, Always_Return); + Global => null; -- Equivalent to Find_Token (Source, Set, Source'First, Test, First, Last) ------------------------------------ @@ -752,8 +740,10 @@ package Ada.Strings.Fixed with SPARK_Mode is (for all J in Source'Range => Translate'Result (J - Source'First + 1) = Mapping (Source (J))), - Global => null, - Annotate => (GNATprove, Always_Return); + Global => null; + pragma Annotate (GNATprove, False_Positive, + "call via access-to-subprogram", + "function Mapping must always terminate"); function Translate (Source : String; @@ -776,8 +766,7 @@ package Ada.Strings.Fixed with SPARK_Mode is (for all J in Source'Range => Translate'Result (J - Source'First + 1) = Ada.Strings.Maps.Value (Mapping, Source (J))), - Global => null, - Annotate => (GNATprove, Always_Return); + Global => null; -- Returns the string S whose length is Source'Length and such that S (I) -- is the character to which Mapping maps the corresponding element of @@ -787,29 +776,30 @@ package Ada.Strings.Fixed with SPARK_Mode is (Source : in out String; Mapping : Maps.Character_Mapping_Function) with - Pre => Mapping /= null, - Post => + Pre => Mapping /= null, + Post => -- Each character in Source after the call is the translation of the -- character at the same position before the call, through Mapping. (for all J in Source'Range => Source (J) = Mapping (Source'Old (J))), - Global => null, - Annotate => (GNATprove, Always_Return); + Global => null; + pragma Annotate (GNATprove, False_Positive, + "call via access-to-subprogram", + "function Mapping must always terminate"); procedure Translate (Source : in out String; Mapping : Maps.Character_Mapping) with - Post => + Post => -- Each character in Source after the call is the translation of the -- character at the same position before the call, through Mapping. (for all J in Source'Range => Source (J) = Ada.Strings.Maps.Value (Mapping, Source'Old (J))), - Global => null, - Annotate => (GNATprove, Always_Return); + Global => null; -- Equivalent to Source := Translate(Source, Mapping) @@ -902,8 +892,7 @@ package Ada.Strings.Fixed with SPARK_Mode is (Low - Source'First + By'Length + 1 .. Replace_Slice'Result'Last) = Source (Low .. Source'Last))), - Global => null, - Annotate => (GNATprove, Always_Return); + Global => null; -- If Low > Source'Last + 1, or High < Source'First - 1, then Index_Error -- is propagated. Otherwise: -- @@ -923,7 +912,7 @@ package Ada.Strings.Fixed with SPARK_Mode is Justify : Alignment := Left; Pad : Character := Space) with - Pre => + Pre => Low - 1 <= Source'Last and then High >= Source'First - 1 and then (if High >= Low @@ -932,11 +921,8 @@ package Ada.Strings.Fixed with SPARK_Mode is - By'Length - Natural'Max (Source'Last - High, 0) else Source'Length <= Natural'Last - By'Length), - - -- Incomplete contract - - Global => null, - Annotate => (GNATprove, Might_Not_Return); + Global => null, + Exceptional_Cases => (Length_Error => Drop = Error); -- Equivalent to: -- -- Move (Replace_Slice (Source, Low, High, By), @@ -982,8 +968,7 @@ package Ada.Strings.Fixed with SPARK_Mode is (Before - Source'First + New_Item'Length + 1 .. Insert'Result'Last) = Source (Before .. Source'Last)), - Global => null, - Annotate => (GNATprove, Always_Return); + Global => null; -- Propagates Index_Error if Before is not in -- Source'First .. Source'Last + 1; otherwise, returns -- Source (Source'First .. Before - 1) @@ -995,14 +980,11 @@ package Ada.Strings.Fixed with SPARK_Mode is New_Item : String; Drop : Truncation := Error) with - Pre => + Pre => Before - 1 in Source'First - 1 .. Source'Last and then Source'Length <= Natural'Last - New_Item'Length, - - -- Incomplete contract - - Global => null, - Annotate => (GNATprove, Might_Not_Return); + Global => null, + Exceptional_Cases => (Length_Error => Drop = Error); -- Equivalent to Move (Insert (Source, Before, New_Item), Source, Drop) function Overwrite @@ -1051,8 +1033,7 @@ package Ada.Strings.Fixed with SPARK_Mode is (Position - Source'First + New_Item'Length + 1 .. Overwrite'Result'Last) = Source (Position + New_Item'Length .. Source'Last)), - Global => null, - Annotate => (GNATprove, Always_Return); + Global => null; -- Propagates Index_Error if Position is not in -- Source'First .. Source'Last + 1; otherwise, returns the string obtained -- from Source by consecutively replacing characters starting at Position @@ -1066,16 +1047,13 @@ package Ada.Strings.Fixed with SPARK_Mode is New_Item : String; Drop : Truncation := Right) with - Pre => + Pre => Position - 1 in Source'First - 1 .. Source'Last and then (if Position - Source'First >= Source'Length - New_Item'Length then Position - Source'First <= Natural'Last - New_Item'Length), - - -- Incomplete contract - - Global => null, - Annotate => (GNATprove, Might_Not_Return); + Global => null, + Exceptional_Cases => (Length_Error => Drop = Error); -- Equivalent to Move(Overwrite(Source, Position, New_Item), Source, Drop) function Delete @@ -1123,8 +1101,7 @@ package Ada.Strings.Fixed with SPARK_Mode is others => Delete'Result'Length = Source'Length and then Delete'Result = Source), - Global => null, - Annotate => (GNATprove, Always_Return); + Global => null; -- If From <= Through, the returned string is -- Replace_Slice(Source, From, Through, ""); otherwise, it is Source with -- lower bound 1. @@ -1136,14 +1113,10 @@ package Ada.Strings.Fixed with SPARK_Mode is Justify : Alignment := Left; Pad : Character := Space) with - Pre => (if From <= Through + Pre => (if From <= Through then (From in Source'Range and then Through <= Source'Last)), - - -- Incomplete contract - - Global => null, - Annotate => (GNATprove, Might_Not_Return); + Global => null; -- Equivalent to: -- -- Move (Delete (Source, From, Through), @@ -1157,7 +1130,7 @@ package Ada.Strings.Fixed with SPARK_Mode is (Source : String; Side : Trim_End) return String with - Post => + Post => -- Lower bound of the returned string is 1 @@ -1182,8 +1155,7 @@ package Ada.Strings.Fixed with SPARK_Mode is else Index_Non_Blank (Source, Backward)); begin Trim'Result = Source (Low .. High))), - Global => null, - Annotate => (GNATprove, Always_Return); + Global => null; -- Returns the string obtained by removing from Source all leading Space -- characters (if Side = Left), all trailing Space characters (if -- Side = Right), or all leading and trailing Space characters (if @@ -1195,11 +1167,7 @@ package Ada.Strings.Fixed with SPARK_Mode is Justify : Alignment := Left; Pad : Character := Space) with - - -- Incomplete contract - - Global => null, - Annotate => (GNATprove, Might_Not_Return); + Global => null; -- Equivalent to: -- -- Move (Trim (Source, Side), Source, Justify=>Justify, Pad=>Pad). @@ -1236,8 +1204,7 @@ package Ada.Strings.Fixed with SPARK_Mode is Index (Source, Right, Outside, Backward); begin Trim'Result = Source (Low .. High))), - Global => null, - Annotate => (GNATprove, Always_Return); + Global => null; -- Returns the string obtained by removing from Source all leading -- characters in Left and all trailing characters in Right. @@ -1248,11 +1215,7 @@ package Ada.Strings.Fixed with SPARK_Mode is Justify : Alignment := Strings.Left; Pad : Character := Space) with - - -- Incomplete contract - - Global => null, - Annotate => (GNATprove, Might_Not_Return); + Global => null; -- Equivalent to: -- -- Move (Trim (Source, Left, Right), @@ -1289,8 +1252,7 @@ package Ada.Strings.Fixed with SPARK_Mode is and then Head'Result (Source'Length + 1 .. Count) = [1 .. Count - Source'Length => Pad]), - Global => null, - Annotate => (GNATprove, Always_Return); + Global => null; -- Returns a string of length Count. If Count <= Source'Length, the string -- comprises the first Count characters of Source. Otherwise, its contents -- are Source concatenated with Count - Source'Length Pad characters. @@ -1301,11 +1263,8 @@ package Ada.Strings.Fixed with SPARK_Mode is Justify : Alignment := Left; Pad : Character := Space) with - - -- Incomplete contract - - Global => null, - Annotate => (GNATprove, Might_Not_Return); + Global => null, + Exceptional_Cases => (Length_Error => Count > Source'Length'Old); -- Equivalent to: -- -- Move (Head (Source, Count, Pad), @@ -1354,8 +1313,7 @@ package Ada.Strings.Fixed with SPARK_Mode is and then Tail'Result (Count - Source'Length + 1 .. Tail'Result'Last) = Source)), - Global => null, - Annotate => (GNATprove, Always_Return); + Global => null; -- Returns a string of length Count. If Count <= Source'Length, the string -- comprises the last Count characters of Source. Otherwise, its contents -- are Count-Source'Length Pad characters concatenated with Source. @@ -1366,11 +1324,8 @@ package Ada.Strings.Fixed with SPARK_Mode is Justify : Alignment := Left; Pad : Character := Space) with - - -- Incomplete contract - - Global => null, - Annotate => (GNATprove, Might_Not_Return); + Global => null, + Exceptional_Cases => (Length_Error => Count > Source'Length'Old); -- Equivalent to: -- -- Move (Tail (Source, Count, Pad), @@ -1384,7 +1339,7 @@ package Ada.Strings.Fixed with SPARK_Mode is (Left : Natural; Right : Character) return String with - Post => + Post => -- Lower bound of the returned string is 1 @@ -1397,8 +1352,7 @@ package Ada.Strings.Fixed with SPARK_Mode is -- All characters of the returned string are Right and then (for all C of "*"'Result => C = Right), - Global => null, - Annotate => (GNATprove, Always_Return); + Global => null; function "*" (Left : Natural; @@ -1421,8 +1375,7 @@ package Ada.Strings.Fixed with SPARK_Mode is and then (for all K in "*"'Result'Range => "*"'Result (K) = Right (Right'First + (K - 1) mod Right'Length)), - Global => null, - Annotate => (GNATprove, Always_Return); + Global => null; -- These functions replicate a character or string a specified number of -- times. The first function returns a string whose length is Left and each diff --git a/gcc/ada/libgnat/a-strmap.adb b/gcc/ada/libgnat/a-strmap.adb index 53af28b..529ecbb 100644 --- a/gcc/ada/libgnat/a-strmap.adb +++ b/gcc/ada/libgnat/a-strmap.adb @@ -545,7 +545,7 @@ is Result (Char) = ((for some Prev in Ranges'First .. R - 1 => Char in Ranges (Prev).Low .. Ranges (Prev).High) - or else (Char in Ranges (R).Low .. C))); + or else Char in Ranges (R).Low .. C)); end loop; pragma Loop_Invariant diff --git a/gcc/ada/libgnat/a-strmap.ads b/gcc/ada/libgnat/a-strmap.ads index 73dd3d9..a070da0 100644 --- a/gcc/ada/libgnat/a-strmap.ads +++ b/gcc/ada/libgnat/a-strmap.ads @@ -48,14 +48,13 @@ pragma Assertion_Policy (Pre => Ignore, with Ada.Characters.Latin_1; -package Ada.Strings.Maps - with SPARK_Mode +package Ada.Strings.Maps with + SPARK_Mode, + Always_Terminates is pragma Pure; -- In accordance with Ada 2005 AI-362 - pragma Annotate (GNATprove, Always_Return, Maps); - -------------------------------- -- Character Set Declarations -- -------------------------------- diff --git a/gcc/ada/libgnat/a-strsea.adb b/gcc/ada/libgnat/a-strsea.adb index ef35843..614b5ac 100644 --- a/gcc/ada/libgnat/a-strsea.adb +++ b/gcc/ada/libgnat/a-strsea.adb @@ -185,6 +185,9 @@ package body Ada.Strings.Search with SPARK_Mode is Ind := Ind + 1; for K in Pattern'Range loop if Pattern (K) /= Mapping (Source (Ind + (K - Pattern'First))) then + pragma Annotate (GNATprove, False_Positive, + "call via access-to-subprogram", + "function Mapping must always terminate"); pragma Assert (not (Match (Source, Pattern, Mapping, Ind))); goto Cont; end if; @@ -192,6 +195,9 @@ package body Ada.Strings.Search with SPARK_Mode is pragma Loop_Invariant (for all J in Pattern'First .. K => Pattern (J) = Mapping (Source (Ind + (J - Pattern'First)))); + pragma Annotate (GNATprove, False_Positive, + "call via access-to-subprogram", + "function Mapping must always terminate"); end loop; pragma Assert (Match (Source, Pattern, Mapping, Ind)); @@ -489,12 +495,18 @@ package body Ada.Strings.Search with SPARK_Mode is if Pattern (K) /= Mapping.all (Source (Ind + (K - Pattern'First))) then + pragma Annotate (GNATprove, False_Positive, + "call via access-to-subprogram", + "function Mapping must always terminate"); goto Cont1; end if; pragma Loop_Invariant (for all J in Pattern'First .. K => Pattern (J) = Mapping (Source (Ind + (J - Pattern'First)))); + pragma Annotate (GNATprove, False_Positive, + "call via access-to-subprogram", + "function Mapping must always terminate"); end loop; pragma Assert (Match (Source, Pattern, Mapping, Ind)); @@ -515,19 +527,25 @@ package body Ada.Strings.Search with SPARK_Mode is if Pattern (K) /= Mapping.all (Source (Ind + (K - Pattern'First))) then + pragma Annotate (GNATprove, False_Positive, + "call via access-to-subprogram", + "function Mapping must always terminate"); goto Cont2; end if; pragma Loop_Invariant (for all J in Pattern'First .. K => Pattern (J) = Mapping (Source (Ind + (J - Pattern'First)))); + pragma Annotate (GNATprove, False_Positive, + "call via access-to-subprogram", + "function Mapping must always terminate"); end loop; return Ind; <<Cont2>> pragma Loop_Invariant - (for all J in Ind .. (Source'Last - PL1) => + (for all J in Ind .. Source'Last - PL1 => not (Match (Source, Pattern, Mapping, J))); null; end loop; diff --git a/gcc/ada/libgnat/a-strsea.ads b/gcc/ada/libgnat/a-strsea.ads index 2c24e1a..df1b342 100644 --- a/gcc/ada/libgnat/a-strsea.ads +++ b/gcc/ada/libgnat/a-strsea.ads @@ -50,9 +50,11 @@ pragma Assertion_Policy (Pre => Ignore, with Ada.Strings.Maps; use type Ada.Strings.Maps.Character_Mapping_Function; -package Ada.Strings.Search with SPARK_Mode is +package Ada.Strings.Search with + SPARK_Mode, + Always_Terminates +is pragma Preelaborate; - pragma Annotate (GNATprove, Always_Return, Search); -- The ghost function Match tells whether the slice of Source starting at -- From and of length Pattern'Length matches with Pattern with respect to @@ -74,6 +76,9 @@ package Ada.Strings.Search with SPARK_Mode is and then Source'Length > 0 and then From in Source'First .. Source'Last - (Pattern'Length - 1), Global => null; + pragma Annotate (GNATprove, False_Positive, + "call via access-to-subprogram", + "function Mapping must always terminate"); function Match (Source : String; diff --git a/gcc/ada/libgnat/a-strsup.adb b/gcc/ada/libgnat/a-strsup.adb index a9323cf..c727575 100644 --- a/gcc/ada/libgnat/a-strsup.adb +++ b/gcc/ada/libgnat/a-strsup.adb @@ -29,12 +29,13 @@ -- -- ------------------------------------------------------------------------------ --- Ghost code, loop invariants and assertions in this unit are meant for +-- Ghost code, loop (in)variants and assertions in this unit are meant for -- analysis only, not for run-time checking, as it would be too costly -- otherwise. This is enforced by setting the assertion policy to Ignore. pragma Assertion_Policy (Ghost => Ignore, Loop_Invariant => Ignore, + Loop_Variant => Ignore, Assert => Ignore); with Ada.Strings.Maps; use Ada.Strings.Maps; @@ -1570,6 +1571,7 @@ package body Ada.Strings.Superbounded with SPARK_Mode is (for all K in 1 .. Indx => Result.Data (K) = Item (Item'First + (K - 1) mod Ilen)); + pragma Loop_Variant (Increases => Indx); end loop; Result.Data (Indx + 1 .. Max_Length) := Super_String_Data @@ -1609,6 +1611,7 @@ package body Ada.Strings.Superbounded with SPARK_Mode is (for all K in Indx + 1 .. Max_Length => Result.Data (K) = Item (Item'Last - (Max_Length - K) mod Ilen)); + pragma Loop_Variant (Decreases => Indx); end loop; Result.Data (1 .. Indx) := @@ -1654,6 +1657,7 @@ package body Ada.Strings.Superbounded with SPARK_Mode is Low : Positive; High : Natural) return Super_String is + Len : constant Natural := (if Low > High then 0 else High - Low + 1); begin return Result : Super_String (Source.Max_Length) do if Low - 1 > Source.Current_Length @@ -1662,9 +1666,8 @@ package body Ada.Strings.Superbounded with SPARK_Mode is raise Index_Error; end if; - Result.Current_Length := (if Low > High then 0 else High - Low + 1); - Result.Data (1 .. Result.Current_Length) := - Source.Data (Low .. High); + Result.Data (1 .. Len) := Source.Data (Low .. High); + Result.Current_Length := Len; end return; end Super_Slice; @@ -1674,6 +1677,7 @@ package body Ada.Strings.Superbounded with SPARK_Mode is Low : Positive; High : Natural) is + Len : constant Natural := (if Low > High then 0 else High - Low + 1); begin if Low - 1 > Source.Current_Length or else High > Source.Current_Length @@ -1681,8 +1685,8 @@ package body Ada.Strings.Superbounded with SPARK_Mode is raise Index_Error; end if; - Target.Current_Length := (if Low > High then 0 else High - Low + 1); - Target.Data (1 .. Target.Current_Length) := Source.Data (Low .. High); + Target.Data (1 .. Len) := Source.Data (Low .. High); + Target.Current_Length := Len; end Super_Slice; ---------------- @@ -1784,6 +1788,12 @@ package body Ada.Strings.Superbounded with SPARK_Mode is Source.Data (1 .. Npad) := [others => Pad]; Source.Data (Npad + 1 .. Max_Length) := Temp (1 .. Max_Length - Npad); + + pragma Assert + (Source.Data (1 .. Npad) = [1 .. Npad => Pad]); + pragma Assert + (Source.Data (Npad + 1 .. Max_Length) + = Temp (1 .. Max_Length - Npad)); end if; when Strings.Left => @@ -1844,10 +1854,16 @@ package body Ada.Strings.Superbounded with SPARK_Mode is begin for J in 1 .. Source.Current_Length loop Result.Data (J) := Mapping.all (Source.Data (J)); + pragma Annotate (GNATprove, False_Positive, + "call via access-to-subprogram", + "function Mapping must always terminate"); pragma Loop_Invariant (Result.Data (1 .. J)'Initialized); pragma Loop_Invariant (for all K in 1 .. J => Result.Data (K) = Mapping (Source.Data (K))); + pragma Annotate (GNATprove, False_Positive, + "call via access-to-subprogram", + "function Mapping must always terminate"); end loop; Result.Current_Length := Source.Current_Length; @@ -1861,9 +1877,15 @@ package body Ada.Strings.Superbounded with SPARK_Mode is begin for J in 1 .. Source.Current_Length loop Source.Data (J) := Mapping.all (Source.Data (J)); + pragma Annotate (GNATprove, False_Positive, + "call via access-to-subprogram", + "function Mapping must always terminate"); pragma Loop_Invariant (for all K in 1 .. J => Source.Data (K) = Mapping (Source'Loop_Entry.Data (K))); + pragma Annotate (GNATprove, False_Positive, + "call via access-to-subprogram", + "function Mapping must always terminate"); end loop; end Super_Translate; diff --git a/gcc/ada/libgnat/a-strsup.ads b/gcc/ada/libgnat/a-strsup.ads index 14e78e4..339cb17 100644 --- a/gcc/ada/libgnat/a-strsup.ads +++ b/gcc/ada/libgnat/a-strsup.ads @@ -51,7 +51,10 @@ with Ada.Strings.Maps; use type Ada.Strings.Maps.Character_Mapping_Function; with Ada.Strings.Search; with Ada.Strings.Text_Buffers; -package Ada.Strings.Superbounded with SPARK_Mode is +package Ada.Strings.Superbounded with + SPARK_Mode, + Always_Terminates +is pragma Preelaborate; -- Type Bounded_String in Ada.Strings.Bounded.Generic_Bounded_Length is @@ -68,7 +71,7 @@ package Ada.Strings.Superbounded with SPARK_Mode is -- Leaving it out is more efficient. end record with - Predicate => + Ghost_Predicate => Current_Length <= Max_Length and then Data (1 .. Current_Length)'Initialized, Put_Image => Put_Image; @@ -1406,6 +1409,9 @@ package Ada.Strings.Superbounded with SPARK_Mode is Super_Element (Super_Translate'Result, K) = Mapping (Super_Element (Source, K))), Global => null; + pragma Annotate (GNATprove, False_Positive, + "call via access-to-subprogram", + "function Mapping must always terminate"); procedure Super_Translate (Source : in out Super_String; @@ -1418,6 +1424,9 @@ package Ada.Strings.Superbounded with SPARK_Mode is Super_Element (Source, K) = Mapping (Super_Element (Source'Old, K))), Global => null; + pragma Annotate (GNATprove, False_Positive, + "call via access-to-subprogram", + "function Mapping must always terminate"); --------------------------------------- -- String Transformation Subprograms -- diff --git a/gcc/ada/libgnat/a-strunb.ads b/gcc/ada/libgnat/a-strunb.ads index 0b0085a..be76ad2 100644 --- a/gcc/ada/libgnat/a-strunb.ads +++ b/gcc/ada/libgnat/a-strunb.ads @@ -54,10 +54,10 @@ private with Ada.Strings.Text_Buffers; package Ada.Strings.Unbounded with SPARK_Mode, - Initial_Condition => Length (Null_Unbounded_String) = 0 + Initial_Condition => Length (Null_Unbounded_String) = 0, + Always_Terminates is pragma Preelaborate; - pragma Annotate (GNATprove, Always_Return, Unbounded); type Unbounded_String is private with Default_Initial_Condition => Length (Unbounded_String) = 0; @@ -86,21 +86,22 @@ is function To_Unbounded_String (Source : String) return Unbounded_String with - Post => Length (To_Unbounded_String'Result) = Source'Length, + Post => To_String (To_Unbounded_String'Result) = Source, Global => null; -- Returns an Unbounded_String that represents Source function To_Unbounded_String (Length : Natural) return Unbounded_String with - Post => - Ada.Strings.Unbounded.Length (To_Unbounded_String'Result) = Length, - Global => null; + SPARK_Mode => Off, + Global => null; -- Returns an Unbounded_String that represents an uninitialized String -- whose length is Length. function To_String (Source : Unbounded_String) return String with - Post => To_String'Result'Length = Length (Source), + Post => + To_String'Result'First = 1 + and then To_String'Result'Length = Length (Source), Global => null; -- Returns the String with lower bound 1 represented by Source @@ -115,6 +116,7 @@ is (Target : out Unbounded_String; Source : String) with + Post => To_String (Target) = Source, Global => null; pragma Ada_05 (Set_Unbounded_String); -- Sets Target to an Unbounded_String that represents Source @@ -198,6 +200,7 @@ is Index : Positive) return Character with Pre => Index <= Length (Source), + Post => Element'Result = To_String (Source) (Index), Global => null; -- Returns the character at position Index in the string represented by -- Source; propagates Index_Error if Index > Length (Source). @@ -259,18 +262,21 @@ is (Left : Unbounded_String; Right : Unbounded_String) return Boolean with + Post => "="'Result = (To_String (Left) = To_String (Right)), Global => null; function "=" (Left : Unbounded_String; Right : String) return Boolean with + Post => "="'Result = (To_String (Left) = Right), Global => null; function "=" (Left : String; Right : Unbounded_String) return Boolean with + Post => "="'Result = (Left = To_String (Right)), Global => null; function "<" diff --git a/gcc/ada/libgnat/a-strunb__shared.ads b/gcc/ada/libgnat/a-strunb__shared.ads index bb69056..2da9dc7 100644 --- a/gcc/ada/libgnat/a-strunb__shared.ads +++ b/gcc/ada/libgnat/a-strunb__shared.ads @@ -83,10 +83,10 @@ private with System.Atomic_Counters; private with Ada.Strings.Text_Buffers; package Ada.Strings.Unbounded with - Initial_Condition => Length (Null_Unbounded_String) = 0 + Initial_Condition => Length (Null_Unbounded_String) = 0, + Always_Terminates is pragma Preelaborate; - pragma Annotate (GNATprove, Always_Return, Unbounded); type Unbounded_String is private with Default_Initial_Condition => Length (Unbounded_String) = 0; @@ -108,24 +108,26 @@ is function To_Unbounded_String (Source : String) return Unbounded_String with - Post => Length (To_Unbounded_String'Result) = Source'Length, + Post => To_String (To_Unbounded_String'Result) = Source, Global => null; function To_Unbounded_String (Length : Natural) return Unbounded_String with - Post => - Ada.Strings.Unbounded.Length (To_Unbounded_String'Result) = Length, - Global => null; + SPARK_Mode => Off, + Global => null; function To_String (Source : Unbounded_String) return String with - Post => To_String'Result'Length = Length (Source), + Post => + To_String'Result'First = 1 + and then To_String'Result'Length = Length (Source), Global => null; procedure Set_Unbounded_String (Target : out Unbounded_String; Source : String) with + Post => To_String (Target) = Source, Global => null; pragma Ada_05 (Set_Unbounded_String); @@ -198,6 +200,7 @@ is Index : Positive) return Character with Pre => Index <= Length (Source), + Post => Element'Result = To_String (Source) (Index), Global => null; procedure Replace_Element @@ -244,18 +247,21 @@ is (Left : Unbounded_String; Right : Unbounded_String) return Boolean with + Post => "="'Result = (To_String (Left) = To_String (Right)), Global => null; function "=" (Left : Unbounded_String; Right : String) return Boolean with + Post => "="'Result = (To_String (Left) = Right), Global => null; function "=" (Left : String; Right : Unbounded_String) return Boolean with + Post => "="'Result = (Left = To_String (Right)), Global => null; function "<" diff --git a/gcc/ada/libgnat/a-ststio.adb b/gcc/ada/libgnat/a-ststio.adb index fd1017f..ab46f48 100644 --- a/gcc/ada/libgnat/a-ststio.adb +++ b/gcc/ada/libgnat/a-ststio.adb @@ -354,7 +354,7 @@ package body Ada.Streams.Stream_IO is -- mode now. Note that we can use Inout_File as the mode for the -- call since File_IO handles all modes for all file types. - if ((File.Mode = FCB.In_File) /= (Mode = In_File)) + if (File.Mode = FCB.In_File) /= (Mode = In_File) and then not File.Update_Mode then FIO.Reset (AP (File)'Unrestricted_Access, FCB.Inout_File); @@ -367,11 +367,13 @@ package body Ada.Streams.Stream_IO is FIO.Append_Set (AP (File)); if File.Mode = FCB.Append_File then - if Standard'Address_Size = 64 then + pragma Warnings (Off, "condition is always *"); + if Memory_Size = 2**64 then File.Index := Count (ftell64 (File.Stream)) + 1; else File.Index := Count (ftell (File.Stream)) + 1; end if; + pragma Warnings (On); end if; File.Last_Op := Op_Other; diff --git a/gcc/ada/libgnat/a-suenco.adb b/gcc/ada/libgnat/a-suenco.adb index b3748f7..39a44bf 100644 --- a/gcc/ada/libgnat/a-suenco.adb +++ b/gcc/ada/libgnat/a-suenco.adb @@ -391,7 +391,7 @@ package body Ada.Strings.UTF_Encoding.Conversions is Result (Len + 1) := Character'Val - (2#11110_000# or (Shift_Right (zzzzz, 2))); + (2#11110_000# or Shift_Right (zzzzz, 2)); Result (Len + 2) := Character'Val (2#10_000000# or Shift_Left (zzzzz and 2#11#, 4) diff --git a/gcc/ada/libgnat/a-textio.ads b/gcc/ada/libgnat/a-textio.ads index 713116e..ddbbd85 100644 --- a/gcc/ada/libgnat/a-textio.ads +++ b/gcc/ada/libgnat/a-textio.ads @@ -59,7 +59,8 @@ package Ada.Text_IO with SPARK_Mode, Abstract_State => File_System, Initializes => File_System, - Initial_Condition => Line_Length = 0 and Page_Length = 0 + Initial_Condition => Line_Length = 0 and Page_Length = 0, + Always_Terminates is pragma Elaborate_Body; @@ -101,15 +102,15 @@ is Name : String := ""; Form : String := "") with - Pre => not Is_Open (File), - Post => + Pre => not Is_Open (File), + Post => Is_Open (File) and then Ada.Text_IO.Mode (File) = Mode and then (if Mode /= In_File then (Line_Length (File) = 0 and then Page_Length (File) = 0)), - Global => (In_Out => File_System), - Annotate => (GNATprove, Might_Not_Return); + Global => (In_Out => File_System), + Exceptional_Cases => (Name_Error | Use_Error => Standard.True); procedure Open (File : in out File_Type; @@ -117,63 +118,63 @@ is Name : String; Form : String := "") with - Pre => not Is_Open (File), - Post => + Pre => not Is_Open (File), + Post => Is_Open (File) and then Ada.Text_IO.Mode (File) = Mode and then (if Mode /= In_File then (Line_Length (File) = 0 and then Page_Length (File) = 0)), - Global => (In_Out => File_System), - Annotate => (GNATprove, Might_Not_Return); + Global => (In_Out => File_System), + Exceptional_Cases => (Name_Error | Use_Error => Standard.True); procedure Close (File : in out File_Type) with - Pre => Is_Open (File), - Post => not Is_Open (File), - Global => (In_Out => File_System), - Annotate => (GNATprove, Always_Return); + Pre => Is_Open (File), + Post => not Is_Open (File), + Global => (In_Out => File_System); + procedure Delete (File : in out File_Type) with - Pre => Is_Open (File), - Post => not Is_Open (File), - Global => (In_Out => File_System), - Annotate => (GNATprove, Might_Not_Return); + Pre => Is_Open (File), + Post => not Is_Open (File), + Global => (In_Out => File_System), + Exceptional_Cases => (Use_Error => Standard.True); + procedure Reset (File : in out File_Type; Mode : File_Mode) with - Pre => Is_Open (File), - Post => + Pre => Is_Open (File), + Post => Is_Open (File) and then Ada.Text_IO.Mode (File) = Mode and then (if Mode /= In_File then (Line_Length (File) = 0 and then Page_Length (File) = 0)), - Global => (In_Out => File_System), - Annotate => (GNATprove, Might_Not_Return); + Global => (In_Out => File_System), + Exceptional_Cases => (Use_Error => Standard.True); + procedure Reset (File : in out File_Type) with - Pre => Is_Open (File), - Post => + Pre => Is_Open (File), + Post => Is_Open (File) and Mode (File)'Old = Mode (File) and (if Mode (File) /= In_File then (Line_Length (File) = 0 and then Page_Length (File) = 0)), - Global => (In_Out => File_System), - Annotate => (GNATprove, Might_Not_Return); + Global => (In_Out => File_System), + Exceptional_Cases => (Use_Error => Standard.True); function Mode (File : File_Type) return File_Mode with - Pre => Is_Open (File), - Global => null, - Annotate => (GNATprove, Always_Return); + Pre => Is_Open (File), + Global => null; + function Name (File : File_Type) return String with - Pre => Is_Open (File), - Global => null, - Annotate => (GNATprove, Always_Return); + Pre => Is_Open (File), + SPARK_Mode => Off; + function Form (File : File_Type) return String with - Pre => Is_Open (File), - Global => null, - Annotate => (GNATprove, Always_Return); + Pre => Is_Open (File), + Global => null; function Is_Open (File : File_Type) return Boolean with - Global => null, - Annotate => (GNATprove, Always_Return); + Global => null; ------------------------------------------------------ -- Control of default input, output and error files -- @@ -209,342 +210,337 @@ is -- an oversight, and was intended to be IN, see AI95-00057. procedure Flush (File : File_Type) with - Pre => Is_Open (File) and then Mode (File) /= In_File, - Post => + Pre => Is_Open (File) and then Mode (File) /= In_File, + Post => Line_Length (File)'Old = Line_Length (File) and Page_Length (File)'Old = Page_Length (File), - Global => (In_Out => File_System), - Annotate => (GNATprove, Always_Return); + Global => (In_Out => File_System); + procedure Flush with - Post => + Post => Line_Length'Old = Line_Length and Page_Length'Old = Page_Length, - Global => (In_Out => File_System), - Annotate => (GNATprove, Always_Return); + Global => (In_Out => File_System); -------------------------------------------- -- Specification of line and page lengths -- -------------------------------------------- procedure Set_Line_Length (File : File_Type; To : Count) with - Pre => Is_Open (File) and then Mode (File) /= In_File, - Post => + Pre => Is_Open (File) and then Mode (File) /= In_File, + Post => Line_Length (File) = To and Page_Length (File)'Old = Page_Length (File), - Global => (In_Out => File_System), - Annotate => (GNATprove, Might_Not_Return); + Global => (In_Out => File_System), + Exceptional_Cases => (Use_Error => Standard.True); + procedure Set_Line_Length (To : Count) with - Post => + Post => Line_Length = To and Page_Length'Old = Page_Length, - Global => (In_Out => File_System), - Annotate => (GNATprove, Might_Not_Return); + Global => (In_Out => File_System), + Exceptional_Cases => (Use_Error => Standard.True); procedure Set_Page_Length (File : File_Type; To : Count) with - Pre => Is_Open (File) and then Mode (File) /= In_File, - Post => + Pre => Is_Open (File) and then Mode (File) /= In_File, + Post => Page_Length (File) = To and Line_Length (File)'Old = Line_Length (File), - Global => (In_Out => File_System), - Annotate => (GNATprove, Might_Not_Return); + Global => (In_Out => File_System), + Exceptional_Cases => (Use_Error => Standard.True); + procedure Set_Page_Length (To : Count) with - Post => + Post => Page_Length = To and Line_Length'Old = Line_Length, - Global => (In_Out => File_System), - Annotate => (GNATprove, Might_Not_Return); + Global => (In_Out => File_System), + Exceptional_Cases => (Use_Error => Standard.True); function Line_Length (File : File_Type) return Count with - Pre => Is_Open (File) and then Mode (File) /= In_File, - Global => (Input => File_System); + Pre => Is_Open (File) and then Mode (File) /= In_File, + Global => (Input => File_System); + function Line_Length return Count with - Global => (Input => File_System), - Annotate => (GNATprove, Always_Return); + Global => (Input => File_System); function Page_Length (File : File_Type) return Count with - Pre => Is_Open (File) and then Mode (File) /= In_File, - Global => (Input => File_System); + Pre => Is_Open (File) and then Mode (File) /= In_File, + Global => (Input => File_System); + function Page_Length return Count with - Global => (Input => File_System), - Annotate => (GNATprove, Always_Return); + Global => (Input => File_System); ------------------------------------ -- Column, Line, and Page Control -- ------------------------------------ procedure New_Line (File : File_Type; Spacing : Positive_Count := 1) with - Pre => Is_Open (File) and then Mode (File) /= In_File, - Post => + Pre => Is_Open (File) and then Mode (File) /= In_File, + Post => Line_Length (File)'Old = Line_Length (File) and Page_Length (File)'Old = Page_Length (File), - Global => (In_Out => File_System), - Annotate => (GNATprove, Always_Return); + Global => (In_Out => File_System); + procedure New_Line (Spacing : Positive_Count := 1) with - Post => + Post => Line_Length'Old = Line_Length and Page_Length'Old = Page_Length, - Global => (In_Out => File_System), - Annotate => (GNATprove, Always_Return); + Global => (In_Out => File_System); procedure Skip_Line (File : File_Type; Spacing : Positive_Count := 1) with - Pre => Is_Open (File) and then Mode (File) = In_File, - Global => (In_Out => File_System), - Annotate => (GNATprove, Might_Not_Return); + Pre => Is_Open (File) and then Mode (File) = In_File, + Global => (In_Out => File_System), + Exceptional_Cases => (End_Error => Standard.True); + procedure Skip_Line (Spacing : Positive_Count := 1) with - Post => + Post => Line_Length'Old = Line_Length and Page_Length'Old = Page_Length, - Global => (In_Out => File_System), - Annotate => (GNATprove, Might_Not_Return); + Global => (In_Out => File_System), + Exceptional_Cases => (End_Error => Standard.True); function End_Of_Line (File : File_Type) return Boolean with - Pre => Is_Open (File) and then Mode (File) = In_File, - Global => (Input => File_System), - Annotate => (GNATprove, Always_Return); + Pre => Is_Open (File) and then Mode (File) = In_File, + Global => (Input => File_System); + function End_Of_Line return Boolean with - Global => (Input => File_System), - Annotate => (GNATprove, Always_Return); + Global => (Input => File_System); procedure New_Page (File : File_Type) with - Pre => Is_Open (File) and then Mode (File) /= In_File, - Post => + Pre => Is_Open (File) and then Mode (File) /= In_File, + Post => Line_Length (File)'Old = Line_Length (File) and Page_Length (File)'Old = Page_Length (File), - Global => (In_Out => File_System), - Annotate => (GNATprove, Always_Return); + Global => (In_Out => File_System); + procedure New_Page with - Post => + Post => Line_Length'Old = Line_Length and Page_Length'Old = Page_Length, - Global => (In_Out => File_System), - Annotate => (GNATprove, Always_Return); + Global => (In_Out => File_System); procedure Skip_Page (File : File_Type) with - Pre => Is_Open (File) and then Mode (File) = In_File, - Global => (In_Out => File_System), - Annotate => (GNATprove, Might_Not_Return); + Pre => Is_Open (File) and then Mode (File) = In_File, + Global => (In_Out => File_System), + Exceptional_Cases => (End_Error => Standard.True); + procedure Skip_Page with - Post => + Post => Line_Length'Old = Line_Length and Page_Length'Old = Page_Length, - Global => (In_Out => File_System), - Annotate => (GNATprove, Might_Not_Return); + Global => (In_Out => File_System), + Exceptional_Cases => (End_Error => Standard.True); function End_Of_Page (File : File_Type) return Boolean with - Pre => Is_Open (File) and then Mode (File) = In_File, - Global => (Input => File_System), - Annotate => (GNATprove, Always_Return); + Pre => Is_Open (File) and then Mode (File) = In_File, + Global => (Input => File_System); + function End_Of_Page return Boolean with - Global => (Input => File_System), - Annotate => (GNATprove, Always_Return); + Global => (Input => File_System); function End_Of_File (File : File_Type) return Boolean with - Pre => Is_Open (File) and then Mode (File) = In_File, - Global => (Input => File_System), - Annotate => (GNATprove, Always_Return); + Pre => Is_Open (File) and then Mode (File) = In_File, + Global => (Input => File_System); + function End_Of_File return Boolean with - Global => (Input => File_System), - Annotate => (GNATprove, Always_Return); + Global => (Input => File_System); procedure Set_Col (File : File_Type; To : Positive_Count) with - Pre => + Pre => Is_Open (File) and then (if Mode (File) /= In_File then (Line_Length (File) = 0 or else To <= Line_Length (File))), - Contract_Cases => + Contract_Cases => (Mode (File) /= In_File => Line_Length (File)'Old = Line_Length (File) and Page_Length (File)'Old = Page_Length (File), others => True), - Global => (In_Out => File_System), - Annotate => (GNATprove, Might_Not_Return); + Global => (In_Out => File_System), + Exceptional_Cases => (End_Error => Standard.True); + procedure Set_Col (To : Positive_Count) with - Pre => Line_Length = 0 or To <= Line_Length, - Post => + Pre => Line_Length = 0 or To <= Line_Length, + Post => Line_Length'Old = Line_Length and Page_Length'Old = Page_Length, - Global => (In_Out => File_System), - Annotate => (GNATprove, Might_Not_Return); + Global => (In_Out => File_System), + Exceptional_Cases => (End_Error => Standard.True); procedure Set_Line (File : File_Type; To : Positive_Count) with - Pre => + Pre => Is_Open (File) and then (if Mode (File) /= In_File then (Page_Length (File) = 0 or else To <= Page_Length (File))), - Contract_Cases => + Contract_Cases => (Mode (File) /= In_File => Line_Length (File)'Old = Line_Length (File) and Page_Length (File)'Old = Page_Length (File), others => True), - Global => (In_Out => File_System), - Annotate => (GNATprove, Might_Not_Return); + Global => (In_Out => File_System), + Exceptional_Cases => (End_Error => Standard.True); + procedure Set_Line (To : Positive_Count) with - Pre => Page_Length = 0 or To <= Page_Length, - Post => + Pre => Page_Length = 0 or To <= Page_Length, + Post => Line_Length'Old = Line_Length and Page_Length'Old = Page_Length, - Global => (In_Out => File_System), - Annotate => (GNATprove, Might_Not_Return); + Global => (In_Out => File_System), + Exceptional_Cases => (End_Error => Standard.True); function Col (File : File_Type) return Positive_Count with - Pre => Is_Open (File), - Global => (Input => File_System), - Annotate => (GNATprove, Always_Return); + SPARK_Mode => Off; + function Col return Positive_Count with - Global => (Input => File_System), - Annotate => (GNATprove, Always_Return); + SPARK_Mode => Off; function Line (File : File_Type) return Positive_Count with - Pre => Is_Open (File), - Global => (Input => File_System), - Annotate => (GNATprove, Always_Return); + SPARK_Mode => Off; + function Line return Positive_Count with - Global => (Input => File_System), - Annotate => (GNATprove, Always_Return); + SPARK_Mode => Off; function Page (File : File_Type) return Positive_Count with - Pre => Is_Open (File), - Global => (Input => File_System), - Annotate => (GNATprove, Always_Return); + SPARK_Mode => Off; + function Page return Positive_Count with - Global => (Input => File_System), - Annotate => (GNATprove, Always_Return); + SPARK_Mode => Off; ---------------------------- -- Character Input-Output -- ---------------------------- procedure Get (File : File_Type; Item : out Character) with - Pre => Is_Open (File) and then Mode (File) = In_File, - Global => (In_Out => File_System), - Annotate => (GNATprove, Might_Not_Return); + Pre => Is_Open (File) and then Mode (File) = In_File, + Global => (In_Out => File_System), + Exceptional_Cases => (End_Error => Standard.True); + procedure Get (Item : out Character) with - Post => + Post => Line_Length'Old = Line_Length and Page_Length'Old = Page_Length, - Global => (In_Out => File_System), - Annotate => (GNATprove, Might_Not_Return); + Global => (In_Out => File_System), + Exceptional_Cases => (End_Error => Standard.True); + procedure Put (File : File_Type; Item : Character) with - Pre => Is_Open (File) and then Mode (File) /= In_File, - Post => + Pre => Is_Open (File) and then Mode (File) /= In_File, + Post => Line_Length (File)'Old = Line_Length (File) and Page_Length (File)'Old = Page_Length (File), - Global => (In_Out => File_System), - Annotate => (GNATprove, Always_Return); + Global => (In_Out => File_System); + procedure Put (Item : Character) with - Post => + Post => Line_Length'Old = Line_Length and Page_Length'Old = Page_Length, - Global => (In_Out => File_System), - Annotate => (GNATprove, Always_Return); + Global => (In_Out => File_System); procedure Look_Ahead (File : File_Type; Item : out Character; End_Of_Line : out Boolean) with - Pre => Is_Open (File) and then Mode (File) = In_File, - Global => (Input => File_System), - Annotate => (GNATprove, Always_Return); + Pre => Is_Open (File) and then Mode (File) = In_File, + Global => (Input => File_System); procedure Look_Ahead (Item : out Character; End_Of_Line : out Boolean) with - Post => + Post => Line_Length'Old = Line_Length and Page_Length'Old = Page_Length, - Global => (Input => File_System), - Annotate => (GNATprove, Always_Return); + Global => (Input => File_System); procedure Get_Immediate (File : File_Type; Item : out Character) with - Pre => Is_Open (File) and then Mode (File) = In_File, - Global => (In_Out => File_System), - Annotate => (GNATprove, Might_Not_Return); + Pre => Is_Open (File) and then Mode (File) = In_File, + Global => (In_Out => File_System), + Exceptional_Cases => (End_Error => Standard.True); procedure Get_Immediate (Item : out Character) with - Post => + Post => Line_Length'Old = Line_Length and Page_Length'Old = Page_Length, - Global => (In_Out => File_System), - Annotate => (GNATprove, Might_Not_Return); + Global => (In_Out => File_System), + Exceptional_Cases => (End_Error => Standard.True); procedure Get_Immediate (File : File_Type; Item : out Character; Available : out Boolean) with - Pre => Is_Open (File) and then Mode (File) = In_File, - Global => (In_Out => File_System), - Annotate => (GNATprove, Might_Not_Return); + Pre => Is_Open (File) and then Mode (File) = In_File, + Global => (In_Out => File_System), + Exceptional_Cases => (End_Error => Standard.True); procedure Get_Immediate (Item : out Character; Available : out Boolean) with - Post => + Post => Line_Length'Old = Line_Length and Page_Length'Old = Page_Length, - Global => (In_Out => File_System), - Annotate => (GNATprove, Might_Not_Return); + Global => (In_Out => File_System), + Exceptional_Cases => (End_Error => Standard.True); ------------------------- -- String Input-Output -- ------------------------- procedure Get (File : File_Type; Item : out String) with - Pre => Is_Open (File) and then Mode (File) = In_File, - Global => (In_Out => File_System), - Annotate => (GNATprove, Might_Not_Return); + Pre => Is_Open (File) and then Mode (File) = In_File, + Global => (In_Out => File_System), + Exceptional_Cases => (End_Error => Item'Length'Old > 0); + procedure Get (Item : out String) with - Post => + Post => Line_Length'Old = Line_Length and Page_Length'Old = Page_Length, - Global => (In_Out => File_System), - Annotate => (GNATprove, Might_Not_Return); + Global => (In_Out => File_System), + Exceptional_Cases => (End_Error => Item'Length'Old > 0); + procedure Put (File : File_Type; Item : String) with - Pre => Is_Open (File) and then Mode (File) /= In_File, - Post => + Pre => Is_Open (File) and then Mode (File) /= In_File, + Post => Line_Length (File)'Old = Line_Length (File) and Page_Length (File)'Old = Page_Length (File), - Global => (In_Out => File_System), - Annotate => (GNATprove, Always_Return); + Global => (In_Out => File_System); + procedure Put (Item : String) with - Post => + Post => Line_Length'Old = Line_Length and Page_Length'Old = Page_Length, - Global => (In_Out => File_System), - Annotate => (GNATprove, Always_Return); + Global => (In_Out => File_System); procedure Get_Line (File : File_Type; Item : out String; Last : out Natural) with - Pre => Is_Open (File) and then Mode (File) = In_File, - Post => (if Item'Length > 0 then Last in Item'First - 1 .. Item'Last - else Last = Item'First - 1), - Global => (In_Out => File_System), - Annotate => (GNATprove, Might_Not_Return); + Pre => Is_Open (File) and then Mode (File) = In_File, + Post => + (if Item'Length > 0 then Last in Item'First - 1 .. Item'Last + else Last = Item'First - 1), + Global => (In_Out => File_System), + Exceptional_Cases => (End_Error => Item'Length'Old > 0); procedure Get_Line (Item : out String; Last : out Natural) with - Post => + Post => Line_Length'Old = Line_Length and Page_Length'Old = Page_Length and (if Item'Length > 0 then Last in Item'First - 1 .. Item'Last else Last = Item'First - 1), - Global => (In_Out => File_System), - Annotate => (GNATprove, Might_Not_Return); + Global => (In_Out => File_System), + Exceptional_Cases => (End_Error => Item'Length'Old > 0); function Get_Line (File : File_Type) return String with SPARK_Mode => Off; pragma Ada_05 (Get_Line); @@ -556,21 +552,19 @@ is (File : File_Type; Item : String) with - Pre => Is_Open (File) and then Mode (File) /= In_File, - Post => + Pre => Is_Open (File) and then Mode (File) /= In_File, + Post => Line_Length (File)'Old = Line_Length (File) and Page_Length (File)'Old = Page_Length (File), - Global => (In_Out => File_System), - Annotate => (GNATprove, Always_Return); + Global => (In_Out => File_System); procedure Put_Line (Item : String) with - Post => + Post => Line_Length'Old = Line_Length and Page_Length'Old = Page_Length, - Global => (In_Out => File_System), - Annotate => (GNATprove, Always_Return); + Global => (In_Out => File_System); --------------------------------------- -- Generic packages for Input-Output -- diff --git a/gcc/ada/libgnat/a-tideio.ads b/gcc/ada/libgnat/a-tideio.ads index b62d251..7f8fa19 100644 --- a/gcc/ada/libgnat/a-tideio.ads +++ b/gcc/ada/libgnat/a-tideio.ads @@ -43,7 +43,9 @@ private generic type Num is delta <> digits <>; -package Ada.Text_IO.Decimal_IO is +package Ada.Text_IO.Decimal_IO with + Always_Terminates +is Default_Fore : Field := Num'Fore; Default_Aft : Field := Num'Aft; @@ -54,19 +56,19 @@ package Ada.Text_IO.Decimal_IO is Item : out Num; Width : Field := 0) with - Pre => Is_Open (File) and then Mode (File) = In_File, - Global => (In_Out => File_System), - Annotate => (GNATprove, Might_Not_Return); + Pre => Is_Open (File) and then Mode (File) = In_File, + Global => (In_Out => File_System), + Exceptional_Cases => (Data_Error | End_Error => Standard.True); procedure Get (Item : out Num; Width : Field := 0) with - Post => + Post => Line_Length'Old = Line_Length and Page_Length'Old = Page_Length, - Global => (In_Out => File_System), - Annotate => (GNATprove, Might_Not_Return); + Global => (In_Out => File_System), + Exceptional_Cases => (Data_Error | End_Error => Standard.True); procedure Put (File : File_Type; @@ -75,12 +77,12 @@ package Ada.Text_IO.Decimal_IO is Aft : Field := Default_Aft; Exp : Field := Default_Exp) with - Pre => Is_Open (File) and then Mode (File) /= In_File, - Post => + Pre => Is_Open (File) and then Mode (File) /= In_File, + Post => Line_Length (File)'Old = Line_Length (File) and Page_Length (File)'Old = Page_Length (File), - Global => (In_Out => File_System), - Annotate => (GNATprove, Might_Not_Return); + Global => (In_Out => File_System), + Exceptional_Cases => (Layout_Error => Line_Length (File) /= 0); procedure Put (Item : Num; @@ -88,11 +90,11 @@ package Ada.Text_IO.Decimal_IO is Aft : Field := Default_Aft; Exp : Field := Default_Exp) with - Post => + Post => Line_Length'Old = Line_Length and Page_Length'Old = Page_Length, - Global => (In_Out => File_System), - Annotate => (GNATprove, Might_Not_Return); + Global => (In_Out => File_System), + Exceptional_Cases => (Layout_Error => Ada.Text_IO.Line_Length /= 0); procedure Get (From : String; @@ -100,7 +102,7 @@ package Ada.Text_IO.Decimal_IO is Last : out Positive) with Global => null, - Annotate => (GNATprove, Might_Not_Return); + Exceptional_Cases => (Data_Error => Standard.True); procedure Put (To : out String; @@ -108,8 +110,8 @@ package Ada.Text_IO.Decimal_IO is Aft : Field := Default_Aft; Exp : Field := Default_Exp) with - Global => null, - Annotate => (GNATprove, Might_Not_Return); + Global => null, + Exceptional_Cases => (Layout_Error => Standard.True); private pragma Inline (Get); diff --git a/gcc/ada/libgnat/a-tienio.ads b/gcc/ada/libgnat/a-tienio.ads index aac90f7..e4cdaee 100644 --- a/gcc/ada/libgnat/a-tienio.ads +++ b/gcc/ada/libgnat/a-tienio.ads @@ -23,21 +23,24 @@ private generic type Enum is (<>); -package Ada.Text_IO.Enumeration_IO is +package Ada.Text_IO.Enumeration_IO with + Always_Terminates +is Default_Width : Field := 0; Default_Setting : Type_Set := Upper_Case; procedure Get (File : File_Type; Item : out Enum) with - Pre => Is_Open (File) and then Mode (File) = In_File, - Global => (In_Out => File_System), - Annotate => (GNATprove, Might_Not_Return); + Pre => Is_Open (File) and then Mode (File) = In_File, + Global => (In_Out => File_System), + Exceptional_Cases => (Data_Error | End_Error => Standard.True); + procedure Get (Item : out Enum) with - Post => + Post => Line_Length'Old = Line_Length and Page_Length'Old = Page_Length, - Global => (In_Out => File_System), - Annotate => (GNATprove, Might_Not_Return); + Global => (In_Out => File_System), + Exceptional_Cases => (Data_Error | End_Error => Standard.True); procedure Put (File : File_Type; @@ -45,38 +48,38 @@ package Ada.Text_IO.Enumeration_IO is Width : Field := Default_Width; Set : Type_Set := Default_Setting) with - Pre => Is_Open (File) and then Mode (File) /= In_File, - Post => + Pre => Is_Open (File) and then Mode (File) /= In_File, + Post => Line_Length (File)'Old = Line_Length (File) and Page_Length (File)'Old = Page_Length (File), - Global => (In_Out => File_System), - Annotate => (GNATprove, Might_Not_Return); + Global => (In_Out => File_System), + Exceptional_Cases => (Layout_Error => Line_Length (File) /= 0); procedure Put (Item : Enum; Width : Field := Default_Width; Set : Type_Set := Default_Setting) with - Post => + Post => Line_Length'Old = Line_Length and Page_Length'Old = Page_Length, - Global => (In_Out => File_System), - Annotate => (GNATprove, Might_Not_Return); + Global => (In_Out => File_System), + Exceptional_Cases => (Layout_Error => Ada.Text_IO.Line_Length /= 0); procedure Get (From : String; Item : out Enum; Last : out Positive) with - Global => null, - Annotate => (GNATprove, Might_Not_Return); + Global => null, + Exceptional_Cases => (Data_Error => Standard.True); procedure Put (To : out String; Item : Enum; Set : Type_Set := Default_Setting) with - Global => null, - Annotate => (GNATprove, Might_Not_Return); + Global => null, + Exceptional_Cases => (Layout_Error => Standard.True); end Ada.Text_IO.Enumeration_IO; diff --git a/gcc/ada/libgnat/a-tifiio.ads b/gcc/ada/libgnat/a-tifiio.ads index bbf8e90..0e3e71c 100644 --- a/gcc/ada/libgnat/a-tifiio.ads +++ b/gcc/ada/libgnat/a-tifiio.ads @@ -23,7 +23,10 @@ private generic type Num is delta <>; -package Ada.Text_IO.Fixed_IO with SPARK_Mode => On is +package Ada.Text_IO.Fixed_IO with + SPARK_Mode => On, + Always_Terminates +is Default_Fore : Field := Num'Fore; Default_Aft : Field := Num'Aft; @@ -34,19 +37,19 @@ package Ada.Text_IO.Fixed_IO with SPARK_Mode => On is Item : out Num; Width : Field := 0) with - Pre => Is_Open (File) and then Mode (File) = In_File, - Global => (In_Out => File_System), - Annotate => (GNATprove, Might_Not_Return); + Pre => Is_Open (File) and then Mode (File) = In_File, + Global => (In_Out => File_System), + Exceptional_Cases => (Data_Error | End_Error => Standard.True); procedure Get (Item : out Num; Width : Field := 0) with - Post => + Post => Line_Length'Old = Line_Length and Page_Length'Old = Page_Length, - Global => (In_Out => File_System), - Annotate => (GNATprove, Might_Not_Return); + Global => (In_Out => File_System), + Exceptional_Cases => (Data_Error | End_Error => Standard.True); procedure Put (File : File_Type; @@ -55,12 +58,12 @@ package Ada.Text_IO.Fixed_IO with SPARK_Mode => On is Aft : Field := Default_Aft; Exp : Field := Default_Exp) with - Pre => Is_Open (File) and then Mode (File) /= In_File, - Post => + Pre => Is_Open (File) and then Mode (File) /= In_File, + Post => Line_Length (File)'Old = Line_Length (File) and Page_Length (File)'Old = Page_Length (File), - Global => (In_Out => File_System), - Annotate => (GNATprove, Might_Not_Return); + Global => (In_Out => File_System), + Exceptional_Cases => (Layout_Error => Line_Length (File) /= 0); procedure Put (Item : Num; @@ -68,19 +71,19 @@ package Ada.Text_IO.Fixed_IO with SPARK_Mode => On is Aft : Field := Default_Aft; Exp : Field := Default_Exp) with - Post => + Post => Line_Length'Old = Line_Length and Page_Length'Old = Page_Length, - Global => (In_Out => File_System), - Annotate => (GNATprove, Might_Not_Return); + Global => (In_Out => File_System), + Exceptional_Cases => (Layout_Error => Ada.Text_IO.Line_Length /= 0); procedure Get (From : String; Item : out Num; Last : out Positive) with - Global => null, - Annotate => (GNATprove, Might_Not_Return); + Global => null, + Exceptional_Cases => (Data_Error => Standard.True); procedure Put (To : out String; @@ -88,8 +91,8 @@ package Ada.Text_IO.Fixed_IO with SPARK_Mode => On is Aft : Field := Default_Aft; Exp : Field := Default_Exp) with - Global => null, - Annotate => (GNATprove, Might_Not_Return); + Global => null, + Exceptional_Cases => (Layout_Error => Standard.True); private pragma Inline (Get); diff --git a/gcc/ada/libgnat/a-tiflio.ads b/gcc/ada/libgnat/a-tiflio.ads index 82ff84b..fcfa76a 100644 --- a/gcc/ada/libgnat/a-tiflio.ads +++ b/gcc/ada/libgnat/a-tiflio.ads @@ -43,7 +43,10 @@ private generic type Num is digits <>; -package Ada.Text_IO.Float_IO with SPARK_Mode => On is +package Ada.Text_IO.Float_IO with + SPARK_Mode => On, + Always_Terminates +is Default_Fore : Field := 2; Default_Aft : Field := Num'Digits - 1; @@ -54,19 +57,19 @@ package Ada.Text_IO.Float_IO with SPARK_Mode => On is Item : out Num; Width : Field := 0) with - Pre => Is_Open (File) and then Mode (File) = In_File, - Global => (In_Out => File_System), - Annotate => (GNATprove, Might_Not_Return); + Pre => Is_Open (File) and then Mode (File) = In_File, + Global => (In_Out => File_System), + Exceptional_Cases => (Data_Error | End_Error => Standard.True); procedure Get (Item : out Num; Width : Field := 0) with - Post => + Post => Line_Length'Old = Line_Length and Page_Length'Old = Page_Length, - Global => (In_Out => File_System), - Annotate => (GNATprove, Might_Not_Return); + Global => (In_Out => File_System), + Exceptional_Cases => (Data_Error | End_Error => Standard.True); procedure Put (File : File_Type; @@ -75,12 +78,12 @@ package Ada.Text_IO.Float_IO with SPARK_Mode => On is Aft : Field := Default_Aft; Exp : Field := Default_Exp) with - Pre => Is_Open (File) and then Mode (File) /= In_File, - Post => + Pre => Is_Open (File) and then Mode (File) /= In_File, + Post => Line_Length (File)'Old = Line_Length (File) and Page_Length (File)'Old = Page_Length (File), - Global => (In_Out => File_System), - Annotate => (GNATprove, Might_Not_Return); + Global => (In_Out => File_System), + Exceptional_Cases => (Layout_Error => Line_Length (File) /= 0); procedure Put (Item : Num; @@ -88,19 +91,19 @@ package Ada.Text_IO.Float_IO with SPARK_Mode => On is Aft : Field := Default_Aft; Exp : Field := Default_Exp) with - Post => + Post => Line_Length'Old = Line_Length and Page_Length'Old = Page_Length, - Global => (In_Out => File_System), - Annotate => (GNATprove, Might_Not_Return); + Global => (In_Out => File_System), + Exceptional_Cases => (Layout_Error => Line_Length /= 0); procedure Get (From : String; Item : out Num; Last : out Positive) with - Global => null, - Annotate => (GNATprove, Might_Not_Return); + Global => null, + Exceptional_Cases => (Data_Error => Standard.True); procedure Put (To : out String; @@ -108,8 +111,8 @@ package Ada.Text_IO.Float_IO with SPARK_Mode => On is Aft : Field := Default_Aft; Exp : Field := Default_Exp) with - Global => null, - Annotate => (GNATprove, Might_Not_Return); + Global => null, + Exceptional_Cases => (Layout_Error => Standard.True); private pragma Inline (Get); diff --git a/gcc/ada/libgnat/a-tiinio.ads b/gcc/ada/libgnat/a-tiinio.ads index 0299cc0..60f21cc 100644 --- a/gcc/ada/libgnat/a-tiinio.ads +++ b/gcc/ada/libgnat/a-tiinio.ads @@ -43,7 +43,9 @@ private generic type Num is range <>; -package Ada.Text_IO.Integer_IO is +package Ada.Text_IO.Integer_IO with + Always_Terminates +is Default_Width : Field := Num'Width; Default_Base : Number_Base := 10; @@ -53,19 +55,19 @@ package Ada.Text_IO.Integer_IO is Item : out Num; Width : Field := 0) with - Pre => Is_Open (File) and then Mode (File) = In_File, - Global => (In_Out => File_System), - Annotate => (GNATprove, Might_Not_Return); + Pre => Is_Open (File) and then Mode (File) = In_File, + Global => (In_Out => File_System), + Exceptional_Cases => (Data_Error | End_Error => Standard.True); procedure Get (Item : out Num; Width : Field := 0) with - Post => + Post => Line_Length'Old = Line_Length and Page_Length'Old = Page_Length, - Global => (In_Out => File_System), - Annotate => (GNATprove, Might_Not_Return); + Global => (In_Out => File_System), + Exceptional_Cases => (Data_Error | End_Error => Standard.True); procedure Put (File : File_Type; @@ -73,39 +75,39 @@ package Ada.Text_IO.Integer_IO is Width : Field := Default_Width; Base : Number_Base := Default_Base) with - Pre => Is_Open (File) and then Mode (File) /= In_File, - Post => + Pre => Is_Open (File) and then Mode (File) /= In_File, + Post => Line_Length (File)'Old = Line_Length (File) and Page_Length (File)'Old = Page_Length (File), - Global => (In_Out => File_System), - Annotate => (GNATprove, Might_Not_Return); + Global => (In_Out => File_System), + Exceptional_Cases => (Layout_Error => Line_Length (File) /= 0); procedure Put (Item : Num; Width : Field := Default_Width; Base : Number_Base := Default_Base) with - Post => + Post => Line_Length'Old = Line_Length and Page_Length'Old = Page_Length, - Global => (In_Out => File_System), - Annotate => (GNATprove, Might_Not_Return); + Global => (In_Out => File_System), + Exceptional_Cases => (Layout_Error => Line_Length /= 0); procedure Get (From : String; Item : out Num; Last : out Positive) with - Global => null, - Annotate => (GNATprove, Might_Not_Return); + Global => null, + Exceptional_Cases => (Data_Error => Standard.True); procedure Put (To : out String; Item : Num; Base : Number_Base := Default_Base) with - Global => null, - Annotate => (GNATprove, Might_Not_Return); + Global => null, + Exceptional_Cases => (Layout_Error => Standard.True); private pragma Inline (Get); diff --git a/gcc/ada/libgnat/a-timoio.ads b/gcc/ada/libgnat/a-timoio.ads index c8554b8..40d91ed 100644 --- a/gcc/ada/libgnat/a-timoio.ads +++ b/gcc/ada/libgnat/a-timoio.ads @@ -43,7 +43,9 @@ private generic type Num is mod <>; -package Ada.Text_IO.Modular_IO is +package Ada.Text_IO.Modular_IO with + Always_Terminates +is Default_Width : Field := Num'Width; Default_Base : Number_Base := 10; @@ -53,19 +55,19 @@ package Ada.Text_IO.Modular_IO is Item : out Num; Width : Field := 0) with - Pre => Is_Open (File) and then Mode (File) = In_File, - Global => (In_Out => File_System), - Annotate => (GNATprove, Might_Not_Return); + Pre => Is_Open (File) and then Mode (File) = In_File, + Global => (In_Out => File_System), + Exceptional_Cases => (Data_Error | End_Error => Standard.True); procedure Get (Item : out Num; Width : Field := 0) with - Post => + Post => Line_Length'Old = Line_Length and Page_Length'Old = Page_Length, - Global => (In_Out => File_System), - Annotate => (GNATprove, Might_Not_Return); + Global => (In_Out => File_System), + Exceptional_Cases => (Data_Error | End_Error => Standard.True); procedure Put (File : File_Type; @@ -73,39 +75,39 @@ package Ada.Text_IO.Modular_IO is Width : Field := Default_Width; Base : Number_Base := Default_Base) with - Pre => Is_Open (File) and then Mode (File) /= In_File, - Post => + Pre => Is_Open (File) and then Mode (File) /= In_File, + Post => Line_Length (File)'Old = Line_Length (File) and Page_Length (File)'Old = Page_Length (File), - Global => (In_Out => File_System), - Annotate => (GNATprove, Might_Not_Return); + Global => (In_Out => File_System), + Exceptional_Cases => (Layout_Error => Line_Length (File) /= 0); procedure Put (Item : Num; Width : Field := Default_Width; Base : Number_Base := Default_Base) with - Post => + Post => Line_Length'Old = Line_Length and Page_Length'Old = Page_Length, - Global => (In_Out => File_System), - Annotate => (GNATprove, Might_Not_Return); + Global => (In_Out => File_System), + Exceptional_Cases => (Layout_Error => Line_Length /= 0); procedure Get (From : String; Item : out Num; Last : out Positive) with - Global => null, - Annotate => (GNATprove, Might_Not_Return); + Global => null, + Exceptional_Cases => (Data_Error => Standard.True); procedure Put (To : out String; Item : Num; Base : Number_Base := Default_Base) with - Global => null, - Annotate => (GNATprove, Might_Not_Return); + Global => null, + Exceptional_Cases => (Layout_Error => Standard.True); private pragma Inline (Get); diff --git a/gcc/ada/libgnat/g-alleve.adb b/gcc/ada/libgnat/g-alleve.adb index b51181a..91e3ddd 100644 --- a/gcc/ada/libgnat/g-alleve.adb +++ b/gcc/ada/libgnat/g-alleve.adb @@ -643,8 +643,8 @@ package body GNAT.Altivec.Low_Level_Vectors is begin for J in Varray_Type'Range loop - All_Element := All_Element and then (D (J) = Bool_True); - Any_Element := Any_Element or else (D (J) = Bool_True); + All_Element := All_Element and then D (J) = Bool_True; + Any_Element := Any_Element or else D (J) = Bool_True; end loop; if A = CR6_LT then @@ -1089,8 +1089,8 @@ package body GNAT.Altivec.Low_Level_Vectors is begin for J in Varray_Type'Range loop - All_Element := All_Element and then (D (J) = Bool_True); - Any_Element := Any_Element or else (D (J) = Bool_True); + All_Element := All_Element and then D (J) = Bool_True; + Any_Element := Any_Element or else D (J) = Bool_True; end loop; if A = CR6_LT then @@ -1582,7 +1582,7 @@ package body GNAT.Altivec.Low_Level_Vectors is D : C_float; begin - if (Bits (VSCR, NJ_POS, NJ_POS) = 1) + if Bits (VSCR, NJ_POS, NJ_POS) = 1 and then abs (X) < 2.0 ** (-126) then D := (if X < 0.0 then -0.0 else +0.0); diff --git a/gcc/ada/libgnat/g-debpoo.adb b/gcc/ada/libgnat/g-debpoo.adb index 91c1416..93be9b1 100644 --- a/gcc/ada/libgnat/g-debpoo.adb +++ b/gcc/ada/libgnat/g-debpoo.adb @@ -362,13 +362,6 @@ package body GNAT.Debug_Pools is -- These procedures are used as markers when computing the stacktraces, -- so that addresses in the debug pool itself are not reported to the user. - Code_Address_For_Allocate_End : System.Address := System.Null_Address; - Code_Address_For_Deallocate_End : System.Address; - Code_Address_For_Dereference_End : System.Address; - -- Taking the address of the above procedures will not work on some - -- architectures (HPUX for instance). Thus we do the same thing that - -- is done in a-except.adb, and get the address of labels instead. - procedure Skip_Levels (Depth : Natural; Trace : Tracebacks_Array; @@ -906,7 +899,7 @@ package body GNAT.Debug_Pools is Set_Handled; else Ptr.Valid (Offset / System.Storage_Unit) := - Ptr.Valid (Offset / System.Storage_Unit) and (not Bit); + Ptr.Valid (Offset / System.Storage_Unit) and not Bit; end if; end if; end Set_Valid; @@ -944,8 +937,6 @@ package body GNAT.Debug_Pools is pragma Unreferenced (Lock); begin - <<Allocate_Label>> - if Disable then Storage_Address := System.CRTL.malloc (System.CRTL.size_t (Size_In_Storage_Elements)); @@ -1022,8 +1013,8 @@ package body GNAT.Debug_Pools is (Pool => Pool, Kind => Alloc, Size => Size_In_Storage_Elements, - Ignored_Frame_Start => Allocate_Label'Address, - Ignored_Frame_End => Code_Address_For_Allocate_End); + Ignored_Frame_Start => Allocate'Code_Address, + Ignored_Frame_End => Allocate_End'Code_Address); pragma Warnings (Off); -- Turn warning on alignment for convert call off. We know that in fact @@ -1073,8 +1064,8 @@ package body GNAT.Debug_Pools is Put (Output_File (Pool), "), at "); Put_Line (Output_File (Pool), Pool.Stack_Trace_Depth, null, - Allocate_Label'Address, - Code_Address_For_Deallocate_End); + Allocate'Code_Address, + Deallocate_End'Code_Address); end if; -- Update internal data @@ -1106,11 +1097,7 @@ package body GNAT.Debug_Pools is -- is done in a-except, so that we can hide the traceback frames internal -- to this package - procedure Allocate_End is - begin - <<Allocate_End_Label>> - Code_Address_For_Allocate_End := Allocate_End_Label'Address; - end Allocate_End; + procedure Allocate_End is null; ------------------- -- Set_Dead_Beef -- @@ -1476,8 +1463,6 @@ package body GNAT.Debug_Pools is Header_Block_Size_Was_Less_Than_0 : Boolean := True; begin - <<Deallocate_Label>> - declare Lock : Scope_Lock; pragma Unreferenced (Lock); @@ -1518,8 +1503,8 @@ package body GNAT.Debug_Pools is Put (Output_File (Pool), "), at "); Put_Line (Output_File (Pool), Pool.Stack_Trace_Depth, null, - Deallocate_Label'Address, - Code_Address_For_Deallocate_End); + Deallocate'Code_Address, + Deallocate_End'Code_Address); Print_Traceback (Output_File (Pool), " Memory was allocated at ", Header.Alloc_Traceback); @@ -1569,8 +1554,8 @@ package body GNAT.Debug_Pools is (Find_Or_Create_Traceback (Pool, Dealloc, Header.Block_Size, - Deallocate_Label'Address, - Code_Address_For_Deallocate_End)), + Deallocate'Code_Address, + Deallocate_End'Code_Address)), Next => System.Null_Address, Block_Size => -Header.Block_Size); @@ -1608,8 +1593,8 @@ package body GNAT.Debug_Pools is Put (Output_File (Pool), "error: Freeing Null_Address, at "); Put_Line (Output_File (Pool), Pool.Stack_Trace_Depth, null, - Deallocate_Label'Address, - Code_Address_For_Deallocate_End); + Deallocate'Code_Address, + Deallocate_End'Code_Address); return; end if; end if; @@ -1629,8 +1614,8 @@ package body GNAT.Debug_Pools is Put (Output_File (Pool), "error: Freeing not allocated storage, at "); Put_Line (Output_File (Pool), Pool.Stack_Trace_Depth, null, - Deallocate_Label'Address, - Code_Address_For_Deallocate_End); + Deallocate'Code_Address, + Deallocate_End'Code_Address); end if; elsif Header_Block_Size_Was_Less_Than_0 then @@ -1640,8 +1625,8 @@ package body GNAT.Debug_Pools is Put (Output_File (Pool), "error: Freeing already deallocated storage, at "); Put_Line (Output_File (Pool), Pool.Stack_Trace_Depth, null, - Deallocate_Label'Address, - Code_Address_For_Deallocate_End); + Deallocate'Code_Address, + Deallocate_End'Code_Address); Print_Traceback (Output_File (Pool), " Memory already deallocated at ", To_Traceback (Header.Dealloc_Traceback)); @@ -1661,11 +1646,7 @@ package body GNAT.Debug_Pools is -- This is making assumptions about code order that may be invalid ??? - procedure Deallocate_End is - begin - <<Deallocate_End_Label>> - Code_Address_For_Deallocate_End := Deallocate_End_Label'Address; - end Deallocate_End; + procedure Deallocate_End is null; ----------------- -- Dereference -- @@ -1690,8 +1671,6 @@ package body GNAT.Debug_Pools is -- now invalid pointer would appear as valid). Instead, we prefer -- optimum performance for dereferences. - <<Dereference_Label>> - if not Valid then if Pool.Raise_Exceptions then raise Accessing_Not_Allocated_Storage; @@ -1699,8 +1678,8 @@ package body GNAT.Debug_Pools is Put (Output_File (Pool), "error: Accessing not allocated storage, at "); Put_Line (Output_File (Pool), Pool.Stack_Trace_Depth, null, - Dereference_Label'Address, - Code_Address_For_Dereference_End); + Deallocate'Code_Address, + Dereference_End'Code_Address); end if; else @@ -1714,8 +1693,8 @@ package body GNAT.Debug_Pools is "error: Accessing deallocated storage, at "); Put_Line (Output_File (Pool), Pool.Stack_Trace_Depth, null, - Dereference_Label'Address, - Code_Address_For_Dereference_End); + Deallocate'Code_Address, + Dereference_End'Code_Address); Print_Traceback (Output_File (Pool), " First deallocation at ", To_Traceback (Header.Dealloc_Traceback)); Print_Traceback (Output_File (Pool), " Initial allocation at ", @@ -1735,11 +1714,7 @@ package body GNAT.Debug_Pools is -- This is making assumptions about code order that may be invalid ??? - procedure Dereference_End is - begin - <<Dereference_End_Label>> - Code_Address_For_Dereference_End := Dereference_End_Label'Address; - end Dereference_End; + procedure Dereference_End is null; ---------------- -- Print_Info -- @@ -2512,10 +2487,4 @@ package body GNAT.Debug_Pools is Put_Line (Standard_Output, S); end Stdout_Put_Line; --- Package initialization - -begin - Allocate_End; - Deallocate_End; - Dereference_End; end GNAT.Debug_Pools; diff --git a/gcc/ada/libgnat/g-debuti.ads b/gcc/ada/libgnat/g-debuti.ads index b989cd4..51a1b77 100644 --- a/gcc/ada/libgnat/g-debuti.ads +++ b/gcc/ada/libgnat/g-debuti.ads @@ -39,8 +39,8 @@ with System; package GNAT.Debug_Utilities is pragma Pure; - Address_64 : constant Boolean := Standard'Address_Size = 64; - -- Set true if 64 bit addresses (assumes only 32 and 64 are possible) + Address_64 : constant Boolean := System.Memory_Size = 2**64; + -- Set true if 64-bit addresses (assumes only 32 and 64 are possible) Address_Image_Length : constant := 13 + 10 * Boolean'Pos (Address_64); -- Length of string returned by Image function for an address diff --git a/gcc/ada/libgnat/g-dirope.adb b/gcc/ada/libgnat/g-dirope.adb index 127f6ba..3cebc9f 100644 --- a/gcc/ada/libgnat/g-dirope.adb +++ b/gcc/ada/libgnat/g-dirope.adb @@ -636,7 +636,6 @@ package body GNAT.Directory_Operations is if not Is_Open (Dir) then Free (Dir); - Dir := Null_Dir; raise Directory_Error; end if; end Open; diff --git a/gcc/ada/libgnat/g-dirope.ads b/gcc/ada/libgnat/g-dirope.ads index a3a8e46..cdb99ff 100644 --- a/gcc/ada/libgnat/g-dirope.ads +++ b/gcc/ada/libgnat/g-dirope.ads @@ -210,8 +210,7 @@ package GNAT.Directory_Operations is procedure Open (Dir : out Dir_Type; Dir_Name : Dir_Name_Str); -- Opens the directory named by Dir_Name and returns a Dir_Type value -- that refers to this directory, and is positioned at the first entry. - -- Raises Directory_Error if Dir_Name cannot be accessed. In that case - -- Dir will be set to Null_Dir. + -- Raises Directory_Error if Dir_Name cannot be accessed. procedure Close (Dir : in out Dir_Type); -- Closes the directory stream referred to by Dir. After calling Close diff --git a/gcc/ada/libgnat/g-dynhta.adb b/gcc/ada/libgnat/g-dynhta.adb index 0119b56..7a62ac8 100644 --- a/gcc/ada/libgnat/g-dynhta.adb +++ b/gcc/ada/libgnat/g-dynhta.adb @@ -56,9 +56,9 @@ package body GNAT.Dynamic_HTables is -- range of Bucket_Range_Type. return - ((Left and Mask) * Half) + (Left and Mask) * Half or - (Right and Mask); + (Right and Mask); end Hash_Two_Keys; ------------------- diff --git a/gcc/ada/libgnat/g-sercom__linux.adb b/gcc/ada/libgnat/g-sercom__linux.adb index 216092e..401ab85 100644 --- a/gcc/ada/libgnat/g-sercom__linux.adb +++ b/gcc/ada/libgnat/g-sercom__linux.adb @@ -304,7 +304,7 @@ package body GNAT.Serial_Communications is Current.c_cc (VMIN) := char'Val (0); Current.c_cc (VTIME) := char'Val (Natural (Timeout * 10)); - Current.c_lflag := Current.c_lflag or (not ICANON); + Current.c_lflag := Current.c_lflag or not ICANON; end if; Res := cfsetispeed (Current'Address, C_Data_Rate (Rate)); diff --git a/gcc/ada/libgnat/g-souinf.ads b/gcc/ada/libgnat/g-souinf.ads index b6598b5..ea65c73 100644 --- a/gcc/ada/libgnat/g-souinf.ads +++ b/gcc/ada/libgnat/g-souinf.ads @@ -41,7 +41,7 @@ package GNAT.Source_Info with Abstract_State => (Source_Code_Information with External => (Async_Writers, Async_Readers)), - Annotate => (GNATprove, Always_Return) + Always_Terminates is pragma Preelaborate; -- Note that this unit is Preelaborate, but not Pure, that's because the diff --git a/gcc/ada/libgnat/g-spipat.ads b/gcc/ada/libgnat/g-spipat.ads index 5766b3a..297afbf 100644 --- a/gcc/ada/libgnat/g-spipat.ads +++ b/gcc/ada/libgnat/g-spipat.ads @@ -58,7 +58,7 @@ -- stored in a binary compatible manner. -- GNAT.Spitbol.Patterns (files g-spipat.ads/g-spipat.adb) --- This is a completely general patterm matching package based on the +-- This is a completely general pattern matching package based on the -- pattern language of SNOBOL4, as implemented in SPITBOL. The pattern -- language is modeled on context free grammars, with context sensitive -- extensions that provide full (type 0) computational capabilities. diff --git a/gcc/ada/libgnat/i-c.adb b/gcc/ada/libgnat/i-c.adb index 4cfccf4..63aa2a2 100644 --- a/gcc/ada/libgnat/i-c.adb +++ b/gcc/ada/libgnat/i-c.adb @@ -186,7 +186,7 @@ is (Item : char_array; Trim_Nul : Boolean := True) return String is - Count : Natural := 0; + Count : Natural; From : size_t; begin @@ -200,6 +200,7 @@ is pragma Loop_Invariant (for all J in Item'First .. From when J /= From => Item (J) /= nul); + pragma Loop_Variant (Increases => From); if From > Item'Last then raise Terminator_Error; @@ -257,6 +258,7 @@ is pragma Loop_Invariant (for all J in Item'First .. From when J /= From => Item (J) /= nul); + pragma Loop_Variant (Increases => From); if From > Item'Last then raise Terminator_Error; @@ -333,6 +335,7 @@ is pragma Loop_Invariant (for all J in Item'First .. From when J /= From => Item (J) /= wide_nul); + pragma Loop_Variant (Increases => From); if From > Item'Last then raise Terminator_Error; @@ -390,6 +393,7 @@ is pragma Loop_Invariant (for all J in Item'First .. From when J /= From => Item (J) /= wide_nul); + pragma Loop_Variant (Increases => From); if From > Item'Last then raise Terminator_Error; @@ -466,6 +470,7 @@ is pragma Loop_Invariant (for all J in Item'First .. From when J /= From => Item (J) /= char16_nul); + pragma Loop_Variant (Increases => From); if From > Item'Last then raise Terminator_Error; @@ -523,6 +528,7 @@ is pragma Loop_Invariant (for all J in Item'First .. From when J /= From => Item (J) /= char16_nul); + pragma Loop_Variant (Increases => From); if From > Item'Last then raise Terminator_Error; @@ -599,6 +605,8 @@ is pragma Loop_Invariant (for all J in Item'First .. From when J /= From => Item (J) /= char32_nul); + pragma Loop_Invariant (From <= Item'First + C_Length_Ghost (Item)); + pragma Loop_Variant (Increases => From); if From > Item'Last then raise Terminator_Error; @@ -656,6 +664,7 @@ is pragma Loop_Invariant (for all J in Item'First .. From when J /= From => Item (J) /= char32_nul); + pragma Loop_Variant (Increases => From); if From > Item'Last then raise Terminator_Error; diff --git a/gcc/ada/libgnat/i-c.ads b/gcc/ada/libgnat/i-c.ads index 7013902..fe87fba 100644 --- a/gcc/ada/libgnat/i-c.ads +++ b/gcc/ada/libgnat/i-c.ads @@ -24,12 +24,14 @@ pragma Assertion_Policy (Pre => Ignore, Contract_Cases => Ignore, Ghost => Ignore); +with System; with System.Parameters; -package Interfaces.C - with SPARK_Mode, Pure +package Interfaces.C with + SPARK_Mode, + Pure, + Always_Terminates is - pragma Annotate (GNATprove, Always_Return, C); -- Each of the types declared in Interfaces.C is C-compatible. @@ -82,10 +84,9 @@ is -- a non-private system.address type. type ptrdiff_t is - range -(2 ** (System.Parameters.ptr_bits - Integer'(1))) .. - +(2 ** (System.Parameters.ptr_bits - Integer'(1)) - 1); + range -System.Memory_Size / 2 .. System.Memory_Size / 2 - 1; - type size_t is mod 2 ** System.Parameters.ptr_bits; + type size_t is mod System.Memory_Size; -- Boolean type diff --git a/gcc/ada/libgnat/i-cheri.adb b/gcc/ada/libgnat/i-cheri.adb new file mode 100644 index 0000000..174fdcc --- /dev/null +++ b/gcc/ada/libgnat/i-cheri.adb @@ -0,0 +1,75 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- I N T E R F A C E S . C H E R I -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2023, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body Interfaces.CHERI is + + ---------------------------- + -- Set_Address_And_Bounds -- + ---------------------------- + + procedure Set_Address_And_Bounds + (Cap : in out Capability; + Address : System.Storage_Elements.Integer_Address; + Length : Bounds_Length) + is + begin + Cap := Capability_With_Address_And_Bounds (Cap, Address, Length); + end Set_Address_And_Bounds; + + ---------------------------------- + -- Set_Address_And_Exact_Bounds -- + ---------------------------------- + + procedure Set_Address_And_Exact_Bounds + (Cap : in out Capability; + Address : System.Storage_Elements.Integer_Address; + Length : Bounds_Length) + is + begin + Cap := Capability_With_Address_And_Exact_Bounds (Cap, Address, Length); + end Set_Address_And_Exact_Bounds; + + ---------------------- + -- Align_Address_Up -- + ---------------------- + + function Align_Address_Up + (Address : System.Storage_Elements.Integer_Address; + Length : Bounds_Length) + return System.Storage_Elements.Integer_Address + is + Mask : constant System.Storage_Elements.Integer_Address := + Representable_Alignment_Mask (Length); + begin + return (Address + (not Mask)) and Mask; + end Align_Address_Up; + +end Interfaces.CHERI; diff --git a/gcc/ada/libgnat/i-cheri.ads b/gcc/ada/libgnat/i-cheri.ads new file mode 100644 index 0000000..547b033 --- /dev/null +++ b/gcc/ada/libgnat/i-cheri.ads @@ -0,0 +1,470 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- I N T E R F A C E S . C H E R I -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2023, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides bindings to CHERI intrinsics and some common +-- operations on capabilities. + +with System; +with System.Storage_Elements; + +package Interfaces.CHERI with + Preelaborate, + No_Elaboration_Code_All +is + + use type System.Storage_Elements.Integer_Address; + + subtype Capability is System.Address; + + type Bounds_Length is range 0 .. System.Memory_Size - 1 with + Size => System.Word_Size; + + ---------------------------- + -- Capability Permissions -- + ---------------------------- + + type Permissions_Mask is mod System.Memory_Size with + Size => System.Word_Size; + + Global : constant Permissions_Mask := 16#0001#; + Executive : constant Permissions_Mask := 16#0002#; + Mutable_Load : constant Permissions_Mask := 16#0040#; + Compartment_Id : constant Permissions_Mask := 16#0080#; + Branch_Sealed_Pair : constant Permissions_Mask := 16#0100#; + Access_System_Registers : constant Permissions_Mask := 16#0200#; + Permit_Unseal : constant Permissions_Mask := 16#0400#; + Permit_Seal : constant Permissions_Mask := 16#0800#; + Permit_Store_Local : constant Permissions_Mask := 16#1000#; + Permit_Store_Capability : constant Permissions_Mask := 16#2000#; + Permit_Load_Capability : constant Permissions_Mask := 16#4000#; + Permit_Execute : constant Permissions_Mask := 16#8000#; + Permit_Store : constant Permissions_Mask := 16#1_0000#; + Permit_Load : constant Permissions_Mask := 16#2_0000#; + + function "and" + (Cap : Capability; + Mask : Permissions_Mask) + return Capability + with + Import, Convention => Intrinsic, + External_Name => "__builtin_cheri_perms_and"; + -- Perform a bitwise-AND of a capability permissions and the specified + -- mask, returning the new capability. + + function Get_Permissions (Cap : Capability) return Permissions_Mask with + Import, Convention => Intrinsic, + External_Name => "__builtin_cheri_perms_get"; + -- Get the permissions of a capability + + function Clear_Permissions + (Cap : Capability; + Mask : Permissions_Mask) + return Capability is + (Cap and not Mask); + -- Clear the specified permissions of a capability, returning the new + -- capability. + + function Has_All_Permissions + (Cap : Capability; + Permissions : Permissions_Mask) + return Boolean is + ((Get_Permissions (Cap) and Permissions) = Permissions); + -- Query whether all of the specified permission bits are set in a + -- capability's permissions flags. + + ----------------------- + -- Common Intrinsics -- + ----------------------- + + function Capability_With_Address + (Cap : Capability; + Addr : System.Storage_Elements.Integer_Address) + return Capability + with + Import, Convention => Intrinsic, + External_Name => "__builtin_cheri_address_set"; + -- Return a new capability with the same bounds and permissions as Cap, + -- with the address set to Addr. + + function Get_Address + (Cap : Capability) + return System.Storage_Elements.Integer_Address + with + Import, Convention => Intrinsic, + External_Name => "__builtin_cheri_address_get"; + -- Get the address of a capability + + procedure Set_Address + (Cap : in out Capability; + Addr : System.Storage_Elements.Integer_Address) + with + Import, Convention => Intrinsic, + External_Name => "__builtin_cheri_address_set"; + -- Set the address of a capability + + function Get_Base + (Cap : Capability) + return System.Storage_Elements.Integer_Address + with + Import, Convention => Intrinsic, + External_Name => "__builtin_cheri_base_get"; + -- Get the lower bound of a capability + + function Get_Offset (Cap : Capability) return Bounds_Length with + Import, Convention => Intrinsic, + External_Name => "__builtin_cheri_offset_get"; + -- Get the difference between the address and the lower bound of a + -- capability. + + procedure Set_Offset + (Cap : in out Capability; + Offset : Bounds_Length) + with + Import, Convention => Intrinsic, + External_Name => "__builtin_cheri_offset_set"; + -- Set the address relative to the lower bound of a capability + + function Capability_With_Offset + (Cap : Capability; + Value : Bounds_Length) + return Capability + with + Import, Convention => Intrinsic, + External_Name => "__builtin_cheri_offset_set"; + -- Set the address relative to the lower bound of a capability, returning + -- the new capability. + + function Increment_Offset + (Cap : Capability; + Value : Bounds_Length) + return Capability + with + Import, Convention => Intrinsic, + External_Name => "__builtin_cheri_offset_increment"; + -- Increment the address of a capability by the specified amount, + -- returning the new capability. + + function Get_Length (Cap : Capability) return Bounds_Length with + Import, Convention => Intrinsic, + External_Name => "__builtin_cheri_length_get"; + -- Get the length of a capability's bounds + + function Clear_Tag (Cap : Capability) return Capability with + Import, Convention => Intrinsic, + External_Name => "__builtin_cheri_tag_clear"; + -- Clear the capability validity tag, returning the new capability + + function Get_Tag (Cap : Capability) return Boolean with + Import, Convention => Intrinsic, + External_Name => "__builtin_cheri_tag_get"; + -- Get the validty tag of a capability + + function Is_Valid (Cap : Capability) return Boolean is (Get_Tag (Cap)); + -- Check whether a capability is valid + + function Is_Invalid (Cap : Capability) return Boolean is + (not Is_Valid (Cap)); + -- Check whether a capability is invalid + + function Is_Equal_Exact (A, B : Capability) return Boolean with + Import, Convention => Intrinsic, + External_Name => "__builtin_cheri_equal_exact"; + -- Check for bit equality between two capabilities + + function Is_Subset (A, B : Capability) return Boolean with + Import, Convention => Intrinsic, + External_Name => "__builtin_cheri_subset_test"; + -- Returns True if capability A is a subset or equal to capability B + + -------------------- + -- Bounds Setting -- + -------------------- + + function Capability_With_Bounds + (Cap : Capability; + Length : Bounds_Length) + return Capability + with + Import, Convention => Intrinsic, + External_Name => "__builtin_cheri_bounds_set"; + -- Narrow the bounds of a capability so that the lower bound is the + -- current address and the upper bound is suitable for the Length, + -- returning the new capability. + -- + -- Note that the effective bounds of the returned capability may be wider + -- than the range Get_Address (Cap) .. Get_Address (Cap) + Length - 1 due + -- to capability compression, but they will always be a subset of the + -- original bounds. + + function Capability_With_Exact_Bounds + (Cap : Capability; + Length : Bounds_Length) + return Capability + with + Import, Convention => Intrinsic, + External_Name => "__builtin_cheri_bounds_set_exact"; + -- Narrow the bounds of a capability so that the lower bound is the + -- current address and the upper bound is suitable for the Length, + -- returning the new capability. + -- + -- This is similar to Capability_With_Bounds but will clear the capability + -- tag in the returned capability if the bounds cannot be set exactly, due + -- to capability compression. + + function Capability_With_Address_And_Bounds + (Cap : Capability; + Address : System.Storage_Elements.Integer_Address; + Length : Bounds_Length) + return Capability is + (Capability_With_Bounds + (Capability_With_Address (Cap, Address), Length)); + -- Set the address and narrow the bounds of the capability so that the + -- lower bound is Address and the upper bound is Address + Length, + -- returning the new capability. + -- + -- Note that the effective bounds of the returned capability may be wider + -- than the range Address .. Address + Length - 1 due to capability + -- compression, but they will always be a subset of the original bounds. + + function Capability_With_Address_And_Exact_Bounds + (Cap : Capability; + Address : System.Storage_Elements.Integer_Address; + Length : Bounds_Length) + return Capability is + (Capability_With_Exact_Bounds + (Capability_With_Address (Cap, Address), Length)); + -- Set the address and narrow the bounds of the capability so that the + -- lower bound is Address and the upper bound is Address + Length, + -- returning the new capability. + -- + -- This is similar to Capability_With_Address_And_Bounds but will clear the + -- capability tag in the returned capability if the bounds cannot be set + -- exactly, due to capability compression. + + procedure Set_Bounds + (Cap : in out Capability; + Length : Bounds_Length) + with + Import, Convention => Intrinsic, + External_Name => "__builtin_cheri_bounds_set"; + -- Narrow the bounds of a capability so that the lower bound is the + -- current address and the upper bound is suitable for the Length. + -- + -- Note that the effective bounds of the output capability may be wider + -- than the range Get_Address (Cap) .. Get_Address (Cap) + Length - 1 due + -- to capability compression, but they will always be a subset of the + -- original bounds. + + procedure Set_Exact_Bounds + (Cap : in out Capability; + Length : Bounds_Length) + with + Import, Convention => Intrinsic, + External_Name => "__builtin_cheri_bounds_set_exact"; + -- Narrow the bounds of a capability so that the lower bound is the + -- current address and the upper bound is suitable for the Length. + -- + -- This is similar to Set_Bounds but will clear the capability tag if the + -- bounds cannot be set exactly, due to capability compression. + + procedure Set_Address_And_Bounds + (Cap : in out Capability; + Address : System.Storage_Elements.Integer_Address; + Length : Bounds_Length) + with + Inline_Always; + -- Set the address and narrow the bounds of the capability so that the + -- lower bound is Address and the upper bound is Address + Length. + -- + -- Note that the effective bounds of the output capability may be wider + -- than the range Address .. Address + Length - 1 due to capability + -- compression, but they will always be a subset of the original bounds. + + procedure Set_Address_And_Exact_Bounds + (Cap : in out Capability; + Address : System.Storage_Elements.Integer_Address; + Length : Bounds_Length) + with + Inline_Always; + -- Set the address and narrow the bounds of the capability so that the + -- lower bound is Address and the upper bound is Address + Length. + -- + -- This is similar to Set_Address_And_Bounds but will clear the capability + -- tag if the bounds cannot be set exactly, due to capability compression. + + function Representable_Length (Length : Bounds_Length) return Bounds_Length + with + Import, Convention => Intrinsic, + External_Name => "__builtin_cheri_round_representable_length"; + -- Returns the length that a capability would have after using Set_Bounds + -- to set the Length (assuming appropriate alignment of the base). + + function Representable_Alignment_Mask + (Length : Bounds_Length) + return System.Storage_Elements.Integer_Address + with + Import, Convention => Intrinsic, + External_Name => "__builtin_cheri_representable_alignment_mask"; + -- Returns a bitmask that can be used to align an address downwards such + -- that it is sufficiently aligned to create a precisely bounded + -- capability. + + function Align_Address_Down + (Address : System.Storage_Elements.Integer_Address; + Length : Bounds_Length) + return System.Storage_Elements.Integer_Address is + (Address and Representable_Alignment_Mask (Length)); + -- Align an address such that it is sufficiently aligned to create a + -- precisely bounded capability, rounding down if necessary. + -- + -- Due to capability compression, the upper and lower bounds of a + -- capability must be aligned based on the length of the bounds to ensure + -- that the capability is representable. This function aligns an address + -- down to the next boundary if it is not already aligned. + + function Capability_With_Address_Aligned_Down + (Cap : Capability; + Length : Bounds_Length) + return Capability is + (Capability_With_Address + (Cap, Align_Address_Down (Get_Address (Cap), Length))); + -- Align a capability's address such that it is sufficiently aligned to + -- create a precisely bounded capability, rounding down if necessary. + -- + -- Due to capability compression, the upper and lower bounds of a + -- capability must be aligned based on the length of the bounds to ensure + -- that the capability is representable. This function aligns an address + -- down to the next boundary if it is not already aligned. + + function Align_Address_Up + (Address : System.Storage_Elements.Integer_Address; + Length : Bounds_Length) + return System.Storage_Elements.Integer_Address + with + Inline; + -- Align an address such that it is sufficiently aligned to create a + -- precisely bounded capability, rounding upwards if necessary. + -- + -- Due to capability compression, the upper and lower bounds of a + -- capability must be aligned based on the length of the bounds to ensure + -- that the capability is representable. This function aligns an address up + -- to the next boundary if it is not already aligned. + + function Capability_With_Address_Aligned_Up + (Cap : Capability; + Length : Bounds_Length) + return Capability is + (Capability_With_Address + (Cap, Align_Address_Up (Get_Address (Cap), Length))); + -- Align a capability's address such that it is sufficiently aligned to + -- create a precisely bounded capability, rounding upwards if necessary. + -- + -- Due to capability compression, the upper and lower bounds of a + -- capability must be aligned based on the length of the bounds to ensure + -- that the capability is representable. This function aligns an address up + -- to the next boundary if it is not already aligned. + + ------------------------------------------ + -- Object Types, Sealing, and Unsealing -- + ------------------------------------------ + + type Object_Type is + range -2**(System.Word_Size - 1) .. +2**(System.Word_Size - 1) - 1 with + Size => System.Word_Size; + + Type_Unsealed : constant Object_Type := 0; + Type_Sentry : constant Object_Type := 1; + + function Get_Object_Type (Cap : Capability) return Object_Type with + Import, Convention => Intrinsic, + External_Name => "__builtin_cheri_type_get"; + -- Get the object type of a capability + + function Is_Sealed (Cap : Capability) return Boolean with + Import, Convention => Intrinsic, + External_Name => "__builtin_cheri_sealed_get"; + -- Check whether a capability is sealed + + function Is_Unsealed (Cap : Capability) return Boolean is + (not Is_Sealed (Cap)); + -- Check whether a capability is unsealed + + function Is_Sentry (Cap : Capability) return Boolean is + (Get_Object_Type (Cap) = Type_Sentry); + -- Check whether a capability is a sealed entry + + function Create_Sentry (Cap : Capability) return Capability with + Import, Convention => Intrinsic, + External_Name => "__builtin_cheri_seal_entry"; + -- Create a sealed entry and return the new capability. + + function Seal + (Cap : Capability; + Sealing_Cap : Capability) + return Capability + with + Import, Convention => Intrinsic, + External_Name => "__builtin_cheri_seal"; + -- Seal a capability with a sealing capability, by setting the object type + -- of the capability to the Sealing_Cap's value, returning the sealed + -- capability. + + function Unseal + (Cap : Capability; + Unsealing_Cap : Capability) + return Capability + with + Import, Convention => Intrinsic, + External_Name => "__builtin_cheri_unseal"; + -- Unseal a capability with an unsealing capability, by checking the object + -- type of the capability against the Sealing_Cap's value, returning the + -- unsealed capability. + + ----------------------------------- + -- Capability Register Accessors -- + ----------------------------------- + + function Get_PCC return System.Address with + Import, Convention => Intrinsic, + External_Name => "__builtin_cheri_program_counter_get"; + -- Get the Program Counter Capablity (PCC) + + function Get_DDC return System.Address with + Import, Convention => Intrinsic, + External_Name => "__builtin_cheri_global_data_get"; + -- Get the Default Data Capability (DDC) + + function Get_CSP return System.Address with + Import, Convention => Intrinsic, + External_Name => "__builtin_cheri_stack_get"; + -- Get the Capability Stack Pointer (CSP) + +end Interfaces.CHERI; diff --git a/gcc/ada/libgnat/i-cpoint.adb b/gcc/ada/libgnat/i-cpoint.adb index bf08e1a..e1805f4 100644 --- a/gcc/ada/libgnat/i-cpoint.adb +++ b/gcc/ada/libgnat/i-cpoint.adb @@ -29,19 +29,20 @@ -- -- ------------------------------------------------------------------------------ -with Interfaces.C.Strings; use Interfaces.C.Strings; -with System; use System; +with Interfaces.C.Strings; use Interfaces.C.Strings; +with System.Storage_Elements; use System.Storage_Elements; +with System; use System; with Ada.Unchecked_Conversion; package body Interfaces.C.Pointers is - type Addr is mod 2 ** System.Parameters.ptr_bits; + subtype Offset is Storage_Offset; - function To_Pointer is new Ada.Unchecked_Conversion (Addr, Pointer); - function To_Addr is new Ada.Unchecked_Conversion (Pointer, Addr); - function To_Addr is new Ada.Unchecked_Conversion (ptrdiff_t, Addr); - function To_Ptrdiff is new Ada.Unchecked_Conversion (Addr, ptrdiff_t); + function To_Pointer is new Ada.Unchecked_Conversion (Address, Pointer); + function To_Addr is new Ada.Unchecked_Conversion (Pointer, Address); + function To_Offset is new Ada.Unchecked_Conversion (ptrdiff_t, Offset); + function To_Ptrdiff is new Ada.Unchecked_Conversion (Offset, ptrdiff_t); Elmt_Size : constant ptrdiff_t := (Element_Array'Component_Size @@ -59,7 +60,7 @@ package body Interfaces.C.Pointers is raise Pointer_Error; end if; - return To_Pointer (To_Addr (Left) + To_Addr (Elmt_Size * Right)); + return To_Pointer (To_Addr (Left) + To_Offset (Elmt_Size * Right)); end "+"; function "+" (Left : ptrdiff_t; Right : Pointer) return Pointer is @@ -68,7 +69,7 @@ package body Interfaces.C.Pointers is raise Pointer_Error; end if; - return To_Pointer (To_Addr (Elmt_Size * Left) + To_Addr (Right)); + return To_Pointer (To_Offset (Elmt_Size * Left) + To_Addr (Right)); end "+"; --------- @@ -81,7 +82,7 @@ package body Interfaces.C.Pointers is raise Pointer_Error; end if; - return To_Pointer (To_Addr (Left) - To_Addr (Right * Elmt_Size)); + return To_Pointer (To_Addr (Left) - To_Offset (Right * Elmt_Size)); end "-"; function "-" (Left : Pointer; Right : Pointer) return ptrdiff_t is diff --git a/gcc/ada/libgnat/i-cstrin.ads b/gcc/ada/libgnat/i-cstrin.ads index 0f39cd8..e486f03 100644 --- a/gcc/ada/libgnat/i-cstrin.ads +++ b/gcc/ada/libgnat/i-cstrin.ads @@ -44,7 +44,8 @@ pragma Assertion_Policy (Pre => Ignore); package Interfaces.C.Strings with SPARK_Mode => On, Abstract_State => (C_Memory), - Initializes => (C_Memory) + Initializes => (C_Memory), + Always_Terminates is pragma Preelaborate; @@ -67,7 +68,7 @@ is (Item : char_array_access; Nul_Check : Boolean := False) return chars_ptr with - SPARK_Mode => Off; + SPARK_Mode => Off; -- To_Chars_Ptr'Result is aliased with Item function New_Char_Array (Chars : char_array) return chars_ptr with Volatile_Function, @@ -120,10 +121,8 @@ is with Pre => Item /= Null_Ptr - and then - (if Check then - Strlen (Item) <= size_t'Last - Offset - and then Strlen (Item) + Offset <= Chars'Length), + and then Strlen (Item) <= size_t'Last - Offset + and then Strlen (Item) + Offset <= Chars'Length, Global => (In_Out => C_Memory); procedure Update @@ -134,10 +133,8 @@ is with Pre => Item /= Null_Ptr - and then - (if Check then - Strlen (Item) <= size_t'Last - Offset - and then Strlen (Item) + Offset <= Str'Length), + and then Strlen (Item) <= size_t'Last - Offset + and then Strlen (Item) + Offset <= Str'Length, Global => (In_Out => C_Memory); Update_Error : exception; diff --git a/gcc/ada/libgnat/interfac.ads b/gcc/ada/libgnat/interfac.ads index edd3f36..bc37a8e 100644 --- a/gcc/ada/libgnat/interfac.ads +++ b/gcc/ada/libgnat/interfac.ads @@ -35,10 +35,11 @@ -- This is the compiler version of this unit -package Interfaces is +package Interfaces with + Always_Terminates +is pragma No_Elaboration_Code_All; pragma Pure; - pragma Annotate (GNATprove, Always_Return, Interfaces); -- All identifiers in this unit are implementation defined diff --git a/gcc/ada/libgnat/interfac__2020.ads b/gcc/ada/libgnat/interfac__2020.ads index 89557bf..70d82be 100644 --- a/gcc/ada/libgnat/interfac__2020.ads +++ b/gcc/ada/libgnat/interfac__2020.ads @@ -35,10 +35,11 @@ -- This is the runtime version of this unit (not used during GNAT build) -package Interfaces is +package Interfaces with + Always_Terminates +is pragma No_Elaboration_Code_All; pragma Pure; - pragma Annotate (GNATprove, Always_Return, Interfaces); -- All identifiers in this unit are implementation defined diff --git a/gcc/ada/libgnat/s-aridou.adb b/gcc/ada/libgnat/s-aridou.adb index 67ebdd4..831590c 100644 --- a/gcc/ada/libgnat/s-aridou.adb +++ b/gcc/ada/libgnat/s-aridou.adb @@ -45,7 +45,8 @@ is Contract_Cases => Ignore, Ghost => Ignore, Loop_Invariant => Ignore, - Assert => Ignore); + Assert => Ignore, + Assert_And_Cut => Ignore); pragma Suppress (Overflow_Check); pragma Suppress (Range_Check); @@ -138,16 +139,11 @@ is (Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (X1)) + Big_2xxSingle * Big (Double_Uns (X2)) + Big (Double_Uns (X3))) - with Ghost; + with + Ghost, + Annotate => (GNATprove, Inline_For_Proof); -- 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)); @@ -169,9 +165,8 @@ is function To_Neg_Int (A : Double_Uns) return Double_Int with - Annotate => (GNATprove, Always_Return), - Pre => In_Double_Int_Range (-Big (A)), - Post => Big (To_Neg_Int'Result) = -Big (A); + Pre => In_Double_Int_Range (-Big (A)), + Post => Big (To_Neg_Int'Result) = -Big (A); -- Convert to negative integer equivalent. If the input is in the range -- 0 .. 2 ** (Double_Size - 1), then the corresponding nonpositive signed -- integer (obtained by negating the given value) is returned, otherwise @@ -179,9 +174,8 @@ is function To_Pos_Int (A : Double_Uns) return Double_Int with - Annotate => (GNATprove, Always_Return), - Pre => In_Double_Int_Range (Big (A)), - Post => Big (To_Pos_Int'Result) = Big (A); + Pre => In_Double_Int_Range (Big (A)), + Post => Big (To_Pos_Int'Result) = Big (A); -- Convert to positive integer equivalent. If the input is in the range -- 0 .. 2 ** (Double_Size - 1) - 1, then the corresponding non-negative -- signed integer is returned, otherwise constraint error is raised. @@ -1069,17 +1063,10 @@ is T1 := Ylo * Zlo; - pragma Assert (Big (T2) = Big (Double_Uns'(Yhi * Zlo)) - + Big (Double_Uns'(Ylo * Zhi))); Lemma_Mult_Distribution (Big_2xxSingle, Big (Double_Uns'(Yhi * Zlo)), Big (Double_Uns'(Ylo * Zhi))); - pragma Assert (Mult = Big_2xxSingle * Big (T2) + Big (T1)); Lemma_Hi_Lo (T1, Hi (T1), Lo (T1)); - pragma Assert - (Mult = Big_2xxSingle * Big (T2) - + Big_2xxSingle * Big (Double_Uns (Hi (T1))) - + Big (Double_Uns (Lo (T1)))); Lemma_Mult_Distribution (Big_2xxSingle, Big (T2), Big (Double_Uns (Hi (T1)))); @@ -1087,17 +1074,11 @@ is T2 := T2 + Hi (T1); - pragma Assert - (Mult = Big_2xxSingle * Big (T2) + Big (Double_Uns (Lo (T1)))); Lemma_Hi_Lo (T2, Hi (T2), Lo (T2)); Lemma_Mult_Distribution (Big_2xxSingle, Big (Double_Uns (Hi (T2))), Big (Double_Uns (Lo (T2)))); Lemma_Double_Big_2xxSingle; - pragma Assert - (Mult = Big_2xxDouble * Big (Double_Uns (Hi (T2))) - + Big_2xxSingle * Big (Double_Uns (Lo (T2))) - + Big (Double_Uns (Lo (T1)))); if Hi (T2) /= 0 then R := X; @@ -1543,15 +1524,36 @@ is Post => X / Double_Uns'(2) ** I / Double_Uns'(2) = X / Double_Uns'(2) ** (I + 1); + procedure Lemma_Quot_Rem (X, Div, Q, R : Double_Uns) + with + Ghost, + Pre => Div /= 0 + and then X = Q * Div + R + and then Q <= Double_Uns'Last / Div + and then R <= Double_Uns'Last - Q * Div + and then R < Div, + Post => Q = X / Div; + pragma Annotate (GNATprove, False_Positive, "postcondition might fail", + "Q is the quotient of X by Div"); + procedure Lemma_Div_Pow2 (X : Double_Uns; I : Natural) is Div1 : constant Double_Uns := Double_Uns'(2) ** I; Div2 : constant Double_Uns := Double_Uns'(2); Left : constant Double_Uns := X / Div1 / Div2; + R2 : constant Double_Uns := X / Div1 - Left * Div2; + pragma Assert (R2 <= Div2 - 1); + R1 : constant Double_Uns := X - X / Div1 * Div1; + pragma Assert (R1 < Div1); begin + pragma Assert (X = Left * (Div1 * Div2) + R2 * Div1 + R1); + pragma Assert (R2 * Div1 + R1 < Div1 * Div2); + Lemma_Quot_Rem (X, Div1 * Div2, Left, R2 * Div1 + R1); pragma Assert (Left = X / (Div1 * Div2)); pragma Assert (Div1 * Div2 = Double_Uns'(2) ** (I + 1)); end Lemma_Div_Pow2; + procedure Lemma_Quot_Rem (X, Div, Q, R : Double_Uns) is null; + XX : Double_Uns := X; begin @@ -1932,7 +1934,9 @@ is + Big_2xxSingle * Big_2xxSingle * D2 + Big_2xxSingle * D3 + D4) - with Ghost; + with + Ghost, + Annotate => (GNATprove, Inline_For_Proof); function Is_Scaled_Mult_Decomposition (D1, D2, D3, D4 : Big_Integer) @@ -1945,7 +1949,8 @@ is + D4) with Ghost, - Pre => Scale < Double_Size; + Annotate => (GNATprove, Inline_For_Proof), + Pre => Scale < Double_Size; -- Local lemmas @@ -2115,12 +2120,15 @@ is -- fourth component. procedure Prove_Scaled_Mult_Decomposition_Regroup3 - (D1, D2, D3, D4 : Big_Integer) + (D1, D2, D3, D4 : Single_Uns) 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); + and then Is_Scaled_Mult_Decomposition + (Big (Double_Uns (D1)), Big (Double_Uns (D2)), + Big (Double_Uns (D3)), Big (Double_Uns (D4))), + Post => Is_Scaled_Mult_Decomposition (0, 0, Big3 (D1, D2, D3), + Big (Double_Uns (D4))); -- Proves scaled decomposition of Mult after regrouping on third -- component. @@ -2221,17 +2229,8 @@ is pragma Assert (Big_D3 = Big_T2); pragma Assert (Big_2xxSingle * Big_D3 = Big_2xxSingle * Big_T2); Lemma_Mult_Commutation (2 ** Scale, Double_Uns (D (4)), T3); - pragma Assert (Big_D4 = Big_T3); pragma Assert - (By (Is_Scaled_Mult_Decomposition (0, Big_T1, Big_T2, Big_T3), - By (Big_2xxSingle * Big_2xxSingle * Big_D12 = - Big_2xxSingle * Big_2xxSingle * Big_T1, - Big_D12 = Big_T1) - and then - By (Big_2xxSingle * Big_D3 = Big_2xxSingle * Big_T2, - Big_D3 = Big_T2) - and then - Big_D4 = Big_T3)); + (Is_Scaled_Mult_Decomposition (0, Big_T1, Big_T2, Big_T3)); Lemma_Hi_Lo (T1, Hi (T1), Lo (T1)); Lemma_Hi_Lo (T2, Hi (T2), Lo (T2)); Lemma_Hi_Lo (T3, Hi (T3), Lo (T3)); @@ -2247,60 +2246,6 @@ is Lemma_Mult_Distribution (Big_2xxSingle, Big (Double_Uns (Lo (T2))), Big (Double_Uns (Hi (T3)))); - pragma Assert - (By (Is_Scaled_Mult_Decomposition - (Big (Double_Uns (Hi (T1))), - Big (Double_Uns (Lo (T1))) + Big (Double_Uns (Hi (T2))), - Big (Double_Uns (Lo (T2))) + Big (Double_Uns (Hi (T3))), - Big (Double_Uns (Lo (T3)))), - -- Start from stating equality between the expanded values of - -- the right-hand side in the known and desired assertions over - -- Is_Scaled_Mult_Decomposition. - By (Big_2xxSingle * Big_2xxSingle * Big_2xxSingle * - Big (Double_Uns (Hi (T1))) - + Big_2xxSingle * Big_2xxSingle * - (Big (Double_Uns (Lo (T1))) + Big (Double_Uns (Hi (T2)))) - + Big_2xxSingle * - (Big (Double_Uns (Lo (T2))) + Big (Double_Uns (Hi (T3)))) - + Big (Double_Uns (Lo (T3))) = - Big_2xxSingle * Big_2xxSingle * Big_2xxSingle * 0 - + Big_2xxSingle * Big_2xxSingle * Big_T1 - + Big_2xxSingle * Big_T2 - + Big_T3, - -- Now list all known equalities that contribute - Big_2xxSingle * Big_2xxSingle * Big_2xxSingle * - Big (Double_Uns (Hi (T1))) - + Big_2xxSingle * Big_2xxSingle * - (Big (Double_Uns (Lo (T1))) + Big (Double_Uns (Hi (T2)))) - + Big_2xxSingle * - (Big (Double_Uns (Lo (T2))) + Big (Double_Uns (Hi (T3)))) - + Big (Double_Uns (Lo (T3))) = - Big_2xxSingle * Big_2xxSingle * Big_2xxSingle * - Big (Double_Uns (Hi (T1))) - + Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (Lo (T1))) - + Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (Hi (T2))) - + Big_2xxSingle * Big (Double_Uns (Lo (T2))) - + Big_2xxSingle * Big (Double_Uns (Hi (T3))) - + Big (Double_Uns (Lo (T3))) - and then - By (Big_2xxSingle * Big_2xxSingle * Big (T1) - = Big_2xxSingle * Big_2xxSingle * Big_2xxSingle - * Big (Double_Uns (Hi (T1))) - + Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (Lo (T1))), - Big_2xxSingle * Big_2xxSingle * Big (T1) - = Big_2xxSingle * Big_2xxSingle - * (Big_2xxSingle * Big (Double_Uns (Hi (T1))) - + Big (Double_Uns (Lo (T1))))) - and then - By (Big_2xxSingle * Big (T2) - = Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (Hi (T2))) - + Big_2xxSingle * Big (Double_Uns (Lo (T2))), - Big_2xxSingle * Big (T2) - = Big_2xxSingle * (Big_2xxSingle * Big (Double_Uns (Hi (T2))) - + Big (Double_Uns (Lo (T2))))) - and then - Big (T3) = Big_2xxSingle * Big (Double_Uns (Hi (T3))) - + Big (Double_Uns (Lo (T3)))))); Lemma_Mult_Distribution (Big_2xxSingle * Big_2xxSingle, Big (Double_Uns (Lo (T1))), Big (Double_Uns (Hi (T2)))); @@ -2310,24 +2255,6 @@ is Double_Uns (Lo (T2)) + Double_Uns (Hi (T3))); Lemma_Add_Commutation (Double_Uns (Lo (T1)), Hi (T2)); Lemma_Add_Commutation (Double_Uns (Lo (T2)), Hi (T3)); - pragma Assert - (By (Is_Scaled_Mult_Decomposition - (Big (Double_Uns (Hi (T1))), - Big (Double_Uns (Lo (T1) or Hi (T2))), - Big (Double_Uns (Lo (T2) or Hi (T3))), - Big (Double_Uns (Lo (T3)))), - By (Big_2xxSingle * Big_2xxSingle - * Big (Double_Uns (Lo (T1) or Hi (T2))) = - Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (Lo (T1))) - + Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (Hi (T2))), - Big_2xxSingle * Big_2xxSingle - * Big (Double_Uns (Lo (T1)) + Double_Uns (Hi (T2))) = - Big_2xxSingle * Big_2xxSingle - * (Big (Double_Uns (Lo (T1))) + Big (Double_Uns (Hi (T2))))) - and then - Big_2xxSingle * Big (Double_Uns (Lo (T2) or Hi (T3))) = - Big_2xxSingle * Big (Double_Uns (Lo (T2))) - + Big_2xxSingle * Big (Double_Uns (Hi (T3))))); end Prove_Dividend_Scaling; -------------------------- @@ -2342,13 +2269,30 @@ is Lemma_Hi_Lo (T3, Hi (T3), S2); Lemma_Mult_Commutation (Double_Uns (Q), Double_Uns (Lo (Zu)), T1); Lemma_Mult_Commutation (Double_Uns (Q), Double_Uns (Hi (Zu)), T2); - pragma Assert (Big (Double_Uns (Q)) * Big (Zu) = - Big_2xxSingle * Big (T2) + Big (T1)); + Lemma_Mult_Distribution (Big (Double_Uns (Q)), + Big_2xxSingle * Big (Double_Uns (Hi (Zu))), + Big (Double_Uns (Lo (Zu)))); + Lemma_Substitution + (Big (Double_Uns (Q)) * Big (Zu), + Big (Double_Uns (Q)), + Big (Zu), + Big_2xxSingle * Big (Double_Uns (Hi (Zu))) + + Big (Double_Uns (Lo (Zu))), + Big_0); pragma Assert (Big (Double_Uns (Q)) * Big (Zu) = Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (Hi (T2))) - + Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (Hi (T3))) - + Big_2xxSingle * Big (Double_Uns (S2)) + + Big_2xxSingle * Big (Double_Uns (Lo (T2))) + + Big_2xxSingle * Big (Double_Uns (Hi (T1))) + Big (Double_Uns (S3))); + Lemma_Add_Commutation (Double_Uns (Lo (T2)), Hi (T1)); + pragma Assert + (By (Big (Double_Uns (Q)) * Big (Zu) = + Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (Hi (T2))) + + Big_2xxSingle * Big (T3) + + Big (Double_Uns (S3)), + Big_2xxSingle * Big (Double_Uns (Lo (T2))) + + Big_2xxSingle * Big (Double_Uns (Hi (T1))) + = Big_2xxSingle * Big (T3))); pragma Assert (Double_Uns (Hi (T3)) + Hi (T2) = Double_Uns (S1)); Lemma_Add_Commutation (Double_Uns (Hi (T3)), Hi (T2)); pragma Assert @@ -2357,20 +2301,6 @@ is Lemma_Mult_Distribution (Big_2xxSingle * Big_2xxSingle, Big (Double_Uns (Hi (T3))), Big (Double_Uns (Hi (T2)))); - pragma Assert - (Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (Hi (T2))) - + Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (Hi (T3))) - = Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (S1))); - pragma Assert (Big (Double_Uns (Q)) * Big (Zu) = - Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (S1)) - + Big_2xxSingle * Big (Double_Uns (S2)) - + Big (Double_Uns (S3))); - pragma Assert - (By (Big (Double_Uns (Q)) * Big (Zu) = Big3 (S1, S2, S3), - Big3 (S1, S2, S3) = - Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (S1)) - + Big_2xxSingle * Big (Double_Uns (S2)) - + Big (Double_Uns (S3)))); end Prove_Multiplication; ------------------------------------- @@ -2492,7 +2422,7 @@ is ---------------------------------------------- procedure Prove_Scaled_Mult_Decomposition_Regroup3 - (D1, D2, D3, D4 : Big_Integer) + (D1, D2, D3, D4 : Single_Uns) is null; ------------------ @@ -2578,58 +2508,25 @@ is Lemma_Abs_Commutation (X); Lemma_Abs_Commutation (Y); Lemma_Mult_Decomposition (Mult, Xu, Yu, Xhi, Xlo, Yhi, Ylo); - pragma Assert - (Is_Mult_Decomposition - (D1 => 0, - D2 => Big (Double_Uns'(Xhi * Yhi)), - D3 => Big (Double_Uns'(Xhi * Ylo)) + Big (Double_Uns'(Xlo * Yhi)), - D4 => Big (Double_Uns'(Xlo * Ylo)))); T1 := Xlo * Ylo; D (4) := Lo (T1); D (3) := Hi (T1); Lemma_Hi_Lo (T1, D (3), D (4)); - pragma Assert - (Is_Mult_Decomposition - (D1 => 0, - D2 => Big (Double_Uns'(Xhi * Yhi)), - D3 => Big (Double_Uns'(Xhi * Ylo)) + Big (Double_Uns'(Xlo * Yhi)) - + Big (Double_Uns (D (3))), - D4 => Big (Double_Uns (D (4))))); if Yhi /= 0 then T1 := Xlo * Yhi; Lemma_Hi_Lo (T1, Hi (T1), Lo (T1)); - pragma Assert - (Is_Mult_Decomposition - (D1 => 0, - D2 => Big (Double_Uns'(Xhi * Yhi)) + Big (Double_Uns (Hi (T1))), - D3 => Big (Double_Uns'(Xhi * Ylo)) + Big (Double_Uns (Lo (T1))) - + Big (Double_Uns (D (3))), - D4 => Big (Double_Uns (D (4))))); T2 := D (3) + Lo (T1); Lemma_Add_Commutation (Double_Uns (Lo (T1)), D (3)); - pragma Assert - (Is_Mult_Decomposition - (D1 => 0, - D2 => Big (Double_Uns'(Xhi * Yhi)) + Big (Double_Uns (Hi (T1))), - D3 => Big (Double_Uns'(Xhi * Ylo)) + Big (T2), - D4 => Big (Double_Uns (D (4))))); Lemma_Mult_Distribution (Big_2xxSingle, Big (Double_Uns (D (3))), Big (Double_Uns (Lo (T1)))); Lemma_Hi_Lo (T2, Hi (T2), Lo (T2)); - pragma Assert - (Is_Mult_Decomposition - (D1 => 0, - D2 => Big (Double_Uns'(Xhi * Yhi)) + Big (Double_Uns (Hi (T1))) - + Big (Double_Uns (Hi (T2))), - D3 => Big (Double_Uns'(Xhi * Ylo)) + Big (Double_Uns (Lo (T2))), - D4 => Big (Double_Uns (D (4))))); D (3) := Lo (T2); D (2) := Hi (T1) + Hi (T2); @@ -2639,30 +2536,11 @@ is pragma Assert (Big (Double_Uns (Hi (T1))) + Big (Double_Uns (Hi (T2))) = Big (Double_Uns (D (2)))); - pragma Assert - (Is_Mult_Decomposition - (D1 => 0, - D2 => Big (Double_Uns'(Xhi * Yhi)) + Big (Double_Uns (D (2))), - D3 => Big (Double_Uns'(Xhi * Ylo)) + Big (Double_Uns (D (3))), - D4 => Big (Double_Uns (D (4))))); if Xhi /= 0 then T1 := Xhi * Ylo; Lemma_Hi_Lo (T1, Hi (T1), Lo (T1)); - pragma Assert - (By (Is_Mult_Decomposition - (D1 => 0, - D2 => Big (Double_Uns'(Xhi * Yhi)) + Big (Double_Uns (D (2))) - + Big (Double_Uns (Hi (T1))), - D3 => Big (Double_Uns (Lo (T1))) + Big (Double_Uns (D (3))), - D4 => Big (Double_Uns (D (4)))), - (By (Big_2xxSingle * Big (T1) = - Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (Hi (T1))) - + Big_2xxSingle * Big (Double_Uns (Lo (T1))), - Big_2xxSingle * Big (T1) = - Big_2xxSingle * (Big_2xxSingle * Big (Double_Uns (Hi (T1))) - + Big (Double_Uns (Lo (T1)))))))); T2 := D (3) + Lo (T1); @@ -2681,75 +2559,18 @@ is T3 := D (2) + Hi (T1); Lemma_Add_Commutation (Double_Uns (D (2)), Hi (T1)); - pragma Assert - (Is_Mult_Decomposition - (D1 => 0, - D2 => Big (Double_Uns'(Xhi * Yhi)) + Big (T3) - + Big (Double_Uns (Hi (T2))), - D3 => Big (Double_Uns (D (3))), - D4 => Big (Double_Uns (D (4))))); Lemma_Add_Commutation (T3, Hi (T2)); T3 := T3 + Hi (T2); T2 := Double_Uns'(Xhi * Yhi); - pragma Assert - (Is_Mult_Decomposition - (D1 => 0, - D2 => Big (T2) + Big (T3), - D3 => Big (Double_Uns (D (3))), - D4 => Big (Double_Uns (D (4))))); Lemma_Hi_Lo (T2, Hi (T2), Lo (T2)); - pragma Assert - (By (Is_Mult_Decomposition - (D1 => Big (Double_Uns (Hi (T2))), - D2 => Big (Double_Uns (Lo (T2))) + Big (T3), - D3 => Big (Double_Uns (D (3))), - D4 => Big (Double_Uns (D (4)))), - By (Big_2xxSingle * Big_2xxSingle * Big (T2) = - Big_2xxSingle * Big_2xxSingle * Big_2xxSingle - * Big (Double_Uns (Hi (T2))) - + Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (Lo (T2))), - Big_2xxSingle * Big_2xxSingle * - (Big_2xxSingle * Big (Double_Uns (Hi (T2))) - + Big (Double_Uns (Lo (T2)))) - = Big_2xxSingle * Big_2xxSingle * Big_2xxSingle - * Big (Double_Uns (Hi (T2))) - + Big_2xxSingle * Big_2xxSingle - * Big (Double_Uns (Lo (T2)))))); T1 := T3 + Lo (T2); D (2) := Lo (T1); Lemma_Add_Commutation (T3, Lo (T2)); - pragma Assert - (Is_Mult_Decomposition - (D1 => Big (Double_Uns (Hi (T2))), - D2 => Big (T1), - D3 => Big (Double_Uns (D (3))), - D4 => Big (Double_Uns (D (4))))); Lemma_Hi_Lo (T1, Hi (T1), Lo (T1)); - pragma Assert - (By (Is_Mult_Decomposition - (D1 => Big (Double_Uns (Hi (T2))) + Big (Double_Uns (Hi (T1))), - D2 => Big (Double_Uns (D (2))), - D3 => Big (Double_Uns (D (3))), - D4 => Big (Double_Uns (D (4)))), - By (Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (Lo (T1))) = - Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (D (2))), - D (2) = Lo (T1)) - and then - By (Big_2xxSingle * Big_2xxSingle * Big (T1) = - Big_2xxSingle * Big_2xxSingle * Big_2xxSingle - * Big (Double_Uns (Hi (T1))) - + Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (Lo (T1))), - Big_2xxSingle * Big_2xxSingle * - (Big_2xxSingle * Big (Double_Uns (Hi (T1))) - + Big (Double_Uns (Lo (T1)))) - = Big_2xxSingle * Big_2xxSingle * Big_2xxSingle - * Big (Double_Uns (Hi (T1))) - + Big_2xxSingle * Big_2xxSingle - * Big (Double_Uns (Lo (T1)))))); D (1) := Hi (T2) + Hi (T1); @@ -2759,75 +2580,42 @@ is pragma Assert (Big (Double_Uns (Hi (T2))) + Big (Double_Uns (Hi (T1))) = Big (Double_Uns (D (1)))); - pragma Assert - (By (Is_Mult_Decomposition - (D1 => Big (Double_Uns (D (1))), - D2 => Big (Double_Uns (D (2))), - D3 => Big (Double_Uns (D (3))), - D4 => Big (Double_Uns (D (4)))), - Big_2xxSingle * Big_2xxSingle * Big_2xxSingle * - Big (Double_Uns (D (1))) - = Big_2xxSingle * Big_2xxSingle * Big_2xxSingle * - (Big (Double_Uns (Hi (T2)) + Double_Uns (Hi (T1)))))); + (Is_Mult_Decomposition (D1 => Big (Double_Uns (D (1))), + D2 => Big (Double_Uns (D (2))), + D3 => Big (Double_Uns (D (3))), + D4 => Big (Double_Uns (D (4))))); else D (1) := 0; pragma Assert - (By (Is_Mult_Decomposition - (D1 => Big (Double_Uns (D (1))), - D2 => Big (Double_Uns (D (2))), - D3 => Big (Double_Uns (D (3))), - D4 => Big (Double_Uns (D (4)))), - Big (Double_Uns'(Xhi * Yhi)) = 0 - and then Big (Double_Uns'(Xhi * Ylo)) = 0 - and then Big (Double_Uns (D (1))) = 0)); + (Is_Mult_Decomposition (D1 => Big (Double_Uns (D (1))), + D2 => Big (Double_Uns (D (2))), + D3 => Big (Double_Uns (D (3))), + D4 => Big (Double_Uns (D (4))))); end if; - pragma Assert - (Is_Mult_Decomposition (D1 => Big (Double_Uns (D (1))), - D2 => Big (Double_Uns (D (2))), - D3 => Big (Double_Uns (D (3))), - D4 => Big (Double_Uns (D (4))))); else - pragma Assert - (By (Is_Mult_Decomposition - (D1 => 0, - D2 => 0, - D3 => Big (Double_Uns'(Xhi * Ylo)) + Big (Double_Uns (D (3))), - D4 => Big (Double_Uns (D (4)))), - Big (Double_Uns'(Xhi * Yhi)) = 0 - and then Big (Double_Uns'(Xlo * Yhi)) = 0)); - if Xhi /= 0 then T1 := Xhi * Ylo; Lemma_Hi_Lo (T1, Hi (T1), Lo (T1)); pragma Assert - (By (Is_Mult_Decomposition + (Is_Mult_Decomposition (D1 => 0, D2 => Big (Double_Uns (Hi (T1))), D3 => Big (Double_Uns (Lo (T1))) + Big (Double_Uns (D (3))), - D4 => Big (Double_Uns (D (4)))), - Big_2xxSingle * Big (Double_Uns'(Xhi * Ylo)) = - Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (Hi (T1))) - + Big_2xxSingle * Big (Double_Uns (Lo (T1))))); + D4 => Big (Double_Uns (D (4))))); T2 := D (3) + Lo (T1); Lemma_Add_Commutation (Double_Uns (Lo (T1)), D (3)); pragma Assert - (By (Is_Mult_Decomposition + (Is_Mult_Decomposition (D1 => 0, D2 => Big (Double_Uns (Hi (T1))), D3 => Big (T2), - D4 => Big (Double_Uns (D (4)))), - Big_2xxSingle * Big (T2) = - Big_2xxSingle * - (Big (Double_Uns (Lo (T1))) + Big (Double_Uns (D (3)))))); - Lemma_Mult_Distribution (Big_2xxSingle, - Big (Double_Uns (D (3))), - Big (Double_Uns (Lo (T1)))); + D4 => Big (Double_Uns (D (4))))); Lemma_Hi_Lo (T2, Hi (T2), Lo (T2)); D (3) := Lo (T2); @@ -2849,22 +2637,42 @@ is D (2) := 0; pragma Assert - (By (Is_Mult_Decomposition + (Is_Mult_Decomposition (D1 => 0, D2 => Big (Double_Uns (D (2))), D3 => Big (Double_Uns (D (3))), - D4 => Big (Double_Uns (D (4)))), - Big (Double_Uns'(Xhi * Ylo)) = 0 - and then Big (Double_Uns (D (2))) = 0)); + D4 => Big (Double_Uns (D (4))))); end if; D (1) := 0; end if; - pragma Assert (Is_Mult_Decomposition (D1 => Big (Double_Uns (D (1))), - D2 => Big (Double_Uns (D (2))), - D3 => Big (Double_Uns (D (3))), - D4 => Big (Double_Uns (D (4))))); + pragma Assert_And_Cut + -- Restate the precondition + (Z /= 0 + and then In_Double_Int_Range + (if Round then Round_Quotient (Big (X) * Big (Y), Big (Z), + Big (X) * Big (Y) / Big (Z), + Big (X) * Big (Y) rem Big (Z)) + else Big (X) * Big (Y) / Big (Z)) + -- Restate the value of local variables + and then Zu = abs Z + and then Zhi = Hi (Zu) + and then Zlo = Lo (Zu) + and then Mult = abs (Big (X) * Big (Y)) + and then Quot = Big (X) * Big (Y) / Big (Z) + and then Big_R = Big (X) * Big (Y) rem Big (Z) + and then + (if Round then + Big_Q = Round_Quotient (Big (X) * Big (Y), Big (Z), Quot, Big_R) + else + Big_Q = Quot) + -- Summarize first part of the procedure + and then D'Initialized + and then Is_Mult_Decomposition (D1 => Big (Double_Uns (D (1))), + D2 => Big (Double_Uns (D (2))), + D3 => Big (Double_Uns (D (3))), + D4 => Big (Double_Uns (D (4))))); -- Now it is time for the dreaded multiple precision division. First an -- easy case, check for the simple case of a one digit divisor. @@ -2872,9 +2680,6 @@ is if Zhi = 0 then if D (1) /= 0 or else D (2) >= Zlo then if D (1) > 0 then - 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))), @@ -2915,6 +2720,8 @@ is elsif (D (1) & D (2)) >= Zu then Lemma_Hi_Lo (D (1) & D (2), D (1), D (2)); Lemma_Ge_Commutation (D (1) & D (2), Zu); + pragma Assert + (Mult >= Big_2xxSingle * Big_2xxSingle * Big (D (1) & D (2))); Prove_Overflow; Raise_Error; @@ -2928,8 +2735,10 @@ is -- First normalize the divisor so that it has the leading bit on. -- We do this by finding the appropriate left shift amount. + Lemma_Hi_Lo (D (1) & D (2), D (1), D (2)); Lemma_Lt_Commutation (D (1) & D (2), Zu); - pragma Assert (Mult < Big_2xxDouble * Big (Zu)); + pragma Assert + (Mult < Big_2xxDouble * Big (Zu)); Shift := Single_Size; Mask := Single_Uns'Last; @@ -3127,7 +2936,8 @@ is Big (D (1) & D (2)), Big_2xxSingle * Big (Double_Uns (D (3))) + Big (Double_Uns (D (4)))); - pragma Assert (Big (D (1) & D (2)) < Big (Zu)); + pragma Assert + (Big (D (1) & D (2)) < Big (Zu)); -- Loop to compute quotient digits, runs twice for Qd (1) and Qd (2) @@ -3152,7 +2962,7 @@ is -- Local ghost variables Qd1 : Single_Uns := 0 with Ghost; - D234 : Big_Integer := 0 with Ghost; + D234 : Big_Integer with Ghost; D123 : constant Big_Integer := Big3 (D (1), D (2), D (3)) with Ghost; D4 : constant Big_Integer := Big (Double_Uns (D (4))) @@ -3160,11 +2970,10 @@ is 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); + (D (1), D (2), D (3), D (4)); + pragma Assert + (By (Mult * Big_2xx (Scale) = Big_2xxSingle * D123 + D4, + Is_Scaled_Mult_Decomposition (0, 0, D123, D4))); for J in 1 .. 2 loop Lemma_Hi_Lo (D (J) & D (J + 1), D (J), D (J + 1)); @@ -3316,26 +3125,9 @@ is Lemma_Mult_Non_Negative (Big_2xxSingle, Big (Double_Uns (D (J + 1)))); pragma Assert - (By (Big3 (D (J), D (J + 1), D (J + 2)) >= + (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 - ))); + * Big (Double_Uns (D (J)))); Lemma_Ge_Commutation (Double_Uns (D (J)), Double_Uns'(1)); Lemma_Ge_Mult (Big (Double_Uns (D (J))), Big (Double_Uns'(1)), @@ -3364,34 +3156,11 @@ is else pragma Assert (Qd1 = Qd (1)); pragma Assert - (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)) = D234 - Big3 (S1, S2, S3))); - pragma Assert - (By (Mult * Big_2xx (Scale) = + (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_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) - )); + + Big (Double_Uns (D (4)))); end if; end loop; end; @@ -3543,12 +3312,6 @@ is Lemma_Add_Commutation (Double_Uns (X1), Y1); Lemma_Add_Commutation (Double_Uns (X2), Y2); Lemma_Add_Commutation (Double_Uns (X3), Y3); - pragma Assert (Double_Uns (Single_Uns'(X1 + Y1)) - = Double_Uns (X1) + Double_Uns (Y1)); - pragma Assert (Double_Uns (Single_Uns'(X2 + Y2)) - = Double_Uns (X2) + Double_Uns (Y2)); - pragma Assert (Double_Uns (Single_Uns'(X3 + Y3)) - = Double_Uns (X3) + Double_Uns (Y3)); end Lemma_Add3_No_Carry; --------------------- diff --git a/gcc/ada/libgnat/s-aridou.ads b/gcc/ada/libgnat/s-aridou.ads index 58aa775..b22f0db 100644 --- a/gcc/ada/libgnat/s-aridou.ads +++ b/gcc/ada/libgnat/s-aridou.ads @@ -77,18 +77,24 @@ is function Big (Arg : Double_Int) return Big_Integer is (Signed_Conversion.To_Big_Integer (Arg)) - with Ghost; + with + Ghost, + Annotate => (GNATprove, Inline_For_Proof); package Unsigned_Conversion is new BI_Ghost.Unsigned_Conversions (Int => Double_Uns); function Big (Arg : Double_Uns) return Big_Integer is (Unsigned_Conversion.To_Big_Integer (Arg)) - with Ghost; + with + Ghost, + Annotate => (GNATprove, Inline_For_Proof); function In_Double_Int_Range (Arg : Big_Integer) return Boolean is (BI_Ghost.In_Range (Arg, Big (Double_Int'First), Big (Double_Int'Last))) - with Ghost; + with + Ghost, + Annotate => (GNATprove, Inline_For_Proof); function Add_With_Ovflo_Check (X, Y : Double_Int) return Double_Int with diff --git a/gcc/ada/libgnat/s-arit32.adb b/gcc/ada/libgnat/s-arit32.adb index bd316c1..d19b9e1 100644 --- a/gcc/ada/libgnat/s-arit32.adb +++ b/gcc/ada/libgnat/s-arit32.adb @@ -104,9 +104,8 @@ is function To_Neg_Int (A : Uns32) return Int32 with - Annotate => (GNATprove, Always_Return), - Pre => In_Int32_Range (-Big (A)), - Post => Big (To_Neg_Int'Result) = -Big (A); + Pre => In_Int32_Range (-Big (A)), + Post => Big (To_Neg_Int'Result) = -Big (A); -- Convert to negative integer equivalent. If the input is in the range -- 0 .. 2**31, then the corresponding nonpositive signed integer (obtained -- by negating the given value) is returned, otherwise constraint error is @@ -114,9 +113,8 @@ is function To_Pos_Int (A : Uns32) return Int32 with - Annotate => (GNATprove, Always_Return), - Pre => In_Int32_Range (Big (A)), - Post => Big (To_Pos_Int'Result) = Big (A); + Pre => In_Int32_Range (Big (A)), + Post => Big (To_Pos_Int'Result) = Big (A); -- Convert to positive integer equivalent. If the input is in the range -- 0 .. 2**31 - 1, then the corresponding nonnegative signed integer is -- returned, otherwise constraint error is raised. @@ -195,12 +193,6 @@ is or else (X >= Big_0 and then Y <= Big_0), Post => X * Y <= Big_0; - procedure Lemma_Neg_Div (X, Y : Big_Integer) - with - Ghost, - Pre => Y /= 0, - Post => X / Y = (-X) / (-Y); - procedure Lemma_Neg_Rem (X, Y : Big_Integer) with Ghost, @@ -223,6 +215,7 @@ is ----------------------------- procedure Lemma_Abs_Commutation (X : Int32) is null; + procedure Lemma_Abs_Div_Commutation (X, Y : Big_Integer) is null; procedure Lemma_Abs_Mult_Commutation (X, Y : Big_Integer) is null; procedure Lemma_Div_Commutation (X, Y : Uns64) is null; procedure Lemma_Div_Ge (X, Y, Z : Big_Integer) is null; @@ -235,22 +228,6 @@ is procedure Lemma_Rem_Commutation (X, Y : Uns64) is null; ------------------------------- - -- Lemma_Abs_Div_Commutation -- - ------------------------------- - - procedure Lemma_Abs_Div_Commutation (X, Y : Big_Integer) is - begin - if Y < 0 then - if X < 0 then - pragma Assert (abs (X / Y) = abs (X / (-Y))); - else - Lemma_Neg_Div (X, Y); - pragma Assert (abs (X / Y) = abs ((-X) / (-Y))); - end if; - end if; - end Lemma_Abs_Div_Commutation; - - ------------------------------- -- Lemma_Abs_Rem_Commutation -- ------------------------------- @@ -277,16 +254,6 @@ is pragma Assert (Uns64 (Xlo) = Xu mod 2 ** 32); end Lemma_Hi_Lo; - ------------------- - -- Lemma_Neg_Div -- - ------------------- - - procedure Lemma_Neg_Div (X, Y : Big_Integer) is - begin - pragma Assert ((-X) / (-Y) = -(X / (-Y))); - pragma Assert (X / (-Y) = -(X / Y)); - end Lemma_Neg_Div; - ----------------- -- Raise_Error -- ----------------- diff --git a/gcc/ada/libgnat/s-atacco.adb b/gcc/ada/libgnat/s-atacco.adb index a98b25c..8c10681 100644 --- a/gcc/ada/libgnat/s-atacco.adb +++ b/gcc/ada/libgnat/s-atacco.adb @@ -29,8 +29,8 @@ -- -- ------------------------------------------------------------------------------ --- This package does not require a body, since it is a package renaming. We --- provide a dummy file containing a No_Body pragma so that previous versions --- of the body (which did exist) will not interfere. +-- This package does not require a body. We provide a dummy file containing a +-- No_Body pragma so that previous versions of the body (which did exist) will +-- not interfere. pragma No_Body; diff --git a/gcc/ada/libgnat/s-atacco.ads b/gcc/ada/libgnat/s-atacco.ads index bd920cc..157ca52 100644 --- a/gcc/ada/libgnat/s-atacco.ads +++ b/gcc/ada/libgnat/s-atacco.ads @@ -55,11 +55,9 @@ package System.Address_To_Access_Conversions is -- of no strict aliasing. function To_Pointer (Value : Address) return Object_Pointer with - Global => null, - Annotate => (GNATprove, Always_Return); + Global => null; function To_Address (Value : Object_Pointer) return Address with - SPARK_Mode => Off, - Annotate => (GNATprove, Always_Return); + SPARK_Mode => Off; pragma Import (Intrinsic, To_Pointer); pragma Import (Intrinsic, To_Address); diff --git a/gcc/ada/libgnat/s-atopri__32.ads b/gcc/ada/libgnat/s-atopri__32.ads new file mode 100644 index 0000000..1281e9b --- /dev/null +++ b/gcc/ada/libgnat/s-atopri__32.ads @@ -0,0 +1,149 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . A T O M I C _ P R I M I T I V E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2012-2023, Free Software Foundation, Inc. -- +-- -- +-- GNAT is 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 both atomic primitives defined from GCC built-in +-- functions and operations used by the compiler to generate the lock-free +-- implementation of protected objects. +-- This is the version that only contains primitives available on 32 bit +-- platforms. + +with Interfaces.C; + +package System.Atomic_Primitives is + pragma Pure; + + type uint is mod 2 ** Long_Integer'Size; + + type uint8 is mod 2**8 + with Size => 8; + + type uint16 is mod 2**16 + with Size => 16; + + type uint32 is mod 2**32 + with Size => 32; + + Relaxed : constant := 0; + Consume : constant := 1; + Acquire : constant := 2; + Release : constant := 3; + Acq_Rel : constant := 4; + Seq_Cst : constant := 5; + Last : constant := 6; + + subtype Mem_Model is Integer range Relaxed .. Last; + + ------------------------------------ + -- GCC built-in atomic primitives -- + ------------------------------------ + + generic + type Atomic_Type is mod <>; + function Atomic_Load + (Ptr : Address; + Model : Mem_Model := Seq_Cst) return Atomic_Type; + pragma Import (Intrinsic, Atomic_Load, "__atomic_load_n"); + + function Atomic_Load_8 is new Atomic_Load (uint8); + function Atomic_Load_16 is new Atomic_Load (uint16); + function Atomic_Load_32 is new Atomic_Load (uint32); + + generic + type Atomic_Type is mod <>; + function Atomic_Compare_Exchange + (Ptr : Address; + Expected : Address; + Desired : Atomic_Type; + Weak : Boolean := False; + Success_Model : Mem_Model := Seq_Cst; + Failure_Model : Mem_Model := Seq_Cst) return Boolean; + pragma Import + (Intrinsic, Atomic_Compare_Exchange, "__atomic_compare_exchange_n"); + + function Atomic_Compare_Exchange_8 is new Atomic_Compare_Exchange (uint8); + function Atomic_Compare_Exchange_16 is new Atomic_Compare_Exchange (uint16); + function Atomic_Compare_Exchange_32 is new Atomic_Compare_Exchange (uint32); + + function Atomic_Test_And_Set + (Ptr : System.Address; + Model : Mem_Model := Seq_Cst) return Boolean; + pragma Import (Intrinsic, Atomic_Test_And_Set, "__atomic_test_and_set"); + + procedure Atomic_Clear + (Ptr : System.Address; + Model : Mem_Model := Seq_Cst); + pragma Import (Intrinsic, Atomic_Clear, "__atomic_clear"); + + function Atomic_Always_Lock_Free + (Size : Interfaces.C.size_t; + Ptr : System.Address := System.Null_Address) return Boolean; + pragma Import + (Intrinsic, Atomic_Always_Lock_Free, "__atomic_always_lock_free"); + + -------------------------- + -- Lock-free operations -- + -------------------------- + + -- The lock-free implementation uses two atomic instructions for the + -- expansion of protected operations: + + -- * Lock_Free_Read atomically loads the value contained in Ptr (with the + -- Acquire synchronization mode). + + -- * Lock_Free_Try_Write atomically tries to write the Desired value into + -- Ptr if Ptr contains the Expected value. It returns true if the value + -- in Ptr was changed, or False if it was not, in which case Expected is + -- updated to the unexpected value in Ptr. Note that it does nothing and + -- returns true if Desired and Expected are equal. + + generic + type Atomic_Type is mod <>; + function Lock_Free_Read (Ptr : Address) return Atomic_Type; + + function Lock_Free_Read_8 is new Lock_Free_Read (uint8); + function Lock_Free_Read_16 is new Lock_Free_Read (uint16); + function Lock_Free_Read_32 is new Lock_Free_Read (uint32); + + generic + type Atomic_Type is mod <>; + function Lock_Free_Try_Write + (Ptr : Address; + Expected : in out Atomic_Type; + Desired : Atomic_Type) return Boolean; + + function Lock_Free_Try_Write_8 is new Lock_Free_Try_Write (uint8); + function Lock_Free_Try_Write_16 is new Lock_Free_Try_Write (uint16); + function Lock_Free_Try_Write_32 is new Lock_Free_Try_Write (uint32); + +private + pragma Inline (Lock_Free_Read); + pragma Inline (Lock_Free_Try_Write); +end System.Atomic_Primitives; diff --git a/gcc/ada/libgnat/s-bituti.adb b/gcc/ada/libgnat/s-bituti.adb index 1b0acc1..28e41f3 100644 --- a/gcc/ada/libgnat/s-bituti.adb +++ b/gcc/ada/libgnat/s-bituti.adb @@ -29,11 +29,13 @@ -- -- ------------------------------------------------------------------------------ +with System.Storage_Elements; use System.Storage_Elements; + package body System.Bitfield_Utils is package body G is - Val_Bytes : constant Address := Address (Val'Size / Storage_Unit); + Val_Bytes : constant Storage_Count := Val'Size / Storage_Unit; -- A Val_2 can cross a memory page boundary (e.g. an 8-byte Val_2 that -- starts 4 bytes before the end of a page). If the bit field also @@ -119,7 +121,7 @@ package body System.Bitfield_Utils is Size : Small_Size) return Val_2 is begin - pragma Assert (Src_Address mod Val'Alignment = 0); + pragma Assert (Src_Address mod Storage_Count'(Val'Alignment) = 0); -- Bit field fits in first half; fetch just one Val. On little -- endian, we want that in the low half, but on big endian, we @@ -154,7 +156,7 @@ package body System.Bitfield_Utils is V : Val_2; Size : Small_Size) is begin - pragma Assert (Dest_Address mod Val'Alignment = 0); + pragma Assert (Dest_Address mod Storage_Count'(Val'Alignment) = 0); -- Comments in Get_Val_2 apply, except we're storing instead of -- fetching. @@ -381,18 +383,19 @@ package body System.Bitfield_Utils is -- Align the Address values as for Val and Val_2, and adjust the -- Bit_Offsets accordingly. - Src_Adjust : constant Address := Src_Address mod Val_Bytes; + Src_Adjust : constant Storage_Offset := Src_Address mod Val_Bytes; Al_Src_Address : constant Address := Src_Address - Src_Adjust; Al_Src_Offset : constant Bit_Offset := Src_Offset + Bit_Offset (Src_Adjust * Storage_Unit); - Dest_Adjust : constant Address := Dest_Address mod Val_Bytes; + Dest_Adjust : constant Storage_Offset := + Dest_Address mod Val_Bytes; Al_Dest_Address : constant Address := Dest_Address - Dest_Adjust; Al_Dest_Offset : constant Bit_Offset := Dest_Offset + Bit_Offset (Dest_Adjust * Storage_Unit); - pragma Assert (Al_Src_Address mod Val'Alignment = 0); - pragma Assert (Al_Dest_Address mod Val'Alignment = 0); + pragma Assert (Al_Src_Address mod Storage_Count'(Val'Alignment) = 0); + pragma Assert (Al_Dest_Address mod Storage_Count'(Val'Alignment) = 0); begin -- Optimized small case diff --git a/gcc/ada/libgnat/s-carun8.adb b/gcc/ada/libgnat/s-carun8.adb index 3a88a9c..b0f2d94b 100644 --- a/gcc/ada/libgnat/s-carun8.adb +++ b/gcc/ada/libgnat/s-carun8.adb @@ -72,7 +72,7 @@ package body System.Compare_Array_Unsigned_8 is begin -- If operands are non-aligned, or length is too short, go by bytes - if (ModA (OrA (Left, Right), 4) /= 0) or else Compare_Len < 4 then + if ModA (OrA (Left, Right), 4) /= 0 or else Compare_Len < 4 then return Compare_Array_U8_Unaligned (Left, Right, Left_Len, Right_Len); end if; diff --git a/gcc/ada/libgnat/s-crtl.ads b/gcc/ada/libgnat/s-crtl.ads index 4b6fc76..c3a3b64 100644 --- a/gcc/ada/libgnat/s-crtl.ads +++ b/gcc/ada/libgnat/s-crtl.ads @@ -55,10 +55,9 @@ package System.CRTL is subtype off_t is Long_Integer; - type size_t is mod 2 ** Standard'Address_Size; + type size_t is mod System.Memory_Size; - type ssize_t is range -(2 ** (Standard'Address_Size - 1)) - .. +(2 ** (Standard'Address_Size - 1)) - 1; + type ssize_t is range -Memory_Size / 2 .. Memory_Size / 2 - 1; type int64 is new Long_Long_Integer; -- Note: we use Long_Long_Integer'First instead of -2 ** 63 to allow this diff --git a/gcc/ada/libgnat/s-dwalin.adb b/gcc/ada/libgnat/s-dwalin.adb index d38bc05..d35d03a 100644 --- a/gcc/ada/libgnat/s-dwalin.adb +++ b/gcc/ada/libgnat/s-dwalin.adb @@ -1542,7 +1542,7 @@ package body System.Dwarf_Lines is exit when Ar_Start = Null_Address and Ar_Len = 0; Len := uint32 (Ar_Len); - Start := uint32 (Address'(Ar_Start - C.Low)); + Start := uint32 (Storage_Count'(Ar_Start - C.Low)); -- Search START in the array @@ -1762,7 +1762,7 @@ package body System.Dwarf_Lines is if C.Cache /= null then declare - Addr_Off : constant uint32 := uint32 (Address'(Addr - C.Low)); + Off : constant uint32 := uint32 (Storage_Count'(Addr - C.Low)); First, Last, Mid : Natural; begin @@ -1772,17 +1772,17 @@ package body System.Dwarf_Lines is while First <= Last loop Mid := First + (Last - First) / 2; - if Addr_Off < C.Cache (Mid).First then + if Off < C.Cache (Mid).First then Last := Mid - 1; - elsif Addr_Off >= C.Cache (Mid).First + C.Cache (Mid).Size then + elsif Off >= C.Cache (Mid).First + C.Cache (Mid).Size then First := Mid + 1; else exit; end if; end loop; - if Addr_Off >= C.Cache (Mid).First - and then Addr_Off < C.Cache (Mid).First + C.Cache (Mid).Size + if Off >= C.Cache (Mid).First + and then Off < C.Cache (Mid).First + C.Cache (Mid).Size then Line_Offset := Offset (C.Cache (Mid).Line); S := Read_Symbol (C.Obj.all, Offset (C.Cache (Mid).Sym)); diff --git a/gcc/ada/libgnat/s-expmod.adb b/gcc/ada/libgnat/s-expmod.adb index 6cf68a5..aa6e9b4 100644 --- a/gcc/ada/libgnat/s-expmod.adb +++ b/gcc/ada/libgnat/s-expmod.adb @@ -109,9 +109,21 @@ is procedure Lemma_Euclidean_Mod (Q, F, R : Big_Natural) with Pre => F /= 0, - Post => (Q * F + R) mod F = R mod F; + Post => (Q * F + R) mod F = R mod F, + Subprogram_Variant => (Decreases => Q); - procedure Lemma_Euclidean_Mod (Q, F, R : Big_Natural) is null; + ------------------------- + -- Lemma_Euclidean_Mod -- + ------------------------- + + procedure Lemma_Euclidean_Mod (Q, F, R : Big_Natural) is + begin + if Q > 0 then + Lemma_Euclidean_Mod (Q - 1, F, R); + end if; + end Lemma_Euclidean_Mod; + + -- Local variables Left : constant Big_Natural := (X + Y) mod B; Right : constant Big_Natural := ((X mod B) + (Y mod B)) mod B; @@ -164,6 +176,9 @@ is Lemma_Mod_Mod (A, B); Lemma_Exp_Mod (A, Exp - 1, B); Lemma_Mult_Mod (A, A ** (Exp - 1), B); + pragma Assert + ((A mod B) * (A mod B) ** (Exp - 1) = (A mod B) ** Exp); + pragma Assert (A * A ** (Exp - 1) = A ** Exp); pragma Assert (Left = Right); end; end if; @@ -190,6 +205,7 @@ is pragma Assert (Left = Right); else pragma Assert (Y mod B = 0); + pragma Assert (Y / B * B = Y); pragma Assert ((X * Y) mod B = (X * Y) - (X * Y) / B * B); pragma Assert ((X * Y) mod B = (X * Y) - (X * (Y / B) * B) / B * B); @@ -309,6 +325,7 @@ is Lemma_Mod_Mod (Rest * Rest, Big (Modulus)); Lemma_Mod_Ident (Big (Result), Big (Modulus)); Lemma_Mult_Mod (Big (Result), Rest * Rest, Big (Modulus)); + pragma Assert (Big (Factor) >= 0); Lemma_Mult_Mod (Big (Result), Big (Factor) ** Exp, Big (Modulus)); pragma Assert (Equal_Modulo diff --git a/gcc/ada/libgnat/s-genbig.adb b/gcc/ada/libgnat/s-genbig.adb index 85dc40b..e1f2e5c 100644 --- a/gcc/ada/libgnat/s-genbig.adb +++ b/gcc/ada/libgnat/s-genbig.adb @@ -49,6 +49,10 @@ package body System.Generic_Bignums is -- Compose double digit value from two single digit values subtype LLI is Long_Long_Integer; + subtype LLLI is Long_Long_Long_Integer; + + LLLI_Is_128 : constant Boolean := Long_Long_Long_Integer'Size = 128; + -- True if Long_Long_Long_Integer is 128-bit large One_Data : constant Digit_Vector (1 .. 1) := [1]; -- Constant one @@ -318,7 +322,7 @@ package body System.Generic_Bignums is elsif X.Len = 1 and then X.D (1) = 1 then return Normalize - (X.D, Neg => X.Neg and then ((Y.D (Y.Len) and 1) = 1)); + (X.D, Neg => X.Neg and then (Y.D (Y.Len) and 1) = 1); -- If the absolute value of the base is greater than 1, then the -- exponent must not be bigger than one word, otherwise the result @@ -694,14 +698,14 @@ package body System.Generic_Bignums is -- Lengths are different, that's decisive since no leading zeroes elsif X'Last /= Y'Last then - return (if (X'Last > Y'Last) xor X_Neg then GT else LT); + return (if X'Last > Y'Last xor X_Neg then GT else LT); -- Need to compare data else for J in X'Range loop if X (J) /= Y (J) then - return (if (X (J) > Y (J)) xor X_Neg then GT else LT); + return (if X (J) > Y (J) xor X_Neg then GT else LT); end if; end loop; @@ -1041,22 +1045,48 @@ package body System.Generic_Bignums is -- From_Bignum -- ----------------- - function From_Bignum (X : Bignum) return Long_Long_Integer is + function From_Bignum (X : Bignum) return Long_Long_Long_Integer is begin if X.Len = 0 then return 0; elsif X.Len = 1 then - return (if X.Neg then -LLI (X.D (1)) else LLI (X.D (1))); + return (if X.Neg then -LLLI (X.D (1)) else LLLI (X.D (1))); elsif X.Len = 2 then declare Mag : constant DD := X.D (1) & X.D (2); begin - if X.Neg and then Mag <= 2 ** 63 then - return -LLI (Mag); - elsif Mag < 2 ** 63 then - return LLI (Mag); + if X.Neg and then (Mag <= 2 ** 63 or else LLLI_Is_128) then + return -LLLI (Mag); + elsif Mag < 2 ** 63 or else LLLI_Is_128 then + return LLLI (Mag); + end if; + end; + + elsif X.Len = 3 and then LLLI_Is_128 then + declare + Hi : constant SD := X.D (1); + Lo : constant DD := X.D (2) & X.D (3); + Mag : constant Unsigned_128 := + Shift_Left (Unsigned_128 (Hi), 64) + Unsigned_128 (Lo); + begin + return (if X.Neg then -LLLI (Mag) else LLLI (Mag)); + end; + + elsif X.Len = 4 and then LLLI_Is_128 then + declare + Hi : constant DD := X.D (1) & X.D (2); + Lo : constant DD := X.D (3) & X.D (4); + Mag : constant Unsigned_128 := + Shift_Left (Unsigned_128 (Hi), 64) + Unsigned_128 (Lo); + begin + if X.Neg + and then (Hi < 2 ** 63 or else (Hi = 2 ** 63 and then Lo = 0)) + then + return -LLLI (Mag); + elsif Hi < 2 ** 63 then + return LLLI (Mag); end if; end; end if; @@ -1064,6 +1094,44 @@ package body System.Generic_Bignums is raise Constraint_Error with "expression value out of range"; end From_Bignum; + function From_Bignum (X : Bignum) return Long_Long_Integer is + begin + return Long_Long_Integer (Long_Long_Long_Integer'(From_Bignum (X))); + end From_Bignum; + + function From_Bignum (X : Bignum) return Unsigned_128 is + begin + if X.Neg then + null; + + elsif X.Len = 0 then + return 0; + + elsif X.Len = 1 then + return Unsigned_128 (X.D (1)); + + elsif X.Len = 2 then + return Unsigned_128 (DD'(X.D (1) & X.D (2))); + + elsif X.Len = 3 and then LLLI_Is_128 then + return + Shift_Left (Unsigned_128 (X.D (1)), 64) + + Unsigned_128 (DD'(X.D (2) & X.D (3))); + + elsif X.Len = 4 and then LLLI_Is_128 then + return + Shift_Left (Unsigned_128 (DD'(X.D (1) & X.D (2))), 64) + + Unsigned_128 (DD'(X.D (3) & X.D (4))); + end if; + + raise Constraint_Error with "expression value out of range"; + end From_Bignum; + + function From_Bignum (X : Bignum) return Unsigned_64 is + begin + return Unsigned_64 (Unsigned_128'(From_Bignum (X))); + end From_Bignum; + ------------------------- -- Bignum_In_LLI_Range -- ------------------------- @@ -1161,29 +1229,27 @@ package body System.Generic_Bignums is elsif X = -2 ** 63 then return Allocate_Big_Integer ([2 ** 31, 0], True); - elsif Long_Long_Long_Integer'Size = 128 - and then X = Long_Long_Long_Integer'First - then + elsif LLLI_Is_128 and then X = Long_Long_Long_Integer'First then return Allocate_Big_Integer ([2 ** 31, 0, 0, 0], True); -- Other negative numbers elsif X < 0 then - if Long_Long_Long_Integer'Size = 64 then + if LLLI_Is_128 then + return Convert_128 (-X, True); + else return Allocate_Big_Integer ((SD ((-X) / Base), SD ((-X) mod Base)), True); - else - return Convert_128 (-X, True); end if; -- Positive numbers else - if Long_Long_Long_Integer'Size = 64 then + if LLLI_Is_128 then + return Convert_128 (X, False); + else return Allocate_Big_Integer ((SD (X / Base), SD (X mod Base)), False); - else - return Convert_128 (X, False); end if; end if; end To_Bignum; @@ -1285,7 +1351,7 @@ package body System.Generic_Bignums is function Image (Arg : Bignum) return String is begin if Big_LT (Arg, Big_Base'Unchecked_Access) then - return [Hex_Chars (Natural (From_Bignum (Arg)))]; + return [Hex_Chars (Natural (LLI'(From_Bignum (Arg))))]; else declare Div : aliased Big_Integer; @@ -1294,7 +1360,7 @@ package body System.Generic_Bignums is begin Div_Rem (Arg, Big_Base'Unchecked_Access, Div, Remain); - R := Natural (From_Bignum (To_Bignum (Remain))); + R := Natural (LLI'(From_Bignum (To_Bignum (Remain)))); Free_Big_Integer (Remain); return S : constant String := diff --git a/gcc/ada/libgnat/s-genbig.ads b/gcc/ada/libgnat/s-genbig.ads index 9cf944c..167f24f 100644 --- a/gcc/ada/libgnat/s-genbig.ads +++ b/gcc/ada/libgnat/s-genbig.ads @@ -117,6 +117,18 @@ package System.Generic_Bignums is -- Convert Bignum to Long_Long_Integer. Constraint_Error raised with -- appropriate message if value is out of range of Long_Long_Integer. + function From_Bignum (X : Bignum) return Long_Long_Long_Integer; + -- Convert Bignum to Long_Long_Long_Integer. Constraint_Error raised with + -- appropriate message if value is out of range of Long_Long_Long_Integer. + + function From_Bignum (X : Bignum) return Interfaces.Unsigned_64; + -- Convert Bignum to Unsigned_64. Constraint_Error raised with + -- appropriate message if value is out of range of Unsigned_64. + + function From_Bignum (X : Bignum) return Interfaces.Unsigned_128; + -- Convert Bignum to Unsigned_128. Constraint_Error raised with + -- appropriate message if value is out of range of Unsigned_128. + function To_String (X : Bignum; Width : Natural := 0; Base : Positive := 10) return String; diff --git a/gcc/ada/libgnat/s-memory.ads b/gcc/ada/libgnat/s-memory.ads index dc431b7..4f6dd3d2 100644 --- a/gcc/ada/libgnat/s-memory.ads +++ b/gcc/ada/libgnat/s-memory.ads @@ -43,7 +43,7 @@ package System.Memory is pragma Elaborate_Body; - type size_t is mod 2 ** Standard'Address_Size; + type size_t is mod Memory_Size; -- Note: the reason we redefine this here instead of using the -- definition in Interfaces.C is that we do not want to drag in -- all of Interfaces.C just because System.Memory is used. diff --git a/gcc/ada/libgnat/s-mmap.adb b/gcc/ada/libgnat/s-mmap.adb index ed4c2bd..abb870e 100644 --- a/gcc/ada/libgnat/s-mmap.adb +++ b/gcc/ada/libgnat/s-mmap.adb @@ -75,7 +75,7 @@ package body System.Mmap is -- Whether this region is actually memory mapped Mutable : Boolean; - -- If the file is opened for reading, wheter this region is writable + -- If the file is opened for reading, whether this region is writable Buffer : System.Strings.String_Access; -- When this region is not actually memory mapped, contains the @@ -284,9 +284,8 @@ package body System.Mmap is if (File.File.Write or else Region.Mutable = Mutable) and then Req_Offset >= Region.System_Offset - and then - (Req_Offset + Req_Length - <= Region.System_Offset + Region.System_Size) + and then Req_Offset + Req_Length <= + Region.System_Offset + Region.System_Size then Region.User_Offset := Req_Offset; Compute_Data (Region); diff --git a/gcc/ada/libgnat/s-parame.adb b/gcc/ada/libgnat/s-parame.adb index 930c92d..6bd9f03 100644 --- a/gcc/ada/libgnat/s-parame.adb +++ b/gcc/ada/libgnat/s-parame.adb @@ -58,6 +58,8 @@ package body System.Parameters is begin if Default_Stack_Size = -1 then return 2 * 1024 * 1024; + elsif Size_Type (Default_Stack_Size) < Minimum_Stack_Size then + return Minimum_Stack_Size; else return Size_Type (Default_Stack_Size); end if; diff --git a/gcc/ada/libgnat/s-parame.ads b/gcc/ada/libgnat/s-parame.ads index 3d6e345..72e7238 100644 --- a/gcc/ada/libgnat/s-parame.ads +++ b/gcc/ada/libgnat/s-parame.ads @@ -53,9 +53,7 @@ package System.Parameters is -- Task And Stack Allocation Control -- --------------------------------------- - type Size_Type is range - -(2 ** (Integer'(Standard'Address_Size) - 1)) .. - +(2 ** (Integer'(Standard'Address_Size) - 1)) - 1; + type Size_Type is range -Memory_Size / 2 .. Memory_Size / 2 - 1; -- Type used to provide task stack sizes to the runtime. Sized to permit -- stack sizes of up to half the total addressable memory space. This may -- seem excessively large (even for 32-bit systems), however there are many diff --git a/gcc/ada/libgnat/s-parame__hpux.ads b/gcc/ada/libgnat/s-parame__hpux.ads index 542131f..243f8c3 100644 --- a/gcc/ada/libgnat/s-parame__hpux.ads +++ b/gcc/ada/libgnat/s-parame__hpux.ads @@ -53,9 +53,7 @@ package System.Parameters is -- Task And Stack Allocation Control -- --------------------------------------- - type Size_Type is range - -(2 ** (Integer'(Standard'Address_Size) - 1)) .. - +(2 ** (Integer'(Standard'Address_Size) - 1)) - 1; + type Size_Type is range -Memory_Size / 2 .. Memory_Size / 2 - 1; -- Type used to provide task stack sizes to the runtime. Sized to permit -- stack sizes of up to half the total addressable memory space. This may -- seem excessively large (even for 32-bit systems), however there are many diff --git a/gcc/ada/libgnat/s-parame__posix2008.ads b/gcc/ada/libgnat/s-parame__posix2008.ads index 4f5d47a..16555e1 100644 --- a/gcc/ada/libgnat/s-parame__posix2008.ads +++ b/gcc/ada/libgnat/s-parame__posix2008.ads @@ -53,9 +53,7 @@ package System.Parameters is -- Task And Stack Allocation Control -- --------------------------------------- - type Size_Type is range - -(2 ** (Integer'(Standard'Address_Size) - 1)) .. - +(2 ** (Integer'(Standard'Address_Size) - 1)) - 1; + type Size_Type is range -Memory_Size / 2 .. Memory_Size / 2 - 1; -- Type used to provide task stack sizes to the runtime. Sized to permit -- stack sizes of up to half the total addressable memory space. This may -- seem excessively large (even for 32-bit systems), however there are many diff --git a/gcc/ada/libgnat/s-parame__qnx.adb b/gcc/ada/libgnat/s-parame__qnx.adb new file mode 100644 index 0000000..d9b46b6 --- /dev/null +++ b/gcc/ada/libgnat/s-parame__qnx.adb @@ -0,0 +1,81 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . P A R A M E T E R S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1995-2023, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the version for AArch64 QNX + +package body System.Parameters is + + ------------------------- + -- Adjust_Storage_Size -- + ------------------------- + + function Adjust_Storage_Size (Size : Size_Type) return Size_Type is + begin + if Size = Unspecified_Size then + return Default_Stack_Size; + elsif Size < Minimum_Stack_Size then + return Minimum_Stack_Size; + else + return Size; + end if; + end Adjust_Storage_Size; + + ------------------------ + -- Default_Stack_Size -- + ------------------------ + + function Default_Stack_Size return Size_Type is + Default_Stack_Size : constant Integer; + pragma Import (C, Default_Stack_Size, "__gl_default_stack_size"); + begin + if Default_Stack_Size = -1 then + -- 256K is the default stack size on aarch64 QNX + return 256 * 1024; + elsif Size_Type (Default_Stack_Size) < Minimum_Stack_Size then + return Minimum_Stack_Size; + else + return Size_Type (Default_Stack_Size); + end if; + end Default_Stack_Size; + + ------------------------ + -- Minimum_Stack_Size -- + ------------------------ + + function Minimum_Stack_Size return Size_Type is + begin + -- 256 is the value of PTHREAD_STACK_MIN on QNX and + -- 12K is required for stack-checking. The value is + -- rounded up to a multiple of a 4K page. + return 16 * 1024; + end Minimum_Stack_Size; + +end System.Parameters; diff --git a/gcc/ada/libgnat/s-parame__rtems.adb b/gcc/ada/libgnat/s-parame__rtems.adb index 2f2e70b..1d51ae9 100644 --- a/gcc/ada/libgnat/s-parame__rtems.adb +++ b/gcc/ada/libgnat/s-parame__rtems.adb @@ -63,6 +63,8 @@ package body System.Parameters is begin if Default_Stack_Size = -1 then return 32 * 1024; + elsif Size_Type (Default_Stack_Size) < Minimum_Stack_Size then + return Minimum_Stack_Size; else return Size_Type (Default_Stack_Size); end if; diff --git a/gcc/ada/libgnat/s-parame__vxworks.adb b/gcc/ada/libgnat/s-parame__vxworks.adb index 8e0768e..38fe022 100644 --- a/gcc/ada/libgnat/s-parame__vxworks.adb +++ b/gcc/ada/libgnat/s-parame__vxworks.adb @@ -58,11 +58,13 @@ package body System.Parameters is begin if Default_Stack_Size = -1 then if Stack_Check_Limits then - return 32 * 1024; -- Extra stack to allow for 12K exception area. + return 32 * 1024; else return 20 * 1024; end if; + elsif Size_Type (Default_Stack_Size) < Minimum_Stack_Size then + return Minimum_Stack_Size; else return Size_Type (Default_Stack_Size); end if; @@ -74,7 +76,12 @@ package body System.Parameters is function Minimum_Stack_Size return Size_Type is begin - return 8 * 1024; + if Stack_Check_Limits then + -- Extra stack to allow for 12K exception area. + return 20 * 1024; + else + return 8 * 1024; + end if; end Minimum_Stack_Size; end System.Parameters; diff --git a/gcc/ada/libgnat/s-parame__vxworks.ads b/gcc/ada/libgnat/s-parame__vxworks.ads index adae27d..6cf32ca 100644 --- a/gcc/ada/libgnat/s-parame__vxworks.ads +++ b/gcc/ada/libgnat/s-parame__vxworks.ads @@ -53,9 +53,7 @@ package System.Parameters is -- Task And Stack Allocation Control -- --------------------------------------- - type Size_Type is range - -(2 ** (Integer'(Standard'Address_Size) - 1)) .. - +(2 ** (Integer'(Standard'Address_Size) - 1)) - 1; + type Size_Type is range -Memory_Size / 2 .. Memory_Size / 2 - 1; -- Type used to provide task stack sizes to the runtime. Sized to permit -- stack sizes of up to half the total addressable memory space. This may -- seem excessively large (even for 32-bit systems), however there are many diff --git a/gcc/ada/libgnat/s-putima.adb b/gcc/ada/libgnat/s-putima.adb index 34d5a03..1d6e608 100644 --- a/gcc/ada/libgnat/s-putima.adb +++ b/gcc/ada/libgnat/s-putima.adb @@ -118,9 +118,8 @@ package body System.Put_Images is (S : in out Sink'Class; X : Long_Long_Long_Unsigned) renames LLL_Integer_Images.Put_Image; - type Signed_Address is range - -2**(Standard'Address_Size - 1) .. 2**(Standard'Address_Size - 1) - 1; - type Unsigned_Address is mod 2**Standard'Address_Size; + type Signed_Address is range -Memory_Size / 2 .. Memory_Size / 2 - 1; + type Unsigned_Address is mod Memory_Size; package Hex is new Generic_Integer_Images (Signed_Address, Unsigned_Address, Base => 16); diff --git a/gcc/ada/libgnat/s-regpat.adb b/gcc/ada/libgnat/s-regpat.adb index 256390f..80f7a8f 100644 --- a/gcc/ada/libgnat/s-regpat.adb +++ b/gcc/ada/libgnat/s-regpat.adb @@ -895,7 +895,7 @@ package body System.Regpat is Flags.SP_Start := Flags.SP_Start or else New_Flags.SP_Start; while Parse_Pos <= Parse_End - and then (E (Parse_Pos) = '|') + and then E (Parse_Pos) = '|' loop Parse_Pos := Parse_Pos + 1; Parse_Branch (New_Flags, False, Br); @@ -979,7 +979,7 @@ package body System.Regpat is C := Expression (Parse_Pos); Parse_Pos := Parse_Pos + 1; - case (C) is + case C is when '^' => IP := Emit_Node diff --git a/gcc/ada/libgnat/s-spcuop.ads b/gcc/ada/libgnat/s-spcuop.ads index daf550b6..642ded7 100644 --- a/gcc/ada/libgnat/s-spcuop.ads +++ b/gcc/ada/libgnat/s-spcuop.ads @@ -45,7 +45,7 @@ package System.SPARK.Cut_Operations with SPARK_Mode, Pure, - Annotate => (GNATprove, Always_Return) + Always_Terminates is function By (Consequence, Premise : Boolean) return Boolean with diff --git a/gcc/ada/libgnat/s-statxd.adb b/gcc/ada/libgnat/s-statxd.adb index dc45ee8..69412b8 100644 --- a/gcc/ada/libgnat/s-statxd.adb +++ b/gcc/ada/libgnat/s-statxd.adb @@ -295,8 +295,8 @@ package body System.Stream_Attributes.XDR is FP : Fat_Pointer; begin - FP.P1 := I_AS (Stream).P1; - FP.P2 := I_AS (Stream).P1; + FP.P1 := I_AS (Stream); + FP.P2 := I_AS (Stream); return FP; end I_AD; @@ -321,7 +321,7 @@ package body System.Stream_Attributes.XDR is U := U * BB + XDR_TM (S (N)); end loop; - return (P1 => To_XDR_SA (XDR_SA (U))); + return To_XDR_SA (XDR_SA (U)); end if; end I_AS; @@ -1181,7 +1181,7 @@ package body System.Stream_Attributes.XDR is procedure W_AS (Stream : not null access RST; Item : Thin_Pointer) is S : XDR_S_TM; - U : XDR_TM := XDR_TM (To_XDR_SA (Item.P1)); + U : XDR_TM := XDR_TM (To_XDR_SA (Item)); begin for N in reverse S'Range loop diff --git a/gcc/ada/libgnat/s-stchop.adb b/gcc/ada/libgnat/s-stchop.adb index 8d8cc60..e0efcef 100644 --- a/gcc/ada/libgnat/s-stchop.adb +++ b/gcc/ada/libgnat/s-stchop.adb @@ -234,11 +234,10 @@ package body System.Stack_Checking.Operations is -- it is essential to use our local copy of Stack. begin - if (Stack_Grows_Down and then - (not (Frame_Address <= My_Stack.Base))) + if (Stack_Grows_Down and then not (Frame_Address <= My_Stack.Base)) or else (not Stack_Grows_Down and then - (not (Frame_Address >= My_Stack.Base))) + not (Frame_Address >= My_Stack.Base)) then -- The returned Base is lower than the stored one, so assume that -- the original one wasn't right and use the current Frame_Address diff --git a/gcc/ada/libgnat/s-stoele.adb b/gcc/ada/libgnat/s-stoele.adb index e029f51..dfd1ba3 100644 --- a/gcc/ada/libgnat/s-stoele.adb +++ b/gcc/ada/libgnat/s-stoele.adb @@ -29,101 +29,8 @@ -- -- ------------------------------------------------------------------------------ -with Ada.Unchecked_Conversion; +-- This package does not require a body. We provide a dummy file containing a +-- No_Body pragma so that previous versions of the body (which did exist) will +-- not interfere. -package body System.Storage_Elements is - - pragma Suppress (All_Checks); - - -- Conversion to/from address - - -- Note qualification below of To_Address to avoid ambiguities systems - -- where Address is a visible integer type. - - function To_Address is - new Ada.Unchecked_Conversion (Storage_Offset, Address); - function To_Offset is - new Ada.Unchecked_Conversion (Address, Storage_Offset); - - -- Conversion to/from integers - - -- These functions must be place first because they are inlined_always - -- and are used and inlined in other subprograms defined in this unit. - - ---------------- - -- To_Address -- - ---------------- - - function To_Address (Value : Integer_Address) return Address is - begin - return Address (Value); - end To_Address; - - ---------------- - -- To_Integer -- - ---------------- - - function To_Integer (Value : Address) return Integer_Address is - begin - return Integer_Address (Value); - end To_Integer; - - -- Address arithmetic - - --------- - -- "+" -- - --------- - - function "+" (Left : Address; Right : Storage_Offset) return Address is - begin - return Storage_Elements.To_Address - (To_Integer (Left) + To_Integer (To_Address (Right))); - end "+"; - - function "+" (Left : Storage_Offset; Right : Address) return Address is - begin - return Storage_Elements.To_Address - (To_Integer (To_Address (Left)) + To_Integer (Right)); - end "+"; - - --------- - -- "-" -- - --------- - - function "-" (Left : Address; Right : Storage_Offset) return Address is - begin - return Storage_Elements.To_Address - (To_Integer (Left) - To_Integer (To_Address (Right))); - end "-"; - - function "-" (Left, Right : Address) return Storage_Offset is - begin - return To_Offset (Storage_Elements.To_Address - (To_Integer (Left) - To_Integer (Right))); - end "-"; - - ----------- - -- "mod" -- - ----------- - - function "mod" - (Left : Address; - Right : Storage_Offset) return Storage_Offset - is - begin - if Right > 0 then - return Storage_Offset - (To_Integer (Left) mod Integer_Address (Right)); - - -- The negative case makes no sense since it is a case of a mod where - -- the left argument is unsigned and the right argument is signed. In - -- accordance with the (spirit of the) permission of RM 13.7.1(16), - -- we raise CE, and also include the zero case here. Yes, the RM says - -- PE, but this really is so obviously more like a constraint error. - - else - raise Constraint_Error; - end if; - end "mod"; - -end System.Storage_Elements; +pragma No_Body; diff --git a/gcc/ada/libgnat/s-stoele.ads b/gcc/ada/libgnat/s-stoele.ads index 9fd31e7..d5d7042 100644 --- a/gcc/ada/libgnat/s-stoele.ads +++ b/gcc/ada/libgnat/s-stoele.ads @@ -37,26 +37,18 @@ -- extra declarations that can be introduced into System using Extend_System. -- It is a good idea to avoid use clauses for this package. -package System.Storage_Elements is +package System.Storage_Elements with + Always_Terminates +is pragma Pure; -- Note that we take advantage of the implementation permission to make -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada 2005, -- this is Pure in any case (AI-362). - pragma Annotate (GNATprove, Always_Return, Storage_Elements); + pragma No_Elaboration_Code_All; + -- Allow the use of that restriction in units that WITH this unit - -- We also add the pragma Pure_Function to the operations in this package, - -- because otherwise functions with parameters derived from Address are - -- treated as non-pure by the back-end (see exp_ch6.adb). This is because - -- in many cases such a parameter is used to hide read/out access to - -- objects, and it would be unsafe to treat such functions as pure. - - type Storage_Offset is range - -(2 ** (Integer'(Standard'Address_Size) - 1)) .. - +(2 ** (Integer'(Standard'Address_Size) - 1)) - Long_Long_Integer'(1); - -- Note: the reason for the Long_Long_Integer qualification here is to - -- avoid a bogus ambiguity when this unit is analyzed in an rtsfind - -- context. + type Storage_Offset is range -Memory_Size / 2 .. Memory_Size / 2 - 1; subtype Storage_Count is Storage_Offset range 0 .. Storage_Offset'Last; @@ -73,44 +65,26 @@ package System.Storage_Elements is -- Address arithmetic function "+" (Left : Address; Right : Storage_Offset) return Address; - pragma Convention (Intrinsic, "+"); - pragma Inline_Always ("+"); - pragma Pure_Function ("+"); - function "+" (Left : Storage_Offset; Right : Address) return Address; - pragma Convention (Intrinsic, "+"); - pragma Inline_Always ("+"); - pragma Pure_Function ("+"); + pragma Import (Intrinsic, "+"); function "-" (Left : Address; Right : Storage_Offset) return Address; - pragma Convention (Intrinsic, "-"); - pragma Inline_Always ("-"); - pragma Pure_Function ("-"); - function "-" (Left, Right : Address) return Storage_Offset; - pragma Convention (Intrinsic, "-"); - pragma Inline_Always ("-"); - pragma Pure_Function ("-"); + pragma Import (Intrinsic, "-"); function "mod" (Left : Address; - Right : Storage_Offset) return Storage_Offset; - pragma Convention (Intrinsic, "mod"); - pragma Inline_Always ("mod"); - pragma Pure_Function ("mod"); + Right : Storage_Offset) return Storage_Offset; + pragma Import (Intrinsic, "mod"); -- Conversion to/from integers type Integer_Address is mod Memory_Size; function To_Address (Value : Integer_Address) return Address; - pragma Convention (Intrinsic, To_Address); - pragma Inline_Always (To_Address); - pragma Pure_Function (To_Address); + pragma Import (Intrinsic, To_Address); function To_Integer (Value : Address) return Integer_Address; - pragma Convention (Intrinsic, To_Integer); - pragma Inline_Always (To_Integer); - pragma Pure_Function (To_Integer); + pragma Import (Intrinsic, To_Integer); end System.Storage_Elements; diff --git a/gcc/ada/libgnat/s-stratt.ads b/gcc/ada/libgnat/s-stratt.ads index e0ddc23..1a3fb60 100644 --- a/gcc/ada/libgnat/s-stratt.ads +++ b/gcc/ada/libgnat/s-stratt.ads @@ -67,9 +67,7 @@ package System.Stream_Attributes is -- (double address) form. The following types are used to hold access -- values using unchecked conversions. - type Thin_Pointer is record - P1 : System.Address; - end record; + subtype Thin_Pointer is System.Address; type Fat_Pointer is record P1 : System.Address; diff --git a/gcc/ada/libgnat/s-strcom.adb b/gcc/ada/libgnat/s-strcom.adb index 59e5698..a2354f3 100644 --- a/gcc/ada/libgnat/s-strcom.adb +++ b/gcc/ada/libgnat/s-strcom.adb @@ -70,7 +70,7 @@ package body System.String_Compare is begin -- If operands are non-aligned, or length is too short, go by bytes - if (((Left or Right) and 2#11#) /= 0) or else Compare_Len < 4 then + if ((Left or Right) and 2#11#) /= 0 or else Compare_Len < 4 then return Str_Compare_Bytes (Left, Right, Left_Len, Right_Len); end if; diff --git a/gcc/ada/libgnat/s-tsmona__linux.adb b/gcc/ada/libgnat/s-tsmona__linux.adb index 7e1b493..6b539f1 100644 --- a/gcc/ada/libgnat/s-tsmona__linux.adb +++ b/gcc/ada/libgnat/s-tsmona__linux.adb @@ -93,23 +93,30 @@ package body Module_Name is pragma Convention (C, link_map_acc); type link_map is record - l_addr : Address; + l_addr : aliased Address; -- Base address of the shared object - l_name : Address; + l_name : aliased Address; -- Null-terminated absolute file name - l_ld : Address; + l_ld : aliased Address; -- Dynamic section - l_next, l_prev : link_map_acc; + l_next, l_prev : aliased link_map_acc; -- Chain end record; pragma Convention (C, link_map); + type r_debug_state is (RT_CONSISTENT, RT_ADD, RT_DELETE); + pragma Convention (C, r_debug_state); + pragma Unreferenced (RT_CONSISTENT, RT_ADD, RT_DELETE); + type r_debug_type is record - r_version : Integer; - r_map : link_map_acc; + r_version : aliased int; + r_map : aliased link_map_acc; + r_brk : aliased Address; + r_state : aliased r_debug_state; + r_ldbase : aliased Address; end record; pragma Convention (C, r_debug_type); diff --git a/gcc/ada/libgnat/s-vaispe.ads b/gcc/ada/libgnat/s-vaispe.ads index 28efced..e74202d7 100644 --- a/gcc/ada/libgnat/s-vaispe.ads +++ b/gcc/ada/libgnat/s-vaispe.ads @@ -62,7 +62,7 @@ generic package System.Value_I_Spec with Ghost, SPARK_Mode, - Annotate => (GNATprove, Always_Return) + Always_Terminates is pragma Preelaborate; use all type Uns_Params.Uns_Option; diff --git a/gcc/ada/libgnat/s-valueu.adb b/gcc/ada/libgnat/s-valueu.adb index c6e26b0..9c77caa 100644 --- a/gcc/ada/libgnat/s-valueu.adb +++ b/gcc/ada/libgnat/s-valueu.adb @@ -29,6 +29,8 @@ -- -- ------------------------------------------------------------------------------ +with System.SPARK.Cut_Operations; use System.SPARK.Cut_Operations; + package body System.Value_U is -- Ghost code, loop invariants and assertions in this unit are meant for @@ -138,10 +140,7 @@ package body System.Value_U is Spec.Scan_Based_Number_Ghost (Str, Ptr.all, Last_Num_Init) with Ghost; Starts_As_Based : constant Boolean := - Last_Num_Init < Max - 1 - and then Str (Last_Num_Init + 1) in '#' | ':' - and then Str (Last_Num_Init + 2) in - '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' + Spec.Raw_Unsigned_Starts_As_Based_Ghost (Str, Last_Num_Init, Max) with Ghost; Last_Num_Based : constant Integer := (if Starts_As_Based @@ -149,9 +148,8 @@ package body System.Value_U is else Last_Num_Init) with Ghost; Is_Based : constant Boolean := - Starts_As_Based - and then Last_Num_Based < Max - and then Str (Last_Num_Based + 1) = Str (Last_Num_Init + 1) + Spec.Raw_Unsigned_Is_Based_Ghost + (Str, Last_Num_Init, Last_Num_Based, Max) with Ghost; Based_Val : constant Spec.Uns_Option := (if Starts_As_Based and then not Init_Val.Overflow @@ -174,6 +172,7 @@ package body System.Value_U is P := Ptr.all; Spec.Lemma_Scan_Based_Number_Ghost_Step (Str, P, Last_Num_Init); Uval := Character'Pos (Str (P)) - Character'Pos ('0'); + pragma Assert (Str (P) in '0' .. '9'); P := P + 1; -- Scan out digits of what is either the number or the base. @@ -215,19 +214,24 @@ package body System.Value_U is -- Accumulate result, checking for overflow else + pragma Assert + (By + (Str (P) in '0' .. '9', + By + (Character'Pos (Str (P)) >= Character'Pos ('0'), + Uns '(Character'Pos (Str (P))) >= + Character'Pos ('0')))); Spec.Lemma_Scan_Based_Number_Ghost_Step (Str, P, Last_Num_Init, Acc => Uval); Spec.Lemma_Scan_Based_Number_Ghost_Overflow (Str, P, Last_Num_Init, Acc => Uval); if Uval <= Umax then - 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)); + (Str, P + 1, Last_Num_Init, Acc => Uval)); elsif Uval > Umax10 then Overflow := True; @@ -241,7 +245,8 @@ package body System.Value_U is pragma Assert (if not Overflow then Init_Val = Spec.Scan_Based_Number_Ghost - (Str, P + 1, Last_Num_Init, Acc => Uval)); + (Str, P + 1, Last_Num_Init, Acc => Uval)); + end if; P := P + 1; @@ -252,7 +257,9 @@ package body System.Value_U is end; pragma Assert_And_Cut - (P = Last_Num_Init + 1 + (By + (P = Last_Num_Init + 1, + P > Max or else Str (P) not in '_' | '0' .. '9') and then Overflow = Init_Val.Overflow and then (if not Overflow then Init_Val.Value = Uval)); @@ -313,13 +320,24 @@ package body System.Value_U is -- already stored in Ptr.all. else + pragma Assert + (By + (Spec.Only_Hexa_Ghost (Str, P, Last_Num_Based), + P > Last_Num_Init + 1 + and Spec.Only_Hexa_Ghost + (Str, Last_Num_Init + 2, Last_Num_Based))); Spec.Lemma_Scan_Based_Number_Ghost_Base (Str, P, Last_Num_Based, Base, Uval); Uval := Base; Base := 10; pragma Assert (Ptr.all = Last_Num_Init + 1); pragma Assert - (if Starts_As_Based then P = Last_Num_Based + 1); + (if Starts_As_Based + then By + (P = Last_Num_Based + 1, + P <= Last_Num_Based + 1 + and Str (P) not in + '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' | '_')); pragma Assert (not Is_Based); pragma Assert (if not Overflow then Uval = Init_Val.Value); exit; @@ -394,11 +412,15 @@ package body System.Value_U is 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 + (By + (Is_Based, + So + (Starts_As_Based, + So + (Last_Num_Based < Max, + Str (Last_Num_Based + 1) = Base_Char + and Base_Char = Str (Last_Num_Init + 1))))); Spec.Lemma_Scan_Based_Number_Ghost_Base (Str, P, Last_Num_Based, Base, Uval); exit; @@ -414,41 +436,40 @@ package body System.Value_U is (if not Overflow 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); + pragma Assert (Str (P) not in '_' | Base_Char); end if; Lemma_Digit_Not_Last (Str, P, Last_Num_Init + 2, Max); - pragma Assert (Str (P) /= '_'); - pragma Assert (Str (P) /= Base_Char); + pragma Assert (Str (P) not in '_' | Base_Char); end loop; end; pragma Assert (if Starts_As_Based then P = Last_Num_Based + 1 else P = Last_Num_Init + 2); pragma Assert - (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)); + (By + (Overflow /= Spec.Scan_Split_No_Overflow_Ghost + (Str, Ptr_Old, Max), + So + (Last_Num_Init < Max - 1 + and then Str (Last_Num_Init + 1) in '#' | ':', + Overflow = + (Init_Val.Overflow + or else Init_Val.Value not in 2 .. 16 + or else (Starts_As_Based and Based_Val.Overflow))))); end if; pragma Assert_And_Cut (Overflow /= Spec.Scan_Split_No_Overflow_Ghost (Str, Ptr_Old, Max) - and then - (if not Overflow then - (if Is_Based then Uval = Based_Val.Value - else Uval = Init_Val.Value)) and then Ptr.all = First_Exp and then Base in 2 .. 16 and then (if not Overflow then - (if Is_Based then Base = Init_Val.Value else Base = 10))); + (if Is_Based then Base = Init_Val.Value else Base = 10)) + and then + (if not Overflow then + (if Is_Based then Uval = Based_Val.Value + else Uval = Init_Val.Value))); -- Come here with scanned unsigned value in Uval. The only remaining -- required step is to deal with exponent if one is present. @@ -456,7 +477,14 @@ package body System.Value_U is Scan_Exponent (Str, Ptr, Max, Expon); pragma Assert - (Ptr.all = Spec.Raw_Unsigned_Last_Ghost (Str, Ptr_Old, Max)); + (By + (Ptr.all = Spec.Raw_Unsigned_Last_Ghost (Str, Ptr_Old, Max), + Ptr.all = + (if not Starts_As_Exponent_Format_Ghost (Str (First_Exp .. Max)) + then First_Exp + elsif Str (First_Exp + 1) in '-' | '+' then + Last_Number_Ghost (Str (First_Exp + 2 .. Max)) + 1 + else Last_Number_Ghost (Str (First_Exp + 1 .. Max)) + 1))); pragma Assert (if not Overflow then Spec.Scan_Split_Value_Ghost (Str, Ptr_Old, Max) = diff --git a/gcc/ada/libgnat/s-valuti.adb b/gcc/ada/libgnat/s-valuti.adb index ec6fdb0..ee37c1a 100644 --- a/gcc/ada/libgnat/s-valuti.adb +++ b/gcc/ada/libgnat/s-valuti.adb @@ -123,6 +123,7 @@ is while F < L and then S (F) = ' ' loop pragma Loop_Invariant (F in S'First .. L - 1); pragma Loop_Invariant (for all J in S'First .. F => S (J) = ' '); + pragma Loop_Variant (Increases => F); F := F + 1; end loop; @@ -139,6 +140,7 @@ is while S (L) = ' ' loop pragma Loop_Invariant (L in F + 1 .. S'Last); pragma Loop_Invariant (for all J in L .. S'Last => S (J) = ' '); + pragma Loop_Variant (Decreases => L); L := L - 1; end loop; diff --git a/gcc/ada/libgnat/s-valuti.ads b/gcc/ada/libgnat/s-valuti.ads index 1faa647..22d0612 100644 --- a/gcc/ada/libgnat/s-valuti.ads +++ b/gcc/ada/libgnat/s-valuti.ads @@ -51,7 +51,8 @@ is procedure Bad_Value (S : String) with - Depends => (null => S); + Depends => (null => S), + Exceptional_Cases => (others => Standard.False); pragma No_Return (Bad_Value); -- Raises constraint error with message: bad input for 'Value: "xxx" diff --git a/gcc/ada/libgnat/s-vauspe.ads b/gcc/ada/libgnat/s-vauspe.ads index 25a095b..bdd97b5 100644 --- a/gcc/ada/libgnat/s-vauspe.ads +++ b/gcc/ada/libgnat/s-vauspe.ads @@ -53,7 +53,7 @@ generic package System.Value_U_Spec with Ghost, SPARK_Mode, - Annotate => (GNATprove, Always_Return) + Always_Terminates is pragma Preelaborate; @@ -279,24 +279,50 @@ is Exponent_Unsigned_Ghost (Value * Base, Exp - 1, Base)); -- Normal case: exponentiation without overflows + function Raw_Unsigned_Starts_As_Based_Ghost + (Str : String; + Last_Num_Init, To : Integer) + return Boolean + is + (Last_Num_Init < To - 1 + and then Str (Last_Num_Init + 1) in '#' | ':' + and then Str (Last_Num_Init + 2) in + '0' .. '9' | 'a' .. 'f' | 'A' .. 'F') + with Ghost, + Pre => Last_Num_Init in Str'Range + and then To in Str'Range; + -- Return True if Str starts as a based number + + function Raw_Unsigned_Is_Based_Ghost + (Str : String; + Last_Num_Init : Integer; + Last_Num_Based : Integer; + To : Integer) + return Boolean + is + (Raw_Unsigned_Starts_As_Based_Ghost (Str, Last_Num_Init, To) + and then Last_Num_Based < To + and then Str (Last_Num_Based + 1) = Str (Last_Num_Init + 1)) + with Ghost, + Pre => Last_Num_Init in Str'Range + and then Last_Num_Based in Last_Num_Init .. Str'Last + and then To in Str'Range; + -- Return True if Str is a based number + function Is_Raw_Unsigned_Format_Ghost (Str : String) return Boolean is (Is_Natural_Format_Ghost (Str) and then (declare Last_Num_Init : constant Integer := Last_Number_Ghost (Str); Starts_As_Based : constant Boolean := - 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'; + Raw_Unsigned_Starts_As_Based_Ghost (Str, Last_Num_Init, Str'Last); Last_Num_Based : constant Integer := (if Starts_As_Based then Last_Hexa_Ghost (Str (Last_Num_Init + 2 .. Str'Last)) else Last_Num_Init); Is_Based : constant Boolean := - Starts_As_Based - and then Last_Num_Based < Str'Last - and then Str (Last_Num_Based + 1) = Str (Last_Num_Init + 1); + Raw_Unsigned_Is_Based_Ghost + (Str, Last_Num_Init, Last_Num_Based, Str'Last); First_Exp : constant Integer := (if Is_Based then Last_Num_Based + 2 else Last_Num_Init + 1); begin @@ -330,10 +356,7 @@ is 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'; + Raw_Unsigned_Starts_As_Based_Ghost (Str, Last_Num_Init, To); Last_Num_Based : constant Integer := (if Starts_As_Based then Last_Hexa_Ghost (Str (Last_Num_Init + 2 .. To)) @@ -378,18 +401,13 @@ is 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'; + Raw_Unsigned_Starts_As_Based_Ghost (Str, Last_Num_Init, To); Last_Num_Based : constant Integer := (if Starts_As_Based then Last_Hexa_Ghost (Str (Last_Num_Init + 2 .. To)) else Last_Num_Init); Is_Based : constant Boolean := - Starts_As_Based - and then Last_Num_Based < To - and then Str (Last_Num_Based + 1) = Str (Last_Num_Init + 1); + Raw_Unsigned_Is_Based_Ghost (Str, Last_Num_Init, Last_Num_Based, To); Based_Val : constant Uns_Option := (if Starts_As_Based and then not Init_Val.Overflow then Scan_Based_Number_Ghost @@ -468,18 +486,13 @@ is 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'; + Raw_Unsigned_Starts_As_Based_Ghost (Str, Last_Num_Init, To); Last_Num_Based : constant Integer := (if Starts_As_Based then Last_Hexa_Ghost (Str (Last_Num_Init + 2 .. To)) else Last_Num_Init); Is_Based : constant Boolean := - Starts_As_Based - and then Last_Num_Based < To - and then Str (Last_Num_Based + 1) = Str (Last_Num_Init + 1); + Raw_Unsigned_Is_Based_Ghost (Str, Last_Num_Init, Last_Num_Based, To); First_Exp : constant Integer := (if Is_Based then Last_Num_Based + 2 else Last_Num_Init + 1); begin @@ -492,7 +505,8 @@ is 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 Str (From) in '0' .. '9', + Post => Raw_Unsigned_Last_Ghost'Result >= From; -- Ghost function that returns the position of the cursor once an unsigned -- number has been seen. diff --git a/gcc/ada/libgnat/s-widthi.adb b/gcc/ada/libgnat/s-widthi.adb index bdd1bfb..7f04e22 100644 --- a/gcc/ada/libgnat/s-widthi.adb +++ b/gcc/ada/libgnat/s-widthi.adb @@ -166,9 +166,9 @@ begin end loop; declare - F : constant Big_Integer := Big_10 ** (W - 2) with Ghost; - Q : constant Big_Integer := Big (T_Init) / F with Ghost; - R : constant Big_Integer := Big (T_Init) rem F with Ghost; + F : constant Big_Positive := Big_10 ** (W - 2) with Ghost; + Q : constant Big_Natural := Big (T_Init) / F with Ghost; + R : constant Big_Natural := Big (T_Init) rem F with Ghost; begin pragma Assert (Q < Big_10); pragma Assert (Big (T_Init) = Q * F + R); diff --git a/gcc/ada/libgnat/system-aix.ads b/gcc/ada/libgnat/system-aix.ads index 18ed063..1485df4 100644 --- a/gcc/ada/libgnat/system-aix.ads +++ b/gcc/ada/libgnat/system-aix.ads @@ -116,6 +116,8 @@ package System is private type Address is mod Memory_Size; + for Address'Size use Standard'Address_Size; + Null_Address : constant Address := 0; -------------------------------------- diff --git a/gcc/ada/libgnat/system-darwin-arm.ads b/gcc/ada/libgnat/system-darwin-arm.ads index 4e4603b..a57bf0b 100644 --- a/gcc/ada/libgnat/system-darwin-arm.ads +++ b/gcc/ada/libgnat/system-darwin-arm.ads @@ -132,6 +132,8 @@ package System is private type Address is mod Memory_Size; + for Address'Size use Standard'Address_Size; + Null_Address : constant Address := 0; -------------------------------------- diff --git a/gcc/ada/libgnat/system-darwin-ppc.ads b/gcc/ada/libgnat/system-darwin-ppc.ads index 80c28c5..b6e73fd 100644 --- a/gcc/ada/libgnat/system-darwin-ppc.ads +++ b/gcc/ada/libgnat/system-darwin-ppc.ads @@ -132,6 +132,8 @@ package System is private type Address is mod Memory_Size; + for Address'Size use Standard'Address_Size; + Null_Address : constant Address := 0; -------------------------------------- diff --git a/gcc/ada/libgnat/system-darwin-x86.ads b/gcc/ada/libgnat/system-darwin-x86.ads index dc52576..994b22f 100644 --- a/gcc/ada/libgnat/system-darwin-x86.ads +++ b/gcc/ada/libgnat/system-darwin-x86.ads @@ -132,6 +132,8 @@ package System is private type Address is mod Memory_Size; + for Address'Size use Standard'Address_Size; + Null_Address : constant Address := 0; -------------------------------------- diff --git a/gcc/ada/libgnat/system-djgpp.ads b/gcc/ada/libgnat/system-djgpp.ads index 2addbfe..459475e 100644 --- a/gcc/ada/libgnat/system-djgpp.ads +++ b/gcc/ada/libgnat/system-djgpp.ads @@ -106,6 +106,8 @@ package System is private type Address is mod Memory_Size; + for Address'Size use Standard'Address_Size; + Null_Address : constant Address := 0; -------------------------------------- diff --git a/gcc/ada/libgnat/system-dragonfly-x86_64.ads b/gcc/ada/libgnat/system-dragonfly-x86_64.ads index 0e8e0ee5..6b16156 100644 --- a/gcc/ada/libgnat/system-dragonfly-x86_64.ads +++ b/gcc/ada/libgnat/system-dragonfly-x86_64.ads @@ -106,6 +106,8 @@ package System is private type Address is mod Memory_Size; + for Address'Size use Standard'Address_Size; + Null_Address : constant Address := 0; -------------------------------------- diff --git a/gcc/ada/libgnat/system-freebsd.ads b/gcc/ada/libgnat/system-freebsd.ads index 23bb9a7..32c1cc4 100644 --- a/gcc/ada/libgnat/system-freebsd.ads +++ b/gcc/ada/libgnat/system-freebsd.ads @@ -107,6 +107,8 @@ package System is private type Address is mod Memory_Size; + for Address'Size use Standard'Address_Size; + Null_Address : constant Address := 0; -------------------------------------- diff --git a/gcc/ada/libgnat/system-hpux-ia64.ads b/gcc/ada/libgnat/system-hpux-ia64.ads index 991ff9e..8eb4a8f 100644 --- a/gcc/ada/libgnat/system-hpux-ia64.ads +++ b/gcc/ada/libgnat/system-hpux-ia64.ads @@ -106,6 +106,8 @@ package System is private type Address is mod Memory_Size; + for Address'Size use Standard'Address_Size; + Null_Address : constant Address := 0; -------------------------------------- diff --git a/gcc/ada/libgnat/system-hpux.ads b/gcc/ada/libgnat/system-hpux.ads index 30e0293..4c5eb3e 100644 --- a/gcc/ada/libgnat/system-hpux.ads +++ b/gcc/ada/libgnat/system-hpux.ads @@ -106,6 +106,8 @@ package System is private type Address is mod Memory_Size; + for Address'Size use Standard'Address_Size; + Null_Address : constant Address := 0; -------------------------------------- diff --git a/gcc/ada/libgnat/system-linux-alpha.ads b/gcc/ada/libgnat/system-linux-alpha.ads index 021a9aa..86fcea3 100644 --- a/gcc/ada/libgnat/system-linux-alpha.ads +++ b/gcc/ada/libgnat/system-linux-alpha.ads @@ -106,6 +106,8 @@ package System is private type Address is mod Memory_Size; + for Address'Size use Standard'Address_Size; + Null_Address : constant Address := 0; -------------------------------------- diff --git a/gcc/ada/libgnat/system-linux-arm.ads b/gcc/ada/libgnat/system-linux-arm.ads index 0c94244..724086c 100644 --- a/gcc/ada/libgnat/system-linux-arm.ads +++ b/gcc/ada/libgnat/system-linux-arm.ads @@ -115,6 +115,8 @@ package System is private type Address is mod Memory_Size; + for Address'Size use Standard'Address_Size; + Null_Address : constant Address := 0; -------------------------------------- diff --git a/gcc/ada/libgnat/system-linux-hppa.ads b/gcc/ada/libgnat/system-linux-hppa.ads index 41a8d3f..148b6f0 100644 --- a/gcc/ada/libgnat/system-linux-hppa.ads +++ b/gcc/ada/libgnat/system-linux-hppa.ads @@ -106,6 +106,8 @@ package System is private type Address is mod Memory_Size; + for Address'Size use Standard'Address_Size; + Null_Address : constant Address := 0; -------------------------------------- diff --git a/gcc/ada/libgnat/system-linux-ia64.ads b/gcc/ada/libgnat/system-linux-ia64.ads index a788eb2..d332820 100644 --- a/gcc/ada/libgnat/system-linux-ia64.ads +++ b/gcc/ada/libgnat/system-linux-ia64.ads @@ -114,6 +114,8 @@ package System is private type Address is mod Memory_Size; + for Address'Size use Standard'Address_Size; + Null_Address : constant Address := 0; -------------------------------------- diff --git a/gcc/ada/libgnat/system-linux-m68k.ads b/gcc/ada/libgnat/system-linux-m68k.ads index 669428b..9db322b 100644 --- a/gcc/ada/libgnat/system-linux-m68k.ads +++ b/gcc/ada/libgnat/system-linux-m68k.ads @@ -116,6 +116,8 @@ package System is private type Address is mod Memory_Size; + for Address'Size use Standard'Address_Size; + Null_Address : constant Address := 0; -------------------------------------- diff --git a/gcc/ada/libgnat/system-linux-mips.ads b/gcc/ada/libgnat/system-linux-mips.ads index a40a0d2..929e54b 100644 --- a/gcc/ada/libgnat/system-linux-mips.ads +++ b/gcc/ada/libgnat/system-linux-mips.ads @@ -107,6 +107,8 @@ package System is private type Address is mod Memory_Size; + for Address'Size use Standard'Address_Size; + Null_Address : constant Address := 0; -------------------------------------- diff --git a/gcc/ada/libgnat/system-linux-ppc.ads b/gcc/ada/libgnat/system-linux-ppc.ads index a24d616..1358bf9 100644 --- a/gcc/ada/libgnat/system-linux-ppc.ads +++ b/gcc/ada/libgnat/system-linux-ppc.ads @@ -115,6 +115,8 @@ package System is private type Address is mod Memory_Size; + for Address'Size use Standard'Address_Size; + Null_Address : constant Address := 0; -------------------------------------- @@ -142,6 +144,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_Composite_Assign : constant Boolean := True; Support_Composite_Compare : constant Boolean := True; Support_Long_Shifts : constant Boolean := True; diff --git a/gcc/ada/libgnat/system-linux-riscv.ads b/gcc/ada/libgnat/system-linux-riscv.ads index 8f8f6e6..420a502 100644 --- a/gcc/ada/libgnat/system-linux-riscv.ads +++ b/gcc/ada/libgnat/system-linux-riscv.ads @@ -106,6 +106,8 @@ package System is private type Address is mod Memory_Size; + for Address'Size use Standard'Address_Size; + Null_Address : constant Address := 0; -------------------------------------- diff --git a/gcc/ada/libgnat/system-linux-s390.ads b/gcc/ada/libgnat/system-linux-s390.ads index dee2424..f53c43f 100644 --- a/gcc/ada/libgnat/system-linux-s390.ads +++ b/gcc/ada/libgnat/system-linux-s390.ads @@ -106,6 +106,8 @@ package System is private type Address is mod Memory_Size; + for Address'Size use Standard'Address_Size; + Null_Address : constant Address := 0; -------------------------------------- diff --git a/gcc/ada/libgnat/system-linux-sh4.ads b/gcc/ada/libgnat/system-linux-sh4.ads index 52c67b6..4970b28 100644 --- a/gcc/ada/libgnat/system-linux-sh4.ads +++ b/gcc/ada/libgnat/system-linux-sh4.ads @@ -114,6 +114,8 @@ package System is private type Address is mod Memory_Size; + for Address'Size use Standard'Address_Size; + Null_Address : constant Address := 0; -------------------------------------- diff --git a/gcc/ada/libgnat/system-linux-sparc.ads b/gcc/ada/libgnat/system-linux-sparc.ads index 4b4978b..a319664 100644 --- a/gcc/ada/libgnat/system-linux-sparc.ads +++ b/gcc/ada/libgnat/system-linux-sparc.ads @@ -106,6 +106,8 @@ package System is private type Address is mod Memory_Size; + for Address'Size use Standard'Address_Size; + Null_Address : constant Address := 0; -------------------------------------- diff --git a/gcc/ada/libgnat/system-linux-x86.ads b/gcc/ada/libgnat/system-linux-x86.ads index ec17297..85538d6 100644 --- a/gcc/ada/libgnat/system-linux-x86.ads +++ b/gcc/ada/libgnat/system-linux-x86.ads @@ -114,6 +114,8 @@ package System is private type Address is mod Memory_Size; + for Address'Size use Standard'Address_Size; + Null_Address : constant Address := 0; -------------------------------------- diff --git a/gcc/ada/libgnat/system-lynxos178-ppc.ads b/gcc/ada/libgnat/system-lynxos178-ppc.ads index 75f17b2..a0ef4118 100644 --- a/gcc/ada/libgnat/system-lynxos178-ppc.ads +++ b/gcc/ada/libgnat/system-lynxos178-ppc.ads @@ -121,6 +121,8 @@ package System is private type Address is mod Memory_Size; + for Address'Size use Standard'Address_Size; + Null_Address : constant Address := 0; -------------------------------------- diff --git a/gcc/ada/libgnat/system-lynxos178-x86.ads b/gcc/ada/libgnat/system-lynxos178-x86.ads index 0f4caea..8c8a61e 100644 --- a/gcc/ada/libgnat/system-lynxos178-x86.ads +++ b/gcc/ada/libgnat/system-lynxos178-x86.ads @@ -121,6 +121,8 @@ package System is private type Address is mod Memory_Size; + for Address'Size use Standard'Address_Size; + Null_Address : constant Address := 0; -------------------------------------- diff --git a/gcc/ada/libgnat/system-mingw.ads b/gcc/ada/libgnat/system-mingw.ads index af1cb20..4b5a7ce 100644 --- a/gcc/ada/libgnat/system-mingw.ads +++ b/gcc/ada/libgnat/system-mingw.ads @@ -106,6 +106,8 @@ package System is private type Address is mod Memory_Size; + for Address'Size use Standard'Address_Size; + Null_Address : constant Address := 0; -------------------------------------- diff --git a/gcc/ada/libgnat/system-qnx-arm.ads b/gcc/ada/libgnat/system-qnx-arm.ads index e834399..1dd1a22 100644 --- a/gcc/ada/libgnat/system-qnx-arm.ads +++ b/gcc/ada/libgnat/system-qnx-arm.ads @@ -95,26 +95,26 @@ package System is -- Priority-related Declarations (RM D.1) - -- System priority is Ada priority + 1, so lies in the range 1 .. 63. - -- -- If the scheduling policy is SCHED_FIFO or SCHED_RR the runtime makes use -- of the entire range provided by the system. -- -- If the scheduling policy is SCHED_OTHER the only valid system priority -- is 1 and other values are simply ignored. - Max_Priority : constant Positive := 61; - Max_Interrupt_Priority : constant Positive := 62; + Max_Priority : constant Positive := 62; + Max_Interrupt_Priority : constant Positive := 63; - subtype Any_Priority is Integer range 0 .. 62; - subtype Priority is Any_Priority range 0 .. 61; - subtype Interrupt_Priority is Any_Priority range 62 .. 62; + subtype Any_Priority is Integer range 1 .. 63; + subtype Priority is Any_Priority range 1 .. 62; + subtype Interrupt_Priority is Any_Priority range 63 .. 63; - Default_Priority : constant Priority := 30; + Default_Priority : constant Priority := 10; private type Address is mod Memory_Size; + for Address'Size use Standard'Address_Size; + Null_Address : constant Address := 0; -------------------------------------- diff --git a/gcc/ada/libgnat/system-rtems.ads b/gcc/ada/libgnat/system-rtems.ads index 6518ada..2dc2d81 100644 --- a/gcc/ada/libgnat/system-rtems.ads +++ b/gcc/ada/libgnat/system-rtems.ads @@ -123,6 +123,8 @@ package System is private type Address is mod Memory_Size; + for Address'Size use Standard'Address_Size; + Null_Address : constant Address := 0; -------------------------------------- diff --git a/gcc/ada/libgnat/system-solaris-sparc.ads b/gcc/ada/libgnat/system-solaris-sparc.ads index e667cd5..7bd8460 100644 --- a/gcc/ada/libgnat/system-solaris-sparc.ads +++ b/gcc/ada/libgnat/system-solaris-sparc.ads @@ -106,6 +106,8 @@ package System is private type Address is mod Memory_Size; + for Address'Size use Standard'Address_Size; + Null_Address : constant Address := 0; -------------------------------------- diff --git a/gcc/ada/libgnat/system-solaris-x86.ads b/gcc/ada/libgnat/system-solaris-x86.ads index b1a2733..6077668 100644 --- a/gcc/ada/libgnat/system-solaris-x86.ads +++ b/gcc/ada/libgnat/system-solaris-x86.ads @@ -106,6 +106,8 @@ package System is private type Address is mod Memory_Size; + for Address'Size use Standard'Address_Size; + Null_Address : constant Address := 0; -------------------------------------- diff --git a/gcc/ada/libgnat/system-vxworks-ppc-kernel.ads b/gcc/ada/libgnat/system-vxworks-ppc-kernel.ads index e57b195..f12dc6e 100644 --- a/gcc/ada/libgnat/system-vxworks-ppc-kernel.ads +++ b/gcc/ada/libgnat/system-vxworks-ppc-kernel.ads @@ -119,6 +119,8 @@ package System is private type Address is mod Memory_Size; + for Address'Size use Standard'Address_Size; + Null_Address : constant Address := 0; -------------------------------------- diff --git a/gcc/ada/libgnat/system-vxworks-ppc-rtp-smp.ads b/gcc/ada/libgnat/system-vxworks-ppc-rtp-smp.ads index ff7c0e6..d8c498f 100644 --- a/gcc/ada/libgnat/system-vxworks-ppc-rtp-smp.ads +++ b/gcc/ada/libgnat/system-vxworks-ppc-rtp-smp.ads @@ -125,6 +125,8 @@ private -- Setup proper set of -L's for this configuration type Address is mod Memory_Size; + for Address'Size use Standard'Address_Size; + Null_Address : constant Address := 0; -------------------------------------- diff --git a/gcc/ada/libgnat/system-vxworks-ppc-rtp.ads b/gcc/ada/libgnat/system-vxworks-ppc-rtp.ads index deb7f5f..3a3d336 100644 --- a/gcc/ada/libgnat/system-vxworks-ppc-rtp.ads +++ b/gcc/ada/libgnat/system-vxworks-ppc-rtp.ads @@ -124,6 +124,8 @@ private -- Setup proper set of -L's for this configuration type Address is mod Memory_Size; + for Address'Size use Standard'Address_Size; + Null_Address : constant Address := 0; -------------------------------------- diff --git a/gcc/ada/libgnat/system-vxworks7-aarch64-rtp-smp.ads b/gcc/ada/libgnat/system-vxworks7-aarch64-rtp-smp.ads index 3df8b7b..0a7886b 100644 --- a/gcc/ada/libgnat/system-vxworks7-aarch64-rtp-smp.ads +++ b/gcc/ada/libgnat/system-vxworks7-aarch64-rtp-smp.ads @@ -124,6 +124,8 @@ private -- Define the symbol wrs_rtp_base type Address is mod Memory_Size; + for Address'Size use Standard'Address_Size; + Null_Address : constant Address := 0; -------------------------------------- diff --git a/gcc/ada/libgnat/system-vxworks7-aarch64.ads b/gcc/ada/libgnat/system-vxworks7-aarch64.ads index 103e9497..811fac1 100644 --- a/gcc/ada/libgnat/system-vxworks7-aarch64.ads +++ b/gcc/ada/libgnat/system-vxworks7-aarch64.ads @@ -121,6 +121,8 @@ package System is private type Address is mod Memory_Size; + for Address'Size use Standard'Address_Size; + Null_Address : constant Address := 0; -------------------------------------- diff --git a/gcc/ada/libgnat/system-vxworks7-arm-rtp-smp.ads b/gcc/ada/libgnat/system-vxworks7-arm-rtp-smp.ads index fae23b1..abdc200 100644 --- a/gcc/ada/libgnat/system-vxworks7-arm-rtp-smp.ads +++ b/gcc/ada/libgnat/system-vxworks7-arm-rtp-smp.ads @@ -121,6 +121,8 @@ package System is private type Address is mod Memory_Size; + for Address'Size use Standard'Address_Size; + Null_Address : constant Address := 0; -------------------------------------- diff --git a/gcc/ada/libgnat/system-vxworks7-arm.ads b/gcc/ada/libgnat/system-vxworks7-arm.ads index 2fa7ed8..0e5e3e6 100644 --- a/gcc/ada/libgnat/system-vxworks7-arm.ads +++ b/gcc/ada/libgnat/system-vxworks7-arm.ads @@ -119,6 +119,8 @@ package System is private type Address is mod Memory_Size; + for Address'Size use Standard'Address_Size; + Null_Address : constant Address := 0; -------------------------------------- diff --git a/gcc/ada/libgnat/system-vxworks7-ppc-kernel.ads b/gcc/ada/libgnat/system-vxworks7-ppc-kernel.ads index ed250e5..bbf6d98 100644 --- a/gcc/ada/libgnat/system-vxworks7-ppc-kernel.ads +++ b/gcc/ada/libgnat/system-vxworks7-ppc-kernel.ads @@ -119,6 +119,8 @@ package System is private type Address is mod Memory_Size; + for Address'Size use Standard'Address_Size; + Null_Address : constant Address := 0; -------------------------------------- @@ -146,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 := False; + Support_Atomic_Primitives : constant Boolean := True; 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-ppc-rtp-smp.ads b/gcc/ada/libgnat/system-vxworks7-ppc-rtp-smp.ads index 503c326..de1e10d 100644 --- a/gcc/ada/libgnat/system-vxworks7-ppc-rtp-smp.ads +++ b/gcc/ada/libgnat/system-vxworks7-ppc-rtp-smp.ads @@ -124,6 +124,8 @@ private -- Define the symbol wrs_rtp_base type Address is mod Memory_Size; + for Address'Size use Standard'Address_Size; + Null_Address : constant Address := 0; -------------------------------------- @@ -151,7 +153,7 @@ private Stack_Check_Probes : constant Boolean := True; Stack_Check_Limits : constant Boolean := False; Support_Aggregates : constant Boolean := True; - Support_Atomic_Primitives : constant Boolean := False; + Support_Atomic_Primitives : constant Boolean := True; 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-ppc64-kernel.ads b/gcc/ada/libgnat/system-vxworks7-ppc64-kernel.ads index 1d5d592..f4f1af5 100644 --- a/gcc/ada/libgnat/system-vxworks7-ppc64-kernel.ads +++ b/gcc/ada/libgnat/system-vxworks7-ppc64-kernel.ads @@ -121,6 +121,8 @@ package System is private type Address is mod Memory_Size; + for Address'Size use Standard'Address_Size; + Null_Address : constant Address := 0; -------------------------------------- diff --git a/gcc/ada/libgnat/system-vxworks7-ppc64-rtp-smp.ads b/gcc/ada/libgnat/system-vxworks7-ppc64-rtp-smp.ads index b55f289..4868891 100644 --- a/gcc/ada/libgnat/system-vxworks7-ppc64-rtp-smp.ads +++ b/gcc/ada/libgnat/system-vxworks7-ppc64-rtp-smp.ads @@ -124,6 +124,8 @@ private -- Define the symbol wrs_rtp_base type Address is mod Memory_Size; + for Address'Size use Standard'Address_Size; + Null_Address : constant Address := 0; -------------------------------------- diff --git a/gcc/ada/libgnat/system-vxworks7-x86-kernel.ads b/gcc/ada/libgnat/system-vxworks7-x86-kernel.ads index 4710098..e60e122 100644 --- a/gcc/ada/libgnat/system-vxworks7-x86-kernel.ads +++ b/gcc/ada/libgnat/system-vxworks7-x86-kernel.ads @@ -119,6 +119,8 @@ package System is private type Address is mod Memory_Size; + for Address'Size use Standard'Address_Size; + Null_Address : constant Address := 0; -------------------------------------- diff --git a/gcc/ada/libgnat/system-vxworks7-x86-rtp-smp.ads b/gcc/ada/libgnat/system-vxworks7-x86-rtp-smp.ads index 867e39f..b8a25a3 100644 --- a/gcc/ada/libgnat/system-vxworks7-x86-rtp-smp.ads +++ b/gcc/ada/libgnat/system-vxworks7-x86-rtp-smp.ads @@ -122,6 +122,8 @@ private -- Define the symbol wrs_rtp_base type Address is mod Memory_Size; + for Address'Size use Standard'Address_Size; + Null_Address : constant Address := 0; -------------------------------------- diff --git a/gcc/ada/libgnat/system-vxworks7-x86_64-kernel.ads b/gcc/ada/libgnat/system-vxworks7-x86_64-kernel.ads index dc00937..273529f 100644 --- a/gcc/ada/libgnat/system-vxworks7-x86_64-kernel.ads +++ b/gcc/ada/libgnat/system-vxworks7-x86_64-kernel.ads @@ -119,6 +119,8 @@ package System is private type Address is mod Memory_Size; + for Address'Size use Standard'Address_Size; + Null_Address : constant Address := 0; -------------------------------------- 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 501ee72..a2ea30a 100644 --- a/gcc/ada/libgnat/system-vxworks7-x86_64-rtp-smp.ads +++ b/gcc/ada/libgnat/system-vxworks7-x86_64-rtp-smp.ads @@ -122,6 +122,8 @@ private -- Define the symbol wrs_rtp_base type Address is mod Memory_Size; + for Address'Size use Standard'Address_Size; + Null_Address : constant Address := 0; -------------------------------------- diff --git a/gcc/ada/live.adb b/gcc/ada/live.adb index 9b38d51..f7057db 100644 --- a/gcc/ada/live.adb +++ b/gcc/ada/live.adb @@ -344,7 +344,7 @@ package body Live is end if; when N_Entity'Range => - if (Ekind (N) = E_Component) and then not Marked (Marks, N) then + if Ekind (N) = E_Component and then not Marked (Marks, N) then if Present (Discriminant_Checking_Func (N)) then Process (Discriminant_Checking_Func (N)); end if; diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads index 7e5919d..87399c8 100644 --- a/gcc/ada/opt.ads +++ b/gcc/ada/opt.ads @@ -81,8 +81,13 @@ package Opt is -- so that tests like Ada_Version >= Ada_95 are legitimate and useful. -- Think twice before using "="; Ada_Version >= Ada_2012 is more likely -- what you want, because it will apply to future versions of the language. + -- -- Note that Ada_With_All_Extensions should always be last since it should - -- always be a superset of the other Ada versions. + -- always be a superset of the other Ada versions. Likewise, the + -- penultimate one should be Ada_With_Core_Extensions. + -- + -- Use the ..._Extensions_Allowed functions below instead of referring + -- directly to Ada_With_..._Extensions. -- WARNING: There is a matching C declaration of this type in fe.h @@ -100,6 +105,16 @@ package Opt is -- WARNING: There is a matching C declaration of this variable in fe.h + function All_Extensions_Allowed return Boolean is + (Ada_Version = Ada_With_All_Extensions); + -- True if GNAT specific language extensions are allowed. See GNAT RM for + -- details. + + function Core_Extensions_Allowed return Boolean is + (Ada_Version >= Ada_With_Core_Extensions); + -- True if some but not all GNAT specific language extensions are allowed. + -- See GNAT RM for details. + Ada_Version_Pragma : Node_Id := Empty; -- Reflects the Ada_xxx pragma that resulted in setting Ada_Version. Used -- to specialize error messages complaining about the Ada version in use. @@ -594,16 +609,6 @@ package Opt is -- Set to True to convert nonbinary modular additions into code -- that relies on the front-end expansion of operator Mod. - function All_Extensions_Allowed return Boolean is - (Ada_Version = Ada_With_All_Extensions); - -- True if GNAT specific language extensions are allowed. See GNAT RM for - -- details. - - function Core_Extensions_Allowed return Boolean is - (Ada_Version >= Ada_With_Core_Extensions); - -- True if some but not all GNAT specific language extensions are allowed. - -- See GNAT RM for details. - type External_Casing_Type is ( As_Is, -- External names cased as they appear in the Ada source Uppercase, -- External names forced to all uppercase letters @@ -1337,6 +1342,11 @@ package Opt is -- GNATPREP -- Set to True if -C switch used. + Reverse_Bit_Order_Threshold : Int := -1; + -- GNAT + -- Set to the threshold from which the RM 13.5.1(13.3/2) clause applies, + -- or -1 if the size of the largest machine scalar is to be used. + RTS_Lib_Path_Name : String_Ptr := null; RTS_Src_Path_Name : String_Ptr := null; -- GNAT diff --git a/gcc/ada/par-ch2.adb b/gcc/ada/par-ch2.adb index b85e397..af92f5a 100644 --- a/gcc/ada/par-ch2.adb +++ b/gcc/ada/par-ch2.adb @@ -225,6 +225,7 @@ package body Ch2 is function P_Interpolated_String_Literal return Node_Id is Elements_List : constant List_Id := New_List; NL_Node : Node_Id; + Saved_State : constant Boolean := Inside_Interpolated_String_Literal; String_Node : Node_Id; begin @@ -245,9 +246,17 @@ package body Ch2 is -- Interpolated expression if Token = Tok_Left_Curly_Bracket then - Scan; -- past '{' - Append_To (Elements_List, P_Expression); - T_Right_Curly_Bracket; + declare + Saved_In_Expr : constant Boolean := + Inside_Interpolated_String_Expression; + + begin + Scan; -- past '{' + Inside_Interpolated_String_Expression := True; + Append_To (Elements_List, P_Expression); + Inside_Interpolated_String_Expression := Saved_In_Expr; + T_Right_Curly_Bracket; + end; else if Prev_Token = Tok_String_Literal then NL_Node := New_Node (N_String_Literal, Token_Ptr); @@ -266,7 +275,7 @@ package body Ch2 is end loop; end if; - Inside_Interpolated_String_Literal := False; + Inside_Interpolated_String_Literal := Saved_State; Set_Expressions (String_Node, Elements_List); return String_Node; @@ -371,7 +380,7 @@ package body Ch2 is if SIS_Entry_Active then Import_Check_Required := - (Prag_Name = Name_Import) or else (Prag_Name = Name_Interface); + Prag_Name = Name_Import or else Prag_Name = Name_Interface; else Import_Check_Required := False; end if; diff --git a/gcc/ada/par-ch3.adb b/gcc/ada/par-ch3.adb index b763d41..fddb1d9 100644 --- a/gcc/ada/par-ch3.adb +++ b/gcc/ada/par-ch3.adb @@ -1466,7 +1466,7 @@ package body Ch3 is Save_Scan_State (Scan_State); -- at colon T_Colon; - -- If we have identifier followed by := then we assume that what is + -- If we have an identifier followed by := then we assume that what is -- really meant is an assignment statement. The assignment statement -- is scanned out and added to the list of declarations. An exception -- occurs if the := is followed by the keyword constant, in which case @@ -3064,10 +3064,25 @@ package body Ch3 is elsif Token = Tok_Dot_Dot then Range_Node := New_Node (N_Range, Token_Ptr); Set_Low_Bound (Range_Node, Expr_Node); + + if Style_Check then + Style.Check_Xtra_Parens (Expr_Node); + end if; + Scan; -- past .. Expr_Node := P_Expression; Check_Simple_Expression (Expr_Node); Set_High_Bound (Range_Node, Expr_Node); + + -- If Expr_Node (ignoring parentheses) is not a simple expression + -- then emit a style check. + + if Style_Check + and then Nkind (Expr_Node) not in N_Op_Boolean | N_Subexpr + then + Style.Check_Xtra_Parens (Expr_Node); + end if; + return Range_Node; -- Otherwise we must have a subtype mark, or an Ada 2012 iterator diff --git a/gcc/ada/par-ch4.adb b/gcc/ada/par-ch4.adb index 2505eb6..52f2b02 100644 --- a/gcc/ada/par-ch4.adb +++ b/gcc/ada/par-ch4.adb @@ -34,17 +34,17 @@ package body Ch4 is -- Attributes that cannot have arguments - Is_Parameterless_Attribute : constant Attribute_Class_Array := - (Attribute_Base => True, - Attribute_Body_Version => True, - Attribute_Class => True, - Attribute_External_Tag => True, - Attribute_Img => True, - Attribute_Loop_Entry => True, - Attribute_Old => True, - Attribute_Result => True, - Attribute_Stub_Type => True, - Attribute_Version => True, + Is_Parameterless_Attribute : constant Attribute_Set := + (Attribute_Base | + Attribute_Body_Version | + Attribute_Class | + Attribute_External_Tag | + Attribute_Img | + Attribute_Loop_Entry | + Attribute_Old | + Attribute_Result | + Attribute_Stub_Type | + Attribute_Version | Attribute_Type_Key => True, others => False); -- This map contains True for parameterless attributes that return a string diff --git a/gcc/ada/par-ch5.adb b/gcc/ada/par-ch5.adb index 418547b..bbade15 100644 --- a/gcc/ada/par-ch5.adb +++ b/gcc/ada/par-ch5.adb @@ -1196,7 +1196,7 @@ package body Ch5 is and then Start_Column /= Scopes (Scope.Last).Ecol then Error_Msg_Col := Scopes (Scope.Last).Ecol; - Error_Msg_SC ("(style) this token should be@"); + Error_Msg_SC ("(style) this token should be@?l?"); end if; end Check_If_Column; @@ -1355,22 +1355,11 @@ package body Ch5 is return Cond; - -- Otherwise check for redundant parentheses but do not emit messages - -- about expressions that require parentheses (e.g. conditional, - -- quantified or declaration expressions). + -- Otherwise check for redundant parentheses else - if Style_Check - and then - Paren_Count (Cond) > - (if Nkind (Cond) in N_Case_Expression - | N_Expression_With_Actions - | N_If_Expression - | N_Quantified_Expression - then 1 - else 0) - then - Style.Check_Xtra_Parens (First_Sloc (Cond)); + if Style_Check then + Style.Check_Xtra_Parens (Cond); end if; -- And return the result @@ -1395,6 +1384,7 @@ package body Ch5 is function P_Case_Statement return Node_Id is Case_Node : Node_Id; + Expr : Node_Id; Alternatives_List : List_Id; First_When_Loc : Source_Ptr; @@ -1409,7 +1399,14 @@ package body Ch5 is Scopes (Scope.Last).Node := Case_Node; Scan; -- past CASE - Set_Expression (Case_Node, P_Expression_No_Right_Paren); + + Expr := P_Expression_No_Right_Paren; + + if Style_Check then + Style.Check_Xtra_Parens (Expr); + end if; + + Set_Expression (Case_Node, Expr); TF_Is; -- Prepare to parse case statement alternatives @@ -2206,7 +2203,7 @@ package body Ch5 is and then Token_Is_At_Start_Of_Line and then Start_Column /= Error_Msg_Col then - Error_Msg_SC ("(style) BEGIN in wrong column, should be@"); + Error_Msg_SC ("(style) BEGIN in wrong column, should be@?l?"); else Scopes (Scope.Last).Ecol := Start_Column; @@ -2244,7 +2241,7 @@ package body Ch5 is -- END, EOF, or a token which starts declarations. elsif Parent_Nkind = N_Package_Body - and then (Token in Tok_End | Tok_EOF | Token_Class_Declk) + and then Token in Tok_End | Tok_EOF | Token_Class_Declk then Set_Null_HSS (Parent); diff --git a/gcc/ada/par-ch6.adb b/gcc/ada/par-ch6.adb index 2de8cee9..3171c5c 100644 --- a/gcc/ada/par-ch6.adb +++ b/gcc/ada/par-ch6.adb @@ -1713,7 +1713,7 @@ package body Ch6 is if Style.Mode_In_Check and then Token /= Tok_Out then Error_Msg_SP -- CODEFIX - ("(style) IN should be omitted"); + ("(style) IN should be omitted?I?"); end if; -- Since Ada 2005, formal objects can have an anonymous access type, diff --git a/gcc/ada/par-ch7.adb b/gcc/ada/par-ch7.adb index ae02298..fc96ce8 100644 --- a/gcc/ada/par-ch7.adb +++ b/gcc/ada/par-ch7.adb @@ -162,9 +162,7 @@ package body Ch7 is -- Move the aspect specifications to the body node - if Has_Aspects (Dummy_Node) then - Move_Aspects (From => Dummy_Node, To => Package_Node); - end if; + Move_Aspects (From => Dummy_Node, To => Package_Node); Parse_Decls_Begin_End (Package_Node); end if; @@ -261,7 +259,7 @@ package body Ch7 is and then Start_Column /= Error_Msg_Col then Error_Msg_SC - ("(style) PRIVATE in wrong column, should be@"); + ("(style) PRIVATE in wrong column, should be@?l?"); end if; end if; diff --git a/gcc/ada/par-ch9.adb b/gcc/ada/par-ch9.adb index 752b28b..d6526de 100644 --- a/gcc/ada/par-ch9.adb +++ b/gcc/ada/par-ch9.adb @@ -140,9 +140,7 @@ package body Ch9 is -- Move the aspect specifications to the body node - if Has_Aspects (Dummy_Node) then - Move_Aspects (From => Dummy_Node, To => Task_Node); - end if; + Move_Aspects (From => Dummy_Node, To => Task_Node); Parse_Decls_Begin_End (Task_Node); diff --git a/gcc/ada/par-endh.adb b/gcc/ada/par-endh.adb index 5ca5004..45cf22a 100644 --- a/gcc/ada/par-endh.adb +++ b/gcc/ada/par-endh.adb @@ -820,9 +820,9 @@ package body Endh is -- Cases where a label is definitely allowed on the END line elsif End_Type = E_Name then - Syntax_OK := (not Explicit_Start_Label (SS_Index)) + Syntax_OK := not Explicit_Start_Label (SS_Index) or else - (not Scopes (SS_Index).Lreq); + not Scopes (SS_Index).Lreq; -- Otherwise we have cases which don't allow labels anyway, so we -- certainly accept an END which does not have a label. @@ -1131,7 +1131,7 @@ package body Endh is then Error_Msg_Col := Scopes (Scope.Last).Ecol; Error_Msg - ("(style) END in wrong column, should be@", End_Sloc); + ("(style) END in wrong column, should be@?l?", End_Sloc); end if; end if; @@ -1164,11 +1164,11 @@ package body Endh is and then (Scope.Last = 1 or else - (not Explicit_Start_Label (Scope.Last - 1)) + not Explicit_Start_Label (Scope.Last - 1) or else - (not Same_Label - (End_Labl, - Scopes (Scope.Last - 1).Labl))) + not Same_Label + (End_Labl, + Scopes (Scope.Last - 1).Labl)) then T_Semicolon; Error_Msg ("duplicate end line ignored", End_Loc); diff --git a/gcc/ada/par-prag.adb b/gcc/ada/par-prag.adb index 3a9764a..b139862 100644 --- a/gcc/ada/par-prag.adb +++ b/gcc/ada/par-prag.adb @@ -120,7 +120,7 @@ function Prag (Pragma_Node : Node_Id; Semi : Source_Ptr) return Node_Id is procedure Add_List_Pragma_Entry (PT : List_Pragma_Type; Loc : Source_Ptr) is begin if List_Pragmas.Last < List_Pragmas.First - or else (List_Pragmas.Table (List_Pragmas.Last)) /= ((PT, Loc)) + or else List_Pragmas.Table (List_Pragmas.Last) /= (PT, Loc) then List_Pragmas.Append ((PT, Loc)); end if; @@ -176,7 +176,7 @@ function Prag (Pragma_Node : Node_Id; Semi : Source_Ptr) return Node_Id is Error : Boolean := Nkind (Expression (Arg)) /= N_Identifier; begin if not Error then - Error := (Chars (Argx) not in Name_On | Name_Off) + Error := Chars (Argx) not in Name_On | Name_Off and then not (All_OK_Too and Chars (Argx) = Name_All); end if; if Error then @@ -1150,13 +1150,14 @@ begin ------------------------------------- function First_Arg_Is_Matching_Tool_Name return Boolean is + Expr : constant Node_Id := Get_Pragma_Arg (Arg1); begin - return Nkind (Arg1) = N_Identifier + return Nkind (Expr) = N_Identifier -- Return True if the tool name is GNAT, and we're not in -- GNATprove or CodePeer mode... - and then ((Chars (Arg1) = Name_Gnat + and then ((Chars (Expr) = Name_Gnat and then not (CodePeer_Mode or GNATprove_Mode)) @@ -1164,7 +1165,7 @@ begin -- mode. or else - (Chars (Arg1) = Name_Gnatprove + (Chars (Expr) = Name_Gnatprove and then GNATprove_Mode)); end First_Arg_Is_Matching_Tool_Name; @@ -1189,7 +1190,7 @@ begin -------------- function Last_Arg return Node_Id is - Last_Arg : Node_Id; + Last_Arg : Node_Id; begin if Arg_Count = 1 then @@ -1314,6 +1315,7 @@ begin | Pragma_Aggregate_Individually_Assign | Pragma_All_Calls_Remote | Pragma_Allow_Integer_Address + | Pragma_Always_Terminates | Pragma_Annotate | Pragma_Assert | Pragma_Assert_And_Cut @@ -1370,6 +1372,7 @@ begin | Pragma_Elaboration_Checks | Pragma_Eliminate | Pragma_Enable_Atomic_Synchronization + | Pragma_Exceptional_Cases | Pragma_Export | Pragma_Export_Function | Pragma_Export_Object diff --git a/gcc/ada/par-util.adb b/gcc/ada/par-util.adb index b1085c8..fc44ddf 100644 --- a/gcc/ada/par-util.adb +++ b/gcc/ada/par-util.adb @@ -165,7 +165,7 @@ package body Util is and then Start_Column <= Scopes (Scope.Last).Ecol then Error_Msg_BC -- CODEFIX - ("(style) incorrect layout"); + ("(style) incorrect layout?l?"); end if; end Check_Bad_Layout; @@ -713,7 +713,7 @@ package body Util is and then Scope.Last = Style_Max_Nesting_Level + 1 then Error_Msg - ("(style) maximum nesting level exceeded", + ("(style) maximum nesting level exceeded?L?", First_Non_Blank_Location); end if; diff --git a/gcc/ada/pprint.adb b/gcc/ada/pprint.adb index 8cc9244..3843ec2 100644 --- a/gcc/ada/pprint.adb +++ b/gcc/ada/pprint.adb @@ -27,6 +27,7 @@ with Atree; use Atree; with Einfo; use Einfo; with Einfo.Entities; use Einfo.Entities; with Einfo.Utils; use Einfo.Utils; +with Errout; use Errout; with Namet; use Namet; with Nlists; use Nlists; with Opt; use Opt; @@ -53,13 +54,6 @@ package body Pprint is (Expr : Node_Id; Default : String) return String is - From_Source : constant Boolean := - Comes_From_Source (Expr) - and then not Opt.Debug_Generated_Code; - Append_Paren : Natural := 0; - Left : Node_Id := Original_Node (Expr); - Right : Node_Id := Original_Node (Expr); - function Expr_Name (Expr : Node_Id; Take_Prefix : Boolean := True; @@ -70,8 +64,24 @@ package body Pprint is -- Expand_Type is True and Expr is a type, try to expand Expr (an -- internally generated type) into a user understandable name. - Max_List : constant := 3; - -- Limit number of list elements to dump + function Count_Parentheses (S : String; C : Character) return Natural + with Pre => C in '(' | ')'; + -- Returns the number of times parenthesis character C should be added + -- to string S for getting a correctly parenthesized result. For C = '(' + -- this means prepending the character, for C = ')' this means appending + -- the character. + + function Fix_Parentheses (S : String) return String; + -- Counts the number of required opening and closing parentheses in S to + -- respectively prepend and append for getting correct parentheses. Then + -- returns S with opening parentheses prepended and closing parentheses + -- appended so that the result is correctly parenthesized. + + Max_List_Depth : constant := 3; + -- Limit number of nested lists to print + + Max_List_Length : constant := 3; + -- Limit number of list elements to print Max_Expr_Elements : constant := 24; -- Limit number of elements in an expression for use by Expr_Name @@ -79,94 +89,82 @@ package body Pprint is Num_Elements : Natural := 0; -- Current number of elements processed by Expr_Name - function List_Name - (List : Node_Id; - Add_Space : Boolean := True; - Add_Paren : Boolean := True) return String; + function List_Name (List : List_Id) return String; -- Return a string corresponding to List --------------- -- List_Name -- --------------- - function List_Name - (List : Node_Id; - Add_Space : Boolean := True; - Add_Paren : Boolean := True) return String - is - function Internal_List_Name - (List : Node_Id; - First : Boolean := True; - Add_Space : Boolean := True; - Add_Paren : Boolean := True; - Num : Natural := 1) return String; - -- Created for purposes of recursing on embedded lists - - ------------------------ - -- Internal_List_Name -- - ------------------------ - - function Internal_List_Name - (List : Node_Id; - First : Boolean := True; - Add_Space : Boolean := True; - Add_Paren : Boolean := True; - Num : Natural := 1) return String - is - begin - if No (List) then - if First or else not Add_Paren then - return ""; - else - return ")"; - end if; - elsif Num > Max_List then - if Add_Paren then - return ", ...)"; - else - return ", ..."; - end if; - end if; + function List_Name (List : List_Id) return String is + Buf : Bounded_String; + Elmt : Node_Id; - -- Continue recursing on the list - handling the first element - -- in a special way. - - return - (if First then - (if Add_Space and Add_Paren then " (" - elsif Add_Paren then "(" - elsif Add_Space then " " - else "") - else ", ") - & Expr_Name (List) - & Internal_List_Name - (List => Next (List), - First => False, - Add_Paren => Add_Paren, - Num => Num + 1); - end Internal_List_Name; - - -- Start of processing for List_Name + Printed_Elmts : Natural := 0; begin - -- Prevent infinite recursion by limiting depth to 3 + -- Give up if the printed list is too deep - if List_Name_Count > 3 then + if List_Name_Count > Max_List_Depth then return "..."; end if; List_Name_Count := List_Name_Count + 1; - declare - Result : constant String := - Internal_List_Name - (List => List, - Add_Space => Add_Space, - Add_Paren => Add_Paren); - begin - List_Name_Count := List_Name_Count - 1; - return Result; - end; + Elmt := First (List); + while Present (Elmt) loop + + -- Print component_association as "x | y | z => 12345" + + if Nkind (Elmt) = N_Component_Association then + declare + Choice : Node_Id := First (Choices (Elmt)); + begin + while Present (Choice) loop + Append (Buf, Expr_Name (Choice)); + Next (Choice); + + if Present (Choice) then + Append (Buf, " | "); + end if; + end loop; + end; + Append (Buf, " => "); + Append (Buf, Expr_Name (Expression (Elmt))); + + -- Print parameter_association as "x => 12345" + + elsif Nkind (Elmt) = N_Parameter_Association then + Append (Buf, Expr_Name (Selector_Name (Elmt))); + Append (Buf, " => "); + Append (Buf, Expr_Name (Explicit_Actual_Parameter (Elmt))); + + -- Print expression itself as "12345" + + else + Append (Buf, Expr_Name (Elmt)); + end if; + + Next (Elmt); + Printed_Elmts := Printed_Elmts + 1; + + -- Separate next element with a comma, if necessary + + if Present (Elmt) then + Append (Buf, ", "); + + -- Abbreviate remaining elements as "...", if limit exceeded + + if Printed_Elmts = Max_List_Length then + Append (Buf, "..."); + exit; + end if; + end if; + end loop; + + List_Name_Count := List_Name_Count - 1; + + return To_String (Buf); end List_Name; --------------- @@ -185,17 +183,44 @@ package body Pprint is return "..."; end if; - case Nkind (Expr) is - when N_Defining_Identifier - | N_Identifier - => + -- Just print pieces of aggregate nodes, even though they are not + -- expressions. It is too much trouble to handle them any better. + + if Nkind (Expr) = N_Component_Association then + + pragma Assert (Box_Present (Expr)); + + declare + Buf : Bounded_String; + Choice : Node_Id := First (Choices (Expr)); + begin + while Present (Choice) loop + Append (Buf, Expr_Name (Choice)); + Next (Choice); + + if Present (Choice) then + Append (Buf, " | "); + end if; + end loop; + + Append (Buf, " => <>"); + + return To_String (Buf); + end; + + elsif Nkind (Expr) = N_Others_Choice then + return "others"; + end if; + + case N_Subexpr'(Nkind (Expr)) is + when N_Identifier => return Ident_Image (Expr, Expression_Image.Expr, Expand_Type); when N_Character_Literal => declare Char : constant Int := UI_To_Int (Char_Literal_Value (Expr)); begin - if Char in 32 .. 127 then + if Char in 32 .. 126 then return "'" & Character'Val (Char) & "'"; else UI_Image (Char_Literal_Value (Expr)); @@ -218,10 +243,7 @@ package body Pprint is when N_Aggregate => if Present (Expressions (Expr)) then - return - List_Name - (List => First (Expressions (Expr)), - Add_Space => False); + return '(' & List_Name (Expressions (Expr)) & ')'; -- Do not return empty string for (others => <>) aggregate -- of a componentless record type. At least one caller (the @@ -234,19 +256,12 @@ package body Pprint is return ("(null record)"); else - return - List_Name - (List => First (Component_Associations (Expr)), - Add_Space => False, - Add_Paren => False); + return '(' & List_Name (Component_Associations (Expr)) & ')'; end if; when N_Extension_Aggregate => - return "(" & Expr_Name (Ancestor_Part (Expr)) & " with " - & List_Name - (List => First (Expressions (Expr)), - Add_Space => False, - Add_Paren => False) & ")"; + return '(' & Expr_Name (Ancestor_Part (Expr)) + & " with (" & List_Name (Expressions (Expr)) & ')'; when N_Attribute_Reference => if Take_Prefix then @@ -304,7 +319,7 @@ package body Pprint is return Str; end; else - return "'" & Get_Name_String (Attribute_Name (Expr)); + return ''' & Get_Name_String (Attribute_Name (Expr)); end if; when N_Explicit_Dereference => @@ -379,14 +394,6 @@ package body Pprint is return "." & Expr_Name (Selector_Name (Expr)); end if; - when N_Component_Association => - return "(" - & List_Name - (List => First (Choices (Expr)), - Add_Space => False, - Add_Paren => False) - & " => " & Expr_Name (Expression (Expr)) & ")"; - when N_If_Expression => declare Cond_Expr : constant Node_Id := First (Expressions (Expr)); @@ -436,6 +443,15 @@ package body Pprint is return "[program_error]"; end if; + when N_Raise_Storage_Error => + if Present (Condition (Expr)) then + return + "[storage_error when " + & Expr_Name (Condition (Expr)) & "]"; + else + return "[storage_error]"; + end if; + when N_Range => return Expr_Name (Low_Bound (Expr)) & ".." & @@ -573,9 +589,6 @@ package body Pprint is when N_Op_Not => return "not (" & Expr_Name (Right_Opnd (Expr)) & ")"; - when N_Parameter_Association => - return Expr_Name (Explicit_Actual_Parameter (Expr)); - when N_Type_Conversion => -- Most conversions are not very interesting (used inside @@ -602,9 +615,9 @@ package body Pprint is if Take_Prefix then return Expr_Name (Prefix (Expr)) - & List_Name (First (Expressions (Expr))); + & " (" & List_Name (Expressions (Expr)) & ')'; else - return List_Name (First (Expressions (Expr))); + return List_Name (Expressions (Expr)); end if; when N_Function_Call => @@ -614,312 +627,239 @@ package body Pprint is -- parentheses around function call to mark it specially. if Default = "" then - return '(' - & Expr_Name (Name (Expr)) - & List_Name (First (Parameter_Associations (Expr))) - & ')'; - else + if Present (Parameter_Associations (Expr)) then + return '(' + & Expr_Name (Name (Expr)) + & " (" + & List_Name (Parameter_Associations (Expr)) + & "))"; + else + return '(' & Expr_Name (Name (Expr)) & ')'; + end if; + elsif Present (Parameter_Associations (Expr)) then return Expr_Name (Name (Expr)) - & List_Name (First (Parameter_Associations (Expr))); + & " (" & List_Name (Parameter_Associations (Expr)) & ')'; + else + return Expr_Name (Name (Expr)); end if; when N_Null => return "null"; - when N_Others_Choice => - return "others"; - - when others => - return "..."; - end case; - end Expr_Name; - - -- Start of processing for Expression_Image - - begin - if not From_Source then - declare - S : constant String := Expr_Name (Expr); - begin - if S = "..." then - return Default; - else - return S; - end if; - end; - end if; - - -- Reach to the underlying expression for an expression-with-actions - - if Nkind (Expr) = N_Expression_With_Actions then - return Expression_Image (Expression (Expr), Default); - end if; - - -- Compute left (start) and right (end) slocs for the expression - -- Consider using Sinput.Sloc_Range instead, except that it does not - -- work properly currently??? - - loop - case Nkind (Left) is - when N_And_Then - | N_Binary_Op - | N_Membership_Test - | N_Or_Else - => - Left := Original_Node (Left_Opnd (Left)); - - when N_Attribute_Reference - | N_Expanded_Name - | N_Explicit_Dereference - | N_Indexed_Component + when N_Case_Expression + | N_Delta_Aggregate + | N_Interpolated_String_Literal + | N_Op_Rotate_Left + | N_Op_Rotate_Right + | N_Operator_Symbol + | N_Procedure_Call_Statement + | N_Quantified_Expression + | N_Raise_Expression | N_Reference - | N_Selected_Component - | N_Slice - => - Left := Original_Node (Prefix (Left)); - - when N_Defining_Program_Unit_Name - | N_Designator - | N_Function_Call + | N_Target_Name => - Left := Original_Node (Name (Left)); - - when N_Range => - Left := Original_Node (Low_Bound (Left)); - - when N_Qualified_Expression - | N_Type_Conversion - => - Left := Original_Node (Subtype_Mark (Left)); - - -- For any other item, quit loop - - when others => - exit; + return "..."; end case; - end loop; - - loop - case Nkind (Right) is - when N_And_Then - | N_Membership_Test - | N_Op - | N_Or_Else - => - Right := Original_Node (Right_Opnd (Right)); - - when N_Expanded_Name - | N_Selected_Component - => - Right := Original_Node (Selector_Name (Right)); - - when N_Qualified_Expression - | N_Type_Conversion - => - Right := Original_Node (Expression (Right)); + end Expr_Name; - -- If argument does not already account for a closing - -- parenthesis, count one here. + ----------------------- + -- Count_Parentheses -- + ----------------------- - if Nkind (Right) not in N_Aggregate | N_Quantified_Expression - then - Append_Paren := Append_Paren + 1; - end if; + function Count_Parentheses (S : String; C : Character) return Natural is - when N_Designator => - Right := Original_Node (Identifier (Right)); + procedure Next_Char (Count : in out Natural; C, D, Ch : Character); + -- Process next character Ch and update the number Count of C + -- characters to add for correct parenthesizing, where D is the + -- opposite parenthesis. - when N_Defining_Program_Unit_Name => - Right := Original_Node (Defining_Identifier (Right)); + --------------- + -- Next_Char -- + --------------- - when N_Range => - Right := Original_Node (High_Bound (Right)); + procedure Next_Char (Count : in out Natural; C, D, Ch : Character) is + begin + if Ch = D then + Count := Count + 1; + elsif Ch = C and then Count > 0 then + Count := Count - 1; + end if; + end Next_Char; - when N_Parameter_Association => - Right := Original_Node (Explicit_Actual_Parameter (Right)); + -- Local variables - when N_Component_Association => - if Present (Expression (Right)) then - Right := Expression (Right); - else - Right := Last (Choices (Right)); - end if; + Count : Natural := 0; - when N_Indexed_Component => - Right := Original_Node (Last (Expressions (Right))); - Append_Paren := Append_Paren + 1; + -- Start of processing for Count_Parentheses - when N_Function_Call => - if Present (Parameter_Associations (Right)) then - declare - Rover : Node_Id; - Found : Boolean; - - begin - -- Avoid source position confusion associated with - -- parameters for which Comes_From_Source is False. - - Rover := First (Parameter_Associations (Right)); - Found := False; - while Present (Rover) loop - if Comes_From_Source (Original_Node (Rover)) then - Right := Original_Node (Rover); - Found := True; - end if; + begin + if C = '(' then + for Ch of reverse S loop + Next_Char (Count, C, ')', Ch); + end loop; + else + for Ch of S loop + Next_Char (Count, C, '(', Ch); + end loop; + end if; - Next (Rover); - end loop; + return Count; + end Count_Parentheses; - if Found then - Append_Paren := Append_Paren + 1; - end if; + --------------------- + -- Fix_Parentheses -- + --------------------- - -- Quit loop if no Comes_From_Source parameters + function Fix_Parentheses (S : String) return String is + Count_Open : constant Natural := Count_Parentheses (S, '('); + Count_Close : constant Natural := Count_Parentheses (S, ')'); + begin + return (1 .. Count_Open => '(') & S & (1 .. Count_Close => ')'); + end Fix_Parentheses; - exit when not Found; - end; + -- Local variables - -- Quit loop if no parameters + Left, Right : Source_Ptr; - else - exit; - end if; - - when N_Quantified_Expression => - Right := Original_Node (Condition (Right)); - Append_Paren := Append_Paren + 1; + -- Start of processing for Expression_Image - when N_Aggregate => + begin + -- Since this is an expression pretty-printer, it should not be called + -- for anything but an expression. However, currently CodePeer calls + -- it for defining identifiers. This should be fixed in the CodePeer + -- itself, but for now simply return the default (if present) or print + -- name of the defining identifier. + + if Nkind (Expr) = N_Defining_Identifier then + pragma Assert (CodePeer_Mode); + if Comes_From_Source (Expr) + or else Opt.Debug_Generated_Code + then + if Default = "" then declare - Aggr : constant Node_Id := Right; - Sub : Node_Id; - + Nam : constant Name_Id := Chars (Expr); + Buf : Bounded_String + (Max_Length => Natural (Length_Of_Name (Nam))); begin - Sub := First (Expressions (Aggr)); - while Present (Sub) loop - if Sloc (Sub) > Sloc (Right) then - Right := Sub; - end if; + Adjust_Name_Case (Buf, Sloc (Expr)); + Append (Buf, Nam); + return To_String (Buf); + end; + else + return Default; + end if; + else + declare + S : constant String := + Ident_Image + (Expr => Expr, Orig_Expr => Expr, Expand_Type => True); + begin + if S = "..." then + return Default; + else + return S; + end if; + end; + end if; + else + pragma Assert (Nkind (Expr) in N_Subexpr); + end if; - Next (Sub); - end loop; + -- ??? The following should be primarily needed for CodePeer - Sub := First (Component_Associations (Aggr)); - while Present (Sub) loop - if Sloc (Sub) > Sloc (Right) then - Right := Sub; - end if; + if not Comes_From_Source (Expr) + or else Opt.Debug_Generated_Code + then + declare + S : constant String := Expr_Name (Expr); + begin + if S = "..." then + return Default; + else + return S; + end if; + end; + end if; - Next (Sub); - end loop; + -- Reach to the underlying expression for an expression-with-actions - exit when Right = Aggr; + if Nkind (Expr) = N_Expression_With_Actions then + return Expression_Image (Expression (Expr), Default); + end if; - Append_Paren := Append_Paren + 1; - end; + -- Compute left (start) and right (end) slocs for the expression - -- For all other items, quit the loop + Left := First_Sloc (Expr); + Right := Last_Sloc (Expr); - when others => - exit; - end case; - end loop; + if Left > Right then + return Default; + end if; declare - Scn : Source_Ptr := Original_Location (Sloc (Left)); - End_Sloc : constant Source_Ptr := - Original_Location (Sloc (Right)); - Src : constant Source_Buffer_Ptr := - Source_Text (Get_Source_File_Index (Scn)); - + Scn : Source_Ptr := Left; + Src : constant not null Source_Buffer_Ptr := + Source_Text (Get_Source_File_Index (Scn)); + + Threshold : constant := 256; + Buffer : String (1 .. Natural (Right - Left + 1)); + Index : Natural := 0; + Skipping_Comment : Boolean := False; + Underscore : Boolean := False; begin - if Scn > End_Sloc then - return Default; - end if; - - declare - Threshold : constant := 256; - Buffer : String (1 .. Natural (End_Sloc - Scn)); - Index : Natural := 0; - Skipping_Comment : Boolean := False; - Underscore : Boolean := False; - - begin - if Right /= Expr then - while Scn < End_Sloc loop - case Src (Scn) is - - -- Give up on non ASCII characters - - when Character'Val (128) .. Character'Last => - Append_Paren := 0; - Index := 0; - Right := Expr; - exit; - - when ' ' - | ASCII.HT - => - if not Skipping_Comment and then not Underscore then - Underscore := True; - Index := Index + 1; - Buffer (Index) := ' '; - end if; + while Scn <= Right loop + case Src (Scn) is - -- CR/LF/FF is the end of any comment + -- Give up on non ASCII characters - when ASCII.CR - | ASCII.FF - | ASCII.LF - => - Skipping_Comment := False; + when Character'Val (128) .. Character'Last => + Index := 0; + exit; - when others => - Underscore := False; + when ' ' + | ASCII.HT + => + if not Skipping_Comment and then not Underscore then + Underscore := True; + Index := Index + 1; + Buffer (Index) := ' '; + end if; - if not Skipping_Comment then + -- CR/LF/FF is the end of any comment - -- Ignore comment + when ASCII.CR + | ASCII.FF + | ASCII.LF + => + Skipping_Comment := False; - if Src (Scn) = '-' and then Src (Scn + 1) = '-' then - Skipping_Comment := True; + when others => + Underscore := False; - else - Index := Index + 1; - Buffer (Index) := Src (Scn); - end if; - end if; - end case; + if not Skipping_Comment then - -- Give up on too long strings + -- Ignore comment - if Index >= Threshold then - return Buffer (1 .. Index) & "..."; + if Src (Scn) = '-' and then Src (Scn + 1) = '-' then + Skipping_Comment := True; + else + Index := Index + 1; + Buffer (Index) := Src (Scn); + end if; end if; + end case; - Scn := Scn + 1; - end loop; + -- Give up on too long strings + + if Index >= Threshold then + return Buffer (1 .. Index) & "..."; end if; - if Index < 1 then - declare - S : constant String := Expr_Name (Right); - begin - if S = "..." then - return Default; - else - return S; - end if; - end; + Scn := Scn + 1; + end loop; - else - return - Buffer (1 .. Index) - & Expr_Name (Right, False) - & (1 .. Append_Paren => ')'); - end if; - end; + return Fix_Parentheses (Buffer (1 .. Index)); end; end Expression_Image; diff --git a/gcc/ada/repinfo.adb b/gcc/ada/repinfo.adb index e39856b..6a30bc7 100644 --- a/gcc/ada/repinfo.adb +++ b/gcc/ada/repinfo.adb @@ -991,12 +991,17 @@ package body Repinfo is procedure List_Structural_Record_Layout (Ent : Entity_Id; Ext_Ent : Entity_Id; - Ext_Level : Nat := 0; + Ext_Level : Integer := 0; Variant : Node_Id := Empty; Indent : Natural := 0); -- Internal recursive procedure to display the structural layout. -- If Ext_Ent is not equal to Ent, it is an extension of Ent and - -- Ext_Level is the number of successive extensions between them. + -- Ext_Level is the number of successive extensions between them, + -- with the convention that this number is positive when we are + -- called from the fixed part of Ext_Ent and negative when we are + -- called from the variant part of Ext_Ent, if any; this is needed + -- because the fixed and variant parts of a parent of an extension + -- cannot be listed contiguously from this extension's viewpoint. -- If Variant is present, it's for a variant in the variant part -- instead of the common part of Ent. Indent is the indentation. @@ -1362,7 +1367,7 @@ package body Repinfo is procedure List_Structural_Record_Layout (Ent : Entity_Id; Ext_Ent : Entity_Id; - Ext_Level : Nat := 0; + Ext_Level : Integer := 0; Variant : Node_Id := Empty; Indent : Natural := 0) is @@ -1381,7 +1386,16 @@ package body Repinfo is Derived_Disc : Entity_Id; begin - Derived_Disc := First_Discriminant (Ext_Ent); + -- Deal with an extension of a type with unknown discriminants + + if Has_Unknown_Discriminants (Ext_Ent) + and then Present (Underlying_Record_View (Ext_Ent)) + then + Derived_Disc := + First_Discriminant (Underlying_Record_View (Ext_Ent)); + else + Derived_Disc := First_Discriminant (Ext_Ent); + end if; -- Loop over the discriminants of the extension @@ -1418,6 +1432,7 @@ package body Repinfo is Comp : Node_Id; Comp_List : Node_Id; First : Boolean := True; + Parent_Ent : Entity_Id := Empty; Var : Node_Id; -- Start of processing for List_Structural_Record_Layout @@ -1471,8 +1486,11 @@ package body Repinfo is raise Not_In_Extended_Main; end if; - List_Structural_Record_Layout - (Parent_Type, Ext_Ent, Ext_Level + 1); + Parent_Ent := Parent_Type; + if Ext_Level >= 0 then + List_Structural_Record_Layout + (Parent_Ent, Ext_Ent, Ext_Level + 1); + end if; end if; First := False; @@ -1488,6 +1506,7 @@ package body Repinfo is if Has_Discriminants (Ent) and then not Is_Unchecked_Union (Ent) + and then Ext_Level >= 0 then Disc := First_Discriminant (Ent); while Present (Disc) loop @@ -1509,7 +1528,12 @@ package body Repinfo is if No (Listed_Disc) then goto Continue_Disc; + + elsif not Known_Normalized_Position (Listed_Disc) then + Listed_Disc := + Original_Record_Component (Listed_Disc); end if; + else Listed_Disc := Disc; end if; @@ -1543,7 +1567,9 @@ package body Repinfo is -- Now deal with the regular components, if any - if Present (Component_Items (Comp_List)) then + if Present (Component_Items (Comp_List)) + and then (Present (Variant) or else Ext_Level >= 0) + then Comp := First_Non_Pragma (Component_Items (Comp_List)); while Present (Comp) loop @@ -1571,6 +1597,20 @@ package body Repinfo is end loop; end if; + -- Stop there if we are called from the fixed part of Ext_Ent, + -- we'll do the variant part when called from its variant part. + + if Ext_Level > 0 then + return; + end if; + + -- List the layout of the variant part of the parent, if any + + if Present (Parent_Ent) then + List_Structural_Record_Layout + (Parent_Ent, Ext_Ent, Ext_Level - 1); + end if; + -- We are done if there is no variant part if No (Variant_Part (Comp_List)) then @@ -1582,7 +1622,7 @@ package body Repinfo is Write_Line (" ],"); Spaces (Indent); Write_Str (" """); - for J in 1 .. Ext_Level loop + for J in Ext_Level .. -1 loop Write_Str ("parent_"); end loop; Write_Str ("variant"" : ["); diff --git a/gcc/ada/repinfo.ads b/gcc/ada/repinfo.ads index 4787b97..db9919a 100644 --- a/gcc/ada/repinfo.ads +++ b/gcc/ada/repinfo.ads @@ -244,7 +244,10 @@ package Repinfo is -- "present" and "record" are present for every variant. The value of -- "present" is a boolean expression that evaluates to true when the -- components of the variant are contained in the record type and to - -- false when they are not. The value of "record" is the list of + -- false when they are not, with the exception that a value of 1 means + -- that the components of the variant are contained in the record type + -- only when the "present" member of all the preceding variants in the + -- variant list evaluates to false. The value of "record" is the list of -- components in the variant. "variant" is present only if the variant -- itself has a variant part and its value is the list of (sub)variants. diff --git a/gcc/ada/rtsfind.adb b/gcc/ada/rtsfind.adb index 4b8e89e..278797f 100644 --- a/gcc/ada/rtsfind.adb +++ b/gcc/ada/rtsfind.adb @@ -1023,6 +1023,13 @@ package body Rtsfind is U : RT_Unit_Table_Record renames RT_Unit_Table (U_Id); Priv_Par : constant Elist_Id := New_Elmt_List; Lib_Unit : Node_Id; + Saved_GM : constant Ghost_Mode_Type := Ghost_Mode; + Saved_IGR : constant Node_Id := Ignored_Ghost_Region; + Saved_ISMP : constant Boolean := + Ignore_SPARK_Mode_Pragmas_In_Instance; + Saved_SM : constant SPARK_Mode_Type := SPARK_Mode; + Saved_SMP : constant Node_Id := SPARK_Mode_Pragma; + -- Save Ghost and SPARK mode-related data to restore on exit procedure Save_Private_Visibility; -- If the current unit is the body of child unit or the spec of a @@ -1034,6 +1041,9 @@ package body Rtsfind is procedure Restore_Private_Visibility; -- Restore the visibility of ancestors after compiling RTU + procedure Restore_SPARK_Context; + -- Restore Ghost and SPARK mode-related data saved on procedure entry + -------------------------------- -- Restore_Private_Visibility -- -------------------------------- @@ -1075,15 +1085,16 @@ package body Rtsfind is end loop; end Save_Private_Visibility; - -- Local variables + --------------------------- + -- Restore_SPARK_Context -- + --------------------------- - Saved_GM : constant Ghost_Mode_Type := Ghost_Mode; - Saved_IGR : constant Node_Id := Ignored_Ghost_Region; - Saved_ISMP : constant Boolean := - Ignore_SPARK_Mode_Pragmas_In_Instance; - Saved_SM : constant SPARK_Mode_Type := SPARK_Mode; - Saved_SMP : constant Node_Id := SPARK_Mode_Pragma; - -- Save Ghost and SPARK mode-related data to restore on exit + procedure Restore_SPARK_Context is + begin + Ignore_SPARK_Mode_Pragmas_In_Instance := Saved_ISMP; + Restore_Ghost_Region (Saved_GM, Saved_IGR); + Restore_SPARK_Mode (Saved_SM, Saved_SMP); + end Restore_SPARK_Context; -- Start of processing for Load_RTU @@ -1195,9 +1206,17 @@ package body Rtsfind is Set_Is_Potentially_Use_Visible (U.Entity, True); end if; - Ignore_SPARK_Mode_Pragmas_In_Instance := Saved_ISMP; - Restore_Ghost_Region (Saved_GM, Saved_IGR); - Restore_SPARK_Mode (Saved_SM, Saved_SMP); + Restore_SPARK_Context; + + exception + -- The Load_Fail procedure that is called when the result of Load_Unit + -- is not satisfactory raises an exception. As the compiler is able to + -- recover in some cases (i.e. when RE_Not_Available is raised), we need + -- to restore the SPARK/Ghost context correctly. + + when others => + Restore_SPARK_Context; + raise; end Load_RTU; -------------------- diff --git a/gcc/ada/s-oscons-tmplt.c b/gcc/ada/s-oscons-tmplt.c index 5480e55..28d42c5 100644 --- a/gcc/ada/s-oscons-tmplt.c +++ b/gcc/ada/s-oscons-tmplt.c @@ -1796,11 +1796,6 @@ CND(SIZEOF_struct_hostent, "struct hostent") #define SIZEOF_struct_servent (sizeof (struct servent)) CND(SIZEOF_struct_servent, "struct servent") -#if defined (__linux__) || defined (__ANDROID__) || defined (__QNX__) -#define SIZEOF_sigset (sizeof (sigset_t)) -CND(SIZEOF_sigset, "sigset") -#endif - #if defined(_WIN32) || defined(__vxworks) #define SIZEOF_nfds_t sizeof (int) * 8 #define SIZEOF_socklen_t sizeof (size_t) @@ -1938,6 +1933,11 @@ CST(Poll_Linkname, "") #endif /* HAVE_SOCKETS */ +#if defined (__linux__) || defined (__ANDROID__) || defined (__QNX__) +#define SIZEOF_sigset (sizeof (sigset_t)) +CND(SIZEOF_sigset, "sigset") +#endif + /* --------------------- diff --git a/gcc/ada/scans.ads b/gcc/ada/scans.ads index 19e13b6..00381bb 100644 --- a/gcc/ada/scans.ads +++ b/gcc/ada/scans.ads @@ -482,6 +482,9 @@ package Scans is -- or aspect. Used to allow/require nonstandard style rules for =>+ with -- -gnatyt. + Inside_Interpolated_String_Expression : Boolean := False; + -- True while parsing an interpolated string expression + Inside_Interpolated_String_Literal : Boolean := False; -- True while parsing an interpolated string literal diff --git a/gcc/ada/scng.adb b/gcc/ada/scng.adb index d1230e2..c2707df 100644 --- a/gcc/ada/scng.adb +++ b/gcc/ada/scng.adb @@ -951,12 +951,20 @@ package body Scng is C3 : Character; begin + -- Skip processing operator symbols if we are scanning an + -- interpolated string literal. + + if Inside_Interpolated_String_Literal + and then not Inside_Interpolated_String_Expression + then + null; + -- Token_Name is currently set to Error_Name. The following -- section of code resets Token_Name to the proper Name_Op_xx -- value if the string is a valid operator symbol, otherwise it is -- left set to Error_Name. - if Slen = 1 then + elsif Slen = 1 then C1 := Source (Token_Ptr + 1); case C1 is @@ -1527,10 +1535,10 @@ package body Scng is end if; -- Left curly bracket, treated as right paren but proper delimiter - -- of interpolated string literals when all extensions are allowed. + -- of interpolated string literals when core extensions are allowed. when '{' => - if All_Extensions_Allowed then + if Core_Extensions_Allowed then Scan_Ptr := Scan_Ptr + 1; Token := Tok_Left_Curly_Bracket; @@ -1962,10 +1970,10 @@ package body Scng is return; -- Right curly bracket, treated as right paren but proper delimiter - -- of interpolated string literals when all extensions are allowed. + -- of interpolated string literals when core extensions are allowed. when '}' => - if All_Extensions_Allowed then + if Core_Extensions_Allowed then Token := Tok_Right_Curly_Bracket; else @@ -2125,7 +2133,7 @@ package body Scng is -- Lower case letters when 'a' .. 'z' => - if All_Extensions_Allowed + if Core_Extensions_Allowed and then Source (Scan_Ptr) = 'f' and then Source (Scan_Ptr + 1) = '"' then @@ -2145,7 +2153,7 @@ package body Scng is -- Upper case letters when 'A' .. 'Z' => - if All_Extensions_Allowed + if Core_Extensions_Allowed and then Source (Scan_Ptr) = 'F' and then Source (Scan_Ptr + 1) = '"' then diff --git a/gcc/ada/sem.adb b/gcc/ada/sem.adb index 9c338d3..3bff8d2 100644 --- a/gcc/ada/sem.adb +++ b/gcc/ada/sem.adb @@ -760,6 +760,29 @@ package body Sem is Debug_A_Exit ("analyzing ", N, " (done)"); + -- Set Is_Not_Self_Hidden flag. RM-8.3(16) says a declaration + -- is no longer hidden from all visibility after "the end of the + -- declaration", so we set the flag here (in addition to setting it + -- elsewhere to handle the "except..." cases of 8.3(16)). However, + -- we implement 3.8(10) using the same flag, so in that case we + -- need to defer the setting until the end of the record. + + declare + E : constant Entity_Id := Defining_Entity_Or_Empty (N); + begin + if Present (E) then + if Ekind (E) = E_Void + and then Nkind (N) = N_Component_Declaration + and then Present (Scope (E)) + and then Ekind (Scope (E)) = E_Record_Type + then + null; -- Set it later, in Analyze_Component_Declaration + elsif not Is_Not_Self_Hidden (E) then + Set_Is_Not_Self_Hidden (E); + end if; + end if; + end; + -- Mark relevant use-type and use-package clauses as effective -- preferring the original node over the analyzed one in the case that -- constant folding has occurred and removed references that need to be diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index 3ebb30d..3918946 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -464,8 +464,8 @@ package body Sem_Aggr is This_Range : constant Node_Id := Aggregate_Bounds (N); -- The aggregate range node of this specific sub-aggregate - This_Low : constant Node_Id := Low_Bound (Aggregate_Bounds (N)); - This_High : constant Node_Id := High_Bound (Aggregate_Bounds (N)); + This_Low : constant Node_Id := Low_Bound (This_Range); + This_High : constant Node_Id := High_Bound (This_Range); -- The aggregate bounds of this specific sub-aggregate Assoc : Node_Id; @@ -828,7 +828,7 @@ package body Sem_Aggr is begin P := Loc + 1; - for J in 1 .. Strlen loop + for J in 1 .. Strlen loop C := Get_String_Char (Str, J); Set_Character_Literal_Name (C); @@ -1180,6 +1180,7 @@ package body Sem_Aggr is | N_Component_Declaration | N_Parameter_Specification | N_Qualified_Expression + | N_Unchecked_Type_Conversion | N_Reference | N_Aggregate | N_Extension_Aggregate @@ -1330,15 +1331,21 @@ package body Sem_Aggr is -- In this event we do not resolve Expr unless expansion is disabled. -- To know why, see the DELAYED COMPONENT RESOLUTION note above. -- - -- NOTE: In the case of "... => <>", we pass the in the - -- N_Component_Association node as Expr, since there is no Expression in - -- that case, and we need a Sloc for the error message. + -- NOTE: In the case of "... => <>", we pass the N_Component_Association + -- node as Expr, since there is no Expression and we need a Sloc for the + -- error message. procedure Resolve_Iterated_Component_Association (N : Node_Id; Index_Typ : Entity_Id); -- For AI12-061 + procedure Warn_On_Null_Component_Association (Expr : Node_Id); + -- Expr is either a conditional expression or a case expression of an + -- iterated component association initializing the aggregate N with + -- components that can never be null. Report warning on associations + -- that may initialize some component with a null value. + --------- -- Add -- --------- @@ -1783,7 +1790,7 @@ package body Sem_Aggr is Choice : Node_Id; Dummy : Boolean; Scop : Entity_Id; - Expr : Node_Id; + Expr : constant Node_Id := Expression (N); -- Start of processing for Resolve_Iterated_Component_Association @@ -1843,20 +1850,17 @@ package body Sem_Aggr is Set_Etype (Id, Index_Typ); Mutate_Ekind (Id, E_Variable); + Set_Is_Not_Self_Hidden (Id); Set_Scope (Id, Scop); end if; - -- Analyze expression without expansion, to verify legality. + -- Analyze expression without expansion, to verify legality. -- When generating code, we then remove references to the index -- variable, because the expression will be analyzed anew after -- rewritting as a loop with a new index variable; when not -- generating code we leave the analyzed expression as it is. - Expr := Expression (N); - - Expander_Mode_Save_And_Set (False); Dummy := Resolve_Aggr_Expr (Expr, Single_Elmt => False); - Expander_Mode_Restore; if Operating_Mode /= Check_Semantics then Remove_References (Expr); @@ -1875,6 +1879,132 @@ package body Sem_Aggr is End_Scope; end Resolve_Iterated_Component_Association; + ---------------------------------------- + -- Warn_On_Null_Component_Association -- + ---------------------------------------- + + procedure Warn_On_Null_Component_Association (Expr : Node_Id) is + Comp_Typ : constant Entity_Id := Component_Type (Etype (N)); + + procedure Check_Case_Expr (N : Node_Id); + -- Check if a case expression may initialize some component with a + -- null value. + + procedure Check_Cond_Expr (N : Node_Id); + -- Check if a conditional expression may initialize some component + -- with a null value. + + procedure Check_Expr (Expr : Node_Id); + -- Check if an expression may initialize some component with a + -- null value. + + procedure Warn_On_Null_Expression_And_Rewrite (Null_Expr : Node_Id); + -- Report warning on known null expression and replace the expression + -- by a raise constraint error node. + + --------------------- + -- Check_Case_Expr -- + --------------------- + + procedure Check_Case_Expr (N : Node_Id) is + Alt_Node : Node_Id := First (Alternatives (N)); + + begin + while Present (Alt_Node) loop + Check_Expr (Expression (Alt_Node)); + Next (Alt_Node); + end loop; + end Check_Case_Expr; + + --------------------- + -- Check_Cond_Expr -- + --------------------- + + procedure Check_Cond_Expr (N : Node_Id) is + If_Expr : Node_Id := N; + Then_Expr : Node_Id; + Else_Expr : Node_Id; + + begin + Then_Expr := Next (First (Expressions (If_Expr))); + Else_Expr := Next (Then_Expr); + + Check_Expr (Then_Expr); + + -- Process elsif parts (if any) + + while Nkind (Else_Expr) = N_If_Expression loop + If_Expr := Else_Expr; + Then_Expr := Next (First (Expressions (If_Expr))); + Else_Expr := Next (Then_Expr); + + Check_Expr (Then_Expr); + end loop; + + if Known_Null (Else_Expr) then + Warn_On_Null_Expression_And_Rewrite (Else_Expr); + end if; + end Check_Cond_Expr; + + ---------------- + -- Check_Expr -- + ---------------- + + procedure Check_Expr (Expr : Node_Id) is + begin + if Known_Null (Expr) then + Warn_On_Null_Expression_And_Rewrite (Expr); + + elsif Nkind (Expr) = N_If_Expression then + Check_Cond_Expr (Expr); + + elsif Nkind (Expr) = N_Case_Expression then + Check_Case_Expr (Expr); + end if; + end Check_Expr; + + ----------------------------------------- + -- Warn_On_Null_Expression_And_Rewrite -- + ----------------------------------------- + + procedure Warn_On_Null_Expression_And_Rewrite (Null_Expr : Node_Id) is + begin + Error_Msg_N + ("(Ada 2005) NULL not allowed in null-excluding component??", + Null_Expr); + Error_Msg_N + ("\Constraint_Error might be raised at run time??", Null_Expr); + + -- We cannot use Apply_Compile_Time_Constraint_Error because in + -- some cases the components are rewritten and the runtime error + -- would be missed. + + Rewrite (Null_Expr, + Make_Raise_Constraint_Error (Sloc (Null_Expr), + Reason => CE_Access_Check_Failed)); + + Set_Etype (Null_Expr, Comp_Typ); + Set_Analyzed (Null_Expr); + end Warn_On_Null_Expression_And_Rewrite; + + -- Start of processing for Warn_On_Null_Component_Association + + begin + pragma Assert (Can_Never_Be_Null (Comp_Typ)); + + case Nkind (Expr) is + when N_If_Expression => + Check_Cond_Expr (Expr); + + when N_Case_Expression => + Check_Case_Expr (Expr); + + when others => + pragma Assert (False); + null; + end case; + end Warn_On_Null_Component_Association; + -- Local variables Assoc : Node_Id; @@ -2037,9 +2167,11 @@ package body Sem_Aggr is if Is_Type (E) and then Has_Predicates (E) then Freeze_Before (N, E); - if Has_Dynamic_Predicate_Aspect (E) then + if Has_Dynamic_Predicate_Aspect (E) + or else Has_Ghost_Predicate_Aspect (E) + then Error_Msg_NE - ("subtype& has dynamic predicate, not allowed " + ("subtype& has non-static predicate, not allowed " & "in aggregate choice", Choice, E); elsif not Is_OK_Static_Subtype (E) then @@ -2144,8 +2276,15 @@ package body Sem_Aggr is ----------------- function Empty_Range (A : Node_Id) return Boolean is - R : constant Node_Id := First (Choices (A)); + R : Node_Id; + begin + if Nkind (A) = N_Iterated_Component_Association then + R := First (Discrete_Choices (A)); + else + R := First (Choices (A)); + end if; + return No (Next (R)) and then Nkind (R) = N_Range and then Compile_Time_Compare @@ -2215,10 +2354,12 @@ package body Sem_Aggr is Resolve_Discrete_Subtype_Indication (Choice, Index_Base); if Has_Dynamic_Predicate_Aspect - (Entity (Subtype_Mark (Choice))) + (Entity (Subtype_Mark (Choice))) + or else Has_Ghost_Predicate_Aspect + (Entity (Subtype_Mark (Choice))) then Error_Msg_NE - ("subtype& has dynamic predicate, " + ("subtype& has non-static predicate, " & "not allowed in aggregate choice", Choice, Entity (Subtype_Mark (Choice))); end if; @@ -2301,8 +2442,8 @@ package body Sem_Aggr is -- this discrete choice specifies a single value. Single_Choice := - (Nb_Discrete_Choices = Prev_Nb_Discrete_Choices + 1) - and then (Low = High); + Nb_Discrete_Choices = Prev_Nb_Discrete_Choices + 1 + and then Low = High; exit; end if; @@ -2311,10 +2452,28 @@ package body Sem_Aggr is -- Ada 2005 (AI-231) if Ada_Version >= Ada_2005 - and then Known_Null (Expression (Assoc)) and then not Empty_Range (Assoc) then - Check_Can_Never_Be_Null (Etype (N), Expression (Assoc)); + if Known_Null (Expression (Assoc)) then + Check_Can_Never_Be_Null (Etype (N), Expression (Assoc)); + + -- Report warning on iterated component association that may + -- initialize some component of an array of null-excluding + -- access type components with a null value. For example: + + -- type AList is array (...) of not null access Integer; + -- L : AList := + -- [for J in A'Range => + -- (if Func (J) = 0 then A(J)'Access else Null)]; + + elsif Ada_Version >= Ada_2022 + and then Can_Never_Be_Null (Component_Type (Etype (N))) + and then Nkind (Assoc) = N_Iterated_Component_Association + and then Nkind (Expression (Assoc)) in N_If_Expression + | N_Case_Expression + then + Warn_On_Null_Component_Association (Expression (Assoc)); + end if; end if; -- Ada 2005 (AI-287): In case of default initialized component @@ -3131,6 +3290,7 @@ package body Sem_Aggr is end if; Mutate_Ekind (Id, E_Variable); + Set_Is_Not_Self_Hidden (Id); Set_Scope (Id, Ent); Set_Referenced (Id); @@ -3157,6 +3317,7 @@ package body Sem_Aggr is if Present (Add_Unnamed_Subp) and then No (New_Indexed_Subp) + and then Etype (Add_Unnamed_Subp) /= Any_Type then declare Elmt_Type : constant Entity_Id := @@ -3200,7 +3361,9 @@ package body Sem_Aggr is end if; end; - elsif Present (Add_Named_Subp) then + elsif Present (Add_Named_Subp) + and then Etype (Add_Named_Subp) /= Any_Type + then declare -- Retrieves types of container, key, and element from the -- specified insertion procedure. @@ -3242,7 +3405,9 @@ package body Sem_Aggr is end loop; end; - elsif Present (Assign_Indexed_Subp) then + elsif Present (Assign_Indexed_Subp) + and then Etype (Assign_Indexed_Subp) /= Any_Type + then -- Indexed Aggregate. Positional or indexed component -- can be present, but not both. Choices must be static -- values or ranges with static bounds. @@ -3503,6 +3668,7 @@ package body Sem_Aggr is if No (Scope (Id)) then Set_Etype (Id, Index_Type); Mutate_Ekind (Id, E_Variable); + Set_Is_Not_Self_Hidden (Id); Set_Scope (Id, Ent); end if; Enter_Name (Id); @@ -4166,7 +4332,7 @@ package body Sem_Aggr is Append (Make_Range (Loc, New_Copy_Tree (Lo), Hi), Constr); Analyze_And_Resolve (Last (Constr), Etype (Index)); - Index := Next_Index (Index); + Next_Index (Index); end loop; Set_Compile_Time_Known_Aggregate (N); @@ -4675,7 +4841,7 @@ package body Sem_Aggr is then Error_Msg_Node_2 := Typ; Error_Msg_NE - ("component&? of type& is uninitialized", + ("??component& of type& is uninitialized", Assoc, Selector_Name); -- An additional reminder if the component type @@ -5466,7 +5632,7 @@ package body Sem_Aggr is end if; Record_Def := Type_Definition (Parent (Base_Type (Parent_Typ))); - Gather_Components (Empty, + Gather_Components (Parent_Typ, Component_List (Record_Extension_Part (Record_Def)), Governed_By => New_Assoc_List, Into => Components, @@ -5508,7 +5674,6 @@ package body Sem_Aggr is -- STEP 6: Find component Values - Component := Empty; Component_Elmt := First_Elmt (Components); -- First scan the remaining positional associations in the aggregate. @@ -5830,15 +5995,16 @@ package body Sem_Aggr is ("OTHERS must represent at least one component", Selectr); elsif Others_Box = 1 and then Warn_On_Redundant_Constructs then - Error_Msg_N ("OTHERS choice is redundant?", Box_Node); + Error_Msg_N ("OTHERS choice is redundant?r?", Box_Node); Error_Msg_N - ("\previous choices cover all components?", Box_Node); + ("\previous choices cover all components?r?", Box_Node); end if; exit Verification; end if; while Present (Selectr) loop + Component := Empty; New_Assoc := First (New_Assoc_List); while Present (New_Assoc) loop Component := First (Choices (New_Assoc)); @@ -5854,6 +6020,11 @@ package body Sem_Aggr is Next (New_Assoc); end loop; + -- If we found an association, then this is a legal component + -- of the type in question. + + pragma Assert (if Present (New_Assoc) then Present (Component)); + -- If no association, this is not a legal component of the type -- in question, unless its association is provided with a box. diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index a9e64b7..7a47abd 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -41,6 +41,7 @@ with Exp_Dist; use Exp_Dist; with Exp_Util; use Exp_Util; with Expander; use Expander; with Freeze; use Freeze; +with Ghost; use Ghost; with Gnatvsn; use Gnatvsn; with Itypes; use Itypes; with Lib; use Lib; @@ -104,8 +105,8 @@ package body Sem_Attr is -- In Ada 83 mode, these are the only recognized attributes. In other Ada -- modes all these attributes are recognized, even if removed in Ada 95. - Attribute_83 : constant Attribute_Class_Array := Attribute_Class_Array'( - Attribute_Address | + Attribute_83 : constant Attribute_Set := + (Attribute_Address | Attribute_Aft | Attribute_Alignment | Attribute_Base | @@ -153,8 +154,8 @@ package body Sem_Attr is -- RM which are not defined in Ada 95. These are recognized in Ada 95 mode, -- but in Ada 95 they are considered to be implementation defined. - Attribute_05 : constant Attribute_Class_Array := Attribute_Class_Array'( - Attribute_Machine_Rounding | + Attribute_05 : constant Attribute_Set := + (Attribute_Machine_Rounding | Attribute_Mod | Attribute_Priority | Attribute_Stream_Size | @@ -165,8 +166,8 @@ package body Sem_Attr is -- RM which are not defined in Ada 2005. These are recognized in Ada 95 -- and Ada 2005 modes, but are considered to be implementation defined. - Attribute_12 : constant Attribute_Class_Array := Attribute_Class_Array'( - Attribute_First_Valid | + Attribute_12 : constant Attribute_Set := + (Attribute_First_Valid | Attribute_Has_Same_Storage | Attribute_Last_Valid | Attribute_Max_Alignment_For_Allocation => True, @@ -176,10 +177,10 @@ package body Sem_Attr is -- RM which are not defined in Ada 2012. These are recognized in Ada -- 95/2005/2012 modes, but are considered to be implementation defined. - Attribute_22 : constant Attribute_Class_Array := Attribute_Class_Array'( - Attribute_Enum_Rep | - Attribute_Enum_Val => True, - Attribute_Index => True, + Attribute_22 : constant Attribute_Set := + (Attribute_Enum_Rep | + Attribute_Enum_Val | + Attribute_Index | Attribute_Preelaborable_Initialization => True, others => False); @@ -187,9 +188,8 @@ package body Sem_Attr is -- of their prefixes or result in an access value. Such prefixes can be -- considered as lvalues. - Attribute_Name_Implies_Lvalue_Prefix : constant Attribute_Class_Array := - Attribute_Class_Array'( - Attribute_Access | + Attribute_Name_Implies_Lvalue_Prefix : constant Attribute_Set := + (Attribute_Access | Attribute_Address | Attribute_Input | Attribute_Read | @@ -1068,9 +1068,11 @@ package body Sem_Attr is Analyze (N); return; - -- OK if a task type, this test needs sharpening up ??? + -- OK if current task. - elsif Is_Task_Type (Typ) then + elsif Is_Task_Type (Typ) + and then In_Open_Scopes (Typ) + then null; -- OK if self-reference in an aggregate in Ada 2005, and @@ -1364,8 +1366,27 @@ package body Sem_Attr is -- yet on its definite context. if Inside_Class_Condition_Preanalysis then - Legal := True; - Spec_Id := Current_Scope; + Legal := True; + + -- Search for the subprogram that has this class-wide condition; + -- required to avoid reporting spurious errors since the current + -- scope may not be appropriate because the attribute may be + -- referenced from the inner scope of, for example, quantified + -- expressions. + + -- Although the expression is not installed on its definite + -- context, we know that the subprogram has been placed in the + -- scope stack by Preanalyze_Condition; we also know that it is + -- not a generic subprogram since class-wide pre/postconditions + -- can only be applied for primitive operations of tagged types. + + if Is_Subprogram (Current_Scope) then + Spec_Id := Current_Scope; + else + Spec_Id := Enclosing_Subprogram (Current_Scope); + end if; + + pragma Assert (Is_Dispatching_Operation (Spec_Id)); return; end if; @@ -1402,6 +1423,14 @@ package body Sem_Attr is elsif Prag_Nam = Name_Contract_Cases then Check_Placement_In_Contract_Cases (Prag); + -- Attributes 'Old and 'Result are allowed to appear in + -- consequence of aspect or pragma Exceptional_Cases. We already + -- examined the exception_choice part of contract syntax, so we + -- can accept all remaining occurrences within the pragma. + + elsif Prag_Nam = Name_Exceptional_Cases then + null; + -- Attribute 'Result is allowed to appear in aspect or pragma -- [Refined_]Depends (SPARK RM 6.1.5(11)). @@ -1485,6 +1514,7 @@ package body Sem_Attr is elsif Nkind (Subp_Decl) not in N_Abstract_Subprogram_Declaration | N_Entry_Declaration | N_Expression_Function + | N_Full_Type_Declaration | N_Generic_Subprogram_Declaration | N_Subprogram_Body | N_Subprogram_Body_Stub @@ -2488,7 +2518,7 @@ package body Sem_Attr is or else In_Spec_Expression then return; - else + elsif not Is_Current_Instance (P) then Check_Fully_Declared (P_Type, P); end if; end Check_Not_Incomplete_Type; @@ -3298,7 +3328,10 @@ package body Sem_Attr is -- Check for missing/bad expression (result of previous error) - if No (E1) or else Etype (E1) = Any_Type then + if No (E1) + or else (Etype (E1) = Any_Type and then Full_Analysis) + then + Check_Error_Detected; raise Bad_Attribute; end if; end if; @@ -4613,7 +4646,7 @@ package body Sem_Attr is if Comes_From_Source (N) then - -- This attribute be prefixed with references to objects or + -- This attribute can be prefixed with references to objects or -- values (such as a current instance value given within a type -- or subtype aspect). @@ -4621,6 +4654,13 @@ package body Sem_Attr is and then not Is_Current_Instance_Reference_In_Type_Aspect (P) then Error_Attr_P ("prefix of % attribute must be object"); + + -- Just like attribute 'Valid_Scalars this attribute is illegal + -- on unchecked union types. + + elsif Has_Unchecked_Union (Validated_View (P_Type)) then + Error_Attr_P + ("attribute % not allowed for Unchecked_Union type"); end if; end if; @@ -4744,8 +4784,9 @@ package body Sem_Attr is Loop_Decl : constant Node_Id := Label_Construct (Parent (Loop_Id)); function Check_Reference (Nod : Node_Id) return Traverse_Result; - -- Determine whether a reference mentions an entity declared - -- within the related loop. + -- Detect attribute 'Loop_Entry in prefix P and determine whether + -- a reference mentions an entity declared within the related + -- loop. function Declared_Within (Nod : Node_Id) return Boolean; -- Determine whether Nod appears in the subtree of Loop_Decl but @@ -4756,8 +4797,22 @@ package body Sem_Attr is --------------------- function Check_Reference (Nod : Node_Id) return Traverse_Result is + Orig_Nod : constant Node_Id := Original_Node (Nod); + -- Check presence of Loop_Entry in the prefix P by looking at + -- the original node for Nod, as it will have been rewritten + -- into its own prefix if the assertion is ignored (see code + -- below). + begin - if Nkind (Nod) = N_Identifier + if Is_Attribute_Loop_Entry (Orig_Nod) then + Error_Msg_Name_1 := Name_Loop_Entry; + Error_Msg_Name_2 := Name_Loop_Entry; + Error_Msg_N + ("attribute % cannot appear in the prefix of attribute %", + Nod); + return Abandon; + + elsif Nkind (Nod) = N_Identifier and then Present (Entity (Nod)) and then Declared_Within (Declaration_Node (Entity (Nod))) then @@ -5971,6 +6026,18 @@ package body Sem_Attr is ("incorrect prefix for attribute %, expected %", P); end if; + -- If the prefix is an access-to-subprogram type, then it must + -- be the same as the annotated type. + + elsif Is_Access_Subprogram_Type (Pref_Id) then + if Pref_Id = Spec_Id then + Set_Etype (N, Etype (Designated_Type (Spec_Id))); + else + Error_Msg_Name_2 := Chars (Spec_Id); + Error_Attr + ("incorrect prefix for attribute %, expected %", P); + end if; + -- Otherwise the prefix denotes some other form of subprogram -- entity. @@ -7598,7 +7665,7 @@ package body Sem_Attr is -- In SPARK certain attributes (see below) depend on Tasking_State. -- Ensure that the entity is available for gnat2why by loading it. - -- See SPARK RM 9(18) for the relevant rule. + -- See SPARK RM 9(19) for the relevant rule. if GNATprove_Mode then case Attr_Id is @@ -8385,9 +8452,13 @@ package body Sem_Attr is -- However, the attribute Unconstrained_Array must be evaluated, -- since it is documented to be a static attribute (and can for -- example appear in a Compile_Time_Warning pragma). The frozen - -- status of the type does not affect its evaluation. + -- status of the type does not affect its evaluation. Likewise + -- for attributes intended to be used with generic definitions. - and then Id /= Attribute_Unconstrained_Array + and then Id not in Attribute_Unconstrained_Array + | Attribute_Has_Access_Values + | Attribute_Has_Discriminants + | Attribute_Has_Tagged_Values then return; end if; @@ -10943,6 +11014,9 @@ package body Sem_Attr is -- Returns True if Declared_Entity is declared within the declarative -- region of Generic_Unit; otherwise returns False. + function Is_Thin_Pointer_To_Unc_Array (T : Entity_Id) return Boolean; + -- Return True if T is a thin pointer to an unconstrained array type + ---------------------------------- -- Declared_Within_Generic_Unit -- ---------------------------------- @@ -10970,6 +11044,28 @@ package body Sem_Attr is return False; end Declared_Within_Generic_Unit; + ---------------------------------- + -- Is_Thin_Pointer_To_Unc_Array -- + ---------------------------------- + + function Is_Thin_Pointer_To_Unc_Array (T : Entity_Id) return Boolean is + begin + if Is_Access_Type (T) + and then Has_Size_Clause (T) + and then RM_Size (T) = System_Address_Size + then + declare + DT : constant Entity_Id := Designated_Type (T); + + begin + return Is_Array_Type (DT) and then not Is_Constrained (DT); + end; + + else + return False; + end if; + end Is_Thin_Pointer_To_Unc_Array; + -- Start of processing for Resolve_Attribute begin @@ -10992,6 +11088,12 @@ package body Sem_Attr is Set_Etype (N, Typ); end if; + -- A Ghost attribute must appear in a specific context + + if Is_Ghost_Attribute_Reference (N) then + Check_Ghost_Context (Empty, N); + end if; + -- Remaining processing depends on attribute case Attr_Id is @@ -11445,9 +11547,7 @@ package body Sem_Attr is end if; end if; - if Attr_Id in Attribute_Access | Attribute_Unchecked_Access - and then (Ekind (Btyp) = E_General_Access_Type - or else Ekind (Btyp) = E_Anonymous_Access_Type) + if Ekind (Btyp) in E_General_Access_Type | E_Anonymous_Access_Type then -- Ada 2005 (AI-230): Check the accessibility of anonymous -- access types for stand-alone objects, record and array @@ -11455,6 +11555,7 @@ package body Sem_Attr is -- the level is the same of the enclosing composite type. if Ada_Version >= Ada_2005 + and then Attr_Id = Attribute_Access and then (Is_Local_Anonymous_Access (Btyp) -- Handle cases where Btyp is the anonymous access @@ -11462,7 +11563,6 @@ package body Sem_Attr is or else Nkind (Associated_Node_For_Itype (Btyp)) = N_Object_Declaration) - and then Attr_Id = Attribute_Access -- Verify that static checking is OK (namely that we aren't -- in a specific context requiring dynamic checks on @@ -11501,7 +11601,9 @@ package body Sem_Attr is end if; end if; - if Is_Dependent_Component_Of_Mutable_Object (P) then + if Attr_Id /= Attribute_Unrestricted_Access + and then Is_Dependent_Component_Of_Mutable_Object (P) + then Error_Msg_F ("illegal attribute for discriminant-dependent component", P); @@ -11516,7 +11618,19 @@ package body Sem_Attr is Nom_Subt := Base_Type (Nom_Subt); end if; - if Is_Tagged_Type (Designated_Type (Typ)) then + -- We do not enforce static matching for Unrestricted_Access + -- except for a thin pointer to an unconstrained array type, + -- because, in this case, the designated object must contain + -- its bounds, which means that it must have an unconstrained + -- nominal subtype (and be aliased, as will be checked below). + + if Attr_Id = Attribute_Unrestricted_Access + and then not (Is_Thin_Pointer_To_Unc_Array (Typ) + and then Is_Aliased_View (Original_Node (P))) + then + null; + + elsif Is_Tagged_Type (Designated_Type (Typ)) then -- If the attribute is in the context of an access -- parameter, then the prefix is allowed to be of @@ -11626,8 +11740,9 @@ package body Sem_Attr is Compatible_Alt_Checks : constant Boolean := No_Dynamic_Acc_Checks and then not Debug_Flag_Underscore_B; + begin - if Attr_Id /= Attribute_Unchecked_Access + if Attr_Id = Attribute_Access and then (Ekind (Btyp) = E_General_Access_Type or else No_Dynamic_Acc_Checks) @@ -11817,22 +11932,12 @@ package body Sem_Attr is -- Check for unrestricted access where expected type is a thin -- pointer to an unconstrained array. - elsif Has_Size_Clause (Typ) - and then RM_Size (Typ) = System_Address_Size - then - declare - DT : constant Entity_Id := Designated_Type (Typ); - begin - if Is_Array_Type (DT) - and then not Is_Constrained (DT) - then - Error_Msg_N - ("illegal use of Unrestricted_Access attribute", P); - Error_Msg_N - ("\attempt to generate thin pointer to unaliased " - & "object", P); - end if; - end; + elsif Is_Thin_Pointer_To_Unc_Array (Typ) then + Error_Msg_N + ("illegal use of Unrestricted_Access attribute", P); + Error_Msg_N + ("\attempt to generate thin pointer to unaliased " + & "object", P); end if; end if; diff --git a/gcc/ada/sem_attr.ads b/gcc/ada/sem_attr.ads index b7a0571..f383ab5 100644 --- a/gcc/ada/sem_attr.ads +++ b/gcc/ada/sem_attr.ads @@ -46,8 +46,8 @@ package Sem_Attr is -- in GNAT, as well as constructing an array of flags indicating which -- attributes these are. - Attribute_Impl_Def : constant Attribute_Class_Array := - Attribute_Class_Array'( + Attribute_Impl_Def : constant Attribute_Set := + ( ------------------ -- Abort_Signal -- diff --git a/gcc/ada/sem_aux.adb b/gcc/ada/sem_aux.adb index 658110f..e7e096f 100644 --- a/gcc/ada/sem_aux.adb +++ b/gcc/ada/sem_aux.adb @@ -728,10 +728,6 @@ package body Sem_Aux is CList : Node_Id; begin - if not Is_Type (Typ) then - return False; - end if; - FSTyp := First_Subtype (Typ); if not Has_Discriminants (FSTyp) then diff --git a/gcc/ada/sem_case.adb b/gcc/ada/sem_case.adb index f649122..0842f94 100644 --- a/gcc/ada/sem_case.adb +++ b/gcc/ada/sem_case.adb @@ -2752,7 +2752,7 @@ package body Sem_Case is procedure Test_Point_For_Match is function In_Range (Val : Uint; Rang : Discrete_Range_Info) return Boolean is - ((Rang.Low <= Val) and then (Val <= Rang.High)); + (Rang.Low <= Val and then Val <= Rang.High); begin pragma Assert (not Done); Matches (Next_Index) := @@ -3429,8 +3429,8 @@ package body Sem_Case is Others_Seen := True; else if Flag_Overlapping_Within_One_Alternative - and then (Compare (Matches (Choice.Alternative), - Choice.Matches) /= Disjoint) + and then Compare (Matches (Choice.Alternative), + Choice.Matches) /= Disjoint then Error_Msg_N ("bad overlapping within one alternative", N); @@ -3479,7 +3479,7 @@ package body Sem_Case is Union (Target => Covered, Source => Matches (A1)); end loop; - if (not Others_Seen) and then not Complement_Is_Empty (Covered) + if not Others_Seen and then not Complement_Is_Empty (Covered) then Error_Msg_N ("not all values are covered", N); end if; @@ -3686,6 +3686,7 @@ package body Sem_Case is if not Is_Discrete_Type (E) or else not Has_Static_Predicate (E) or else Has_Dynamic_Predicate_Aspect (E) + or else Has_Ghost_Predicate_Aspect (E) then Bad_Predicated_Subtype_Use ("cannot use subtype& with non-static " @@ -3823,7 +3824,7 @@ package body Sem_Case is (Choice_Table, Bounds_Type, Subtyp, - Others_Present or else (Choice_Type = Universal_Integer), + Others_Present or else Choice_Type = Universal_Integer, N); -- If no others choice we are all done, otherwise we have one more diff --git a/gcc/ada/sem_cat.adb b/gcc/ada/sem_cat.adb index 5398153..13dff3d 100644 --- a/gcc/ada/sem_cat.adb +++ b/gcc/ada/sem_cat.adb @@ -346,14 +346,13 @@ package body Sem_Cat is if Null_Present (Recdef) then return; - else - Component_Decl := First (Component_Items (Component_List (Recdef))); end if; - while Present (Component_Decl) - and then Nkind (Component_Decl) = N_Component_Declaration - loop - if Present (Expression (Component_Decl)) + Component_Decl := First (Component_Items (Component_List (Recdef))); + + while Present (Component_Decl) loop + if Nkind (Component_Decl) = N_Component_Declaration + and then Present (Expression (Component_Decl)) and then Nkind (Expression (Component_Decl)) /= N_Null and then not Is_OK_Static_Expression (Expression (Component_Decl)) @@ -562,7 +561,7 @@ package body Sem_Cat is -- There are no constraints on the body of Remote_Call_Interface or -- Remote_Types packages. - return (Unit_Entity /= Standard_Standard) + return Unit_Entity /= Standard_Standard and then (Is_Preelaborated (Unit_Entity) or else Is_Pure (Unit_Entity) or else Is_Shared_Passive (Unit_Entity) diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb index 1c4d575..a6cbe46 100644 --- a/gcc/ada/sem_ch10.adb +++ b/gcc/ada/sem_ch10.adb @@ -85,6 +85,14 @@ package body Sem_Ch10 is procedure Analyze_Context (N : Node_Id); -- Analyzes items in the context clause of compilation unit + procedure Analyze_Required_Limited_With_Units (N : Node_Id); + -- Subsidiary of Analyze_Compilation_Unit. Perform full analysis of the + -- limited-with units of N when it is a package declaration that does not + -- require a package body, and the profile of some subprogram defined in N + -- depends on shadow incomplete type entities visible through limited-with + -- context clauses. This analysis is required to provide the backend with + -- the non-limited view of these shadow entities. + procedure Build_Limited_Views (N : Node_Id); -- Build and decorate the list of shadow entities for a package mentioned -- in a limited_with clause. If the package was not previously analyzed @@ -1390,6 +1398,13 @@ package body Sem_Ch10 is -- ensure that the pragma/aspect, if present, has been analyzed. Check_No_Elab_Code_All (N); + + -- If this is a main compilation containing a package declaration that + -- requires no package body, and the profile of some subprogram depends + -- on shadow incomplete entities then perform full analysis of its + -- limited-with units. + + Analyze_Required_Limited_With_Units (N); end Analyze_Compilation_Unit; --------------------- @@ -2024,6 +2039,149 @@ package body Sem_Ch10 is end if; end Analyze_Protected_Body_Stub; + ----------------------------------------- + -- Analyze_Required_Limited_With_Units -- + ----------------------------------------- + + procedure Analyze_Required_Limited_With_Units (N : Node_Id) is + Unit_Node : constant Node_Id := Unit (N); + Spec_Id : constant Entity_Id := Defining_Entity (Unit_Node); + + function Depends_On_Limited_Views (Pkg_Id : Entity_Id) return Boolean; + -- Determines whether the given package has some subprogram with a + -- profile that depends on shadow incomplete type entities of a + -- limited-with unit. + + function Has_Limited_With_Clauses return Boolean; + -- Determines whether the compilation unit N has limited-with context + -- clauses. + + ------------------------------ + -- Has_Limited_With_Clauses -- + ------------------------------ + + function Has_Limited_With_Clauses return Boolean is + Item : Node_Id := First (Context_Items (N)); + + begin + while Present (Item) loop + if Nkind (Item) = N_With_Clause + and then Limited_Present (Item) + and then not Implicit_With (Item) + then + return True; + end if; + + Next (Item); + end loop; + + return False; + end Has_Limited_With_Clauses; + + ------------------------------ + -- Depends_On_Limited_Views -- + ------------------------------ + + function Depends_On_Limited_Views (Pkg_Id : Entity_Id) return Boolean is + + function Has_Limited_View_Types (Subp : Entity_Id) return Boolean; + -- Determines whether the type of some formal of Subp, or its return + -- type, is a shadow incomplete entity of a limited-with unit. + + ---------------------------- + -- Has_Limited_View_Types -- + ---------------------------- + + function Has_Limited_View_Types (Subp : Entity_Id) return Boolean is + Formal : Entity_Id := First_Formal (Subp); + + begin + while Present (Formal) loop + if From_Limited_With (Etype (Formal)) + and then Has_Non_Limited_View (Etype (Formal)) + and then Ekind (Non_Limited_View (Etype (Formal))) + = E_Incomplete_Type + then + return True; + end if; + + Formal := Next_Formal (Formal); + end loop; + + if Ekind (Subp) = E_Function + and then From_Limited_With (Etype (Subp)) + and then Has_Non_Limited_View (Etype (Subp)) + and then Ekind (Non_Limited_View (Etype (Subp))) + = E_Incomplete_Type + then + return True; + end if; + + return False; + end Has_Limited_View_Types; + + -- Local variables + + E : Entity_Id := First_Entity (Pkg_Id); + + begin + while Present (E) loop + if Is_Subprogram (E) + and then Has_Limited_View_Types (E) + then + return True; + + -- Recursion on nested packages skipping package renamings + + elsif Ekind (E) = E_Package + and then No (Renamed_Entity (E)) + and then Depends_On_Limited_Views (E) + then + return True; + end if; + + Next_Entity (E); + end loop; + + return False; + end Depends_On_Limited_Views; + + -- Local variables + + Item : Node_Id; + + -- Start of processing for Analyze_Required_Limited_With_Units + + begin + -- Cases where no action is required + + if not Expander_Active + or else Nkind (Unit_Node) /= N_Package_Declaration + or else Main_Unit_Entity /= Spec_Id + or else Is_Generic_Unit (Spec_Id) + or else Unit_Requires_Body (Spec_Id) + or else not Has_Limited_With_Clauses + or else not Depends_On_Limited_Views (Spec_Id) + then + return; + end if; + + -- Perform full analyis of limited-with units to provide the backend + -- with the full-view of shadow entities. + + Item := First (Context_Items (N)); + while Present (Item) loop + if Nkind (Item) = N_With_Clause + and then Limited_Present (Item) + and then not Implicit_With (Item) + then + Semantics (Library_Unit (Item)); + end if; + + Next (Item); + end loop; + end Analyze_Required_Limited_With_Units; + ---------------------------------- -- Analyze_Subprogram_Body_Stub -- ---------------------------------- @@ -2051,8 +2209,8 @@ package body Sem_Ch10 is Decl := First (Declarations (Parent (N))); while Present (Decl) and then Decl /= N loop if Nkind (Decl) = N_Subprogram_Body_Stub - and then (Chars (Defining_Unit_Name (Specification (Decl))) = - Chars (Defining_Unit_Name (Specification (N)))) + and then Chars (Defining_Unit_Name (Specification (Decl))) = + Chars (Defining_Unit_Name (Specification (N))) then Error_Msg_N ("identifier for stub is not unique", N); end if; @@ -3148,6 +3306,7 @@ package body Sem_Ch10 is -- incomplete type, and carries the corresponding attributes. Mutate_Ekind (Ent, E_Incomplete_Type); + Set_Is_Not_Self_Hidden (Ent); Set_Etype (Ent, Ent); Set_Full_View (Ent, Empty); Set_Is_First_Subtype (Ent); @@ -4194,6 +4353,10 @@ package body Sem_Ch10 is Set_Subtype_Indication (Decl, New_Occurrence_Of (Non_Lim_View, Sloc (Def_Id))); Set_Etype (Def_Id, Non_Lim_View); + Reinit_Field_To_Zero (Def_Id, F_Non_Limited_View, + Old_Ekind => (E_Incomplete_Subtype => True, + others => False)); + Reinit_Field_To_Zero (Def_Id, F_Private_Dependents); Mutate_Ekind (Def_Id, Subtype_Kind (Ekind (Non_Lim_View))); Set_Analyzed (Decl, False); @@ -4696,9 +4859,9 @@ package body Sem_Ch10 is -- Save for subsequent examination of import pragmas. if Comes_From_Source (Decl) - and then (Nkind (Decl) in N_Subprogram_Declaration - | N_Subprogram_Renaming_Declaration - | N_Generic_Subprogram_Declaration) + and then Nkind (Decl) in N_Subprogram_Declaration + | N_Subprogram_Renaming_Declaration + | N_Generic_Subprogram_Declaration then Append_Elmt (Defining_Entity (Decl), Subp_List); @@ -5827,7 +5990,8 @@ package body Sem_Ch10 is Mutate_Ekind (Shadow, Ekind (Ent)); end if; - Set_Is_Internal (Shadow); + Set_Is_Not_Self_Hidden (Shadow); + Set_Is_Internal (Shadow); Set_From_Limited_With (Shadow); -- Add the new shadow entity to the limited view of the package @@ -5894,6 +6058,7 @@ package body Sem_Ch10 is procedure Decorate_State (Ent : Entity_Id; Scop : Entity_Id) is begin Mutate_Ekind (Ent, E_Abstract_State); + Set_Is_Not_Self_Hidden (Ent); Set_Etype (Ent, Standard_Void_Type); Set_Scope (Ent, Scop); Set_Encapsulating_State (Ent, Empty); @@ -6254,11 +6419,12 @@ package body Sem_Ch10 is raise Program_Error; end case; - -- The withed unit may not be analyzed, but the with calause itself + -- The withed unit may not be analyzed, but the with clause itself -- must be minimally decorated. This ensures that the checks on unused -- with clauses also process limieted withs. Mutate_Ekind (Pack, E_Package); + Set_Is_Not_Self_Hidden (Pack); Set_Etype (Pack, Standard_Void_Type); if Is_Entity_Name (Nam) then diff --git a/gcc/ada/sem_ch11.adb b/gcc/ada/sem_ch11.adb index 401e2be..73eca7a 100644 --- a/gcc/ada/sem_ch11.adb +++ b/gcc/ada/sem_ch11.adb @@ -120,7 +120,7 @@ package body Sem_Ch11 is elsif Nkind (Id1) /= N_Others_Choice and then (Id_Entity = Entity (Id1) - or else (Id_Entity = Renamed_Entity (Entity (Id1)))) + or else Id_Entity = Renamed_Entity (Entity (Id1))) then if Handler /= Parent (Id) then Error_Msg_Sloc := Sloc (Id1); @@ -136,10 +136,10 @@ package body Sem_Ch11 is end if; end if; - Next_Non_Pragma (Id1); + Next (Id1); end loop; - Next (Handler); + Next_Non_Pragma (Handler); end loop; end Check_Duplication; @@ -151,15 +151,13 @@ package body Sem_Ch11 is H : Node_Id; begin - H := First (L); + H := First_Non_Pragma (L); while Present (H) loop - if Nkind (H) /= N_Pragma - and then Nkind (First (Exception_Choices (H))) = N_Others_Choice - then + if Nkind (First (Exception_Choices (H))) = N_Others_Choice then return True; end if; - Next (H); + Next_Non_Pragma (H); end loop; return False; @@ -234,6 +232,7 @@ package body Sem_Ch11 is Enter_Name (Choice); Mutate_Ekind (Choice, E_Variable); + Set_Is_Not_Self_Hidden (Choice); if RTE_Available (RE_Exception_Occurrence) then Set_Etype (Choice, RTE (RE_Exception_Occurrence)); @@ -544,11 +543,12 @@ package body Sem_Ch11 is if Present (P) and then Nkind (P) = N_Assignment_Statement then L := Name (P); - -- Give warning for assignment to scalar formal + -- Give warning for assignment to by-copy formal - if Is_Scalar_Type (Etype (L)) - and then Is_Entity_Name (L) + if Is_Entity_Name (L) and then Is_Formal (Entity (L)) + and then Is_By_Copy_Type (Etype (L)) + and then not Is_Aliased (Entity (L)) -- Do this only for parameters to the current subprogram. -- This avoids some false positives for the nested case. diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 39ceaf7..d5280ce 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -261,9 +261,11 @@ package body Sem_Ch12 is -- as annotations: -- package subprogram [body] - -- Abstract_State Contract_Cases - -- Initial_Condition Depends - -- Initializes Extensions_Visible + -- Abstract_State Always_Terminates + -- Initial_Condition Contract_Cases + -- Initializes Depends + -- Exceptional_Cases + -- Extensions_Visible -- Global -- package body Post -- Refined_State Post_Class @@ -658,6 +660,9 @@ package body Sem_Ch12 is -- the instance and the generic, so that the back-end can establish the -- proper order of elaboration. + function Get_Associated_Entity (Id : Entity_Id) return Entity_Id; + -- Similar to Get_Associated_Node below, but for entities + function Get_Associated_Node (N : Node_Id) return Node_Id; -- In order to propagate semantic information back from the analyzed copy -- to the original generic, we maintain links between selected nodes in the @@ -3186,6 +3191,7 @@ package body Sem_Ch12 is Renaming_In_Par := Make_Defining_Identifier (Loc, Chars (Gen_Unit)); Mutate_Ekind (Renaming_In_Par, E_Package); + Set_Is_Not_Self_Hidden (Renaming_In_Par); Set_Etype (Renaming_In_Par, Standard_Void_Type); Set_Scope (Renaming_In_Par, Parent_Instance); Set_Parent (Renaming_In_Par, Parent (Formal)); @@ -3846,6 +3852,7 @@ package body Sem_Ch12 is Enter_Name (Id); Mutate_Ekind (Id, E_Generic_Package); + Set_Is_Not_Self_Hidden (Id); Set_Etype (Id, Standard_Void_Type); -- Set SPARK_Mode from context @@ -4093,6 +4100,8 @@ package body Sem_Ch12 is Set_Etype (Id, Standard_Void_Type); end if; + Set_Is_Not_Self_Hidden (Id); + -- Analyze the aspects of the generic copy to ensure that all generated -- pragmas (if any) perform their semantic effects. @@ -4336,6 +4345,7 @@ package body Sem_Ch12 is Generate_Definition (Act_Decl_Id); Mutate_Ekind (Act_Decl_Id, E_Package); + Set_Is_Not_Self_Hidden (Act_Decl_Id); -- Initialize list of incomplete actuals before analysis @@ -4788,91 +4798,68 @@ package body Sem_Ch12 is Needs_Body := False; end if; + -- If the context requires a full instantiation, set things up for + -- subsequent construction of the body. + if Needs_Body then - -- Indicate that the enclosing scopes contain an instantiation, - -- and that cleanup actions should be delayed until after the - -- instance body is expanded. + declare + Fin_Scop, S : Entity_Id; - Check_Forward_Instantiation (Gen_Decl); - if Nkind (N) = N_Package_Instantiation then - declare - Enclosing_Master : Entity_Id; + begin + Check_Forward_Instantiation (Gen_Decl); - begin - -- Loop to search enclosing masters - - Enclosing_Master := Current_Scope; - Scope_Loop : while Enclosing_Master /= Standard_Standard loop - if Ekind (Enclosing_Master) = E_Package then - if Is_Compilation_Unit (Enclosing_Master) then - if In_Package_Body (Enclosing_Master) then - Set_Delay_Subprogram_Descriptors - (Body_Entity (Enclosing_Master)); - else - Set_Delay_Subprogram_Descriptors - (Enclosing_Master); - end if; + Fin_Scop := Empty; - exit Scope_Loop; + -- For a package instantiation that is not a compilation unit, + -- indicate that cleanup actions of the innermost enclosing + -- scope for which they are generated should be delayed until + -- after the package body is instantiated. - else - Enclosing_Master := Scope (Enclosing_Master); - end if; + if Nkind (N) = N_Package_Instantiation + and then not Is_Compilation_Unit (Act_Decl_Id) + then + S := Current_Scope; + + while S /= Standard_Standard loop + -- Cleanup actions are not generated within generic units + -- or in the formal part of generic units. - elsif Is_Generic_Unit (Enclosing_Master) - or else Ekind (Enclosing_Master) = E_Void + if Inside_A_Generic + or else Is_Generic_Unit (S) + or else Ekind (S) = E_Void then - -- Cleanup actions will eventually be performed on the - -- enclosing subprogram or package instance, if any. - -- Enclosing scope is void in the formal part of a - -- generic subprogram. + exit; - exit Scope_Loop; + -- For package scopes, cleanup actions are generated only + -- for compilation units, for spec and body separately. - else - if Ekind (Enclosing_Master) = E_Entry - and then - Ekind (Scope (Enclosing_Master)) = E_Protected_Type - then - if not Expander_Active then - exit Scope_Loop; + elsif Ekind (S) = E_Package then + if Is_Compilation_Unit (S) then + if In_Package_Body (S) then + Fin_Scop := Body_Entity (S); else - Enclosing_Master := - Protected_Body_Subprogram (Enclosing_Master); + Fin_Scop := S; end if; - end if; - - Set_Delay_Cleanups (Enclosing_Master); - while Ekind (Enclosing_Master) = E_Block loop - Enclosing_Master := Scope (Enclosing_Master); - end loop; + Set_Delay_Cleanups (Fin_Scop); + exit; - if Is_Subprogram (Enclosing_Master) then - Set_Delay_Subprogram_Descriptors (Enclosing_Master); - - elsif Is_Task_Type (Enclosing_Master) then - declare - TBP : constant Node_Id := - Get_Task_Body_Procedure - (Enclosing_Master); - begin - if Present (TBP) then - Set_Delay_Subprogram_Descriptors (TBP); - Set_Delay_Cleanups (TBP); - end if; - end; + else + S := Scope (S); end if; - exit Scope_Loop; - end if; - end loop Scope_Loop; - end; + -- Cleanup actions are generated for all dynamic scopes - -- Make entry in table + else + Fin_Scop := S; + Set_Delay_Cleanups (Fin_Scop); + exit; + end if; + end loop; + end if; - Add_Pending_Instantiation (N, Act_Decl); - end if; + Add_Pending_Instantiation (N, Act_Decl, Fin_Scop); + end; end if; Set_Categorization_From_Pragmas (Act_Decl); @@ -5002,10 +4989,12 @@ package body Sem_Ch12 is Set_First_Private_Entity (Defining_Unit_Name (Unit_Renaming), First_Private_Entity (Act_Decl_Id)); - -- If the instantiation will receive a body, the unit will be - -- transformed into a package body, and receive its own elaboration - -- entity. Otherwise, the nature of the unit is now a package - -- declaration. + -- If the instantiation needs a body, the unit will be turned into + -- a package body and receive its own elaboration entity. Otherwise, + -- the nature of the unit is now a package declaration. + + -- Note that the below rewriting means that Act_Decl, which has been + -- analyzed and expanded, will be re-expanded as the rewritten N. if Nkind (Parent (N)) = N_Compilation_Unit and then not Needs_Body @@ -5269,11 +5258,12 @@ package body Sem_Ch12 is Instantiate_Package_Body (Body_Info => - ((Act_Decl => Act_Decl, + ((Inst_Node => N, + Act_Decl => Act_Decl, + Fin_Scop => Empty, Config_Switches => Config_Attrs, Current_Sem_Unit => Current_Sem_Unit, Expander_Status => Expander_Active, - Inst_Node => N, Local_Suppress_Stack_Top => Local_Suppress_Stack_Top, Scope_Suppress => Scope_Suppress, Warnings => Save_Warnings)), @@ -5324,7 +5314,7 @@ package body Sem_Ch12 is Par : Entity_Id; begin Par := Scope (Curr_Scope); - while (Present (Par)) and then Par /= Standard_Standard loop + while Present (Par) and then Par /= Standard_Standard loop Install_Private_Declarations (Par); Par := Scope (Par); end loop; @@ -5383,11 +5373,12 @@ package body Sem_Ch12 is else Instantiate_Package_Body (Body_Info => - ((Act_Decl => Act_Decl, + ((Inst_Node => N, + Act_Decl => Act_Decl, + Fin_Scop => Empty, Config_Switches => Save_Config_Switches, Current_Sem_Unit => Current_Sem_Unit, Expander_Status => Expander_Active, - Inst_Node => N, Local_Suppress_Stack_Top => Local_Suppress_Stack_Top, Scope_Suppress => Scope_Suppress, Warnings => Save_Warnings)), @@ -6131,6 +6122,25 @@ package body Sem_Ch12 is Restore_SPARK_Mode (Saved_SM, Saved_SMP); end Analyze_Subprogram_Instantiation; + --------------------------- + -- Get_Associated_Entity -- + --------------------------- + + function Get_Associated_Entity (Id : Entity_Id) return Entity_Id is + Assoc : Entity_Id; + + begin + Assoc := Associated_Entity (Id); + + if Present (Assoc) then + while Present (Associated_Entity (Assoc)) loop + Assoc := Associated_Entity (Assoc); + end loop; + end if; + + return Assoc; + end Get_Associated_Entity; + ------------------------- -- Get_Associated_Node -- ------------------------- @@ -6976,8 +6986,63 @@ package body Sem_Ch12 is (Instance : Entity_Id; Is_Formal_Box : Boolean) is - E : Entity_Id; + Gen_Id : constant Entity_Id + := (if Is_Generic_Unit (Instance) then + Instance + elsif Is_Wrapper_Package (Instance) then + Generic_Parent + (Specification + (Unit_Declaration_Node (Related_Instance (Instance)))) + else + Generic_Parent (Package_Specification (Instance))); + -- The generic unit + + Parent_Scope : constant Entity_Id := Scope (Gen_Id); + -- The enclosing scope of the generic unit + + procedure Check_Actual_Type (Typ : Entity_Id); + -- If the type of the actual is a private type declared in the + -- enclosing scope of the generic unit, but not a derived type + -- of a private type declared elsewhere, the body of the generic + -- sees the full view of the type (because it has to appear in + -- the corresponding package body). If the type is private now, + -- exchange views to restore the proper visibility in the instance. + + ----------------------- + -- Check_Actual_Type -- + ----------------------- + + procedure Check_Actual_Type (Typ : Entity_Id) is + Btyp : constant Entity_Id := Base_Type (Typ); + + begin + -- The exchange is only needed if the generic is defined + -- within a package which is not a common ancestor of the + -- scope of the instance, and is not already in scope. + + if Is_Private_Type (Btyp) + and then Scope (Btyp) = Parent_Scope + and then not Has_Private_Ancestor (Btyp) + and then Ekind (Parent_Scope) in E_Package | E_Generic_Package + and then Scope (Instance) /= Parent_Scope + and then not Is_Child_Unit (Gen_Id) + then + Switch_View (Btyp); + + -- If the type of the entity is a subtype, it may also have + -- to be made visible, together with the base type of its + -- full view, after exchange. + + if Is_Private_Type (Typ) then + Switch_View (Typ); + Switch_View (Base_Type (Typ)); + end if; + end if; + end Check_Actual_Type; + Astype : Entity_Id; + E : Entity_Id; + Formal : Node_Id; begin E := First_Entity (Instance); @@ -7095,60 +7160,22 @@ package body Sem_Ch12 is Set_Is_Hidden (E, False); end if; - if Ekind (E) = E_Constant then - - -- If the type of the actual is a private type declared in the - -- enclosing scope of the generic unit, the body of the generic - -- sees the full view of the type (because it has to appear in - -- the corresponding package body). If the type is private now, - -- exchange views to restore the proper visiblity in the instance. - - declare - Typ : constant Entity_Id := Base_Type (Etype (E)); - -- The type of the actual - - Gen_Id : Entity_Id; - -- The generic unit + -- Check directly the type of the actual objects - Parent_Scope : Entity_Id; - -- The enclosing scope of the generic unit + if Ekind (E) in E_Constant | E_Variable then + Check_Actual_Type (Etype (E)); - begin - if Is_Wrapper_Package (Instance) then - Gen_Id := - Generic_Parent - (Specification - (Unit_Declaration_Node - (Related_Instance (Instance)))); - else - Gen_Id := - Generic_Parent (Package_Specification (Instance)); - end if; + -- As well as the type of formal parameters of actual subprograms - Parent_Scope := Scope (Gen_Id); - - -- The exchange is only needed if the generic is defined - -- within a package which is not a common ancestor of the - -- scope of the instance, and is not already in scope. - - if Is_Private_Type (Typ) - and then Scope (Typ) = Parent_Scope - and then Scope (Instance) /= Parent_Scope - and then Ekind (Parent_Scope) = E_Package - and then not Is_Child_Unit (Gen_Id) - then - Switch_View (Typ); - - -- If the type of the entity is a subtype, it may also have - -- to be made visible, together with the base type of its - -- full view, after exchange. - - if Is_Private_Type (Etype (E)) then - Switch_View (Etype (E)); - Switch_View (Base_Type (Etype (E))); - end if; - end if; - end; + elsif Ekind (E) in E_Function | E_Procedure + and then Is_Generic_Actual_Subprogram (E) + and then Present (Alias (E)) + then + Formal := First_Formal (Alias (E)); + while Present (Formal) loop + Check_Actual_Type (Etype (Formal)); + Next_Formal (Formal); + end loop; end if; Next_Entity (E); @@ -7614,46 +7641,36 @@ package body Sem_Ch12 is ------------------------ procedure Check_Private_View (N : Node_Id) is - T : constant Entity_Id := Etype (N); - BT : Entity_Id; + Typ : constant Entity_Id := Etype (N); - begin - -- Exchange views if the type was not private in the generic but is - -- private at the point of instantiation. Do not exchange views if - -- the scope of the type is in scope. This can happen if both generic - -- and instance are sibling units, or if type is defined in a parent. - -- In this case the visibility of the type will be correct for all - -- semantic checks. + procedure Check_Private_Type (T : Entity_Id; Private_View : Boolean); + -- Check that the available view of T matches Private_View and, if not, + -- switch the view of T or of its base type. + + procedure Check_Private_Type (T : Entity_Id; Private_View : Boolean) is + BT : constant Entity_Id := Base_Type (T); - if Present (T) then - BT := Base_Type (T); + begin + -- If the full declaration was not visible in the generic, stop here + + if Private_View then + return; + end if; + + -- Exchange views if the type was not private in the generic but is + -- private at the point of instantiation. Do not exchange views if + -- the scope of the type is in scope. This can happen if both generic + -- and instance are sibling units, or if type is defined in a parent. + -- In this case the visibility of the type will be correct for all + -- semantic checks. if Is_Private_Type (T) - and then not Has_Private_View (N) and then Present (Full_View (T)) and then not In_Open_Scopes (Scope (T)) then - -- In the generic, the full declaration was visible - Switch_View (T); - elsif Has_Private_View (N) - and then not Is_Private_Type (T) - and then not Has_Been_Exchanged (T) - and then (not In_Open_Scopes (Scope (T)) - or else Nkind (Parent (N)) = N_Subtype_Declaration) - then - -- In the generic, only the private declaration was visible - - -- If the type appears in a subtype declaration, the subtype in - -- instance must have a view compatible with that of its parent, - -- which must be exchanged (see corresponding code in Restore_ - -- Private_Views) so we make an exception to the open scope rule. - - Prepend_Elmt (T, Exchanged_Views); - Exchange_Declarations (Etype (Get_Associated_Node (N))); - - -- Finally, a non-private subtype may have a private base type, which + -- Finally, a nonprivate subtype may have a private base type, which -- must be exchanged for consistency. This can happen when a package -- body is instantiated, when the scope stack is empty but in fact -- the subtype and the base type are declared in an enclosing scope. @@ -7665,15 +7682,46 @@ package body Sem_Ch12 is -- provision for that case in Switch_View). elsif not Is_Private_Type (T) - and then not Has_Private_View (N) and then Is_Private_Type (BT) and then Present (Full_View (BT)) - and then not Is_Generic_Type (BT) and then not In_Open_Scopes (BT) then Prepend_Elmt (Full_View (BT), Exchanged_Views); Exchange_Declarations (BT); end if; + end Check_Private_Type; + + begin + if Present (Typ) then + -- If the type appears in a subtype declaration, the subtype in + -- instance must have a view compatible with that of its parent, + -- which must be exchanged (see corresponding code in Restore_ + -- Private_Views) so we make an exception to the open scope rule + -- implemented by Check_Private_Type above. + + if Has_Private_View (N) + and then not Is_Private_Type (Typ) + and then not Has_Been_Exchanged (Typ) + and then (not In_Open_Scopes (Scope (Typ)) + or else Nkind (Parent (N)) = N_Subtype_Declaration) + then + -- In the generic, only the private declaration was visible + + Prepend_Elmt (Typ, Exchanged_Views); + Exchange_Declarations (Etype (Get_Associated_Node (N))); + + else + Check_Private_Type (Typ, Has_Private_View (N)); + + if Is_Access_Type (Typ) then + Check_Private_Type + (Designated_Type (Typ), Has_Secondary_Private_View (N)); + + elsif Is_Array_Type (Typ) then + Check_Private_Type + (Component_Type (Typ), Has_Secondary_Private_View (N)); + end if; + end if; end if; end Check_Private_View; @@ -7966,11 +8014,11 @@ package body Sem_Ch12 is -- Special casing for identifiers and other entity names and operators - if Nkind (New_N) in N_Character_Literal - | N_Expanded_Name - | N_Identifier - | N_Operator_Symbol - | N_Op + if Nkind (N) in N_Character_Literal + | N_Expanded_Name + | N_Identifier + | N_Operator_Symbol + | N_Op then if not Instantiating then @@ -8049,115 +8097,34 @@ package body Sem_Ch12 is Set_Entity (New_N, Entity (Assoc)); Check_Private_View (N); - -- Here we deal with a very peculiar case for which the - -- Has_Private_View mechanism is not sufficient, because - -- the reference to the type is implicit in the tree, - -- that is to say, it's not referenced from a node but - -- only from another type, namely through Component_Type. - - -- package P is - - -- type Pt is private; - - -- generic - -- type Ft is array (Positive range <>) of Pt; - -- package G is - -- procedure Check (F1, F2 : Ft; Lt : Boolean); - -- end G; - - -- private - -- type Pt is new Boolean; - -- end P; - - -- package body P is - -- package body G is - -- procedure Check (F1, F2 : Ft; Lt : Boolean) is - -- begin - -- if (F1 < F2) /= Lt then - -- null; - -- end if; - -- end Check; - -- end G; - -- end P; - - -- type Arr is array (Positive range <>) of P.Pt; - - -- package Inst is new P.G (Arr); - - -- Pt is a global type for the generic package G and it - -- is not referenced in its body, but only as component - -- type of Ft, which is a local type. This means that no - -- references to Pt or Ft are seen during the copy of the - -- body, the only reference to Pt being seen is when the - -- actuals are checked by Check_Generic_Actuals, but Pt - -- is still private at this point. In the end, the views - -- of Pt are not switched in the body and, therefore, the - -- array comparison is rejected because the component is - -- still private. - - -- Adding e.g. a dummy variable of type Pt in the body is - -- sufficient to make everything work, so we generate an - -- artificial reference to Pt on the fly and thus force - -- the switching of views on the grounds that, if the - -- comparison was accepted during the semantic analysis - -- of the generic, this means that the component cannot - -- have been private (see Sem_Type.Valid_Comparison_Arg). - - if Nkind (Assoc) in N_Op_Compare - and then Present (Etype (Left_Opnd (Assoc))) - and then Is_Array_Type (Etype (Left_Opnd (Assoc))) - and then Present (Etype (Right_Opnd (Assoc))) - and then Is_Array_Type (Etype (Right_Opnd (Assoc))) + -- For the comparison and equality operators, the Etype + -- of the operator does not provide any information so, + -- if one of the operands is of a universal type, we need + -- to manually restore the full view of private types. + + if Nkind (N) in N_Op_Eq + | N_Op_Ge + | N_Op_Gt + | N_Op_Le + | N_Op_Lt + | N_Op_Ne then - declare - Ltyp : constant Entity_Id := - Etype (Left_Opnd (Assoc)); - Rtyp : constant Entity_Id := - Etype (Right_Opnd (Assoc)); - begin - if Is_Private_Type (Component_Type (Ltyp)) then - Check_Private_View - (New_Occurrence_Of (Component_Type (Ltyp), - Sloc (N))); - end if; - if Is_Private_Type (Component_Type (Rtyp)) then - Check_Private_View - (New_Occurrence_Of (Component_Type (Rtyp), - Sloc (N))); + if Yields_Universal_Type (Left_Opnd (Assoc)) then + if Present (Etype (Right_Opnd (Assoc))) + and then + Is_Private_Type (Etype (Right_Opnd (Assoc))) + then + Switch_View (Etype (Right_Opnd (Assoc))); end if; - end; - - -- Here is a similar case, for the Designated_Type of an - -- access type that is present as target type in a type - -- conversion from another access type. In this case, if - -- the base types of the designated types are different - -- and the conversion was accepted during the semantic - -- analysis of the generic, this means that the target - -- type cannot have been private (see Valid_Conversion). - - elsif Nkind (Assoc) = N_Identifier - and then Nkind (Parent (Assoc)) = N_Type_Conversion - and then Subtype_Mark (Parent (Assoc)) = Assoc - and then Present (Etype (Assoc)) - and then Is_Access_Type (Etype (Assoc)) - and then Present (Etype (Expression (Parent (Assoc)))) - and then - Is_Access_Type (Etype (Expression (Parent (Assoc)))) - then - declare - Targ_Desig : constant Entity_Id := - Designated_Type (Etype (Assoc)); - Expr_Desig : constant Entity_Id := - Designated_Type - (Etype (Expression (Parent (Assoc)))); - begin - if Base_Type (Targ_Desig) /= Base_Type (Expr_Desig) - and then Is_Private_Type (Targ_Desig) + + elsif Yields_Universal_Type (Right_Opnd (Assoc)) then + if Present (Etype (Left_Opnd (Assoc))) + and then + Is_Private_Type (Etype (Left_Opnd (Assoc))) then - Check_Private_View - (New_Occurrence_Of (Targ_Desig, Sloc (N))); + Switch_View (Etype (Left_Opnd (Assoc))); end if; - end; + end if; end if; -- The node is a reference to a global type and acts as the @@ -8174,6 +8141,15 @@ package body Sem_Ch12 is then Set_Entity (New_N, Assoc); + -- Cope with the rewriting into expanded name that may have + -- occurred in between, e.g. in Check_Generic_Child_Unit for + -- generic renaming declarations. + + elsif Nkind (Assoc) = N_Expanded_Name then + Rewrite (N, New_Copy_Tree (Assoc)); + Set_Associated_Node (N, Assoc); + return Copy_Generic_Node (N, Parent_Id, Instantiating); + -- The name in the call may be a selected component if the -- call has not been analyzed yet, as may be the case for -- pre/post conditions in a generic unit. @@ -8182,12 +8158,13 @@ package body Sem_Ch12 is and then Is_Entity_Name (Name (Assoc)) then Set_Entity (New_N, Entity (Name (Assoc))); + Check_Private_View (N); elsif Nkind (Assoc) in N_Entity - and then (Expander_Active or - (GNATprove_Mode - and then not In_Spec_Expression - and then not Inside_A_Generic)) + and then (Expander_Active + or else (GNATprove_Mode + and then not In_Spec_Expression + and then not Inside_A_Generic)) then -- Inlining case: we are copying a tree that contains -- global entities, which are preserved in the copy to be @@ -8408,7 +8385,7 @@ package body Sem_Ch12 is -- install the full view (and that of its ancestors, if any). declare - T : Entity_Id := (Etype (Get_Associated_Node (New_N))); + T : Entity_Id := Etype (Get_Associated_Node (N)); Rt : Entity_Id; begin @@ -8494,6 +8471,32 @@ package body Sem_Ch12 is Copy_Descendants; end; + -- Iterator and loop parameter specifications do not have an identifier + -- denoting the index type, so we must locate it through the expression + -- to check whether the views are consistent. + + elsif Nkind (N) in N_Iterator_Specification + | N_Loop_Parameter_Specification + and then Instantiating + then + declare + Id : constant Entity_Id := + Get_Associated_Entity (Defining_Identifier (N)); + + Index_T : Entity_Id; + + begin + if Present (Id) and then Present (Etype (Id)) then + Index_T := First_Subtype (Etype (Id)); + + if Present (Index_T) and then Is_Private_Type (Index_T) then + Switch_View (Index_T); + end if; + end if; + + Copy_Descendants; + end; + -- For a proper body, we must catch the case of a proper body that -- replaces a stub. This represents the point at which a separate -- compilation unit, and hence template file, may be referenced, so we @@ -11924,12 +11927,6 @@ package body Sem_Ch12 is return; end if; - -- The package being instantiated may be subject to pragma Ghost. Set - -- the mode now to ensure that any nodes generated during instantiation - -- are properly marked as Ghost. - - Set_Ghost_Mode (Act_Decl_Id); - Expander_Mode_Save_And_Set (Body_Info.Expander_Status); -- Re-establish the state of information on which checks are suppressed. @@ -12042,6 +12039,12 @@ package body Sem_Ch12 is Instantiation_Node := Inst_Node; end if; + -- The package being instantiated may be subject to pragma Ghost. Set + -- the mode now to ensure that any nodes generated during instantiation + -- are properly marked as Ghost. + + Set_Ghost_Mode (Act_Decl_Id); + if Present (Gen_Body_Id) then Save_Env (Gen_Unit, Act_Decl_Id); Style_Check := False; @@ -12175,9 +12178,6 @@ package body Sem_Ch12 is and then Nkind (Gen_Id) = N_Expanded_Name then Par_Ent := Entity (Prefix (Gen_Id)); - Par_Vis := Is_Immediately_Visible (Par_Ent); - Install_Parent (Par_Ent, In_Body => True); - Par_Installed := True; elsif Ekind (Scope (Gen_Unit)) = E_Generic_Package and then Ekind (Scope (Act_Decl_Id)) = E_Package @@ -12189,12 +12189,12 @@ package body Sem_Ch12 is Par_Ent := Entity (Prefix (Name (Get_Unit_Instantiation_Node (Scope (Act_Decl_Id))))); - Par_Vis := Is_Immediately_Visible (Par_Ent); - Install_Parent (Par_Ent, In_Body => True); - Par_Installed := True; elsif Is_Child_Unit (Gen_Unit) then Par_Ent := Scope (Gen_Unit); + end if; + + if Present (Par_Ent) then Par_Vis := Is_Immediately_Visible (Par_Ent); Install_Parent (Par_Ent, In_Body => True); Par_Installed := True; @@ -12484,12 +12484,6 @@ package body Sem_Ch12 is return; end if; - -- The subprogram being instantiated may be subject to pragma Ghost. Set - -- the mode now to ensure that any nodes generated during instantiation - -- are properly marked as Ghost. - - Set_Ghost_Mode (Act_Decl_Id); - Expander_Mode_Save_And_Set (Body_Info.Expander_Status); -- Re-establish the state of information on which checks are suppressed. @@ -12527,6 +12521,12 @@ package body Sem_Ch12 is Instantiation_Node := Inst_Node; + -- The subprogram being instantiated may be subject to pragma Ghost. Set + -- the mode now to ensure that any nodes generated during instantiation + -- are properly marked as Ghost. + + Set_Ghost_Mode (Act_Decl_Id); + if Present (Gen_Body_Id) then Gen_Body := Unit_Declaration_Node (Gen_Body_Id); @@ -12611,12 +12611,11 @@ package body Sem_Ch12 is and then Nkind (Gen_Id) = N_Expanded_Name then Par_Ent := Entity (Prefix (Gen_Id)); - Par_Vis := Is_Immediately_Visible (Par_Ent); - Install_Parent (Par_Ent, In_Body => True); - Par_Installed := True; - elsif Is_Child_Unit (Gen_Unit) then Par_Ent := Scope (Gen_Unit); + end if; + + if Present (Par_Ent) then Par_Vis := Is_Immediately_Visible (Par_Ent); Install_Parent (Par_Ent, In_Body => True); Par_Installed := True; @@ -14317,6 +14316,13 @@ package body Sem_Ch12 is if Is_Private_Type (Act_T) then Set_Has_Private_View (Subtype_Indication (Decl_Node)); + + elsif (Is_Access_Type (Act_T) + and then Is_Private_Type (Designated_Type (Act_T))) + or else (Is_Array_Type (Act_T) + and then Is_Private_Type (Component_Type (Act_T))) + then + Set_Has_Secondary_Private_View (Subtype_Indication (Decl_Node)); end if; -- In Ada 2012 the actual may be a limited view. Indicate that @@ -14715,13 +14721,14 @@ package body Sem_Ch12 is Decl := First_Elmt (Previous_Instances); while Present (Decl) loop Info := - (Act_Decl => + (Inst_Node => Node (Decl), + Act_Decl => Instance_Spec (Node (Decl)), + Fin_Scop => Empty, Config_Switches => Save_Config_Switches, Current_Sem_Unit => Get_Code_Unit (Sloc (Node (Decl))), Expander_Status => Exp_Status, - Inst_Node => Node (Decl), Local_Suppress_Stack_Top => Local_Suppress_Stack_Top, Scope_Suppress => Scope_Suppress, @@ -14775,12 +14782,13 @@ package body Sem_Ch12 is Instantiate_Package_Body (Body_Info => - ((Act_Decl => True_Parent, + ((Inst_Node => Inst_Node, + Act_Decl => True_Parent, + Fin_Scop => Empty, Config_Switches => Save_Config_Switches, Current_Sem_Unit => Get_Code_Unit (Sloc (Inst_Node)), Expander_Status => Exp_Status, - Inst_Node => Inst_Node, Local_Suppress_Stack_Top => Local_Suppress_Stack_Top, Scope_Suppress => Scope_Suppress, Warnings => Save_Warnings)), @@ -15722,6 +15730,13 @@ package body Sem_Ch12 is -- This is the recursive procedure that does the work, once the -- enclosing generic scope has been established. + procedure Set_Global_Type (N : Node_Id; N2 : Node_Id); + -- If the type of N2 is global to the generic unit, save the type in + -- the generic node. Just as we perform name capture for explicit + -- references within the generic, we must capture the global types + -- of local entities because they may participate in resolution in + -- the instance. + --------------- -- Is_Global -- --------------- @@ -15915,67 +15930,12 @@ package body Sem_Ch12 is ------------------ procedure Reset_Entity (N : Node_Id) is - procedure Set_Global_Type (N : Node_Id; N2 : Node_Id); - -- If the type of N2 is global to the generic unit, save the type in - -- the generic node. Just as we perform name capture for explicit - -- references within the generic, we must capture the global types - -- of local entities because they may participate in resolution in - -- the instance. - function Top_Ancestor (E : Entity_Id) return Entity_Id; -- Find the ultimate ancestor of the current unit. If it is not a -- generic unit, then the name of the current unit in the prefix of -- an expanded name must be replaced with its generic homonym to -- ensure that it will be properly resolved in an instance. - --------------------- - -- Set_Global_Type -- - --------------------- - - procedure Set_Global_Type (N : Node_Id; N2 : Node_Id) is - Typ : constant Entity_Id := Etype (N2); - - begin - Set_Etype (N, Typ); - - -- If the entity of N is not the associated node, this is a - -- nested generic and it has an associated node as well, whose - -- type is already the full view (see below). Indicate that the - -- original node has a private view. - - if Entity (N) /= N2 and then Has_Private_View (Entity (N)) then - Set_Has_Private_View (N); - end if; - - -- If not a private type, nothing else to do - - if not Is_Private_Type (Typ) then - null; - - -- If it is a derivation of a private type in a context where no - -- full view is needed, nothing to do either. - - elsif No (Full_View (Typ)) and then Typ /= Etype (Typ) then - null; - - -- Otherwise mark the type for flipping and use the full view when - -- available. - - else - Set_Has_Private_View (N); - - if Present (Full_View (Typ)) then - Set_Etype (N2, Full_View (Typ)); - end if; - end if; - - if Is_Floating_Point_Type (Typ) - and then Has_Dimension_System (Typ) - then - Copy_Dimensions (N2, N); - end if; - end Set_Global_Type; - ------------------ -- Top_Ancestor -- ------------------ @@ -16414,7 +16374,7 @@ package body Sem_Ch12 is return Is_Generic_Declaration_Or_Body (Unit_Declaration_Node - (Associated_Entity (Defining_Entity (Nod)))); + (Get_Associated_Entity (Defining_Entity (Nod)))); -- Otherwise the generic unit being processed is not the top -- level template. It is safe to capture of global references @@ -16579,7 +16539,7 @@ package body Sem_Ch12 is E := Entity (Name (N2)); if Present (E) and then Is_Global (E) then - Set_Etype (N, Etype (N2)); + Set_Global_Type (N, N2); else Set_Associated_Node (N, Empty); Set_Etype (N, Empty); @@ -16613,8 +16573,10 @@ package body Sem_Ch12 is and then Is_Global (Entity (Prefix (N2))) then Set_Associated_Node (N, Prefix (N2)); + Set_Global_Type (N, Prefix (N2)); elsif Nkind (Prefix (N2)) = N_Function_Call + and then Is_Entity_Name (Name (Prefix (N2))) and then Present (Entity (Name (Prefix (N2)))) and then Is_Global (Entity (Name (Prefix (N2)))) then @@ -16625,6 +16587,9 @@ package body Sem_Ch12 is Name => New_Occurrence_Of (Entity (Name (Prefix (N2))), Loc)))); + Set_Associated_Node + (Name (Prefix (N)), Name (Prefix (N2))); + Set_Global_Type (Name (Prefix (N)), Name (Prefix (N2))); else Set_Associated_Node (N, Empty); @@ -16650,15 +16615,16 @@ package body Sem_Ch12 is procedure Save_References_In_Operator (N : Node_Id) is begin + N2 := Get_Associated_Node (N); + -- The node did not undergo a transformation - if Nkind (N) = Nkind (Get_Associated_Node (N)) then + if Nkind (N) = Nkind (N2) then if Nkind (N) = N_Op_Concat then - Set_Is_Component_Left_Opnd (N, - Is_Component_Left_Opnd (Get_Associated_Node (N))); - - Set_Is_Component_Right_Opnd (N, - Is_Component_Right_Opnd (Get_Associated_Node (N))); + Set_Is_Component_Left_Opnd + (N, Is_Component_Left_Opnd (N2)); + Set_Is_Component_Right_Opnd + (N, Is_Component_Right_Opnd (N2)); end if; Reset_Entity (N); @@ -16668,8 +16634,6 @@ package body Sem_Ch12 is -- applicable. else - N2 := Get_Associated_Node (N); - -- The operator resoved to a function call if Nkind (N2) = N_Function_Call then @@ -16684,7 +16648,7 @@ package body Sem_Ch12 is E := Entity (Name (N2)); if Present (E) and then Is_Global (E) then - Set_Etype (N, Etype (N2)); + Set_Global_Type (N, N2); else Set_Associated_Node (N, Empty); Set_Etype (N, Empty); @@ -16851,6 +16815,66 @@ package body Sem_Ch12 is end if; end Save_References; + --------------------- + -- Set_Global_Type -- + --------------------- + + procedure Set_Global_Type (N : Node_Id; N2 : Node_Id) is + Typ : constant Entity_Id := Etype (N2); + + begin + Set_Etype (N, Typ); + + -- If the entity of N is not the associated node, this is a + -- nested generic and it has an associated node as well, whose + -- type is already the full view (see below). Indicate that the + -- original node has a private view. + + if Entity (N) /= N2 then + if Has_Private_View (Entity (N)) then + Set_Has_Private_View (N); + end if; + + if Has_Secondary_Private_View (Entity (N)) then + Set_Has_Secondary_Private_View (N); + end if; + end if; + + -- If not a private type, deal with a secondary private view + + if not Is_Private_Type (Typ) then + if (Is_Access_Type (Typ) + and then Is_Private_Type (Designated_Type (Typ))) + or else (Is_Array_Type (Typ) + and then Is_Private_Type (Component_Type (Typ))) + then + Set_Has_Secondary_Private_View (N); + end if; + + -- If it is a derivation of a private type in a context where no + -- full view is needed, nothing to do either. + + elsif No (Full_View (Typ)) and then Typ /= Etype (Typ) then + null; + + -- Otherwise mark the type for flipping and use the full view when + -- available. + + else + Set_Has_Private_View (N); + + if Present (Full_View (Typ)) then + Set_Etype (N2, Full_View (Typ)); + end if; + end if; + + if Is_Floating_Point_Type (Typ) + and then Has_Dimension_System (Typ) + then + Copy_Dimensions (N2, N); + end if; + end Set_Global_Type; + -- Start of processing for Save_Global_References begin diff --git a/gcc/ada/sem_ch12.ads b/gcc/ada/sem_ch12.ads index 52e100e..3bf8fe9 100644 --- a/gcc/ada/sem_ch12.ads +++ b/gcc/ada/sem_ch12.ads @@ -204,7 +204,9 @@ package Sem_Ch12 is -- the current view after instantiation. The processing is driven by the -- current private status of the type of the node, and Has_Private_View, -- a flag that is set at the point of generic compilation. If view and - -- flag are inconsistent then the type is updated appropriately. + -- flag are inconsistent then the type is updated appropriately. A second + -- flag Has_Secondary_Private_View is used to update a second type related + -- to this type if need be. -- -- This subprogram is used in Check_Generic_Actuals and Copy_Generic_Node, -- and is exported here for the purpose of front-end inlining (see Exp_Ch6. diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 0d311ca..c3ea8d63 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -38,6 +38,7 @@ with Exp_Ch3; use Exp_Ch3; with Exp_Disp; use Exp_Disp; with Exp_Tss; use Exp_Tss; with Exp_Util; use Exp_Util; +with Expander; use Expander; with Freeze; use Freeze; with Ghost; use Ghost; with Lib; use Lib; @@ -132,9 +133,7 @@ package body Sem_Ch13 is function Build_Predicate_Function_Declaration (Typ : Entity_Id) return Node_Id; -- Build the declaration for a predicate function. The declaration is built - -- at the end of the declarative part containing the type definition, which - -- may be before the freeze point of the type. The predicate expression is - -- preanalyzed at this point, to catch visibility errors. + -- at the same time as the body but inserted before, as explained below. procedure Build_Predicate_Function (Typ : Entity_Id; N : Node_Id); -- If Typ has predicates (indicated by Has_Predicates being set for Typ), @@ -427,7 +426,9 @@ package body Sem_Ch13 is procedure Adjust_Record_For_Reverse_Bit_Order (R : Entity_Id) is Max_Machine_Scalar_Size : constant Uint := - UI_From_Int (System_Max_Integer_Size); + UI_From_Int (if Reverse_Bit_Order_Threshold >= 0 + then Reverse_Bit_Order_Threshold + else System_Max_Integer_Size); -- We use this as the maximum machine scalar size SSU : constant Uint := UI_From_Int (System_Storage_Unit); @@ -1408,20 +1409,39 @@ package body Sem_Ch13 is Is_Instance : Boolean := False); -- Subsidiary to the analysis of aspects -- Abstract_State + -- Always_Terminates -- Attach_Handler + -- Async_Readers + -- Async_Writers + -- Constant_After_Elaboration -- Contract_Cases + -- Convention + -- Default_Initial_Condition + -- Default_Storage_Pool -- Depends + -- Effective_Reads + -- Effective_Writes + -- Exceptional_Cases + -- Extensions_Visible -- Ghost -- Global -- Initial_Condition -- Initializes + -- Max_Entry_Queue_Depth + -- Max_Entry_Queue_Length + -- Max_Queue_Length + -- No_Caching + -- Part_Of -- Post -- Pre -- Refined_Depends -- Refined_Global + -- Refined_Post -- Refined_State -- SPARK_Mode + -- Secondary_Stack_Size -- Subprogram_Variant + -- Volatile_Function -- Warnings -- Insert pragma Prag such that it mimics the placement of a source -- pragma of the same kind. Flag Is_Generic should be set when the @@ -1667,10 +1687,11 @@ package body Sem_Ch13 is -- analyzed right now. -- Note that there is a special handling for Pre, Post, Test_Case, - -- Contract_Cases and Subprogram_Variant aspects. In these cases, we do - -- not have to worry about delay issues, since the pragmas themselves - -- deal with delay of visibility for the expression analysis. Thus, we - -- just insert the pragma after the node N. + -- Contract_Cases, Always_Terminates, Exceptional_Cases and + -- Subprogram_Variant aspects. In these cases, we do not have to worry + -- about delay issues, since the pragmas themselves deal with delay of + -- visibility for the expression analysis. Thus, we just insert the + -- pragma after the node N. -- Loop through aspects @@ -2908,10 +2929,10 @@ package body Sem_Ch13 is end case; if Delay_Required - and then (A_Id = Aspect_Stable_Properties or else A_Id = Aspect_Designated_Storage_Model - or else A_Id = Aspect_Storage_Model_Type) + or else A_Id = Aspect_Storage_Model_Type + or else A_Id = Aspect_Aggregate) -- ??? It seems like we should do this for all aspects, not -- just these, but that causes as-yet-undiagnosed regressions. @@ -3062,16 +3083,11 @@ package body Sem_Ch13 is Expression => Relocate_Node (Expr))), Pragma_Name => Name_Linker_Section); - -- Linker_Section does not need delaying, as its argument - -- must be a static string. Furthermore, if applied to - -- an object with an explicit initialization, the object - -- must be frozen in order to elaborate the initialization - -- code. (This is already done for types with implicit - -- initialization, such as protected types.) + -- No need to delay the processing if the entity is already + -- frozen. This should only happen for subprogram bodies. - if Nkind (N) = N_Object_Declaration - and then Has_Init_Expression (N) - then + if Is_Frozen (E) then + pragma Assert (Nkind (N) = N_Subprogram_Body); Delay_Required := False; end if; @@ -3108,6 +3124,7 @@ package body Sem_Ch13 is -- Dynamic_Predicate, Predicate, Static_Predicate when Aspect_Dynamic_Predicate + | Aspect_Ghost_Predicate | Aspect_Predicate | Aspect_Static_Predicate => @@ -3158,6 +3175,8 @@ package body Sem_Ch13 is elsif A_Id = Aspect_Static_Predicate then Set_Has_Static_Predicate_Aspect (E); + elsif A_Id = Aspect_Ghost_Predicate then + Set_Has_Ghost_Predicate_Aspect (E); end if; -- If the type is private, indicate that its completion @@ -3171,6 +3190,8 @@ package body Sem_Ch13 is Set_Has_Dynamic_Predicate_Aspect (Full_View (E)); elsif A_Id = Aspect_Static_Predicate then Set_Has_Static_Predicate_Aspect (Full_View (E)); + elsif A_Id = Aspect_Ghost_Predicate then + Set_Has_Ghost_Predicate_Aspect (Full_View (E)); end if; Set_Has_Delayed_Aspects (Full_View (E)); @@ -3216,8 +3237,9 @@ package body Sem_Ch13 is goto Continue; elsif not (Directly_Specified (E, Aspect_Dynamic_Predicate) - or else Directly_Specified (E, Aspect_Static_Predicate) - or else Directly_Specified (E, Aspect_Predicate)) + or else Directly_Specified (E, Aspect_Predicate) + or else Directly_Specified (E, Aspect_Ghost_Predicate) + or else Directly_Specified (E, Aspect_Static_Predicate)) then Error_Msg_N ("Predicate_Failure requires accompanying" & @@ -4203,6 +4225,9 @@ package body Sem_Ch13 is Aitem := Empty; when Aspect_Aggregate => + -- We will be checking that the aspect is not specified on a + -- non-array type in Check_Aspect_At_Freeze_Point + Validate_Aspect_Aggregate (Expr); Record_Rep_Item (E, Aspect); goto Continue; @@ -4288,8 +4313,9 @@ package body Sem_Ch13 is -- Case 4: Aspects requiring special handling - -- Pre/Post/Test_Case/Contract_Cases/Subprogram_Variant whose - -- corresponding pragmas take care of the delay. + -- Pre/Post/Test_Case/Contract_Cases/Always_Terminates/ + -- Exceptional_Cases and Subprogram_Variant whose corresponding + -- pragmas take care of the delay. -- Pre/Post @@ -4521,6 +4547,32 @@ package body Sem_Ch13 is Insert_Pragma (Aitem); goto Continue; + -- Always_Terminates + + when Aspect_Always_Terminates => + Aitem := Make_Aitem_Pragma + (Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Loc, + Expression => Relocate_Node (Expr))), + Pragma_Name => Name_Always_Terminates); + + Decorate (Aspect, Aitem); + Insert_Pragma (Aitem); + goto Continue; + + -- Exceptional_Cases + + when Aspect_Exceptional_Cases => + Aitem := Make_Aitem_Pragma + (Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Loc, + Expression => Relocate_Node (Expr))), + Pragma_Name => Name_Exceptional_Cases); + + Decorate (Aspect, Aitem); + Insert_Pragma (Aitem); + goto Continue; + -- Subprogram_Variant when Aspect_Subprogram_Variant => @@ -4725,9 +4777,7 @@ package body Sem_Ch13 is -- For an aspect that applies to a type, indicate whether it -- appears on a partial view of the type. - if Is_Type (E) - and then Is_Private_Type (E) - then + if Is_Type (E) and then Is_Private_Type (E) then Set_Aspect_On_Partial_View (Aspect); end if; @@ -8872,6 +8922,10 @@ package body Sem_Ch13 is -- Given a type, if it has a static predicate, then set Result to the -- predicate as a range list, otherwise set Static.all to False. + procedure Warn_If_Test_Ineffective (REntry : REnt; N : Node_Id); + -- Issue a warning if REntry includes only values that are + -- outside the range TLo .. THi. + ----------- -- "and" -- ----------- @@ -9126,8 +9180,9 @@ package body Sem_Ch13 is (Exp : Node_Id; Static : access Boolean) return RList is - Op : Node_Kind; - Val : Uint; + Op : Node_Kind; + Val : Uint; + Val_Bearer : Node_Id; begin -- Static expression can only be true or false @@ -9178,14 +9233,14 @@ package body Sem_Ch13 is if Is_Type_Ref (Left_Opnd (Exp)) and then Is_OK_Static_Expression (Right_Opnd (Exp)) then - Val := Expr_Value (Right_Opnd (Exp)); + Val_Bearer := Right_Opnd (Exp); -- Typ is right operand elsif Is_Type_Ref (Right_Opnd (Exp)) and then Is_OK_Static_Expression (Left_Opnd (Exp)) then - Val := Expr_Value (Left_Opnd (Exp)); + Val_Bearer := Left_Opnd (Exp); -- Invert sense of comparison @@ -9204,30 +9259,41 @@ package body Sem_Ch13 is return False_Range; end if; + Val := Expr_Value (Val_Bearer); + -- Construct range according to comparison operation - case Op is - when N_Op_Eq => - return RList'(1 => REnt'(Val, Val)); + declare + REntry : REnt; + begin + case Op is + when N_Op_Eq => + REntry := (Val, Val); + + when N_Op_Ge => + REntry := (Val, THi); - when N_Op_Ge => - return RList'(1 => REnt'(Val, BHi)); + when N_Op_Gt => + REntry := (Val + 1, THi); - when N_Op_Gt => - return RList'(1 => REnt'(Val + 1, BHi)); + when N_Op_Le => + REntry := (TLo, Val); - when N_Op_Le => - return RList'(1 => REnt'(BLo, Val)); + when N_Op_Lt => + REntry := (TLo, Val - 1); - when N_Op_Lt => - return RList'(1 => REnt'(BLo, Val - 1)); + when N_Op_Ne => + Warn_If_Test_Ineffective ((Val, Val), Val_Bearer); + return RList'(REnt'(TLo, Val - 1), + REnt'(Val + 1, THi)); - when N_Op_Ne => - return RList'(REnt'(BLo, Val - 1), REnt'(Val + 1, BHi)); + when others => + raise Program_Error; + end case; - when others => - raise Program_Error; - end case; + Warn_If_Test_Ineffective (REntry, Val_Bearer); + return RList'(1 => REntry); + end; -- Membership (IN) @@ -9443,7 +9509,12 @@ package body Sem_Ch13 is else SLo := Expr_Value (Low_Bound (N)); SHi := Expr_Value (High_Bound (N)); - return RList'(1 => REnt'(SLo, SHi)); + declare + REntry : constant REnt := (SLo, SHi); + begin + Warn_If_Test_Ineffective (REntry, N); + return RList'(1 => REntry); + end; end if; -- Others case @@ -9469,7 +9540,12 @@ package body Sem_Ch13 is elsif Is_OK_Static_Expression (N) then Val := Expr_Value (N); - return RList'(1 => REnt'(Val, Val)); + declare + REntry : constant REnt := (Val, Val); + begin + Warn_If_Test_Ineffective (REntry, N); + return RList'(1 => REntry); + end; -- Identifier (other than static expression) case @@ -9541,6 +9617,49 @@ package body Sem_Ch13 is end; end Stat_Pred; + procedure Warn_If_Test_Ineffective (REntry : REnt; N : Node_Id) is + + procedure IPT_Warning (Msg : String); + -- Emit warning + + ----------------- + -- IPT_Warning -- + ----------------- + procedure IPT_Warning (Msg : String) is + begin + Error_Msg_N ("ineffective predicate test " & Msg & "?_s?", N); + end IPT_Warning; + + -- Start of processing for Warn_If_Test_Ineffective + + begin + -- Do nothing if warning disabled + + if not Warn_On_Ineffective_Predicate_Test then + null; + + -- skip null-range corner cases + + elsif REntry.Lo > REntry.Hi or else TLo > THi then + null; + + -- warn if no overlap between subtype bounds and the given range + + elsif REntry.Lo > THi or else REntry.Hi < TLo then + Error_Msg_Uint_1 := REntry.Lo; + if REntry.Lo /= REntry.Hi then + Error_Msg_Uint_2 := REntry.Hi; + IPT_Warning ("range: ^ .. ^"); + elsif Is_Enumeration_Type (Typ) and then + Nkind (N) in N_Identifier | N_Expanded_Name + then + IPT_Warning ("value: &"); + else + IPT_Warning ("value: ^"); + end if; + end if; + end Warn_If_Test_Ineffective; + -- Start of processing for Build_Discrete_Static_Predicate begin @@ -9671,10 +9790,10 @@ package body Sem_Ch13 is -- Resolve new expression in function context - Install_Formals (Predicate_Function (Typ)); Push_Scope (Predicate_Function (Typ)); + Install_Formals (Predicate_Function (Typ)); Analyze_And_Resolve (Expr, Standard_Boolean); - Pop_Scope; + End_Scope; end if; end; end; @@ -9853,9 +9972,13 @@ package body Sem_Ch13 is procedure Build_Predicate_Function (Typ : Entity_Id; N : Node_Id) is Loc : constant Source_Ptr := Sloc (Typ); + Saved_GM : constant Ghost_Mode_Type := Ghost_Mode; + Saved_IGR : constant Node_Id := Ignored_Ghost_Region; + -- Save the Ghost-related attributes to restore on exit + Expr : Node_Id; -- This is the expression for the result of the function. It is - -- is build by connecting the component predicates with AND THEN. + -- built by connecting the component predicates with AND THEN. Object_Name : Name_Id; -- Name for argument of Predicate procedure. Note that we use the same @@ -9871,6 +9994,9 @@ package body Sem_Ch13 is SId : Entity_Id; -- Its entity + Restore_Scope : Boolean; + -- True if the current scope must be restored on exit + Ancestor_Predicate_Function_Called : Boolean := False; -- Does this predicate function include a call to the -- predication function of an ancestor subtype? @@ -10002,6 +10128,16 @@ package body Sem_Ch13 is -- Start of processing for Add_Predicate begin + -- A ghost predicate is checked only when Ghost mode is enabled. + -- Add a condition for the presence of a predicate to be recorded, + -- which is needed to generate the corresponding predicate + -- function. + + if Is_Ignored_Ghost_Pragma (Prag) then + Add_Condition (New_Occurrence_Of (Standard_True, Sloc (Prag))); + return; + end if; + -- Mark corresponding SCO as enabled Set_SCO_Pragma_Enabled (Sloc (Prag)); @@ -10122,12 +10258,6 @@ package body Sem_Ch13 is Replace_Type_References (N, Typ); end Replace_Current_Instance_References; - -- Local variables - - Saved_GM : constant Ghost_Mode_Type := Ghost_Mode; - Saved_IGR : constant Node_Id := Ignored_Ghost_Region; - -- Save the Ghost-related attributes to restore on exit - -- Start of processing for Build_Predicate_Function begin @@ -10166,6 +10296,15 @@ package body Sem_Ch13 is return; end if; + -- Ensure that the declarations are added to the scope of the type + + if Scope (Typ) /= Current_Scope then + Push_Scope (Scope (Typ)); + Restore_Scope := True; + else + Restore_Scope := False; + end if; + -- The related type may be subject to pragma Ghost. Set the mode now to -- ensure that the predicate functions are properly marked as Ghost. @@ -10584,6 +10723,10 @@ package body Sem_Ch13 is end if; Restore_Ghost_Region (Saved_GM, Saved_IGR); + + if Restore_Scope then + Pop_Scope; + end if; end Build_Predicate_Function; ------------------------------------------ @@ -10702,7 +10845,7 @@ package body Sem_Ch13 is -- Expression from call to Check_Aspect_At_Freeze_Point. T : constant Entity_Id := - (if Present (Freeze_Expr) and (A_Id /= Aspect_Stable_Properties) + (if Present (Freeze_Expr) and A_Id /= Aspect_Stable_Properties then Etype (Original_Node (Freeze_Expr)) else Empty); -- Type required for preanalyze call. We use the original expression to @@ -10828,8 +10971,10 @@ package body Sem_Ch13 is -- also make its potential components accessible. if not Analyzed (Freeze_Expr) and then Inside_A_Generic then - if A_Id in Aspect_Dynamic_Predicate | Aspect_Predicate | - Aspect_Static_Predicate + if A_Id in Aspect_Dynamic_Predicate + | Aspect_Ghost_Predicate + | Aspect_Predicate + | Aspect_Static_Predicate then Push_Type (Ent); Preanalyze_Spec_Expression (Freeze_Expr, Standard_Boolean); @@ -10859,6 +11004,7 @@ package body Sem_Ch13 is if Present (Freeze_Expr) and then No (T) then if A_Id in Aspect_Dynamic_Predicate + | Aspect_Ghost_Predicate | Aspect_Predicate | Aspect_Priority | Aspect_Static_Predicate @@ -10887,6 +11033,7 @@ package body Sem_Ch13 is elsif A_Id in Aspect_CPU | Aspect_Dynamic_Predicate + | Aspect_Ghost_Predicate | Aspect_Predicate | Aspect_Priority | Aspect_Static_Predicate @@ -11122,6 +11269,11 @@ package body Sem_Ch13 is return; when Aspect_Aggregate => + if Is_Array_Type (Entity (ASN)) then + Error_Msg_N + ("aspect& can only be applied to non-array type", + Ident); + end if; Resolve_Aspect_Aggregate (Entity (ASN), Expression (ASN)); return; @@ -11135,6 +11287,7 @@ package body Sem_Ch13 is when Aspect_Dynamic_Predicate | Aspect_Invariant + | Aspect_Ghost_Predicate | Aspect_Predicate | Aspect_Static_Predicate | Aspect_Type_Invariant @@ -11189,6 +11342,7 @@ package body Sem_Ch13 is -- Here is the list of aspects that don't require delay analysis when Aspect_Abstract_State + | Aspect_Always_Terminates | Aspect_Annotate | Aspect_Async_Readers | Aspect_Async_Writers @@ -11198,6 +11352,7 @@ package body Sem_Ch13 is | Aspect_Depends | Aspect_Dimension | Aspect_Dimension_System + | Aspect_Exceptional_Cases | Aspect_Effective_Reads | Aspect_Effective_Writes | Aspect_Extensions_Visible @@ -11872,163 +12027,157 @@ package body Sem_Ch13 is Sbit : Uint; Abit : out Uint) is - Compl : Integer; - - begin - Compl := Integer (List_Length (Component_Items (CL))); - - if DS /= No_List then - Compl := Compl + Integer (List_Length (DS)); - end if; + Compl : constant Natural := + Natural (List_Length (Component_Items (CL)) + List_Length (DS)); - declare - Comps : array (Natural range 0 .. Compl) of Entity_Id; - -- Gather components (zero entry is for sort routine) + Comps : array (Natural range 0 .. Compl) of Entity_Id; + -- Gather components (zero entry is for sort routine) - Ncomps : Natural := 0; - -- Number of entries stored in Comps (starting at Comps (1)) + Ncomps : Natural := 0; + -- Number of entries stored in Comps (starting at Comps (1)) - Citem : Node_Id; - -- One component item or discriminant specification + Citem : Node_Id; + -- One component item or discriminant specification - Nbit : Uint; - -- Starting bit for next component + Nbit : Uint; + -- Starting bit for next component - CEnt : Entity_Id; - -- Component entity + CEnt : Entity_Id; + -- Component entity - Variant : Node_Id; - -- One variant + Variant : Node_Id; + -- One variant - function Lt (Op1, Op2 : Natural) return Boolean; - -- Compare routine for Sort + function Lt (Op1, Op2 : Natural) return Boolean; + -- Compare routine for Sort - procedure Move (From : Natural; To : Natural); - -- Move routine for Sort + procedure Move (From : Natural; To : Natural); + -- Move routine for Sort - package Sorting is new GNAT.Heap_Sort_G (Move, Lt); + package Sorting is new GNAT.Heap_Sort_G (Move, Lt); - -------- - -- Lt -- - -------- + -------- + -- Lt -- + -------- - function Lt (Op1, Op2 : Natural) return Boolean is - K1 : constant Boolean := - Known_Component_Bit_Offset (Comps (Op1)); - K2 : constant Boolean := - Known_Component_Bit_Offset (Comps (Op2)); - -- Record representation clauses can be incomplete, so the - -- Component_Bit_Offsets can be unknown. - begin - if K1 then - if K2 then - return Component_Bit_Offset (Comps (Op1)) - < Component_Bit_Offset (Comps (Op2)); - else - return True; - end if; + function Lt (Op1, Op2 : Natural) return Boolean is + K1 : constant Boolean := + Known_Component_Bit_Offset (Comps (Op1)); + K2 : constant Boolean := + Known_Component_Bit_Offset (Comps (Op2)); + -- Record representation clauses can be incomplete, so the + -- Component_Bit_Offsets can be unknown. + begin + if K1 then + if K2 then + return Component_Bit_Offset (Comps (Op1)) + < Component_Bit_Offset (Comps (Op2)); else - return K2; + return True; end if; - end Lt; - - ---------- - -- Move -- - ---------- + else + return K2; + end if; + end Lt; - procedure Move (From : Natural; To : Natural) is - begin - Comps (To) := Comps (From); - end Move; + ---------- + -- Move -- + ---------- + procedure Move (From : Natural; To : Natural) is begin - -- Gather discriminants into Comp + Comps (To) := Comps (From); + end Move; - Citem := First (DS); - while Present (Citem) loop - if Nkind (Citem) = N_Discriminant_Specification then - declare - Ent : constant Entity_Id := - Defining_Identifier (Citem); - begin - if Ekind (Ent) = E_Discriminant then - Ncomps := Ncomps + 1; - Comps (Ncomps) := Ent; - end if; - end; - end if; + -- Start of processing for Check_Component_List - Next (Citem); - end loop; + begin + -- Gather discriminants into Comp + + Citem := First (DS); + while Present (Citem) loop + if Nkind (Citem) = N_Discriminant_Specification then + declare + Ent : constant Entity_Id := + Defining_Identifier (Citem); + begin + if Ekind (Ent) = E_Discriminant then + Ncomps := Ncomps + 1; + Comps (Ncomps) := Ent; + end if; + end; + end if; - -- Gather component entities into Comp + Next (Citem); + end loop; - Citem := First (Component_Items (CL)); - while Present (Citem) loop - if Nkind (Citem) = N_Component_Declaration then - Ncomps := Ncomps + 1; - Comps (Ncomps) := Defining_Identifier (Citem); - end if; + -- Gather component entities into Comp - Next (Citem); - end loop; + Citem := First (Component_Items (CL)); + while Present (Citem) loop + if Nkind (Citem) = N_Component_Declaration then + Ncomps := Ncomps + 1; + Comps (Ncomps) := Defining_Identifier (Citem); + end if; - -- Now sort the component entities based on the first bit. - -- Note we already know there are no overlapping components. + Next (Citem); + end loop; - Sorting.Sort (Ncomps); + -- Now sort the component entities based on the first bit. + -- Note we already know there are no overlapping components. - -- Loop through entries checking for holes + Sorting.Sort (Ncomps); - Nbit := Sbit; - for J in 1 .. Ncomps loop - CEnt := Comps (J); - pragma Annotate (CodePeer, Modified, CEnt); + -- Loop through entries checking for holes - declare - CBO : constant Uint := Component_Bit_Offset (CEnt); + Nbit := Sbit; + for J in 1 .. Ncomps loop + CEnt := Comps (J); + pragma Annotate (CodePeer, Modified, CEnt); - begin - -- Skip components with unknown offsets + declare + CBO : constant Uint := Component_Bit_Offset (CEnt); - if Present (CBO) and then CBO >= 0 then - Error_Msg_Uint_1 := CBO - Nbit; + begin + -- Skip components with unknown offsets - if Warn and then Error_Msg_Uint_1 > 0 then - Error_Msg_NE - ("?.h?^-bit gap before component&", - Component_Name (Component_Clause (CEnt)), - CEnt); - end if; + if Present (CBO) and then CBO >= 0 then + Error_Msg_Uint_1 := CBO - Nbit; - Nbit := CBO + Esize (CEnt); + if Warn and then Error_Msg_Uint_1 > 0 then + Error_Msg_NE + ("?.h?^-bit gap before component&", + Component_Name (Component_Clause (CEnt)), + CEnt); end if; - end; - end loop; - -- Set Abit to just after the last nonvariant component + Nbit := CBO + Esize (CEnt); + end if; + end; + end loop; - Abit := Nbit; + -- Set Abit to just after the last nonvariant component - -- Process variant parts recursively if present. Set Abit to - -- the maximum for all variant parts. + Abit := Nbit; - if Present (Variant_Part (CL)) then - declare - Var_Start : constant Uint := Nbit; - begin - Variant := First (Variants (Variant_Part (CL))); - while Present (Variant) loop - Check_Component_List - (No_List, Component_List (Variant), Var_Start, Nbit); - Next (Variant); - if Nbit > Abit then - Abit := Nbit; - end if; - end loop; - end; - end if; - end; + -- Process variant parts recursively if present. Set Abit to the + -- maximum for all variant parts. + + if Present (Variant_Part (CL)) then + declare + Var_Start : constant Uint := Nbit; + begin + Variant := First (Variants (Variant_Part (CL))); + while Present (Variant) loop + Check_Component_List + (No_List, Component_List (Variant), Var_Start, Nbit); + Next (Variant); + if Nbit > Abit then + Abit := Nbit; + end if; + end loop; + end; + end if; end Check_Component_List; -- Local variables @@ -13149,6 +13298,7 @@ package body Sem_Ch13 is then if Get_Aspect_Id (Ritem) in Aspect_CPU | Aspect_Dynamic_Predicate + | Aspect_Ghost_Predicate | Aspect_Predicate | Aspect_Static_Predicate | Aspect_Priority @@ -14161,7 +14311,7 @@ package body Sem_Ch13 is -- transformed into just "(S /= 0)", which would appear to be -- a predicate-static expression (and therefore legal). - if Original_Node (Expr) /= Expr then + if Is_Rewrite_Substitution (Expr) then -- Emit warnings for predicates that are always True or always False -- and were not originally expressed as Boolean literals. @@ -15550,21 +15700,36 @@ package body Sem_Ch13 is null; when Aspect_Dynamic_Predicate - | Aspect_Static_Predicate + | Aspect_Ghost_Predicate | Aspect_Predicate + | Aspect_Static_Predicate => -- Preanalyze expression after type replacement to catch -- name resolution errors if the predicate function has -- not been built yet. + -- Note that we cannot use Preanalyze_Spec_Expression - -- because of the special handling required for - -- quantifiers, see comments on Resolve_Aspect_Expression - -- above. + -- directly because of the special handling required for + -- quantifiers (see comments on Resolve_Aspect_Expression + -- above) but we need to emulate it properly. if No (Predicate_Function (E)) then - Push_Type (E); - Resolve_Aspect_Expression (Expr); - Pop_Type (E); + declare + Save_In_Spec_Expression : constant Boolean := + In_Spec_Expression; + Save_Full_Analysis : constant Boolean := + Full_Analysis; + begin + In_Spec_Expression := True; + Full_Analysis := False; + Expander_Mode_Save_And_Set (False); + Push_Type (E); + Resolve_Aspect_Expression (Expr); + Pop_Type (E); + Expander_Mode_Restore; + Full_Analysis := Save_Full_Analysis; + In_Spec_Expression := Save_In_Spec_Expression; + end; end if; when Pre_Post_Aspects => @@ -15882,7 +16047,7 @@ package body Sem_Ch13 is begin Error_Msg_Ada_2022_Feature ("aspect Stable_Properties", Sloc (N)); - if (not Is_Aspect_Of_Type) and then (not Is_Subprogram (E)) then + if not Is_Aspect_Of_Type and then not Is_Subprogram (E) then Error_Msg_N ("Stable_Properties aspect can only be specified for " & "a type or a subprogram", N); elsif Class_Present then @@ -16359,7 +16524,7 @@ package body Sem_Ch13 is function Matches_Param_Type (Typ : Entity_Id) return Boolean is - ((Base_Type (Typ) = Param_Type) + (Base_Type (Typ) = Param_Type or else (Is_Class_Wide_Type (Param_Type) and then Is_Ancestor (Root_Type (Param_Type), @@ -17742,12 +17907,12 @@ package body Sem_Ch13 is and then Is_Descendant_Of_Address (Source) and then In_Same_Source_Unit (Target, N) then - Set_Can_Use_Internal_Rep (Target, False); + Set_Can_Use_Internal_Rep (Base_Type (Target), False); elsif Is_Access_Subprogram_Type (Source) and then Is_Descendant_Of_Address (Target) and then In_Same_Source_Unit (Source, N) then - Set_Can_Use_Internal_Rep (Source, False); + Set_Can_Use_Internal_Rep (Base_Type (Source), False); end if; -- Generate N_Validate_Unchecked_Conversion node for back end in case diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 299ea6e..85019df 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -3224,6 +3224,7 @@ package body Sem_Ch3 is if Ada_Version >= Ada_2022 and then Present (Aspect_Specifications (N)) + and then Expander_Active then Build_Access_Subprogram_Wrapper (N); end if; @@ -3252,13 +3253,6 @@ package body Sem_Ch3 is when N_Derived_Type_Definition => Derived_Type_Declaration (T, N, T /= Def_Id); - -- Inherit predicates from parent, and protect against illegal - -- derivations. - - if Is_Type (T) and then Has_Predicates (T) then - Set_Has_Predicates (Def_Id); - end if; - -- Save the scenario for examination by the ABE Processing -- phase. @@ -3658,9 +3652,11 @@ package body Sem_Ch3 is if not Is_Overloaded (E) then T := Etype (E); - if Has_Dynamic_Predicate_Aspect (T) then + if Has_Dynamic_Predicate_Aspect (T) + or else Has_Ghost_Predicate_Aspect (T) + then Error_Msg_N - ("subtype has dynamic predicate, " + ("subtype has non-static predicate, " & "not allowed in number declaration", N); end if; @@ -4694,6 +4690,16 @@ package body Sem_Ch3 is elsif No (E) and then Is_Null_Record_Type (T) then null; + -- If there is an address clause for this object, do not generate a + -- predicate check here. It will be generated later, at the freezng + -- point. It would be wrong to generate references to the object + -- here, before the address has been determined. + + elsif Has_Aspect (Id, Aspect_Address) + or else Present (Following_Address_Clause (N)) + then + null; + -- Do not generate a predicate check if the initialization expression -- is a type conversion whose target subtype statically matches the -- object's subtype because the conversion has been subjected to the @@ -4713,7 +4719,6 @@ package body Sem_Ch3 is declare Check : constant Node_Id := Make_Predicate_Check (T, New_Occurrence_Of (Id, Loc)); - begin if No (Next_Decl) then Append_To (List_Containing (N), Check); @@ -4971,6 +4976,7 @@ package body Sem_Ch3 is end if; Rewrite (Object_Definition (N), New_Occurrence_Of (Act_T, Loc)); + Freeze_Before (N, Act_T); elsif Nkind (E) = N_Function_Call and then Constant_Present (N) @@ -5375,7 +5381,6 @@ package body Sem_Ch3 is Set_Convention (T, Convention (Parent_Type)); Set_First_Rep_Item (T, First_Rep_Item (Parent_Type)); Set_Is_First_Subtype (T); - Make_Class_Wide_Type (T); -- Set the SPARK mode from the current context @@ -5544,7 +5549,7 @@ package body Sem_Ch3 is -- avoided here, when the created subtype declaration is analyzed. (See -- Build_Derived_Types) - -- This also happens when the full view of a private type is derived + -- This also happens when the full view of a private type is a derived -- type with constraints. In this case the entity has been introduced -- in the private declaration. @@ -6462,13 +6467,6 @@ package body Sem_Ch3 is end if; if Nkind (Def) = N_Constrained_Array_Definition then - - if Ekind (T) in Incomplete_Or_Private_Kind then - Reinit_Field_To_Zero (T, F_Stored_Constraint); - else - pragma Assert (Ekind (T) = E_Void); - end if; - -- Establish Implicit_Base as unconstrained base type Implicit_Base := Create_Itype (E_Array_Type, P, Related_Id, 'B'); @@ -6509,13 +6507,6 @@ package body Sem_Ch3 is -- Unconstrained array case else pragma Assert (Nkind (Def) = N_Unconstrained_Array_Definition); - - if Ekind (T) in Incomplete_Or_Private_Kind then - Reinit_Field_To_Zero (T, F_Stored_Constraint); - else - pragma Assert (Ekind (T) = E_Void); - end if; - Mutate_Ekind (T, E_Array_Type); Reinit_Size_Align (T); Set_Etype (T, T); @@ -6862,25 +6853,16 @@ package body Sem_Ch3 is declare Asp : Node_Id; A_Id : Aspect_Id; - Cond : Node_Id; - Expr : Node_Id; begin Asp := First (Aspect_Specifications (Decl)); while Present (Asp) loop A_Id := Get_Aspect_Id (Chars (Identifier (Asp))); if A_Id = Aspect_Pre or else A_Id = Aspect_Post then - Cond := Asp; - Expr := Expression (Cond); - Replace_Type_Name (Expr); - Next (Asp); - - Remove (Cond); - Append (Cond, Contracts); - - else - Next (Asp); + Append (New_Copy_Tree (Asp), Contracts); + Replace_Type_Name (Expression (Last (Contracts))); end if; + Next (Asp); end loop; end; @@ -6938,16 +6920,7 @@ package body Sem_Ch3 is -- may be handled as a dispatching operation and erroneously registered -- in a dispatch table. - if not GNATprove_Mode then - Append_Freeze_Action (Id, New_Decl); - - -- Under GNATprove mode there is no such problem but we do not declare - -- it in the freezing actions since they are not analyzed under this - -- mode. - - else - Insert_After (Decl, New_Decl); - end if; + Append_Freeze_Action (Id, New_Decl); Set_Access_Subprogram_Wrapper (Designated_Type (Id), Subp); Build_Access_Subprogram_Wrapper_Body (Decl, New_Decl); @@ -7055,7 +7028,7 @@ package body Sem_Ch3 is Desig_Type := Designated_Type (Derived_Type); if Is_Composite_Type (Desig_Type) - and then (not Is_Array_Type (Desig_Type)) + and then not Is_Array_Type (Desig_Type) and then Has_Discriminants (Desig_Type) and then Base_Type (Desig_Type) /= Desig_Type then @@ -7603,6 +7576,7 @@ package body Sem_Ch3 is end if; Mutate_Ekind (New_Lit, E_Enumeration_Literal); + Set_Is_Not_Self_Hidden (New_Lit); Set_Enumeration_Pos (New_Lit, Enumeration_Pos (Literal)); Set_Enumeration_Rep (New_Lit, Enumeration_Rep (Literal)); Set_Enumeration_Rep_Expr (New_Lit, Empty); @@ -8137,6 +8111,7 @@ package body Sem_Ch3 is Build_Derived_Type (N, Full_Parent, Full_Der, Is_Completion => False, Derive_Subps => False); + Set_Is_Not_Self_Hidden (Full_Der); end if; Set_Has_Private_Declaration (Full_Der); @@ -8703,7 +8678,7 @@ package body Sem_Ch3 is -- 5. FIRST TRANSFORMATION FOR DERIVED RECORDS -- - -- Regardless of whether we dealing with a tagged or untagged type + -- Regardless of whether we are dealing with a tagged or untagged type -- we will transform all derived type declarations of the form -- -- type T is new R (...) [with ...]; @@ -9071,9 +9046,16 @@ package body Sem_Ch3 is -- Start of processing for Build_Derived_Record_Type begin + -- If the parent type is a private extension with discriminants, we + -- need to have an unconstrained type on which to apply the inherited + -- constraint, so we get to the full view. However, this means that the + -- derived type and its implicit base type created below will not point + -- to the same view of their respective parent type and, thus, special + -- glue code like Exp_Ch7.Convert_View is needed to bridge this gap. + if Ekind (Parent_Type) = E_Record_Type_With_Private - and then Present (Full_View (Parent_Type)) and then Has_Discriminants (Parent_Type) + and then Present (Full_View (Parent_Type)) then Parent_Base := Base_Type (Full_View (Parent_Type)); else @@ -9090,6 +9072,36 @@ package body Sem_Ch3 is Parent_Base := Base_Type (Parent_Base); end if; + -- If the parent base is a private type and only its full view has + -- discriminants, use the full view's base type. + + -- This can happen when we are deriving from a subtype of a derived type + -- of a private type derived from a discriminated type with known + -- discriminant: + -- + -- package Pkg; + -- type Root_Type(I: Positive) is record + -- ... + -- end record; + -- type Bounded_Root_Type is private; + -- private + -- type Bounded_Root_Type is new Root_Type(10); + -- end Pkg; + -- + -- package Pkg2 is + -- type Constrained_Root_Type is new Pkg.Bounded_Root_Type; + -- end Pkg2; + -- subtype Sub_Base is Pkg2.Constrained_Root_Type; + -- type New_Der_Type is new Sub_Base; + + if Is_Private_Type (Parent_Base) + and then Present (Full_View (Parent_Base)) + and then not Has_Discriminants (Parent_Base) + and then Has_Discriminants (Full_View (Parent_Base)) + then + Parent_Base := Base_Type (Full_View (Parent_Base)); + end if; + -- AI05-0115: if this is a derivation from a private type in some -- other scope that may lead to invisible components for the derived -- type, mark it accordingly. @@ -9218,10 +9230,14 @@ package body Sem_Ch3 is then -- First, we must analyze the constraint (see comment in point 5.) -- The constraint may come from the subtype indication of the full - -- declaration. + -- declaration. Temporarily set the state of the Derived_Type to + -- "self-hidden" (see RM-8.3(17)). if Constraint_Present then + pragma Assert (Is_Not_Self_Hidden (Derived_Type)); + Set_Is_Not_Self_Hidden (Derived_Type, False); New_Discrs := Build_Discriminant_Constraints (Parent_Type, Indic); + Set_Is_Not_Self_Hidden (Derived_Type); -- If there is no explicit constraint, there might be one that is -- inherited from a constrained parent type. In that case verify that @@ -9317,7 +9333,7 @@ package body Sem_Ch3 is Is_Completion => False, Derive_Subps => False); -- ??? This needs re-examination to determine whether the - -- above call can simply be replaced by a call to Analyze. + -- following call can simply be replaced by a call to Analyze. Set_Analyzed (New_Decl); @@ -9519,11 +9535,19 @@ package body Sem_Ch3 is if Discriminant_Specs then Set_Has_Unknown_Discriminants (Derived_Type, False); - -- The following call initializes fields Has_Discriminants and - -- Discriminant_Constraint, unless we are processing the completion - -- of a private type declaration. + -- The following call to Check_Or_Process_Discriminants initializes + -- fields Has_Discriminants and Discriminant_Constraint, unless we + -- are processing the completion of a private type declaration. + -- Temporarily set the state of the Derived_Type to "self-hidden" + -- (see RM-8.3(17)), unless it is already the case. - Check_Or_Process_Discriminants (N, Derived_Type); + if Is_Not_Self_Hidden (Derived_Type) then + Set_Is_Not_Self_Hidden (Derived_Type, False); + Check_Or_Process_Discriminants (N, Derived_Type); + Set_Is_Not_Self_Hidden (Derived_Type); + else + Check_Or_Process_Discriminants (N, Derived_Type); + end if; -- For untagged types, the constraint on the Parent_Type must be -- present and is used to rename the discriminants. @@ -9931,8 +9955,8 @@ package body Sem_Ch3 is -- There is no completion for record extensions declared in the -- parameter part of a generic, so we need to complete processing for - -- these generic record extensions here. The Record_Type_Definition call - -- will change the Ekind of the components from E_Void to E_Component. + -- these generic record extensions here. Record_Type_Definition will + -- set the Is_Not_Self_Hidden flag. elsif Private_Extension and then Is_Generic_Type (Derived_Type) then Record_Type_Definition (Empty, Derived_Type); @@ -10030,9 +10054,9 @@ package body Sem_Ch3 is -- Set common attributes if Ekind (Derived_Type) in Incomplete_Or_Private_Kind - and then Ekind (Parent_Base) in Modular_Integer_Kind | Array_Kind + and then Ekind (Parent_Base) in Elementary_Kind then - Reinit_Field_To_Zero (Derived_Type, F_Stored_Constraint); + Reinit_Field_To_Zero (Derived_Type, F_Discriminant_Constraint); end if; Set_Scope (Derived_Type, Current_Scope); @@ -10139,15 +10163,9 @@ package body Sem_Ch3 is end if; end if; - -- We similarly inherit predicates. Note that for scalar derived types - -- the predicate is inherited from the first subtype, and not from its - -- (anonymous) base type. + -- We similarly inherit predicates - if Has_Predicates (Parent_Type) - or else Has_Predicates (First_Subtype (Parent_Type)) - then - Set_Has_Predicates (Derived_Type); - end if; + Inherit_Predicate_Flags (Derived_Type, Parent_Type, Only_Flags => True); -- The derived type inherits representation clauses from the parent -- type, and from any interfaces. @@ -11973,6 +11991,8 @@ package body Sem_Ch3 is return; end if; + Set_Is_Not_Self_Hidden (Typ); + Comp := First (Component_Items (Comp_List)); while Present (Comp) loop if Nkind (Comp) = N_Component_Declaration then @@ -12322,7 +12342,7 @@ package body Sem_Ch3 is -- Check all components to ensure no default expressions if Present (Clist) then - Comp := First (Component_Items (Clist)); + Comp := First_Non_Pragma (Component_Items (Clist)); while Present (Comp) loop if Present (Expression (Comp)) then Error_Msg_N @@ -12330,7 +12350,7 @@ package body Sem_Ch3 is & "default expression", Expression (Comp)); end if; - Next (Comp); + Next_Non_Pragma (Comp); end loop; end if; end Check_CPP_Type_Has_No_Defaults; @@ -12944,13 +12964,14 @@ package body Sem_Ch3 is -- Set common attributes for all subtypes: kind, convention, etc. - Mutate_Ekind (Full, Subtype_Kind (Ekind (Full_Base))); - Set_Convention (Full, Convention (Full_Base)); + Mutate_Ekind (Full, Subtype_Kind (Ekind (Full_Base))); + Set_Is_Not_Self_Hidden (Full); + Set_Convention (Full, Convention (Full_Base)); Set_Is_First_Subtype (Full, False); - Set_Scope (Full, Scope (Priv)); - Set_Size_Info (Full, Full_Base); - Copy_RM_Size (To => Full, From => Full_Base); - Set_Is_Itype (Full); + Set_Scope (Full, Scope (Priv)); + Set_Size_Info (Full, Full_Base); + Copy_RM_Size (To => Full, From => Full_Base); + Set_Is_Itype (Full); -- A subtype of a private-type-without-discriminants, whose full-view -- has discriminants with default expressions, is not constrained. @@ -15108,6 +15129,7 @@ package body Sem_Ch3 is -- in the private part is the full declaration. Exchange_Entities (Priv, Full); + Set_Is_Not_Self_Hidden (Priv); Append_Entity (Full, Scope (Full)); end Copy_And_Swap; @@ -15169,8 +15191,8 @@ package body Sem_Ch3 is Loc : constant Source_Ptr := Sloc (Subt); Comp_List : constant Elist_Id := New_Elmt_List; Parent_Type : constant Entity_Id := Etype (Typ); - Assoc_List : constant List_Id := New_List; + Assoc_List : List_Id; Discr_Val : Elmt_Id; Errors : Boolean; New_C : Entity_Id; @@ -15199,8 +15221,10 @@ package body Sem_Ch3 is procedure Collect_Fixed_Components (Typ : Entity_Id) is begin - -- Build association list for discriminants, and find components of the - -- variant part selected by the values of the discriminants. + -- Build association list for discriminants, and find components of + -- the variant part selected by the values of the discriminants. + + Assoc_List := New_List; Old_C := First_Discriminant (Typ); Discr_Val := First_Elmt (Constraints); @@ -15301,13 +15325,13 @@ package body Sem_Ch3 is ----------------------- function Is_Variant_Record (T : Entity_Id) return Boolean is + Decl : constant Node_Id := Parent (T); begin - return Nkind (Parent (T)) = N_Full_Type_Declaration - and then Nkind (Type_Definition (Parent (T))) = N_Record_Definition - and then Present (Component_List (Type_Definition (Parent (T)))) + return Nkind (Decl) = N_Full_Type_Declaration + and then Nkind (Type_Definition (Decl)) = N_Record_Definition + and then Present (Component_List (Type_Definition (Decl))) and then - Present - (Variant_Part (Component_List (Type_Definition (Parent (T))))); + Present (Variant_Part (Component_List (Type_Definition (Decl)))); end Is_Variant_Record; -- Start of processing for Create_Constrained_Components @@ -15435,10 +15459,10 @@ package body Sem_Ch3 is Gather_Components (Typ, Component_List (Type_Definition (Parent (Typ))), - Governed_By => Assoc_List, - Into => Comp_List, - Report_Errors => Errors, - Allow_Compile_Time => True); + Governed_By => Assoc_List, + Into => Comp_List, + Report_Errors => Errors, + Allow_Compile_Time => True); pragma Assert (not Errors or else Serious_Errors_Detected > 0); Create_All_Components; @@ -15458,10 +15482,10 @@ package body Sem_Ch3 is Gather_Components (Typ, Component_List (Type_Definition (Parent (Parent_Type))), - Governed_By => Assoc_List, - Into => Comp_List, - Report_Errors => Errors, - Allow_Compile_Time => True); + Governed_By => Assoc_List, + Into => Comp_List, + Report_Errors => Errors, + Allow_Compile_Time => True); -- Note: previously there was a check at this point that no errors -- were detected. As a consequence of AI05-220 there may be an error @@ -15863,7 +15887,11 @@ package body Sem_Ch3 is -- derived type. procedure Replace_Type (Id, New_Id : Entity_Id); - -- When the type is an anonymous access type, create a new access type + -- Set the Etype of New_Id to the appropriate subtype determined from + -- the Etype of Id, following (RM 3.4 (18, 19, 20, 21)). Id is either + -- the parent type's primitive subprogram or one of its formals, and + -- New_Id is the corresponding entity for the derived type. When the + -- Etype of Id is an anonymous access type, create a new access type -- designating the derived type. procedure Set_Derived_Name; @@ -15915,7 +15943,6 @@ package body Sem_Ch3 is procedure Replace_Type (Id, New_Id : Entity_Id) is Id_Type : constant Entity_Id := Etype (Id); - Acc_Type : Entity_Id; Par : constant Node_Id := Parent (Derived_Type); begin @@ -15927,6 +15954,7 @@ package body Sem_Ch3 is if Ekind (Id_Type) = E_Anonymous_Access_Type then declare + Acc_Type : Entity_Id; Desig_Typ : Entity_Id := Designated_Type (Id_Type); begin @@ -16008,7 +16036,7 @@ package body Sem_Ch3 is -- of the parent, and we can also use it rather than its base, -- which can lead to more efficient code. - if Etype (Id) = Parent_Type then + if Id_Type = Parent_Type then if Is_Scalar_Type (Parent_Type) and then Subtypes_Statically_Compatible (Parent_Type, Derived_Type) @@ -16033,7 +16061,7 @@ package body Sem_Ch3 is end if; else - Set_Etype (New_Id, Etype (Id)); + Set_Etype (New_Id, Id_Type); end if; end Replace_Type; @@ -16056,6 +16084,7 @@ package body Sem_Ch3 is begin New_Subp := New_Entity (Nkind (Parent_Subp), Sloc (Derived_Type)); Mutate_Ekind (New_Subp, Ekind (Parent_Subp)); + Set_Is_Not_Self_Hidden (New_Subp); -- Check whether the inherited subprogram is a private operation that -- should be inherited but not yet made visible. Such subprograms can @@ -16219,6 +16248,7 @@ package body Sem_Ch3 is if No (Actual_Subp) then if Is_Intrinsic_Subprogram (Parent_Subp) then + Set_Convention (New_Subp, Convention_Intrinsic); Set_Is_Intrinsic_Subprogram (New_Subp); if Present (Alias (Parent_Subp)) @@ -17367,8 +17397,8 @@ package body Sem_Ch3 is Error_Msg_N ("type cannot be used in its own definition", Indic); end if; - Mutate_Ekind (T, Ekind (Parent_Type)); - Set_Etype (T, Any_Type); + Mutate_Ekind (T, Ekind (Parent_Type)); + Set_Etype (T, Any_Type); Set_Scalar_Range (T, Scalar_Range (Any_Type)); -- Initialize the list of primitive operations to an empty list, @@ -17671,6 +17701,8 @@ package body Sem_Ch3 is -- Avoid deriving parent primitives of underlying record views + Set_Is_Not_Self_Hidden (T); + Build_Derived_Type (N, Parent_Type, T, Is_Completion, Derive_Subps => not Is_Underlying_Record_View (T)); @@ -17759,6 +17791,7 @@ package body Sem_Ch3 is while Present (L) loop if Ekind (L) /= E_Enumeration_Literal then Mutate_Ekind (L, E_Enumeration_Literal); + Set_Is_Not_Self_Hidden (L); Set_Enumeration_Pos (L, Ev); Set_Enumeration_Rep (L, Ev); Set_Is_Known_Valid (L, True); @@ -18422,19 +18455,21 @@ package body Sem_Ch3 is Analyze (Subtype_Mark (Obj_Def)); declare - Base_T : constant Entity_Id := Entity (Subtype_Mark (Obj_Def)); - Decl : constant Node_Id := + Base_T : constant Entity_Id := Entity (Subtype_Mark (Obj_Def)); + New_Def : constant Node_Id := New_Copy_Tree (Obj_Def); + Decl : constant Node_Id := Make_Subtype_Declaration (Sloc (P), Defining_Identifier => T, - Subtype_Indication => Relocate_Node (Obj_Def)); + Subtype_Indication => New_Def); + begin Set_Etype (T, Base_T); Mutate_Ekind (T, Subtype_Kind (Ekind (Base_T))); - Set_Parent (T, Obj_Def); + Set_Parent (T, Decl); + Set_Scope (T, Current_Scope); if Ekind (T) = E_Array_Subtype then - Set_First_Index (T, First_Index (Base_T)); - Set_Is_Constrained (T); + Constrain_Array (T, New_Def, Related_Nod, T, 'P'); elsif Ekind (T) = E_Record_Subtype then Set_First_Entity (T, First_Entity (Base_T)); @@ -19206,22 +19241,6 @@ package body Sem_Ch3 is end if; end if; - -- In derived tagged types it is illegal to reference a non - -- discriminant component in the parent type. To catch this, mark - -- these components with an Ekind of E_Void. This will be reset in - -- Record_Type_Definition after processing the record extension of - -- the derived type. - - -- If the declaration is a private extension, there is no further - -- record extension to process, and the components retain their - -- current kind, because they are visible at this point. - - if Is_Tagged and then Ekind (New_C) = E_Component - and then Nkind (N) /= N_Private_Extension_Declaration - then - Mutate_Ekind (New_C, E_Void); - end if; - if Plain_Discrim then Set_Corresponding_Discriminant (New_C, Old_C); Build_Discriminal (New_C); @@ -19726,6 +19745,9 @@ package body Sem_Ch3 is if Ekind (CW_Type) in E_Task_Type | E_Protected_Type then Reinit_Field_To_Zero (CW_Type, F_SPARK_Aux_Pragma_Inherited); end if; + + elsif Ekind (CW_Type) = E_Record_Type then + Reinit_Field_To_Zero (CW_Type, F_Corresponding_Concurrent_Type); end if; Mutate_Ekind (CW_Type, E_Class_Wide_Type); @@ -20112,10 +20134,6 @@ package body Sem_Ch3 is Analyze_And_Resolve (Mod_Expr, Any_Integer); - if Ekind (T) in Incomplete_Or_Private_Kind then - Reinit_Field_To_Zero (T, F_Stored_Constraint); - end if; - Set_Etype (T, T); Mutate_Ekind (T, E_Modular_Integer_Type); Reinit_Alignment (T); @@ -20232,6 +20250,7 @@ package body Sem_Ch3 is Op := Make_Defining_Operator_Symbol (Loc, Name_Op_Concat); Mutate_Ekind (Op, E_Operator); + Set_Is_Not_Self_Hidden (Op); Set_Scope (Op, Current_Scope); Set_Etype (Op, Typ); Set_Homonym (Op, Get_Name_Entity_Id (Name_Op_Concat)); @@ -20950,6 +20969,7 @@ package body Sem_Ch3 is end if; Mutate_Ekind (Id, E_Discriminant); + Set_Is_Not_Self_Hidden (Id); Reinit_Component_Location (Id); Reinit_Esize (Id); Set_Discriminant_Number (Id, Discr_Number); @@ -22772,6 +22792,8 @@ package body Sem_Ch3 is T := Prev_T; end if; + Set_Is_Not_Self_Hidden (T); + Final_Storage_Only := not Is_Controlled (T); -- Ada 2005: Check whether an explicit "limited" is present in a derived @@ -22813,6 +22835,7 @@ package body Sem_Ch3 is then Mutate_Ekind (Component, E_Component); Reinit_Component_Location (Component); + Set_Is_Not_Self_Hidden (Component); end if; Propagate_Concurrent_Flags (T, Etype (Component)); @@ -23032,9 +23055,8 @@ package body Sem_Ch3 is -- Reset the kind of the subtype during analysis of the range, to -- catch possible premature use in the bounds themselves. - Mutate_Ekind (Def_Id, E_Void); Process_Range_Expr_In_Decl (R, Subt, Subtyp => Def_Id); - Mutate_Ekind (Def_Id, Kind); + pragma Assert (Ekind (Def_Id) = Kind); end Set_Scalar_Range_For_Subtype; -------------------------------------------------------- diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 153a635..fafb7e6 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -65,6 +65,7 @@ with Sinfo; use Sinfo; with Sinfo.Nodes; use Sinfo.Nodes; with Sinfo.Utils; use Sinfo.Utils; with Snames; use Snames; +with Style; use Style; with Tbuild; use Tbuild; with Uintp; use Uintp; with Warnsw; use Warnsw; @@ -255,8 +256,8 @@ package body Sem_Ch4 is -- type is not directly visible. The routine uses this type to emit a more -- informative message. - function Has_Possible_Literal_Aspects (N : Node_Id) return Boolean; - -- Ada_2022: if an operand is a literal it may be subject to an + function Has_Possible_User_Defined_Literal (N : Node_Id) return Boolean; + -- Ada 2022: if an operand is a literal, it may be subject to an -- implicit conversion to a type for which a user-defined literal -- function exists. During the first pass of type resolution we do -- not know the context imposed on the literal, so we assume that @@ -1539,8 +1540,14 @@ package body Sem_Ch4 is Set_Etype (N, Full_View (Etype (N))); + -- If the call is within a thunk, the nonlimited view should be + -- analyzed eventually (see also Analyze_Return_Type). + elsif From_Limited_With (Etype (N)) and then Present (Non_Limited_View (Etype (N))) + and then + (Ekind (Non_Limited_View (Etype (N))) /= E_Incomplete_Type + or else Is_Thunk (Current_Scope)) then Set_Etype (N, Non_Limited_View (Etype (N))); @@ -2368,6 +2375,16 @@ package body Sem_Ch4 is procedure Check_Action_OK (A : Node_Id) is begin if not Comes_From_Source (N) or else not Comes_From_Source (A) then + + -- If, for example, an (illegal) expression function is + -- transformed into a "vanilla" function then we don't want to + -- allow it just because Comes_From_Source is now False. So look + -- at the Original_Node. + + if Is_Rewrite_Substitution (A) then + Check_Action_OK (Original_Node (A)); + end if; + return; -- Allow anything in generated code end if; @@ -2400,10 +2417,27 @@ package body Sem_Ch4 is return; -- ???For now; the RM rule is a bit more complicated end if; + when N_Pragma => + declare + -- See AI22-0045 pragma categorization. + subtype Executable_Pragma_Id is Pragma_Id + with Predicate => Executable_Pragma_Id in + -- language-defined executable pragmas + Pragma_Assert | Pragma_Inspection_Point + + -- GNAT-defined executable pragmas + | Pragma_Assume | Pragma_Debug; + begin + if Get_Pragma_Id (A) in Executable_Pragma_Id then + return; + end if; + end; + when others => - null; -- Nothing else allowed, not even pragmas + null; -- Nothing else allowed end case; + -- We could mention pragmas in the message text; let's not. Error_Msg_N ("object renaming or constant declaration expected", A); end Check_Action_OK; @@ -3124,6 +3158,20 @@ package body Sem_Ch4 is Operator_Check (N); Check_Function_Writable_Actuals (N); + + if Style_Check then + if Nkind (L) not in N_Short_Circuit | N_Op_And | N_Op_Or | N_Op_Xor + and then Is_Boolean_Type (Etype (L)) + then + Check_Xtra_Parens_Precedence (L); + end if; + + if Nkind (R) not in N_Short_Circuit | N_Op_And | N_Op_Or | N_Op_Xor + and then Is_Boolean_Type (Etype (R)) + then + Check_Xtra_Parens_Precedence (R); + end if; + end if; end Analyze_Logical_Op; --------------------------- @@ -3385,6 +3433,26 @@ package body Sem_Ch4 is Analyze_Set_Membership; + declare + Alt : Node_Id; + begin + Alt := First (Alternatives (N)); + while Present (Alt) loop + if Is_Entity_Name (Alt) and then Is_Type (Entity (Alt)) then + Check_Fully_Declared (Entity (Alt), Alt); + + if Has_Ghost_Predicate_Aspect (Entity (Alt)) then + Error_Msg_NE + ("subtype& has ghost predicate, " + & "not allowed in membership test", + Alt, Entity (Alt)); + end if; + end if; + + Next (Alt); + end loop; + end; + elsif Nkind (R) = N_Range or else (Nkind (R) = N_Attribute_Reference and then Attribute_Name (R) = Name_Range) @@ -3404,6 +3472,13 @@ package body Sem_Ch4 is Find_Type (R); Check_Fully_Declared (Entity (R), R); + if Has_Ghost_Predicate_Aspect (Entity (R)) then + Error_Msg_NE + ("subtype& has ghost predicate, " + & "not allowed in membership test", + R, Entity (R)); + end if; + elsif Ada_Version >= Ada_2012 and then Find_Interp then Op := Make_Op_Eq (Loc, Left_Opnd => L, Right_Opnd => R); Resolve_Membership_Equality (Op, Etype (L)); @@ -4838,16 +4913,6 @@ package body Sem_Ch4 is -- 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 - -- component with the proper identifier. This is only done if all other - -- searches have failed. If a match is found, the Etype of both N and - -- Sel are set from this component, and the entity of Sel is set to - -- reference this component. If no match is found, Entity (Sel) remains - -- unset. For a derived type that is an actual of the instance, the - -- desired component may be found in any ancestor. - function Has_Mode_Conformant_Spec (Comp : Entity_Id) return Boolean; -- It is known that the parent of N denotes a subprogram call. Comp -- is an overloadable component of the concurrent type of the prefix. @@ -4866,6 +4931,14 @@ package body Sem_Ch4 is -- _Procedure, and collect all its interpretations (since it may be an -- overloaded interface primitive); otherwise return False. + function Try_Selected_Component_In_Instance + (Typ : Entity_Id) return Boolean; + -- If Typ is the actual for a formal derived type, or a derived type + -- thereof, the component inherited from the generic parent may not + -- be visible in the actual, but the selected component is legal. Climb + -- up the derivation chain of the generic parent type and return True if + -- we find the proper ancestor type; otherwise return False. + ------------------------------------------------------ -- Constraint_Has_Unprefixed_Discriminant_Reference -- ------------------------------------------------------ @@ -4873,10 +4946,9 @@ package body Sem_Ch4 is 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)); + (Nkind (N) = N_Identifier + and then Ekind (Entity (N)) = E_Discriminant); begin if Is_Array_Type (Typ) then declare @@ -4916,49 +4988,6 @@ package body Sem_Ch4 is return False; end Constraint_Has_Unprefixed_Discriminant_Reference; - -------------------------------- - -- Find_Component_In_Instance -- - -------------------------------- - - procedure Find_Component_In_Instance (Rec : Entity_Id) is - Comp : Entity_Id; - Typ : Entity_Id; - - begin - Typ := Rec; - while Present (Typ) loop - Comp := First_Component (Typ); - while Present (Comp) loop - if Chars (Comp) = Chars (Sel) then - Set_Entity_With_Checks (Sel, Comp); - Set_Etype (Sel, Etype (Comp)); - Set_Etype (N, Etype (Comp)); - return; - end if; - - Next_Component (Comp); - end loop; - - -- If not found, the component may be declared in the parent - -- type or its full view, if any. - - if Is_Derived_Type (Typ) then - Typ := Etype (Typ); - - if Is_Private_Type (Typ) then - Typ := Full_View (Typ); - end if; - - else - return; - end if; - end loop; - - -- If we fall through, no match, so no changes made - - return; - end Find_Component_In_Instance; - ------------------------------ -- Has_Mode_Conformant_Spec -- ------------------------------ @@ -5096,6 +5125,122 @@ package body Sem_Ch4 is return Present (Candidate); end Try_By_Protected_Procedure_Prefixed_View; + ---------------------------------------- + -- Try_Selected_Component_In_Instance -- + ---------------------------------------- + + function Try_Selected_Component_In_Instance + (Typ : Entity_Id) return Boolean + is + 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 component with the proper identifier. If a match is + -- found, the Etype of both N and Sel are set from this component, + -- and the entity of Sel is set to reference this component. If no + -- match is found, Entity (Sel) remains unset. For a derived type + -- that is an actual of the instance, the desired component may be + -- found in any ancestor. + + -------------------------------- + -- Find_Component_In_Instance -- + -------------------------------- + + procedure Find_Component_In_Instance (Rec : Entity_Id) is + Comp : Entity_Id; + Typ : Entity_Id; + + begin + Typ := Rec; + while Present (Typ) loop + Comp := First_Component (Typ); + while Present (Comp) loop + if Chars (Comp) = Chars (Sel) then + Set_Entity_With_Checks (Sel, Comp); + Set_Etype (Sel, Etype (Comp)); + Set_Etype (N, Etype (Comp)); + return; + end if; + + Next_Component (Comp); + end loop; + + -- If not found, the component may be declared in the parent + -- type or its full view, if any. + + if Is_Derived_Type (Typ) then + Typ := Etype (Typ); + + if Is_Private_Type (Typ) then + Typ := Full_View (Typ); + end if; + + else + return; + end if; + end loop; + + -- If we fall through, no match, so no changes made + + return; + end Find_Component_In_Instance; + + -- Local variables + + Par : Entity_Id; + + -- Start of processing for Try_Selected_Component_In_Instance + + begin + pragma Assert (In_Instance and then Is_Tagged_Type (Typ)); + pragma Assert (Etype (N) = Any_Type); + + -- Climb up derivation chain to generic actual subtype + + Par := Typ; + while not Is_Generic_Actual_Type (Par) loop + if Ekind (Par) = E_Record_Type then + Par := Parent_Subtype (Par); + exit when No (Par); + else + exit when Par = Etype (Par); + Par := Etype (Par); + end if; + end loop; + + if Present (Par) and then Is_Generic_Actual_Type (Par) then + + -- Now look for component in ancestor types + + Par := Generic_Parent_Type (Declaration_Node (Par)); + loop + Find_Component_In_Instance (Par); + exit when Present (Entity (Sel)) + or else Par = Etype (Par); + Par := Etype (Par); + end loop; + + -- Another special case: the type is an extension of a private + -- type T, either is an actual in an instance or is immediately + -- visible, and we are in the body of the instance, which means + -- the generic body had a full view of the type declaration for + -- T or some ancestor that defines the component in question. + -- This happens because Is_Visible_Component returned False on + -- this component, as T or the ancestor is still private since + -- the Has_Private_View mechanism is bypassed because T or the + -- ancestor is not directly referenced in the generic body. + + elsif Is_Derived_Type (Typ) + and then (Used_As_Generic_Actual (Typ) + or else Is_Immediately_Visible (Typ)) + and then In_Instance_Body + then + Find_Component_In_Instance (Parent_Subtype (Typ)); + end if; + + return Etype (N) /= Any_Type; + end Try_Selected_Component_In_Instance; + -- Start of processing for Analyze_Selected_Component begin @@ -5449,6 +5594,22 @@ package body Sem_Ch4 is elsif Try_By_Protected_Procedure_Prefixed_View then return; + -- If the prefix type is the actual for a formal derived type, + -- or a derived type thereof, the component inherited from the + -- generic parent may not be visible in the actual, but the + -- selected component is legal. This case must be handled before + -- trying the object.operation notation to avoid reporting + -- spurious errors, but must be skipped when Is_Prefixed_Call has + -- been set (because that means that this node was resolved to an + -- Object.Operation call when the generic unit was analyzed). + + elsif In_Instance + and then not Is_Prefixed_Call (N) + and then Is_Tagged_Type (Prefix_Type) + and then Try_Selected_Component_In_Instance (Type_To_Use) + then + return; + elsif Try_Object_Operation (N) then return; end if; @@ -5809,65 +5970,23 @@ package body Sem_Ch4 is -- Similarly, if this is the actual for a formal derived type, or -- a derived type thereof, the component inherited from the generic -- parent may not be visible in the actual, but the selected - -- component is legal. Climb up the derivation chain of the generic - -- parent type until we find the proper ancestor type. + -- component is legal. elsif In_Instance and then Is_Tagged_Type (Prefix_Type) then - declare - Par : Entity_Id := Prefix_Type; - begin - -- Climb up derivation chain to generic actual subtype - - while not Is_Generic_Actual_Type (Par) loop - if Ekind (Par) = E_Record_Type then - Par := Parent_Subtype (Par); - exit when No (Par); - else - exit when Par = Etype (Par); - Par := Etype (Par); - end if; - end loop; - - if Present (Par) and then Is_Generic_Actual_Type (Par) then - -- Now look for component in ancestor types + -- Climb up the derivation chain of the generic parent type until + -- we find the proper ancestor type. - Par := Generic_Parent_Type (Declaration_Node (Par)); - loop - Find_Component_In_Instance (Par); - exit when Present (Entity (Sel)) - or else Par = Etype (Par); - Par := Etype (Par); - end loop; - - -- Another special case: the type is an extension of a private - -- type T, either is an actual in an instance or is immediately - -- visible, and we are in the body of the instance, which means - -- the generic body had a full view of the type declaration for - -- T or some ancestor that defines the component in question. - -- This happens because Is_Visible_Component returned False on - -- this component, as T or the ancestor is still private since - -- the Has_Private_View mechanism is bypassed because T or the - -- ancestor is not directly referenced in the generic body. - - elsif Is_Derived_Type (Type_To_Use) - and then (Used_As_Generic_Actual (Type_To_Use) - or else Is_Immediately_Visible (Type_To_Use)) - and then In_Instance_Body - then - Find_Component_In_Instance (Parent_Subtype (Type_To_Use)); - end if; - end; + if Try_Selected_Component_In_Instance (Type_To_Use) then + return; -- The search above must have eventually succeeded, since the -- selected component was legal in the generic. - if No (Entity (Sel)) then + else raise Program_Error; end if; - return; - -- Component not found, specialize error message when appropriate else @@ -5997,6 +6116,18 @@ package body Sem_Ch4 is Resolve (R, Standard_Boolean); Set_Etype (N, Standard_Boolean); end if; + + if Style_Check then + if Nkind (L) not in N_Short_Circuit | N_Op_And | N_Op_Or | N_Op_Xor + then + Check_Xtra_Parens_Precedence (L); + end if; + + if Nkind (R) not in N_Short_Circuit | N_Op_And | N_Op_Or | N_Op_Xor + then + Check_Xtra_Parens_Precedence (R); + end if; + end if; end Analyze_Short_Circuit; ------------------- @@ -7519,19 +7650,11 @@ package body Sem_Ch4 is if Etype (N) = Any_Type then declare - L : Node_Id; - R : Node_Id; - Op_Id : Entity_Id := Empty; + L : constant Node_Id := + (if Nkind (N) in N_Binary_Op then Left_Opnd (N) else Empty); + R : constant Node_Id := Right_Opnd (N); begin - R := Right_Opnd (N); - - if Nkind (N) in N_Binary_Op then - L := Left_Opnd (N); - else - L := Empty; - end if; - -- If either operand has no type, then don't complain further, -- since this simply means that we have a propagated error. @@ -7612,9 +7735,10 @@ package body Sem_Ch4 is then return; - elsif Present (Entity (N)) - and then Has_Possible_Literal_Aspects (N) - then + -- The handling of user-defined literals is deferred to the second + -- pass of resolution. + + elsif Has_Possible_User_Defined_Literal (N) then return; -- If we have a logical operator, one of whose operands is @@ -7829,117 +7953,19 @@ package body Sem_Ch4 is end if; end if; - -- If we fall through then just give general message. Note that in - -- the following messages, if the operand is overloaded we choose - -- an arbitrary type to complain about, but that is probably more - -- useful than not giving a type at all. - - if Nkind (N) in N_Unary_Op then - Error_Msg_Node_2 := Etype (R); - Error_Msg_N ("operator& not defined for}", N); - return; - - else - if Nkind (N) in N_Binary_Op then - if not Is_Overloaded (L) - and then not Is_Overloaded (R) - and then Base_Type (Etype (L)) = Base_Type (Etype (R)) - then - Error_Msg_Node_2 := First_Subtype (Etype (R)); - Error_Msg_N ("there is no applicable operator& for}", N); - - else - -- Another attempt to find a fix: one of the candidate - -- interpretations may not be use-visible. This has - -- already been checked for predefined operators, so - -- we examine only user-defined functions. - - Op_Id := Get_Name_Entity_Id (Chars (N)); - - while Present (Op_Id) loop - if Ekind (Op_Id) /= E_Operator - and then Is_Overloadable (Op_Id) - then - if not Is_Immediately_Visible (Op_Id) - and then not In_Use (Scope (Op_Id)) - and then not Is_Abstract_Subprogram (Op_Id) - and then not Is_Hidden (Op_Id) - and then Ekind (Scope (Op_Id)) = E_Package - and then - Has_Compatible_Type - (L, Etype (First_Formal (Op_Id))) - and then Present - (Next_Formal (First_Formal (Op_Id))) - and then - Has_Compatible_Type - (R, - Etype (Next_Formal (First_Formal (Op_Id)))) - then - Error_Msg_N - ("no legal interpretation for operator&", N); - Error_Msg_NE - ("\use clause on& would make operation legal", - N, Scope (Op_Id)); - exit; - end if; - end if; - - Op_Id := Homonym (Op_Id); - end loop; - - if No (Op_Id) then - Error_Msg_N ("invalid operand types for operator&", N); - - if Nkind (N) /= N_Op_Concat then - Error_Msg_NE ("\left operand has}!", N, Etype (L)); - Error_Msg_NE ("\right operand has}!", N, Etype (R)); - - -- For multiplication and division operators with - -- a fixed-point operand and an integer operand, - -- indicate that the integer operand should be of - -- type Integer. - - if Nkind (N) in N_Op_Multiply | N_Op_Divide - and then Is_Fixed_Point_Type (Etype (L)) - and then Is_Integer_Type (Etype (R)) - then - Error_Msg_N - ("\convert right operand to `Integer`", N); - - elsif Nkind (N) = N_Op_Multiply - and then Is_Fixed_Point_Type (Etype (R)) - and then Is_Integer_Type (Etype (L)) - then - Error_Msg_N - ("\convert left operand to `Integer`", N); - end if; - - -- For concatenation operators it is more difficult to - -- determine which is the wrong operand. It is worth - -- flagging explicitly an access type, for those who - -- might think that a dereference happens here. + -- If we fall through then just give general message - elsif Is_Access_Type (Etype (L)) then - Error_Msg_N ("\left operand is access type", N); - - elsif Is_Access_Type (Etype (R)) then - Error_Msg_N ("\right operand is access type", N); - end if; - end if; - end if; - end if; - end if; + Unresolved_Operator (N); end; end if; end Operator_Check; - ---------------------------------- - -- Has_Possible_Literal_Aspects -- - ---------------------------------- + --------------------------------------- + -- Has_Possible_User_Defined_Literal -- + --------------------------------------- - function Has_Possible_Literal_Aspects (N : Node_Id) return Boolean is + function Has_Possible_User_Defined_Literal (N : Node_Id) return Boolean is R : constant Node_Id := Right_Opnd (N); - L : Node_Id := Empty; procedure Check_Literal_Opnd (Opnd : Node_Id); -- If an operand is a literal to which an aspect may apply, @@ -7953,25 +7979,20 @@ package body Sem_Ch4 is begin if Nkind (Opnd) in N_Numeric_Or_String_Literal or else (Is_Entity_Name (Opnd) - and then Present (Entity (Opnd)) - and then Is_Named_Number (Entity (Opnd))) + and then Present (Entity (Opnd)) + and then Is_Named_Number (Entity (Opnd))) then Add_One_Interp (N, Etype (Opnd), Etype (Opnd)); end if; end Check_Literal_Opnd; - -- Start of processing for Has_Possible_Literal_Aspects + -- Start of processing for Has_Possible_User_Defined_Literal begin if Ada_Version < Ada_2022 then return False; end if; - if Nkind (N) in N_Binary_Op then - L := Left_Opnd (N); - else - L := Empty; - end if; Check_Literal_Opnd (R); -- Check left operand only if right one did not provide a @@ -7987,14 +8008,12 @@ package body Sem_Ch4 is -- determine whether a user-defined literal may apply to -- either or both. - if Present (L) - and then Etype (N) = Any_Type - then - Check_Literal_Opnd (L); + if Nkind (N) in N_Binary_Op and then Etype (N) = Any_Type then + Check_Literal_Opnd (Left_Opnd (N)); end if; return Etype (N) /= Any_Type; - end Has_Possible_Literal_Aspects; + end Has_Possible_User_Defined_Literal; ----------------------------------------------- -- Nondispatching_Call_To_Abstract_Operation -- @@ -10620,6 +10639,106 @@ package body Sem_Ch4 is end if; end Try_Object_Operation; + ------------------------- + -- Unresolved_Operator -- + ------------------------- + + procedure Unresolved_Operator (N : Node_Id) is + L : constant Node_Id := + (if Nkind (N) in N_Binary_Op then Left_Opnd (N) else Empty); + R : constant Node_Id := Right_Opnd (N); + + Op_Id : Entity_Id; + + begin + -- Note that in the following messages, if the operand is overloaded we + -- choose an arbitrary type to complain about, but that is probably more + -- useful than not giving a type at all. + + if Nkind (N) in N_Unary_Op then + Error_Msg_Node_2 := Etype (R); + Error_Msg_N ("operator& not defined for}", N); + + elsif Nkind (N) in N_Binary_Op then + if not Is_Overloaded (L) + and then not Is_Overloaded (R) + and then Base_Type (Etype (L)) = Base_Type (Etype (R)) + then + Error_Msg_Node_2 := First_Subtype (Etype (R)); + Error_Msg_N ("there is no applicable operator& for}", N); + + else + -- Another attempt to find a fix: one of the candidate + -- interpretations may not be use-visible. This has + -- already been checked for predefined operators, so + -- we examine only user-defined functions. + + Op_Id := Get_Name_Entity_Id (Chars (N)); + + while Present (Op_Id) loop + if Ekind (Op_Id) /= E_Operator + and then Is_Overloadable (Op_Id) + and then not Is_Immediately_Visible (Op_Id) + and then not In_Use (Scope (Op_Id)) + and then not Is_Abstract_Subprogram (Op_Id) + and then not Is_Hidden (Op_Id) + and then Ekind (Scope (Op_Id)) = E_Package + and then Has_Compatible_Type (L, Etype (First_Formal (Op_Id))) + and then Present (Next_Formal (First_Formal (Op_Id))) + and then + Has_Compatible_Type + (R, Etype (Next_Formal (First_Formal (Op_Id)))) + then + Error_Msg_N ("no legal interpretation for operator&", N); + Error_Msg_NE ("\use clause on& would make operation legal", + N, Scope (Op_Id)); + exit; + end if; + + Op_Id := Homonym (Op_Id); + end loop; + + if No (Op_Id) then + Error_Msg_N ("invalid operand types for operator&", N); + + if Nkind (N) /= N_Op_Concat then + Error_Msg_NE ("\left operand has}!", N, Etype (L)); + Error_Msg_NE ("\right operand has}!", N, Etype (R)); + + -- For multiplication and division operators with + -- a fixed-point operand and an integer operand, + -- indicate that the integer operand should be of + -- type Integer. + + if Nkind (N) in N_Op_Multiply | N_Op_Divide + and then Is_Fixed_Point_Type (Etype (L)) + and then Is_Integer_Type (Etype (R)) + then + Error_Msg_N ("\convert right operand to `Integer`", N); + + elsif Nkind (N) = N_Op_Multiply + and then Is_Fixed_Point_Type (Etype (R)) + and then Is_Integer_Type (Etype (L)) + then + Error_Msg_N ("\convert left operand to `Integer`", N); + end if; + + -- For concatenation operators it is more difficult to + -- determine which is the wrong operand. It is worth + -- flagging explicitly an access type, for those who + -- might think that a dereference happens here. + + elsif Is_Access_Type (Etype (L)) then + Error_Msg_N ("\left operand is access type", N); + + elsif Is_Access_Type (Etype (R)) then + Error_Msg_N ("\right operand is access type", N); + end if; + end if; + end if; + end if; + end Unresolved_Operator; + --------- -- wpo -- --------- diff --git a/gcc/ada/sem_ch4.ads b/gcc/ada/sem_ch4.ads index a0e2069..6f266a7 100644 --- a/gcc/ada/sem_ch4.ads +++ b/gcc/ada/sem_ch4.ads @@ -88,4 +88,7 @@ package Sem_Ch4 is -- of a non-tagged type is allowed as if Extensions_Allowed returned True. -- This is used to issue better error messages. + procedure Unresolved_Operator (N : Node_Id); + -- Give an error for an unresolved operator + end Sem_Ch4; diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index ab5a208..fa36a5a 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -113,7 +113,7 @@ package body Sem_Ch5 is procedure Analyze_Assignment (N : Node_Id) is Lhs : constant Node_Id := Name (N); - Rhs : Node_Id := Expression (N); + Rhs : constant Node_Id := Expression (N); procedure Diagnose_Non_Variable_Lhs (N : Node_Id); -- N is the node for the left hand side of an assignment, and it is not @@ -137,27 +137,6 @@ package body Sem_Ch5 is -- nominal subtype. This procedure is used to deal with cases where the -- nominal subtype must be replaced by the actual subtype. - procedure Transform_BIP_Assignment (Typ : Entity_Id); - function Should_Transform_BIP_Assignment - (Typ : Entity_Id) return Boolean; - -- If the right-hand side of an assignment statement is a build-in-place - -- call we cannot build in place, so we insert a temp initialized with - -- the call, and transform the assignment statement to copy the temp. - -- Transform_BIP_Assignment does the transformation, and - -- Should_Transform_BIP_Assignment determines whether we should. - -- The same goes for qualified expressions and conversions whose - -- operand is such a call. - -- - -- This is only for nonlimited types; assignment statements are illegal - -- for limited types, but are generated internally for aggregates and - -- init procs. These limited-type are not really assignment statements - -- -- conceptually, they are initializations, so should not be - -- transformed. - -- - -- Similarly, for nonlimited types, aggregates and init procs generate - -- assignment statements that are really initializations. These are - -- marked No_Ctrl_Actions. - function Within_Function return Boolean; -- Determine whether the current scope is a function or appears within -- one. @@ -324,10 +303,13 @@ package body Sem_Ch5 is then Opnd_Type := Get_Actual_Subtype (Opnd); - -- If assignment operand is a component reference, then we get the - -- actual subtype of the component for the unconstrained case. + -- If the assignment operand is a component reference, then we build + -- the actual subtype of the component for the unconstrained case, + -- unless there is already one or the type is an unchecked union. - elsif Nkind (Opnd) in N_Selected_Component | N_Explicit_Dereference + elsif (Nkind (Opnd) = N_Selected_Component + or else (Nkind (Opnd) = N_Explicit_Dereference + and then No (Actual_Designated_Subtype (Opnd)))) and then not Is_Unchecked_Union (Opnd_Type) then Decl := Build_Actual_Subtype_Of_Component (Opnd_Type, Opnd); @@ -351,87 +333,6 @@ package body Sem_Ch5 is end if; end Set_Assignment_Type; - ------------------------------------- - -- Should_Transform_BIP_Assignment -- - ------------------------------------- - - function Should_Transform_BIP_Assignment - (Typ : Entity_Id) return Boolean - is - begin - if Expander_Active - and then not Is_Limited_View (Typ) - and then Is_Build_In_Place_Result_Type (Typ) - and then not No_Ctrl_Actions (N) - then - -- This function is called early, before name resolution is - -- complete, so we have to deal with things that might turn into - -- function calls later. N_Function_Call and N_Op nodes are the - -- obvious case. An N_Identifier or N_Expanded_Name is a - -- parameterless function call if it denotes a function. - -- Finally, an attribute reference can be a function call. - - declare - Unqual_Rhs : constant Node_Id := Unqual_Conv (Rhs); - begin - case Nkind (Unqual_Rhs) is - when N_Function_Call - | N_Op - => - return True; - - when N_Expanded_Name - | N_Identifier - => - return - Ekind (Entity (Unqual_Rhs)) in E_Function | E_Operator; - - -- T'Input will turn into a call whose result type is T - - when N_Attribute_Reference => - return Attribute_Name (Unqual_Rhs) = Name_Input; - - when others => - return False; - end case; - end; - else - return False; - end if; - end Should_Transform_BIP_Assignment; - - ------------------------------ - -- Transform_BIP_Assignment -- - ------------------------------ - - procedure Transform_BIP_Assignment (Typ : Entity_Id) is - - -- Tranform "X : [constant] T := F (...);" into: - -- - -- Temp : constant T := F (...); - -- X := Temp; - - Loc : constant Source_Ptr := Sloc (N); - Def_Id : constant Entity_Id := Make_Temporary (Loc, 'Y', Rhs); - Obj_Decl : constant Node_Id := - Make_Object_Declaration (Loc, - Defining_Identifier => Def_Id, - Constant_Present => True, - Object_Definition => New_Occurrence_Of (Typ, Loc), - Expression => Rhs, - Has_Init_Expression => True); - - begin - Set_Etype (Def_Id, Typ); - Set_Expression (N, New_Occurrence_Of (Def_Id, Loc)); - - -- At this point, Rhs is no longer equal to Expression (N), so: - - Rhs := Expression (N); - - Insert_Action (N, Obj_Decl); - end Transform_BIP_Assignment; - --------------------- -- Within_Function -- --------------------- @@ -607,56 +508,6 @@ package body Sem_Ch5 is end if; end if; - -- Deal with build-in-place calls for nonlimited types. We don't do this - -- later, because resolving the rhs tranforms it incorrectly for build- - -- in-place. - - if Should_Transform_BIP_Assignment (Typ => T1) then - - -- In certain cases involving user-defined concatenation operators, - -- we need to resolve the right-hand side before transforming the - -- assignment. - - case Nkind (Unqual_Conv (Rhs)) is - when N_Function_Call => - declare - Actual : Node_Id := - First (Parameter_Associations (Unqual_Conv (Rhs))); - Actual_Exp : Node_Id; - - begin - while Present (Actual) loop - if Nkind (Actual) = N_Parameter_Association then - Actual_Exp := Explicit_Actual_Parameter (Actual); - else - Actual_Exp := Actual; - end if; - - if Nkind (Actual_Exp) = N_Op_Concat then - Resolve (Rhs, T1); - exit; - end if; - - Next (Actual); - end loop; - end; - - when N_Attribute_Reference - | N_Expanded_Name - | N_Identifier - | N_Op - => - null; - - when others => - raise Program_Error; - end case; - - Transform_BIP_Assignment (Typ => T1); - end if; - - pragma Assert (not Should_Transform_BIP_Assignment (Typ => T1)); - -- The resulting assignment type is T1, so now we will resolve the left -- hand side of the assignment using this determined type. @@ -1300,8 +1151,6 @@ package body Sem_Ch5 is Full_Analysis := Save_Full_Analysis; Current_Assignment := Empty; end if; - - pragma Assert (not Should_Transform_BIP_Assignment (Typ => T1)); end if; end Analyze_Assignment; @@ -2371,6 +2220,7 @@ package body Sem_Ch5 is -- iterator name. Mutate_Ekind (Def_Id, E_Variable); + Set_Is_Not_Self_Hidden (Def_Id); -- Provide a link between the iterator variable and the container, for -- subsequent use in cross-reference and modification information. @@ -2649,6 +2499,7 @@ package body Sem_Ch5 is else Mutate_Ekind (Def_Id, E_Loop_Parameter); + Set_Is_Not_Self_Hidden (Def_Id); Error_Msg_Ada_2012_Feature ("container iterator", Sloc (N)); -- OF present @@ -2702,6 +2553,7 @@ package body Sem_Ch5 is if Has_Aspect (Typ, Aspect_Variable_Indexing) then Mutate_Ekind (Def_Id, E_Variable); + Set_Is_Not_Self_Hidden (Def_Id); end if; -- If the container is a constant, iterating over it @@ -2853,10 +2705,10 @@ package body Sem_Ch5 is end if; end if; - if Present (Iterator_Filter (N)) then - -- Preanalyze the filter. Expansion will take place when enclosing - -- loop is expanded. + -- Preanalyze the filter. Expansion will take place when enclosing + -- loop is expanded. + if Present (Iterator_Filter (N)) then Preanalyze_And_Resolve (Iterator_Filter (N), Standard_Boolean); end if; end Analyze_Iterator_Specification; @@ -2963,7 +2815,8 @@ package body Sem_Ch5 is and then Has_Predicates (T) and then (not Has_Static_Predicate (T) or else not Is_Static_Subtype (T) - or else Has_Dynamic_Predicate_Aspect (T)) + or else Has_Dynamic_Predicate_Aspect (T) + or else Has_Ghost_Predicate_Aspect (T)) then -- Seems a confusing message for the case of a static predicate -- with a non-static subtype??? @@ -3326,6 +3179,7 @@ package body Sem_Ch5 is end if; Mutate_Ekind (Id, E_Loop_Parameter); + Set_Is_Not_Self_Hidden (Id); -- A quantified expression which appears in a pre- or post-condition may -- be analyzed multiple times. The analysis of the range creates several @@ -3570,8 +3424,11 @@ package body Sem_Ch5 is end; end if; + -- Preanalyze the filter. Expansion will take place when enclosing + -- loop is expanded. + if Present (Iterator_Filter (N)) then - Analyze_And_Resolve (Iterator_Filter (N), Standard_Boolean); + Preanalyze_And_Resolve (Iterator_Filter (N), Standard_Boolean); end if; -- A loop parameter cannot be effectively volatile (SPARK RM 7.1.3(4)). diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index d4701ae..62ca985 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -226,6 +226,10 @@ package body Sem_Ch6 is -- Preanalysis of default expressions of subprogram formals. N is the -- expression to be analyzed and T is the expected type. + procedure Set_Formal_Mode (Formal_Id : Entity_Id); + -- Set proper Ekind to reflect formal mode (in, out, in out), and set + -- miscellaneous other attributes. + procedure Set_Formal_Validity (Formal_Id : Entity_Id); -- Formal_Id is an formal parameter entity. This procedure deals with -- setting the proper validity status for this entity, which depends on @@ -357,6 +361,13 @@ package body Sem_Ch6 is Ret := Make_Simple_Return_Statement (LocX, Expr); + -- Remove parens around the expression, so that if the expression will + -- appear without them when pretty-printed in error messages. + + if Paren_Count (Expr) > 0 then + Set_Paren_Count (Expr, Paren_Count (Expr) - 1); + end if; + New_Body := Make_Subprogram_Body (Loc, Specification => New_Spec, @@ -379,9 +390,7 @@ package body Sem_Ch6 is -- function to the proper body when the expression function acts -- as a completion. - if Has_Aspects (N) then - Move_Aspects (N, To => New_Body); - end if; + Move_Aspects (N, To => New_Body); Relocate_Pragmas_To_Body (New_Body); @@ -838,6 +847,7 @@ package body Sem_Ch6 is and then Serious_Errors_Detected = 0 and then Is_Access_Type (R_Type) and then Nkind (Expr) not in N_Null | N_Raise_Expression + and then Is_Access_Type (Etype (Expr)) and then Is_Interface (Designated_Type (R_Type)) and then Is_Progenitor (Designated_Type (R_Type), Designated_Type (Etype (Expr))) @@ -847,6 +857,14 @@ package body Sem_Ch6 is end if; Resolve (Expr, R_Type); + + -- The expansion of the expression may have rewritten the return + -- statement itself, e.g. when it is a conditional expression. + + if Nkind (N) /= N_Simple_Return_Statement then + return; + end if; + Check_Limited_Return (N, Expr, R_Type); Check_Return_Construct_Accessibility (N, Stm_Entity); @@ -942,9 +960,7 @@ package body Sem_Ch6 is -- Defend against previous errors - if Nkind (Expr) = N_Empty - or else No (Etype (Expr)) - then + if Nkind (Expr) = N_Empty or else No (Etype (Expr)) then return; end if; @@ -1225,6 +1241,10 @@ package body Sem_Ch6 is (E_Function | E_Procedure | E_Generic_Function | E_Generic_Procedure => True, others => False)); + Reinit_Field_To_Zero (Body_Id, F_Needs_No_Actuals); + if Ekind (Body_Id) in E_Function | E_Procedure then + Reinit_Field_To_Zero (Body_Id, F_Is_Inlined_Always); + end if; Mutate_Ekind (Body_Id, E_Subprogram_Body); Set_Convention (Body_Id, Convention (Gen_Id)); Set_Is_Obsolescent (Body_Id, Is_Obsolescent (Gen_Id)); @@ -2033,7 +2053,7 @@ package body Sem_Ch6 is procedure Analyze_Return_Type (N : Node_Id) is Designator : constant Entity_Id := Defining_Entity (N); - Typ : Entity_Id := Empty; + Typ : Entity_Id; begin -- Normal case where result definition does not indicate an error @@ -2262,7 +2282,7 @@ package body Sem_Ch6 is Mask_Types : Elist_Id := No_Elist; Prot_Typ : Entity_Id := Empty; Spec_Decl : Node_Id := Empty; - Spec_Id : Entity_Id; + Spec_Id : Entity_Id := Empty; Last_Real_Spec_Entity : Entity_Id := Empty; -- When we analyze a separate spec, the entity chain ends up containing @@ -2860,9 +2880,7 @@ package body Sem_Ch6 is -- Move aspects to the new spec - if Has_Aspects (N) then - Move_Aspects (N, To => Decl); - end if; + Move_Aspects (N, To => Decl); Insert_Before (N, Decl); Analyze (Decl); @@ -3895,6 +3913,7 @@ package body Sem_Ch6 is and then Serious_Errors_Detected = 0 then Set_Has_Delayed_Freeze (Spec_Id); + Create_Extra_Formals (Spec_Id); Freeze_Before (N, Spec_Id); end if; end if; @@ -4002,13 +4021,17 @@ package body Sem_Ch6 is Reference_Body_Formals (Spec_Id, Body_Id); end if; - Reinit_Field_To_Zero (Body_Id, F_Has_Out_Or_In_Out_Parameter); - Reinit_Field_To_Zero (Body_Id, F_Needs_No_Actuals, - Old_Ekind => (E_Function | E_Procedure => True, others => False)); - Reinit_Field_To_Zero (Body_Id, F_Is_Predicate_Function, - Old_Ekind => (E_Function | E_Procedure => True, others => False)); - Reinit_Field_To_Zero (Body_Id, F_Protected_Subprogram, + Reinit_Field_To_Zero (Body_Id, F_Has_Out_Or_In_Out_Parameter, Old_Ekind => (E_Function | E_Procedure => True, others => False)); + Reinit_Field_To_Zero (Body_Id, F_Needs_No_Actuals); + Reinit_Field_To_Zero (Body_Id, F_Is_Predicate_Function); + Reinit_Field_To_Zero (Body_Id, F_Protected_Subprogram); + Reinit_Field_To_Zero (Body_Id, F_Is_Inlined_Always); + Reinit_Field_To_Zero (Body_Id, F_Is_Generic_Actual_Subprogram); + Reinit_Field_To_Zero (Body_Id, F_Is_Primitive_Wrapper); + Reinit_Field_To_Zero (Body_Id, F_Is_Private_Primitive); + Reinit_Field_To_Zero (Body_Id, F_Original_Protected_Subprogram); + Reinit_Field_To_Zero (Body_Id, F_Wrapped_Entity); if Ekind (Body_Id) = E_Procedure then Reinit_Field_To_Zero (Body_Id, F_Receiving_Entry); @@ -5233,6 +5256,8 @@ package body Sem_Ch6 is Set_Etype (Designator, Standard_Void_Type); end if; + Set_Is_Not_Self_Hidden (Designator); + -- Flag Is_Inlined_Always is True by default, and reversed to False for -- those subprograms which could be inlined in GNATprove mode (because -- Body_To_Inline is non-Empty) but should not be inlined. @@ -5980,41 +6005,35 @@ package body Sem_Ch6 is -- avoids some redundant error messages. and then not Error_Posted (New_Formal) - then - -- It is allowed to omit the null-exclusion in case of stream - -- attribute subprograms. We recognize stream subprograms - -- through their TSS-generated suffix. - declare - TSS_Name : constant TSS_Name_Type := Get_TSS_Name (New_Id); + -- It is allowed to omit the null-exclusion in case of stream + -- attribute subprograms. We recognize stream subprograms + -- through their TSS-generated suffix. - begin - if TSS_Name /= TSS_Stream_Read - and then TSS_Name /= TSS_Stream_Write - and then TSS_Name /= TSS_Stream_Input - and then TSS_Name /= TSS_Stream_Output - then - -- Here we have a definite conformance error. It is worth - -- special casing the error message for the case of a - -- controlling formal (which excludes null). + and then Get_TSS_Name (New_Id) not in TSS_Stream_Read + | TSS_Stream_Write + | TSS_Stream_Input + | TSS_Stream_Output + then + -- Here we have a definite conformance error. It is worth + -- special casing the error message for the case of a + -- controlling formal (which excludes null). - if Is_Controlling_Formal (New_Formal) then - Error_Msg_Node_2 := Scope (New_Formal); - Conformance_Error - ("\controlling formal & of & excludes null, " - & "declaration must exclude null as well", - New_Formal); + if Is_Controlling_Formal (New_Formal) then + Error_Msg_Node_2 := Scope (New_Formal); + Conformance_Error + ("\controlling formal & of & excludes null, " + & "declaration must exclude null as well", + New_Formal); - -- Normal case (couldn't we give more detail here???) + -- Normal case (couldn't we give more detail here???) - else - Conformance_Error - ("\type of & does not match!", New_Formal); - end if; + else + Conformance_Error + ("\type of & does not match!", New_Formal); + end if; - return; - end if; - end; + return; end if; end if; @@ -8391,21 +8410,14 @@ package body Sem_Ch6 is Ctype <= Mode_Conformant or else Subtypes_Statically_Match (Type_1, Full_View (Type_2)); - elsif Is_Private_Type (Type_2) - and then In_Instance - and then Present (Full_View (Type_2)) - and then Base_Types_Match (Type_1, Full_View (Type_2)) - then - return - Ctype <= Mode_Conformant - or else Subtypes_Statically_Match (Type_1, Full_View (Type_2)); - - -- Another confusion between views in a nested instance with an - -- actual private type whose full view is not in scope. + -- The subtype declared for the formal type in an instantiation and the + -- actual type are conforming. Note that testing Is_Generic_Actual_Type + -- here is not sufficient because the flag is only set in the bodies of + -- instances, which is too late for formal subprograms. elsif Ekind (Type_2) = E_Private_Subtype - and then In_Instance and then Etype (Type_2) = Type_1 + and then Present (Generic_Parent_Type (Declaration_Node (Type_2))) then return True; @@ -9017,8 +9029,8 @@ package body Sem_Ch6 is or else not (Is_Limited_Type (Formal_Type) and then - (Is_Tagged_Type - (Underlying_Type (Formal_Type))))) + Is_Tagged_Type + (Underlying_Type (Formal_Type)))) then Set_Extra_Constrained (Formal, Add_Extra_Formal (Formal, Standard_Boolean, E, "O")); @@ -10349,7 +10361,7 @@ package body Sem_Ch6 is FCL (Expressions (E1), Expressions (E2)); when N_Integer_Literal => - return (Intval (E1) = Intval (E2)) + return Intval (E1) = Intval (E2) and then not User_Defined_Numeric_Literal_Mismatch; when N_Null => @@ -10436,7 +10448,7 @@ package body Sem_Ch6 is FCE (High_Bound (E1), High_Bound (E2)); when N_Real_Literal => - return (Realval (E1) = Realval (E2)) + return Realval (E1) = Realval (E2) and then not User_Defined_Numeric_Literal_Mismatch; when N_Selected_Component => @@ -10625,21 +10637,16 @@ package body Sem_Ch6 is else declare - Typ : constant Entity_Id := - Underlying_Type (Find_Dispatching_Type (Alias_E)); + TSS_Name : constant TSS_Name_Type := Get_TSS_Name (E); + Typ : constant Entity_Id := + Underlying_Type (Find_Dispatching_Type (Alias_E)); begin - if (Get_TSS_Name (E) = TSS_Stream_Input - and then not Stream_Operation_OK (Typ, TSS_Stream_Input)) - or else - (Get_TSS_Name (E) = TSS_Stream_Output - and then not Stream_Operation_OK (Typ, TSS_Stream_Output)) - or else - (Get_TSS_Name (E) = TSS_Stream_Read - and then not Stream_Operation_OK (Typ, TSS_Stream_Read)) - or else - (Get_TSS_Name (E) = TSS_Stream_Write - and then not Stream_Operation_OK (Typ, TSS_Stream_Write)) + if TSS_Name in TSS_Stream_Input + | TSS_Stream_Output + | TSS_Stream_Read + | TSS_Stream_Write + and then not Stream_Operation_OK (Typ, TSS_Name) then return False; end if; @@ -11718,7 +11725,7 @@ package body Sem_Ch6 is begin while Present (Param_E1) and then Present (Param_E2) loop - if (Ctype >= Mode_Conformant) and then + if Ctype >= Mode_Conformant and then Ekind (Defining_Identifier (Param_E1)) /= Ekind (Defining_Identifier (Param_E2)) then @@ -13413,6 +13420,8 @@ package body Sem_Ch6 is Mutate_Ekind (Formal_Id, E_In_Parameter); end if; + Set_Is_Not_Self_Hidden (Formal_Id); + -- Set Is_Known_Non_Null for access parameters since the language -- guarantees that access parameters are always non-null. We also set -- Can_Never_Be_Null, since there is no way to change the value. diff --git a/gcc/ada/sem_ch6.ads b/gcc/ada/sem_ch6.ads index b3dc82f..f5ff960 100644 --- a/gcc/ada/sem_ch6.ads +++ b/gcc/ada/sem_ch6.ads @@ -282,9 +282,6 @@ package Sem_Ch6 is -- during execution of the subprogram. By setting the actual subtype -- once, we avoid recomputing it unnecessarily. - procedure Set_Formal_Mode (Formal_Id : Entity_Id); - -- Set proper Ekind to reflect formal mode (in, out, in out) - function Subtype_Conformant (New_Id : Entity_Id; Old_Id : Entity_Id; diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb index 7cb7c86..ecb4bbe 100644 --- a/gcc/ada/sem_ch7.adb +++ b/gcc/ada/sem_ch7.adb @@ -319,8 +319,9 @@ package body Sem_Ch7 is function Set_Referencer_Of_Non_Subprograms return Boolean is begin -- An inlined subprogram body acts as a referencer - -- unless we generate C code since inlining is then - -- handled by the C compiler. + -- unless we generate C code without -gnatn where we want + -- to favor generating static inline functions as much as + -- possible. -- Note that we test Has_Pragma_Inline here in addition -- to Is_Inlined. We are doing this for a client, since @@ -329,7 +330,9 @@ package body Sem_Ch7 is -- should occur, so we need to catch all cases where the -- subprogram may be inlined by the client. - if (not CCG_Mode or else Has_Pragma_Inline_Always (Decl_Id)) + if (not CCG_Mode + or else Has_Pragma_Inline_Always (Decl_Id) + or else Inline_Active) and then (Is_Inlined (Decl_Id) or else Has_Pragma_Inline (Decl_Id)) then @@ -446,7 +449,11 @@ package body Sem_Ch7 is else Decl_Id := Defining_Entity (Decl); + -- See the N_Subprogram_Declaration case below + if not Set_Referencer_Of_Non_Subprograms + and then (not In_Nested_Instance + or else not Subprogram_Table.Get_First) and then not Subprogram_Table.Get (Decl_Id) then -- We can reset Is_Public right away @@ -893,6 +900,9 @@ package body Sem_Ch7 is -- current node otherwise. Note that N was rewritten above, so we must -- be sure to get the latest Body_Id value. + if Ekind (Body_Id) = E_Package then + Reinit_Field_To_Zero (Body_Id, F_Body_Needed_For_Inlining); + end if; Mutate_Ekind (Body_Id, E_Package_Body); Set_Body_Entity (Spec_Id, Body_Id); Set_Spec_Entity (Body_Id, Spec_Id); @@ -1180,6 +1190,8 @@ package body Sem_Ch7 is Generate_Definition (Id); Enter_Name (Id); Mutate_Ekind (Id, E_Package); + Set_Is_Not_Self_Hidden (Id); + -- Needed early because of Set_Categorization_From_Pragmas below Set_Etype (Id, Standard_Void_Type); -- Set SPARK_Mode from context @@ -1927,6 +1939,20 @@ package body Sem_Ch7 is end; end if; + -- Preanalyze class-wide conditions of dispatching primitives defined + -- in nested packages. For library packages, class-wide pre- and + -- postconditions are preanalyzed when the primitives are frozen + -- (see Merge_Class_Conditions); for nested packages, the end of the + -- package does not cause freezing (and hence they must be analyzed + -- now to ensure the correct visibility of referenced entities). + + if not Is_Compilation_Unit (Id) + and then Is_Dispatching_Operation (E) + and then Present (Contract (E)) + then + Preanalyze_Class_Conditions (E); + end if; + Next_Entity (E); end loop; @@ -2720,10 +2746,11 @@ package body Sem_Ch7 is Mutate_Ekind (Id, E_Private_Type); end if; - Set_Etype (Id, Id); + Set_Is_Not_Self_Hidden (Id); + Set_Etype (Id, Id); Set_Has_Delayed_Freeze (Id); - Set_Is_First_Subtype (Id); - Reinit_Size_Align (Id); + Set_Is_First_Subtype (Id); + Reinit_Size_Align (Id); Set_Is_Constrained (Id, No (Discriminant_Specifications (N)) @@ -3187,10 +3214,6 @@ package body Sem_Ch7 is -- is simply that the initializing expression is missing. if not Has_Private_Declaration (Etype (Id)) then - - -- We assume that the user did not intend a deferred constant - -- declaration, and the expression is just missing. - Error_Msg_N ("constant declaration requires initialization expression", Parent (Id)); diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 6f858ee..6e0db36 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -536,6 +536,11 @@ package body Sem_Ch8 is procedure Premature_Usage (N : Node_Id); -- Diagnose usage of an entity before it is visible + function Is_Self_Hidden (E : Entity_Id) return Boolean; + -- True within a declaration if it is hidden from all visibility by itself + -- (see RM-8.3(16-18)). This is mostly just "not Is_Not_Self_Hidden", but + -- we need to check for E_Void in case of errors. + procedure Use_One_Package (N : Node_Id; Pack_Name : Entity_Id := Empty; @@ -3485,9 +3490,13 @@ package body Sem_Ch8 is -- constructed later at the freeze point, so indicate that the -- completion has not been seen yet. - Reinit_Field_To_Zero (New_S, F_Has_Out_Or_In_Out_Parameter); - Reinit_Field_To_Zero (New_S, F_Needs_No_Actuals, + Reinit_Field_To_Zero (New_S, F_Has_Out_Or_In_Out_Parameter, Old_Ekind => (E_Function | E_Procedure => True, others => False)); + Reinit_Field_To_Zero (New_S, F_Needs_No_Actuals); + Reinit_Field_To_Zero (New_S, F_Is_Predicate_Function); + Reinit_Field_To_Zero (New_S, F_Protected_Subprogram); + Reinit_Field_To_Zero (New_S, F_Is_Inlined_Always); + Reinit_Field_To_Zero (New_S, F_Is_Generic_Actual_Subprogram); Mutate_Ekind (New_S, E_Subprogram_Body); New_S := Rename_Spec; Set_Has_Completion (Rename_Spec, False); @@ -5066,7 +5075,6 @@ package body Sem_Ch8 is if Id /= Current_Entity (Id) then Prev := Current_Entity (Id); while Present (Prev) - and then Present (Homonym (Prev)) and then Homonym (Prev) /= Id loop Prev := Homonym (Prev); @@ -5074,7 +5082,7 @@ package body Sem_Ch8 is -- Skip to end of loop if Id is not in the visibility chain - if No (Prev) or else Homonym (Prev) /= Id then + if No (Prev) then goto Next_Ent; end if; @@ -5452,6 +5460,19 @@ package body Sem_Ch8 is end case; end Error_Missing_With_Of_Known_Unit; + -------------------- + -- Is_Self_Hidden -- + -------------------- + + function Is_Self_Hidden (E : Entity_Id) return Boolean is + begin + if Is_Not_Self_Hidden (E) then + return Ekind (E) = E_Void; + else + return True; + end if; + end Is_Self_Hidden; + ---------------------- -- Find_Direct_Name -- ---------------------- @@ -6440,14 +6461,7 @@ package body Sem_Ch8 is Write_Entity_Info (E, " "); end if; - -- If the Ekind of the entity is Void, it means that all homonyms - -- are hidden from all visibility (RM 8.3(5,14-20)). However, this - -- test is skipped if the current scope is a record and the name is - -- a pragma argument expression (case of Atomic and Volatile pragmas - -- and possibly other similar pragmas added later, which are allowed - -- to reference components in the current record). - - if Ekind (E) = E_Void + if Is_Self_Hidden (E) and then (not Is_Record_Type (Current_Scope) or else Nkind (Parent (N)) /= N_Pragma_Argument_Association) @@ -7199,10 +7213,7 @@ package body Sem_Ch8 is Check_Wide_Character_Restriction (Id, N); - -- If the Ekind of the entity is Void, it means that all homonyms are - -- hidden from all visibility (RM 8.3(5,14-20)). - - if Ekind (Id) = E_Void then + if Is_Self_Hidden (Id) then Premature_Usage (N); elsif Is_Overloadable (Id) and then Present (Homonym (Id)) then @@ -7631,8 +7642,8 @@ package body Sem_Ch8 is elsif Present (First_Formal (It.Nam)) and then Present (First_Formal (New_S)) - and then (Base_Type (Etype (First_Formal (It.Nam))) = - Base_Type (Etype (First_Formal (New_S)))) + and then Base_Type (Etype (First_Formal (It.Nam))) = + Base_Type (Etype (First_Formal (New_S))) then Candidate_Renaming := It.Nam; end if; @@ -7664,8 +7675,8 @@ package body Sem_Ch8 is elsif Present (First_Formal (Entity (Nam))) and then Present (First_Formal (New_S)) - and then (Base_Type (Etype (First_Formal (Entity (Nam)))) = - Base_Type (Etype (First_Formal (New_S)))) + and then Base_Type (Etype (First_Formal (Entity (Nam)))) = + Base_Type (Etype (First_Formal (New_S))) then Candidate_Renaming := Entity (Nam); end if; @@ -8145,7 +8156,7 @@ package body Sem_Ch8 is end loop; end; - elsif Ekind (P_Name) = E_Void then + elsif Is_Self_Hidden (P_Name) then Premature_Usage (P); elsif Ekind (P_Name) = E_Generic_Package then @@ -10316,7 +10327,7 @@ package body Sem_Ch8 is if Is_Immediately_Visible (Prev) and then (not Is_Overloadable (Prev) or else not Is_Overloadable (Id) - or else (Type_Conformant (Id, Prev))) + or else Type_Conformant (Id, Prev)) then if No (Current_Instance) then @@ -10419,7 +10430,7 @@ package body Sem_Ch8 is -- On exit, we know entity is not hidden, unless it is private if not Is_Hidden (Id) - and then ((not Is_Child_Unit (Id)) or else Is_Visible_Lib_Unit (Id)) + and then (not Is_Child_Unit (Id) or else Is_Visible_Lib_Unit (Id)) then Set_Is_Potentially_Use_Visible (Id); @@ -10752,7 +10763,7 @@ package body Sem_Ch8 is Error_Msg_Sloc := Sloc (Clause1); Error_Msg_NE -- CODEFIX ("& is already use-visible through previous " - & "use_type_clause #??", Clause2, T); + & "use_type_clause #?r?", Clause2, T); return; end if; @@ -10824,7 +10835,7 @@ package body Sem_Ch8 is Error_Msg_NE -- CODEFIX ("& is already use-visible through previous " - & "use_type_clause #??", Err_No, Id); + & "use_type_clause #?r?", Err_No, Id); end if; end Use_Clause_Known; @@ -10834,7 +10845,7 @@ package body Sem_Ch8 is else Error_Msg_NE -- CODEFIX ("& is already use-visible through previous " - & "use_type_clause??", Id, T); + & "use_type_clause?r?", Id, T); end if; -- The package where T is declared is already used @@ -10849,7 +10860,7 @@ package body Sem_Ch8 is Error_Msg_Sloc := Sloc (Find_First_Use (Current_Use_Clause (Scope (T)))); Error_Msg_NE -- CODEFIX - ("& is already use-visible through package use clause #??", + ("& is already use-visible through package use clause #?r?", Id, T); end if; @@ -10858,7 +10869,7 @@ package body Sem_Ch8 is else Error_Msg_Node_2 := Scope (T); Error_Msg_NE -- CODEFIX - ("& is already use-visible inside package &??", Id, T); + ("& is already use-visible inside package &?r?", Id, T); end if; end if; end Use_One_Type; diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb index e63d48b..72821c5 100644 --- a/gcc/ada/sem_ch9.adb +++ b/gcc/ada/sem_ch9.adb @@ -880,7 +880,7 @@ package body Sem_Ch9 is E := First_Entity (Etype (Task_Nam)); while Present (E) loop if Chars (E) = Chars (Nam) - and then (Ekind (E) = Ekind (Accept_Id)) + and then Ekind (E) = Ekind (Accept_Id) and then Type_Conformant (Accept_Id, E) then Entry_Nam := E; @@ -1305,6 +1305,7 @@ package body Sem_Ch9 is Entry_Name := E; Set_Convention (Id, Convention (E)); Set_Corresponding_Body (Parent (E), Id); + Set_Corresponding_Spec (N, E); Check_Fully_Conformant (Id, E, N); if Ekind (Id) = E_Entry_Family then @@ -2066,6 +2067,7 @@ package body Sem_Ch9 is end if; Mutate_Ekind (T, E_Protected_Type); + Set_Is_Not_Self_Hidden (T); Set_Is_First_Subtype (T); Reinit_Size_Align (T); Set_Etype (T, T); @@ -2179,14 +2181,16 @@ package body Sem_Ch9 is Set_Has_Controlled_Component (T, True); end if; - -- The Ekind of components is E_Void during analysis to detect illegal - -- uses. Now it can be set correctly. + -- The Ekind of components is E_Void during analysis for historical + -- reasons. Now it can be set correctly. E := First_Entity (Current_Scope); while Present (E) loop if Ekind (E) = E_Void then - Mutate_Ekind (E, E_Component); - Reinit_Component_Location (E); + if not Is_Itype (E) then + Mutate_Ekind (E, E_Component); + Reinit_Component_Location (E); + end if; end if; Next_Entity (E); @@ -2500,7 +2504,7 @@ package body Sem_Ch9 is -- for error output in some cases not to do that here. if (No (First_Formal (It.Nam)) - or else (Type_Conformant (Enclosing, It.Nam))) + or else Type_Conformant (Enclosing, It.Nam)) and then Ekind (It.Nam) = E_Entry then -- Ada 2005 (AI-345): Since protected and task types have @@ -2900,6 +2904,7 @@ package body Sem_Ch9 is Enter_Name (Obj_Id); Mutate_Ekind (Obj_Id, E_Variable); + Set_Is_Not_Self_Hidden (Obj_Id); Set_Etype (Obj_Id, Typ); Set_SPARK_Pragma (Obj_Id, SPARK_Mode_Pragma); Set_SPARK_Pragma_Inherited (Obj_Id); @@ -2986,6 +2991,7 @@ package body Sem_Ch9 is Enter_Name (Obj_Id); Mutate_Ekind (Obj_Id, E_Variable); + Set_Is_Not_Self_Hidden (Obj_Id); Set_Etype (Obj_Id, Typ); Set_SPARK_Pragma (Obj_Id, SPARK_Mode_Pragma); Set_SPARK_Pragma_Inherited (Obj_Id); @@ -3264,6 +3270,7 @@ package body Sem_Ch9 is end if; Mutate_Ekind (T, E_Task_Type); + Set_Is_Not_Self_Hidden (T); Set_Is_First_Subtype (T, True); Set_Has_Task (T, True); Reinit_Size_Align (T); diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb index 7820a50..6c8212c 100644 --- a/gcc/ada/sem_disp.adb +++ b/gcc/ada/sem_disp.adb @@ -1392,7 +1392,7 @@ package body Sem_Disp is -- 4. Wrappers built for inherited operations with inherited class- -- wide conditions, where the conditions include calls to other -- overridden primitives. The wrappers include checks on these - -- modified conditions. (AI12-113). + -- modified conditions. (AI12-195). -- 5. Declarations built for subprograms without separate specs that -- are eligible for inlining in GNATprove (inside @@ -1414,9 +1414,9 @@ package body Sem_Disp is and then Is_Null_Interface_Primitive (Ultimate_Alias (Old_Subp))) - or else Get_TSS_Name (Subp) = TSS_Stream_Read - or else Get_TSS_Name (Subp) = TSS_Stream_Write - or else Get_TSS_Name (Subp) = TSS_Put_Image + or else Get_TSS_Name (Subp) in TSS_Stream_Read + | TSS_Stream_Write + | TSS_Put_Image or else (Is_Wrapper (Subp) @@ -1441,7 +1441,7 @@ package body Sem_Disp is -- where it can be a dispatching op is when it overrides an operation -- before the freezing point of the type. - elsif ((not Is_Package_Or_Generic_Package (Scope (Subp))) + elsif (not Is_Package_Or_Generic_Package (Scope (Subp)) or else In_Package_Body (Scope (Subp))) and then not Has_Dispatching_Parent then @@ -1488,7 +1488,7 @@ package body Sem_Disp is Decl_Item := Next (Parent (Tagged_Type)); while Present (Decl_Item) - and then (Decl_Item /= Subp_Body) + and then Decl_Item /= Subp_Body loop if Comes_From_Source (Decl_Item) and then (Nkind (Decl_Item) in N_Proper_Body @@ -2969,7 +2969,7 @@ package body Sem_Disp is end loop; end if; - if (not Is_Package_Or_Generic_Package (Current_Scope)) + if not Is_Package_Or_Generic_Package (Current_Scope) or else not In_Private_Part (Current_Scope) then -- Not a private primitive diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb index 07c3df7..46bad04 100644 --- a/gcc/ada/sem_elab.adb +++ b/gcc/ada/sem_elab.adb @@ -15263,10 +15263,13 @@ package body Sem_Elab is -- Nothing to do for predefined primitives because they are -- artifacts of tagged type expansion and cannot override source -- primitives. Nothing to do as well for inherited primitives, as - -- the check concerns overriding ones. + -- the check concerns overriding ones. Finally, nothing to do for + -- abstract subprograms, because they have no body that could be + -- examined. if Is_Predefined_Dispatching_Operation (Prim) or else not Is_Overriding_Subprogram (Prim) + or else Is_Abstract_Subprogram (Prim) then return; end if; @@ -15313,9 +15316,10 @@ package body Sem_Elab is if Earlier_In_Extended_Unit (FNode, Region) then Error_Msg_Node_2 := Prim; + Error_Msg_Code := GEC_Type_Early_Call_Region; Error_Msg_NE ("first freezing point of type & must appear within early " - & "call region of primitive body & (SPARK RM 7.7(8))", + & "call region of primitive body '[[]']", Typ_Decl, Typ); Error_Msg_Sloc := Sloc (Region); @@ -19617,7 +19621,7 @@ package body Sem_Elab is Etype (First (Parameter_Associations (Call))); begin Elab_Unit := Scope (Typ); - while (Present (Elab_Unit)) + while Present (Elab_Unit) and then not Is_Compilation_Unit (Elab_Unit) loop Elab_Unit := Scope (Elab_Unit); diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb index 24cd9e1..f744ab3 100644 --- a/gcc/ada/sem_eval.adb +++ b/gcc/ada/sem_eval.adb @@ -434,6 +434,7 @@ package body Sem_Eval is if Is_Static_Expression (Expr) and then not Has_Dynamic_Predicate_Aspect (Typ) + and then not Has_Ghost_Predicate_Aspect (Typ) then if Static_Failure_Is_Error then Error_Msg_NE @@ -1523,7 +1524,7 @@ package body Sem_Eval is Determine_Range (R, ROK, RLo, RHi, Assume_Valid); if LOK and ROK then - Single := (LLo = LHi) and then (RLo = RHi); + Single := LLo = LHi and then RLo = RHi; if LHi < RLo then if Single and Assume_Valid then @@ -3076,7 +3077,7 @@ package body Sem_Eval is else Fold_Uint - (N, Test ((Result = Match) xor (Nkind (N) = N_Not_In)), True); + (N, Test (Result = Match xor Nkind (N) = N_Not_In), True); Warn_On_Known_Condition (N); end if; end if; @@ -5416,8 +5417,9 @@ package body Sem_Eval is return Expr_Value_R (Lo) > Expr_Value_R (Hi); end if; end; + else - return False; + return Compile_Time_Compare (Lo, Hi, Assume_Valid => False) = GT; end if; end Is_Null_Range; @@ -5672,12 +5674,15 @@ package body Sem_Eval is then return False; - -- If there is a dynamic predicate for the type (declared or inherited) - -- the expression is not static. + -- If there is a non-static predicate for the type (declared or + -- inherited) the expression is not static. elsif Has_Dynamic_Predicate_Aspect (Typ) or else (Is_Derived_Type (Typ) and then Has_Aspect (Typ, Aspect_Dynamic_Predicate)) + or else Has_Ghost_Predicate_Aspect (Typ) + or else (Is_Derived_Type (Typ) + and then Has_Aspect (Typ, Aspect_Ghost_Predicate)) or else (Has_Aspect (Typ, Aspect_Predicate) and then not Has_Static_Predicate (Typ)) then @@ -6028,10 +6033,11 @@ package body Sem_Eval is return Expr_Value_R (Lo) <= Expr_Value_R (Hi); end if; end; + else - return False; + return + Compile_Time_Compare (Lo, Hi, Assume_Valid => False) in Compare_LE; end if; - end Not_Null_Range; ------------- @@ -6370,10 +6376,13 @@ package body Sem_Eval is Etype (First_Formal (Entity (Name (Expr)))); begin - -- If the inherited predicate is dynamic, just ignore it. We can't - -- go trying to evaluate a dynamic predicate as a static one! + -- If the inherited predicate is not static, just ignore it. We + -- can't go trying to evaluate a dynamic predicate as a static + -- one! - if Has_Dynamic_Predicate_Aspect (Typ) then + if Has_Dynamic_Predicate_Aspect (Typ) + or else Has_Ghost_Predicate_Aspect (Typ) + then return True; -- Otherwise inherited predicate is static, check for match @@ -6644,7 +6653,7 @@ package body Sem_Eval is -- setting Is_Constrained right for Itypes. if Is_Numeric_Type (T1) - and then (Is_Constrained (T1) /= Is_Constrained (T2)) + and then Is_Constrained (T1) /= Is_Constrained (T2) and then (Scope (T1) = Standard_Standard or else Comes_From_Source (T1)) and then (Scope (T2) = Standard_Standard @@ -6658,7 +6667,7 @@ package body Sem_Eval is elsif Is_Generic_Type (T1) and then Is_Generic_Type (T2) - and then (Is_Constrained (T1) /= Is_Constrained (T2)) + and then Is_Constrained (T1) /= Is_Constrained (T2) then return False; end if; @@ -7611,7 +7620,7 @@ package body Sem_Eval is Error_Msg_NE ("!& is not a static subtype (RM 4.9(26))", N, E); - else + elsif E /= Any_Id then Error_Msg_NE ("!& is not static constant or named number " & "(RM 4.9(5))", N, E); diff --git a/gcc/ada/sem_eval.ads b/gcc/ada/sem_eval.ads index c2e2b45..5cb97ba 100644 --- a/gcc/ada/sem_eval.ads +++ b/gcc/ada/sem_eval.ads @@ -409,9 +409,9 @@ package Sem_Eval is -- an entity with Is_Known_Valid set, or Assume_No_Invalid_Values is True. function Is_Null_Range (Lo : Node_Id; Hi : Node_Id) return Boolean; - -- Returns True if it can guarantee that Lo .. Hi is a null range. If it - -- cannot (because the value of Lo or Hi is not known at compile time) then - -- it returns False. + -- Returns True if it can guarantee that Lo .. Hi is a null range + + -- WARNING: There is a matching C declaration of this subprogram in fe.h function Is_OK_Static_Expression (N : Node_Id) return Boolean; -- An OK static expression is one that is static in the RM definition sense @@ -485,9 +485,7 @@ package Sem_Eval is -- per RM 4.9(38/2). N is a node only used to post warnings. function Not_Null_Range (Lo : Node_Id; Hi : Node_Id) return Boolean; - -- Returns True if it can guarantee that Lo .. Hi is not a null range. If - -- it cannot (because the value of Lo or Hi is not known at compile time) - -- then it returns False. + -- Returns True if it can guarantee that Lo .. Hi is not a null range function Predicates_Compatible (T1, T2 : Entity_Id) return Boolean; -- In Ada 2012, subtypes are statically compatible if the predicates are diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 266a433..c581068 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -208,9 +208,10 @@ package body Sem_Prag is (Prag : Node_Id; Spec_Id : Entity_Id); -- Subsidiary to the analysis of pragmas Contract_Cases, Postcondition, - -- Precondition, Refined_Post, and Test_Case. Emit a warning when pragma - -- Prag is associated with subprogram Spec_Id subject to Inline_Always, - -- and assertions are enabled. + -- Precondition, Refined_Post, Subprogram_Variant, and Test_Case. Emit a + -- warning when pragma Prag is associated with subprogram Spec_Id subject + -- to Inline_Always, assertions are enabled and inling is done in the + -- frontend. procedure Check_State_And_Constituent_Use (States : Elist_Id; @@ -224,10 +225,10 @@ package body Sem_Prag is procedure Contract_Freeze_Error (Contract_Id : Entity_Id; Freeze_Id : Entity_Id); - -- Subsidiary to the analysis of pragmas Contract_Cases, Part_Of, Post, and - -- Pre. Emit a freezing-related error message where Freeze_Id is the entity - -- of a body which caused contract freezing and Contract_Id denotes the - -- entity of the affected contstruct. + -- Subsidiary to the analysis of pragmas Contract_Cases, Exceptional_Cases, + -- Part_Of, Post, Pre and Subprogram_Variant. Emit a freezing-related error + -- message where Freeze_Id is the entity of a body which caused contract + -- freezing and Contract_Id denotes the entity of the affected contstruct. procedure Duplication_Error (Prag : Node_Id; Prev : Node_Id); -- Subsidiary to all Find_Related_xxx routines. Emit an error on pragma @@ -419,6 +420,81 @@ package body Sem_Prag is end if; end Adjust_External_Name_Case; + -------------------------------------------- + -- Analyze_Always_Terminates_In_Decl_Part -- + -------------------------------------------- + + procedure Analyze_Always_Terminates_In_Decl_Part + (N : Node_Id; + Freeze_Id : Entity_Id := Empty) + is + Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N); + Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl); + Arg1 : constant Node_Id := + First (Pragma_Argument_Associations (N)); + + Saved_GM : constant Ghost_Mode_Type := Ghost_Mode; + Saved_IGR : constant Node_Id := Ignored_Ghost_Region; + -- Save the Ghost-related attributes to restore on exit + + Errors : Nat; + Restore_Scope : Boolean := False; + + begin + -- Do not analyze the pragma multiple times + + if Is_Analyzed_Pragma (N) then + return; + end if; + + if Present (Arg1) then + + -- Set the Ghost mode in effect from the pragma. Due to the delayed + -- analysis of the pragma, the Ghost mode at point of declaration and + -- point of analysis may not necessarily be the same. Use the mode in + -- effect at the point of declaration. + + Set_Ghost_Mode (N); + + -- Ensure that the subprogram and its formals are visible when + -- analyzing the expression of the pragma. + + if not In_Open_Scopes (Spec_Id) then + Restore_Scope := True; + + if Is_Generic_Subprogram (Spec_Id) then + Push_Scope (Spec_Id); + Install_Generic_Formals (Spec_Id); + else + Push_Scope (Spec_Id); + Install_Formals (Spec_Id); + end if; + end if; + + Errors := Serious_Errors_Detected; + Preanalyze_Assert_Expression (Expression (Arg1), Standard_Boolean); + + -- Emit a clarification message when the expression contains at least + -- one undefined reference, possibly due to contract freezing. + + if Errors /= Serious_Errors_Detected + and then Present (Freeze_Id) + and then Has_Undefined_Reference (Expression (Arg1)) + then + Contract_Freeze_Error (Spec_Id, Freeze_Id); + end if; + + if Restore_Scope then + End_Scope; + end if; + + Restore_Ghost_Region (Saved_GM, Saved_IGR); + end if; + + Set_Is_Analyzed_Pragma (N); + + end Analyze_Always_Terminates_In_Decl_Part; + ----------------------------------------- -- Analyze_Contract_Cases_In_Decl_Part -- ----------------------------------------- @@ -2104,6 +2180,298 @@ package body Sem_Prag is end Analyze_Depends_In_Decl_Part; -------------------------------------------- + -- Analyze_Exceptional_Cases_In_Decl_Part -- + -------------------------------------------- + + -- WARNING: This routine manages Ghost regions. Return statements must be + -- replaced by gotos which jump to the end of the routine and restore the + -- Ghost mode. + + procedure Analyze_Exceptional_Cases_In_Decl_Part + (N : Node_Id; + Freeze_Id : Entity_Id := Empty) + is + Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N); + Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl); + + procedure Analyze_Exceptional_Contract (Exceptional_Contract : Node_Id); + -- Verify the legality of a single exceptional contract + + procedure Check_Duplication (Id : Node_Id; Contracts : List_Id); + -- Iterate through the identifiers in each contract to find duplicates + + ---------------------------------- + -- Analyze_Exceptional_Contract -- + ---------------------------------- + + procedure Analyze_Exceptional_Contract (Exceptional_Contract : Node_Id) + is + Exception_Choice : Node_Id; + Consequence : Node_Id; + Errors : Nat; + + begin + if Nkind (Exceptional_Contract) /= N_Component_Association then + Error_Msg_N + ("wrong syntax in exceptional contract", Exceptional_Contract); + return; + end if; + + Exception_Choice := First (Choices (Exceptional_Contract)); + Consequence := Expression (Exceptional_Contract); + + while Present (Exception_Choice) loop + if Nkind (Exception_Choice) = N_Others_Choice then + if Present (Next (Exception_Choice)) + or else Present (Next (Exceptional_Contract)) + or else Present (Prev (Exception_Choice)) + then + Error_Msg_N + ("OTHERS must appear alone and last", Exception_Choice); + end if; + + else + Analyze (Exception_Choice); + + if Is_Entity_Name (Exception_Choice) + and then Ekind (Entity (Exception_Choice)) = E_Exception + then + if Present (Renamed_Entity (Entity (Exception_Choice))) + and then Entity (Exception_Choice) = Standard_Numeric_Error + then + Check_Restriction + (No_Obsolescent_Features, Exception_Choice); + + if Warn_On_Obsolescent_Feature then + Error_Msg_N + ("Numeric_Error is an obsolescent feature " & + "(RM J.6(1))?j?", + Exception_Choice); + Error_Msg_N + ("\use Constraint_Error instead?j?", + Exception_Choice); + end if; + end if; + + Check_Duplication + (Exception_Choice, List_Containing (Exceptional_Contract)); + + -- Check for exception declared within generic formal + -- package (which is illegal, see RM 11.2(8)). + + declare + Ent : Entity_Id := Entity (Exception_Choice); + Scop : Entity_Id; + + begin + if Present (Renamed_Entity (Ent)) then + Ent := Renamed_Entity (Ent); + end if; + + Scop := Scope (Ent); + while Scop /= Standard_Standard + and then Ekind (Scop) = E_Package + loop + if Nkind (Declaration_Node (Scop)) = + N_Package_Specification + and then + Nkind (Original_Node (Parent + (Declaration_Node (Scop)))) = + N_Formal_Package_Declaration + then + Error_Msg_NE + ("exception& is declared in generic formal " + & "package", Exception_Choice, Ent); + Error_Msg_N + ("\and therefore cannot appear in contract " + & "(RM 11.2(8))", Exception_Choice); + exit; + + -- If the exception is declared in an inner instance, + -- nothing else to check. + + elsif Is_Generic_Instance (Scop) then + exit; + end if; + + Scop := Scope (Scop); + end loop; + end; + else + Error_Msg_N ("exception name expected", Exception_Choice); + end if; + end if; + + Next (Exception_Choice); + end loop; + + -- Now analyze the expressions of this contract + + Errors := Serious_Errors_Detected; + + -- Preanalyze_Assert_Expression, but without enforcing any of the two + -- acceptable types. + + Preanalyze_Assert_Expression (Consequence, Any_Boolean); + + -- Emit a clarification message when the consequence contains at + -- least one undefined reference, possibly due to contract freezing. + + if Errors /= Serious_Errors_Detected + and then Present (Freeze_Id) + and then Has_Undefined_Reference (Consequence) + then + Contract_Freeze_Error (Spec_Id, Freeze_Id); + end if; + end Analyze_Exceptional_Contract; + + ----------------------- + -- Check_Duplication -- + ----------------------- + + procedure Check_Duplication (Id : Node_Id; Contracts : List_Id) is + Contract : Node_Id; + Id1 : Node_Id; + Id_Entity : Entity_Id := Entity (Id); + + begin + if Present (Renamed_Entity (Id_Entity)) then + Id_Entity := Renamed_Entity (Id_Entity); + end if; + + Contract := First (Contracts); + while Present (Contract) loop + Id1 := First (Choices (Contract)); + while Present (Id1) loop + + -- Only check against the exception choices which precede + -- Id in the contract, since the ones that follow Id have not + -- been analyzed yet and will be checked in a subsequent call. + + if Id = Id1 then + return; + + -- Duplication both simple and via a renaming across different + -- exceptional contracts is illegal. + + elsif Nkind (Id1) /= N_Others_Choice + and then + (Id_Entity = Entity (Id1) + or else Id_Entity = Renamed_Entity (Entity (Id1))) + and then Contract /= Parent (Id) + then + Error_Msg_Sloc := Sloc (Id1); + Error_Msg_NE ("exception choice duplicates &#", Id, Id1); + end if; + + Next (Id1); + end loop; + + Next (Contract); + end loop; + end Check_Duplication; + + -- Local variables + + Exceptional_Contracts : constant Node_Id := + Expression (Get_Argument (N, Spec_Id)); + + Saved_GM : constant Ghost_Mode_Type := Ghost_Mode; + Saved_IGR : constant Node_Id := Ignored_Ghost_Region; + -- Save the Ghost-related attributes to restore on exit + + Exceptional_Contract : Node_Id; + Restore_Scope : Boolean := False; + + -- Start of processing for Analyze_Subprogram_Variant_In_Decl_Part + + begin + -- Do not analyze the pragma multiple times + + if Is_Analyzed_Pragma (N) then + return; + end if; + + -- Set the Ghost mode in effect from the pragma. Due to the delayed + -- analysis of the pragma, the Ghost mode at point of declaration and + -- point of analysis may not necessarily be the same. Use the mode in + -- effect at the point of declaration. + + Set_Ghost_Mode (N); + + -- Single and multiple contracts must appear in aggregate form. If this + -- is not the case, then either the parser of the analysis of the pragma + -- failed to produce an aggregate, e.g. when the contract is "null" or a + -- "(null record)". + + pragma Assert + (if Nkind (Exceptional_Contracts) = N_Aggregate + then Null_Record_Present (Exceptional_Contracts) + xor (Present (Component_Associations (Exceptional_Contracts)) + or + Present (Expressions (Exceptional_Contracts))) + else Nkind (Exceptional_Contracts) = N_Null); + + -- Only clauses of the following form are allowed: + -- + -- exceptional_contract ::= + -- [choice_parameter_specification:] + -- exception_choice {'|' exception_choice} => consequence + -- + -- where + -- + -- consequence ::= Boolean_expression + + if Nkind (Exceptional_Contracts) = N_Aggregate + and then Present (Component_Associations (Exceptional_Contracts)) + and then No (Expressions (Exceptional_Contracts)) + then + + -- Check that the expression is a proper aggregate (no parentheses) + + if Paren_Count (Exceptional_Contracts) /= 0 then + Error_Msg_F -- CODEFIX + ("redundant parentheses", Exceptional_Contracts); + end if; + + -- Ensure that the formal parameters are visible when analyzing all + -- clauses. This falls out of the general rule of aspects pertaining + -- to subprogram declarations. + + if not In_Open_Scopes (Spec_Id) then + Restore_Scope := True; + Push_Scope (Spec_Id); + + if Is_Generic_Subprogram (Spec_Id) then + Install_Generic_Formals (Spec_Id); + else + Install_Formals (Spec_Id); + end if; + end if; + + Exceptional_Contract := + First (Component_Associations (Exceptional_Contracts)); + while Present (Exceptional_Contract) loop + Analyze_Exceptional_Contract (Exceptional_Contract); + Next (Exceptional_Contract); + end loop; + + if Restore_Scope then + End_Scope; + end if; + + -- Otherwise the pragma is illegal + + else + Error_Msg_N ("wrong syntax for exceptional cases", N); + end if; + + Set_Is_Analyzed_Pragma (N); + + Restore_Ghost_Region (Saved_GM, Saved_IGR); + end Analyze_Exceptional_Cases_In_Decl_Part; + + -------------------------------------------- -- Analyze_External_Property_In_Decl_Part -- -------------------------------------------- @@ -4222,11 +4590,11 @@ package body Sem_Prag is procedure Ensure_Aggregate_Form (Arg : Node_Id); -- Subsidiary routine to the processing of pragmas Abstract_State, - -- Contract_Cases, Depends, Global, Initializes, Refined_Depends, - -- Refined_Global, Refined_State and Subprogram_Variant. Transform - -- argument Arg into an aggregate if not one already. N_Null is never - -- transformed. Arg may denote an aspect specification or a pragma - -- argument association. + -- Contract_Cases, Depends, Exceptional_Cases, Global, Initializes, + -- Refined_Depends, Refined_Global, Refined_State and + -- Subprogram_Variant. Transform argument Arg into an aggregate if not + -- one already. N_Null is never transformed. Arg may denote an aspect + -- specification or a pragma argument association. procedure Error_Pragma (Msg : String); pragma No_Return (Error_Pragma); @@ -4942,9 +5310,19 @@ package body Sem_Prag is then null; - -- An access-to-subprogram type can have pre/postconditions, but - -- these are transferred to the generated subprogram wrapper and - -- analyzed there. + -- An access-to-subprogram type can have pre/postconditions, which + -- are both analyzed when attached to the type and copied to the + -- generated subprogram wrapper and analyzed there. + + elsif Nkind (Subp_Decl) = N_Full_Type_Declaration + and then Nkind (Type_Definition (Subp_Decl)) in + N_Access_To_Subprogram_Definition + then + if Ada_Version < Ada_2022 then + Error_Msg_Ada_2022_Feature + ("pre/postcondition on access-to-subprogram", Loc); + raise Pragma_Exit; + end if; -- Otherwise the placement of the pragma is illegal @@ -4962,7 +5340,11 @@ package body Sem_Prag is -- Chain the pragma on the contract for further processing by -- Analyze_Pre_Post_Condition_In_Decl_Part. - Add_Contract_Item (N, Subp_Id); + if Ekind (Subp_Id) in Access_Subprogram_Kind then + Add_Contract_Item (N, Directly_Designated_Type (Subp_Id)); + else + Add_Contract_Item (N, Subp_Id); + end if; -- Fully analyze the pragma when it appears inside an entry or -- subprogram body because it cannot benefit from forward references. @@ -6258,6 +6640,14 @@ package body Sem_Prag is elsif Is_Loop_Pragma (Stmt) then Prag := Stmt; + -- Skip Annotate pragmas, typically used to justify + -- unproved loop pragmas in GNATprove. + + elsif Nkind (Stmt) = N_Pragma + and then Pragma_Name (Stmt) = Name_Annotate + then + null; + -- Skip declarations and statements generated by -- the compiler during expansion. Note that some -- source statements (e.g. pragma Assert) may have @@ -7826,7 +8216,9 @@ package body Sem_Prag is -- then. For example, if the expression is "Record_Type'Size /= 32" -- it might be known after the back end has determined the size of -- Record_Type. We do not defer validation if we're inside a generic - -- unit, because we will have more information in the instances. + -- unit, because we will have more information in the instances, and + -- this ultimately applies to the main unit itself, because it is not + -- compiled by the back end when it is generic. if Compile_Time_Known_Value (Arg1x) then Validate_Compile_Time_Warning_Or_Error (N, Sloc (Arg1)); @@ -7844,7 +8236,10 @@ package body Sem_Prag is end if; end loop; - if No (P) then + if No (P) + and then + Nkind (Unit (Cunit (Main_Unit))) not in N_Generic_Declaration + then Defer_Compile_Time_Warning_Error_To_BE (N); end if; end if; @@ -10959,7 +11354,10 @@ package body Sem_Prag is -- Warn that suppress of Elaboration_Check has no effect in SPARK - if C = Elaboration_Check and then SPARK_Mode = On then + if C = Elaboration_Check + and then Suppress_Case + and then SPARK_Mode = On + then Error_Pragma_Arg ("Suppress of Elaboration_Check ignored in SPARK??", "\elaboration checking rules are statically enforced " @@ -11691,29 +12089,24 @@ package body Sem_Prag is -- Preset arguments - Arg_Count := 0; - Arg1 := Empty; + Arg_Count := List_Length (Pragma_Argument_Associations (N)); + Arg1 := First (Pragma_Argument_Associations (N)); Arg2 := Empty; Arg3 := Empty; Arg4 := Empty; Arg5 := Empty; - if Present (Pragma_Argument_Associations (N)) then - Arg_Count := List_Length (Pragma_Argument_Associations (N)); - Arg1 := First (Pragma_Argument_Associations (N)); - - if Present (Arg1) then - Arg2 := Next (Arg1); + if Present (Arg1) then + Arg2 := Next (Arg1); - if Present (Arg2) then - Arg3 := Next (Arg2); + if Present (Arg2) then + Arg3 := Next (Arg2); - if Present (Arg3) then - Arg4 := Next (Arg3); + if Present (Arg3) then + Arg4 := Next (Arg3); - if Present (Arg4) then - Arg5 := Next (Arg4); - end if; + if Present (Arg4) then + Arg5 := Next (Arg4); end if; end if; end if; @@ -12198,10 +12591,11 @@ package body Sem_Prag is -- Null states never come from source - Set_Comes_From_Source (State_Id, not Is_Null); - Set_Parent (State_Id, State); - Mutate_Ekind (State_Id, E_Abstract_State); - Set_Etype (State_Id, Standard_Void_Type); + Set_Comes_From_Source (State_Id, not Is_Null); + Set_Parent (State_Id, State); + Mutate_Ekind (State_Id, E_Abstract_State); + Set_Is_Not_Self_Hidden (State_Id); + Set_Etype (State_Id, Standard_Void_Type); Set_Encapsulating_State (State_Id, Empty); -- Set the SPARK mode from the current context @@ -12883,6 +13277,165 @@ package body Sem_Prag is Opt.Allow_Integer_Address := True; end if; + ----------------------- + -- Always_Terminates -- + ----------------------- + + -- pragma Always_Terminates [ (boolean_EXPRESSION) ]; + + -- Characteristics: + + -- * Analysis - The annotation undergoes initial checks to verify + -- the legal placement and context. Secondary checks preanalyze the + -- expressions in: + + -- Analyze_Always_Terminates_Cases_In_Decl_Part + + -- * Expansion - The annotation is expanded during the expansion of + -- the related subprogram [body] contract as performed in: + + -- Expand_Subprogram_Contract + + -- * Template - The annotation utilizes the generic template of the + -- related subprogram [body] when it is: + + -- aspect on subprogram declaration + -- aspect on stand-alone subprogram body + -- pragma on stand-alone subprogram body + + -- The annotation must prepare its own template when it is: + + -- pragma on subprogram declaration + + -- * Globals - Capture of global references must occur after full + -- analysis. + + -- * Instance - The annotation is instantiated automatically when + -- the related generic subprogram [body] is instantiated except for + -- the "pragma on subprogram declaration" case. In that scenario + -- the annotation must instantiate itself. + + when Pragma_Always_Terminates => Always_Terminates : declare + Spec_Id : Entity_Id; + Subp_Decl : Node_Id; + Subp_Spec : Node_Id; + + begin + GNAT_Pragma; + Check_No_Identifiers; + Check_At_Most_N_Arguments (1); + + -- Ensure the proper placement of the pragma. Exceptional_Cases + -- must be associated with a subprogram declaration or a body that + -- acts as a spec. + + Subp_Decl := + Find_Related_Declaration_Or_Body (N, Do_Checks => True); + + -- Generic subprogram and package declaration + + if Nkind (Subp_Decl) in N_Generic_Declaration then + null; + + -- Package declaration + + elsif Nkind (Subp_Decl) = N_Package_Declaration then + null; + + -- Body acts as spec + + elsif Nkind (Subp_Decl) = N_Subprogram_Body + and then No (Corresponding_Spec (Subp_Decl)) + then + null; + + -- Body stub acts as spec + + elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub + and then No (Corresponding_Spec_Of_Stub (Subp_Decl)) + then + null; + + -- Subprogram + + elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then + Subp_Spec := Specification (Subp_Decl); + + -- Pragma Always_Terminates is forbidden on null procedures, + -- as this may lead to potential ambiguities in behavior + -- when interface null procedures are involved. Also, it + -- just wouldn't make sense, because null procedures always + -- terminate anyway. + + if Nkind (Subp_Spec) = N_Procedure_Specification + and then Null_Present (Subp_Spec) + then + Error_Msg_N (Fix_Error + ("pragma % cannot apply to null procedure"), N); + return; + end if; + + -- Entry + + elsif Nkind (Subp_Decl) = N_Entry_Declaration then + null; + + else + Pragma_Misplaced; + end if; + + Spec_Id := Unique_Defining_Entity (Subp_Decl); + + -- Pragma Always_Terminates is not allowed on functions + + if Ekind (Spec_Id) = E_Function then + Error_Msg_N (Fix_Error + ("pragma % cannot apply to function"), N); + return; + + elsif Ekind (Spec_Id) = E_Generic_Function then + Error_Msg_N (Fix_Error + ("pragma % cannot apply to generic function"), N); + return; + end if; + + -- Pragma Always_Terminates applied to packages doesn't allow any + -- expression. + + if Is_Package_Or_Generic_Package (Spec_Id) + and then Arg_Count /= 0 + then + Error_Msg_N (Fix_Error + ("pragma % applied to package cannot have arguments"), N); + return; + end if; + + -- A pragma that applies to a Ghost entity becomes Ghost for the + -- purposes of legality checks and removal of ignored Ghost code. + + Mark_Ghost_Pragma (N, Spec_Id); + + -- Chain the pragma on the contract for further processing by + -- Analyze_Always_Terminates_In_Decl_Part. + + Add_Contract_Item (N, Defining_Entity (Subp_Decl)); + + -- Fully analyze the pragma when it appears inside a subprogram + -- body because it cannot benefit from forward references. + + if Nkind (Subp_Decl) in N_Subprogram_Body + | N_Subprogram_Body_Stub + then + -- The legality checks of pragma Always_Terminates are affected + -- by the SPARK mode in effect and the volatility of the + -- context. Analyze all pragmas in a specific order. + + Analyze_If_Present (Pragma_SPARK_Mode); + Analyze_If_Present (Pragma_Volatile_Function); + Analyze_Always_Terminates_In_Decl_Part (N); + end if; + end Always_Terminates; + -------------- -- Annotate -- -------------- @@ -12937,8 +13490,8 @@ package body Sem_Prag is Standard_String); begin for Idx in Type_Table'Range loop - if (L_Type = Type_Table (Idx)) or - (R_Type = Type_Table (Idx)) + if L_Type = Type_Table (Idx) or + R_Type = Type_Table (Idx) then return Type_Table (Idx); end if; @@ -13494,7 +14047,7 @@ package body Sem_Prag is begin GNAT_Pragma; Check_No_Identifiers; - Check_At_Most_N_Arguments (1); + Check_At_Most_N_Arguments (1); Obj_Or_Type_Decl := Find_Related_Context (N, Do_Checks => True); @@ -15490,7 +16043,7 @@ package body Sem_Prag is Default := Fold_Upper (Name_Buffer (1)); if not Support_Nondefault_SSO_On_Target - and then (Ttypes.Bytes_Big_Endian /= (Default = 'H')) + and then Ttypes.Bytes_Big_Endian /= (Default = 'H') then if Warn_On_Unrecognized_Pragma then Error_Msg_N @@ -16275,6 +16828,142 @@ package body Sem_Prag is GNAT_Pragma; Process_Disable_Enable_Atomic_Sync (Name_Unsuppress); + ----------------------- + -- Exceptional_Cases -- + ----------------------- + + -- pragma Exceptional_Cases ( EXCEPTIONAL_CONTRACT_LIST ); + + -- EXCEPTIONAL_CONTRACT_LIST ::= + -- ( EXCEPTIONAL_CONTRACT {, EXCEPTIONAL_CONTRACT }) + + -- EXCEPTIONAL_CONTRACT ::= + -- EXCEPTION_CHOICE {'|' EXCEPTION_CHOICE} => CONSEQUENCE + -- + -- where + -- + -- CONSEQUENCE ::= boolean_EXPRESSION + + -- Characteristics: + + -- * Analysis - The annotation undergoes initial checks to verify + -- the legal placement and context. Secondary checks preanalyze the + -- expressions in: + + -- Analyze_Exceptional_Cases_In_Decl_Part + + -- * Expansion - The annotation is expanded during the expansion of + -- the related subprogram [body] contract as performed in: + + -- Expand_Subprogram_Contract + + -- * Template - The annotation utilizes the generic template of the + -- related subprogram [body] when it is: + + -- aspect on subprogram declaration + -- aspect on stand-alone subprogram body + -- pragma on stand-alone subprogram body + + -- The annotation must prepare its own template when it is: + + -- pragma on subprogram declaration + + -- * Globals - Capture of global references must occur after full + -- analysis. + + -- * Instance - The annotation is instantiated automatically when + -- the related generic subprogram [body] is instantiated except for + -- the "pragma on subprogram declaration" case. In that scenario + -- the annotation must instantiate itself. + + when Pragma_Exceptional_Cases => Exceptional_Cases : declare + Spec_Id : Entity_Id; + Subp_Decl : Node_Id; + Subp_Spec : Node_Id; + + begin + GNAT_Pragma; + Check_No_Identifiers; + Check_Arg_Count (1); + + -- Ensure the proper placement of the pragma. Exceptional_Cases + -- must be associated with a subprogram declaration or a body that + -- acts as a spec. + + Subp_Decl := + Find_Related_Declaration_Or_Body (N, Do_Checks => True); + + -- Generic subprogram + + if Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then + null; + + -- Body acts as spec + + elsif Nkind (Subp_Decl) = N_Subprogram_Body + and then No (Corresponding_Spec (Subp_Decl)) + then + null; + + -- Body stub acts as spec + + elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub + and then No (Corresponding_Spec_Of_Stub (Subp_Decl)) + then + null; + + -- Subprogram + + elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then + Subp_Spec := Specification (Subp_Decl); + + -- Pragma Exceptional_Cases is forbidden on null procedures, + -- as this may lead to potential ambiguities in behavior when + -- interface null procedures are involved. Also, it just + -- wouldn't make sense, because null procedures do not raise + -- exceptions. + + if Nkind (Subp_Spec) = N_Procedure_Specification + and then Null_Present (Subp_Spec) + then + Error_Msg_N (Fix_Error + ("pragma % cannot apply to null procedure"), N); + return; + end if; + + else + Pragma_Misplaced; + end if; + + Spec_Id := Unique_Defining_Entity (Subp_Decl); + + -- A pragma that applies to a Ghost entity becomes Ghost for the + -- purposes of legality checks and removal of ignored Ghost code. + + Mark_Ghost_Pragma (N, Spec_Id); + Ensure_Aggregate_Form (Get_Argument (N, Spec_Id)); + + -- Chain the pragma on the contract for further processing by + -- Analyze_Exceptional_Cases_In_Decl_Part. + + Add_Contract_Item (N, Defining_Entity (Subp_Decl)); + + -- Fully analyze the pragma when it appears inside a subprogram + -- body because it cannot benefit from forward references. + + if Nkind (Subp_Decl) in N_Subprogram_Body + | N_Subprogram_Body_Stub + then + -- The legality checks of pragma Exceptional_Cases are + -- affected by the SPARK mode in effect and the volatility + -- of the context. Analyze all pragmas in a specific order. + + Analyze_If_Present (Pragma_SPARK_Mode); + Analyze_If_Present (Pragma_Volatile_Function); + Analyze_Exceptional_Cases_In_Decl_Part (N); + end if; + end Exceptional_Cases; + ------------ -- Export -- ------------ @@ -20027,7 +20716,11 @@ package body Sem_Prag is N : Node_Id) return Boolean is begin - if Ekind (E) = E_Procedure then + if Ekind (E) in E_Function | E_Generic_Function then + Error_Msg_Ada_2022_Feature ("No_Return function", Sloc (N)); + return Ada_Version >= Ada_2022; + + elsif Ekind (E) = E_Procedure then -- If E is a generic instance, marking it with No_Return -- is forbidden, but having it inherit the No_Return of @@ -20098,9 +20791,7 @@ package body Sem_Prag is -- Ada 2022 (AI12-0269): A function can be No_Return if Ekind (E) in E_Generic_Procedure | E_Procedure - or else (Ada_Version >= Ada_2022 - and then - Ekind (E) in E_Generic_Function | E_Function) + | E_Generic_Function | E_Function then -- Check that the pragma is not applied to a body. -- First check the specless body case, to give a @@ -21510,10 +22201,21 @@ package body Sem_Prag is return; end if; - -- A pragma that applies to a Ghost entity becomes Ghost for the - -- purposes of legality checks and removal of ignored Ghost code. + -- A Ghost_Predicate aspect is always Ghost with a mode inherited + -- from the context. A Predicate pragma that applies to a Ghost + -- entity becomes Ghost for the purposes of legality checks and + -- removal of ignored Ghost code. - Mark_Ghost_Pragma (N, Typ); + if From_Aspect_Specification (N) + and then Get_Aspect_Id + (Chars (Identifier (Corresponding_Aspect (N)))) + = Aspect_Ghost_Predicate + then + Mark_Ghost_Pragma + (N, Name_To_Ghost_Mode (Policy_In_Effect (Name_Ghost))); + else + Mark_Ghost_Pragma (N, Typ); + end if; -- The remaining processing is simply to link the pragma on to -- the rep item chain, for processing when the type is frozen. @@ -26200,11 +26902,15 @@ package body Sem_Prag is if not In_Open_Scopes (Spec_Id) then Restore_Scope := True; - Push_Scope (Spec_Id); if Is_Generic_Subprogram (Spec_Id) then + Push_Scope (Spec_Id); Install_Generic_Formals (Spec_Id); + elsif Is_Access_Subprogram_Type (Spec_Id) then + Push_Scope (Designated_Type (Spec_Id)); + Install_Formals (Designated_Type (Spec_Id)); else + Push_Scope (Spec_Id); Install_Formals (Spec_Id); end if; end if; @@ -26262,20 +26968,6 @@ package body Sem_Prag is Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id); Set_Is_Analyzed_Pragma (N); - -- If the subprogram is frozen then its class-wide pre- and post- - -- conditions have been preanalyzed (see Merge_Class_Conditions); - -- otherwise they must be preanalyzed now to ensure the correct - -- visibility of their referenced entities. This scenario occurs - -- when the subprogram is defined in a nested package (since the - -- end of the package does not cause freezing). - - if Class_Present (N) - and then Is_Dispatching_Operation (Spec_Id) - and then not Is_Frozen (Spec_Id) - then - Preanalyze_Class_Conditions (Spec_Id); - end if; - Restore_Ghost_Region (Saved_GM, Saved_IGR); end Analyze_Pre_Post_Condition_In_Decl_Part; @@ -29622,6 +30314,11 @@ package body Sem_Prag is End_Scope; end if; + -- Currently it is not possible to inline Subprogram_Variant on a + -- subprogram subject to pragma Inline_Always. + + Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id); + -- Otherwise the pragma is illegal else @@ -30070,7 +30767,7 @@ package body Sem_Prag is | Name_Loop_Invariant | Name_Loop_Variant) then - case (Chars (Get_Pragma_Arg (Last (PPA)))) is + case Chars (Get_Pragma_Arg (Last (PPA))) is when Name_Check | Name_On => @@ -30277,9 +30974,10 @@ package body Sem_Prag is -- All other cases require Part_Of else + Error_Msg_Code := GEC_Required_Part_Of; Error_Msg_N - ("indicator Part_Of is required in this context " - & "(SPARK RM 7.2.6(2))", Item_Id); + ("indicator Part_Of is required in this context '[[]']", + Item_Id); Error_Msg_Name_1 := Chars (Pack_Id); Error_Msg_N ("\& is declared in the private part of package %", Item_Id); @@ -30299,6 +30997,7 @@ package body Sem_Prag is if Warn_On_Redundant_Constructs and then Has_Pragma_Inline_Always (Spec_Id) and then Assertions_Enabled + and then not Back_End_Inlining then Error_Msg_Name_1 := Original_Aspect_Pragma_Name (Prag); @@ -31223,7 +31922,9 @@ package body Sem_Prag is -- to save the global references in the generic context. if From_Aspect_Specification (Prag) - and then (Present (Context_Id) and then Is_Generic_Unit (Context_Id)) + and then Present (Context_Id) + and then + Is_Generic_Declaration_Or_Body (Unit_Declaration_Node (Context_Id)) then return Corresponding_Aspect (Prag); @@ -31524,6 +32225,7 @@ package body Sem_Prag is Pragma_Aggregate_Individually_Assign => 0, Pragma_All_Calls_Remote => -1, Pragma_Allow_Integer_Address => -1, + Pragma_Always_Terminates => -1, Pragma_Annotate => 93, Pragma_Assert => -1, Pragma_Assert_And_Cut => -1, @@ -31581,6 +32283,7 @@ package body Sem_Prag is Pragma_Elaboration_Checks => 0, Pragma_Eliminate => 0, Pragma_Enable_Atomic_Synchronization => 0, + Pragma_Exceptional_Cases => -1, Pragma_Export => -1, Pragma_Export_Function => -1, Pragma_Export_Object => -1, @@ -32009,6 +32712,7 @@ package body Sem_Prag is | Name_Debug | Name_Default_Initial_Condition | Name_Ghost + | Name_Ghost_Predicate | Name_Initial_Condition | Name_Invariant | Name_uInvariant @@ -32214,9 +32918,7 @@ package body Sem_Prag is if Nkind (Context) = N_Package_Body then Spec_Id := Corresponding_Spec (Context); - if Present (Abstract_States (Spec_Id)) - and then Contains (Abstract_States (Spec_Id), State_Id) - then + if Contains (Abstract_States (Spec_Id), State_Id) then if No (Body_References (State_Id)) then Set_Body_References (State_Id, New_Elmt_List); end if; diff --git a/gcc/ada/sem_prag.ads b/gcc/ada/sem_prag.ads index fa7e707..e8e9856 100644 --- a/gcc/ada/sem_prag.ads +++ b/gcc/ada/sem_prag.ads @@ -38,6 +38,7 @@ package Sem_Prag is Aspect_Specifying_Pragma : constant array (Pragma_Id) of Boolean := (Pragma_Abstract_State => True, Pragma_All_Calls_Remote => True, + Pragma_Always_Terminates => True, Pragma_Annotate => True, Pragma_Async_Readers => True, Pragma_Async_Writers => True, @@ -59,6 +60,7 @@ package Sem_Prag is Pragma_Effective_Reads => True, Pragma_Effective_Writes => True, Pragma_Elaborate_Body => True, + Pragma_Exceptional_Cases => True, Pragma_Export => True, Pragma_Extensions_Visible => True, Pragma_Favor_Top_Level => True, @@ -109,6 +111,7 @@ package Sem_Prag is Pragma_Simple_Storage_Pool_Type => True, Pragma_SPARK_Mode => True, Pragma_Storage_Size => True, + Pragma_Subprogram_Variant => True, Pragma_Suppress => True, Pragma_Suppress_Debug_Info => True, Pragma_Suppress_Initialization => True, @@ -131,13 +134,15 @@ package Sem_Prag is -- expression. Assertion_Expression_Pragma : constant array (Pragma_Id) of Boolean := - (Pragma_Assert => True, + (Pragma_Always_Terminates => True, + Pragma_Assert => True, Pragma_Assert_And_Cut => True, Pragma_Assume => True, Pragma_Check => True, Pragma_Compile_Time_Error => True, Pragma_Contract_Cases => True, Pragma_Default_Initial_Condition => True, + Pragma_Exceptional_Cases => True, Pragma_Initial_Condition => True, Pragma_Invariant => True, Pragma_Loop_Invariant => True, @@ -207,27 +212,30 @@ package Sem_Prag is -- 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); + (Pragma_Always_Terminates => True, + Pragma_Contract_Cases => True, + Pragma_Depends => True, + Pragma_Exceptional_Cases => 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_Subprogram_Variant => True, + Pragma_Volatile => True, + Pragma_Volatile_Function => True, + others => False); ----------------- -- Subprograms -- @@ -236,6 +244,13 @@ package Sem_Prag is procedure Analyze_Pragma (N : Node_Id); -- Analyze procedure for pragma reference node N + procedure Analyze_Always_Terminates_In_Decl_Part + (N : Node_Id; + Freeze_Id : Entity_Id := Empty); + -- Perform full analysis of delayed pragma Always_Terminates. Freeze_Id is + -- the entity of [generic] package body or [generic] subprogram body which + -- caused "freezing" of the related contract where the pragma resides. + procedure Analyze_Contract_Cases_In_Decl_Part (N : Node_Id; Freeze_Id : Entity_Id := Empty); @@ -247,6 +262,13 @@ package Sem_Prag is -- Perform full analysis of delayed pragma Depends. This routine is also -- capable of performing basic analysis of pragma Refined_Depends. + procedure Analyze_Exceptional_Cases_In_Decl_Part + (N : Node_Id; + Freeze_Id : Entity_Id := Empty); + -- Perform full analysis of delayed pragma Exceptional_Cases. Freeze_Id is + -- the entity of [generic] package body or [generic] subprogram body which + -- caused "freezing" of the related contract where the pragma resides. + procedure Analyze_External_Property_In_Decl_Part (N : Node_Id; Expr_Val : out Boolean); @@ -433,8 +455,10 @@ package Sem_Prag is (Prag : Node_Id; Do_Checks : Boolean := False) return Node_Id; -- Subsidiary to the analysis of pragmas + -- Always_Terminates -- Contract_Cases -- Depends + -- Exceptional_Cases -- Extensions_Visible -- Global -- Initializes @@ -451,6 +475,7 @@ package Sem_Prag is -- Refined_Global -- Refined_Post -- Refined_State + -- Subprogram_Variant -- Test_Case -- Volatile_Function -- as well as attributes 'Old and 'Result. Find the declaration of the diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index df9ccb1..2c8efec 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -111,10 +111,9 @@ package body Sem_Res is function Has_Applicable_User_Defined_Literal (N : Node_Id; Typ : Entity_Id) return Boolean; - -- If N is a literal or a named number, check whether Typ - -- has a user-defined literal aspect that can apply to N. - -- If present, replace N with a call to the corresponding - -- function and return True. + -- Check whether N is a literal or a named number, and whether Typ has a + -- user-defined literal aspect that may apply to N. In this case, replace + -- N with a call to the corresponding function and return True. procedure Check_Discriminant_Use (N : Node_Id); -- Enforce the restrictions on the use of discriminants when constraining @@ -306,11 +305,20 @@ package body Sem_Res is function Try_User_Defined_Literal (N : Node_Id; Typ : Entity_Id) return Boolean; - -- If an operator node has a literal operand, check whether the type - -- of the context, or the type of the other operand has a user-defined - -- literal aspect that can be applied to the literal to resolve the node. - -- If such aspect exists, replace literal with a call to the - -- corresponding function and return True, return false otherwise. + -- If the node is a literal or a named number or a conditional expression + -- whose dependent expressions are all literals or named numbers, and the + -- context type has a user-defined literal aspect, then rewrite the node + -- or its leaf nodes as calls to the corresponding function, which plays + -- the role of an implicit conversion. + + function Try_User_Defined_Literal_For_Operator + (N : Node_Id; + Typ : Entity_Id) return Boolean; + -- If an operator node has a literal operand, check whether the type of the + -- context, or that of the other operand has a user-defined literal aspect + -- that can be applied to the literal to resolve the node. If such aspect + -- exists, replace literal with a call to the corresponding function and + -- return True, return false otherwise. function Unique_Fixed_Point_Type (N : Node_Id) return Entity_Id; -- A universal_fixed expression in an universal context is unambiguous if @@ -492,7 +500,6 @@ package body Sem_Res is Name := Make_Identifier (Loc, Chars (Callee)); if Is_Derived_Type (Typ) - and then Is_Tagged_Type (Typ) and then Base_Type (Etype (Callee)) /= Base_Type (Typ) then Callee := @@ -601,6 +608,7 @@ package body Sem_Res is Analyze_And_Resolve (N, Typ); return True; + else return False; end if; @@ -948,7 +956,7 @@ package body Sem_Res is -------------------------------------- function Invoked_With_Different_Arguments (N : Node_Id) return Boolean is - Subp : constant Entity_Id := Entity (Name (N)); + Subp : constant Entity_Id := Get_Called_Entity (N); Actual : Node_Id; Formal : Entity_Id; @@ -957,7 +965,7 @@ package body Sem_Res is -- Determine whether the formals of the invoked subprogram are not -- used as actuals in the call. - Actual := First_Actual (Call); + Actual := First_Actual (N); Formal := First_Formal (Subp); while Present (Actual) and then Present (Formal) loop @@ -2484,10 +2492,17 @@ package body Sem_Res is Expr_Type := Etype (Parent (N)); -- If not overloaded, then we know the type, and all that needs doing - -- is to check that this type is compatible with the context. + -- is to check that this type is compatible with the context. But note + -- that we may have an operator with no interpretation in Ada 2022 for + -- the case of possible user-defined literals as operands. elsif not Is_Overloaded (N) then - Found := Covers (Typ, Etype (N)); + if Nkind (N) in N_Op and then No (Entity (N)) then + pragma Assert (Ada_Version >= Ada_2022); + Found := False; + else + Found := Covers (Typ, Etype (N)); + end if; Expr_Type := Etype (N); -- In the overloaded case, we must select the interpretation that @@ -2938,7 +2953,7 @@ package body Sem_Res is -- view-swapping mechanism has no identifier. elsif (In_Instance or else In_Inlined_Body) - and then (Nkind (N) = N_Null) + and then Nkind (N) = N_Null and then Is_Private_Type (Typ) and then Is_Access_Type (Full_View (Typ)) then @@ -3055,15 +3070,11 @@ package body Sem_Res is end; end if; - -- If node is a literal and context type has a user-defined - -- literal aspect, rewrite node as a call to the corresponding - -- function, which plays the role of an implicit conversion. + -- Check whether the node is a literal or a named number or a + -- conditional expression whose dependent expressions are all + -- literals or named numbers. - if Nkind (N) in - N_Numeric_Or_String_Literal | N_Identifier - and then Has_Applicable_User_Defined_Literal (N, Typ) - then - Analyze_And_Resolve (N, Typ); + if Try_User_Defined_Literal (N, Typ) then return; end if; @@ -3170,13 +3181,15 @@ package body Sem_Res is (First (Component_Associations (N)))); end if; - -- For an operator with no interpretation, check whether - -- one of its operands may be a user-defined literal. + -- For an operator with no interpretation, check whether one of + -- its operands may be a user-defined literal. - elsif Nkind (N) in N_Op - and then Try_User_Defined_Literal (N, Typ) - then - return; + elsif Nkind (N) in N_Op and then No (Entity (N)) then + if Try_User_Defined_Literal_For_Operator (N, Typ) then + return; + else + Unresolved_Operator (N); + end if; else Wrong_Type (N, Typ); @@ -3901,9 +3914,10 @@ package body Sem_Res is Obj_Ref => N, Check_Actuals => True) then + Error_Msg_Code := GEC_Volatile_Non_Interfering_Context; Error_Msg_N - ("volatile object cannot appear in this context" - & " (SPARK RM 7.1.3(10))", N); + ("volatile object cannot appear in this context '[[]']", + N); end if; return Skip; @@ -6038,11 +6052,11 @@ package body Sem_Res is -- Start of processing for Resolve_Arithmetic_Op begin - if Comes_From_Source (N) - and then Ekind (Entity (N)) = E_Function + if Ekind (Entity (N)) = E_Function and then Is_Imported (Entity (N)) and then Is_Intrinsic_Subprogram (Entity (N)) then + Generate_Reference (Entity (N), N); Resolve_Intrinsic_Operator (N, Typ); return; @@ -6306,11 +6320,11 @@ package body Sem_Res is begin Determine_Range (Left_Opnd (N), OK, Lo, Hi, Assume_Valid => True); - LNeg := (not OK) or else Lo < 0; + LNeg := not OK or else Lo < 0; Determine_Range (Right_Opnd (N), OK, Lo, Hi, Assume_Valid => True); - RNeg := (not OK) or else Lo < 0; + RNeg := not OK or else Lo < 0; -- Check if we will be generating conditionals. There are two -- cases where that can happen, first for REM, the only case @@ -6910,65 +6924,62 @@ package body Sem_Res is return; end if; - -- Create a transient scope if the resulting type requires it + -- Create a transient scope if the expander is active and the resulting + -- type requires it. -- There are several notable exceptions: - -- a) In init procs, the transient scope overhead is not needed, and is - -- even incorrect when the call is a nested initialization call for a - -- component whose expansion may generate adjust calls. However, if the - -- call is some other procedure call within an initialization procedure - -- (for example a call to Create_Task in the init_proc of the task - -- run-time record) a transient scope must be created around this call. - - -- b) Enumeration literal pseudo-calls need no transient scope - - -- c) Intrinsic subprograms (Unchecked_Conversion and source info + -- a) Intrinsic subprograms (Unchecked_Conversion and source info -- functions) do not use the secondary stack even though the return -- type may be unconstrained. - -- d) Calls to a build-in-place function, since such functions may + -- b) Subprograms that are ignored ghost entities do not return anything + + -- c) Calls to a build-in-place function, since such functions may -- allocate their result directly in a target object, and cases where -- the result does get allocated in the secondary stack are checked for -- within the specialized Exp_Ch6 procedures for expanding those -- build-in-place calls. - -- e) Calls to inlinable expression functions do not use the secondary + -- d) Calls to inlinable expression functions do not use the secondary -- stack (since the call will be replaced by its returned object). - -- f) If the subprogram is marked Inline_Always, then even if it returns + -- e) If the subprogram is marked Inline, then even if it returns -- an unconstrained type the call does not require use of the secondary -- stack. However, inlining will only take place if the body to inline -- is already present. It may not be available if e.g. the subprogram is -- declared in a child instance. - -- g) If the subprogram is a static expression function and the call is + -- f) If the subprogram is a static expression function and the call is -- a static call (the actuals are all static expressions), then we never -- want to create a transient scope (this could occur in the case of a -- static string-returning call). - if Is_Inlined (Nam) - and then Has_Pragma_Inline (Nam) - and then Nkind (Unit_Declaration_Node (Nam)) = N_Subprogram_Declaration - and then Present (Body_To_Inline (Unit_Declaration_Node (Nam))) - then - null; + -- g) If the call is the expression of a simple return statement that + -- returns on the same stack, since it will be handled as a tail call + -- by Expand_Simple_Function_Return. - elsif Ekind (Nam) = E_Enumeration_Literal - or else Is_Build_In_Place_Function (Nam) - or else Is_Intrinsic_Subprogram (Nam) - or else Is_Inlinable_Expression_Function (Nam) - or else Is_Static_Function_Call (N) - then - null; - - -- A return statement from an ignored Ghost function does not use the - -- secondary stack (or any other one). - - elsif Expander_Active + if Expander_Active and then Ekind (Nam) in E_Function | E_Subprogram_Type and then Requires_Transient_Scope (Etype (Nam)) + and then not Is_Intrinsic_Subprogram (Nam) and then not Is_Ignored_Ghost_Entity (Nam) + and then not Is_Build_In_Place_Function (Nam) + and then not Is_Inlinable_Expression_Function (Nam) + and then not (Is_Inlined (Nam) + and then Has_Pragma_Inline (Nam) + and then Nkind (Unit_Declaration_Node (Nam)) = + N_Subprogram_Declaration + and then + Present (Body_To_Inline (Unit_Declaration_Node (Nam)))) + and then not Is_Static_Function_Call (N) + and then not (Nkind (Parent (N)) = N_Simple_Return_Statement + and then + Needs_Secondary_Stack + (Etype + (Return_Applies_To + (Return_Statement_Entity (Parent (N))))) = + Needs_Secondary_Stack (Etype (Nam))) then Establish_Transient_Scope (N, Needs_Secondary_Stack (Etype (Nam))); @@ -7280,10 +7291,19 @@ package body Sem_Res is Cannot_Inline ("cannot inline & (in default expression)?", N, Nam_UA); - -- Calls cannot be inlined inside quantified expressions, which - -- are left in expression form for GNATprove. Since these - -- expressions are only preanalyzed, we need to detect the failure - -- to inline outside of the case for Full_Analysis below. + -- Calls cannot be inlined inside potentially unevaluated + -- expressions, as this would create complex actions inside + -- expressions, that are not handled by GNATprove. + + elsif Is_Potentially_Unevaluated (N) then + Cannot_Inline + ("cannot inline & (in potentially unevaluated context)?", + N, Nam_UA); + + -- Calls are not inlined inside the loop_parameter_specification + -- or iterator_specification of the quantified expression, as they + -- are only preanalyzed. Calls in the predicate part are handled + -- by the previous test on potentially unevaluated expressions. elsif In_Quantified_Expression (N) then Cannot_Inline @@ -7355,15 +7375,6 @@ package body Sem_Res is elsif No (Body_To_Inline (Nam_Decl)) then null; - -- Calls cannot be inlined inside potentially unevaluated - -- expressions, as this would create complex actions inside - -- expressions, that are not handled by GNATprove. - - elsif Is_Potentially_Unevaluated (N) then - Cannot_Inline - ("cannot inline & (in potentially unevaluated context)?", - N, Nam_UA); - -- Calls cannot be inlined inside the conditions of while -- loops, as this would create complex actions inside -- the condition, that are not handled by GNATprove. @@ -7833,6 +7844,14 @@ package body Sem_Res is -- Determine whether Expr is part of an N_Attribute_Reference -- expression. + function In_Attribute_Old (Expr : Node_Id) return Boolean; + -- Determine whether Expr is in attribute Old + + function Within_Exceptional_Cases_Consequence + (Expr : Node_Id) + return Boolean; + -- Determine whether Expr is part of an Exceptional_Cases consequence + ---------------------------------------- -- Is_Assignment_Or_Object_Expression -- ---------------------------------------- @@ -7874,6 +7893,31 @@ package body Sem_Res is end if; end Is_Assignment_Or_Object_Expression; + ---------------------- + -- In_Attribute_Old -- + ---------------------- + + function In_Attribute_Old (Expr : Node_Id) return Boolean is + N : Node_Id := Expr; + begin + while Present (N) loop + if Nkind (N) = N_Attribute_Reference + and then Attribute_Name (N) = Name_Old + then + return True; + + -- Prevent the search from going too far + + elsif Is_Body_Or_Package_Declaration (N) then + return False; + end if; + + N := Parent (N); + end loop; + + return False; + end In_Attribute_Old; + ----------------------------- -- Is_Attribute_Expression -- ----------------------------- @@ -7897,6 +7941,39 @@ package body Sem_Res is return False; end Is_Attribute_Expression; + ------------------------------------------ + -- Within_Exceptional_Cases_Consequence -- + ------------------------------------------ + + function Within_Exceptional_Cases_Consequence + (Expr : Node_Id) + return Boolean + is + Context : Node_Id := Parent (Expr); + begin + while Present (Context) loop + if Nkind (Context) = N_Pragma then + + -- In Exceptional_Cases references to formal parameters are + -- only allowed within consequences, so it is enough to + -- recognize the pragma itself. + + if Get_Pragma_Id (Context) = Pragma_Exceptional_Cases then + return True; + end if; + + -- Prevent the search from going too far + + elsif Is_Body_Or_Package_Declaration (Context) then + return False; + end if; + + Context := Parent (Context); + end loop; + + return False; + end Within_Exceptional_Cases_Consequence; + -- Local variables E : constant Entity_Id := Entity (N); @@ -8023,7 +8100,7 @@ package body Sem_Res is if Comes_From_Source (N) then - -- The following checks are only relevant when SPARK_Mode is on as + -- The following checks are only relevant when SPARK_Mode is On as -- they are not standard Ada legality rules. if SPARK_Mode = On then @@ -8036,9 +8113,43 @@ package body Sem_Res is and then not Is_OK_Volatile_Context (Par, N, Check_Actuals => False) then + Error_Msg_Code := GEC_Volatile_Non_Interfering_Context; SPARK_Msg_N - ("volatile object cannot appear in this context " - & "(SPARK RM 7.1.3(10))", N); + ("volatile object cannot appear in this context '[[]']", N); + end if; + + -- Parameters of modes OUT or IN OUT of the subprogram shall not + -- occur in the consequences of an exceptional contract unless + -- they are either passed by reference or occur in the prefix + -- of a reference to the 'Old attribute. For convenience, we also + -- allow them as prefixes of attributes that do not actually read + -- data from the object. + + if Ekind (E) in E_Out_Parameter | E_In_Out_Parameter + and then Scope (E) = Current_Scope_No_Loops + and then Within_Exceptional_Cases_Consequence (N) + and then not In_Attribute_Old (N) + and then not (Nkind (Parent (N)) = N_Attribute_Reference + and then + Attribute_Name (Parent (N)) in Name_Constrained + | Name_First + | Name_Last + | Name_Length + | Name_Range) + and then not Is_By_Reference_Type (Etype (E)) + and then not Is_Aliased (E) + then + if Ekind (E) = E_Out_Parameter then + Error_Msg_N + ("formal parameter of mode `OUT` cannot appear " & + "in consequence of Exceptional_Cases", N); + else + Error_Msg_N + ("formal parameter of mode `IN OUT` cannot appear " & + "in consequence of Exceptional_Cases", N); + end if; + Error_Msg_N + ("\only parameters passed by reference are allowed", N); end if; -- Check for possible elaboration issues with respect to reads of @@ -8068,13 +8179,11 @@ package body Sem_Res is if Is_Ghost_Entity (E) then Check_Ghost_Context (E, N); end if; - end if; - -- We may be resolving an entity within expanded code, so a reference to - -- an entity should be ignored when calculating effective use clauses to - -- avoid inappropriate marking. + -- We may be resolving an entity within expanded code, so a reference + -- to an entity should be ignored when calculating effective use + -- clauses to avoid inappropriate marking. - if Comes_From_Source (N) then Mark_Use_Clauses (E); end if; end Resolve_Entity_Name; @@ -9503,17 +9612,6 @@ package body Sem_Res is Desig_Typ : Entity_Id; begin - -- In an instance the proper view may not always be correct for - -- private types, see e.g. Sem_Type.Covers for similar handling. - - if Is_Private_Type (Etype (P)) - and then Present (Full_View (Etype (P))) - and then Is_Access_Type (Full_View (Etype (P))) - and then In_Instance - then - Set_Etype (P, Full_View (Etype (P))); - end if; - if Is_Access_Type (Etype (P)) then Desig_Typ := Implicitly_Designated_Type (Etype (P)); Insert_Explicit_Dereference (P); @@ -9713,10 +9811,19 @@ package body Sem_Res is -------------------------------- procedure Resolve_Intrinsic_Operator (N : Node_Id; Typ : Entity_Id) is - Btyp : constant Entity_Id := Base_Type (Underlying_Type (Typ)); - Op : Entity_Id; - Arg1 : Node_Id; - Arg2 : Node_Id; + Is_Stoele_Mod : constant Boolean := + Nkind (N) = N_Op_Mod + and then Is_RTE (First_Subtype (Typ), RE_Storage_Offset) + and then Is_RTE (Etype (Left_Opnd (N)), RE_Address); + -- True if this is the special mod operator of System.Storage_Elements, + -- which needs to be resolved to the type of the left operand in order + -- to implement the correct semantics. + + Btyp : constant Entity_Id := + (if Is_Stoele_Mod + then Implementation_Base_Type (Etype (Left_Opnd (N))) + else Implementation_Base_Type (Typ)); + -- The base type to be used for the operator function Convert_Operand (Opnd : Node_Id) return Node_Id; -- If the operand is a literal, it cannot be the expression in a @@ -9745,6 +9852,12 @@ package body Sem_Res is return Res; end Convert_Operand; + -- Local variables + + Arg1 : Node_Id; + Arg2 : Node_Id; + Op : Entity_Id; + -- Start of processing for Resolve_Intrinsic_Operator begin @@ -9766,11 +9879,13 @@ package body Sem_Res is -- If the result or operand types are private, rewrite with unchecked -- conversions on the operands and the result, to expose the proper - -- underlying numeric type. + -- underlying numeric type. Likewise for the special mod operator of + -- System.Storage_Elements, to expose the modified base type. if Is_Private_Type (Typ) or else Is_Private_Type (Etype (Left_Opnd (N))) or else Is_Private_Type (Etype (Right_Opnd (N))) + or else Is_Stoele_Mod then Arg1 := Convert_Operand (Left_Opnd (N)); @@ -10644,11 +10759,11 @@ package body Sem_Res is end if; end if; - if Comes_From_Source (N) - and then Ekind (Entity (N)) = E_Function + if Ekind (Entity (N)) = E_Function and then Is_Imported (Entity (N)) and then Is_Intrinsic_Subprogram (Entity (N)) then + Generate_Reference (Entity (N), N); Resolve_Intrinsic_Operator (N, Typ); return; end if; @@ -10917,14 +11032,14 @@ package body Sem_Res is if not Parentheses_Found and then Comes_From_Source (Par) and then - ((Nkind (Par) in N_Modular_Type_Definition - | N_Floating_Point_Definition - | N_Ordinary_Fixed_Point_Definition - | N_Decimal_Fixed_Point_Definition - | N_Extension_Aggregate - | N_Discriminant_Specification - | N_Parameter_Specification - | N_Formal_Object_Declaration) + (Nkind (Par) in N_Modular_Type_Definition + | N_Floating_Point_Definition + | N_Ordinary_Fixed_Point_Definition + | N_Decimal_Fixed_Point_Definition + | N_Extension_Aggregate + | N_Discriminant_Specification + | N_Parameter_Specification + | N_Formal_Object_Declaration or else (Nkind (Par) = N_Object_Declaration and then @@ -13202,36 +13317,111 @@ package body Sem_Res is Typ : Entity_Id) return Boolean is begin - if Nkind (N) in N_Op_Add | N_Op_Divide | N_Op_Mod | N_Op_Multiply - | N_Op_Rem | N_Op_Subtract - then + if Has_Applicable_User_Defined_Literal (N, Typ) then + return True; + + elsif Nkind (N) = N_If_Expression then + -- Both dependent expressions must have the same type as the context + + declare + Condition : constant Node_Id := First (Expressions (N)); + Then_Expr : constant Node_Id := Next (Condition); + Else_Expr : constant Node_Id := Next (Then_Expr); + + begin + if Has_Applicable_User_Defined_Literal (Then_Expr, Typ) then + Resolve (Else_Expr, Typ); + Analyze_And_Resolve (N, Typ); + return True; + + elsif Has_Applicable_User_Defined_Literal (Else_Expr, Typ) then + Resolve (Then_Expr, Typ); + Analyze_And_Resolve (N, Typ); + return True; + end if; + end; + + elsif Nkind (N) = N_Case_Expression then + -- All dependent expressions must have the same type as the context + + declare + Alt : Node_Id; + + begin + Alt := First (Alternatives (N)); - -- Both operands must have the same type as the context. + while Present (Alt) loop + if Has_Applicable_User_Defined_Literal (Expression (Alt), Typ) + then + declare + Other_Alt : Node_Id; + + begin + Other_Alt := First (Alternatives (N)); + + while Present (Other_Alt) loop + if Other_Alt /= Alt then + Resolve (Expression (Other_Alt), Typ); + end if; + + Next (Other_Alt); + end loop; + + Analyze_And_Resolve (N, Typ); + return True; + end; + end if; + + Next (Alt); + end loop; + end; + end if; + + return False; + end Try_User_Defined_Literal; + + ------------------------------------------- + -- Try_User_Defined_Literal_For_Operator -- + ------------------------------------------- + + function Try_User_Defined_Literal_For_Operator + (N : Node_Id; + Typ : Entity_Id) return Boolean + is + begin + if Nkind (N) in N_Op_Add + | N_Op_Divide + | N_Op_Mod + | N_Op_Multiply + | N_Op_Rem + | N_Op_Subtract + then + -- Both operands must have the same type as the context -- (ignoring for now fixed-point and exponentiation ops). - if Has_Applicable_User_Defined_Literal (Right_Opnd (N), Typ) then + if Has_Applicable_User_Defined_Literal (Right_Opnd (N), Typ) + or else (Nkind (Left_Opnd (N)) in N_Op + and then Covers (Typ, Etype (Right_Opnd (N)))) + then Resolve (Left_Opnd (N), Typ); Analyze_And_Resolve (N, Typ); return True; - end if; - if - Has_Applicable_User_Defined_Literal (Left_Opnd (N), Typ) + elsif Has_Applicable_User_Defined_Literal (Left_Opnd (N), Typ) + or else (Nkind (Right_Opnd (N)) in N_Op + and then Covers (Typ, Etype (Left_Opnd (N)))) then Resolve (Right_Opnd (N), Typ); Analyze_And_Resolve (N, Typ); return True; - - else - return False; end if; elsif Nkind (N) in N_Binary_Op then - -- For other operators the context does not impose a type on + -- For other binary operators the context does not impose a type on -- the operands, but their types must match. - if (Nkind (Left_Opnd (N)) - not in N_Integer_Literal | N_String_Literal | N_Real_Literal) + if Nkind (Left_Opnd (N)) + not in N_Integer_Literal | N_String_Literal | N_Real_Literal and then Has_Applicable_User_Defined_Literal (Right_Opnd (N), Etype (Left_Opnd (N))) @@ -13239,29 +13429,25 @@ package body Sem_Res is Analyze_And_Resolve (N, Typ); return True; - elsif (Nkind (Right_Opnd (N)) - not in N_Integer_Literal | N_String_Literal | N_Real_Literal) + elsif Nkind (Right_Opnd (N)) + not in N_Integer_Literal | N_String_Literal | N_Real_Literal and then Has_Applicable_User_Defined_Literal (Left_Opnd (N), Etype (Right_Opnd (N))) then Analyze_And_Resolve (N, Typ); return True; - else - return False; end if; elsif Nkind (N) in N_Unary_Op - and then - Has_Applicable_User_Defined_Literal (Right_Opnd (N), Typ) + and then Has_Applicable_User_Defined_Literal (Right_Opnd (N), Typ) then Analyze_And_Resolve (N, Typ); return True; - - else -- Other operators - return False; end if; - end Try_User_Defined_Literal; + + return False; + end Try_User_Defined_Literal_For_Operator; ----------------------------- -- Unique_Fixed_Point_Type -- @@ -13544,8 +13730,8 @@ package body Sem_Res is -- return False if Expr not of form <prefix>.all.Some_Component - if (Nkind (Expr) /= N_Selected_Component) - or else (Nkind (Prefix (Expr)) /= N_Explicit_Dereference) + if Nkind (Expr) /= N_Selected_Component + or else Nkind (Prefix (Expr)) /= N_Explicit_Dereference then -- conditional expressions, declare expressions ??? return False; @@ -13629,8 +13815,8 @@ package body Sem_Res is if not (Is_Integer_Type (Target_Index_Type) and then Is_Integer_Type (Opnd_Index_Type)) - and then (Root_Type (Target_Index_Type) - /= Root_Type (Opnd_Index_Type)) + and then Root_Type (Target_Index_Type) + /= Root_Type (Opnd_Index_Type) then Conversion_Error_N ("incompatible index types for array conversion", diff --git a/gcc/ada/sem_scil.adb b/gcc/ada/sem_scil.adb index 7c75c9d..da8fab6 100644 --- a/gcc/ada/sem_scil.adb +++ b/gcc/ada/sem_scil.adb @@ -88,8 +88,9 @@ package body Sem_SCIL is -- object or parameter declaration. Interface types are still -- unsupported. - elsif Nkind (Ctrl_Tag) in - N_Object_Declaration | N_Parameter_Specification + elsif Nkind (Ctrl_Tag) in N_Object_Renaming_Declaration + | N_Object_Declaration + | N_Parameter_Specification then Ctrl_Typ := Etype (Defining_Identifier (Ctrl_Tag)); diff --git a/gcc/ada/sem_type.adb b/gcc/ada/sem_type.adb index 0c0df68f..00a6415 100644 --- a/gcc/ada/sem_type.adb +++ b/gcc/ada/sem_type.adb @@ -884,6 +884,16 @@ package body Sem_Type is end; end if; + -- This test may seem to be redundant with the above one, but it catches + -- peculiar cases where a private type declared in a package is used in + -- a generic construct declared in another package, and the body of the + -- former package contains an instantiation of the generic construct on + -- an object whose type is a subtype of the private type; in this case, + -- the subtype is not private but the type is private in the instance. + + elsif Is_Subtype_Of (T1 => T2, T2 => T1) then + return True; + -- Literals are compatible with types in a given "class" elsif (T2 = Universal_Integer and then Is_Integer_Type (T1)) @@ -1033,8 +1043,8 @@ package body Sem_Type is and then Ekind (BT1) = E_General_Access_Type and then Ekind (BT2) = E_Anonymous_Access_Type and then Covers (Designated_Type (T1), Designated_Type (T2)) - and then (Is_Class_Wide_Type (Designated_Type (T1)) >= - Is_Class_Wide_Type (Designated_Type (T2))) + and then Is_Class_Wide_Type (Designated_Type (T1)) >= + Is_Class_Wide_Type (Designated_Type (T2)) then return True; @@ -1161,20 +1171,20 @@ package body Sem_Type is then return True; - -- In instances, or with types exported from instantiations, check - -- whether a partial and a full view match. Verify that types are - -- legal, to prevent cascaded errors. + -- With types exported from instantiations, check whether a partial and + -- a full view match. Verify that types are legal, to prevent cascaded + -- errors. elsif Is_Private_Type (T1) - and then (In_Instance - or else (Is_Type (T2) and then Is_Generic_Actual_Type (T2))) + and then Is_Type (T2) + and then Is_Generic_Actual_Type (T2) and then Full_View_Covers (T1, T2) then return True; elsif Is_Private_Type (T2) - and then (In_Instance - or else (Is_Type (T1) and then Is_Generic_Actual_Type (T1))) + and then Is_Type (T1) + and then Is_Generic_Actual_Type (T1) and then Full_View_Covers (T2, T1) then return True; @@ -2229,7 +2239,7 @@ package body Sem_Type is Is_Immediately_Visible (Base_Type (Etype (Right_Opnd (N)))) and then Is_Potentially_Use_Visible (User_Subp) then - if It2.Nam = Predef_Subp then + if It1.Nam = Predef_Subp then return It1; else return It2; @@ -3210,7 +3220,7 @@ package body Sem_Type is elsif Op_Name = Name_Op_Concat then return Is_Array_Type (T) - and then (Base_Type (T) = Base_Type (Etype (Op))) + and then Base_Type (T) = Base_Type (Etype (Op)) and then (Base_Type (T1) = Base_Type (T) or else Base_Type (T1) = Base_Type (Component_Type (T))) @@ -3457,9 +3467,10 @@ package body Sem_Type is then return T2; - -- In instances, also check private views the same way as Covers + -- With types exported from instantiation, also check private views the + -- same way as Covers - elsif Is_Private_Type (T1) and then In_Instance then + elsif Is_Private_Type (T1) and then Is_Generic_Actual_Type (T2) then if Present (Full_View (T1)) then return Specific_Type (Full_View (T1), T2); @@ -3467,7 +3478,7 @@ package body Sem_Type is return Specific_Type (Underlying_Full_View (T1), T2); end if; - elsif Is_Private_Type (T2) and then In_Instance then + elsif Is_Private_Type (T2) and then Is_Generic_Actual_Type (T1) then if Present (Full_View (T2)) then return Specific_Type (T1, Full_View (T2)); diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index f285635..d9ea00e 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -132,9 +132,6 @@ package body Sem_Util is -- Determine whether arbitrary entity Id denotes an atomic object as per -- RM C.6(7). - function Is_Container_Aggregate (Exp : Node_Id) return Boolean; - -- Is the given expression a container aggregate? - generic with function Is_Effectively_Volatile_Entity (Id : Entity_Id) return Boolean; @@ -312,11 +309,12 @@ package body Sem_Util is -------------------------- procedure Add_Block_Identifier - (N : Node_Id; - Id : out Entity_Id; - Scope : Entity_Id := Current_Scope) + (N : Node_Id; + Id : out Entity_Id; + Scope : Entity_Id := Current_Scope) is Loc : constant Source_Ptr := Sloc (N); + begin pragma Assert (Nkind (N) = N_Block_Statement); @@ -331,7 +329,6 @@ package body Sem_Util is Id := New_Internal_Entity (E_Block, Scope, Loc, 'B'); Set_Etype (Id, Standard_Void_Type); Set_Parent (Id, N); - Set_Identifier (N, New_Occurrence_Of (Id, Loc)); Set_Block_Node (Id, Identifier (N)); end if; @@ -477,7 +474,7 @@ package body Sem_Util is -- this breaks the name resolution mechanism for generic instances. if not Expander_Active - and (Inside_A_Generic or not Full_Analysis or not GNATprove_Mode) + and not (GNATprove_Mode and not Inside_A_Generic) then return; end if; @@ -961,10 +958,11 @@ package body Sem_Util is if Is_Generic_Actual_Type (Typ) then -- The restriction on loop parameters is only that the type - -- should have no dynamic predicates. + -- should only have static predicates. if Nkind (Parent (N)) = N_Loop_Parameter_Specification and then not Has_Dynamic_Predicate_Aspect (Typ) + and then not Has_Ghost_Predicate_Aspect (Typ) and then Is_OK_Static_Subtype (Typ) then return; @@ -998,6 +996,7 @@ package body Sem_Util is -- if the predicate is static. if not Has_Dynamic_Predicate_Aspect (Typ) + and then not Has_Ghost_Predicate_Aspect (Typ) and then Has_Static_Predicate (Typ) and then Nkind (N) = N_Attribute_Reference then @@ -2234,9 +2233,12 @@ package body Sem_Util is and then Entity (Formal_Type) = Par_Typ then Rewrite (Formal_Type, New_Occurrence_Of (Typ, Loc)); - end if; - -- Nothing needs to be done for access parameters + elsif Nkind (Formal_Type) = N_Access_Definition + and then Entity (Subtype_Mark (Formal_Type)) = Par_Typ + then + Rewrite (Subtype_Mark (Formal_Type), New_Occurrence_Of (Typ, Loc)); + end if; Next (Formal_Spec); end loop; @@ -2618,7 +2620,8 @@ package body Sem_Util is function Check_Node (N : Node_Id) return Traverse_Result is Is_Writable_Actual : Boolean := False; - Id : Entity_Id; + Id : Entity_Id := Empty; + -- Default init of Id for CodePeer begin if Nkind (N) = N_Identifier then @@ -2881,9 +2884,7 @@ package body Sem_Util is Collect_Identifiers (Right_Opnd (N)); end if; - if Nkind (N) in N_In | N_Not_In - and then Present (Alternatives (N)) - then + if Nkind (N) in N_Membership_Test then Expr := First (Alternatives (N)); while Present (Expr) loop Collect_Identifiers (Expr); @@ -2898,6 +2899,10 @@ package body Sem_Util is function Get_Record_Part (N : Node_Id) return Node_Id; -- Return the record part of this record type definition + --------------------- + -- Get_Record_Part -- + --------------------- + function Get_Record_Part (N : Node_Id) return Node_Id is Type_Def : constant Node_Id := Type_Definition (N); begin @@ -3292,9 +3297,7 @@ package body Sem_Util is & "in unspecified order", Node (Elmt_2)); - when N_In - | N_Not_In - => + when N_Membership_Test => Error_Msg_N ("value may be affected by call in other " & "alternative because they are evaluated " @@ -3306,7 +3309,7 @@ package body Sem_Util is ("value of actual may be affected by call in " & "other actual because they are evaluated " & "in unspecified order", - Node (Elmt_2)); + Node (Elmt_2)); end case; end if; @@ -3497,6 +3500,11 @@ package body Sem_Util is ("internal call cannot appear in default for formal of " & "protected operation", N); return; + + -- Prevent the search from going too far + + elsif Is_Body_Or_Package_Declaration (P) then + exit; end if; P := Parent (P); @@ -4537,13 +4545,12 @@ package body Sem_Util is -- Local variables Items : constant Node_Id := Contract (Subp_Id); - Subp_Decl : constant Node_Id := Unit_Declaration_Node (Subp_Id); Case_Prag : Node_Id := Empty; Post_Prag : Node_Id := Empty; Prag : Node_Id; Seen_In_Case : Boolean := False; Seen_In_Post : Boolean := False; - Spec_Id : Entity_Id; + Spec_Id : constant Entity_Id := Unique_Entity (Subp_Id); -- Start of processing for Check_Result_And_Post_State @@ -4559,22 +4566,38 @@ package body Sem_Util is elsif No (Items) then return; - end if; - -- Retrieve the entity of the subprogram spec (if any) + -- If the subprogram has a contract Exceptional_Cases, it is often + -- useful to refer only to the pre-state in the postcondition, to + -- indicate when the subprogram might terminate normally. - if Nkind (Subp_Decl) = N_Subprogram_Body - and then Present (Corresponding_Spec (Subp_Decl)) - then - Spec_Id := Corresponding_Spec (Subp_Decl); + elsif Present (Get_Pragma (Subp_Id, Pragma_Exceptional_Cases)) then + return; - elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub - and then Present (Corresponding_Spec_Of_Stub (Subp_Decl)) - then - Spec_Id := Corresponding_Spec_Of_Stub (Subp_Decl); + -- Same if the subprogram has a contract Always_Terminates => Cond, + -- where Cond is not syntactically True. else - Spec_Id := Subp_Id; + declare + Prag : constant Node_Id := + Get_Pragma (Subp_Id, Pragma_Always_Terminates); + begin + if Present (Prag) + and then Present (Pragma_Argument_Associations (Prag)) + then + declare + Cond : constant Node_Id := + Get_Pragma_Arg + (First (Pragma_Argument_Associations (Prag))); + begin + if not Compile_Time_Known_Value (Cond) + or else not Is_True (Expr_Value (Cond)) + then + return; + end if; + end; + end if; + end; end if; -- Examine all postconditions for attribute 'Result and a post-state @@ -4635,7 +4658,8 @@ package body Sem_Util is -- attribute 'Result. elsif Present (Case_Prag) and then not Seen_In_Case then - Error_Msg_N ("contract cases do not mention result?.t?", Case_Prag); + Error_Msg_N + ("contract cases do not mention function result?.t?", Case_Prag); -- The function has non-trivial postconditions only and they do not -- mention attribute 'Result. @@ -6101,7 +6125,7 @@ package body Sem_Util is Conc_Typ : constant Entity_Id := (if Present (Init_Proc_Type) - and then Init_Proc_Type in E_Record_Type_Id + and then Ekind (Init_Proc_Type) = E_Record_Type then Corresponding_Concurrent_Type (Init_Proc_Type) else Empty); @@ -6235,6 +6259,19 @@ package body Sem_Util is -- Examine parent type if Etype (Typ) /= Typ then + -- Prevent infinite recursion, which can happen in illegal + -- programs. Silently return if illegal. For now, just deal + -- with the 2-type cycle case. Larger cycles will get + -- SIGSEGV at compile time from running out of stack. + + if Etype (Etype (Typ)) = Typ then + if Total_Errors_Detected = 0 then + raise Program_Error; + else + return; + end if; + end if; + Process_Type (Etype (Typ)); end if; @@ -6483,9 +6520,8 @@ package body Sem_Util is (Ancestor_Op : Entity_Id; Descendant_Type : Entity_Id) return Entity_Id is - Typ : constant Entity_Id := Find_Dispatching_Type (Ancestor_Op); - Elmt : Elmt_Id; - Subp : Entity_Id; + function Find_Untagged_Type_Of (Prim : Entity_Id) return Entity_Id; + -- Search for the untagged type of the primitive operation Prim. function Profile_Matches_Ancestor (S : Entity_Id) return Boolean; -- Returns True if subprogram S has the proper profile for an @@ -6493,6 +6529,33 @@ package body Sem_Util is -- have the same type, or are corresponding controlling formals, -- and similarly for result types). + --------------------------- + -- Find_Untagged_Type_Of -- + --------------------------- + + function Find_Untagged_Type_Of (Prim : Entity_Id) return Entity_Id is + E : Entity_Id := First_Entity (Scope (Prim)); + + begin + while Present (E) and then E /= Prim loop + if not Is_Tagged_Type (E) + and then Contains (Direct_Primitive_Operations (E), Prim) + then + return E; + end if; + + Next_Entity (E); + end loop; + + pragma Assert (False); + return Empty; + end Find_Untagged_Type_Of; + + Typ : constant Entity_Id := + (if Is_Dispatching_Operation (Ancestor_Op) + then Find_Dispatching_Type (Ancestor_Op) + else Find_Untagged_Type_Of (Ancestor_Op)); + ------------------------------ -- Profile_Matches_Ancestor -- ------------------------------ @@ -6529,10 +6592,14 @@ package body Sem_Util is or else Is_Ancestor (Typ, Etype (S))); end Profile_Matches_Ancestor; + -- Local variables + + Elmt : Elmt_Id; + Subp : Entity_Id; + -- Start of processing for Corresponding_Primitive_Op begin - pragma Assert (Is_Dispatching_Operation (Ancestor_Op)); pragma Assert (Is_Ancestor (Typ, Descendant_Type) or else Is_Progenitor (Typ, Descendant_Type)); @@ -7294,7 +7361,7 @@ package body Sem_Util is | N_Defining_Program_Unit_Name then return - (Chars (Select_Node (Name1)) = Chars (Select_Node (Name2))) + Chars (Select_Node (Name1)) = Chars (Select_Node (Name2)) and then Designate_Same_Unit (Prefix_Node (Name1), Prefix_Node (Name2)); @@ -8167,12 +8234,8 @@ package body Sem_Util is elsif Present (Etype (Def_Id)) then null; - -- Otherwise, the kind E_Void insures that premature uses of the entity - -- will be detected. Any_Type insures that no cascaded errors will occur - else - Mutate_Ekind (Def_Id, E_Void); - Set_Etype (Def_Id, Any_Type); + Set_Etype (Def_Id, Any_Type); -- avoid cascaded errors end if; -- All entities except Itypes are immediately visible @@ -8560,6 +8623,7 @@ package body Sem_Util is Context : constant Node_Id := Parent (N); Actual : Node_Id; Call_Nam : Node_Id; + Call_Ent : Node_Id := Empty; begin if Nkind (Context) in N_Indexed_Component | N_Selected_Component @@ -8608,13 +8672,42 @@ package body Sem_Util is Call_Nam := Selector_Name (Call_Nam); end if; - if Is_Entity_Name (Call_Nam) - and then Present (Entity (Call_Nam)) - and then (Is_Generic_Subprogram (Entity (Call_Nam)) - or else Is_Overloadable (Entity (Call_Nam)) - or else Ekind (Entity (Call_Nam)) in E_Entry_Family - | E_Subprogram_Body - | E_Subprogram_Type) + -- If Call_Nam is an entity name, get its entity + + if Is_Entity_Name (Call_Nam) then + Call_Ent := Entity (Call_Nam); + + -- If it is a dereference, get the designated subprogram type + + elsif Nkind (Call_Nam) = N_Explicit_Dereference then + declare + Typ : Entity_Id := Etype (Prefix (Call_Nam)); + begin + if Present (Full_View (Typ)) then + Typ := Full_View (Typ); + elsif Is_Private_Type (Typ) + and then Present (Underlying_Full_View (Typ)) + then + Typ := Underlying_Full_View (Typ); + end if; + + if Is_Access_Type (Typ) then + Call_Ent := Directly_Designated_Type (Typ); + else + pragma Assert (Has_Implicit_Dereference (Typ)); + Formal := Empty; + Call := Empty; + return; + end if; + end; + end if; + + if Present (Call_Ent) + and then (Is_Generic_Subprogram (Call_Ent) + or else Is_Overloadable (Call_Ent) + or else Ekind (Call_Ent) in E_Entry_Family + | E_Subprogram_Body + | E_Subprogram_Type) and then not Is_Overloaded (Call_Nam) then -- If node is name in call it is not an actual @@ -8628,7 +8721,7 @@ package body Sem_Util is -- Fall here if we are definitely a parameter Actual := First_Actual (Call); - Formal := First_Formal (Entity (Call_Nam)); + Formal := First_Formal (Call_Ent); while Present (Formal) and then Present (Actual) loop if Actual = N then return; @@ -9669,14 +9762,9 @@ package body Sem_Util is if No (Comp_List) or else Null_Present (Comp_List) then return; - - elsif Present (Component_Items (Comp_List)) then - Comp_Item := First (Component_Items (Comp_List)); - - else - Comp_Item := Empty; end if; + Comp_Item := First (Component_Items (Comp_List)); while Present (Comp_Item) loop -- Skip the tag of a tagged record, as well as all items that are not @@ -9714,6 +9802,8 @@ package body Sem_Util is Assoc := First (Governed_By); Find_Constraint : loop Discrim := First (Choices (Assoc)); + pragma Assert (No (Next (Discrim))); + exit Find_Constraint when Chars (Discrim_Name) = Chars (Discrim) or else @@ -9788,16 +9878,16 @@ package body Sem_Util is end if; end if; - if No (Next (Assoc)) then + Next (Assoc); + + if No (Assoc) then Error_Msg_NE - (" missing value for discriminant&", + ("missing value for discriminant&", First (Governed_By), Discrim_Name); Report_Errors := True; return; end if; - - Next (Assoc); end loop Find_Constraint; Discrim_Value := Expression (Assoc); @@ -9830,7 +9920,7 @@ package body Sem_Util is -- with Static_Predicate => Null_By_Predicate < 0; -- so test for that null case separately. - if (not Has_Static_Predicate (Discrim_Value_Subtype)) + if not Has_Static_Predicate (Discrim_Value_Subtype) or else Present (First (Static_Discrete_Predicate (Discrim_Value_Subtype))) then @@ -10017,6 +10107,14 @@ package body Sem_Util is then return Actual_Subtype (Entity (N)); + -- Similarly, if we have an explicit dereference, then we get the + -- actual subtype from the node itself if one has been built. + + elsif Nkind (N) = N_Explicit_Dereference + and then Present (Actual_Designated_Subtype (N)) + then + return Actual_Designated_Subtype (N); + -- Actual subtype of unchecked union is always itself. We never need -- the "real" actual subtype. If we did, we couldn't get it anyway -- because the discriminant is not available. The restrictions on @@ -10031,7 +10129,7 @@ package body Sem_Util is -- Checking the type, not the underlying type, for constrainedness -- seems to be necessary. Maybe all the tests should be on the type??? - elsif (not Is_Constrained (Typ)) + elsif not Is_Constrained (Typ) and then (Is_Array_Type (Utyp) or else (Is_Record_Type (Utyp) and then Has_Discriminants (Utyp))) @@ -10130,6 +10228,14 @@ package body Sem_Util is then return Actual_Subtype (Entity (N)); + -- Similarly, if we have an explicit dereference, then we get the + -- actual subtype from the node itself if one has been built. + + elsif Nkind (N) = N_Explicit_Dereference + and then Present (Actual_Designated_Subtype (N)) + then + return Actual_Designated_Subtype (N); + -- Otherwise the Etype of N is returned unchanged else @@ -14574,7 +14680,10 @@ package body Sem_Util is -- Inherit_Predicate_Flags -- ----------------------------- - procedure Inherit_Predicate_Flags (Subt, Par : Entity_Id) is + procedure Inherit_Predicate_Flags + (Subt, Par : Entity_Id; + Only_Flags : Boolean := False) + is begin if Ada_Version < Ada_2012 or else Present (Predicate_Function (Subt)) @@ -14587,6 +14696,8 @@ package body Sem_Util is (Subt, Has_Static_Predicate_Aspect (Par)); Set_Has_Dynamic_Predicate_Aspect (Subt, Has_Dynamic_Predicate_Aspect (Par)); + Set_Has_Ghost_Predicate_Aspect + (Subt, Has_Ghost_Predicate_Aspect (Par)); -- A named subtype does not inherit the predicate function of its -- parent but an itype declared for a loop index needs the discrete @@ -14594,7 +14705,10 @@ package body Sem_Util is -- A non-discrete type may has a static predicate (for example True) -- but has no static_discrete_predicate. - if Is_Itype (Subt) and then Present (Predicate_Function (Par)) then + if not Only_Flags + and then Is_Itype (Subt) + and then Present (Predicate_Function (Par)) + then Set_Subprograms_For_Type (Subt, Subprograms_For_Type (Par)); if Has_Static_Predicate (Par) and then Is_Discrete_Type (Par) then @@ -15175,18 +15289,6 @@ package body Sem_Util is end case; end Is_Actual_Parameter; - -------------------------------- - -- Is_Actual_Tagged_Parameter -- - -------------------------------- - - function Is_Actual_Tagged_Parameter (N : Node_Id) return Boolean is - Formal : Entity_Id; - Call : Node_Id; - begin - Find_Actual (N, Formal, Call); - return Present (Formal) and then Is_Tagged_Type (Etype (Formal)); - end Is_Actual_Tagged_Parameter; - --------------------- -- Is_Aliased_View -- --------------------- @@ -15686,8 +15788,8 @@ package body Sem_Util is Item_1 : constant Node_Id := Aspect_Rep_Item (Aspect_Spec_1); Item_2 : constant Node_Id := Aspect_Rep_Item (Aspect_Spec_2); begin - if (Nkind (Item_1) /= N_Attribute_Definition_Clause) - or (Nkind (Item_2) /= N_Attribute_Definition_Clause) + if Nkind (Item_1) /= N_Attribute_Definition_Clause + or Nkind (Item_2) /= N_Attribute_Definition_Clause then pragma Assert (Serious_Errors_Detected > 0); return True; @@ -16083,9 +16185,25 @@ package body Sem_Util is ----------------------------- function Is_CPP_Constructor_Call (N : Node_Id) return Boolean is + Ret_Typ : Entity_Id; + begin - return Nkind (N) = N_Function_Call - and then Is_CPP_Class (Etype (Etype (N))) + if Nkind (N) /= N_Function_Call then + return False; + end if; + + Ret_Typ := Base_Type (Etype (N)); + + if Is_Class_Wide_Type (Ret_Typ) then + Ret_Typ := Root_Type (Ret_Typ); + end if; + + if Is_Private_Type (Ret_Typ) then + Ret_Typ := Underlying_Type (Ret_Typ); + end if; + + return Present (Ret_Typ) + and then Is_CPP_Class (Ret_Typ) and then Is_Constructor (Entity (Name (N))) and then Is_Imported (Entity (Name (N))); end Is_CPP_Constructor_Call; @@ -17512,21 +17630,6 @@ package body Sem_Util is and then Is_Derived_Type (Etype (E))); end Is_Inherited_Operation; - ------------------------------------- - -- Is_Inherited_Operation_For_Type -- - ------------------------------------- - - function Is_Inherited_Operation_For_Type - (E : Entity_Id; - Typ : Entity_Id) return Boolean - is - begin - -- Check that the operation has been created by the type declaration - - return Is_Inherited_Operation (E) - and then Defining_Identifier (Parent (E)) = Typ; - end Is_Inherited_Operation_For_Type; - -------------------------------------- -- Is_Inlinable_Expression_Function -- -------------------------------------- @@ -17562,6 +17665,16 @@ package body Sem_Util is return False; end Is_Inlinable_Expression_Function; + ----------------------- + -- Is_Internal_Block -- + ----------------------- + + function Is_Internal_Block (N : Node_Id) return Boolean is + begin + return Nkind (N) = N_Block_Statement + and then Is_Internal (Entity (Identifier (N))); + end Is_Internal_Block; + ----------------- -- Is_Iterator -- ----------------- @@ -18029,8 +18142,8 @@ package body Sem_Util is Next (First (Expressions (Original_Exp))); Else_Expr : constant Node_Id := Next (Then_Expr); begin - if (Is_NC (Then_Expr) = Bad_Result) - or else (Is_NC (Else_Expr) = Bad_Result) + if Is_NC (Then_Expr) = Bad_Result + or else Is_NC (Else_Expr) = Bad_Result then return Bad_Result; else @@ -18609,19 +18722,17 @@ package body Sem_Util is return True; end if; - Item := First (Component_Items (Component_List (Record_Def))); + Item := First_Non_Pragma (Component_Items (Component_List (Record_Def))); while Present (Item) loop if Nkind (Item) = N_Component_Declaration and then Is_Internal_Name (Chars (Defining_Identifier (Item))) then null; - elsif Nkind (Item) = N_Pragma then - null; else return False; end if; - Item := Next (Item); + Next_Non_Pragma (Item); end loop; return True; @@ -19503,7 +19614,8 @@ package body Sem_Util is elsif Nkind (Par) = N_Quantified_Expression then return Expr = Condition (Par); - elsif Nkind (Par) = N_Component_Association + elsif Nkind (Par) in N_Component_Association + | N_Iterated_Component_Association and then Expr = Expression (Par) and then Nkind (Parent (Par)) in N_Aggregate | N_Delta_Aggregate | N_Extension_Aggregate @@ -19645,10 +19757,15 @@ package body Sem_Util is then return True; - -- For component associations continue climbing; it may be part of - -- an array aggregate. + -- For component associations continue climbing; it may be part of an + -- array aggregate. For iterated component association we know that + -- it belongs to an array aggreate, but only its expression is + -- potentially unevaluated, not discrete choice list or iterator + -- specification. - elsif Nkind (Par) = N_Component_Association then + elsif Nkind (Par) in N_Component_Association + | N_Iterated_Component_Association + then null; -- If the context is not an expression, or if is the result of @@ -20495,8 +20612,10 @@ package body Sem_Util is Nam := Pragma_Name (Item); end if; - return Nam = Name_Contract_Cases + return Nam = Name_Always_Terminates + or else Nam = Name_Contract_Cases or else Nam = Name_Depends + or else Nam = Name_Exceptional_Cases or else Nam = Name_Extensions_Visible or else Nam = Name_Global or else Nam = Name_Post @@ -21092,11 +21211,8 @@ package body Sem_Util is return Is_Variable_Prefix (Prefix (Orig_Node)); when N_Selected_Component => - return (Is_Variable (Selector_Name (Orig_Node)) - and then Is_Variable_Prefix (Prefix (Orig_Node))) - or else - (Nkind (N) = N_Expanded_Name - and then Scope (Entity (N)) = Entity (Prefix (N))); + return Is_Variable (Selector_Name (Orig_Node)) + and then Is_Variable_Prefix (Prefix (Orig_Node)); -- For an explicit dereference, the type of the prefix cannot -- be an access to constant or an access to subprogram. @@ -22798,113 +22914,6 @@ package body Sem_Util is end if; end New_Copy_List_Tree; - ---------------------------- - -- New_Copy_Separate_List -- - ---------------------------- - - function New_Copy_Separate_List (List : List_Id) return List_Id is - begin - if List = No_List then - return No_List; - - else - declare - List_Copy : constant List_Id := New_List; - N : Node_Id := First (List); - - begin - while Present (N) loop - Append (New_Copy_Separate_Tree (N), List_Copy); - Next (N); - end loop; - - return List_Copy; - end; - end if; - end New_Copy_Separate_List; - - ---------------------------- - -- New_Copy_Separate_Tree -- - ---------------------------- - - function New_Copy_Separate_Tree (Source : Node_Id) return Node_Id is - function Search_Decl (N : Node_Id) return Traverse_Result; - -- Subtree visitor which collects declarations - - procedure Search_Declarations is new Traverse_Proc (Search_Decl); - -- Subtree visitor instantiation - - ----------------- - -- Search_Decl -- - ----------------- - - Decls : Elist_Id; - - function Search_Decl (N : Node_Id) return Traverse_Result is - begin - if Nkind (N) in N_Declaration then - Append_New_Elmt (N, Decls); - end if; - - return OK; - end Search_Decl; - - -- Local variables - - Source_Copy : constant Node_Id := New_Copy_Tree (Source); - - -- Start of processing for New_Copy_Separate_Tree - - begin - Decls := No_Elist; - Search_Declarations (Source_Copy); - - -- Associate a new Entity with all the subtree declarations (keeping - -- their original name). - - if Present (Decls) then - declare - Elmt : Elmt_Id; - Decl : Node_Id; - New_E : Entity_Id; - - begin - Elmt := First_Elmt (Decls); - while Present (Elmt) loop - Decl := Node (Elmt); - New_E := Make_Temporary (Sloc (Decl), 'P'); - - if Nkind (Decl) = N_Expression_Function then - Decl := Specification (Decl); - end if; - - if Nkind (Decl) in N_Function_Instantiation - | N_Function_Specification - | N_Generic_Function_Renaming_Declaration - | N_Generic_Package_Renaming_Declaration - | N_Generic_Procedure_Renaming_Declaration - | N_Package_Body - | N_Package_Instantiation - | N_Package_Renaming_Declaration - | N_Package_Specification - | N_Procedure_Instantiation - | N_Procedure_Specification - then - Set_Chars (New_E, Chars (Defining_Unit_Name (Decl))); - Set_Defining_Unit_Name (Decl, New_E); - else - Set_Chars (New_E, Chars (Defining_Identifier (Decl))); - Set_Defining_Identifier (Decl, New_E); - end if; - - Next_Elmt (Elmt); - end loop; - end; - end if; - - return Source_Copy; - end New_Copy_Separate_Tree; - ------------------- -- New_Copy_Tree -- ------------------- @@ -22982,11 +22991,10 @@ package body Sem_Util is ------------------- function New_Copy_Tree - (Source : Node_Id; - Map : Elist_Id := No_Elist; - New_Sloc : Source_Ptr := No_Location; - New_Scope : Entity_Id := Empty; - Scopes_In_EWA_OK : Boolean := False) return Node_Id + (Source : Node_Id; + Map : Elist_Id := No_Elist; + New_Sloc : Source_Ptr := No_Location; + New_Scope : Entity_Id := Empty) return Node_Id is -- This routine performs low-level tree manipulations and needs access -- to the internals of the tree. @@ -23076,6 +23084,13 @@ 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_Controlling_Argument + (Old_Call : Node_Id; + New_Call : Node_Id); + pragma Inline (Update_Controlling_Argument); + -- Update Controlling_Argument of New_Call base on Old_Call to make it + -- points to the corresponding newly copied actual parameter. + procedure Update_Named_Associations (Old_Call : Node_Id; New_Call : Node_Id); @@ -23323,65 +23338,6 @@ package body Sem_Util is New_Par : Node_Id := Empty; Semantic : Boolean := False) return Union_Id is - function Has_More_Ids (N : Node_Id) return Boolean; - -- Return True when N has attribute More_Ids set to True - - function Is_Syntactic_Node return Boolean; - -- Return True when Field is a syntactic node - - ------------------ - -- Has_More_Ids -- - ------------------ - - function Has_More_Ids (N : Node_Id) return Boolean is - begin - if Nkind (N) in N_Component_Declaration - | N_Discriminant_Specification - | N_Exception_Declaration - | N_Formal_Object_Declaration - | N_Number_Declaration - | N_Object_Declaration - | N_Parameter_Specification - | N_Use_Package_Clause - | N_Use_Type_Clause - then - return More_Ids (N); - else - return False; - end if; - end Has_More_Ids; - - ----------------------- - -- Is_Syntactic_Node -- - ----------------------- - - function Is_Syntactic_Node return Boolean is - Old_N : constant Node_Id := Node_Id (Field); - - begin - if Parent (Old_N) = Old_Par then - return True; - - elsif not Has_More_Ids (Old_Par) then - return False; - - -- Perform the check using the last last id in the syntactic chain - - else - declare - N : Node_Id := Old_Par; - - begin - while Present (N) and then More_Ids (N) loop - Next (N); - end loop; - - pragma Assert (Prev_Ids (N)); - return Parent (Old_N) = N; - end; - end if; - end Is_Syntactic_Node; - begin -- The field is empty @@ -23393,7 +23349,8 @@ package body Sem_Util is elsif Field in Node_Range then declare Old_N : constant Node_Id := Node_Id (Field); - Syntactic : constant Boolean := Is_Syntactic_Node; + Syntactic : constant Boolean := + Is_Syntactic_Node (Source => Old_Par, Field => Old_N); New_N : Node_Id; @@ -23572,17 +23529,22 @@ package body Sem_Util is (Old_Assoc => N, New_Assoc => Result); - -- Update the First/Next_Named_Association chain for a replicated - -- call. + -- Update the First/Next_Named_Association chain and the + -- Controlling_Argument for a replicated call. if Nkind (N) in N_Entry_Call_Statement - | N_Function_Call - | N_Procedure_Call_Statement + | N_Subprogram_Call then Update_Named_Associations (Old_Call => N, New_Call => Result); + if Nkind (N) in N_Subprogram_Call then + Update_Controlling_Argument + (Old_Call => N, + New_Call => Result); + end if; + -- Update the Renamed_Object attribute of a replicated object -- declaration. @@ -23692,6 +23654,59 @@ package body Sem_Util is end if; end Update_CFS_Sloc; + --------------------------------- + -- Update_Controlling_Argument -- + --------------------------------- + + procedure Update_Controlling_Argument + (Old_Call : Node_Id; + New_Call : Node_Id) + is + New_Act : Node_Id; + Old_Act : Node_Id; + + Old_Ctrl_Arg : constant Node_Id := Controlling_Argument (Old_Call); + -- Controlling argument of the old call node + + Replaced : Boolean := False; + -- Flag to make sure that replacement works as expected + + begin + if No (Old_Ctrl_Arg) then + return; + end if; + + -- Recreate the Controlling_Argument of a call by traversing both the + -- old and new actual parameters in parallel. + + New_Act := First (Parameter_Associations (New_Call)); + Old_Act := First (Parameter_Associations (Old_Call)); + while Present (Old_Act) loop + + -- Actual parameter appears either in a named parameter + -- association or directly. + + if Nkind (Old_Act) = N_Parameter_Association then + if Explicit_Actual_Parameter (Old_Act) = Old_Ctrl_Arg then + Set_Controlling_Argument + (New_Call, Explicit_Actual_Parameter (New_Act)); + Replaced := True; + exit; + end if; + + elsif Old_Act = Old_Ctrl_Arg then + Set_Controlling_Argument (New_Call, New_Act); + Replaced := True; + exit; + end if; + + Next (New_Act); + Next (Old_Act); + end loop; + + pragma Assert (Replaced); + end Update_Controlling_Argument; + ------------------------------- -- Update_Named_Associations -- ------------------------------- @@ -23766,9 +23781,7 @@ package body Sem_Util is -- ??? Is there a better way of distinguishing those? while Present (Old_Id) and then Present (New_Id) loop - if not (Present (Entity_Map) - and then In_Entity_Map (Old_Id, Entity_Map)) - then + if not In_Entity_Map (Old_Id, Entity_Map) then Update_Semantic_Fields (New_Id); end if; @@ -23940,12 +23953,9 @@ package body Sem_Util is return; -- Nothing to do when the entity is defined in a scoping construct - -- within an N_Expression_With_Actions node, unless the caller has - -- requested their replication. + -- within an N_Expression_With_Actions node. - -- ??? should this restriction be eliminated? - - elsif EWA_Inner_Scope_Level > 0 and then not Scopes_In_EWA_OK then + elsif EWA_Inner_Scope_Level > 0 then return; -- Nothing to do when the entity does not denote a construct that @@ -24225,14 +24235,12 @@ package body Sem_Util is -- Note that the element of a syntactic list is always a node, never -- an entity or itype, hence the call to Visit_Node. - if Present (List) then - Elmt := First (List); - while Present (Elmt) loop - Visit_Node (Elmt); + Elmt := First (List); + while Present (Elmt) loop + Visit_Node (Elmt); - Next (Elmt); - end loop; - end if; + Next (Elmt); + end loop; end Visit_List; ---------------- @@ -24264,8 +24272,7 @@ package body Sem_Util is -- If the node is a block, we need to process all declarations -- in the block and make new entities for each. - if Nkind (N) = N_Block_Statement and then Present (Declarations (N)) - then + if Nkind (N) = N_Block_Statement then declare Decl : Node_Id := First (Declarations (N)); @@ -24300,7 +24307,10 @@ package body Sem_Util is then EWA_Inner_Scope_Level := EWA_Inner_Scope_Level - 1; - elsif Nkind (N) = N_Expression_With_Actions then + elsif Nkind (N) = N_Expression_With_Actions + or else + (Nkind (N) = N_Quantified_Expression and then Expander_Active) + then EWA_Level := EWA_Level - 1; end if; end Visit_Node; @@ -27163,6 +27173,15 @@ package body Sem_Util is then return True; + -- The body of a protected operation is within the protected type + + elsif Is_Subprogram (Curr) + and then Present (Protected_Subprogram (Curr)) + and then Is_Protected_Type (Outer) + and then Scope (Protected_Subprogram (Curr)) = Outer + then + return True; + -- Outside of its scope, a synchronized type may just be private elsif Is_Private_Type (Curr) @@ -27204,6 +27223,13 @@ package body Sem_Util is then return True; + elsif Is_Subprogram (Curr) + and then Present (Protected_Subprogram (Curr)) + and then Is_Protected_Type (Outer) + and then Scope (Protected_Subprogram (Curr)) = Outer + then + return True; + elsif Is_Private_Type (Curr) and then Present (Full_View (Curr)) then @@ -27477,7 +27503,7 @@ package body Sem_Util is -- call to Ada.Task_Identification.Abort_Task. if Restriction_Check_Required (No_Abort_Statements) - and then (Is_RTE (Val, RE_Abort_Task)) + and then Is_RTE (Val, RE_Abort_Task) -- A special extra check, don't complain about a reference from within -- the Ada.Task_Identification package itself! @@ -27981,8 +28007,8 @@ package body Sem_Util is High_Value : constant Uint := Expr_Value (Type_High_Bound (Index_Subtype)); begin - if (Index_Value < Low_Value) - or (Index_Value > High_Value) + if Index_Value < Low_Value + or Index_Value > High_Value then return False; end if; @@ -27990,8 +28016,8 @@ package body Sem_Util is Next_Index (Indx); Expr := Next (Expr); - pragma Assert ((Present (Indx) = Present (Expr)) - or else (Serious_Errors_Detected > 0)); + pragma Assert (Present (Indx) = Present (Expr) + or else Serious_Errors_Detected > 0); exit when not (Present (Indx) and Present (Expr)); end loop; end; @@ -28156,6 +28182,9 @@ package body Sem_Util is Ent := Defining_Identifier (Ent); exit; + when N_Entity => + exit; + when others => null; end case; @@ -29481,56 +29510,6 @@ package body Sem_Util is and then Full_View (Etype (Expr)) = Expec_Type then return; - - -- In an instance, there is an ongoing problem with completion of - -- types derived from private types. Their structure is what Gigi - -- expects, but the Etype is the parent type rather than the derived - -- private type itself. Do not flag error in this case. The private - -- completion is an entity without a parent, like an Itype. Similarly, - -- full and partial views may be incorrect in the instance. - -- There is no simple way to insure that it is consistent ??? - - -- A similar view discrepancy can happen in an inlined body, for the - -- same reason: inserted body may be outside of the original package - -- and only partial views are visible at the point of insertion. - - -- If In_Generic_Actual (Expr) is True then we cannot assume that - -- the successful semantic analysis of the generic guarantees anything - -- useful about type checking of this instance, so we ignore - -- In_Instance in that case. There may be cases where this is not - -- right (the symptom would probably be rejecting something - -- that ought to be accepted) but we don't currently have any - -- concrete examples of this. - - elsif (In_Instance and then not In_Generic_Actual (Expr)) - or else In_Inlined_Body - then - if Etype (Etype (Expr)) = Etype (Expected_Type) - and then - (Has_Private_Declaration (Expected_Type) - or else Has_Private_Declaration (Etype (Expr))) - and then No (Parent (Expected_Type)) - then - return; - - elsif Nkind (Parent (Expr)) = N_Qualified_Expression - and then Entity (Subtype_Mark (Parent (Expr))) = Expected_Type - then - return; - - elsif Is_Private_Type (Expected_Type) - and then Present (Full_View (Expected_Type)) - and then Covers (Full_View (Expected_Type), Etype (Expr)) - then - return; - - -- Conversely, type of expression may be the private one - - elsif Is_Private_Type (Base_Type (Etype (Expr))) - and then Full_View (Base_Type (Etype (Expr))) = Expected_Type - then - return; - end if; end if; -- Avoid printing internally generated subtypes in error messages and @@ -30550,9 +30529,9 @@ package body Sem_Util is (Expr : Node_Id; Expr_Trailer : Node_Id := Empty) return Determining_Expression_List is - Par : Node_Id := Expr; - Trailer : Node_Id := Expr_Trailer; - Next_Element : Determining_Expr; + Par : Node_Id := Expr; + Trailer : Node_Id := Expr_Trailer; + Next_Element : Determining_Expr; begin -- We want to stop climbing up the tree when we reach the -- postcondition expression. An aspect_specification is @@ -30660,9 +30639,13 @@ package body Sem_Util is else pragma Assert (Get_Pragma_Id (Pragma_Name (Par)) in - Pragma_Post | Pragma_Postcondition - | Pragma_Post_Class | Pragma_Refined_Post - | Pragma_Check | Pragma_Contract_Cases); + Pragma_Check + | Pragma_Contract_Cases + | Pragma_Exceptional_Cases + | Pragma_Post + | Pragma_Postcondition + | Pragma_Post_Class + | Pragma_Refined_Post); return (1 .. 0 => <>); -- recursion terminates here end if; @@ -30783,7 +30766,8 @@ package body Sem_Util is -- array_component_association or of -- a container_element_associatiation. - if Nkind (Par) = N_Component_Association + if Nkind (Par) in N_Component_Association + | N_Iterated_Component_Association and then Trailer = Expression (Par) then -- determine whether Par is part of an array aggregate diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index f98e056..3751fb7 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -618,9 +618,9 @@ package Sem_Util is -- Possible optimization??? function Corresponding_Primitive_Op - (Ancestor_Op : Entity_Id; - Descendant_Type : Entity_Id) return Entity_Id; - -- Given a primitive subprogram of a tagged type and a (distinct) + (Ancestor_Op : Entity_Id; + Descendant_Type : Entity_Id) return Entity_Id; + -- Given a primitive subprogram of a first type and a (distinct) -- descendant type of that type, find the corresponding primitive -- subprogram of the descendant type. @@ -639,18 +639,18 @@ package Sem_Util is function Current_Scope return Entity_Id; -- Get entity representing current scope + function Current_Scope_No_Loops return Entity_Id; + -- Return the current scope ignoring internally generated loops + procedure Add_Block_Identifier - (N : Node_Id; - Id : out Entity_Id; - Scope : Entity_Id := Current_Scope); + (N : Node_Id; + Id : out Entity_Id; + Scope : Entity_Id := Current_Scope); -- Given a block statement N, generate an internal E_Block label and make -- it the identifier of the block. Scope denotes the scope in which the -- generated entity Id is created and defaults to the current scope. If the -- block already has an identifier, Id returns the entity of its label. - function Current_Scope_No_Loops return Entity_Id; - -- Return the current scope ignoring internally generated loops - function Current_Subprogram return Entity_Id; -- Returns current enclosing subprogram. If Current_Scope is a subprogram, -- then that is what is returned, otherwise the Enclosing_Subprogram of the @@ -809,8 +809,10 @@ package Sem_Util is procedure Enter_Name (Def_Id : Entity_Id); -- Insert new name in symbol table of current scope with check for -- duplications (error message is issued if a conflict is found). - -- Note: Enter_Name is not used for overloadable entities, instead these - -- are entered using Sem_Ch6.Enter_Overloaded_Entity. + -- Note: Enter_Name is not used for most overloadable entities, instead + -- they are entered using Sem_Ch6.Enter_Overloaded_Entity. However, + -- this is used for SOME overloadable entities, such as enumeration + -- literals and certain operator symbols. function Entity_Of (N : Node_Id) return Entity_Id; -- Obtain the entity of arbitrary node N. If N is a renaming, return the @@ -1078,7 +1080,6 @@ package Sem_Util is -- -- Report_Errors is set to True if the values of the discriminants are -- insufficiently static (see body for details of what that means). - -- -- Allow_Compile_Time if set to True, allows compile time known values in -- Governed_By expressions in addition to static expressions. @@ -1474,6 +1475,9 @@ package Sem_Util is -- Return True if the loop has no side effect and can therefore be -- marked for removal. Return False if N is not a N_Loop_Statement. + function Is_Container_Aggregate (Exp : Node_Id) return Boolean; + -- Is the given expression a container aggregate? + function Is_Newly_Constructed (Exp : Node_Id; Context_Requires_NC : Boolean) return Boolean; -- Indicates whether a given expression is "newly constructed" (RM 4.4). @@ -1695,9 +1699,14 @@ package Sem_Util is -- either the value is not yet known before back-end processing or it is -- not known at compile time after back-end processing. - procedure Inherit_Predicate_Flags (Subt, Par : Entity_Id); + procedure Inherit_Predicate_Flags + (Subt, Par : Entity_Id; + Only_Flags : Boolean := False); -- Propagate static and dynamic predicate flags from a parent to the - -- subtype in a subtype declaration with and without constraints. + -- subtype in a subtype declaration with and without constraints, or from + -- a parent to the derived type in a derived type declaration. Only_Flags + -- is True in the case of a derived type declaration to inherit only the + -- flags, not the predicate functions. procedure Inherit_Rep_Item_Chain (Typ : Entity_Id; From_Typ : Entity_Id); -- Inherit the rep item chain of type From_Typ without clobbering any @@ -1759,10 +1768,6 @@ package Sem_Util is function Is_Actual_Parameter (N : Node_Id) return Boolean; -- Determines if N is an actual parameter in a subprogram or entry call - function Is_Actual_Tagged_Parameter (N : Node_Id) return Boolean; - -- Determines if N is an actual parameter of a formal of tagged type in a - -- subprogram call. - function Is_Aliased_View (Obj : Node_Id) return Boolean; -- Determine if Obj is an aliased view, i.e. the name of an object to which -- 'Access or 'Unchecked_Access can apply. Note that this routine uses the @@ -2083,12 +2088,6 @@ package Sem_Util is -- E is a subprogram. Return True is E is an implicit operation inherited -- by a derived type declaration. - function Is_Inherited_Operation_For_Type - (E : Entity_Id; - Typ : Entity_Id) return Boolean; - -- E is a subprogram. Return True is E is an implicit operation inherited - -- by the derived type declaration for type Typ. - function Is_Inlinable_Expression_Function (Subp : Entity_Id) return Boolean; -- Return True if Subp is an expression function that fulfills all the -- following requirements for inlining: @@ -2103,6 +2102,11 @@ package Sem_Util is -- 9. Nominal subtype of the returned object statically compatible -- with the result subtype of the expression function. + function Is_Internal_Block (N : Node_Id) return Boolean; + pragma Inline (Is_Internal_Block); + -- Determine if N is an N_Block_Statement with an internal label. See + -- Add_Block_Identifier. + function Is_Iterator (Typ : Entity_Id) return Boolean; -- AI05-0139-2: Check whether Typ is one of the predefined interfaces in -- Ada.Iterator_Interfaces, or it is derived from one. @@ -2345,8 +2349,10 @@ package Sem_Util is function Is_Subprogram_Contract_Annotation (Item : Node_Id) return Boolean; -- Determine whether aspect specification or pragma Item is one of the -- following subprogram contract annotations: + -- Always_Terminates -- Contract_Cases -- Depends + -- Exceptional_Cases -- Extensions_Visible -- Global -- Post @@ -2620,22 +2626,11 @@ package Sem_Util is -- below. As for New_Copy_Tree, it is illegal to attempt to copy extended -- nodes (entities) either directly or indirectly using this function. - function New_Copy_Separate_List (List : List_Id) return List_Id; - -- Copy recursively a list of nodes using New_Copy_Separate_Tree - - function New_Copy_Separate_Tree (Source : Node_Id) return Node_Id; - -- Perform a deep copy of the subtree rooted at Source using New_Copy_Tree - -- replacing entities of local declarations by new entities. This behavior - -- is required by the backend to ensure entities uniqueness when a copy of - -- a subtree is attached to the tree. The new entities keep their original - -- names to facilitate debugging the tree copy. - function New_Copy_Tree - (Source : Node_Id; - Map : Elist_Id := No_Elist; - New_Sloc : Source_Ptr := No_Location; - New_Scope : Entity_Id := Empty; - Scopes_In_EWA_OK : Boolean := False) return Node_Id; + (Source : Node_Id; + Map : Elist_Id := No_Elist; + New_Sloc : Source_Ptr := No_Location; + New_Scope : Entity_Id := Empty) return Node_Id; -- Perform a deep copy of the subtree rooted at Source. Entities, itypes, -- and nodes are handled separately as follows: -- @@ -2646,6 +2641,7 @@ package Sem_Util is -- -- First_Named_Actual -- Next_Named_Actual + -- Controlling_Argument -- -- If applicable, the Etype field (if any) is updated to refer to a -- local itype or type (see below). @@ -2704,10 +2700,6 @@ package Sem_Util is -- -- Parameter New_Scope may be used to specify a new scope for all copied -- entities and itypes. - -- - -- Parameter Scopes_In_EWA_OK may be used to force the replication of both - -- scoping entities and non-scoping entities found within expression with - -- actions nodes. function New_External_Entity (Kind : Entity_Kind; diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb index 834d48d..5dd7c17 100644 --- a/gcc/ada/sem_warn.adb +++ b/gcc/ada/sem_warn.adb @@ -353,7 +353,7 @@ package body Sem_Warn is begin -- One argument, so check the argument - if Present (PA) and then List_Length (PA) = 1 then + if List_Length (PA) = 1 then if Nkind (First (PA)) = N_Parameter_Association then Find_Var (Explicit_Actual_Parameter (First (PA))); else diff --git a/gcc/ada/set_targ.adb b/gcc/ada/set_targ.adb index b37c8b7..4165615 100644 --- a/gcc/ada/set_targ.adb +++ b/gcc/ada/set_targ.adb @@ -943,7 +943,7 @@ begin Long_Long_Size := Get_Long_Long_Size; Long_Size := Get_Long_Size; Maximum_Alignment := Get_Maximum_Alignment; - Max_Unaligned_Field := Get_Max_Unaligned_Field; + Max_Unaligned_Field := 1; Pointer_Size := Get_Pointer_Size; Short_Enums := Get_Short_Enums; Short_Size := Get_Short_Size; diff --git a/gcc/ada/set_targ.ads b/gcc/ada/set_targ.ads index 623de6a..4342059 100644 --- a/gcc/ada/set_targ.ads +++ b/gcc/ada/set_targ.ads @@ -74,7 +74,7 @@ package Set_Targ is Long_Long_Size : Pos; -- Standard.Long_Long_Integer'Size Long_Size : Pos; -- Standard.Long_Integer'Size Maximum_Alignment : Pos; -- Maximum permitted alignment - Max_Unaligned_Field : Pos; -- Maximum size for unaligned bit field + Max_Unaligned_Field : Pos; -- Kept only for backward compatibility Pointer_Size : Pos; -- System.Address'Size Short_Enums : Nat; -- Foreign enums use short size? Short_Size : Pos; -- Standard.Short_Integer'Size diff --git a/gcc/ada/sinfo-utils.adb b/gcc/ada/sinfo-utils.adb index 02ed69d..b0cc2d3 100644 --- a/gcc/ada/sinfo-utils.adb +++ b/gcc/ada/sinfo-utils.adb @@ -50,7 +50,7 @@ package body Sinfo.Utils is -- Either way, gnat1 will stop when node 12345 is created, or certain other -- interesting operations are performed, such as Rewrite. To see exactly - -- which operations, search for "pragma Debug" below. + -- which operations, search for "New_Node_Debugging_Output" in Atree. -- The second method is much faster if the amount of Ada code being -- compiled is large. diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index c25db08..57fd704 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -389,21 +389,23 @@ package Sinfo is -- abbreviations are used: -- "plus fields for binary operator" - -- Chars Name_Id for the operator - -- Left_Opnd left operand expression - -- Right_Opnd right operand expression - -- Entity defining entity for operator - -- Associated_Node for generic processing - -- Do_Overflow_Check set if overflow check needed - -- Has_Private_View set in generic units. + -- Chars Name_Id for the operator + -- Left_Opnd left operand expression + -- Right_Opnd right operand expression + -- Entity defining entity for operator + -- Associated_Node for generic processing + -- Do_Overflow_Check set if overflow check needed + -- Has_Private_View set in generic units + -- Has_Secondary_Private_View set in generic units -- "plus fields for unary operator" - -- Chars Name_Id for the operator - -- Right_Opnd right operand expression - -- Entity defining entity for operator - -- Associated_Node for generic processing - -- Do_Overflow_Check set if overflow check needed - -- Has_Private_View set in generic units. + -- Chars Name_Id for the operator + -- Right_Opnd right operand expression + -- Entity defining entity for operator + -- Associated_Node for generic processing + -- Do_Overflow_Check set if overflow check needed + -- Has_Private_View set in generic units + -- Has_Secondary_Private_View set in generic units -- "plus fields for expression" -- Paren_Count number of parentheses levels @@ -830,7 +832,7 @@ package Sinfo is -- an unconstrained packed array and the dereference is the prefix of -- a 'Size attribute reference, or 2) when the dereference node is -- created for the expansion of an allocator with a subtype_indication - -- and the designated subtype is an unconstrained discriminated type. + -- and the designated subtype is an unconstrained composite type. -- Address_Warning_Posted -- Present in N_Attribute_Definition nodes. Set to indicate that we have @@ -932,6 +934,12 @@ package Sinfo is -- a pragma Import or Interface applies, in which case no body is -- permitted (in Ada 83 or Ada 95). + -- Cannot_Be_Superflat + -- This flag is present in N_Range nodes. It is set if the range is of a + -- discrete type and cannot be superflat, i.e. it is guaranteed that the + -- inequality High_Bound >= Low_Bound - 1 is true. At the time of this + -- writing, it is only used by the code generator to streamline things. + -- Cleanup_Actions -- Present in block statements created for transient blocks, contains -- additional cleanup actions carried over from the transient scope. @@ -1046,8 +1054,8 @@ package Sinfo is -- and their first named subtypes. -- Corresponding_Spec - -- This field is set in subprogram, package, task, and protected body - -- nodes, where it points to the defining entity in the corresponding + -- This field is set in subprogram, package, task, entry and protected + -- body nodes where it points to the defining entity in the corresponding -- spec. The attribute is also set in N_With_Clause nodes where it points -- to the defining entity for the with'ed spec, and in a subprogram -- renaming declaration when it is a Renaming_As_Body. The field is Empty @@ -1323,8 +1331,9 @@ package Sinfo is -- to the entity for the first subtype. -- Float_Truncate - -- A flag present in type conversion nodes. This is used for float to - -- integer conversions where truncation is required rather than rounding. + -- A flag present in type conversion nodes. It is used for floating-point + -- to fixed-point or integer conversions, where truncation is required + -- rather than rounding. -- Forwards_OK -- A flag present in the N_Assignment_Statement node. It is used only @@ -1450,6 +1459,13 @@ package Sinfo is -- A flag present in N_Subprogram_Body and N_Task_Definition nodes to -- flag the presence of a pragma Relative_Deadline. + -- Has_Secondary_Private_View + -- A flag present in generic nodes that have an entity, to indicate that + -- the node is either of an access type whose Designated_Type is private + -- or of an array type whose Component_Type is private. Used to exchange + -- private and full declarations if the visibility at instantiation is + -- different from the visibility at generic definition. + -- Has_Self_Reference -- Present in N_Aggregate and N_Extension_Aggregate. Indicates that one -- of the expressions contains an access attribute reference to the @@ -1704,8 +1720,10 @@ package Sinfo is -- a source construct, applies to a generic unit or its body, and denotes -- one of the following contract-related annotations: -- Abstract_State + -- Always_Terminates -- Contract_Cases -- Depends + -- Exceptional_Cases -- Extensions_Visible -- Global -- Initial_Condition @@ -1720,6 +1738,7 @@ package Sinfo is -- Refined_Global -- Refined_Post -- Refined_State + -- Subprogram_Variant -- Test_Case -- Is_Homogeneous_Aggregate @@ -1899,6 +1918,11 @@ package Sinfo is -- Present in variable reference markers. Set when the original variable -- reference constitutes a write of the variable. + -- Iterator_Filter + -- Present in N_Loop_Parameter_Specification and N_Iterator_Specification + -- nodes for Ada 2022. It is used to store the condition present in the + -- eponymous Ada 2022 construct. + -- Itype -- Used in N_Itype_Reference node to reference an itype for which it is -- important to ensure that it is defined. See description of this node @@ -2058,12 +2082,14 @@ package Sinfo is -- is undefined and should not be read). -- No_Ctrl_Actions - -- Present in N_Assignment_Statement to indicate that no Finalize nor - -- Adjust should take place on this assignment even though the RHS is - -- controlled. Also indicates that the primitive _assign should not be - -- used for a tagged assignment. This is used in init procs and aggregate - -- expansions where the generated assignments are initializations, not - -- real assignments. + -- Present in N_Assignment_Statement to indicate that neither Finalize + -- nor Adjust should take place on this assignment even though the LHS + -- and RHS are controlled. Also to indicate that the primitive _assign + -- should not be used for a tagged assignment. This flag is used in init + -- proc and aggregate expansion where the generated assignments are + -- initializations, not real assignments. Note that it also suppresses + -- the creation of transient scopes around the N_Assignment_Statement, + -- in other words it disables all controlled actions for the assignment. -- No_Elaboration_Check -- NOTE: this flag is relevant only for the legacy ABE mechanism and @@ -2083,6 +2109,15 @@ package Sinfo is -- to generate the proper message (see Sem_Util.Check_Unused_Withs for -- full details). + -- No_Finalize_Actions + -- Present in N_Assignment_Statement to indicate that no Finalize should + -- take place on this assignment even though the LHS is controlled. Also + -- to indicate that the primitive _assign should not be used for a tagged + -- assignment. This flag is only used in aggregates expansion where the + -- generated assignments are initializations, not real assignments. Note + -- that, unlike the No_Ctrl_Actions flag, it does *not* suppress the + -- creation of transient scopes around the N_Assignment_Statement. + -- No_Initialization -- Present in N_Object_Declaration and N_Allocator to indicate that the -- object must not be initialized (by Initialize or call to an init @@ -2097,12 +2132,6 @@ package Sinfo is -- It is used to indicate that processing for extended overflow checking -- modes is not required (this is used to prevent infinite recursion). - -- No_Side_Effect_Removal - -- Present in N_Function_Call nodes. Set when a function call does not - -- require side effect removal. This attribute suppresses the generation - -- of a temporary to capture the result of the function which eventually - -- replaces the function call. - -- No_Truncation -- Present in N_Unchecked_Type_Conversion node. This flag has an effect -- only if the RM_Size of the source is greater than the RM_Size of the @@ -2305,7 +2334,7 @@ package Sinfo is -- can be set in N_Object_Declaration nodes, to similarly suppress any -- checks on the initializing value. In assignment statements it also -- suppresses access checks in the generated code for out- and in-out - -- parameters in entry calls, as well as length checks. + -- parameters in entry calls, as well as discriminant and length checks. -- Suppress_Loop_Warnings -- Used in N_Loop_Statement node to indicate that warnings within the @@ -2502,6 +2531,7 @@ package Sinfo is -- Is_SPARK_Mode_On_Node -- Is_Elaboration_Warnings_OK_Node -- Has_Private_View (set in generic units) + -- Has_Secondary_Private_View (set in generic units) -- Redundant_Use -- Atomic_Sync_Required -- plus fields for expression @@ -2585,6 +2615,7 @@ package Sinfo is -- Entity -- Associated_Node -- Has_Private_View (set in generic units) + -- Has_Secondary_Private_View (set in generic units) -- plus fields for expression -- Note: the Entity field will be missing (set to Empty) for character @@ -3081,6 +3112,7 @@ package Sinfo is -- Sloc points to .. -- Low_Bound -- High_Bound + -- Cannot_Be_Superflat -- Includes_Infinities -- plus fields for expression @@ -4924,6 +4956,7 @@ package Sinfo is -- Forwards_OK -- Backwards_OK -- No_Ctrl_Actions + -- No_Finalize_Actions -- Has_Target_Names -- Is_Elaboration_Code -- Componentwise_Assignment @@ -5366,6 +5399,7 @@ package Sinfo is -- Associated_Node Note this is shared with Entity -- Etype -- Has_Private_View (set in generic units) + -- Has_Secondary_Private_View (set in generic units) -- Note: the Strval field may be set to No_String for generated -- operator symbols that are known not to be string literals @@ -5550,7 +5584,6 @@ package Sinfo is -- Is_Elaboration_Warnings_OK_Node -- No_Elaboration_Check -- Is_Expanded_Build_In_Place_Call - -- No_Side_Effect_Removal -- Is_Known_Guaranteed_ABE -- plus fields for expression @@ -6199,6 +6232,7 @@ package Sinfo is -- Declarations -- Handled_Statement_Sequence -- Activation_Chain_Entity + -- Corresponding_Spec -- At_End_Proc (set to Empty if no clean up procedure) ----------------------------------- @@ -7955,13 +7989,14 @@ package Sinfo is -- operation) are also in this list. -- Contract_Test_Cases contains a collection of pragmas that correspond - -- to aspects/pragmas Contract_Cases, Test_Case and Subprogram_Variant. - -- The ordering in the list is in LIFO fashion. + -- to aspects/pragmas Contract_Cases, Exceptional_Cases, Test_Case and + -- Subprogram_Variant. The ordering in the list is in LIFO fashion. -- Classifications contains pragmas that either declare, categorize, or -- establish dependencies between subprogram or package inputs and -- outputs. Currently the following pragmas appear in this list: -- Abstract_States + -- Always_Terminates -- Async_Readers -- Async_Writers -- Constant_After_Elaboration @@ -8007,6 +8042,7 @@ package Sinfo is -- Is_SPARK_Mode_On_Node -- Is_Elaboration_Warnings_OK_Node -- Has_Private_View (set in generic units) + -- Has_Secondary_Private_View (set in generic units) -- Redundant_Use -- Atomic_Sync_Required -- plus fields for expression diff --git a/gcc/ada/sinput.adb b/gcc/ada/sinput.adb index 2e07a42..4352cad 100644 --- a/gcc/ada/sinput.adb +++ b/gcc/ada/sinput.adb @@ -550,7 +550,7 @@ package body Sinput is or else S = Standard_ASCII_Location or else S = System_Location; - pragma Assert ((S > No_Location) xor Special); + pragma Assert (S > No_Location xor Special); pragma Assert (Result in Source_File.First .. Source_File.Last); SFR : Source_File_Record renames Source_File.Table (Result); diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index 8f71ad9..5044abb 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -156,6 +156,7 @@ package Snames is Name_Dynamic_Predicate : constant Name_Id := N + $; Name_Exclusive_Functions : constant Name_Id := N + $; Name_Full_Access_Only : constant Name_Id := N + $; + Name_Ghost_Predicate : constant Name_Id := N + $; Name_Integer_Literal : constant Name_Id := N + $; Name_No_Controlled_Parts : constant Name_Id := N + $; Name_No_Task_Parts : constant Name_Id := N + $; @@ -260,6 +261,7 @@ package Snames is -- Some miscellaneous names used for error detection/recovery + Name_ASCII : constant Name_Id := N + $; Name_Const : constant Name_Id := N + $; Name_Error : constant Name_Id := N + $; Name_False : constant Name_Id := N + $; @@ -501,6 +503,7 @@ package Snames is Name_Abort_Defer : constant Name_Id := N + $; -- GNAT Name_Abstract_State : constant Name_Id := N + $; -- GNAT Name_All_Calls_Remote : constant Name_Id := N + $; + Name_Always_Terminates : constant Name_Id := N + $; -- GNAT Name_Assert : constant Name_Id := N + $; -- Ada 05 Name_Assert_And_Cut : constant Name_Id := N + $; -- GNAT Name_Assume : constant Name_Id := N + $; -- GNAT @@ -551,6 +554,7 @@ package Snames is Name_Elaborate : constant Name_Id := N + $; -- Ada 83 Name_Elaborate_All : constant Name_Id := N + $; Name_Elaborate_Body : constant Name_Id := N + $; + Name_Exceptional_Cases : constant Name_Id := N + $; -- GNAT Name_Export : constant Name_Id := N + $; Name_Export_Function : constant Name_Id := N + $; -- GNAT Name_Export_Object : constant Name_Id := N + $; -- GNAT @@ -1336,9 +1340,10 @@ package Snames is Name_Shift_Right : constant Name_Id := N + $; Name_Shift_Right_Arithmetic : constant Name_Id := N + $; Name_Source_Location : constant Name_Id := N + $; + Name_To_Integer : constant Name_Id := N + $; + Name_To_Pointer : constant Name_Id := N + $; Name_Unchecked_Conversion : constant Name_Id := N + $; Name_Unchecked_Deallocation : constant Name_Id := N + $; - Name_To_Pointer : constant Name_Id := N + $; Last_Intrinsic_Name : constant Name_Id := N + $; -- Names used in processing intrinsic calls @@ -1640,7 +1645,7 @@ package Snames is subtype Internal_Attribute_Id is Attribute_Id range Attribute_CPU .. Attribute_Interrupt_Priority; - type Attribute_Class_Array is array (Attribute_Id) of Boolean; + type Attribute_Set is array (Attribute_Id) of Boolean; -- Type used to build attribute classification flag arrays ------------------------------------ @@ -1809,6 +1814,7 @@ package Snames is Pragma_Abort_Defer, Pragma_Abstract_State, Pragma_All_Calls_Remote, + Pragma_Always_Terminates, Pragma_Assert, Pragma_Assert_And_Cut, Pragma_Assume, @@ -1846,6 +1852,7 @@ package Snames is Pragma_Elaborate, Pragma_Elaborate_All, Pragma_Elaborate_Body, + Pragma_Exceptional_Cases, Pragma_Export, Pragma_Export_Function, Pragma_Export_Object, diff --git a/gcc/ada/style.adb b/gcc/ada/style.adb index 3014359..e21730b 100644 --- a/gcc/ada/style.adb +++ b/gcc/ada/style.adb @@ -35,9 +35,8 @@ with Nlists; use Nlists; with Opt; use Opt; with Sinfo; use Sinfo; with Sinfo.Nodes; use Sinfo.Nodes; -with Sinfo.Utils; use Sinfo.Utils; with Sinput; use Sinput; -with Stand; use Stand; +with Snames; use Snames; with Stylesw; use Stylesw; package body Style is @@ -68,7 +67,7 @@ package body Style is end; end if; - Error_Msg_N ("(style) subprogram body has no previous spec", N); + Error_Msg_N ("(style) subprogram body has no previous spec?s?", N); end if; end Body_With_No_Spec; @@ -85,11 +84,11 @@ package body Style is if Style_Check_Array_Attribute_Index then if D = 1 and then Present (E1) then Error_Msg_N -- CODEFIX - ("(style) index number not allowed for one dimensional array", + ("(style) index number not allowed for one dimensional array?A?", E1); elsif D > 1 and then No (E1) then Error_Msg_N -- CODEFIX - ("(style) index number required for multi-dimensional array", + ("(style) index number required for multi-dimensional array?A?", N); end if; end if; @@ -168,7 +167,7 @@ package body Style is Error_Msg_Node_1 := Def; Error_Msg_Sloc := Sloc (Def); Error_Msg -- CODEFIX - ("(style) bad casing of & declared#", Sref, Ref); + ("(style) bad casing of & declared#?r?", Sref, Ref); return; end if; @@ -201,7 +200,7 @@ package body Style is else -- ASCII is all upper case - if Entity (Ref) = Standard_ASCII then + if Chars (Ref) = Name_ASCII then Cas := All_Upper_Case; -- Special handling for names in package ASCII @@ -250,7 +249,7 @@ package body Style is Set_Casing (Cas); Error_Msg_Name_1 := Name_Enter; Error_Msg_N -- CODEFIX - ("(style) bad casing of %% declared in Standard", Ref); + ("(style) bad casing of %% declared in Standard?n?", Ref); end if; end if; end if; @@ -294,16 +293,16 @@ package body Style is if Nkind (N) = N_Subprogram_Body then Error_Msg_NE -- CODEFIX - ("(style) missing OVERRIDING indicator in body of&", N, E); + ("(style) missing OVERRIDING indicator in body of&?O?", N, E); elsif Nkind (N) = N_Abstract_Subprogram_Declaration then Error_Msg_NE -- CODEFIX - ("(style) missing OVERRIDING indicator in declaration of&", + ("(style) missing OVERRIDING indicator in declaration of&?O?", Specification (N), E); else Error_Msg_NE -- CODEFIX - ("(style) missing OVERRIDING indicator in declaration of&", + ("(style) missing OVERRIDING indicator in declaration of&?O?", Nod, E); end if; end if; @@ -317,7 +316,7 @@ package body Style is begin if Style_Check_Order_Subprograms then Error_Msg_N -- CODEFIX - ("(style) subprogram body& not in alphabetical order", Name); + ("(style) subprogram body& not in alphabetical order?o?", Name); end if; end Subprogram_Not_In_Alpha_Order; end Style; diff --git a/gcc/ada/style.ads b/gcc/ada/style.ads index 35118f4..726abcd 100644 --- a/gcc/ada/style.ads +++ b/gcc/ada/style.ads @@ -192,10 +192,15 @@ package Style is renames Style_Inst.Check_Vertical_Bar; -- Called after scanning a vertical bar to check spacing - procedure Check_Xtra_Parens (Loc : Source_Ptr) + procedure Check_Xtra_Parens (N : Node_Id) renames Style_Inst.Check_Xtra_Parens; - -- Called after scanning an if, case or quantified expression that has at - -- least one level of parentheses around the entire expression. + -- Called after scanning an entire expression (N) that does not require an + -- extra level of parentheses. + + procedure Check_Xtra_Parens_Precedence (N : Node_Id) + renames Style_Inst.Check_Xtra_Parens_Precedence; + -- Called after scanning a subexpression (N) that does not require an + -- extra level of parentheses according to operator precedence rules. function Mode_In_Check return Boolean renames Style_Inst.Mode_In_Check; diff --git a/gcc/ada/styleg.adb b/gcc/ada/styleg.adb index 045842b..a7524ec 100644 --- a/gcc/ada/styleg.adb +++ b/gcc/ada/styleg.adb @@ -33,6 +33,7 @@ with Csets; use Csets; with Einfo; use Einfo; with Einfo.Utils; use Einfo.Utils; with Err_Vars; use Err_Vars; +with Errout; with Opt; use Opt; with Scans; use Scans; with Sinfo; use Sinfo; @@ -173,7 +174,7 @@ package body Styleg is if Style_Check_Attribute_Casing then if Determine_Token_Casing /= Mixed_Case then Error_Msg_SC -- CODEFIX - ("(style) bad capitalization, mixed case required"); + ("(style) bad capitalization, mixed case required?a?"); end if; end if; end Check_Attribute_Name; @@ -263,10 +264,10 @@ package body Styleg is elsif Nkind (Orig) = N_Op_And then Error_Msg -- CODEFIX - ("(style) `AND THEN` required", Sloc (Orig)); + ("(style) `AND THEN` required?B?", Sloc (Orig)); else Error_Msg -- CODEFIX - ("(style) `OR ELSE` required", Sloc (Orig)); + ("(style) `OR ELSE` required?B?", Sloc (Orig)); end if; end; end if; @@ -506,7 +507,7 @@ package body Styleg is and then Source (Scan_Ptr - 1) > ' ' then Error_Msg_S -- CODEFIX - ("(style) space required"); + ("(style) space required?c?"); end if; end if; @@ -520,7 +521,7 @@ package body Styleg is and then not Is_Special_Character (Source (Scan_Ptr + 2)) then Error_Msg -- CODEFIX - ("(style) space required", Scan_Ptr + 2); + ("(style) space required?c?", Scan_Ptr + 2); end if; end if; @@ -537,7 +538,7 @@ package body Styleg is and then not Same_Column_As_Previous_Line then Error_Msg_S -- CODEFIX - ("(style) bad column"); + ("(style) bad column?0?"); end if; return; @@ -583,7 +584,7 @@ package body Styleg is Error_Space_Required (Scan_Ptr + 2); else Error_Msg -- CODEFIX - ("(style) two spaces required", Scan_Ptr + 2); + ("(style) two spaces required?c?", Scan_Ptr + 2); end if; return; @@ -624,7 +625,7 @@ package body Styleg is | All_Upper_Case => Error_Msg_SC -- CODEFIX - ("(style) bad capitalization, mixed case required"); + ("(style) bad capitalization, mixed case required?D?"); -- The Unknown case is something like A_B_C, which is both all -- caps and mixed case. @@ -665,12 +666,12 @@ package body Styleg is if Blank_Lines = 2 then Error_Msg -- CODEFIX - ("(style) blank line not allowed at end of file", + ("(style) blank line not allowed at end of file?u?", Blank_Line_Location); elsif Blank_Lines >= 3 then Error_Msg -- CODEFIX - ("(style) blank lines not allowed at end of file", + ("(style) blank lines not allowed at end of file?u?", Blank_Line_Location); end if; end if; @@ -697,7 +698,7 @@ package body Styleg is begin if Style_Check_Horizontal_Tabs then Error_Msg_S -- CODEFIX - ("(style) horizontal tab not allowed"); + ("(style) horizontal tab not allowed?h?"); end if; end Check_HT; @@ -716,7 +717,7 @@ package body Styleg is and then Start_Column rem Style_Check_Indentation /= 0 then Error_Msg_SC -- CODEFIX - ("(style) bad indentation"); + ("(style) bad indentation?0?"); end if; end if; end Check_Indentation; @@ -755,7 +756,7 @@ package body Styleg is if Style_Check_Max_Line_Length then if Len > Style_Max_Line_Length then Error_Msg - ("(style) this line is too long", + ("(style) this line is too long?M?", Current_Line_Start + Source_Ptr (Style_Max_Line_Length)); end if; end if; @@ -792,10 +793,10 @@ package body Styleg is if Style_Check_Form_Feeds then if Source (Scan_Ptr) = ASCII.FF then Error_Msg_S -- CODEFIX - ("(style) form feed not allowed"); + ("(style) form feed not allowed?f?"); elsif Source (Scan_Ptr) = ASCII.VT then Error_Msg_S -- CODEFIX - ("(style) vertical tab not allowed"); + ("(style) vertical tab not allowed?f?"); end if; end if; @@ -813,7 +814,7 @@ package body Styleg is -- Bad terminator if we don't have an LF elsif Source (Scan_Ptr) /= LF then - Error_Msg_S ("(style) incorrect line terminator"); + Error_Msg_S ("(style) incorrect line terminator?d?"); end if; end if; @@ -829,7 +830,7 @@ package body Styleg is if Style_Check_Blanks_At_End and then L < Len then Error_Msg -- CODEFIX - ("(style) trailing spaces not permitted", S); + ("(style) trailing spaces not permitted?b?", S); end if; -- Deal with empty (blank) line @@ -851,7 +852,7 @@ package body Styleg is else if Style_Check_Blank_Lines and then Blank_Lines > 1 then Error_Msg -- CODEFIX - ("(style) multiple blank lines", Blank_Line_Location); + ("(style) multiple blank lines?u?", Blank_Line_Location); end if; -- And reset blank line count @@ -873,7 +874,8 @@ package body Styleg is or else Token_Ptr - Prev_Token_Ptr /= 4 then -- CODEFIX? Error_Msg - ("(style) single space must separate NOT and IN", Token_Ptr - 1); + ("(style) single space must separate NOT and IN?t?", + Token_Ptr - 1); end if; end if; end Check_Not_In; @@ -933,7 +935,7 @@ package body Styleg is if Style_Check_Pragma_Casing then if Determine_Token_Casing /= Mixed_Case then Error_Msg_SC -- CODEFIX - ("(style) bad capitalization, mixed case required"); + ("(style) bad capitalization, mixed case required?p?"); end if; end if; end Check_Pragma_Name; @@ -1043,10 +1045,10 @@ package body Styleg is else if Token = Tok_Then then Error_Msg -- CODEFIX - ("(style) no statements may follow THEN on same line", S); + ("(style) no statements may follow THEN on same line?S?", S); else Error_Msg - ("(style) no statements may follow ELSE on same line", S); + ("(style) no statements may follow ELSE on same line?S?", S); end if; end if; end Check_Separate_Stmt_Lines_Cont; @@ -1071,7 +1073,7 @@ package body Styleg is if If_Line = Then_Line then null; elsif Token_Ptr /= First_Non_Blank_Location then - Error_Msg_SC ("(style) misplaced THEN"); + Error_Msg_SC ("(style) misplaced THEN?i?"); end if; end; end if; @@ -1117,14 +1119,46 @@ package body Styleg is -- Check_Xtra_Parens -- ----------------------- - procedure Check_Xtra_Parens (Loc : Source_Ptr) is + procedure Check_Xtra_Parens (N : Node_Id) is begin - if Style_Check_Xtra_Parens then + if Style_Check_Xtra_Parens + and then + Paren_Count (N) > + (if Nkind (N) in N_Case_Expression + | N_Expression_With_Actions + | N_If_Expression + | N_Quantified_Expression + | N_Raise_Expression + then 1 + else 0) + then Error_Msg -- CODEFIX - ("(style) redundant parentheses", Loc); + ("(style) redundant parentheses?x?", Errout.First_Sloc (N)); end if; end Check_Xtra_Parens; + ---------------------------------- + -- Check_Xtra_Parens_Precedence -- + ---------------------------------- + + procedure Check_Xtra_Parens_Precedence (N : Node_Id) is + begin + if Style_Check_Xtra_Parens_Precedence + and then + Paren_Count (N) > + (if Nkind (N) in N_Case_Expression + | N_Expression_With_Actions + | N_If_Expression + | N_Quantified_Expression + | N_Raise_Expression + then 1 + else 0) + then + Error_Msg -- CODEFIX + ("(style) redundant parentheses?z?", Errout.First_Sloc (N)); + end if; + end Check_Xtra_Parens_Precedence; + ---------------------------- -- Determine_Token_Casing -- ---------------------------- @@ -1141,7 +1175,7 @@ package body Styleg is procedure Error_Space_Not_Allowed (S : Source_Ptr) is begin Error_Msg -- CODEFIX - ("(style) space not allowed", S); + ("(style) space not allowed?t?", S); end Error_Space_Not_Allowed; -------------------------- @@ -1151,7 +1185,7 @@ package body Styleg is procedure Error_Space_Required (S : Source_Ptr) is begin Error_Msg -- CODEFIX - ("(style) space required", S); + ("(style) space required?t?", S); end Error_Space_Required; -------------------- @@ -1184,7 +1218,7 @@ package body Styleg is if Style_Check_End_Labels then Error_Msg_Node_1 := Name; Error_Msg_SP -- CODEFIX - ("(style) `END &` required"); + ("(style) `END &` required?e?"); end if; end No_End_Name; @@ -1200,7 +1234,7 @@ package body Styleg is if Style_Check_End_Labels then Error_Msg_Node_1 := Name; Error_Msg_SP -- CODEFIX - ("(style) `EXIT &` required"); + ("(style) `EXIT &` required?e?"); end if; end No_Exit_Name; @@ -1216,7 +1250,7 @@ package body Styleg is begin if Style_Check_Keyword_Casing then Error_Msg_SC -- CODEFIX - ("(style) reserved words must be all lower case"); + ("(style) reserved words must be all lower case?k?"); end if; end Non_Lower_Case_Keyword; diff --git a/gcc/ada/styleg.ads b/gcc/ada/styleg.ads index 6f7fbfc..7a610a1 100644 --- a/gcc/ada/styleg.ads +++ b/gcc/ada/styleg.ads @@ -160,9 +160,13 @@ package Styleg is procedure Check_Vertical_Bar; -- Called after scanning a vertical bar to check spacing - procedure Check_Xtra_Parens (Loc : Source_Ptr); - -- Called after scanning an if, case, or quantified expression that has at - -- least one level of parentheses around the entire expression. + procedure Check_Xtra_Parens (N : Node_Id); + -- Called after scanning an entire expression (N) that does not require an + -- extra level of parentheses. + + procedure Check_Xtra_Parens_Precedence (N : Node_Id); + -- Called after scanning a subexpression (N) that does not require an + -- extra level of parentheses according to operator precedence rules. function Mode_In_Check return Boolean; pragma Inline (Mode_In_Check); diff --git a/gcc/ada/stylesw.adb b/gcc/ada/stylesw.adb index 2edc9e8..1b2acfb 100644 --- a/gcc/ada/stylesw.adb +++ b/gcc/ada/stylesw.adb @@ -58,12 +58,8 @@ package body Stylesw is "I" & -- check mode IN "S" & -- check separate lines after THEN or ELSE "u" & -- check no unnecessary blank lines - "x"; -- check extra parentheses around conditionals - - -- Note: we intend GNAT_Style to also include the following, but we do - -- not yet have the whole tool suite clean with respect to this. - - -- "B" & -- check boolean operators + "x" & -- check extra parentheses around conditionals + "z"; -- check parens not required by precedence rules. ------------------------------- -- Reset_Style_Check_Options -- @@ -71,33 +67,34 @@ package body Stylesw is procedure Reset_Style_Check_Options is begin - Style_Check_Indentation := 0; - Style_Check_Array_Attribute_Index := False; - Style_Check_Attribute_Casing := False; - Style_Check_Blanks_At_End := False; - Style_Check_Blank_Lines := False; - Style_Check_Boolean_And_Or := False; - Style_Check_Comments := False; - Style_Check_DOS_Line_Terminator := False; - Style_Check_Mixed_Case_Decls := False; - Style_Check_End_Labels := False; - Style_Check_Form_Feeds := False; - Style_Check_Horizontal_Tabs := False; - Style_Check_If_Then_Layout := False; - Style_Check_Keyword_Casing := False; - Style_Check_Layout := False; - Style_Check_Max_Line_Length := False; - Style_Check_Max_Nesting_Level := False; - Style_Check_Missing_Overriding := False; - Style_Check_Mode_In := False; - Style_Check_Order_Subprograms := False; - Style_Check_Pragma_Casing := False; - Style_Check_References := False; - Style_Check_Separate_Stmt_Lines := False; - Style_Check_Specs := False; - Style_Check_Standard := False; - Style_Check_Tokens := False; - Style_Check_Xtra_Parens := False; + Style_Check_Indentation := 0; + Style_Check_Array_Attribute_Index := False; + Style_Check_Attribute_Casing := False; + Style_Check_Blanks_At_End := False; + Style_Check_Blank_Lines := False; + Style_Check_Boolean_And_Or := False; + Style_Check_Comments := False; + Style_Check_DOS_Line_Terminator := False; + Style_Check_Mixed_Case_Decls := False; + Style_Check_End_Labels := False; + Style_Check_Form_Feeds := False; + Style_Check_Horizontal_Tabs := False; + Style_Check_If_Then_Layout := False; + Style_Check_Keyword_Casing := False; + Style_Check_Layout := False; + Style_Check_Max_Line_Length := False; + Style_Check_Max_Nesting_Level := False; + Style_Check_Missing_Overriding := False; + Style_Check_Mode_In := False; + Style_Check_Order_Subprograms := False; + Style_Check_Pragma_Casing := False; + Style_Check_References := False; + Style_Check_Separate_Stmt_Lines := False; + Style_Check_Specs := False; + Style_Check_Standard := False; + Style_Check_Tokens := False; + Style_Check_Xtra_Parens := False; + Style_Check_Xtra_Parens_Precedence := False; end Reset_Style_Check_Options; --------------------- @@ -187,6 +184,7 @@ package body Stylesw is Add ('t', Style_Check_Tokens); Add ('u', Style_Check_Blank_Lines); Add ('x', Style_Check_Xtra_Parens); + Add ('z', Style_Check_Xtra_Parens_Precedence); if Style_Check_Max_Line_Length then P := P + 1; @@ -426,44 +424,47 @@ package body Stylesw is or else Options (Err_Col) not in '0' .. '9'; end loop; - Style_Check_Max_Line_Length := Style_Max_Line_Length /= 0; + Style_Check_Max_Line_Length := Style_Max_Line_Length /= 0; when 'n' => - Style_Check_Standard := True; + Style_Check_Standard := True; when 'N' => Reset_Style_Check_Options; when 'o' => - Style_Check_Order_Subprograms := True; + Style_Check_Order_Subprograms := True; when 'O' => - Style_Check_Missing_Overriding := True; + Style_Check_Missing_Overriding := True; when 'p' => - Style_Check_Pragma_Casing := True; + Style_Check_Pragma_Casing := True; when 'r' => - Style_Check_References := True; + Style_Check_References := True; when 's' => - Style_Check_Specs := True; + Style_Check_Specs := True; when 'S' => - Style_Check_Separate_Stmt_Lines := True; + Style_Check_Separate_Stmt_Lines := True; when 't' => - Style_Check_Tokens := True; + Style_Check_Tokens := True; when 'u' => - Style_Check_Blank_Lines := True; + Style_Check_Blank_Lines := True; when 'x' => - Style_Check_Xtra_Parens := True; + Style_Check_Xtra_Parens := True; when 'y' => Set_Default_Style_Check_Options; + when 'z' => + Style_Check_Xtra_Parens_Precedence := True; + when ' ' => null; @@ -491,89 +492,92 @@ package body Stylesw is Style_Check_Indentation := 0; when 'a' => - Style_Check_Attribute_Casing := False; + Style_Check_Attribute_Casing := False; when 'A' => - Style_Check_Array_Attribute_Index := False; + Style_Check_Array_Attribute_Index := False; when 'b' => - Style_Check_Blanks_At_End := False; + Style_Check_Blanks_At_End := False; when 'B' => - Style_Check_Boolean_And_Or := False; + Style_Check_Boolean_And_Or := False; when 'c' | 'C' => - Style_Check_Comments := False; + Style_Check_Comments := False; when 'd' => - Style_Check_DOS_Line_Terminator := False; + Style_Check_DOS_Line_Terminator := False; when 'D' => - Style_Check_Mixed_Case_Decls := False; + Style_Check_Mixed_Case_Decls := False; when 'e' => - Style_Check_End_Labels := False; + Style_Check_End_Labels := False; when 'f' => - Style_Check_Form_Feeds := False; + Style_Check_Form_Feeds := False; when 'g' => Reset_Style_Check_Options; when 'h' => - Style_Check_Horizontal_Tabs := False; + Style_Check_Horizontal_Tabs := False; when 'i' => - Style_Check_If_Then_Layout := False; + Style_Check_If_Then_Layout := False; when 'I' => - Style_Check_Mode_In := False; + Style_Check_Mode_In := False; when 'k' => - Style_Check_Keyword_Casing := False; + Style_Check_Keyword_Casing := False; when 'l' => - Style_Check_Layout := False; + Style_Check_Layout := False; when 'L' => Style_Max_Nesting_Level := 0; when 'm' => - Style_Check_Max_Line_Length := False; + Style_Check_Max_Line_Length := False; when 'M' => - Style_Max_Line_Length := 0; - Style_Check_Max_Line_Length := False; + Style_Max_Line_Length := 0; + Style_Check_Max_Line_Length := False; when 'n' => - Style_Check_Standard := False; + Style_Check_Standard := False; when 'o' => - Style_Check_Order_Subprograms := False; + Style_Check_Order_Subprograms := False; when 'O' => - Style_Check_Missing_Overriding := False; + Style_Check_Missing_Overriding := False; when 'p' => - Style_Check_Pragma_Casing := False; + Style_Check_Pragma_Casing := False; when 'r' => - Style_Check_References := False; + Style_Check_References := False; when 's' => - Style_Check_Specs := False; + Style_Check_Specs := False; when 'S' => - Style_Check_Separate_Stmt_Lines := False; + Style_Check_Separate_Stmt_Lines := False; when 't' => - Style_Check_Tokens := False; + Style_Check_Tokens := False; when 'u' => - Style_Check_Blank_Lines := False; + Style_Check_Blank_Lines := False; when 'x' => - Style_Check_Xtra_Parens := False; + Style_Check_Xtra_Parens := False; + + when 'z' => + Style_Check_Xtra_Parens_Precedence := False; when ' ' => null; diff --git a/gcc/ada/stylesw.ads b/gcc/ada/stylesw.ads index 3f8cc78..18428e1 100644 --- a/gcc/ada/stylesw.ads +++ b/gcc/ada/stylesw.ads @@ -279,6 +279,11 @@ package Stylesw is -- not allowed to enclose entire expressions in tests in parentheses -- (C style), e.g. if (x = y) then ... is not allowed. + Style_Check_Xtra_Parens_Precedence : Boolean := False; + -- This can be set True by using the -gnatyz switch. If true, then it is + -- not allowed to enclose subexpressions in parentheses when not required + -- by operator precedence rules, e.g. (X > 1) and (Y < 1). + Style_Max_Line_Length : Nat := 0; -- Value used to check maximum line length. Gets reset as a result of -- use of -gnatym or -gnatyMnnn switches. This value is only read if diff --git a/gcc/ada/switch-c.adb b/gcc/ada/switch-c.adb index f6207e4..bbbb536 100644 --- a/gcc/ada/switch-c.adb +++ b/gcc/ada/switch-c.adb @@ -635,6 +635,12 @@ package body Switch.C is Generate_Processed_File := True; Ptr := Ptr + 1; + -- -gnateH (set reverse Bit_Order threshold to 64) + + when 'H' => + Reverse_Bit_Order_Threshold := 64; + Ptr := Ptr + 1; + -- -gnatei (max number of instantiations) when 'i' => diff --git a/gcc/ada/targparm.adb b/gcc/ada/targparm.adb index 6e753ea..d470145 100644 --- a/gcc/ada/targparm.adb +++ b/gcc/ada/targparm.adb @@ -660,6 +660,14 @@ package body Targparm is Opt.Task_Dispatching_Policy_Sloc := System_Location; goto Line_Loop_Continue; + -- Allow "pragma Style_Checks (On);" and "pragma Style_Checks (Off);" + -- to make it possible to have long "pragma Restrictions" line. + + elsif Looking_At_Skip ("pragma Style_Checks (On);") or else + Looking_At_Skip ("pragma Style_Checks (Off);") + then + goto Line_Loop_Continue; + -- No other configuration pragmas are permitted elsif Looking_At ("pragma ") then diff --git a/gcc/ada/targparm.ads b/gcc/ada/targparm.ads index aa91ee6..2127252 100644 --- a/gcc/ada/targparm.ads +++ b/gcc/ada/targparm.ads @@ -110,6 +110,10 @@ package Targparm is -- If a pragma Profile with a valid profile argument appears, then -- the appropriate restrictions and policy flags are set. + -- pragma Style_Checks is allowed with "On" or "Off" as an argument, in + -- order to make the conditions on pragma Restrictions documented in the + -- next paragraph easier to manage. + -- The only other pragma allowed is a pragma Restrictions that specifies -- a restriction that will be imposed on all units in the partition. Note -- that in this context, only one restriction can be specified in a single @@ -213,22 +217,7 @@ package Targparm is -- Control of Exception Handling -- ----------------------------------- - -- GNAT implements three methods of implementing exceptions: - - -- Front-End Longjmp/Setjmp Exceptions - - -- This approach uses longjmp/setjmp to handle exceptions. It - -- uses less storage, and can often propagate exceptions faster, - -- at the expense of (sometimes considerable) overhead in setting - -- up an exception handler. - - -- The generation of the setjmp and longjmp calls is handled by - -- the front end of the compiler (this includes gigi in the case - -- of the standard GCC back end). It does not use any back end - -- support (such as the GCC3 exception handling mechanism). When - -- this approach is used, the compiler generates special exception - -- handlers for handling cleanups (AT-END actions) when an exception - -- is raised. + -- GNAT provides two methods of implementing exceptions: -- Back-End Zero Cost Exceptions @@ -254,10 +243,10 @@ package Targparm is -- Control of Available Methods and Defaults - -- The following switches specify whether we're using a front-end or a - -- back-end mechanism and whether this is a zero-cost or a sjlj scheme. + -- The following switch specifies whether this is a zero-cost or a sjlj + -- scheme. - -- The per-switch default values correspond to the default value of + -- The default value corresponds to the default value of -- Opt.Exception_Mechanism. ZCX_By_Default_On_Target : Boolean := False; @@ -408,7 +397,7 @@ package Targparm is -- Control of Stack Checking -- ------------------------------- - -- GNAT provides three methods of implementing exceptions: + -- GNAT provides three methods of implementing stack checking: -- GCC Probing Mechanism diff --git a/gcc/ada/tbuild.adb b/gcc/ada/tbuild.adb index 2a8fc36..a8b0437 100644 --- a/gcc/ada/tbuild.adb +++ b/gcc/ada/tbuild.adb @@ -525,6 +525,38 @@ package body Tbuild is return Make_String_Literal (Sloc, Strval => End_String); end Make_String_Literal; + ------------------------- + -- Make_Suppress_Block -- + ------------------------- + + -- Generates the following expansion: + + -- declare + -- pragma Suppress (<check>); + -- begin + -- <stmts> + -- end; + + function Make_Suppress_Block + (Loc : Source_Ptr; + Check : Name_Id; + Stmts : List_Id) return Node_Id + is + begin + return + Make_Block_Statement (Loc, + Declarations => New_List ( + Make_Pragma (Loc, + Chars => Name_Suppress, + Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Loc, + Expression => Make_Identifier (Loc, Check))))), + + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stmts)); + end Make_Suppress_Block; + -------------------- -- Make_Temporary -- -------------------- @@ -548,7 +580,7 @@ package body Tbuild is -- Generates the following expansion: -- declare - -- pragma Suppress (<check>); + -- pragma Unsuppress (<check>); -- begin -- <stmts> -- end; @@ -563,7 +595,7 @@ package body Tbuild is Make_Block_Statement (Loc, Declarations => New_List ( Make_Pragma (Loc, - Chars => Name_Suppress, + Chars => Name_Unsuppress, Pragma_Argument_Associations => New_List ( Make_Pragma_Argument_Association (Loc, Expression => Make_Identifier (Loc, Check))))), diff --git a/gcc/ada/tbuild.ads b/gcc/ada/tbuild.ads index 1b42fbd..bb2c70c 100644 --- a/gcc/ada/tbuild.ads +++ b/gcc/ada/tbuild.ads @@ -187,6 +187,13 @@ package Tbuild is -- A convenient form of Make_String_Literal, where the string value is -- given as a normal string instead of a String_Id value. + function Make_Suppress_Block + (Loc : Source_Ptr; + Check : Name_Id; + Stmts : List_Id) return Node_Id; + -- Build a block with a pragma Suppress on Check. Stmts is the statements + -- list that needs protection against the check activation. + function Make_Temporary (Loc : Source_Ptr; Id : Character; @@ -207,8 +214,8 @@ package Tbuild is (Loc : Source_Ptr; Check : Name_Id; Stmts : List_Id) return Node_Id; - -- Build a block with a pragma Suppress on 'Check'. Stmts is the statements - -- list that needs protection against the check + -- Build a block with a pragma Unsuppress on Check. Stmts is the statements + -- list that needs protection against the check suppression. function New_Constraint_Error (Loc : Source_Ptr) return Node_Id; -- This function builds a tree corresponding to the Ada statement diff --git a/gcc/ada/ttypes.ads b/gcc/ada/ttypes.ads index 953781d..28c6376 100644 --- a/gcc/ada/ttypes.ads +++ b/gcc/ada/ttypes.ads @@ -60,11 +60,10 @@ package Ttypes is -- Two approaches are used for handling target dependent values in the -- standard library packages. Package Standard is handled specially, -- being constructed internally (by package Stand). Target dependent - -- values needed in Stand are obtained by direct reference to Ttypes - -- and Ttypef. + -- values needed in Stand are obtained by direct reference to Ttypes. -- For package System, there is a separate version for each target, with - -- explicit declarations of the required, constants. + -- explicit declarations of the required constants. -- Historical note: Originally we had in mind dealing with target dependent -- differences by referencing appropriate attributes. Ada 95 already @@ -185,10 +184,6 @@ package Ttypes is Set_Targ.System_Allocator_Alignment; -- The alignment in storage units of addresses returned by malloc - Max_Unaligned_Field : constant Pos := Set_Targ.Max_Unaligned_Field; - -- The maximum supported size in bits for a field that is not aligned - -- on a storage unit boundary. - Bytes_Big_Endian : Boolean := Set_Targ.Bytes_BE /= 0; -- Important note: for Ada purposes, the important setting is the bytes -- endianness (Bytes_Big_Endian), not the bits value (Bits_Big_Endian). diff --git a/gcc/ada/uintp.adb b/gcc/ada/uintp.adb index 02dd4d9..f58353b 100644 --- a/gcc/ada/uintp.adb +++ b/gcc/ada/uintp.adb @@ -2027,7 +2027,7 @@ package body Uintp is begin Init_Operand (Left, L_Vec); Init_Operand (Right, R_Vec); - Neg := (L_Vec (1) < Int_0) xor (R_Vec (1) < Int_0); + Neg := L_Vec (1) < Int_0 xor R_Vec (1) < Int_0; L_Vec (1) := abs (L_Vec (1)); R_Vec (1) := abs (R_Vec (1)); diff --git a/gcc/ada/usage.adb b/gcc/ada/usage.adb index 4a2fa01..681ece5 100644 --- a/gcc/ada/usage.adb +++ b/gcc/ada/usage.adb @@ -199,6 +199,11 @@ begin Write_Switch_Char ("eG"); Write_Line ("Generate preprocessed source"); + -- Line for -gnateH switch + + Write_Switch_Char ("eH"); + Write_Line ("Set reverse Bit_Order threshold to 64"); + -- Line for -gnatei switch Write_Switch_Char ("einn"); @@ -580,6 +585,10 @@ begin Write_Line (" s suppress all info/warnings"); Write_Line (" .s turn on warnings for overridden size clause"); Write_Line (" .S* turn off warnings for overridden size clause"); + Write_Line (" _s+ turn on warnings for ineffective predicate " & + "tests"); + Write_Line (" _S* turn off warnings for ineffective predicate " & + "tests"); Write_Line (" t turn on warnings for tracking deleted code"); Write_Line (" T* turn off warnings for tracking deleted code"); Write_Line (" .t*+ turn on warnings for suspicious contract"); @@ -655,6 +664,7 @@ begin Write_Line (" c check comment format (two spaces)"); Write_Line (" C check comment format (one space)"); Write_Line (" d check no DOS line terminators"); + Write_Line (" D check declared identifiers in mixed case"); Write_Line (" e check end/exit labels present"); Write_Line (" f check no form feeds/vertical tabs in source"); Write_Line (" g check standard GNAT style rules, same as ydISux"); @@ -678,6 +688,8 @@ begin Write_Line (" u check no unnecessary blank lines"); Write_Line (" x check extra parentheses around conditionals"); Write_Line (" y turn on default style checks"); + Write_Line (" z check parentheses not required by operator " & + "precedence rules"); Write_Line (" - subtract (turn off) subsequent checks"); Write_Line (" + add (turn on) subsequent checks"); diff --git a/gcc/ada/vxworks7-cert-rtp-base-link.spec b/gcc/ada/vxworks7-cert-rtp-base-link.spec deleted file mode 100644 index 1d6ee49..0000000 --- a/gcc/ada/vxworks7-cert-rtp-base-link.spec +++ /dev/null @@ -1,2 +0,0 @@ -*base_link: ---defsym=__wrs_rtp_base=0x80000000 diff --git a/gcc/ada/vxworks7-cert-rtp-base-link__ppc64.spec b/gcc/ada/vxworks7-cert-rtp-base-link__ppc64.spec deleted file mode 100644 index 97332b8..0000000 --- a/gcc/ada/vxworks7-cert-rtp-base-link__ppc64.spec +++ /dev/null @@ -1,2 +0,0 @@ -*base_link: ---defsym=__wrs_rtp_base=0x40000000 diff --git a/gcc/ada/vxworks7-cert-rtp-base-link__x86.spec b/gcc/ada/vxworks7-cert-rtp-base-link__x86.spec deleted file mode 100644 index eafb582..0000000 --- a/gcc/ada/vxworks7-cert-rtp-base-link__x86.spec +++ /dev/null @@ -1,2 +0,0 @@ -*base_link: ---defsym=__wrs_rtp_base=0x400000 diff --git a/gcc/ada/vxworks7-cert-rtp-base-link__x86_64.spec b/gcc/ada/vxworks7-cert-rtp-base-link__x86_64.spec deleted file mode 100644 index dd28869..0000000 --- a/gcc/ada/vxworks7-cert-rtp-base-link__x86_64.spec +++ /dev/null @@ -1,2 +0,0 @@ -*base_link: ---defsym=__wrs_rtp_base=0x200000 diff --git a/gcc/ada/vxworks7-cert-rtp-link.spec b/gcc/ada/vxworks7-cert-rtp-link.spec deleted file mode 100644 index 9923c58..0000000 --- a/gcc/ada/vxworks7-cert-rtp-link.spec +++ /dev/null @@ -1,10 +0,0 @@ -*self_spec: -+ %{!nostdlib:-nodefaultlibs -nostartfiles} - -*link: -+ %{!nostdlib:%{mrtp:%{!shared: \ - %(base_link) \ - -l:certRtp.o \ - -L%:getenv(VSB_DIR /usr/lib/common/objcert) \ - -T%:getenv(VSB_DIR /usr/ldscripts/rtp.ld) \ - }}} diff --git a/gcc/ada/vxworks7-cert-rtp-link__ppcXX.spec b/gcc/ada/vxworks7-cert-rtp-link__ppcXX.spec deleted file mode 100644 index 8671cea..0000000 --- a/gcc/ada/vxworks7-cert-rtp-link__ppcXX.spec +++ /dev/null @@ -1,10 +0,0 @@ -*self_spec: -+ %{!nostdlib:-nodefaultlibs -nostartfiles} - -*link: -+ %{!nostdlib:%{mrtp:%{!shared: \ - %(base_link) \ - -lcert -lgnu \ - -L%:getenv(VSB_DIR /usr/lib/common/objcert) \ - -T%:getenv(VSB_DIR /usr/ldscripts/rtp.ld) \ - }}} diff --git a/gcc/ada/warnsw.adb b/gcc/ada/warnsw.adb index d157488..1931e02 100644 --- a/gcc/ada/warnsw.adb +++ b/gcc/ada/warnsw.adb @@ -93,14 +93,15 @@ package body Warnsw is '_' => ('b' | 'd' | 'e' | 'f' | 'g' | 'h' | 'i' | 'j' | 'k' | 'l' | 'm' | - 'n' | 'o' | 's' | 't' | 'u' | 'v' | 'w' | 'x' | 'y' | 'z' => + 'n' | 'o' | 't' | 'u' | 'v' | 'w' | 'x' | 'y' | 'z' => No_Such_Warning, 'a' => X.Warn_On_Anonymous_Allocators, 'c' => X.Warn_On_Unknown_Compile_Time_Warning, 'p' => X.Warn_On_Pedantic_Checks, 'q' => X.Warn_On_Ignored_Equality, - 'r' => X.Warn_On_Component_Order)); + 'r' => X.Warn_On_Component_Order, + 's' => X.Warn_On_Ineffective_Predicate_Test)); All_Warnings : constant Warnings_State := -- Warnings set by -gnatw.e (X.Elab_Info_Messages | @@ -130,6 +131,7 @@ package body Warnsw is X.Warn_On_Biased_Representation | -- -gnatw.b X.Warn_On_Constant | -- -gnatwk X.Warn_On_Export_Import | -- -gnatwx + X.Warn_On_Ineffective_Predicate_Test | -- -gnatw_s X.Warn_On_Late_Primitives | -- -gnatw.j X.Warn_On_Modified_Unread | -- -gnatwm X.Warn_On_No_Value_Assigned | -- -gnatwv diff --git a/gcc/ada/warnsw.ads b/gcc/ada/warnsw.ads index 2636aba..cee1f30 100644 --- a/gcc/ada/warnsw.ads +++ b/gcc/ada/warnsw.ads @@ -71,6 +71,7 @@ package Warnsw is Warn_On_Export_Import, Warn_On_Hiding, Warn_On_Ignored_Equality, + Warn_On_Ineffective_Predicate_Test, Warn_On_Late_Primitives, Warn_On_Modified_Unread, Warn_On_No_Value_Assigned, @@ -155,6 +156,7 @@ package Warnsw is Warn_On_Elab_Access | Warn_On_Hiding | Warn_On_Ignored_Equality | + Warn_On_Ineffective_Predicate_Test | Warn_On_Late_Primitives | Warn_On_Modified_Unread | Warn_On_Non_Local_Exception | @@ -215,7 +217,7 @@ package Warnsw is -- of the old ABE mechanism. Implementation_Unit_Warnings : Boolean renames F (X.Implementation_Unit_Warnings); - -- Set True to active warnings for use of implementation internal units. + -- Set True to activate warnings for use of implementation internal units. -- Modified by use of -gnatwi/-gnatwI. Ineffective_Inline_Warnings : Boolean renames F (X.Ineffective_Inline_Warnings); @@ -333,6 +335,11 @@ package Warnsw is -- whose type has the user-defined "=" as primitive). Off by default, and -- set by -gnatw_q (but not -gnatwa). + Warn_On_Ineffective_Predicate_Test : Boolean renames F (X.Warn_On_Ineffective_Predicate_Test); + -- Set to True to generate warnings if a static predicate is testing for + -- values that do not belong to the parent subtype. Modified by use of + -- -gnatw_s/S. + Warn_On_Late_Primitives : Boolean renames F (X.Warn_On_Late_Primitives); -- Warn when tagged type public primitives are defined after its private -- extensions. |