diff options
Diffstat (limited to 'gcc/ada')
82 files changed, 3320 insertions, 1819 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index f45c81a..f51e899 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,602 @@ +2025-06-12 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/decl.cc (gnat_to_gnu_entity) <E_Variable>: Generate + a zero-initialization for the anonymous object of a small aggregate + allocated on the stack. + (inline_status_for_subprog): Minor tweak. + +2025-06-12 Tonu Naks <naks@adacore.com> + + * comperr.adb: update support instructions + * switch.adb: update support instructions + +2025-06-12 Ronan Desplanques <desplanques@adacore.com> + + * sinfo.ads: Fix RM reference. + +2025-06-12 Piotr Trojanek <trojanek@adacore.com> + + * sem_ch3.adb (Apply_External_Initialization): Reuse local constant. + +2025-06-12 Eric Botcazou <ebotcazou@adacore.com> + + * doc/gnat_rm/gnat_language_extensions.rst + (Generalized Finalization): Document the actual implementation. + (No_Raise): Move to separate section. + * gnat_rm.texi: Regenerate. + +2025-06-12 Ronan Desplanques <desplanques@adacore.com> + + * libgnat/s-valuer.adb (Scan_Raw_Real): Apply tweak. + +2025-06-12 Tonu Naks <naks@adacore.com> + + * comperr.adb: replace report@ with support@ + * gnatcmd.adb: replace report@ with support@ + +2025-06-12 Ronan Desplanques <desplanques@adacore.com> + + * sem_ch3.adb (Build_Derived_Private_Type): Fix test. + (Build_Derived_Record_Type): Adjust error recovery paths. + +2025-06-12 Eric Botcazou <ebotcazou@adacore.com> + + * einfo.ads (Has_Homonym): Fix inaccuracy in description. + * sem_ch8.ads (Find_Direct_Name): Remove obsolete description. + * sem_ch12.adb (Analyze_Associations): Rename I_Node parameter + into N and adjust description. + (Analyze_Subprogram_Instantiation): Add missing description. + (Contains_Instance_Of): Fix description. + (Associations): Rename Generic_Actual_Rec into Actual_Rec and + Gen_Assocs_Rec into Match_Rec. + (Analyze_One_Association): Rename I_Node parameter into N. + (Check_Fixed_Point_Warning): Rename Gen_Assocs parameter into + Match. + (Body of Associations): Minor cleanups and tweaks. + (Analyze_Associations): Rename I_Node parameter into N and + adjust implementation. + (Analyze_One_Association): Likewise. + (Analyze_Package_Instantiation): Remove obsolete code and clean up. + (Check_Fixed_Point_Warning): Rename Gen_Assocs parameter into + Match and adjust implementation. + (Freeze_Package_Instance): Simplify condition. + (Get_Unit_Instantiation_Node): Add support for instantiations of + subprograms and stop the loop properly in case of errors. + * sem_util.ads (Add_Global_Declaration): Rename N parameter into + Decl and fix description. + * sem_util.adb (Add_Global_Declaration): Rename N parameter into + Decl and adjust implementation. + +2025-06-12 Ronan Desplanques <desplanques@adacore.com> + + * libgnat/s-valuer.adb (Scan_Raw_Real): Add RM reference. + +2025-06-12 Ronan Desplanques <desplanques@adacore.com> + + * libgnat/s-valuer.adb (Scan_Raw_Real): Remove subexpression. Improve + surrounding comments. + +2025-06-12 Bob Duff <duff@adacore.com> + + * vast.adb: Check basic tree properties. + * atree.adb (Traverse_Field): Minor. + * treepr.adb (Destroy): Minor comment. + +2025-06-12 Eric Botcazou <ebotcazou@adacore.com> + + * libgnat/s-valuer.adb (Round_Extra): Use multiplicative test. + +2025-06-12 Ronan Desplanques <desplanques@adacore.com> + + * einfo-utils.adb (Set_Convention): Remove obsolete test. + +2025-06-12 Ronan Desplanques <desplanques@adacore.com> + + * sem_ch3.adb (Process_Discriminants): Set Ekind earlier. + * sem_util.adb (Enter_Name): Adjust error processing. + +2025-06-12 Eric Botcazou <ebotcazou@adacore.com> + + * libgnat/s-valuef.adb (Integer_To_Fixed): Enable overflow checks. + Deal specifically with Val = 2**(Int'Size - 1) if Minus is not set. + Exit the loop when V saturates to 0 in the case of (huge) negative + exponents. + +2025-06-12 Ronan Desplanques <desplanques@adacore.com> + + * exp_util.adb (Insert_Actions): Refine test. + +2025-06-12 Eric Botcazou <ebotcazou@adacore.com> + + * doc/gnat_ugn/building_executable_programs_with_gnat.rst (Compiler + switches) <-O>: Fix long line. + * gnat_ugn.texi: Regenerate. + +2025-06-12 Eric Botcazou <ebotcazou@adacore.com> + + * doc/gnat_ugn/building_executable_programs_with_gnat.rst (List of + all switches): Add -gnatRh subswitch. + (Debugging Control): Document -gnatRh subswitch. + * opt.ads (List_Representation_Info_Holes): New boolean variable. + * repinfo.adb: Add with clause for GNAT.Heap_Sort_G. + (List_Common_Type_Info): Relax assertion. + (List_Object_Info): Replace assertion with additional test. + (List_Record_Layout): If -gnatRh is specified, make sure that the + components are ordered by increasing offsets. Output a comment + line giving the number of unused bits if there is a hole between + consecutive components. Streamline the control flow of the loop. + (List_Record_Info): Use the original record type giving the layout + of components, if any, to display the layout of the record. + * switch-c.adb (Scan_Front_End_Switches) <-gnatR>: Add support for + -gnatRh subswitch. + * usage.adb (Usage): Document -gnatRh subswitch. + * gnat_ugn.texi: Regenerate. + +2025-06-12 Johannes Kliemann <kliemann@adacore.com> + + * libgnat/s-secsta.adb (SS_Allocate): Add comment about + conservative alignment padding calculation. + * libgnat/s-secsta__cheri.adb (SS_Allocate): Add comment about + conservative alignment padding calculation. + +2025-06-12 Ronan Desplanques <desplanques@adacore.com> + + * sem_warn.adb (Check_References): Rewrite expression + +2025-06-12 Ronan Desplanques <desplanques@adacore.com> + + * sem_ch3.adb (Constrain_Index, Make_Index, Array_Type_Declaration, + Analyze_Number_Declaration): Remove uses of E_Void. + +2025-06-12 Eric Botcazou <ebotcazou@adacore.com> + + * usage.adb (Usage): Justify the documentation of common switches + like that of other switches. Rework that of the -O switch. + * doc/gnat_ugn/building_executable_programs_with_gnat.rst (Compiler + switches) <-O>: Rework and document 'z' and 'g' operands. + * doc/gnat_ugn/gnat_and_program_execution.rst (Optimization Levels): + Rework and document -Oz and -Og switches. + * gnat_ugn.texi: Regenerate. + +2025-06-12 Ronan Desplanques <desplanques@adacore.com> + + * sem_ch3.adb (Constrain_Index): Avoid unused itypes. + +2025-06-12 Ronan Desplanques <desplanques@adacore.com> + + * sem_ch3.adb (Constrain_Index): Factorize return statement. + +2025-06-12 Ronan Desplanques <desplanques@adacore.com> + + * sem_ch3.adb (Build_Derived_Numeric_Type): Remove duplicate call. + +2025-06-10 Piotr Trojanek <trojanek@adacore.com> + + * gen_il-gen-gen_entities.adb (Formal_Object_Kind): Remove + Entry_Component field. + +2025-06-10 Piotr Trojanek <trojanek@adacore.com> + + * sem_attr.adb (Resolve_Attribute): Remove redundant guard. + +2025-06-10 Eric Botcazou <ebotcazou@adacore.com> + + * inline.adb (Analyze_Inlined_Bodies): Minor comment tweak. + +2025-06-10 Eric Botcazou <ebotcazou@adacore.com> + + * inline.adb (Instantiate_Body): Do not call Add_Scope_To_Clean if + the main unit is generic. + (Instantiate_Bodies): Do not deal with generic main units here. + * sem_ch12.adb (Need_Subprogram_Instance_Body): Return false if the + main unit is generic. + +2025-06-10 Eric Botcazou <ebotcazou@adacore.com> + + * Makefile.rtl (ADA_EXCLUDE_SRCS): Add the 128-bit support files. + +2025-06-10 Ronan Desplanques <desplanques@adacore.com> + + * sem_ch3.adb (Process_Subtype): Factorize code. + +2025-06-10 Bob Duff <duff@adacore.com> + + * einfo.ads (Associated_Node_For_Itype): Document that + Parent field may be empty. + * vast.adb: Allow empty Parent in Itypes. + +2025-06-10 Gary Dismukes <dismukes@adacore.com> + + * einfo.ads: Revise comment about Dynamic_Predicate flag to make it + more accurate. + * sem_case.adb (Check_Choices): Test "not Has_Static_Predicate_Aspect" + as additional guard for error about use of subtype with nonstatic + predicate as a case choice. Improve related error message. + +2025-06-10 Tonu Naks <naks@adacore.com> + + * libgnat/s-valueu.adb: add explict raise + * libgnat/s-valueu.ads: update annotation + +2025-06-10 Ronan Desplanques <desplanques@adacore.com> + + * sem_ch6.adb, sem_ch6.ads (Check_Discriminant_Conformance): Move to … + * sem_ch3.adb (Check_Discriminant_Conformance): … here. + +2025-06-10 Eric Botcazou <ebotcazou@adacore.com> + + * freeze.adb (Freeze_Static_Object): Do not issue any error message + for compiler-generated entities. + +2025-06-10 Bob Duff <duff@adacore.com> + + * vast.adb: Implement two checks. Improve debugging + outputs. + +2025-06-10 Eric Botcazou <ebotcazou@adacore.com> + + * exp_ch4.adb (Insert_Conditional_Object_Declaration): Deal with a + transient scope being created around the declaration. + * freeze.adb (Freeze_Entity): Do not call Freeze_Static_Object for + a renaming declaration. + +2025-06-10 Eric Botcazou <ebotcazou@adacore.com> + + * libgnat/s-vafi32.ads: Fix head description. + * libgnat/s-vafi64.ads: Likewise. + * libgnat/s-vafi128.ads: Likewise. + +2025-06-10 Bob Duff <duff@adacore.com> + + * vast.adb: Initial implementation. + * vast.ads: Rename procedure. Remove parameter; body should decide + what to do. + * lib.ads (ipu): Minor: Rewrite comment for brevity, and because + of an inconvenient misspelling. + (Num_Units): Not used; remove. + (Remove_Unit): Minor: Remove "Currently" (which was current a decade + ago from) comment. + * lib.adb (Num_Units): Not used; remove. + * debug_a.adb (Debug_A_Entry): Fix bug: Use Write_Name_For_Debug, + so this won't crash on the Error node. + * debug.adb: Document -gnatd_V and -gnatd_W compiler switches. + * exp_ch6.adb (Validate_Subprogram_Calls): Remove redundant check for + Serious_Errors_Detected. (We turn off code gen when errors are + detected.) + * frontend.adb: Move decisions into VAST body. + * namet.ads (Present): Remove unnecessary overriding; these are + inherited by the derived types. + * namet.adb (Present): Likewise. + +2025-06-10 Gary Dismukes <dismukes@adacore.com> + + * exp_aggr.adb (Build_Container_Aggr_Code.To_Int): Apply Enumeration_Pos + to Entity (Expr) rather than Expr. + +2025-06-10 Ronan Desplanques <desplanques@adacore.com> + + * sem_ch3.adb (Find_Type_Of_Object): Fix comment. + +2025-06-10 Ronan Desplanques <desplanques@adacore.com> + + * sem_ch3.adb (Analyze_Component_Declaration): Rename constant. + +2025-06-10 Ronan Desplanques <desplanques@adacore.com> + + * sem_ch3.adb (Constrain_Array): Simplify. + (Process_Subtype): Adjust. + +2025-06-10 Eric Botcazou <ebotcazou@adacore.com> + + * sem_ch12.adb (Copy_Generic_Node): Do not call Root_Type to find + the root type of an aggregate of a derived tagged type. + +2025-06-10 Ronan Desplanques <desplanques@adacore.com> + + * libgnarl/s-stusta.adb (Compute_All_Tasks): Skip terminated tasks. + +2025-06-10 Viljar Indus <indus@adacore.com> + + * sem_prag.adb (Is_Configuration_Pragma): Check that nodes + preceding the pragma are pragma nodes or originally were + pragma nodes. + +2025-06-10 Eric Botcazou <ebotcazou@adacore.com> + + * libgnat/s-valued.adb (Integer_to_Decimal): Add Extra parameter and + use its value to call Bad_Value on boundary values. + (Scan_Decimal): Adjust call to Integer_to_Decimal. + (Value_Decimal): Likewise. + +2025-06-10 Ronan Desplanques <desplanques@adacore.com> + + * sem_ch3.ads (Process_Subtype): New formal. + * sem_ch3.adb (Process_Subtype): Likewise. + (Analyze_Subtype_Declaration, Access_Type_Declaration): Use new + formal. + +2025-06-10 Ronan Desplanques <desplanques@adacore.com> + + * sem_ch3.adb (Process_Subtype): Fix recursive call. + +2025-06-10 Eric Botcazou <ebotcazou@adacore.com> + + * par-ch5.adb (P_Declare_Statement): Rename local variable. + (P_Begin_Statement): Likewise. + +2025-06-10 Piotr Trojanek <trojanek@adacore.com> + + * einfo.ads (Overridden_Operation, Static_Initialization): Remove + comments about a reused entity field. + +2025-06-10 Ronan Desplanques <desplanques@adacore.com> + + * sem_ch3.adb (Process_Subtype): Tweak formatting. + +2025-06-10 Ronan Desplanques <desplanques@adacore.com> + + * sem_ch3.adb (Process_Subtype): Add assertion. + +2025-06-10 Ronan Desplanques <desplanques@adacore.com> + + * sem_ch3.adb (Process_Subtype): Factorize initialization of variable. + +2025-06-09 Gary Dismukes <dismukes@adacore.com> + + * sem_ch3.adb (Constrain_Index): In the case of a fixed-lower-bound index, + set Etype of the newly created itype's Scalar_Range from the index's Etype. + * sem_ch12.adb (Validate_Array_Type_Instance): If the actual subtype is + a fixed-lower-bound type, then check again the Etype of its Scalar_Range. + +2025-06-09 Piotr Trojanek <trojanek@adacore.com> + + * sem_prag.adb (Analyze_Pragma): Fix conditions for legality checks on + formal type declarations. + +2025-06-09 Piotr Trojanek <trojanek@adacore.com> + + * sem_prag.adb (Analyze_Pragma): If pragmas apply to a formal array + type, then set the flags on the base type. + +2025-06-09 Ronan Desplanques <desplanques@adacore.com> + + * sem_ch3.adb (Process_Subtype): Clarify code. + +2025-06-09 Ronan Desplanques <desplanques@adacore.com> + + * sem_ch3.ads (Process_Subtype): Add formal. + * sem_ch3.adb (Process_Subtype): Use new formal. + (Analyze_Subtype_Declaration, Array_Type_Declaration, + Build_Derived_Access_Type): Pass new actual. + * sem_ch4.adb (Find_Type_Of_Object): Likewise. + +2025-06-09 Ronan Desplanques <desplanques@adacore.com> + + * sem_ch6.adb (Set_Formal_Mode): Extend profile. Move parts of the + body… + (Process_Formals): … here. Move call to Set_Formal_Mode earlier. Call + Set_Is_Not_Self_Hidden in second traversal. + +2025-06-09 Gary Dismukes <dismukes@adacore.com> + + * exp_aggr.adb (Expand_Container_Aggregate): Use the Base_Type of the + subtype provided by the context as the subtype of the temporary object + initialized by the aggregate. + +2025-06-09 Eric Botcazou <ebotcazou@adacore.com> + + * par-ch4.adb (P_Function_Name): Delete body. + (P_Qualified_Simple_Name_Resync): Do not raise Error_Resync on an + operator symbol followed by something else than a dot. + * par-ch6.adb (P_Subprogram): Do not call P_Function_Name. + * par.adb (P_Function_Name): Delete declaration. + +2025-06-09 Ronan Desplanques <desplanques@adacore.com> + + * sem.adb (Analyze): Adapt to new Ekinds. + * sem_ch3.adb (Analyze_Component_Declaration): Set Ekind early. + (Is_Visible_Component, Record_Type_Definition): Adjust. + +2025-06-09 Ronan Desplanques <desplanques@adacore.com> + + * sem.adb (Analyze): Fix comment. + +2025-06-09 Eric Botcazou <ebotcazou@adacore.com> + + * par-ch4.adb (P_Name): Remove obsolete references in comments. + (P_Qualified_Simple_Name): Call P_Qualified_Simple_Name_Resync. + (P_Qualified_Simple_Name_Resync): Adjust a couple of comments. + +2025-06-09 Gary Dismukes <dismukes@adacore.com> + + * exp_util.adb (Call_To_Parent_Dispatching_Op_Must_Be_Mapped): Replace + test of Covers with test of Is_Controlling_Formal. Add handling for + 'Result actuals. Remove Actual_Type and its uses. + +2025-06-09 Piotr Trojanek <trojanek@adacore.com> + + * sem_util.adb (Is_Name_Reference): Remove check for selector_name of a + selected_component; reuse existing code for indexed components and + slices. + (Statically_Names_Object): Remove dead code. + +2025-06-09 Eric Botcazou <ebotcazou@adacore.com> + + * einfo.ads (Overlays_Constant): Define in constants and variables. + * gen_il-gen-gen_entities.adb (Entity_Kind): Move Overlays_Constant + semantic flag to... + (Constant_Or_Variable_Kind): ...here. + * sem_util.adb (Note_Possible_Modification): Add guard. + +2025-06-09 Bob Duff <duff@adacore.com> + + * exp_ch6.adb: (Make_Build_In_Place_Call_In_Object_Declaration): + Deal with renamings transformed into object declarations. + * sem_ch8.adb (Analyze_Object_Renaming): + Reinstate transformation of a renaming into + an object declaration. + +2025-06-09 Ronan Desplanques <desplanques@adacore.com> + + * sem_ch3.adb (Analyze_Object_Declaration): Call Mutate_Ekind earlier. + +2025-06-09 Ronan Desplanques <desplanques@adacore.com> + + * sem_ch3.adb (Analyze_Object_Declaration): Tweak error handling. + +2025-06-09 Piotr Trojanek <trojanek@adacore.com> + + * par-ch13.adb (Get_Aspect_Specifications): Save and restore flag while + parsing aspect Abstract_State. + * par-ch2.adb (P_Pragma): Same while parsing pragma Abstract_State. + * par-ch4.adb (P_Aggregate_Or_Paren_Expr): Specialize error message + for contract Abstract_State and extended aggregate. + * par.adb (Inside_Abstract_State): Add new context flag. + +2025-06-09 Ronan Desplanques <desplanques@adacore.com> + + * sem_ch10.adb (Analyze_Compilation_Unit): Check for generic bodies. + * exp_disp.adb (Build_Dispatch_Tables): Likewise. + +2025-06-09 Piotr Trojanek <trojanek@adacore.com> + + * sem_util.adb (Find_Overlaid_Entity): Don't call Etype on empty Ent; + tune style; move computation of Overl_Typ out of the loop. + +2025-06-09 Javier Miranda <miranda@adacore.com> + + * doc/gnat_rm/implementation_defined_pragmas.rst: Adding + documentation. + * doc/gnat_ugn/the_gnat_compilation_model.rst: ditto. + * gnat_rm.texi: Regenerate. + * gnat_ugn.texi: Regenerate. + +2025-06-09 Ronan Desplanques <desplanques@adacore.com> + + * sem_attr.adb (Analyze_Attribute): Remove test. + +2025-06-09 Ronan Desplanques <desplanques@adacore.com> + + * sem_util.adb (Enter_Name): Remove special handling. + +2025-06-09 Ronan Desplanques <desplanques@adacore.com> + + * sem_util.adb (Enter_Name): Remove comment. + +2025-06-09 Bob Duff <duff@adacore.com> + + * exp_ch6.adb: Remove a couple of "???" suggesting something that + we will likely never do. + (Make_Build_In_Place_Call_In_Object_Declaration): + When a constraint check is needed, do the check. + Do it at the call site for now. + The check is still missing in the untagged case, + because the caller allocates in that case. + * sem_ch8.adb (Analyze_Object_Renaming): + Remove obsolete transformation of a renaming into + an object declaration. Given that we also (sometimes) tranform + object declarations into renamings, this transformation was + adding complexity; the new code in + Make_Build_In_Place_Call_In_Object_Declaration above + would need to explicitly avoid the run-time check in the case of + renamings, because renamings are supposed to ignore the nominal + subtype. Anyway, it is no longer needed. + * exp_ch3.adb (Expand_N_Object_Declaration): Rewrite comment; + it IS clear how to do it, but we haven't done it right yet. + +2025-06-09 Ronan Desplanques <desplanques@adacore.com> + + * atree.ads (Copy_Node): Fix comment. + +2025-06-09 Piotr Trojanek <trojanek@adacore.com> + + * exp_attr.adb (Expand_N_Attribute_Reference): When expanding attribute + Valid, use signedness from the validated view, not from its base type. + +2025-06-09 Marc Poulhiès <poulhies@adacore.com> + + * sem_util.adb (Find_Overlaid_Entity): Add extra parameter to + extract the type being overlaid. + (Note_Possible_Modification): Adjust call to Find_Overlaid_Entity. + (Ultimate_Overlaid_Entity): Likewise. + * sem_ch13.adb (Analyze_Attribute_Definition_Clause): Likewise. + * sem_util.ads (Find_Overlaid_Entity): Add extra parameter to + extract the type being overlaid. + * freeze.adb (Check_Address_Clause): Likewise. + +2025-06-09 Gary Dismukes <dismukes@adacore.com> + + * contracts.adb (Inherit_Condition): Remove Assoc_List and its uses + along with function Check_Condition, since mapping of formals will + effectively be done in Build_Class_Wide_Expression (by Replace_Entity). + * exp_util.adb (Replace_Entity): Only rewrite entity references in + function calls that qualify according to the result of calling the + new function Call_To_Parent_Dispatching_Op_Must_Be_Mapped. + (Call_To_Parent_Dispatching_Op_Must_Be_Mapped): New function that + determines whether a function call to a primitive of Par_Subp + associated tagged type needs to be mapped (according to whether + it has any actuals that reference controlling formals of the + primitive). + +2025-06-09 Ronan Desplanques <desplanques@adacore.com> + + * sem_ch3.adb (Analyze_Object_Declaration): Remove comment. + +2025-06-09 Ronan Desplanques <desplanques@adacore.com> + + * sem_util.ads (Current_Entity_In_Scope): Add example in comment. + +2025-06-09 Ronan Desplanques <desplanques@adacore.com> + + * atree.ads (Rewrite, Replace): Clarify comments. + +2025-06-09 Ronan Desplanques <desplanques@adacore.com> + + * atree.ads (Rewrite): Remove comment. + +2025-06-09 Ronan Desplanques <desplanques@adacore.com> + + * atree.adb (Rewrite): Improve readability. + +2025-06-09 Ronan Desplanques <desplanques@adacore.com> + + * sem_util.adb (Kill_Current_Values): Tweak condition. + +2025-06-09 Eric Botcazou <ebotcazou@adacore.com> + + * exp_ch4.adb (Insert_Conditional_Object_Declaration): Remove Decl + formal parameter, add Typ and Const formal parameters. + (Expand_N_Case_Expression): Fix pasto in comment. Adjust call to + Insert_Conditional_Object_Declaration and tidy up surrounding code. + (Expand_N_If_Expression): Adjust couple of calls to + Insert_Conditional_Object_Declaration. + +2025-06-09 Ronan Desplanques <desplanques@adacore.com> + + * sem_ch8.adb (Find_Selected_Component): Fix error path. + +2025-06-09 Eric Botcazou <ebotcazou@adacore.com> + + * libgnat/s-dourea.adb (Is_Infinity): Rename to... + (Is_Infinity_Or_NaN): ...this. + ("*"): Adjust accordingly. + ("/"): Likewise. + (Sqr): Likewise. + * libgnat/s-dorepr.adb (Two_Prod): Likewise. + (Two_Sqr): Likewise. + * libgnat/s-dorepr__fma.adb (Two_Prod): Likewise. + +2025-06-09 Daniel King <dmking@adacore.com> + + * libgnat/i-cheri.ads + (Set_Bounds, Set_Exact_Bounds): Remove wrong intrinsic binding. + * libgnat/i-cheri.adb + (Set_Bounds, Set_Exact_Bounds): New subprogram bodies. + +2025-06-09 Ronan Desplanques <desplanques@adacore.com> + + * sem_ch8.adb (Find_Selected_Component): Add mention. + 2025-06-06 Piotr Trojanek <trojanek@adacore.com> * urealp.adb (UR_Negate): Capture array element in a local constant. diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl index bd36c31..c2a4e1f 100644 --- a/gcc/ada/Makefile.rtl +++ b/gcc/ada/Makefile.rtl @@ -3242,8 +3242,92 @@ ADA_EXCLUDE_SRCS =\ i-vxwoio.adb i-vxwoio.ads i-vxwork.ads \ s-linux.ads s-vxwext.adb s-vxwext.ads s-win32.ads s-winext.ads \ s-stchop.ads s-stchop.adb \ - s-strcom.adb s-strcom.ads s-thread.ads \ + s-strcom.ads s-strcom.adb \ + s-thread.ads \ s-qnx.ads \ + s-arit128.ads s-arit128.adb \ + s-casi128.ads s-casi128.adb \ + s-caun128.ads s-caun128.adb \ + s-exnllli.ads \ + s-expllli.ads \ + s-explllu.ads \ + s-fode128.ads \ + s-fofi128.ads \ + s-imde128.ads \ + s-imfi128.ads \ + s-imglllb.ads \ + s-imgllli.ads \ + s-imglllu.ads \ + s-imglllw.ads \ + s-pack65.ads s-pack65.adb \ + s-pack66.ads s-pack66.adb \ + s-pack67.ads s-pack67.adb \ + s-pack68.ads s-pack68.adb \ + s-pack69.ads s-pack69.adb \ + s-pack70.ads s-pack70.adb \ + s-pack71.ads s-pack71.adb \ + s-pack72.ads s-pack72.adb \ + s-pack73.ads s-pack73.adb \ + s-pack74.ads s-pack74.adb \ + s-pack75.ads s-pack75.adb \ + s-pack76.ads s-pack76.adb \ + s-pack77.ads s-pack77.adb \ + s-pack78.ads s-pack78.adb \ + s-pack79.ads s-pack79.adb \ + s-pack80.ads s-pack80.adb \ + s-pack81.ads s-pack81.adb \ + s-pack82.ads s-pack82.adb \ + s-pack83.ads s-pack83.adb \ + s-pack84.ads s-pack84.adb \ + s-pack85.ads s-pack85.adb \ + s-pack86.ads s-pack86.adb \ + s-pack87.ads s-pack87.adb \ + s-pack88.ads s-pack88.adb \ + s-pack89.ads s-pack89.adb \ + s-pack90.ads s-pack90.adb \ + s-pack91.ads s-pack91.adb \ + s-pack92.ads s-pack92.adb \ + s-pack93.ads s-pack93.adb \ + s-pack94.ads s-pack94.adb \ + s-pack95.ads s-pack95.adb \ + s-pack96.ads s-pack96.adb \ + s-pack97.ads s-pack97.adb \ + s-pack98.ads s-pack98.adb \ + s-pack99.ads s-pack99.adb \ + s-pack100.ads s-pack100.adb \ + s-pack101.ads s-pack101.adb \ + s-pack102.ads s-pack102.adb \ + s-pack103.ads s-pack103.adb \ + s-pack104.ads s-pack104.adb \ + s-pack105.ads s-pack105.adb \ + s-pack106.ads s-pack106.adb \ + s-pack107.ads s-pack107.adb \ + s-pack108.ads s-pack108.adb \ + s-pack109.ads s-pack109.adb \ + s-pack110.ads s-pack110.adb \ + s-pack111.ads s-pack111.adb \ + s-pack112.ads s-pack112.adb \ + s-pack113.ads s-pack113.adb \ + s-pack114.ads s-pack114.adb \ + s-pack115.ads s-pack115.adb \ + s-pack116.ads s-pack116.adb \ + s-pack117.ads s-pack117.adb \ + s-pack118.ads s-pack118.adb \ + s-pack119.ads s-pack119.adb \ + s-pack120.ads s-pack120.adb \ + s-pack121.ads s-pack121.adb \ + s-pack122.ads s-pack122.adb \ + s-pack123.ads s-pack123.adb \ + s-pack124.ads s-pack124.adb \ + s-pack125.ads s-pack125.adb \ + s-pack126.ads s-pack126.adb \ + s-pack127.ads s-pack127.adb \ + s-vade128.ads \ + s-vafi128.ads \ + s-valllli.ads \ + s-vallllu.ads \ + s-widllli.ads \ + s-widlllu.ads # ADA_EXCLUDE_SRCS without the sources used by the target ADA_EXCLUDE_FILES=$(filter-out \ diff --git a/gcc/ada/atree.adb b/gcc/ada/atree.adb index 8a69a0c..17538de 100644 --- a/gcc/ada/atree.adb +++ b/gcc/ada/atree.adb @@ -2271,10 +2271,10 @@ package body Atree is -- Copy substitute node into place, preserving old fields as required Copy_Node (Source => New_Node, Destination => Old_Node); - Set_Error_Posted (Old_Node, Old_Error_Posted); Set_Check_Actuals (Old_Node, Old_CA); Set_Is_Ignored_Ghost_Node (Old_Node, Old_Is_IGN); + Set_Error_Posted (Old_Node, Old_Error_Posted); if Nkind (New_Node) in N_Subexpr then Set_Paren_Count (Old_Node, Old_Paren_Count); @@ -2702,9 +2702,9 @@ package body Atree is -- tail recursive step won't go past the end. declare - Cur_Field : Offset_Array_Index := Traversed_Offset_Array'First; Offsets : Traversed_Offset_Array renames Traversed_Fields (Nkind (Cur_Node)); + Cur_Field : Offset_Array_Index := Traversed_Offset_Array'First; begin if Offsets (Traversed_Offset_Array'First) /= No_Field_Offset then diff --git a/gcc/ada/atree.ads b/gcc/ada/atree.ads index c8cc2bc..615d040 100644 --- a/gcc/ada/atree.ads +++ b/gcc/ada/atree.ads @@ -285,15 +285,11 @@ package Atree is procedure Copy_Node (Source, Destination : Node_Or_Entity_Id); -- Copy the entire contents of the source node to the destination node. - -- The contents of the source node is not affected. If the source node - -- has an extension, then the destination must have an extension also. - -- The parent pointer of the destination and its list link, if any, are - -- not affected by the copy. Note that parent pointers of descendants - -- are not adjusted, so the descendants of the destination node after - -- the Copy_Node is completed have dubious parent pointers. Note that - -- this routine does NOT copy aspect specifications, the Has_Aspects - -- flag in the returned node will always be False. The caller must deal - -- with copying aspect specifications where this is required. + -- The contents of the source node is not affected. The parent pointer of + -- the destination and its list link, if any, are not affected by the copy. + -- Note that parent pointers of descendants are not adjusted, so the + -- descendants of the destination node after the Copy_Node is completed + -- have dubious parent pointers. function New_Copy (Source : Node_Id) return Node_Id; -- This function allocates a new node, and then initializes it by copying @@ -536,16 +532,13 @@ package Atree is procedure Rewrite (Old_Node, New_Node : Node_Id); -- This is used when a complete subtree is to be replaced. Old_Node is the -- root of the old subtree to be replaced, and New_Node is the root of the - -- newly constructed replacement subtree. The actual mechanism is to swap - -- the contents of these two nodes fixing up the parent pointers of the - -- replaced node (we do not attempt to preserve parent pointers for the - -- original node). - -- ??? The above explanation is incorrect, instead Copy_Node is called. + -- newly constructed replacement subtree. -- -- Note: New_Node may not contain references to Old_Node, for example as - -- descendants, since the rewrite would make such references invalid. If - -- New_Node does need to reference Old_Node, then these references should - -- be to a relocated copy of Old_Node (see Relocate_Node procedure). + -- descendants, since the rewrite would turn them into cyclic + -- self-references. If New_Node does need to reference Old_Node, then these + -- references should be to a relocated copy of Old_Node (see Relocate_Node + -- procedure). -- -- Note: The Original_Node function applied to Old_Node (which has now -- been replaced by the contents of New_Node), can be used to obtain the @@ -559,10 +552,8 @@ package Atree is -- original contents of the Old_Node, but rather the New_Node value. -- Replace also preserves the setting of Comes_From_Source. -- - -- Note that New_Node must not contain references to Old_Node, for example - -- as descendants, since the rewrite would make such references invalid. If - -- New_Node does need to reference Old_Node, then these references should - -- be to a relocated copy of Old_Node (see Relocate_Node procedure). + -- The note in the documentation of Rewrite about the risk of creating + -- cyclic references also applies here. -- -- Replace is used in certain circumstances where it is desirable to -- suppress any history of the rewriting operation. Notably, it is used diff --git a/gcc/ada/comperr.adb b/gcc/ada/comperr.adb index 180ea94..602b13d 100644 --- a/gcc/ada/comperr.adb +++ b/gcc/ada/comperr.adb @@ -307,16 +307,16 @@ package body Comperr is Write_Str ("| Please submit a bug report by email " & - "to report@adacore.com."); + "to support@adacore.com."); End_Line; Write_Str - ("| GAP members can alternatively use GNAT Tracker:"); + ("| GAP members can alternatively use GNATtracker:"); End_Line; Write_Str - ("| https://www.adacore.com/login?mode=gap " & - "section 'Create New Ticket'."); + ("| https://support.adacore.com/csm " & + "by using the button 'Create A New Case'."); End_Line; Write_Str @@ -326,17 +326,17 @@ package body Comperr is else Write_Str - ("| Please submit a bug report using GNAT Tracker:"); + ("| Please submit a bug report using GNATtracker at"); End_Line; Write_Str - ("| https://www.adacore.com/login " & - "section 'Create New Ticket'."); + ("| https://support.adacore.com/csm " & + "by using the button 'Create New Case'."); End_Line; Write_Str ("| Or submit a bug report by email " & - "to report@adacore.com"); + "to support@adacore.com"); End_Line; Write_Str diff --git a/gcc/ada/contracts.adb b/gcc/ada/contracts.adb index 810458a..70e9487 100644 --- a/gcc/ada/contracts.adb +++ b/gcc/ada/contracts.adb @@ -4399,10 +4399,10 @@ package body Contracts is Seen : Subprogram_List (Subps'Range) := (others => Empty); function Inherit_Condition - (Par_Subp : Entity_Id; - Subp : Entity_Id) return Node_Id; - -- Inherit the class-wide condition from Par_Subp to Subp and adjust - -- all the references to formals in the inherited condition. + (Par_Subp : Entity_Id) return Node_Id; + -- Inherit the class-wide condition from Par_Subp. Simply makes + -- a copy of the condition in preparation for later mapping of + -- referenced formals and functions by Build_Class_Wide_Expression. procedure Merge_Conditions (From : Node_Id; Into : Node_Id); -- Merge two class-wide preconditions or postconditions (the former @@ -4417,92 +4417,11 @@ package body Contracts is ----------------------- function Inherit_Condition - (Par_Subp : Entity_Id; - Subp : Entity_Id) return Node_Id - is - function Check_Condition (Expr : Node_Id) return Boolean; - -- Used in assertion to check that Expr has no reference to the - -- formals of Par_Subp. - - --------------------- - -- Check_Condition -- - --------------------- - - function Check_Condition (Expr : Node_Id) return Boolean is - Par_Formal_Id : Entity_Id; - - function Check_Entity (N : Node_Id) return Traverse_Result; - -- Check occurrence of Par_Formal_Id - - ------------------ - -- Check_Entity -- - ------------------ - - function Check_Entity (N : Node_Id) return Traverse_Result is - begin - if Nkind (N) = N_Identifier - and then Present (Entity (N)) - and then Entity (N) = Par_Formal_Id - then - return Abandon; - end if; - - return OK; - end Check_Entity; - - function Check_Expression is new Traverse_Func (Check_Entity); - - -- Start of processing for Check_Condition - - begin - Par_Formal_Id := First_Formal (Par_Subp); - - while Present (Par_Formal_Id) loop - if Check_Expression (Expr) = Abandon then - return False; - end if; - - Next_Formal (Par_Formal_Id); - end loop; - - return True; - end Check_Condition; - - -- Local variables - - Assoc_List : constant Elist_Id := New_Elmt_List; - Par_Formal_Id : Entity_Id := First_Formal (Par_Subp); - Subp_Formal_Id : Entity_Id := First_Formal (Subp); - New_Condition : Node_Id; - + (Par_Subp : Entity_Id) return Node_Id is begin - while Present (Par_Formal_Id) loop - Append_Elmt (Par_Formal_Id, Assoc_List); - Append_Elmt (Subp_Formal_Id, Assoc_List); - - Next_Formal (Par_Formal_Id); - Next_Formal (Subp_Formal_Id); - end loop; - - -- Check that Parent field of all the nodes have their correct - -- decoration; required because otherwise mapped nodes with - -- wrong Parent field are left unmodified in the copied tree - -- and cause reporting wrong errors at later stages. - - pragma Assert - (Check_Parents (Class_Condition (Kind, Par_Subp), Assoc_List)); - - New_Condition := + return New_Copy_Tree - (Source => Class_Condition (Kind, Par_Subp), - Map => Assoc_List); - - -- Ensure that the inherited condition has no reference to the - -- formals of the parent subprogram. - - pragma Assert (Check_Condition (New_Condition)); - - return New_Condition; + (Source => Class_Condition (Kind, Par_Subp)); end Inherit_Condition; ---------------------- @@ -4616,9 +4535,7 @@ package body Contracts is Par_Prim := Subp_Id; Par_Iface_Prims := Covered_Interface_Primitives (Par_Prim); - Cond := Inherit_Condition - (Subp => Spec_Id, - Par_Subp => Subp_Id); + Cond := Inherit_Condition (Par_Subp => Subp_Id); if Present (Class_Cond) then Merge_Conditions (Cond, Class_Cond); @@ -4662,9 +4579,7 @@ package body Contracts is then Seen (Index) := Subp_Id; - Cond := Inherit_Condition - (Subp => Spec_Id, - Par_Subp => Subp_Id); + Cond := Inherit_Condition (Par_Subp => Subp_Id); Check_Class_Condition (Cond => Cond, diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb index 3a39ec8..f250d74 100644 --- a/gcc/ada/debug.adb +++ b/gcc/ada/debug.adb @@ -186,8 +186,8 @@ package body Debug is -- d_S -- d_T Output trace information on invocation path recording -- d_U Disable prepending messages with "error:". - -- d_V Enable verifications on the expanded tree - -- d_W + -- d_V Enable VAST (verifications on the expanded tree) + -- d_W Enable VAST in verbose mode -- d_X Disable assertions to check matching of extra formals -- d_Y -- d_Z @@ -1065,8 +1065,11 @@ package body Debug is -- d_U Disable prepending 'error:' to error messages. This used to be the -- default and can be seen as the opposite of -gnatU. - -- d_V Enable verification of the expanded code before calling the backend - -- and generate error messages on each inconsistency found. + -- d_V Enable VAST (Verifier for the Ada Semantic Tree). This does + -- verification of the expanded code before calling the backend. + + -- d_W Same as d_V, but also prints lots of tracing/debugging output + -- as it walks the tree. -- d_X Disable assertions to check matching of extra formals; switch added -- temporarily to disable these checks until this work is complete if diff --git a/gcc/ada/debug_a.adb b/gcc/ada/debug_a.adb index d36ae69..8d68fc8 100644 --- a/gcc/ada/debug_a.adb +++ b/gcc/ada/debug_a.adb @@ -83,11 +83,8 @@ package body Debug_A is case Nkind (N) is when N_Has_Chars => - Write_Str (" """); - if Present (Chars (N)) then - Write_Str (Get_Name_String (Chars (N))); - end if; - Write_Str (""""); + Write_Str (" "); + Write_Name_For_Debug (Chars (N)); when others => null; end case; diff --git a/gcc/ada/doc/gnat_rm/gnat_language_extensions.rst b/gcc/ada/doc/gnat_rm/gnat_language_extensions.rst index 1713f56..0a08a83 100644 --- a/gcc/ada/doc/gnat_rm/gnat_language_extensions.rst +++ b/gcc/ada/doc/gnat_rm/gnat_language_extensions.rst @@ -1469,97 +1469,60 @@ that the record type must be a root type, in other words not a derived type. The aspect additionally makes it possible to specify relaxed semantics for the finalization operations by means of the ``Relaxed_Finalization`` setting. - -Example: +Here is the archetypal example: .. code-block:: ada - type Ctrl is record - Id : Natural := 0; + type T is record + ... end record with Finalizable => (Initialize => Initialize, Adjust => Adjust, Finalize => Finalize, Relaxed_Finalization => True); - procedure Adjust (Obj : in out Ctrl); - procedure Finalize (Obj : in out Ctrl); - procedure Initialize (Obj : in out Ctrl); - -The three procedures have the same profile, taking a single ``in out T`` -parameter. + procedure Adjust (Obj : in out T); + procedure Finalize (Obj : in out T); + procedure Initialize (Obj : in out T); -We follow the same dynamic semantics as controlled objects: +The three procedures have the same profile, with a single ``in out`` parameter, +and also have the same dynamic semantics as for controlled types: - ``Initialize`` is called when an object of type ``T`` is declared without - default expression. + initialization expression. - ``Adjust`` is called after an object of type ``T`` is assigned a new value. - ``Finalize`` is called when an object of type ``T`` goes out of scope (for - stack-allocated objects) or is explicitly deallocated (for heap-allocated - objects). It is also called when on the value being replaced in an - assignment. - -However the following differences are enforced by default when compared to the -current Ada controlled-objects finalization model: - -* No automatic finalization of heap allocated objects: ``Finalize`` is only - called when an object is implicitly deallocated. As a consequence, no-runtime - support is needed for the implicit case, and no header will be maintained for - this in heap-allocated controlled objects. - - Heap-allocated objects allocated through a nested access type definition will - hence **not** be deallocated either. The result is simply that memory will be - leaked in those cases. - -* The ``Finalize`` procedure should have have the :ref:`No_Raise_Aspect` specified. - If that's not the case, a compilation error will be raised. - -Additionally, two other configuration aspects are added, -``Legacy_Heap_Finalization`` and ``Exceptions_In_Finalize``: - -* ``Legacy_Heap_Finalization``: Uses the legacy automatic finalization of - heap-allocated objects - -* ``Exceptions_In_Finalize``: Allow users to have a finalizer that raises exceptions - **NB!** note that using this aspect introduces execution time penalities. - -.. _No_Raise_Aspect: - -No_Raise aspect ----------------- + stack-allocated objects) or is deallocated (for heap-allocated objects). + It is also called when the value is replaced by an assignment. -The ``No_Raise`` aspect can be applied to a subprogram to declare that this subprogram is not -expected to raise any exceptions. Should an exception still occur during the execution of -this subprogram, ``Program_Error`` is raised. +However, when ``Relaxed_Finalization`` is either ``True`` or not explicitly +specified, the following differences are implemented relative to the semantics +of controlled types: -New specification for ``Ada.Finalization.Controlled`` -^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +* The compiler has permission to perform no automatic finalization of + heap-allocated objects: ``Finalize`` is only called when such an object + is explicitly deallocated, or when the designated object is assigned a new + value. As a consequence, no runtime support is needed for performing + implicit deallocation. In particular, no per-object header data is needed + for heap-allocated objects. -``Ada.Finalization.Controlled`` is now specified as: - -.. code-block:: ada - - type Controlled is abstract tagged null record - with Initialize => Initialize, - Adjust => Adjust, - Finalize => Finalize, - Legacy_Heap_Finalization, Exceptions_In_Finalize; - - procedure Initialize (Self : in out Controlled) is abstract; - procedure Adjust (Self : in out Controlled) is abstract; - procedure Finalize (Self : in out Controlled) is abstract; + Heap-allocated objects allocated through a nested access type will therefore + **not** be deallocated either. The result is simply that memory will be leaked + in this case. +* The ``Adjust`` and ``Finalize`` procedures are automatically considered as + having the :ref:`No_Raise_Aspect` specified for them. In particular, the + compiler has permission to enforce none of the guarantees specified by the + RM 7.6.1 (14/1) and subsequent subclauses. -### Examples - -A simple example of a ref-counted type: +Simple example of ref-counted type: .. code-block:: ada type T is record - Value : Integer; + Value : Integer; Ref_Count : Natural := 0; end record; @@ -1571,8 +1534,8 @@ A simple example of a ref-counted type: type T_Ref is record Value : T_Access; end record - with Adjust => Adjust, - Finalize => Finalize; + with Finalizable => (Adjust => Adjust, + Finalize => Finalize); procedure Adjust (Ref : in out T_Ref) is begin @@ -1584,8 +1547,7 @@ A simple example of a ref-counted type: Def_Ref (Ref.Value); end Finalize; - -A simple file handle that ensures resources are properly released: +Simple file handle that ensures resources are properly released: .. code-block:: ada @@ -1595,51 +1557,47 @@ A simple file handle that ensures resources are properly released: function Open (Path : String) return File; procedure Close (F : in out File); + private type File is limited record Handle : ...; end record - with Finalize => Close; - - -Finalized tagged types -^^^^^^^^^^^^^^^^^^^^^^^ + with Finalizable (Finalize => Close); + end P; -Aspects are inherited by derived types and optionally overriden by those. The -compiler-generated calls to the user-defined operations are then -dispatching whenever it makes sense, i.e. the object in question is of -class-wide type and the class includes at least one finalized tagged type. +Finalizable tagged types +^^^^^^^^^^^^^^^^^^^^^^^^ -However note that for simplicity, it is forbidden to change the value of any of -those new aspects in derived types. +The aspect is inherited by derived types and the primitives may be overridden +by the derivation. The compiler-generated calls to these operations are then +dispatching whenever it makes sense, i.e. when the object in question is of a +class-wide type and the class includes at least one finalizable tagged type. Composite types ^^^^^^^^^^^^^^^ -When a finalized type is used as a component of a composite type, the latter -becomes finalized as well. The three primitives are derived automatically -in order to call the primitives of their components. - -If that composite type was already user-finalized, then the compiler -calls the primitives of the components so as to stay consistent with today's -controlled types's behavior. - -So, ``Initialize`` and ``Adjust`` are called on components before they -are called on the composite object, but ``Finalize`` is called on the composite -object first. +When a finalizable type is used as a component of a composite type, the latter +becomes finalizable as well. The three primitives are derived automatically +in order to call the primitives of their components. The dynamic semantics is +the same as for controlled components of composite types. Interoperability with controlled types ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -As a consequence of the redefinition of the ``Controlled`` type as a base type -with the new aspects defined, interoperability with controlled type naturally -follows the definition of the above rules. In particular: +Finalizable types are fully interoperable with controlled types, in particular +it is possible for a finalizable type to have a controlled component and vice +versa, but the stricter dynamic semantics, in other words that of controlled +types, is applied in this case. -* It is possible to have a new finalized type have a controlled type - component -* It is possible to have a controlled type have a finalized type - component +.. _No_Raise_Aspect: + +No_Raise aspect +---------------- +The ``No_Raise`` aspect can be applied to a subprogram to declare that this +subprogram is not expected to raise an exception. Should an exception still +be raised during the execution of the subprogram, it is caught at the end of +this execution and ``Program_Error`` is propagated to the caller. Inference of Dependent Types in Generic Instantiations ------------------------------------------------------ diff --git a/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst b/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst index cae8c16..02013f1 100644 --- a/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst +++ b/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst @@ -123,6 +123,11 @@ and generics may name types with unknown discriminants without using the ``(<>)`` notation. In addition, some but not all of the additional restrictions of Ada 83 are enforced. +Like all configuration pragmas, if the pragma is placed before a library +level package specification it is not propagated to the corresponding +package body (see RM 10.1.5(8)); it must be added explicitly to the +package body. + Ada 83 mode is intended for two purposes. Firstly, it allows existing Ada 83 code to be compiled and adapted to GNAT with less effort. Secondly, it aids in keeping code backwards compatible with Ada 83. @@ -149,6 +154,11 @@ contexts. This pragma is useful when writing a reusable component that itself uses Ada 95 features, but which is intended to be usable from either Ada 83 or Ada 95 programs. +Like all configuration pragmas, if the pragma is placed before a library +level package specification it is not propagated to the corresponding +package body (see RM 10.1.5(8)); it must be added explicitly to the +package body. + Pragma Ada_05 ============= @@ -166,6 +176,11 @@ This pragma is useful when writing a reusable component that itself uses Ada 2005 features, but which is intended to be usable from either Ada 83 or Ada 95 programs. +Like all configuration pragmas, if the pragma is placed before a library +level package specification it is not propagated to the corresponding +package body (see RM 10.1.5(8)); it must be added explicitly to the +package body. + The one argument form (which is not a configuration pragma) is used for managing the transition from Ada 95 to Ada 2005 in the run-time library. If an entity is marked @@ -209,6 +224,11 @@ contexts. This pragma is useful when writing a reusable component that itself uses Ada 2012 features, but which is intended to be usable from Ada 83, Ada 95, or Ada 2005 programs. +Like all configuration pragmas, if the pragma is placed before a library +level package specification it is not propagated to the corresponding +package body (see RM 10.1.5(8)); it must be added explicitly to the +package body. + The one argument form, which is not a configuration pragma, is used for managing the transition from Ada 2005 to Ada 2012 in the run-time library. If an entity is marked @@ -252,6 +272,11 @@ contexts. This pragma is useful when writing a reusable component that itself uses Ada 2022 features, but which is intended to be usable from Ada 83, Ada 95, Ada 2005 or Ada 2012 programs. +Like all configuration pragmas, if the pragma is placed before a library +level package specification it is not propagated to the corresponding +package body (see RM 10.1.5(8)); it must be added explicitly to the +package body. + The one argument form, which is not a configuration pragma, is used for managing the transition from Ada 2012 to Ada 2022 in the run-time library. If an entity is marked diff --git a/gcc/ada/doc/gnat_ugn/building_executable_programs_with_gnat.rst b/gcc/ada/doc/gnat_ugn/building_executable_programs_with_gnat.rst index 4f46fba..b99eba7 100644 --- a/gcc/ada/doc/gnat_ugn/building_executable_programs_with_gnat.rst +++ b/gcc/ada/doc/gnat_ugn/building_executable_programs_with_gnat.rst @@ -2112,7 +2112,7 @@ Alphabetical List of All Switches .. index:: -gnatR (gcc) -:switch:`-gnatR[0|1|2|3|4][e][j][m][s]` +:switch:`-gnatR[0|1|2|3|4][e][h][m][j][s]` Output representation information for declared types, objects and subprograms. Note that this switch is not allowed if a previous :switch:`-gnatD` switch has been given, since these two switches @@ -2259,15 +2259,16 @@ Alphabetical List of All Switches ======= ================================================================== *n* Effect ------- ------------------------------------------------------------------ - *0* No optimization, the default setting if no :switch:`-O` appears - *1* Normal optimization, the default if you specify :switch:`-O` without an - operand. A good compromise between code quality and compilation - time. - *2* Extensive optimization, may improve execution time, possibly at + *0* No optimization, the default setting if no :switch:`-O` appears. + *1* Moderate optimization, same as :switch:`-O` without an operand. + A good compromise between code quality and compilation time. + *2* Extensive optimization, should improve execution time, possibly at the cost of substantially increased compilation time. - *3* Same as :switch:`-O2`, and also includes inline expansion for small - subprograms in the same unit. - *s* Optimize space usage + *3* Full optimization, may further improve execution time, possibly at + the cost of substantially larger generated code. + *s* Optimize for size (code and data) rather than speed. + *z* Optimize aggressively for size (code and data) rather than speed. + *g* Optimize for debugging experience rather than speed. ======= ================================================================== See also :ref:`Optimization_Levels`. @@ -6088,7 +6089,7 @@ Debugging Control .. index:: -gnatR (gcc) -:switch:`-gnatR[0|1|2|3|4][e][j][m][s]` +:switch:`-gnatR[0|1|2|3|4][e][h][m][j][s]` This switch controls output from the compiler of a listing showing representation information for declared types, objects and subprograms. For :switch:`-gnatR0`, no information is output (equivalent to omitting @@ -6116,17 +6117,21 @@ Debugging Control extended representation information for record sub-components of records is included. + If the switch is followed by a ``h`` (e.g. :switch:`-gnatR3h`), then + the components of records are sorted by increasing offsets and holes + between consecutive components are flagged. + If the switch is followed by an ``m`` (e.g. :switch:`-gnatRm`), then subprogram conventions and parameter passing mechanisms for all the subprograms are included. - If the switch is followed by a ``j`` (e.g., :switch:`-gnatRj`), then + If the switch is followed by a ``j`` (e.g. :switch:`-gnatRj`), then the output is in the JSON data interchange format specified by the ECMA-404 standard. The semantic description of this JSON output is available in the specification of the Repinfo unit present in the compiler sources. - If the switch is followed by an ``s`` (e.g., :switch:`-gnatR3s`), then + If the switch is followed by an ``s`` (e.g. :switch:`-gnatR3s`), then the output is to a file with the name :file:`file.rep` where ``file`` is the name of the corresponding source file, except if ``j`` is also specified, in which case the file name is :file:`file.json`. diff --git a/gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst b/gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst index 756bc74..4ecb3cf 100644 --- a/gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst +++ b/gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst @@ -1584,18 +1584,16 @@ Turning on optimization makes the compiler attempt to improve the performance and/or code size at the expense of compilation time and possibly the ability to debug the program. -If you use multiple :switch:`-O` switches, with or without level -numbers, the last such switch is the one that's used. - -You can use the -:switch:`-O` switch (the permitted forms are :switch:`-O0`, :switch:`-O1` -:switch:`-O2`, :switch:`-O3`, and :switch:`-Os`) -to ``gcc`` to control the optimization level: +You can pass the :switch:`-O` switch, with or without an operand +(the permitted forms with an operand are :switch:`-O0`, :switch:`-O1`, +:switch:`-O2`, :switch:`-O3`, :switch:`-Os`, :switch:`-Oz`, and +:switch:`-Og`) to ``gcc`` to control the optimization level. If you +pass multiple :switch:`-O` switches, with or without an operand, +the last such switch is the one that's used: * :switch:`-O0` - No optimization (the default); - generates unoptimized code but has + No optimization (the default); generates unoptimized code but has the fastest compilation time. Debugging is easiest with this switch. Note that many other compilers do substantial optimization even if @@ -1606,32 +1604,45 @@ to ``gcc`` to control the optimization level: mind when doing performance comparisons. * :switch:`-O1` - Moderate optimization; optimizes reasonably well but does not - degrade compilation time significantly. You may not be able to see - some variables in the debugger and changing the value of some - variables in the debugger may not have the effect you desire. + Moderate optimization (same as :switch:`-O` without an operand); + optimizes reasonably well but does not degrade compilation time + significantly. You may not be able to see some variables in the + debugger, and changing the value of some variables in the debugger + may not have the effect you desire. * :switch:`-O2` - Full optimization; - generates highly optimized code and has - the slowest compilation time. You may see significant impacts on + Extensive optimization; generates highly optimized code but has + an increased compilation time. You may see significant impacts on your ability to display and modify variables in the debugger. * :switch:`-O3` - Full optimization as in :switch:`-O2`; - also uses more aggressive automatic inlining of subprograms within a unit - (:ref:`Inlining_of_Subprograms`) and attempts to vectorize loops. - + Full optimization; attempts more sophisticated transformations, in + particular on loops, possibly at the cost of larger generated code. + You may be hardly able to use the debugger at this optimization level. * :switch:`-Os` - Optimize space usage (code and data) of resulting program. + Optimize for size (code and data) of resulting binary rather than + speed; based on the :switch:`-O2` optimization level, but disables + some of its transformations that often increase code size, as well + as performs further optimizations designed to reduce code size. + +* :switch:`-Oz` + Optimize aggressively for size (code and data) of resulting binary + rather than speed; may increase the number of instructions executed + if these instructions require fewer bytes to be encoded. + +* :switch:`-Og` + Optimize for debugging experience rather than speed; based on the + :switch:`-O1` optimization level, but attempts to eliminate all the + negative effects of optimization on debugging. + Higher optimization levels perform more global transformations on the program and apply more expensive analysis algorithms in order to generate faster and more compact code. The price in compilation time, and the -resulting improvement in execution time, -both depend on the particular application and the hardware environment. -You should experiment to find the best level for your application. +resulting improvement in execution time, both depend on the particular +application and the hardware environment. You should experiment to find +the best level for your application. Since the precise set of optimizations done at each level will vary from release to release (and sometime from target to target), it is best to think diff --git a/gcc/ada/doc/gnat_ugn/the_gnat_compilation_model.rst b/gcc/ada/doc/gnat_ugn/the_gnat_compilation_model.rst index 64a3631..891886b 100644 --- a/gcc/ada/doc/gnat_ugn/the_gnat_compilation_model.rst +++ b/gcc/ada/doc/gnat_ugn/the_gnat_compilation_model.rst @@ -1477,6 +1477,10 @@ You can place configuration pragmas either appear at the start of a compilation unit or in a configuration pragma file that applies to all compilations performed in a given compilation environment. +Configuration pragmas placed before a library level package specification +are not propagated to the corresponding package body (see RM 10.1.5(8)); +they must be added explicitly to the package body. + GNAT includes the ``gnatchop`` utility to provide an automatic way to handle configuration pragmas that follows the semantics for compilations (that is, files with multiple units) described in the RM. diff --git a/gcc/ada/einfo-utils.adb b/gcc/ada/einfo-utils.adb index 15f5b99..91d273c 100644 --- a/gcc/ada/einfo-utils.adb +++ b/gcc/ada/einfo-utils.adb @@ -2639,14 +2639,7 @@ package body Einfo.Utils is -- anonymous protected types, since protected types always have the -- default convention. - if Present (Etype (E)) - and then (Is_Object (E) - - -- Allow E_Void (happens for pragma Convention appearing - -- in the middle of a record applying to a component) - - or else Ekind (E) = E_Void) - then + if Present (Etype (E)) and then Is_Object (E) then declare Typ : constant Entity_Id := Etype (E); diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 545c15d..d8958d6 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -463,11 +463,13 @@ package Einfo is -- For an access_to_protected_subprogram parameter it is the declaration -- of the corresponding formal parameter. --- --- Itypes have no explicit declaration, and therefore are not attached to --- the tree: their Parent field is always empty. The Associated_Node_For_ --- Itype is the only way to determine the construct that leads to the --- creation of a given itype entity. + +-- Itypes need not have an explicit declaration, in which case they are +-- not attached to the tree through the Parent field, which is empty. In +-- other cases, they have one and are attached to the tree through the +-- Parent field as usual. Associated_Node_For_Itype should be used to +-- determine the construct that leads to the creation of a given itype +-- entity. -- Associated_Storage_Pool [root type only] -- Defined in simple and general access type entities. References the @@ -1606,7 +1608,7 @@ package Einfo is -- Has_Dynamic_Predicate_Aspect -- Defined in all types and subtypes. Set if a Dynamic_Predicate aspect --- was explicitly applied to the type. Generally we treat predicates as +-- was applied to the type or subtype. Generally we treat predicates as -- static if possible, regardless of whether they are specified using -- Predicate, Static_Predicate, or Dynamic_Predicate. And if a predicate -- can be treated as static (i.e. its expression is predicate-static), @@ -1687,7 +1689,7 @@ package Einfo is -- -- Has_Homonym -- Defined in all entities. Set if an entity has a homonym in the same --- scope. Used by the backend to generate unique names for all entities. +-- scope. Used by Exp_Dbug to generate unique names for all entities. -- Has_Implicit_Dereference -- Defined in types and discriminants. Set if the type has an aspect @@ -3927,17 +3929,12 @@ package Einfo is -- Points to the component in the base type. -- Overlays_Constant --- Defined in all entities. Set only for E_Constant or E_Variable for --- which there is an address clause that causes the entity to overlay --- a constant object. +-- Defined in constants and variables. Set if there is an address clause +-- that causes the entity to overlay a constant object. -- Overridden_Operation -- Defined in subprograms. For overriding operations, points to the --- user-defined parent subprogram that is being overridden. Note: this --- attribute uses the same field as Static_Initialization. The latter --- is only defined for internal initialization procedures, for which --- Overridden_Operation is irrelevant. Thus this attribute must not be --- set for init_procs. +-- user-defined parent subprogram that is being overridden. -- Package_Instantiation -- Defined in packages and generic packages. When defined, this field @@ -4491,9 +4488,7 @@ package Einfo is -- initialized statically. The value of this attribute is a positional -- aggregate whose components are compile-time static values. Used -- when available in object declarations to eliminate the call to the --- initialization procedure, and to minimize elaboration code. Note: --- This attribute uses the same field as Overridden_Operation, which is --- irrelevant in init_procs. +-- initialization procedure, and to minimize elaboration code. -- Static_Real_Or_String_Predicate -- Defined in real types/subtypes with static predicates (with the two @@ -4961,7 +4956,6 @@ package Einfo is -- Materialize_Entity -- Needs_Debug_Info -- Never_Set_In_Source - -- Overlays_Constant -- Referenced -- Referenced_As_LHS -- Referenced_As_Out_Parameter @@ -5288,7 +5282,7 @@ package Einfo is -- Interface_Name (constants only) -- Related_Type (constants only) -- Initialization_Statements - -- BIP_Initialization_Call + -- BIP_Initialization_Call (constants only) -- Finalization_Master_Node -- Last_Aggregate_Assignment -- Activation_Record_Component @@ -5318,6 +5312,7 @@ package Einfo is -- Is_Volatile_Full_Access -- Optimize_Alignment_Space (constants only) -- Optimize_Alignment_Time (constants only) + -- Overlays_Constant (constants only) -- SPARK_Pragma_Inherited (constants only) -- Stores_Attribute_Old_Prefix (constants only) -- Treat_As_Volatile @@ -6205,6 +6200,7 @@ package Einfo is -- OK_To_Rename -- Optimize_Alignment_Space -- Optimize_Alignment_Time + -- Overlays_Constant -- SPARK_Pragma_Inherited -- Suppress_Initialization -- Treat_As_Volatile diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index 5450402..8aad721 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -7017,7 +7017,7 @@ package body Exp_Aggr is begin return UI_To_Int ((if Nkind (Expr) = N_Integer_Literal then Intval (Expr) - else Enumeration_Pos (Expr))); + else Enumeration_Pos (Entity (Expr)))); end To_Int; -- Local variables @@ -7503,10 +7503,19 @@ package body Exp_Aggr is Set_Assignment_OK (Lhs); Aggr_Code := Build_Container_Aggr_Code (N, Typ, Lhs, Init); + + -- Use the unconstrained base subtype of the subtype provided by + -- the context for declaring the temporary object (which may come + -- from a constrained assignment target), to ensure that the + -- aggregate can be successfully expanded and assigned to the + -- temporary without exceeding its capacity. (Later assignment + -- of the temporary to a target object may result in failing + -- a discriminant check.) + Prepend_To (Aggr_Code, Make_Object_Declaration (Loc, Defining_Identifier => Obj_Id, - Object_Definition => New_Occurrence_Of (Typ, Loc), + Object_Definition => New_Occurrence_Of (Base_Type (Typ), Loc), Expression => Init)); Insert_Actions (N, Aggr_Code); diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index f1f8424..3d1bff9 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -8183,9 +8183,8 @@ package body Exp_Attr is else declare Uns : constant Boolean := - Is_Unsigned_Type (Ptyp) - or else (Is_Private_Type (Ptyp) - and then Is_Unsigned_Type (PBtyp)); + Is_Unsigned_Type (Validated_View (Ptyp)); + Size : Uint; P : Node_Id := Pref; diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index d884e75..cf2238e 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -8741,8 +8741,9 @@ package body Exp_Ch3 is -- be illegal in some cases (such as converting access- -- to-unconstrained to access-to-constrained), but the -- the unchecked conversion will presumably fail to work - -- right in just such cases. It's not clear at all how to - -- handle this. + -- right in just such cases. In order to handle this + -- properly, in the Caller_Allocation case, the callee + -- needs to do the constraint check. Alloc_Stmt := Make_If_Statement (Loc, diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 01be3df..0cf5643 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -193,12 +193,12 @@ package body Exp_Ch4 is procedure Insert_Conditional_Object_Declaration (Obj_Id : Entity_Id; + Typ : Entity_Id; Expr : Node_Id; - Decl : Node_Id); - -- Expr is the dependent expression of a conditional expression and Decl - -- is the declaration of an object whose initialization expression is the - -- conditional expression. Insert in the actions of Expr the declaration - -- of Obj_Id modeled on Decl and with Expr as initialization expression. + Const : Boolean); + -- Expr is the dependent expression of a conditional expression. Insert in + -- the actions of Expr the declaration of Obj_Id with type Typ and Expr as + -- initialization expression. Const is True when Obj_Id is a constant. procedure Insert_Dereference_Action (N : Node_Id); -- N is an expression whose type is an access. When the type of the @@ -5313,7 +5313,7 @@ package body Exp_Ch4 is -- 'Unrestricted_Access. -- Generate: - -- type Ptr_Typ is not null access all [constant] Typ; + -- type Target_Typ is not null access all [constant] Typ; else Target_Typ := Make_Temporary (Loc, 'P'); @@ -5411,20 +5411,16 @@ package body Exp_Ch4 is elsif Optimize_Object_Decl then Obj := Make_Temporary (Loc, 'C', Alt_Expr); - Insert_Conditional_Object_Declaration (Obj, Alt_Expr, Par); - - Alt_Expr := - Make_Attribute_Reference (Alt_Loc, - Prefix => New_Occurrence_Of (Obj, Alt_Loc), - Attribute_Name => Name_Unrestricted_Access); - - LHS := New_Occurrence_Of (Target, Loc); - Set_Assignment_OK (LHS); + Insert_Conditional_Object_Declaration + (Obj, Typ, Alt_Expr, Const => Constant_Present (Par)); Stmts := New_List ( Make_Assignment_Statement (Alt_Loc, - Name => LHS, - Expression => Alt_Expr)); + Name => New_Occurrence_Of (Target, Loc), + Expression => + Make_Attribute_Reference (Alt_Loc, + Prefix => New_Occurrence_Of (Obj, Alt_Loc), + Attribute_Name => Name_Unrestricted_Access))); -- Take the unrestricted access of the expression value for non- -- scalar types. This approach avoids big copies and covers the @@ -6022,8 +6018,10 @@ package body Exp_Ch4 is Target : constant Entity_Id := Make_Temporary (Loc, 'C', N); begin - Insert_Conditional_Object_Declaration (Then_Obj, Thenx, Par); - Insert_Conditional_Object_Declaration (Else_Obj, Elsex, Par); + Insert_Conditional_Object_Declaration + (Then_Obj, Typ, Thenx, Const => Constant_Present (Par)); + Insert_Conditional_Object_Declaration + (Else_Obj, Typ, Elsex, Const => Constant_Present (Par)); -- Generate: -- type Ptr_Typ is not null access all [constant] Typ; @@ -13294,16 +13292,17 @@ package body Exp_Ch4 is procedure Insert_Conditional_Object_Declaration (Obj_Id : Entity_Id; + Typ : Entity_Id; Expr : Node_Id; - Decl : Node_Id) + Const : Boolean) is Loc : constant Source_Ptr := Sloc (Expr); Obj_Decl : constant Node_Id := Make_Object_Declaration (Loc, Defining_Identifier => Obj_Id, Aliased_Present => True, - Constant_Present => Constant_Present (Decl), - Object_Definition => New_Copy_Tree (Object_Definition (Decl)), + Constant_Present => Const, + Object_Definition => New_Occurrence_Of (Typ, Loc), Expression => Relocate_Node (Expr)); -- We make the object unconditionally aliased to avoid dangling bound -- issues when its nominal subtype is an unconstrained array type. @@ -13322,9 +13321,19 @@ package body Exp_Ch4 is Insert_Action (Expr, Obj_Decl); -- The object can never be local to an elaboration routine at library - -- level since we will take 'Unrestricted_Access of it. - - Set_Is_Statically_Allocated (Obj_Id, Is_Library_Level_Entity (Obj_Id)); + -- level since we will take 'Unrestricted_Access of it. Beware that + -- Is_Library_Level_Entity always returns False when called from within + -- a transient scope, but the associated block will not be materialized + -- when the transient scope is finally closed in the case of an object + -- declaration (see Exp.Ch7.Wrap_Transient_Declaration). + + if Scope (Obj_Id) = Current_Scope and then Scope_Is_Transient then + Set_Is_Statically_Allocated + (Obj_Id, Is_Library_Level_Entity (Scope (Obj_Id))); + else + Set_Is_Statically_Allocated + (Obj_Id, Is_Library_Level_Entity (Obj_Id)); + end if; -- If the object needs finalization, we need to insert its Master_Node -- manually because 1) the machinery in Exp_Ch7 will not pick it since diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index f85d977..2a246ad 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -158,7 +158,7 @@ package body Exp_Ch6 is Alloc_Form_Exp : Node_Id := Empty; Pool_Exp : Node_Id := Empty); -- Ada 2005 (AI-318-02): If the result type of a build-in-place call needs - -- them, add the actuals parameters BIP_Alloc_Form and BIP_Storage_Pool. + -- them, add the actual parameters BIP_Alloc_Form and BIP_Storage_Pool. -- If Alloc_Form_Exp is present, then pass it for the first parameter, -- otherwise pass a literal corresponding to the Alloc_Form parameter -- (which must not be Unspecified in that case). If Pool_Exp is present, @@ -442,9 +442,7 @@ package body Exp_Ch6 is return; end if; - -- Locate the implicit allocation form parameter in the called function. - -- Maybe it would be better for each implicit formal of a build-in-place - -- function to have a flag or a Uint attribute to identify it. ??? + -- Locate the implicit allocation form parameter in the called function Alloc_Form_Formal := Build_In_Place_Formal (Function_Id, BIP_Alloc_Form); @@ -928,9 +926,6 @@ package body Exp_Ch6 is Formal_Suffix : constant String := BIP_Formal_Suffix (Kind); begin - -- Maybe it would be better for each implicit formal of a build-in-place - -- function to have a flag or a Uint attribute to identify it. ??? - -- The return type in the function declaration may have been a limited -- view, and the extra formals for the function were not generated at -- that point. At the point of call the full view must be available and @@ -8821,6 +8816,25 @@ package body Exp_Ch6 is and then not Has_Foreign_Convention (Return_Applies_To (Scope (Obj_Def_Id))); + Constraint_Check_Needed : constant Boolean := + (Has_Discriminants (Obj_Typ) or else Is_Array_Type (Obj_Typ)) + and then Is_Tagged_Type (Obj_Typ) + and then Nkind (Original_Node (Obj_Decl)) /= + N_Object_Renaming_Declaration + and then Is_Constrained (Obj_Typ); + -- We are processing a call in the context of something like + -- "X : T := F (...);". This is True if we need to do a constraint + -- check, because T has constrained bounds or discriminants, + -- and F is returning an unconstrained subtype. + -- We are currently doing the check at the call site, + -- which is possible only in the callee-allocates case, + -- which is why we have Is_Tagged_Type above. + -- ???The check is missing in the untagged caller-allocates case. + -- ???The check for renaming declarations above is needed because + -- Sem_Ch8.Analyze_Object_Renaming sometimes changes a renaming + -- into an object declaration. We probably shouldn't do that, + -- but for now, we need this check. + -- Start of processing for Make_Build_In_Place_Call_In_Object_Declaration begin @@ -8863,15 +8877,16 @@ package body Exp_Ch6 is Subtype_Indication => New_Occurrence_Of (Designated_Type, Loc))); - -- The access type and its accompanying object must be inserted after - -- the object declaration in the constrained case, so that the function - -- call can be passed access to the object. In the indefinite case, or + -- The access type and its object must be inserted after the object + -- declaration in the caller-allocates case, so that the function call + -- can be passed access to the object. In the caller-allocates case, or -- if the object declaration is for a return object, the access type and -- object must be inserted before the object, since the object -- declaration is rewritten to be a renaming of a dereference of the -- access object. - if Definite and then not Is_OK_Return_Object then + if Definite and not Is_OK_Return_Object and not Constraint_Check_Needed + then Insert_Action_After (Obj_Decl, Ptr_Typ_Decl); else Insert_Action (Obj_Decl, Ptr_Typ_Decl); @@ -8952,7 +8967,7 @@ package body Exp_Ch6 is -- to the (specific) result type of the function is inserted to handle -- the case where the object is declared with a class-wide type. - elsif Definite then + elsif Definite and not Constraint_Check_Needed then Caller_Object := Unchecked_Convert_To (Result_Subt, New_Occurrence_Of (Obj_Def_Id, Loc)); @@ -9090,8 +9105,8 @@ package body Exp_Ch6 is -- itself the return expression of an enclosing BIP function, then mark -- the object as having no initialization. - if Definite and then not Is_OK_Return_Object then - + if Definite and not Is_OK_Return_Object and not Constraint_Check_Needed + then Set_Expression (Obj_Decl, Empty); Set_No_Initialization (Obj_Decl); @@ -9150,6 +9165,10 @@ package body Exp_Ch6 is Analyze (Obj_Decl); Replace_Renaming_Declaration_Id (Obj_Decl, Original_Node (Obj_Decl)); + + if Constraint_Check_Needed then + Apply_Constraint_Check (Call_Deref, Obj_Typ); + end if; end if; pragma Assert (Check_Number_Of_Actuals (Func_Call, Function_Id)); @@ -9919,15 +9938,15 @@ package body Exp_Ch6 is -- Start of processing for Validate_Subprogram_Calls begin - -- No action required if we are not generating code or compiling sources - -- that have errors. + -- No action if we are not generating code (including if we have + -- errors). - if Serious_Errors_Detected > 0 - or else Operating_Mode /= Generate_Code - then + if Operating_Mode /= Generate_Code then return; end if; + pragma Assert (Serious_Errors_Detected = 0); + Check_Calls (N); end Validate_Subprogram_Calls; diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index 458b32c..080a2e1 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -413,7 +413,9 @@ package body Exp_Disp is if Nkind (D) = N_Package_Declaration then Build_Package_Dispatch_Tables (D); - elsif Nkind (D) = N_Package_Body then + elsif Nkind (D) = N_Package_Body + and then Ekind (Corresponding_Spec (D)) /= E_Generic_Package + then Build_Dispatch_Tables (Declarations (D)); elsif Nkind (D) = N_Package_Body_Stub diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 028ee01..45eb808 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -1523,7 +1523,123 @@ package body Exp_Util is New_E := Type_Map.Get (Entity (N)); if Present (New_E) then - Rewrite (N, New_Occurrence_Of (New_E, Sloc (N))); + declare + + Ctrl_Type : constant Entity_Id + := Find_Dispatching_Type (Par_Subp); + + function Call_To_Parent_Dispatching_Op_Must_Be_Mapped + (Call_Node : Node_Id) return Boolean; + -- If Call_Node is a call to a primitive function F of the + -- tagged type T associated with Par_Subp that either has + -- any actuals that are controlling formals of Par_Subp, + -- or else the call to F is an actual parameter of an + -- enclosing call to a primitive of T that has any actuals + -- that are controlling formals of Par_Subp (and recursively + -- up the tree of enclosing function calls), returns True; + -- otherwise returns False. Returning True implies that the + -- call to F must be mapped to a call that instead targets + -- the corresponding function F of the tagged type for which + -- Subp is a primitive function. + + -------------------------------------------------- + -- Call_To_Parent_Dispatching_Op_Must_Be_Mapped -- + -------------------------------------------------- + + function Call_To_Parent_Dispatching_Op_Must_Be_Mapped + (Call_Node : Node_Id) return Boolean + is + pragma Assert (Nkind (Call_Node) = N_Function_Call); + + Actual : Node_Id := First_Actual (Call_Node); + Actual_Or_Prefix : Node_Id; + + begin + if Is_Entity_Name (Name (Call_Node)) + and then Is_Dispatching_Operation + (Entity (Name (Call_Node))) + and then + Is_Ancestor + (Ctrl_Type, + Find_Dispatching_Type + (Entity (Name (Call_Node)))) + then + while Present (Actual) loop + + -- Account for 'Old and explicit dereferences, + -- picking up the prefix object in those cases. + + if (Nkind (Actual) = N_Attribute_Reference + and then Attribute_Name (Actual) = Name_Old) + or else Nkind (Actual) = N_Explicit_Dereference + then + Actual_Or_Prefix := Prefix (Actual); + else + Actual_Or_Prefix := Actual; + end if; + + -- If at least one actual is a controlling formal + -- parameter of a class-wide Pre/Post aspect's + -- subprogram, the rule in RM 6.1.1(7) applies, + -- and we want to map the call to target the + -- corresponding function of the derived type. + + if Nkind (Actual_Or_Prefix) + in N_Identifier + | N_Expanded_Name + | N_Operator_Symbol + + and then Is_Formal (Entity (Actual_Or_Prefix)) + + and then Is_Controlling_Formal + (Entity (Actual_Or_Prefix)) + then + return True; + + -- RM 6.1.1(7) also applies to Result attributes + -- of primitive functions with controlling results. + + elsif Is_Attribute_Result (Actual) + and then Has_Controlling_Result (Subp) + then + return True; + end if; + + Next_Actual (Actual); + end loop; + + if Nkind (Parent (Call_Node)) = N_Function_Call then + return + Call_To_Parent_Dispatching_Op_Must_Be_Mapped + (Parent (Call_Node)); + end if; + + return False; + + else + return False; + end if; + end Call_To_Parent_Dispatching_Op_Must_Be_Mapped; + + begin + -- If N's entity is in the map, then the entity is either + -- a formal of the parent subprogram that should necessarily + -- be mapped, or it's a function call's target entity that + -- that should be mapped if the call involves any actuals + -- that reference formals of the parent subprogram (or the + -- function call is part of an enclosing call that similarly + -- qualifies for mapping). Rewrite a node that references + -- any such qualified entity to a new node referencing the + -- corresponding entity associated with the derived type. + + if not Is_Subprogram (Entity (N)) + or else Nkind (Parent (N)) /= N_Function_Call + or else + Call_To_Parent_Dispatching_Op_Must_Be_Mapped (Parent (N)) + then + Rewrite (N, New_Occurrence_Of (New_E, Sloc (N))); + end if; + end; end if; -- Update type of function call node, which should be the same as @@ -8112,19 +8228,31 @@ package body Exp_Util is return; end if; - -- the expansion of Task and protected type declarations can + -- The expansion of task and protected type declarations can -- create declarations for temporaries which, like other actions - -- are inserted and analyzed before the current declaraation. - -- However, the current scope is the synchronized type, and - -- for unnesting it is critical that the proper scope for these - -- generated entities be the enclosing one. + -- are inserted and analyzed before the current declaration. + -- However, in some cases, the current scope is the synchronized + -- type, and for unnesting it is critical that the proper scope + -- for these generated entities be the enclosing one. when N_Task_Type_Declaration | N_Protected_Type_Declaration => - Push_Scope (Scope (Current_Scope)); - Insert_List_Before_And_Analyze (P, Ins_Actions); - Pop_Scope; + declare + Skip_Scope : constant Boolean := + Ekind (Current_Scope) in Concurrent_Kind; + begin + if Skip_Scope then + Push_Scope (Scope (Current_Scope)); + end if; + + Insert_List_Before_And_Analyze (P, Ins_Actions); + + if Skip_Scope then + Pop_Scope; + end if; + end; + return; -- A special case, N_Raise_xxx_Error can act either as a statement diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index ec0fb16e..35f14d6 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -715,10 +715,11 @@ package body Freeze is then declare O_Ent : Entity_Id; + O_Typ : Entity_Id; Off : Boolean; begin - Find_Overlaid_Entity (Addr, O_Ent, Off); + Find_Overlaid_Entity (Addr, O_Ent, O_Typ, Off); if Ekind (O_Ent) = E_Constant and then Etype (O_Ent) = Typ @@ -6869,9 +6870,10 @@ package body Freeze is end if; end if; - -- Static objects require special handling + -- Statically allocated objects require special handling if (Ekind (E) = E_Constant or else Ekind (E) = E_Variable) + and then No (Renamed_Object (E)) and then Is_Statically_Allocated (E) then Freeze_Static_Object (E); @@ -10231,11 +10233,17 @@ package body Freeze is -- issue an error message saying that this object cannot be imported -- or exported. If it has an address clause it is an overlay in the -- current partition and the static requirement is not relevant. - -- Do not issue any error message when ignoring rep clauses. + -- Do not issue any error message when ignoring rep clauses or for + -- compiler-generated entities. if Ignore_Rep_Clauses then null; + elsif not Comes_From_Source (E) then + pragma + Assert (Nkind (Parent (Declaration_Node (E))) in N_Case_Statement + | N_If_Statement); + elsif Is_Imported (E) then if No (Address_Clause (E)) then Error_Msg_N diff --git a/gcc/ada/frontend.adb b/gcc/ada/frontend.adb index 12cea9c..d537678 100644 --- a/gcc/ada/frontend.adb +++ b/gcc/ada/frontend.adb @@ -506,9 +506,7 @@ begin -- Verify the validity of the tree - if Debug_Flag_Underscore_VV then - VAST.Check_Tree (Cunit (Main_Unit)); - end if; + VAST.VAST; -- Validate all the subprogram calls; this work will be done by VAST; in -- the meantime it is done to check extra formals and it can be disabled diff --git a/gcc/ada/gcc-interface/decl.cc b/gcc/ada/gcc-interface/decl.cc index 1694b4e..972607a 100644 --- a/gcc/ada/gcc-interface/decl.cc +++ b/gcc/ada/gcc-interface/decl.cc @@ -1228,6 +1228,24 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) gnu_expr = gnat_build_constructor (gnu_type, v); } + /* If we are allocating the anonymous object of a small aggregate on + the stack, zero-initialize it so that the entire object is assigned + and the subsequent assignments need not preserve unknown bits, but + do it only when optimization is enabled for the sake of consistency + with the gimplifier which does the same for CONSTRUCTORs. */ + else if (definition + && !imported_p + && !static_flag + && !gnu_expr + && TREE_CODE (gnu_type) == RECORD_TYPE + && TREE_CODE (gnu_object_size) == INTEGER_CST + && compare_tree_int (gnu_object_size, MAX_FIXED_MODE_SIZE) <= 0 + && Present (Related_Expression (gnat_entity)) + && Nkind (Original_Node (Related_Expression (gnat_entity))) + == N_Aggregate + && optimize) + gnu_expr = build_constructor (gnu_type, NULL); + /* Convert the expression to the type of the object if need be. */ if (gnu_expr && initial_value_needs_conversion (gnu_type, gnu_expr)) gnu_expr = convert (gnu_type, gnu_expr); @@ -5251,7 +5269,7 @@ inline_status_for_subprog (Entity_Id subprog) && Is_Record_Type (Etype (First_Formal (subprog))) && (gnu_type = gnat_to_gnu_type (Etype (First_Formal (subprog)))) && !TYPE_IS_BY_REFERENCE_P (gnu_type) - && tree_fits_uhwi_p (TYPE_SIZE (gnu_type)) + && TREE_CODE (TYPE_SIZE (gnu_type)) == INTEGER_CST && compare_tree_int (TYPE_SIZE (gnu_type), MAX_FIXED_MODE_SIZE) <= 0) return is_prescribed; diff --git a/gcc/ada/gen_il-gen-gen_entities.adb b/gcc/ada/gen_il-gen-gen_entities.adb index bfa634f..5c89597 100644 --- a/gcc/ada/gen_il-gen-gen_entities.adb +++ b/gcc/ada/gen_il-gen-gen_entities.adb @@ -215,7 +215,6 @@ begin -- Gen_IL.Gen.Gen_Entities Sm (May_Inherit_Delayed_Rep_Aspects, Flag), Sm (Needs_Debug_Info, Flag), Sm (Never_Set_In_Source, Flag), - Sm (Overlays_Constant, Flag), Sm (Prev_Entity, Node_Id), Sm (Referenced, Flag), Sm (Referenced_As_LHS, Flag), @@ -353,6 +352,7 @@ begin -- Gen_IL.Gen.Gen_Entities Sm (Last_Aggregate_Assignment, Node_Id), Sm (Optimize_Alignment_Space, Flag), Sm (Optimize_Alignment_Time, Flag), + Sm (Overlays_Constant, Flag), Sm (Prival_Link, Node_Id), Sm (Related_Type, Node_Id), Sm (Return_Statement, Node_Id), @@ -426,9 +426,8 @@ begin -- Gen_IL.Gen.Gen_Entities Sm (Discriminant_Default_Value, Node_Id), Sm (Is_Activation_Record, Flag))); - Ab (Formal_Object_Kind, Object_Kind, - -- Generic formal objects are also objects - (Sm (Entry_Component, Node_Id))); + Ab (Formal_Object_Kind, Object_Kind); + -- Generic formal objects are also objects Cc (E_Generic_In_Out_Parameter, Formal_Object_Kind, -- A generic in out parameter, created by the use of a generic in out diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index 4d98471..0ae1a24 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -942,10 +942,9 @@ Simpler Accessibility Model * Subprogram parameters:: * Function results:: -No_Raise aspect +Generalized Finalization -* New specification for Ada.Finalization.Controlled: New specification for Ada Finalization Controlled. -* Finalized tagged types:: +* Finalizable tagged types:: * Composite types:: * Interoperability with controlled types:: @@ -1581,6 +1580,11 @@ and generics may name types with unknown discriminants without using the @code{(<>)} notation. In addition, some but not all of the additional restrictions of Ada 83 are enforced. +Like all configuration pragmas, if the pragma is placed before a library +level package specification it is not propagated to the corresponding +package body (see RM 10.1.5(8)); it must be added explicitly to the +package body. + Ada 83 mode is intended for two purposes. Firstly, it allows existing Ada 83 code to be compiled and adapted to GNAT with less effort. Secondly, it aids in keeping code backwards compatible with Ada 83. @@ -1608,6 +1612,11 @@ contexts. This pragma is useful when writing a reusable component that itself uses Ada 95 features, but which is intended to be usable from either Ada 83 or Ada 95 programs. +Like all configuration pragmas, if the pragma is placed before a library +level package specification it is not propagated to the corresponding +package body (see RM 10.1.5(8)); it must be added explicitly to the +package body. + @node Pragma Ada_05,Pragma Ada_2005,Pragma Ada_95,Implementation Defined Pragmas @anchor{gnat_rm/implementation_defined_pragmas pragma-ada-05}@anchor{21} @section Pragma Ada_05 @@ -1626,6 +1635,11 @@ This pragma is useful when writing a reusable component that itself uses Ada 2005 features, but which is intended to be usable from either Ada 83 or Ada 95 programs. +Like all configuration pragmas, if the pragma is placed before a library +level package specification it is not propagated to the corresponding +package body (see RM 10.1.5(8)); it must be added explicitly to the +package body. + The one argument form (which is not a configuration pragma) is used for managing the transition from Ada 95 to Ada 2005 in the run-time library. If an entity is marked @@ -1671,6 +1685,11 @@ contexts. This pragma is useful when writing a reusable component that itself uses Ada 2012 features, but which is intended to be usable from Ada 83, Ada 95, or Ada 2005 programs. +Like all configuration pragmas, if the pragma is placed before a library +level package specification it is not propagated to the corresponding +package body (see RM 10.1.5(8)); it must be added explicitly to the +package body. + The one argument form, which is not a configuration pragma, is used for managing the transition from Ada 2005 to Ada 2012 in the run-time library. If an entity is marked @@ -1716,6 +1735,11 @@ contexts. This pragma is useful when writing a reusable component that itself uses Ada 2022 features, but which is intended to be usable from Ada 83, Ada 95, Ada 2005 or Ada 2012 programs. +Like all configuration pragmas, if the pragma is placed before a library +level package specification it is not propagated to the corresponding +package body (see RM 10.1.5(8)); it must be added explicitly to the +package body. + The one argument form, which is not a configuration pragma, is used for managing the transition from Ada 2012 to Ada 2022 in the run-time library. If an entity is marked @@ -30914,27 +30938,24 @@ that the record type must be a root type, in other words not a derived type. The aspect additionally makes it possible to specify relaxed semantics for the finalization operations by means of the @code{Relaxed_Finalization} setting. - -Example: +Here is the archetypal example: @example -type Ctrl is record - Id : Natural := 0; +type T is record + ... end record with Finalizable => (Initialize => Initialize, Adjust => Adjust, Finalize => Finalize, Relaxed_Finalization => True); -procedure Adjust (Obj : in out Ctrl); -procedure Finalize (Obj : in out Ctrl); -procedure Initialize (Obj : in out Ctrl); +procedure Adjust (Obj : in out T); +procedure Finalize (Obj : in out T); +procedure Initialize (Obj : in out T); @end example -The three procedures have the same profile, taking a single @code{in out T} -parameter. - -We follow the same dynamic semantics as controlled objects: +The three procedures have the same profile, with a single @code{in out} parameter, +and also have the same dynamic semantics as for controlled types: @quotation @@ -30943,98 +30964,49 @@ We follow the same dynamic semantics as controlled objects: @item @code{Initialize} is called when an object of type @code{T} is declared without -default expression. +initialization expression. @item @code{Adjust} is called after an object of type @code{T} is assigned a new value. @item @code{Finalize} is called when an object of type @code{T} goes out of scope (for -stack-allocated objects) or is explicitly deallocated (for heap-allocated -objects). It is also called when on the value being replaced in an -assignment. +stack-allocated objects) or is deallocated (for heap-allocated objects). +It is also called when the value is replaced by an assignment. @end itemize @end quotation -However the following differences are enforced by default when compared to the -current Ada controlled-objects finalization model: +However, when @code{Relaxed_Finalization} is either @code{True} or not explicitly +specified, the following differences are implemented relative to the semantics +of controlled types: @itemize * @item -No automatic finalization of heap allocated objects: @code{Finalize} is only -called when an object is implicitly deallocated. As a consequence, no-runtime -support is needed for the implicit case, and no header will be maintained for -this in heap-allocated controlled objects. - -Heap-allocated objects allocated through a nested access type definition will -hence `not' be deallocated either. The result is simply that memory will be -leaked in those cases. - -@item -The @code{Finalize} procedure should have have the @ref{466,,No_Raise aspect} specified. -If that’s not the case, a compilation error will be raised. -@end itemize - -Additionally, two other configuration aspects are added, -@code{Legacy_Heap_Finalization} and @code{Exceptions_In_Finalize}: +The compiler has permission to perform no automatic finalization of +heap-allocated objects: @code{Finalize} is only called when such an object +is explicitly deallocated, or when the designated object is assigned a new +value. As a consequence, no runtime support is needed for performing +implicit deallocation. In particular, no per-object header data is needed +for heap-allocated objects. - -@itemize * +Heap-allocated objects allocated through a nested access type will therefore +`not' be deallocated either. The result is simply that memory will be leaked +in this case. @item -@code{Legacy_Heap_Finalization}: Uses the legacy automatic finalization of -heap-allocated objects - -@item -@code{Exceptions_In_Finalize}: Allow users to have a finalizer that raises exceptions -`NB!' note that using this aspect introduces execution time penalities. +The @code{Adjust} and @code{Finalize} procedures are automatically considered as +having the @ref{466,,No_Raise aspect} specified for them. In particular, the +compiler has permission to enforce none of the guarantees specified by the +RM 7.6.1 (14/1) and subsequent subclauses. @end itemize -@node No_Raise aspect,Inference of Dependent Types in Generic Instantiations,Generalized Finalization,Experimental Language Extensions -@anchor{gnat_rm/gnat_language_extensions id3}@anchor{467}@anchor{gnat_rm/gnat_language_extensions no-raise-aspect}@anchor{466} -@subsection No_Raise aspect - - -The @code{No_Raise} aspect can be applied to a subprogram to declare that this subprogram is not -expected to raise any exceptions. Should an exception still occur during the execution of -this subprogram, @code{Program_Error} is raised. - -@menu -* New specification for Ada.Finalization.Controlled: New specification for Ada Finalization Controlled. -* Finalized tagged types:: -* Composite types:: -* Interoperability with controlled types:: - -@end menu - -@node New specification for Ada Finalization Controlled,Finalized tagged types,,No_Raise aspect -@anchor{gnat_rm/gnat_language_extensions new-specification-for-ada-finalization-controlled}@anchor{468} -@subsubsection New specification for @code{Ada.Finalization.Controlled} - - -@code{Ada.Finalization.Controlled} is now specified as: - -@example -type Controlled is abstract tagged null record - with Initialize => Initialize, - Adjust => Adjust, - Finalize => Finalize, - Legacy_Heap_Finalization, Exceptions_In_Finalize; - - procedure Initialize (Self : in out Controlled) is abstract; - procedure Adjust (Self : in out Controlled) is abstract; - procedure Finalize (Self : in out Controlled) is abstract; -@end example - -### Examples - -A simple example of a ref-counted type: +Simple example of ref-counted type: @example type T is record - Value : Integer; + Value : Integer; Ref_Count : Natural := 0; end record; @@ -31046,8 +31018,8 @@ type T_Access is access all T; type T_Ref is record Value : T_Access; end record - with Adjust => Adjust, - Finalize => Finalize; + with Finalizable => (Adjust => Adjust, + Finalize => Finalize); procedure Adjust (Ref : in out T_Ref) is begin @@ -31060,7 +31032,7 @@ begin end Finalize; @end example -A simple file handle that ensures resources are properly released: +Simple file handle that ensures resources are properly released: @example package P is @@ -31069,66 +31041,64 @@ package P is function Open (Path : String) return File; procedure Close (F : in out File); + private type File is limited record Handle : ...; end record - with Finalize => Close; + with Finalizable (Finalize => Close); +end P; @end example -@node Finalized tagged types,Composite types,New specification for Ada Finalization Controlled,No_Raise aspect -@anchor{gnat_rm/gnat_language_extensions finalized-tagged-types}@anchor{469} -@subsubsection Finalized tagged types - +@menu +* Finalizable tagged types:: +* Composite types:: +* Interoperability with controlled types:: -Aspects are inherited by derived types and optionally overriden by those. The -compiler-generated calls to the user-defined operations are then -dispatching whenever it makes sense, i.e. the object in question is of -class-wide type and the class includes at least one finalized tagged type. +@end menu -However note that for simplicity, it is forbidden to change the value of any of -those new aspects in derived types. +@node Finalizable tagged types,Composite types,,Generalized Finalization +@anchor{gnat_rm/gnat_language_extensions finalizable-tagged-types}@anchor{467} +@subsubsection Finalizable tagged types -@node Composite types,Interoperability with controlled types,Finalized tagged types,No_Raise aspect -@anchor{gnat_rm/gnat_language_extensions composite-types}@anchor{46a} -@subsubsection Composite types +The aspect is inherited by derived types and the primitives may be overridden +by the derivation. The compiler-generated calls to these operations are then +dispatching whenever it makes sense, i.e. when the object in question is of a +class-wide type and the class includes at least one finalizable tagged type. -When a finalized type is used as a component of a composite type, the latter -becomes finalized as well. The three primitives are derived automatically -in order to call the primitives of their components. +@node Composite types,Interoperability with controlled types,Finalizable tagged types,Generalized Finalization +@anchor{gnat_rm/gnat_language_extensions composite-types}@anchor{468} +@subsubsection Composite types -If that composite type was already user-finalized, then the compiler -calls the primitives of the components so as to stay consistent with today’s -controlled types’s behavior. -So, @code{Initialize} and @code{Adjust} are called on components before they -are called on the composite object, but @code{Finalize} is called on the composite -object first. +When a finalizable type is used as a component of a composite type, the latter +becomes finalizable as well. The three primitives are derived automatically +in order to call the primitives of their components. The dynamic semantics is +the same as for controlled components of composite types. -@node Interoperability with controlled types,,Composite types,No_Raise aspect -@anchor{gnat_rm/gnat_language_extensions interoperability-with-controlled-types}@anchor{46b} +@node Interoperability with controlled types,,Composite types,Generalized Finalization +@anchor{gnat_rm/gnat_language_extensions interoperability-with-controlled-types}@anchor{469} @subsubsection Interoperability with controlled types -As a consequence of the redefinition of the @code{Controlled} type as a base type -with the new aspects defined, interoperability with controlled type naturally -follows the definition of the above rules. In particular: - +Finalizable types are fully interoperable with controlled types, in particular +it is possible for a finalizable type to have a controlled component and vice +versa, but the stricter dynamic semantics, in other words that of controlled +types, is applied in this case. -@itemize * +@node No_Raise aspect,Inference of Dependent Types in Generic Instantiations,Generalized Finalization,Experimental Language Extensions +@anchor{gnat_rm/gnat_language_extensions id3}@anchor{46a}@anchor{gnat_rm/gnat_language_extensions no-raise-aspect}@anchor{466} +@subsection No_Raise aspect -@item -It is possible to have a new finalized type have a controlled type -component -@item -It is possible to have a controlled type have a finalized type -component -@end itemize +The @code{No_Raise} aspect can be applied to a subprogram to declare that this +subprogram is not expected to raise an exception. Should an exception still +be raised during the execution of the subprogram, it is caught at the end of +this execution and @code{Program_Error} is propagated to the caller. @node Inference of Dependent Types in Generic Instantiations,External_Initialization Aspect,No_Raise aspect,Experimental Language Extensions -@anchor{gnat_rm/gnat_language_extensions inference-of-dependent-types-in-generic-instantiations}@anchor{46c} +@anchor{gnat_rm/gnat_language_extensions inference-of-dependent-types-in-generic-instantiations}@anchor{46b} @subsection Inference of Dependent Types in Generic Instantiations @@ -31205,7 +31175,7 @@ package Int_Array_Operations is new Array_Operations @end example @node External_Initialization Aspect,Finally construct,Inference of Dependent Types in Generic Instantiations,Experimental Language Extensions -@anchor{gnat_rm/gnat_language_extensions external-initialization-aspect}@anchor{46d} +@anchor{gnat_rm/gnat_language_extensions external-initialization-aspect}@anchor{46c} @subsection External_Initialization Aspect @@ -31246,7 +31216,7 @@ The maximum size of loaded files is limited to 2@w{^31} bytes. @end cartouche @node Finally construct,,External_Initialization Aspect,Experimental Language Extensions -@anchor{gnat_rm/gnat_language_extensions finally-construct}@anchor{46e} +@anchor{gnat_rm/gnat_language_extensions finally-construct}@anchor{46d} @subsection Finally construct @@ -31263,7 +31233,7 @@ This feature is similar to the one with the same name in other languages such as @end menu @node Syntax<2>,Legality Rules<2>,,Finally construct -@anchor{gnat_rm/gnat_language_extensions id4}@anchor{46f} +@anchor{gnat_rm/gnat_language_extensions id4}@anchor{46e} @subsubsection Syntax @@ -31278,7 +31248,7 @@ handled_sequence_of_statements ::= @end example @node Legality Rules<2>,Dynamic Semantics<2>,Syntax<2>,Finally construct -@anchor{gnat_rm/gnat_language_extensions id5}@anchor{470} +@anchor{gnat_rm/gnat_language_extensions id5}@anchor{46f} @subsubsection Legality Rules @@ -31288,7 +31258,7 @@ to be transferred outside the finally part are forbidden. Goto & exit where the target is outside of the finally’s @code{sequence_of_statements} are forbidden @node Dynamic Semantics<2>,,Legality Rules<2>,Finally construct -@anchor{gnat_rm/gnat_language_extensions id6}@anchor{471} +@anchor{gnat_rm/gnat_language_extensions id6}@anchor{470} @subsubsection Dynamic Semantics @@ -31303,7 +31273,7 @@ execution, that is the finally block must be executed in full even if the contai aborted, or if the control is transferred out of the block. @node Security Hardening Features,Obsolescent Features,GNAT language extensions,Top -@anchor{gnat_rm/security_hardening_features doc}@anchor{472}@anchor{gnat_rm/security_hardening_features id1}@anchor{473}@anchor{gnat_rm/security_hardening_features security-hardening-features}@anchor{15} +@anchor{gnat_rm/security_hardening_features doc}@anchor{471}@anchor{gnat_rm/security_hardening_features id1}@anchor{472}@anchor{gnat_rm/security_hardening_features security-hardening-features}@anchor{15} @chapter Security Hardening Features @@ -31325,7 +31295,7 @@ change. @end menu @node Register Scrubbing,Stack Scrubbing,,Security Hardening Features -@anchor{gnat_rm/security_hardening_features register-scrubbing}@anchor{474} +@anchor{gnat_rm/security_hardening_features register-scrubbing}@anchor{473} @section Register Scrubbing @@ -31361,7 +31331,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{475} +@anchor{gnat_rm/security_hardening_features stack-scrubbing}@anchor{474} @section Stack Scrubbing @@ -31505,7 +31475,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{476} +@anchor{gnat_rm/security_hardening_features hardened-conditionals}@anchor{475} @section Hardened Conditionals @@ -31595,7 +31565,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{477} +@anchor{gnat_rm/security_hardening_features hardened-booleans}@anchor{476} @section Hardened Booleans @@ -31656,7 +31626,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{478} +@anchor{gnat_rm/security_hardening_features control-flow-redundancy}@anchor{477} @section Control Flow Redundancy @@ -31824,7 +31794,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{479}@anchor{gnat_rm/obsolescent_features id1}@anchor{47a}@anchor{gnat_rm/obsolescent_features obsolescent-features}@anchor{16} +@anchor{gnat_rm/obsolescent_features doc}@anchor{478}@anchor{gnat_rm/obsolescent_features id1}@anchor{479}@anchor{gnat_rm/obsolescent_features obsolescent-features}@anchor{16} @chapter Obsolescent Features @@ -31843,7 +31813,7 @@ compatibility purposes. @end menu @node pragma No_Run_Time,pragma Ravenscar,,Obsolescent Features -@anchor{gnat_rm/obsolescent_features id2}@anchor{47b}@anchor{gnat_rm/obsolescent_features pragma-no-run-time}@anchor{47c} +@anchor{gnat_rm/obsolescent_features id2}@anchor{47a}@anchor{gnat_rm/obsolescent_features pragma-no-run-time}@anchor{47b} @section pragma No_Run_Time @@ -31856,7 +31826,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{47d}@anchor{gnat_rm/obsolescent_features pragma-ravenscar}@anchor{47e} +@anchor{gnat_rm/obsolescent_features id3}@anchor{47c}@anchor{gnat_rm/obsolescent_features pragma-ravenscar}@anchor{47d} @section pragma Ravenscar @@ -31865,7 +31835,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{47f}@anchor{gnat_rm/obsolescent_features pragma-restricted-run-time}@anchor{480} +@anchor{gnat_rm/obsolescent_features id4}@anchor{47e}@anchor{gnat_rm/obsolescent_features pragma-restricted-run-time}@anchor{47f} @section pragma Restricted_Run_Time @@ -31875,7 +31845,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{481}@anchor{gnat_rm/obsolescent_features pragma-task-info}@anchor{482} +@anchor{gnat_rm/obsolescent_features id5}@anchor{480}@anchor{gnat_rm/obsolescent_features pragma-task-info}@anchor{481} @section pragma Task_Info @@ -31901,7 +31871,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{483}@anchor{gnat_rm/obsolescent_features package-system-task-info-s-tasinf-ads}@anchor{484} +@anchor{gnat_rm/obsolescent_features package-system-task-info}@anchor{482}@anchor{gnat_rm/obsolescent_features package-system-task-info-s-tasinf-ads}@anchor{483} @section package System.Task_Info (@code{s-tasinf.ads}) @@ -31911,7 +31881,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{485}@anchor{gnat_rm/compatibility_and_porting_guide compatibility-and-porting-guide}@anchor{17}@anchor{gnat_rm/compatibility_and_porting_guide id1}@anchor{486} +@anchor{gnat_rm/compatibility_and_porting_guide doc}@anchor{484}@anchor{gnat_rm/compatibility_and_porting_guide compatibility-and-porting-guide}@anchor{17}@anchor{gnat_rm/compatibility_and_porting_guide id1}@anchor{485} @chapter Compatibility and Porting Guide @@ -31933,7 +31903,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{487}@anchor{gnat_rm/compatibility_and_porting_guide writing-portable-fixed-point-declarations}@anchor{488} +@anchor{gnat_rm/compatibility_and_porting_guide id2}@anchor{486}@anchor{gnat_rm/compatibility_and_porting_guide writing-portable-fixed-point-declarations}@anchor{487} @section Writing Portable Fixed-Point Declarations @@ -32055,7 +32025,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{489}@anchor{gnat_rm/compatibility_and_porting_guide id3}@anchor{48a} +@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-ada-83}@anchor{488}@anchor{gnat_rm/compatibility_and_porting_guide id3}@anchor{489} @section Compatibility with Ada 83 @@ -32083,7 +32053,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{48b}@anchor{gnat_rm/compatibility_and_porting_guide legal-ada-83-programs-that-are-illegal-in-ada-95}@anchor{48c} +@anchor{gnat_rm/compatibility_and_porting_guide id4}@anchor{48a}@anchor{gnat_rm/compatibility_and_porting_guide legal-ada-83-programs-that-are-illegal-in-ada-95}@anchor{48b} @subsection Legal Ada 83 programs that are illegal in Ada 95 @@ -32183,7 +32153,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{48d}@anchor{gnat_rm/compatibility_and_porting_guide more-deterministic-semantics}@anchor{48e} +@anchor{gnat_rm/compatibility_and_porting_guide id5}@anchor{48c}@anchor{gnat_rm/compatibility_and_porting_guide more-deterministic-semantics}@anchor{48d} @subsection More deterministic semantics @@ -32211,7 +32181,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{48f}@anchor{gnat_rm/compatibility_and_porting_guide id6}@anchor{490} +@anchor{gnat_rm/compatibility_and_porting_guide changed-semantics}@anchor{48e}@anchor{gnat_rm/compatibility_and_porting_guide id6}@anchor{48f} @subsection Changed semantics @@ -32253,7 +32223,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{491}@anchor{gnat_rm/compatibility_and_porting_guide other-language-compatibility-issues}@anchor{492} +@anchor{gnat_rm/compatibility_and_porting_guide id7}@anchor{490}@anchor{gnat_rm/compatibility_and_porting_guide other-language-compatibility-issues}@anchor{491} @subsection Other language compatibility issues @@ -32286,7 +32256,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{493}@anchor{gnat_rm/compatibility_and_porting_guide id8}@anchor{494} +@anchor{gnat_rm/compatibility_and_porting_guide compatibility-between-ada-95-and-ada-2005}@anchor{492}@anchor{gnat_rm/compatibility_and_porting_guide id8}@anchor{493} @section Compatibility between Ada 95 and Ada 2005 @@ -32358,7 +32328,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{495}@anchor{gnat_rm/compatibility_and_porting_guide implementation-dependent-characteristics}@anchor{496} +@anchor{gnat_rm/compatibility_and_porting_guide id9}@anchor{494}@anchor{gnat_rm/compatibility_and_porting_guide implementation-dependent-characteristics}@anchor{495} @section Implementation-dependent characteristics @@ -32381,7 +32351,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{497}@anchor{gnat_rm/compatibility_and_porting_guide implementation-defined-pragmas}@anchor{498} +@anchor{gnat_rm/compatibility_and_porting_guide id10}@anchor{496}@anchor{gnat_rm/compatibility_and_porting_guide implementation-defined-pragmas}@anchor{497} @subsection Implementation-defined pragmas @@ -32403,7 +32373,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{499}@anchor{gnat_rm/compatibility_and_porting_guide implementation-defined-attributes}@anchor{49a} +@anchor{gnat_rm/compatibility_and_porting_guide id11}@anchor{498}@anchor{gnat_rm/compatibility_and_porting_guide implementation-defined-attributes}@anchor{499} @subsection Implementation-defined attributes @@ -32417,7 +32387,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{49b}@anchor{gnat_rm/compatibility_and_porting_guide libraries}@anchor{49c} +@anchor{gnat_rm/compatibility_and_porting_guide id12}@anchor{49a}@anchor{gnat_rm/compatibility_and_porting_guide libraries}@anchor{49b} @subsection Libraries @@ -32446,7 +32416,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{49d}@anchor{gnat_rm/compatibility_and_porting_guide id13}@anchor{49e} +@anchor{gnat_rm/compatibility_and_porting_guide elaboration-order}@anchor{49c}@anchor{gnat_rm/compatibility_and_porting_guide id13}@anchor{49d} @subsection Elaboration order @@ -32482,7 +32452,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{49f}@anchor{gnat_rm/compatibility_and_porting_guide target-specific-aspects}@anchor{4a0} +@anchor{gnat_rm/compatibility_and_porting_guide id14}@anchor{49e}@anchor{gnat_rm/compatibility_and_porting_guide target-specific-aspects}@anchor{49f} @subsection Target-specific aspects @@ -32495,10 +32465,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{4a1,,Representation Clauses}. +GNAT’s approach to these issues is described in @ref{4a0,,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{4a2}@anchor{gnat_rm/compatibility_and_porting_guide id15}@anchor{4a3} +@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-other-ada-systems}@anchor{4a1}@anchor{gnat_rm/compatibility_and_porting_guide id15}@anchor{4a2} @section Compatibility with Other Ada Systems @@ -32541,7 +32511,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{4a4}@anchor{gnat_rm/compatibility_and_porting_guide representation-clauses}@anchor{4a1} +@anchor{gnat_rm/compatibility_and_porting_guide id16}@anchor{4a3}@anchor{gnat_rm/compatibility_and_porting_guide representation-clauses}@anchor{4a0} @section Representation Clauses @@ -32634,7 +32604,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{4a5}@anchor{gnat_rm/compatibility_and_porting_guide id17}@anchor{4a6} +@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-hp-ada-83}@anchor{4a4}@anchor{gnat_rm/compatibility_and_porting_guide id17}@anchor{4a5} @section Compatibility with HP Ada 83 @@ -32664,7 +32634,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{4a7}@anchor{share/gnu_free_documentation_license gnu-fdl}@anchor{1}@anchor{share/gnu_free_documentation_license gnu-free-documentation-license}@anchor{4a8} +@anchor{share/gnu_free_documentation_license doc}@anchor{4a6}@anchor{share/gnu_free_documentation_license gnu-fdl}@anchor{1}@anchor{share/gnu_free_documentation_license gnu-free-documentation-license}@anchor{4a7} @chapter GNU Free Documentation License diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index ca1d7bc..639708b 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -2911,6 +2911,10 @@ You can place configuration pragmas either appear at the start of a compilation unit or in a configuration pragma file that applies to all compilations performed in a given compilation environment. +Configuration pragmas placed before a library level package specification +are not propagated to the corresponding package body (see RM 10.1.5(8)); +they must be added explicitly to the package body. + GNAT includes the @code{gnatchop} utility to provide an automatic way to handle configuration pragmas that follows the semantics for compilations (that is, files with multiple units) described in the RM. @@ -9846,7 +9850,7 @@ Treat pragma Restrictions as Restriction_Warnings. @table @asis -@item @code{-gnatR[0|1|2|3|4][e][j][m][s]} +@item @code{-gnatR[0|1|2|3|4][e][h][m][j][s]} Output representation information for declared types, objects and subprograms. Note that this switch is not allowed if a previous @@ -10072,7 +10076,7 @@ Library (RTL) ALI files. @code{n} controls the optimization level: -@multitable {xxxxxxxxx} {xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx} +@multitable {xxxxxxxxx} {xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx} @item `n' @@ -10087,7 +10091,7 @@ Effect @tab -No optimization, the default setting if no @code{-O} appears +No optimization, the default setting if no @code{-O} appears. @item @@ -10095,9 +10099,8 @@ No optimization, the default setting if no @code{-O} appears @tab -Normal optimization, the default if you specify @code{-O} without an -operand. A good compromise between code quality and compilation -time. +Moderate optimization, same as @code{-O} without an operand. +A good compromise between code quality and compilation time. @item @@ -10105,7 +10108,7 @@ time. @tab -Extensive optimization, may improve execution time, possibly at +Extensive optimization, should improve execution time, possibly at the cost of substantially increased compilation time. @item @@ -10114,8 +10117,8 @@ the cost of substantially increased compilation time. @tab -Same as @code{-O2}, and also includes inline expansion for small -subprograms in the same unit. +Full optimization, may further improve execution time, possibly at +the cost of substantially larger generated code. @item @@ -10123,7 +10126,23 @@ subprograms in the same unit. @tab -Optimize space usage +Optimize for size (code and data) rather than speed. + +@item + +`z' + +@tab + +Optimize aggressively for size (code and data) rather than speed. + +@item + +`g' + +@tab + +Optimize for debugging experience rather than speed. @end multitable @@ -15266,7 +15285,7 @@ restriction warnings rather than restrictions. @table @asis -@item @code{-gnatR[0|1|2|3|4][e][j][m][s]} +@item @code{-gnatR[0|1|2|3|4][e][h][m][j][s]} This switch controls output from the compiler of a listing showing representation information for declared types, objects and subprograms. @@ -15295,17 +15314,21 @@ If the switch is followed by an @code{e} (e.g. @code{-gnatR2e}), then extended representation information for record sub-components of records is included. +If the switch is followed by a @code{h} (e.g. @code{-gnatR3h}), then +the components of records are sorted by increasing offsets and holes +between consecutive components are flagged. + If the switch is followed by an @code{m} (e.g. @code{-gnatRm}), then subprogram conventions and parameter passing mechanisms for all the subprograms are included. -If the switch is followed by a @code{j} (e.g., @code{-gnatRj}), then +If the switch is followed by a @code{j} (e.g. @code{-gnatRj}), then the output is in the JSON data interchange format specified by the ECMA-404 standard. The semantic description of this JSON output is available in the specification of the Repinfo unit present in the compiler sources. -If the switch is followed by an @code{s} (e.g., @code{-gnatR3s}), then +If the switch is followed by an @code{s} (e.g. @code{-gnatR3s}), then the output is to a file with the name @code{file.rep} where @code{file} is the name of the corresponding source file, except if @code{j} is also specified, in which case the file name is @code{file.json}. @@ -20277,13 +20300,12 @@ Turning on optimization makes the compiler attempt to improve the performance and/or code size at the expense of compilation time and possibly the ability to debug the program. -If you use multiple @code{-O} switches, with or without level -numbers, the last such switch is the one that’s used. - -You can use the -@code{-O} switch (the permitted forms are @code{-O0}, @code{-O1} -@code{-O2}, @code{-O3}, and @code{-Os}) -to @code{gcc} to control the optimization level: +You can pass the @code{-O} switch, with or without an operand +(the permitted forms with an operand are @code{-O0}, @code{-O1}, +@code{-O2}, @code{-O3}, @code{-Os}, @code{-Oz}, and +@code{-Og}) to @code{gcc} to control the optimization level. If you +pass multiple @code{-O} switches, with or without an operand, +the last such switch is the one that’s used: @itemize * @@ -20294,8 +20316,7 @@ to @code{gcc} to control the optimization level: @item @code{-O0} -No optimization (the default); -generates unoptimized code but has +No optimization (the default); generates unoptimized code but has the fastest compilation time. Debugging is easiest with this switch. Note that many other compilers do substantial optimization even if @@ -20312,10 +20333,11 @@ mind when doing performance comparisons. @item @code{-O1} -Moderate optimization; optimizes reasonably well but does not -degrade compilation time significantly. You may not be able to see -some variables in the debugger and changing the value of some -variables in the debugger may not have the effect you desire. +Moderate optimization (same as @code{-O} without an operand); +optimizes reasonably well but does not degrade compilation time +significantly. You may not be able to see some variables in the +debugger, and changing the value of some variables in the debugger +may not have the effect you desire. @end table @item @@ -20324,9 +20346,8 @@ variables in the debugger may not have the effect you desire. @item @code{-O2} -Full optimization; -generates highly optimized code and has -the slowest compilation time. You may see significant impacts on +Extensive optimization; generates highly optimized code but has +an increased compilation time. You may see significant impacts on your ability to display and modify variables in the debugger. @end table @@ -20336,9 +20357,9 @@ your ability to display and modify variables in the debugger. @item @code{-O3} -Full optimization as in @code{-O2}; -also uses more aggressive automatic inlining of subprograms within a unit -(@ref{104,,Inlining of Subprograms}) and attempts to vectorize loops. +Full optimization; attempts more sophisticated transformations, in +particular on loops, possibly at the cost of larger generated code. +You may be hardly able to use the debugger at this optimization level. @end table @item @@ -20347,16 +20368,41 @@ also uses more aggressive automatic inlining of subprograms within a unit @item @code{-Os} -Optimize space usage (code and data) of resulting program. +Optimize for size (code and data) of resulting binary rather than +speed; based on the @code{-O2} optimization level, but disables +some of its transformations that often increase code size, as well +as performs further optimizations designed to reduce code size. +@end table + +@item + +@table @asis + +@item @code{-Oz} + +Optimize aggressively for size (code and data) of resulting binary +rather than speed; may increase the number of instructions executed +if these instructions require fewer bytes to be encoded. +@end table + +@item + +@table @asis + +@item @code{-Og} + +Optimize for debugging experience rather than speed; based on the +@code{-O1} optimization level, but attempts to eliminate all the +negative effects of optimization on debugging. @end table @end itemize Higher optimization levels perform more global transformations on the program and apply more expensive analysis algorithms in order to generate faster and more compact code. The price in compilation time, and the -resulting improvement in execution time, -both depend on the particular application and the hardware environment. -You should experiment to find the best level for your application. +resulting improvement in execution time, both depend on the particular +application and the hardware environment. You should experiment to find +the best level for your application. Since the precise set of optimizations done at each level will vary from release to release (and sometime from target to target), it is best to think @@ -29833,8 +29879,8 @@ to permit their use in free software. @printindex ge -@anchor{gnat_ugn/gnat_utility_programs switches-related-to-project-files}@w{ } @anchor{d2}@w{ } +@anchor{gnat_ugn/gnat_utility_programs switches-related-to-project-files}@w{ } @c %**end of body @bye diff --git a/gcc/ada/gnatcmd.adb b/gcc/ada/gnatcmd.adb index 546dbca..5e3802e 100644 --- a/gcc/ada/gnatcmd.adb +++ b/gcc/ada/gnatcmd.adb @@ -368,7 +368,7 @@ begin -- --help flag. Set_Standard_Output; Write_Eol; - Write_Line ("Report bugs to report@adacore.com"); + Write_Line ("Report bugs to support@adacore.com"); return; end if; diff --git a/gcc/ada/inline.adb b/gcc/ada/inline.adb index abb49b5..72b9989 100644 --- a/gcc/ada/inline.adb +++ b/gcc/ada/inline.adb @@ -1006,9 +1006,9 @@ package body Inline is end loop; -- The list of inlined subprograms is an overestimate, because it - -- includes inlined functions called from functions that are compiled - -- as part of an inlined package, but are not themselves called. An - -- accurate computation of just those subprograms that are needed + -- includes inlined subprograms called from subprograms that are + -- declared in an inlined package, but are not themselves called. + -- An accurate computation of just those subprograms that are needed -- requires that we perform a transitive closure over the call graph, -- starting from calls in the main compilation unit. @@ -4924,11 +4924,17 @@ package body Inline is and then Ekind (Info.Fin_Scop) = E_Package_Body then Set_In_Package_Body (Spec_Entity (Info.Fin_Scop), True); + Instantiate_Package_Body (Info); + Set_In_Package_Body (Spec_Entity (Info.Fin_Scop), False); + else + Instantiate_Package_Body (Info); end if; - Instantiate_Package_Body (Info); + -- No need to generate cleanups if the main unit is generic - if Present (Info.Fin_Scop) then + if Present (Info.Fin_Scop) + and then not Is_Generic_Unit (Main_Unit_Entity) + then Scop := Info.Fin_Scop; -- If the enclosing finalization scope is dynamic, the instance @@ -4941,12 +4947,6 @@ package body Inline is end if; Add_Scope_To_Clean (Scop); - - -- Reset the In_Package_Body flag if it was set above - - if Ekind (Info.Fin_Scop) = E_Package_Body then - Set_In_Package_Body (Spec_Entity (Info.Fin_Scop), False); - end if; end if; -- For subprogram instances, always instantiate the body @@ -4967,10 +4967,6 @@ package body Inline is Push_Scope (Standard_Standard); To_Clean := New_Elmt_List; - if Is_Generic_Unit (Cunit_Entity (Main_Unit)) then - Start_Generic; - end if; - -- A body instantiation may generate additional instantiations, so -- the following loop must scan to the end of a possibly expanding -- set (that's why we cannot simply use a FOR loop here). We must @@ -5009,16 +5005,10 @@ package body Inline is Pending_Instantiations.Init; end if; - -- We can now complete the cleanup actions of scopes that contain - -- pending instantiations (skipped for generic units, since we - -- never need any cleanups in generic units). + -- Expand the cleanup actions of scopes that contain instantiations - if Expander_Active - and then not Is_Generic_Unit (Main_Unit_Entity) - then + if Expander_Active then Cleanup_Scopes; - elsif Is_Generic_Unit (Cunit_Entity (Main_Unit)) then - End_Generic; end if; Pop_Scope; diff --git a/gcc/ada/lib.adb b/gcc/ada/lib.adb index 2c6a682..a727f48 100644 --- a/gcc/ada/lib.adb +++ b/gcc/ada/lib.adb @@ -1129,15 +1129,6 @@ package body Lib is Units.Locked := True; end Lock; - --------------- - -- Num_Units -- - --------------- - - function Num_Units return Nat is - begin - return Int (Units.Last) - Int (Main_Unit) + 1; - end Num_Units; - ----------------- -- Remove_Unit -- ----------------- diff --git a/gcc/ada/lib.ads b/gcc/ada/lib.ads index c22db30..a085aa7 100644 --- a/gcc/ada/lib.ads +++ b/gcc/ada/lib.ads @@ -633,10 +633,8 @@ package Lib is -- Same as above, but for Source_Ptr function ipu (N : Node_Or_Entity_Id) return Boolean; - -- Same as In_Predefined_Unit, but renamed so it can assist debugging. - -- Otherwise, there is a disambiguous name conflict in the two versions of - -- In_Predefined_Unit which makes it inconvient to set as a breakpoint - -- condition. + -- Same as In_Predefined_Unit, but renamed to this unambiguous name for use + -- in the debugger. function In_Predefined_Unit (N : Node_Or_Entity_Id) return Boolean; -- Returns True if the given node or entity appears within the source text @@ -720,12 +718,9 @@ package Lib is procedure Lock; -- Lock internal tables before calling back end - function Num_Units return Nat; - -- Number of units currently in unit table - procedure Remove_Unit (U : Unit_Number_Type); - -- Remove unit U from unit table. Currently this is effective only if U is - -- the last unit currently stored in the unit table. + -- Remove unit U from unit table. U must be the last unit currently stored + -- in the unit table. procedure Replace_Linker_Option_String (S : String_Id; diff --git a/gcc/ada/libgnarl/s-stusta.adb b/gcc/ada/libgnarl/s-stusta.adb index 5aca435..c9848a0 100644 --- a/gcc/ada/libgnarl/s-stusta.adb +++ b/gcc/ada/libgnarl/s-stusta.adb @@ -32,6 +32,7 @@ -- This is why this package is part of GNARL: with System.Tasking.Debug; +with System.Tasking.Stages; with System.Task_Primitives.Operations; with System.IO; @@ -103,7 +104,9 @@ package body System.Stack_Usage.Tasking is -- Calculate the task usage for a given task - Report_For_Task (Id); + if not System.Tasking.Stages.Terminated (Id) then + Report_For_Task (Id); + end if; end loop; end if; diff --git a/gcc/ada/libgnat/i-cheri.adb b/gcc/ada/libgnat/i-cheri.adb index 37e5c3d..1575705 100644 --- a/gcc/ada/libgnat/i-cheri.adb +++ b/gcc/ada/libgnat/i-cheri.adb @@ -31,6 +31,30 @@ package body Interfaces.CHERI is + ---------------- + -- Set_Bounds -- + ---------------- + + procedure Set_Bounds + (Cap : in out Capability; + Length : Bounds_Length) + is + begin + Cap := Capability_With_Bounds (Cap, Length); + end Set_Bounds; + + ---------------------- + -- Set_Exact_Bounds -- + ---------------------- + + procedure Set_Exact_Bounds + (Cap : in out Capability; + Length : Bounds_Length) + is + begin + Cap := Capability_With_Exact_Bounds (Cap, Length); + end Set_Exact_Bounds; + ---------------------------- -- Set_Address_And_Bounds -- ---------------------------- diff --git a/gcc/ada/libgnat/i-cheri.ads b/gcc/ada/libgnat/i-cheri.ads index ed26e55..4186b6d 100644 --- a/gcc/ada/libgnat/i-cheri.ads +++ b/gcc/ada/libgnat/i-cheri.ads @@ -273,8 +273,7 @@ is (Cap : in out Capability; Length : Bounds_Length) with - Import, Convention => Intrinsic, - External_Name => "__builtin_cheri_bounds_set"; + Inline; -- Narrow the bounds of a capability so that the lower bound is the -- current address and the upper bound is suitable for the Length. -- @@ -287,8 +286,7 @@ is (Cap : in out Capability; Length : Bounds_Length) with - Import, Convention => Intrinsic, - External_Name => "__builtin_cheri_bounds_set_exact"; + Inline; -- Narrow the bounds of a capability so that the lower bound is the -- current address and the upper bound is suitable for the Length. -- diff --git a/gcc/ada/libgnat/s-dorepr.adb b/gcc/ada/libgnat/s-dorepr.adb index ddc7c1d..1d9604a 100644 --- a/gcc/ada/libgnat/s-dorepr.adb +++ b/gcc/ada/libgnat/s-dorepr.adb @@ -134,7 +134,7 @@ package body Product is Ahi, Alo, Bhi, Blo, E : Num; begin - if Is_Infinity (P) or else Is_Zero (P) then + if Is_Infinity_Or_NaN (P) or else Is_Zero (P) then return (P, 0.0); else @@ -157,7 +157,7 @@ package body Product is Hi, Lo, E : Num; begin - if Is_Infinity (Q) or else Is_Zero (Q) then + if Is_Infinity_Or_NaN (Q) or else Is_Zero (Q) then return (Q, 0.0); else diff --git a/gcc/ada/libgnat/s-dorepr__fma.adb b/gcc/ada/libgnat/s-dorepr__fma.adb index 0d3dc53..45a9223 100644 --- a/gcc/ada/libgnat/s-dorepr__fma.adb +++ b/gcc/ada/libgnat/s-dorepr__fma.adb @@ -78,7 +78,7 @@ package body Product is E : Num; begin - if Is_Infinity (P) or else Is_Zero (P) then + if Is_Infinity_Or_NaN (P) or else Is_Zero (P) then return (P, 0.0); else diff --git a/gcc/ada/libgnat/s-dourea.adb b/gcc/ada/libgnat/s-dourea.adb index a37f2eb..68d4d9a 100644 --- a/gcc/ada/libgnat/s-dourea.adb +++ b/gcc/ada/libgnat/s-dourea.adb @@ -34,12 +34,12 @@ package body System.Double_Real is function Is_NaN (N : Num) return Boolean is (N /= N); -- Return True if N is a NaN - function Is_Infinity (N : Num) return Boolean is (Is_NaN (N - N)); - -- Return True if N is an infinity. Used to avoid propagating meaningless - -- errors when the result of a product is an infinity. + function Is_Infinity_Or_NaN (N : Num) return Boolean is (Is_NaN (N - N)); + -- Return True if N is either an infinity or NaN. Used to avoid propagating + -- meaningless errors when the result of a product is an infinity or NaN. function Is_Zero (N : Num) return Boolean is (N = -N); - -- Return True if N is a Zero. Used to preserve the sign when the result of + -- Return True if N is a zero. Used to preserve the sign when the result of -- a product is a zero. package Product is @@ -151,7 +151,7 @@ package body System.Double_Real is P : constant Double_T := Two_Prod (A.Hi, B); begin - if Is_Infinity (P.Hi) or else Is_Zero (P.Hi) then + if Is_Infinity_Or_NaN (P.Hi) or else Is_Zero (P.Hi) then return (P.Hi, 0.0); else return Quick_Two_Sum (P.Hi, P.Lo + A.Lo * B); @@ -162,7 +162,7 @@ package body System.Double_Real is P : constant Double_T := Two_Prod (A.Hi, B.Hi); begin - if Is_Infinity (P.Hi) or else Is_Zero (P.Hi) then + if Is_Infinity_Or_NaN (P.Hi) or else Is_Zero (P.Hi) then return (P.Hi, 0.0); else return Quick_Two_Sum (P.Hi, P.Lo + A.Hi * B.Lo + A.Lo * B.Hi); @@ -178,7 +178,7 @@ package body System.Double_Real is P, R : Double_T; begin - if Is_Infinity (B) or else Is_Zero (B) then + if Is_Infinity_Or_NaN (B) or else Is_Zero (B) then return (A.Hi / B, 0.0); end if; pragma Annotate (CodePeer, Intentional, "test always false", @@ -202,7 +202,7 @@ package body System.Double_Real is R, S : Double_T; begin - if Is_Infinity (B.Hi) or else Is_Zero (B.Hi) then + if Is_Infinity_Or_NaN (B.Hi) or else Is_Zero (B.Hi) then return (A.Hi / B.Hi, 0.0); end if; pragma Annotate (CodePeer, Intentional, "test always false", @@ -228,7 +228,7 @@ package body System.Double_Real is Q : constant Double_T := Two_Sqr (A.Hi); begin - if Is_Infinity (Q.Hi) or else Is_Zero (Q.Hi) then + if Is_Infinity_Or_NaN (Q.Hi) or else Is_Zero (Q.Hi) then return (Q.Hi, 0.0); else return Quick_Two_Sum (Q.Hi, Q.Lo + 2.0 * A.Hi * A.Lo + A.Lo * A.Lo); diff --git a/gcc/ada/libgnat/s-secsta.adb b/gcc/ada/libgnat/s-secsta.adb index 2749658..9d78b86 100644 --- a/gcc/ada/libgnat/s-secsta.adb +++ b/gcc/ada/libgnat/s-secsta.adb @@ -633,6 +633,15 @@ package body System.Secondary_Stack is if Over_Aligning then Padding := Alignment; + + -- Typically the padding would be + -- Alignment - (Addr mod Alignment) + -- however Addr in this case is not known yet. It depends on the + -- type of the secondary stack (Dynamic/Static). The allocation + -- routine for the respective type of stack requires to know the + -- allocation size before the address is known. To ensure a + -- sufficient allocation size to fit the padding, the padding is + -- calculated conservatively. end if; -- Round the requested size (plus the needed padding in case of diff --git a/gcc/ada/libgnat/s-secsta__cheri.adb b/gcc/ada/libgnat/s-secsta__cheri.adb index a24b50e..9a65ed28 100644 --- a/gcc/ada/libgnat/s-secsta__cheri.adb +++ b/gcc/ada/libgnat/s-secsta__cheri.adb @@ -662,6 +662,15 @@ package body System.Secondary_Stack is if Over_Aligning then Over_Align_Padding := Alignment; + + -- Typically the padding would be + -- Alignment - (Addr mod Alignment) + -- however Addr in this case is not known yet. It depends on the + -- type of the secondary stack (Dynamic/Static). The allocation + -- routine for the respective type of stack requires to know the + -- allocation size before the address is known. To ensure a + -- sufficient allocation size to fit the padding, the padding is + -- calculated conservatively. end if; -- It should not be possible to request an allocation of negative diff --git a/gcc/ada/libgnat/s-vafi128.ads b/gcc/ada/libgnat/s-vafi128.ads index 7518c6c..d75857a 100644 --- a/gcc/ada/libgnat/s-vafi128.ads +++ b/gcc/ada/libgnat/s-vafi128.ads @@ -29,9 +29,9 @@ -- -- ------------------------------------------------------------------------------ --- This package contains routines for scanning values for ordinary fixed point --- types up to 128-bit small and mantissa, for use in Text_IO.Decimal_IO, and --- the Value attribute for such decimal types. +-- This package contains the routines for supporting the Value attribute for +-- ordinary fixed point types up to 128-bit small and mantissa, and also for +-- conversion operations required in Text_IO.Fixed_IO for such types. with Interfaces; with System.Arith_128; diff --git a/gcc/ada/libgnat/s-vafi32.ads b/gcc/ada/libgnat/s-vafi32.ads index e3ad5c2..7ed22c6 100644 --- a/gcc/ada/libgnat/s-vafi32.ads +++ b/gcc/ada/libgnat/s-vafi32.ads @@ -29,9 +29,9 @@ -- -- ------------------------------------------------------------------------------ --- This package contains routines for scanning values for decimal fixed point --- types up to 32-bit small and mantissa, for use in Text_IO.Decimal_IO, and --- the Value attribute for such decimal types. +-- This package contains the routines for supporting the Value attribute for +-- ordinary fixed point types up to 32-bit small and mantissa, and also for +-- conversion operations required in Text_IO.Fixed_IO for such types. with Interfaces; with System.Arith_32; diff --git a/gcc/ada/libgnat/s-vafi64.ads b/gcc/ada/libgnat/s-vafi64.ads index 4d86939..43197bb 100644 --- a/gcc/ada/libgnat/s-vafi64.ads +++ b/gcc/ada/libgnat/s-vafi64.ads @@ -29,9 +29,9 @@ -- -- ------------------------------------------------------------------------------ --- This package contains routines for scanning values for decimal fixed point --- types up to 64-bit small and mantissa, for use in Text_IO.Decimal_IO, and --- the Value attribute for such decimal types. +-- This package contains the routines for supporting the Value attribute for +-- ordinary fixed point types up to 64-bit small and mantissa, and also for +-- conversion operations required in Text_IO.Fixed_IO for such types. with Interfaces; with System.Arith_64; diff --git a/gcc/ada/libgnat/s-valued.adb b/gcc/ada/libgnat/s-valued.adb index dfef9a88..cc2cffc 100644 --- a/gcc/ada/libgnat/s-valued.adb +++ b/gcc/ada/libgnat/s-valued.adb @@ -39,13 +39,15 @@ package body System.Value_D is -- We need an unsigned type large enough to represent the mantissa package Impl is new Value_R (Uns, 1, 2**(Int'Size - 1), Round => False); - -- We do not use the Extra digit for decimal fixed-point types + -- We do not use the Extra digit for decimal fixed-point types, except to + -- effectively ensure that overflow is detected near the boundaries. function Integer_to_Decimal (Str : String; Val : Uns; Base : Unsigned; ScaleB : Integer; + Extra : Unsigned; Minus : Boolean; Scale : Integer) return Int; -- Convert the real value from integer to decimal representation @@ -59,6 +61,7 @@ package body System.Value_D is Val : Uns; Base : Unsigned; ScaleB : Integer; + Extra : Unsigned; Minus : Boolean; Scale : Integer) return Int is @@ -126,6 +129,10 @@ package body System.Value_D is end if; end Unsigned_To_Signed; + -- Local variables + + E : Uns := Uns (Extra); + begin -- If the base of the value is 10 or its scaling factor is zero, then -- add the scales (they are defined in the opposite sense) and apply @@ -143,9 +150,10 @@ package body System.Value_D is end loop; while S > 0 loop - if V <= Uns'Last / 10 then - V := V * 10; + if V <= (Uns'Last - E) / 10 then + V := V * 10 + E; S := S - 1; + E := 0; else Bad_Value (Str); end if; @@ -193,8 +201,9 @@ package body System.Value_D is Z := 10 ** Integer'Max (0, -Scale); for J in 1 .. LS loop - if V <= Uns'Last / Uns (B) then - V := V * Uns (B); + if V <= (Uns'Last - E) / Uns (B) then + V := V * Uns (B) + E; + E := 0; else Bad_Value (Str); end if; @@ -207,7 +216,7 @@ package body System.Value_D is raise Program_Error; end if; - -- Perform a scale divide operation with rounding to match 'Image + -- Perform a scaled divide operation with rounding to match 'Image Scaled_Divide (Unsigned_To_Signed (V), Y, Z, Q, R, Round => True); @@ -238,7 +247,8 @@ package body System.Value_D is begin Val := Impl.Scan_Raw_Real (Str, Ptr, Max, Base, Scl, Extra, Minus); - return Integer_to_Decimal (Str, Val (1), Base, Scl (1), Minus, Scale); + return + Integer_to_Decimal (Str, Val (1), Base, Scl (1), Extra, Minus, Scale); end Scan_Decimal; ------------------- @@ -255,7 +265,8 @@ package body System.Value_D is begin Val := Impl.Value_Raw_Real (Str, Base, Scl, Extra, Minus); - return Integer_to_Decimal (Str, Val (1), Base, Scl (1), Minus, Scale); + return + Integer_to_Decimal (Str, Val (1), Base, Scl (1), Extra, Minus, Scale); end Value_Decimal; end System.Value_D; diff --git a/gcc/ada/libgnat/s-valuef.adb b/gcc/ada/libgnat/s-valuef.adb index 9930740..7baa3b3 100644 --- a/gcc/ada/libgnat/s-valuef.adb +++ b/gcc/ada/libgnat/s-valuef.adb @@ -156,6 +156,9 @@ package body System.Value_F is pragma Assert (Num < 0 and then Den < 0); -- Accept only negative numbers to allow -2**(Int'Size - 1) + pragma Unsuppress (Overflow_Check); + -- Use overflow check to catch bad values + function Safe_Expont (Base : Int; Exp : in out Natural; @@ -224,38 +227,52 @@ package body System.Value_F is B : constant Int := Int (Base); - V : Uns := Val; - E : Uns := Uns (Extra); + V : Uns := Val; + S : Integer := ScaleB; + E : Uns := Uns (Extra); Y, Z, Q1, R1, Q2, R2 : Int; begin + -- The implementation of Value_R uses fully symmetric arithmetics + -- but here we cannot handle 2**(Int'Size - 1) if Minus is not set. + + if V = 2**(Int'Size - 1) and then not Minus then + E := V rem Uns (B); + V := V / Uns (B); + S := S + 1; + end if; + -- We will use a scaled divide operation for which we must control the -- magnitude of operands so that an overflow exception is not unduly -- raised during the computation. The only real concern is the exponent. - -- If ScaleB is too negative, then drop trailing digits, but preserve - -- the last dropped digit. + -- If S is too negative, then drop trailing digits, but preserve the + -- last dropped digit, until V saturates to 0. - if ScaleB < 0 then + if S < 0 then declare - LS : Integer := -ScaleB; + LS : Integer := -S; begin Y := Den; Z := Safe_Expont (B, LS, Num); for J in 1 .. LS loop + if V = 0 then + E := 0; + exit; + end if; E := V rem Uns (B); V := V / Uns (B); end loop; end; - -- If ScaleB is too positive, then scale V up, which may then overflow + -- If S is too positive, then scale V up, which may then overflow - elsif ScaleB > 0 then + elsif S > 0 then declare - LS : Integer := ScaleB; + LS : Integer := S; begin Y := Safe_Expont (B, LS, Den); @@ -271,7 +288,7 @@ package body System.Value_F is end loop; end; - -- If ScaleB is zero, then proceed directly + -- If S is zero, then proceed directly else Y := Den; diff --git a/gcc/ada/libgnat/s-valuer.adb b/gcc/ada/libgnat/s-valuer.adb index 6f557e9..cc1f778 100644 --- a/gcc/ada/libgnat/s-valuer.adb +++ b/gcc/ada/libgnat/s-valuer.adb @@ -135,7 +135,9 @@ package body System.Value_R is B : constant Uns := Uns (Base); begin - if Digit >= Base / 2 then + -- Beware that Base may be odd + + if 2 * Unsigned (Digit) >= Base then -- If Extra is maximum, round Value @@ -578,8 +580,8 @@ package body System.Value_R is if Str (Index) in '0' .. '9' then After_Point := False; - -- If this is a digit it can indicates either the float decimal - -- part or the base to use. + -- If this is a digit it can indicate either the integral part or the + -- base to use. Scan_Integral_Digits (Str, Index, Max, Base, False, Value, Scale, N, @@ -602,7 +604,8 @@ package body System.Value_R is Bad_Value (Str); end if; - -- Check if the first number encountered is a base + -- Check if the first number encountered is a base. ':' is allowed in + -- place of '#' in virtue of RM J.2 (3). pragma Assert (Index >= Str'First); @@ -611,7 +614,13 @@ package body System.Value_R is then Base_Char := Str (Index); - if N = 1 and then Value (1) in 2 .. 16 then + -- Functionally, "(Parts = 1 or else N = 1)" in the condition of the + -- following if statement could replaced by the simpler "N = 1". The + -- reason we use a more complicated expression is to accommodate + -- machine-code-based coverage tools: the simple version makes it + -- impossible to fully cover generic instances of System.Value_R with + -- Parts = 1. + if (Parts = 1 or else N = 1) and then Value (1) in 2 .. 16 then Base := Unsigned (Value (1)); else Base_Violation := True; @@ -630,10 +639,10 @@ package body System.Value_R is end if; end if; - -- Scan the integral part if still necessary + -- Scan the integral part if there was a base and no point right after if Base_Char /= ASCII.NUL and then not After_Point then - if Index > Max or else As_Digit (Str (Index)) not in Valid_Digit then + if As_Digit (Str (Index)) not in Valid_Digit then Bad_Value (Str); end if; diff --git a/gcc/ada/libgnat/s-valueu.adb b/gcc/ada/libgnat/s-valueu.adb index 72e73a8..a27e00f 100644 --- a/gcc/ada/libgnat/s-valueu.adb +++ b/gcc/ada/libgnat/s-valueu.adb @@ -73,6 +73,15 @@ package body System.Value_U is end if; P := Ptr.all; + + -- Exit when the initial string to parse is empty + + if Max < P then + raise Program_Error with + "Scan end Max=" & Max'Img & + " is smaller than scan end Ptr=" & P'Img; + end if; + Uval := Character'Pos (Str (P)) - Character'Pos ('0'); pragma Assert (Str (P) in '0' .. '9'); P := P + 1; diff --git a/gcc/ada/libgnat/s-valueu.ads b/gcc/ada/libgnat/s-valueu.ads index 0dc3399..488c342 100644 --- a/gcc/ada/libgnat/s-valueu.ads +++ b/gcc/ada/libgnat/s-valueu.ads @@ -102,11 +102,9 @@ package System.Value_U is -- This string results in a Constraint_Error with the pointer pointing -- past the second 2. -- - -- Note: if Str is empty, i.e. if Max is less than Ptr, then this is a - -- special case of an all-blank string, and Ptr is unchanged, and hence - -- is greater than Max as required in this case. - -- ??? This is not the case. We will read Str (Ptr.all) without checking - -- and increase Ptr.all by one. + -- Note: If Max is less than Ptr, then Ptr is left unchanged and + -- Program_Error is raised to indicate that a valid integer cannot + -- be parsed. -- -- Note: this routine should not be called with Str'Last = Positive'Last. -- If this occurs Program_Error is raised with a message noting that this diff --git a/gcc/ada/namet.adb b/gcc/ada/namet.adb index e27669e..b7d3abd 100644 --- a/gcc/ada/namet.adb +++ b/gcc/ada/namet.adb @@ -1297,29 +1297,11 @@ package body Namet is -- Present -- ------------- - function Present (Nam : File_Name_Type) return Boolean is - begin - return Nam /= No_File; - end Present; - - ------------- - -- Present -- - ------------- - function Present (Nam : Name_Id) return Boolean is begin return Nam /= No_Name; end Present; - ------------- - -- Present -- - ------------- - - function Present (Nam : Unit_Name_Type) return Boolean is - begin - return Nam /= No_Unit_Name; - end Present; - ------------------ -- Reinitialize -- ------------------ diff --git a/gcc/ada/namet.ads b/gcc/ada/namet.ads index 7182fb8..b05e4b5 100644 --- a/gcc/ada/namet.ads +++ b/gcc/ada/namet.ads @@ -504,10 +504,6 @@ package Namet is -- Constant used to indicate no file is present (this is used for example -- when a search for a file indicates that no file of the name exists). - function Present (Nam : File_Name_Type) return Boolean; - pragma Inline (Present); - -- Determine whether file name Nam exists - Error_File_Name : constant File_Name_Type := File_Name_Type (Error_Name); -- The special File_Name_Type value Error_File_Name is used to indicate -- a unit name where some previous processing has found an error. @@ -532,10 +528,6 @@ package Namet is No_Unit_Name : constant Unit_Name_Type := Unit_Name_Type (No_Name); -- Constant used to indicate no file name present - function Present (Nam : Unit_Name_Type) return Boolean; - pragma Inline (Present); - -- Determine whether unit name Nam exists - Error_Unit_Name : constant Unit_Name_Type := Unit_Name_Type (Error_Name); -- The special Unit_Name_Type value Error_Unit_Name is used to indicate -- a unit name where some previous processing has found an error. diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads index cbe4701..e595b08 100644 --- a/gcc/ada/opt.ads +++ b/gcc/ada/opt.ads @@ -943,6 +943,21 @@ package Opt is -- WARNING: There is a matching C declaration of this variable in fe.h + List_Representation_Info_Extended : Boolean := False; + -- GNAT + -- Set true by -gnatRe switch. Causes extended information for record types + -- to be included in the representation output information. + + List_Representation_Info_Holes : Boolean := False; + -- GNAT + -- Set true by -gnatRh switch. Causes information for holes between record + -- components to be included in the representation output information. + + List_Representation_Info_Mechanisms : Boolean := False; + -- GNAT + -- Set true by -gnatRm switch. Causes information on mechanisms to be + -- included in the representation output information. + List_Representation_Info_To_File : Boolean := False; -- GNAT -- Set true by -gnatRs switch. Causes information from -gnatR[1-4]m to be @@ -955,16 +970,6 @@ package Opt is -- Set true by -gnatRj switch. Causes information from -gnatR[1-4]m to be -- output in the JSON data interchange format. - List_Representation_Info_Mechanisms : Boolean := False; - -- GNAT - -- Set true by -gnatRm switch. Causes information on mechanisms to be - -- included in the representation output information. - - List_Representation_Info_Extended : Boolean := False; - -- GNAT - -- Set true by -gnatRe switch. Causes extended information for record types - -- to be included in the representation output information. - List_Preprocessing_Symbols : Boolean := False; -- GNAT, GNATPREP -- Set to True if symbols for preprocessing a source are to be listed diff --git a/gcc/ada/par-ch13.adb b/gcc/ada/par-ch13.adb index f52136c..dbb894f 100644 --- a/gcc/ada/par-ch13.adb +++ b/gcc/ada/par-ch13.adb @@ -503,6 +503,8 @@ package body Ch13 is or else A_Id = Aspect_Refined_Depends then Inside_Depends := True; + elsif A_Id = Aspect_Abstract_State then + Inside_Abstract_State := True; end if; -- Note that we have seen an Import aspect specification. @@ -529,9 +531,10 @@ package body Ch13 is Set_Expression (Aspect, P_Expression); end if; - -- Unconditionally reset flag for Inside_Depends + -- Unconditionally reset flag for being inside aspects - Inside_Depends := False; + Inside_Depends := False; + Inside_Abstract_State := False; end if; -- Add the aspect to the resulting list only when it was properly diff --git a/gcc/ada/par-ch2.adb b/gcc/ada/par-ch2.adb index 20640d55..11c9a83 100644 --- a/gcc/ada/par-ch2.adb +++ b/gcc/ada/par-ch2.adb @@ -385,6 +385,8 @@ package body Ch2 is or else Chars (Ident_Node) = Name_Refined_Depends then Inside_Depends := True; + elsif Chars (Ident_Node) = Name_Abstract_State then + Inside_Abstract_State := True; end if; -- Scan arguments. We assume that arguments are present if there is @@ -441,11 +443,11 @@ package body Ch2 is Semicolon_Loc := Token_Ptr; - -- Cancel indication of being within a pragma or in particular a Depends - -- pragma. + -- Cancel indication of being within a pragma - Inside_Depends := False; - Inside_Pragma := False; + Inside_Depends := False; + Inside_Abstract_State := False; + Inside_Pragma := False; -- Now we have two tasks left, we need to scan out the semicolon -- following the pragma, and we have to call Par.Prag to process @@ -472,8 +474,9 @@ package body Ch2 is exception when Error_Resync => Resync_Past_Semicolon; - Inside_Depends := False; - Inside_Pragma := False; + Inside_Depends := False; + Inside_Abstract_State := False; + Inside_Pragma := False; return Error; end P_Pragma; diff --git a/gcc/ada/par-ch4.adb b/gcc/ada/par-ch4.adb index 8267a0c..ebdc587 100644 --- a/gcc/ada/par-ch4.adb +++ b/gcc/ada/par-ch4.adb @@ -668,13 +668,13 @@ package body Ch4 is -- (discrete_range) - -- This is a slice. This case is handled in LP_State_Init + -- This is a slice -- (expression, expression, ..) -- This is interpreted as an indexed component, i.e. as a -- case of a name which can be extended in the normal manner. - -- This case is handled by LP_State_Name or LP_State_Expr. + -- This case is handled by LP_State_Expr. -- Note: if and case expressions (without an extra level of -- parentheses) are permitted in this context). @@ -935,129 +935,9 @@ package body Ch4 is -- Error recovery: cannot raise Error_Resync - function P_Function_Name return Node_Id is - Designator_Node : Node_Id; - Prefix_Node : Node_Id; - Selector_Node : Node_Id; - Dot_Sloc : Source_Ptr := No_Location; - - begin - -- Prefix_Node is set to the gathered prefix so far, Empty means that - -- no prefix has been scanned. This allows us to build up the result - -- in the required right recursive manner. - - Prefix_Node := Empty; - - -- Loop through prefixes - - loop - Designator_Node := Token_Node; - - if Token not in Token_Class_Desig then - return P_Identifier; -- let P_Identifier issue the error message - - else -- Token in Token_Class_Desig - Scan; -- past designator - exit when Token /= Tok_Dot; - end if; - - -- Here at a dot, with token just before it in Designator_Node - - if No (Prefix_Node) then - Prefix_Node := Designator_Node; - else - Selector_Node := New_Node (N_Selected_Component, Dot_Sloc); - Set_Prefix (Selector_Node, Prefix_Node); - Set_Selector_Name (Selector_Node, Designator_Node); - Prefix_Node := Selector_Node; - end if; - - Dot_Sloc := Token_Ptr; - Scan; -- past dot - end loop; - - -- Fall out of the loop having just scanned a designator - - if No (Prefix_Node) then - return Designator_Node; - else - Selector_Node := New_Node (N_Selected_Component, Dot_Sloc); - Set_Prefix (Selector_Node, Prefix_Node); - Set_Selector_Name (Selector_Node, Designator_Node); - return Selector_Node; - end if; - - exception - when Error_Resync => - return Error; - end P_Function_Name; - - -- This function parses a restricted form of Names which are either - -- identifiers, or identifiers preceded by a sequence of prefixes - -- that are direct names. - - -- Error recovery: cannot raise Error_Resync - function P_Qualified_Simple_Name return Node_Id is - Designator_Node : Node_Id; - Prefix_Node : Node_Id; - Selector_Node : Node_Id; - Dot_Sloc : Source_Ptr := No_Location; - begin - -- Prefix node is set to the gathered prefix so far, Empty means that - -- no prefix has been scanned. This allows us to build up the result - -- in the required right recursive manner. - - Prefix_Node := Empty; - - -- Loop through prefixes - - loop - Designator_Node := Token_Node; - - if Token = Tok_Identifier then - Scan; -- past identifier - exit when Token /= Tok_Dot; - - elsif Token not in Token_Class_Desig then - return P_Identifier; -- let P_Identifier issue the error message - - else - Scan; -- past designator - - if Token /= Tok_Dot then - Error_Msg_SP ("identifier expected"); - return Error; - end if; - end if; - - -- Here at a dot, with token just before it in Designator_Node - - if No (Prefix_Node) then - Prefix_Node := Designator_Node; - else - Selector_Node := New_Node (N_Selected_Component, Dot_Sloc); - Set_Prefix (Selector_Node, Prefix_Node); - Set_Selector_Name (Selector_Node, Designator_Node); - Prefix_Node := Selector_Node; - end if; - - Dot_Sloc := Token_Ptr; - Scan; -- past dot - end loop; - - -- Fall out of the loop having just scanned an identifier - - if No (Prefix_Node) then - return Designator_Node; - else - Selector_Node := New_Node (N_Selected_Component, Dot_Sloc); - Set_Prefix (Selector_Node, Prefix_Node); - Set_Selector_Name (Selector_Node, Designator_Node); - return Selector_Node; - end if; - + return P_Qualified_Simple_Name_Resync; exception when Error_Resync => return Error; @@ -1076,6 +956,10 @@ package body Ch4 is Dot_Sloc : Source_Ptr := No_Location; begin + -- Prefix_Node is set to the gathered prefix so far, Empty means that + -- no prefix has been scanned. This allows us to build up the result + -- in the required right recursive manner. + Prefix_Node := Empty; -- Loop through prefixes @@ -1083,21 +967,13 @@ package body Ch4 is loop Designator_Node := Token_Node; - if Token = Tok_Identifier then - Scan; -- past identifier - exit when Token /= Tok_Dot; - - elsif Token not in Token_Class_Desig then + if Token not in Token_Class_Desig then Discard_Junk_Node (P_Identifier); -- to issue the error message raise Error_Resync; else Scan; -- past designator - - if Token /= Tok_Dot then - Error_Msg_SP ("identifier expected"); - raise Error_Resync; - end if; + exit when Token /= Tok_Dot; end if; -- Here at a dot, with token just before it in Designator_Node @@ -1112,7 +988,7 @@ package body Ch4 is end if; Dot_Sloc := Token_Ptr; - Scan; -- past period + Scan; -- past dot end loop; -- Fall out of the loop having just scanned an identifier @@ -1607,8 +1483,13 @@ package body Ch4 is -- Improper use of WITH elsif Token = Tok_With then - Error_Msg_SC ("WITH must be preceded by single expression in " & - "extension aggregate"); + if Inside_Abstract_State then + Error_Msg_SC ("state name with options must be enclosed in " & + "parentheses"); + else + Error_Msg_SC ("WITH must be preceded by single expression in " & + "extension aggregate"); + end if; raise Error_Resync; -- Range attribute can only appear as part of a discrete choice list diff --git a/gcc/ada/par-ch5.adb b/gcc/ada/par-ch5.adb index a46fe44..34c1019 100644 --- a/gcc/ada/par-ch5.adb +++ b/gcc/ada/par-ch5.adb @@ -1899,11 +1899,11 @@ package body Ch5 is (Block_Name : Node_Id := Empty) return Node_Id is - Block_Node : Node_Id; + Block : Node_Id; Created_Name : Node_Id; begin - Block_Node := New_Node (N_Block_Statement, Token_Ptr); + Block := New_Node (N_Block_Statement, Token_Ptr); Push_Scope_Stack; Scopes (Scope.Last).Etyp := E_Name; @@ -1916,18 +1916,18 @@ package body Ch5 is if No (Block_Name) then Created_Name := - Make_Identifier (Sloc (Block_Node), Set_Loop_Block_Name ('B')); + Make_Identifier (Sloc (Block), Set_Loop_Block_Name ('B')); Set_Comes_From_Source (Created_Name, False); - Set_Has_Created_Identifier (Block_Node, True); - Set_Identifier (Block_Node, Created_Name); + Set_Has_Created_Identifier (Block, True); + Set_Identifier (Block, Created_Name); Scopes (Scope.Last).Labl := Created_Name; else - Set_Identifier (Block_Node, Block_Name); + Set_Identifier (Block, Block_Name); end if; - Append_Elmt (Block_Node, Label_List); - Parse_Decls_Begin_End (Block_Node); - return Block_Node; + Append_Elmt (Block, Label_List); + Parse_Decls_Begin_End (Block); + return Block; end P_Declare_Statement; -- P_Begin_Statement @@ -1942,11 +1942,11 @@ package body Ch5 is (Block_Name : Node_Id := Empty) return Node_Id is - Block_Node : Node_Id; + Block : Node_Id; Created_Name : Node_Id; begin - Block_Node := New_Node (N_Block_Statement, Token_Ptr); + Block := New_Node (N_Block_Statement, Token_Ptr); Push_Scope_Stack; Scopes (Scope.Last).Etyp := E_Name; @@ -1957,24 +1957,24 @@ package body Ch5 is if No (Block_Name) then Created_Name := - Make_Identifier (Sloc (Block_Node), Set_Loop_Block_Name ('B')); + Make_Identifier (Sloc (Block), Set_Loop_Block_Name ('B')); Set_Comes_From_Source (Created_Name, False); - Set_Has_Created_Identifier (Block_Node, True); - Set_Identifier (Block_Node, Created_Name); + Set_Has_Created_Identifier (Block, True); + Set_Identifier (Block, Created_Name); Scopes (Scope.Last).Labl := Created_Name; else - Set_Identifier (Block_Node, Block_Name); + Set_Identifier (Block, Block_Name); end if; - Append_Elmt (Block_Node, Label_List); + Append_Elmt (Block, Label_List); Scopes (Scope.Last).Ecol := Start_Column; Scopes (Scope.Last).Sloc := Token_Ptr; Scan; -- past BEGIN Set_Handled_Statement_Sequence - (Block_Node, P_Handled_Sequence_Of_Statements); - End_Statements (Handled_Statement_Sequence (Block_Node)); - return Block_Node; + (Block, P_Handled_Sequence_Of_Statements); + End_Statements (Handled_Statement_Sequence (Block)); + return Block; end P_Begin_Statement; ------------------------- diff --git a/gcc/ada/par-ch6.adb b/gcc/ada/par-ch6.adb index 55591fd..0f7765b 100644 --- a/gcc/ada/par-ch6.adb +++ b/gcc/ada/par-ch6.adb @@ -362,12 +362,11 @@ package body Ch6 is if Func then Inst_Node := New_Node (N_Function_Instantiation, Fproc_Sloc); - Set_Name (Inst_Node, P_Function_Name); else Inst_Node := New_Node (N_Procedure_Instantiation, Fproc_Sloc); - Set_Name (Inst_Node, P_Qualified_Simple_Name); end if; + Set_Name (Inst_Node, P_Qualified_Simple_Name); Set_Defining_Unit_Name (Inst_Node, Name_Node); Set_Generic_Associations (Inst_Node, P_Generic_Actual_Part_Opt); P_Aspect_Specifications (Inst_Node, Semicolon => True); diff --git a/gcc/ada/par.adb b/gcc/ada/par.adb index 5d61fac..e11ec7e 100644 --- a/gcc/ada/par.adb +++ b/gcc/ada/par.adb @@ -80,6 +80,11 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is -- True within a delta aggregate (but only after the "delta" token has -- been scanned). Used to distinguish syntax errors from syntactically -- correct "deep" delta aggregates (enabled via -gnatX0). + + Inside_Abstract_State : Boolean := False; + -- True within an Abstract_State contract. Used to distinguish syntax error + -- about extended aggregates and about a malformed contract. + Save_Style_Checks : Style_Check_Options; Save_Style_Check : Boolean; -- Variables for storing the original state of whether style checks should @@ -825,7 +830,6 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is function P_Aggregate return Node_Id; function P_Expression return Node_Id; function P_Expression_Or_Range_Attribute return Node_Id; - function P_Function_Name return Node_Id; function P_Name return Node_Id; function P_Qualified_Simple_Name return Node_Id; function P_Qualified_Simple_Name_Resync return Node_Id; diff --git a/gcc/ada/repinfo.adb b/gcc/ada/repinfo.adb index a6dff7c..ddbb58e 100644 --- a/gcc/ada/repinfo.adb +++ b/gcc/ada/repinfo.adb @@ -30,6 +30,7 @@ with Debug; use Debug; with Einfo; use Einfo; with Einfo.Entities; use Einfo.Entities; with Einfo.Utils; use Einfo.Utils; +with GNAT.Heap_Sort_G; with Lib; use Lib; with Namet; use Namet; with Nlists; use Nlists; @@ -413,9 +414,9 @@ package body Repinfo is Write_Line (";"); end if; - -- Alignment is not always set for task, protected, and class-wide - -- types, or when doing semantic analysis only. Representation aspects - -- are not computed for types in a generic unit. + -- Alignment is not always set for concurrent types, class-wide types, + -- cloned subtypes, or when doing semantic analysis only. Representation + -- aspects are not computed for types declared in a generic unit. else -- Add unknown alignment entry in JSON format to ensure the format is @@ -426,11 +427,13 @@ package body Repinfo is Write_Unknown_Val; end if; - pragma Assert - (not Expander_Active or else - Is_Concurrent_Type (Ent) or else - Is_Class_Wide_Type (Ent) or else - Sem_Util.In_Generic_Scope (Ent)); + pragma Assert (not Expander_Active + or else Is_Concurrent_Type (Ent) + or else Is_Class_Wide_Type (Ent) + or else (Ekind (Ent) = E_Record_Subtype + and then Present (Cloned_Subtype (Ent)) + and then Has_Delayed_Freeze (Cloned_Subtype (Ent))) + or else Sem_Util.In_Generic_Scope (Ent)); end if; end List_Common_Type_Info; @@ -856,8 +859,7 @@ package body Repinfo is -- generic unit, or if the back end is not being run), don't try to -- print them. - pragma Assert (Known_Esize (Ent) = Known_Alignment (Ent)); - if not Known_Alignment (Ent) then + if not Known_Esize (Ent) or else not Known_Alignment (Ent) then return; end if; @@ -882,6 +884,7 @@ package body Repinfo is Write_Eol; Write_Line ("}"); + else Write_Str ("for "); List_Name (Ent); @@ -1223,11 +1226,135 @@ package body Repinfo is Starting_First_Bit : Uint := Uint_0; Prefix : String := "") is - Comp : Entity_Id; - First : Boolean := True; + function First_Comp_Or_Discr (Ent : Entity_Id) return Entity_Id; + -- Like First_Component_Or_Discriminant, but reorder the components + -- according to their bit offset if need be. + + ------------------------- + -- First_Comp_Or_Discr -- + ------------------------- + + function First_Comp_Or_Discr (Ent : Entity_Id) return Entity_Id is + + function Is_Placed_Before (C1, C2 : Entity_Id) return Boolean; + -- Return True if component C1 is placed before component C2 + + ---------------------- + -- Is_Placed_Before -- + ---------------------- + + function Is_Placed_Before (C1, C2 : Entity_Id) return Boolean is + begin + return Known_Static_Component_Bit_Offset (C1) + and then Known_Static_Component_Bit_Offset (C2) + and then + Component_Bit_Offset (C1) < Component_Bit_Offset (C2); + end Is_Placed_Before; + + -- Local variables + + Comp : Entity_Id; + N_Comp : Natural := 0; + Prev : Entity_Id; + Reorder : Boolean := False; + + -- Start of processing for First_Comp_Or_Discr + + begin + -- Reordering is needed only for -gnatRh + + if not List_Representation_Info_Holes then + return First_Component_Or_Discriminant (Ent); + end if; + + -- Count the number of components and whether reordering is needed + + Comp := First_Component_Or_Discriminant (Ent); + Prev := Comp; + + while Present (Comp) loop + N_Comp := N_Comp + 1; + + if not Reorder then + Reorder := Is_Placed_Before (Comp, Prev); + end if; + + Prev := Comp; + Next_Component_Or_Discriminant (Comp); + end loop; + + -- Reorder the components, if need be, by directly reshuffling the + -- list of entities between First_Entity and Last_Entity, which is + -- safe because we are invoked after compilation is finished. + + if Reorder then + declare + Comps : array (Natural range 0 .. N_Comp) of Entity_Id; + -- Support array for the heapsort + + function Lt (Op1, Op2 : Natural) return Boolean is + (Is_Placed_Before (Comps (Op1), Comps (Op2))); + -- Compare function for the heapsort + + procedure Move (From : Natural; To : Natural); + pragma Inline (Move); + -- Move procedure for the heapsort + + ---------- + -- Move -- + ---------- + + procedure Move (From : Natural; To : Natural) is + begin + Comps (To) := Comps (From); + end Move; + + package HS is new GNAT.Heap_Sort_G (Lt => Lt, Move => Move); + -- The heapsort for record components + + begin + -- Pack the components into the array + + N_Comp := 0; + Comp := First_Component_Or_Discriminant (Ent); + + while Present (Comp) loop + N_Comp := N_Comp + 1; + Comps (N_Comp) := Comp; + + Next_Component_Or_Discriminant (Comp); + end loop; + + -- Sort the array + + HS.Sort (N_Comp); + + -- Unpack the component into the list of entities + + Set_First_Entity (Ent, Comps (1)); + Set_Prev_Entity (Comps (1), Empty); + for J in 1 .. N_Comp - 1 loop + Set_Next_Entity (Comps (J), Comps (J + 1)); + Set_Prev_Entity (Comps (J + 1), Comps (J)); + end loop; + Set_Next_Entity (Comps (N_Comp), Empty); + Set_Last_Entity (Ent, Comps (N_Comp)); + end; + end if; + + return First_Component_Or_Discriminant (Ent); + end First_Comp_Or_Discr; + + -- Local variables + + Bit_Offset : Uint := Uint_0; + Comp : Entity_Id; + First : Boolean := True; + + -- Start of processing for List_Record_Layout begin - Comp := First_Component_Or_Discriminant (Ent); + Comp := First_Comp_Or_Discr (Ent); while Present (Comp) loop -- Skip a completely hidden discriminant or a discriminant in an @@ -1237,69 +1364,98 @@ package body Repinfo is and then (Is_Completely_Hidden (Comp) or else Is_Unchecked_Union (Ent)) then - goto Continue; - end if; + null; -- Skip _Parent component in extension (to avoid overlap) - if Chars (Comp) = Name_uParent then - goto Continue; - end if; + elsif Chars (Comp) = Name_uParent then + null; -- All other cases - declare - Ctyp : constant Entity_Id := Underlying_Type (Etype (Comp)); - Npos : constant Uint := Normalized_Position (Comp); - Fbit : constant Uint := Normalized_First_Bit (Comp); - Spos : Uint; - Sbit : Uint; + else + declare + C : constant Entity_Id := + (if Known_Normalized_Position (Comp) + then Comp + else Original_Record_Component (Comp)); + -- The Parent_Subtype in an extension is not back-annotated + -- but its layout is the same as that of the parent type. - begin - Get_Decoded_Name_String (Chars (Comp)); - Set_Casing (Unit_Casing); + Ctyp : constant Entity_Id := Underlying_Type (Etype (C)); - -- If extended information is requested, recurse fully into - -- record components, i.e. skip the outer level. + begin + Get_Decoded_Name_String (Chars (C)); + Set_Casing (Unit_Casing); - if List_Representation_Info_Extended - and then Is_Record_Type (Ctyp) - and then Known_Static_Normalized_Position (Comp) - and then Known_Static_Normalized_First_Bit (Comp) - then - Spos := Starting_Position + Npos; - Sbit := Starting_First_Bit + Fbit; + -- If extended information is requested, recurse fully into + -- record components, i.e. skip the outer level. - if Sbit >= SSU then - Spos := Spos + 1; - Sbit := Sbit - SSU; - end if; + if List_Representation_Info_Extended + and then Is_Record_Type (Ctyp) + and then Known_Static_Normalized_Position (C) + and then Known_Static_Normalized_First_Bit (C) + then + declare + Npos : constant Uint := Normalized_Position (C); + Fbit : constant Uint := Normalized_First_Bit (C); + Pref : constant String := + Prefix & Name_Buffer (1 .. Name_Len) & "."; - List_Record_Layout (Ctyp, - Spos, Sbit, Prefix & Name_Buffer (1 .. Name_Len) & "."); + Spos : Uint; + Sbit : Uint; - goto Continue; - end if; + begin + Spos := Starting_Position + Npos; + Sbit := Starting_First_Bit + Fbit; + + if Sbit >= SSU then + Spos := Spos + 1; + Sbit := Sbit - SSU; + end if; + + List_Record_Layout (Ctyp, Spos, Sbit, Pref); + end; - if List_Representation_Info_To_JSON then - if First then - Write_Eol; - First := False; else - Write_Line (","); - end if; - end if; + if List_Representation_Info_To_JSON then + if First then + Write_Eol; + First := False; + else + Write_Line (","); + end if; + end if; - -- The Parent_Subtype in an extension is not back-annotated + -- If information about holes is requested, update the + -- current bit offset and report any (static) gap. - List_Component_Layout ( - (if Known_Normalized_Position (Comp) - then Comp - else Original_Record_Component (Comp)), - Starting_Position, Starting_First_Bit, Prefix); - end; + if List_Representation_Info_Holes + and then Known_Static_Component_Bit_Offset (C) + then + declare + Gap : constant Uint := + Component_Bit_Offset (C) - Bit_Offset; + begin + if Gap > Uint_0 then + Write_Str (" -- "); + UI_Write (Gap, Decimal); + Write_Line (" bits unused --"); + end if; + + if Known_Static_Esize (C) then + Bit_Offset := + Component_Bit_Offset (C) + Esize (C); + end if; + end; + end if; + + List_Component_Layout + (C, Starting_Position, Starting_First_Bit, Prefix); + end if; + end; + end if; - <<Continue>> Next_Component_Or_Discriminant (Comp); end loop; end List_Record_Layout; @@ -1610,6 +1766,17 @@ package body Repinfo is end loop; end List_Structural_Record_Layout; + -- Use the original record type giving the layout of components + -- to avoid repeated reordering when -gnatRh is specified. + + Rec : constant Entity_Id := + (if Ekind (Ent) = E_Record_Subtype + and then Present (Cloned_Subtype (Ent)) + then (if Is_Private_Type (Cloned_Subtype (Ent)) + then Full_View (Cloned_Subtype (Ent)) + else Cloned_Subtype (Ent)) + else Ent); + -- Start of processing for List_Record_Info begin @@ -1624,7 +1791,7 @@ package body Repinfo is -- First find out max line length and max starting position -- length, for the purpose of lining things up nicely. - Compute_Max_Length (Ent); + Compute_Max_Length (Rec); -- Then do actual output based on those values @@ -1636,21 +1803,21 @@ package body Repinfo is -- declared in the extended main source unit for the time being, -- because otherwise declarations might not be processed at all. - if Is_Base_Type (Ent) then + if Is_Base_Type (Rec) then begin - List_Structural_Record_Layout (Ent, Ent); + List_Structural_Record_Layout (Rec, Rec); exception when Incomplete_Layout | Not_In_Extended_Main => - List_Record_Layout (Ent); + List_Record_Layout (Rec); when others => raise Program_Error; end; else - List_Record_Layout (Ent); + List_Record_Layout (Rec); end if; Write_Eol; @@ -1660,7 +1827,7 @@ package body Repinfo is List_Name (Ent); Write_Line (" use record"); - List_Record_Layout (Ent); + List_Record_Layout (Rec); Write_Line ("end record;"); end if; diff --git a/gcc/ada/sem.adb b/gcc/ada/sem.adb index 06df00e..449fd8a 100644 --- a/gcc/ada/sem.adb +++ b/gcc/ada/sem.adb @@ -765,12 +765,11 @@ package body Sem is E : constant Entity_Id := Defining_Entity_Or_Empty (N); begin if Present (E) then - if Ekind (E) = E_Void - and then Nkind (N) = N_Component_Declaration + if Nkind (N) = N_Component_Declaration and then Present (Scope (E)) and then Ekind (Scope (E)) = E_Record_Type then - null; -- Set it later, in Analyze_Component_Declaration + null; -- Set it later, in Record_Type_Definition elsif not Is_Not_Self_Hidden (E) then Set_Is_Not_Self_Hidden (E); end if; diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index bf4d684..4f5047f 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -5693,19 +5693,15 @@ package body Sem_Attr is when Attribute_Partition_ID => Check_E0; - if P_Type /= Any_Type then - if not Is_Library_Level_Entity (Entity (P)) then - Error_Attr_P - ("prefix of % attribute must be library-level entity"); + if not Is_Library_Level_Entity (Entity (P)) then + Error_Attr_P + ("prefix of % attribute must be library-level entity"); - -- The defining entity of prefix should not be declared inside a - -- Pure unit. RM E.1(8). Is_Pure was set during declaration. + -- The defining entity of prefix should not be declared inside a + -- Pure unit. RM E.1(8). Is_Pure was set during declaration. - elsif Is_Entity_Name (P) - and then Is_Pure (Entity (P)) - then - Error_Attr_P ("prefix of% attribute must not be declared pure"); - end if; + elsif Is_Entity_Name (P) and then Is_Pure (Entity (P)) then + Error_Attr_P ("prefix of% attribute must not be declared pure"); end if; Set_Etype (N, Universal_Integer); @@ -13018,7 +13014,6 @@ package body Sem_Attr is -- their Entity attribute to reference their discriminal. if Expander_Active - and then Present (Expressions (N)) and then Attr_Id /= Attribute_Make then declare diff --git a/gcc/ada/sem_case.adb b/gcc/ada/sem_case.adb index 3399a41..c81b563 100644 --- a/gcc/ada/sem_case.adb +++ b/gcc/ada/sem_case.adb @@ -3684,13 +3684,15 @@ package body Sem_Case is -- Use of nonstatic predicate is an error if not Is_Discrete_Type (E) - or else not Has_Static_Predicate (E) + or else (not Has_Static_Predicate (E) + and then + not Has_Static_Predicate_Aspect (E)) or else Has_Dynamic_Predicate_Aspect (E) or else Has_Ghost_Predicate_Aspect (E) then Bad_Predicated_Subtype_Use - ("cannot use subtype& with non-static " - & "predicate as case alternative", + ("cannot use subtype& with nonstatic " + & "predicate as choice in case alternative", Choice, E, Suggest_Static => True); -- Static predicate case. The bounds are those of diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb index 25bba9b..45aabad 100644 --- a/gcc/ada/sem_ch10.adb +++ b/gcc/ada/sem_ch10.adb @@ -1225,9 +1225,15 @@ package body Sem_Ch10 is if Expander_Active and then Tagged_Type_Expansion then case Nkind (Unit_Node) is - when N_Package_Declaration | N_Package_Body => + when N_Package_Declaration => Build_Static_Dispatch_Tables (Unit_Node); + when N_Package_Body => + if Ekind (Corresponding_Spec (Unit_Node)) /= E_Generic_Package + then + Build_Static_Dispatch_Tables (Unit_Node); + end if; + when N_Package_Instantiation => Build_Static_Dispatch_Tables (Instance_Spec (Unit_Node)); diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 3a31a92..062251f 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -479,18 +479,19 @@ package body Sem_Ch12 is -- Create a new access type with the given designated type function Analyze_Associations - (I_Node : Node_Id; + (N : Node_Id; Formals : List_Id; F_Copy : List_Id) return List_Id; -- At instantiation time, build the list of associations between formals -- and actuals. Each association becomes a renaming declaration for the - -- formal entity. F_Copy is the analyzed list of formals in the generic - -- copy. It is used to apply legality checks to the actuals. I_Node is the - -- instantiation node. + -- formal entity. N is the instantiation node. Formals is the list of + -- unanalyzed formals. F_Copy is the analyzed list of formals in the + -- generic copy. procedure Analyze_Subprogram_Instantiation (N : Node_Id; K : Entity_Kind); + -- Analyze subprogram instantiation N, either a function or a procedure procedure Build_Instance_Compilation_Unit_Nodes (N : Node_Id; @@ -609,12 +610,12 @@ package body Sem_Ch12 is (Inner : Entity_Id; Outer : Entity_Id; N : Node_Id) return Boolean; - -- Inner is instantiated within the generic Outer. Check whether Inner - -- directly or indirectly contains an instance of Outer or of one of its - -- parents, in the case of a subunit. Each generic unit holds a list of - -- the entities instantiated within (at any depth). This procedure - -- determines whether the set of such lists contains a cycle, i.e. an - -- illegal circular instantiation. + -- Inner is being instantiated within Outer. If Outer is also a generic + -- unit, check whether Inner directly or indirectly contains an instance + -- of Outer or of one of its parents (case of subunit). Each generic unit + -- holds a list of the entities instantiated within (at any depth). This + -- procedure determines whether the set of such lists contains a cycle, + -- i.e. an illegal circular instantiation. function Denotes_Formal_Package (Pack : Entity_Id; @@ -1009,8 +1010,8 @@ package body Sem_Ch12 is procedure Set_Next_Assoc (E : Assoc_Ptr; Next : Assoc_Ptr); function Next_Assoc (E : Assoc_Ptr) return Assoc_Ptr; - function Get_Gen_Id (E : Assoc_Ptr) return Entity_Id; - function Hash (F : Entity_Id) return HTable_Range; + function Get_Gen_Id (E : Assoc_Ptr) return Entity_Id; + function Hash (F : Entity_Id) return HTable_Range; package Generic_Renamings_HTable is new GNAT.HTable.Static_HTable ( Header_Num => HTable_Range, @@ -1158,19 +1159,29 @@ package body Sem_Ch12 is -- kinds for N_Box_Subp_Default, N_Box_Actual, N_Null_Default, and -- N_Exp_Func_Default. - type Generic_Actual_Rec (Kind : Actual_Kind := None) is record - -- Representation of one generic actual parameter + type Actual_Rec (Kind : Actual_Kind := None) is record case Kind is - when None | None_Use_Clause | Box_Subp_Default | Box_Actual | - Null_Default | Dummy_Assoc => + when None + | None_Use_Clause + | Box_Subp_Default + | Box_Actual + | Null_Default + | Dummy_Assoc + => null; - when Name_Exp | Exp_Func_Default => + when Name_Exp + | Exp_Func_Default + => Name_Exp : Node_Id; end case; end record; + -- Representation of one generic actual parameter type Actual_Origin_Enum is - (None, From_Explicit_Actual, From_Default, From_Inference, + (None, + From_Explicit_Actual, + From_Default, + From_Inference, From_Others_Box); -- Indication of where the Actual came from -- explicitly in the -- instantiation, inferred from some other type, or defaulted. @@ -1179,16 +1190,16 @@ package body Sem_Ch12 is -- Reason an actual type corresponding to a formal type was (or could -- be) inferred from the actual type corresponding to another formal -- type. - (Designated_Type, -- designated type from formal access - Index_Type, -- index type from formal array - Component_Type, -- component type from formal array + (Designated_Type, -- designated type from formal access + Index_Type, -- index type from formal array + Component_Type, -- component type from formal array Discriminant_Type); -- discriminant type from formal discriminated function Image (Reason : Inference_Reason) return String is (case Reason is - when Designated_Type => "designated type", - when Index_Type => "index type", - when Component_Type => "component type", + when Designated_Type => "designated type", + when Index_Type => "index type", + when Component_Type => "component type", when Discriminant_Type => "discriminant type"); type Assoc_Index is new Pos; @@ -1210,7 +1221,7 @@ package body Sem_Ch12 is Explicit_Assoc : Opt_N_Generic_Association_Id; -- Explicit association, if any, from the source or generated. - Actual : Generic_Actual_Rec; + Actual : Actual_Rec; -- Generic actual parameter corresponding to Un_Formal/An_Formal, -- possibly from defaults or others/boxes. @@ -1224,7 +1235,7 @@ package body Sem_Ch12 is -- inferred. Inferred_From : Assoc_Index; - -- Index of a later Assoc_Rec in the same Gen_Assocs_Rec from which + -- Index of a later Assoc_Rec in the same Match_Rec from which -- this one was inferred, or could be inferred. -- Valid only if Info_Inferred_Actual is present. @@ -1237,10 +1248,10 @@ package body Sem_Ch12 is -- One element for each formal and (if legal) for each corresponding -- actual. - type Gen_Assocs_Rec (Num_Assocs : Assoc_Count) is record - -- Representation of formal/actual matching. Num_Assocs - -- is the number of formals and (if legal) the number - -- of actuals. + type Match_Rec (Num_Assocs : Assoc_Count) is record + -- Representation of formal/actual matching. Num_Assocs is the + -- number of formals and (if legal) the number of actuals. + Gen_Unit : Entity_Id; -- the generic unit being instantiated Others_Present : Boolean; @@ -1251,25 +1262,26 @@ package body Sem_Ch12 is end record; function Match_Assocs - (I_Node : Node_Id; Formals : List_Id; F_Copy : List_Id) - return Gen_Assocs_Rec; - -- I_Node is the instantiation node. Formals is the list of unanalyzed + (N : Node_Id; + Formals : List_Id; + F_Copy : List_Id) return Match_Rec; + -- N is the instantiation node. Formals is the list of unanalyzed -- formals. F_Copy is the analyzed list of formals in the generic copy. - -- Return a Gen_Assocs_Rec with formals, explicit actuals, and default + -- Return a Match_Rec with formals, explicit actuals, and default -- actuals filled in. Check legality rules related to formal/actual -- matching. procedure Note_Potential_Inference - (I_Node : Node_Id; Gen_Assocs : Gen_Assocs_Rec); + (N : Node_Id; + Match : Match_Rec); -- If -gnatd_I, print "info:" messages about type inference that could -- have been done. end Associations; procedure Analyze_One_Association - (I_Node : Node_Id; -- instantiation node - Assoc : Associations.Assoc_Rec; - -- Logical 'in out' parameters: + (N : Node_Id; + Assoc : Associations.Assoc_Rec; Result_Renamings : List_Id; Default_Actuals : List_Id; Actuals_To_Freeze : Elist_Id); @@ -1279,12 +1291,12 @@ package body Sem_Ch12 is -- appended onto Actuals_To_Freeze. procedure Check_Fixed_Point_Warning - (Gen_Assocs : Associations.Gen_Assocs_Rec; + (Match : Associations.Match_Rec; Renamings : List_Id); -- Warn if any actual is a fixed-point type that has user-defined -- arithmetic operators, but there is no corresponding formal in the -- generic, in which case the predefined operators will be used. This - -- merits a warning because of the special semantics of fixed point + -- deserves a warning because of the special semantics of fixed point -- operators. However, do not warn if the formal is private, because there -- can be no arithmetic operators in the generic so there no danger of -- confusion. @@ -1315,27 +1327,29 @@ package body Sem_Ch12 is -- analyzed formals in cases where there are multiple ones -- corresponding to a particular unanalyzed one. - function Num_An_Formals (F_Copy : List_Id) return Assoc_Count; + function Num_An_Formals (F_Copy : List_Id) return Assoc_Count; -- Number of analyzed formals that correspond directly to unanalyzed -- formals. There are all sorts of other things in F_Copy, which -- are not counted. - procedure Check_Box (I_Node, Actual : Node_Id); + procedure Check_Box (N, Actual : Node_Id); -- Check for errors in "others => <>" and "Name => <>" - function Default (Un_Formal : Node_Id) return Generic_Actual_Rec; + function Default (Un_Formal : Node_Id) return Actual_Rec; -- Return the default for a given formal, which can be a name, -- expression, box, etc. procedure Match_Positional - (Src_Assoc : in out Node_Id; Assoc : in out Assoc_Rec); + (Src_Assoc : in out Node_Id; + Assoc : in out Assoc_Rec); -- Called by Match_Assocs to match one positional parameter association. -- If the current formal (in Assoc) is not a use clause, then there is a -- match, and we set Assoc.Actual and move Src_Assoc to the next one. procedure Match_Named - (Src_Assoc : Node_Id; Assoc : in out Assoc_Rec; - Found : in out Boolean); + (Src_Assoc : Node_Id; + Assoc : in out Assoc_Rec; + Found : in out Boolean); -- Called by Match_Assocs to match one named parameter association. -- If the current formal (in Assoc) is not a use clause, and the -- selector name matches the formal name, then there is a match, @@ -1343,48 +1357,50 @@ package body Sem_Ch12 is -- the matched formal, and set Found to True. procedure Inference_Msg - (Gen_Unit : Entity_Id; - Inferred_To, Inferred_From : Assoc_Rec; - Was_Inferred : Boolean); + (Gen_Unit : Entity_Id; + Inferred_To : Assoc_Rec; + Inferred_From : Assoc_Rec; + Was_Inferred : Boolean); -- If Was_Inferred is True, this prints out an "info:" message -- showing the inference. -- If Was_Inferred is False, the message says that it could have -- been inferred. function Find_Assoc - (Gen_Assocs : Gen_Assocs_Rec; F : Entity_Id) return Assoc_Index; - -- Return the index of F in Gen_Assocs.Assocs, which must be - -- present. + (Match : Match_Rec; + F : Entity_Id) return Assoc_Index; + -- Return the index of F in Match.Assocs, which must be present procedure Maybe_Infer_One - (Gen_Assocs : in out Gen_Assocs_Rec; - FF, AA : N_Entity_Id; Inferred_From : Assoc_Index; - Reason : Inference_Reason); + (Match : in out Match_Rec; + FF, AA : N_Entity_Id; + Inferred_From : Assoc_Index; + Reason : Inference_Reason); -- If it makes sense to infer that formal FF is associated with -- actual AA, then do so. procedure Infer_From_Access - (Gen_Assocs : in out Gen_Assocs_Rec; - Index : Assoc_Index; - F : Node_Id; + (Match : in out Match_Rec; + Index : Assoc_Index; + F : Node_Id; A_Full : Entity_Id); -- Try to infer the designated type procedure Infer_From_Array - (Gen_Assocs : in out Gen_Assocs_Rec; - Index : Assoc_Index; - F : Node_Id; + (Match : in out Match_Rec; + Index : Assoc_Index; + F : Node_Id; A_Full : Entity_Id); -- Try to infer the index and component types procedure Infer_From_Discriminated - (Gen_Assocs : in out Gen_Assocs_Rec; - Index : Assoc_Index; - F : Node_Id; + (Match : in out Match_Rec; + Index : Assoc_Index; + F : Node_Id; A_Full : Entity_Id); -- Try to infer the types of discriminants - procedure Infer_Actuals (Gen_Assocs : in out Gen_Assocs_Rec); + procedure Infer_Actuals (Match : in out Match_Rec); -- Called by Match_Assocs after processing explicit and defaulted -- parameters to infer any that are still missing. @@ -1542,13 +1558,13 @@ package body Sem_Ch12 is -- Check_Box -- --------------- - procedure Check_Box (I_Node, Actual : Node_Id) is + procedure Check_Box (N, Actual : Node_Id) is begin -- "... => <>" is allowed only in formal packages, not old-fashioned -- instantiations. - if Nkind (I_Node) /= N_Formal_Package_Declaration - and then Comes_From_Source (I_Node) + if Nkind (N) /= N_Formal_Package_Declaration + and then Comes_From_Source (N) then if Actual in N_Others_Choice_Id then Error_Msg_N @@ -1573,9 +1589,9 @@ package body Sem_Ch12 is -- Default -- ------------- - function Default (Un_Formal : Node_Id) return Generic_Actual_Rec is + function Default (Un_Formal : Node_Id) return Actual_Rec is begin - return Result : Generic_Actual_Rec do + return Result : Actual_Rec do case Nkind (Un_Formal) is when N_Formal_Object_Declaration => if Present (Default_Expression (Un_Formal)) then @@ -1727,22 +1743,24 @@ package body Sem_Ch12 is ------------------ function Match_Assocs - (I_Node : Node_Id; Formals : List_Id; F_Copy : List_Id) - return Gen_Assocs_Rec + (N : Node_Id; + Formals : List_Id; + F_Copy : List_Id) return Match_Rec is - Src_Assocs : constant List_Id := Generic_Associations (I_Node); - Gen_Unit : constant Entity_Id := Defining_Entity (Parent (F_Copy)); + Src_Assocs : constant List_Id := Generic_Associations (N); + Gen_Unit : constant Entity_Id := Defining_Entity (Parent (F_Copy)); + begin pragma Assert (Num_An_Formals (F_Copy) = Num_Formals (Formals) or else Serious_Errors_Detected > 0); - return Result : Gen_Assocs_Rec (Num_Assocs => Num_Formals (Formals)) + return Result : Match_Rec (Num_Assocs => Num_Formals (Formals)) do Result.Gen_Unit := Gen_Unit; Result.Others_Present := False; - -- Loop through the unanalyzed formals: + -- Loop through the unanalyzed formals declare procedure Set_Formal (F : Node_Id; Index : Assoc_Index); @@ -1779,7 +1797,7 @@ package body Sem_Ch12 is Iter (Formals); end; - -- Loop through the analyzed copy of the formals: + -- Loop through the analyzed copy of the formals declare procedure Set_An_Formal (F : Node_Id; Index : Assoc_Index); @@ -1836,7 +1854,7 @@ package body Sem_Ch12 is Iter (F_Copy); end; - -- Loop through actual source associations: + -- Loop through actual source associations declare Src_Assoc : Node_Id := First (Src_Assocs); @@ -1864,7 +1882,7 @@ package body Sem_Ch12 is -- Loop through named actuals and "others => <>": while Present (Src_Assoc) loop - Check_Box (I_Node, Src_Assoc); + Check_Box (N, Src_Assoc); if Src_Assoc in N_Others_Choice_Id then Result.Others_Present := True; exit; @@ -1942,8 +1960,8 @@ package body Sem_Ch12 is end; end loop; - if Nkind (I_Node) /= N_Formal_Package_Declaration then - Infer_Actuals (Gen_Assocs => Result); + if Nkind (N) /= N_Formal_Package_Declaration then + Infer_Actuals (Result); end if; -- Check for missing actuals @@ -1969,9 +1987,10 @@ package body Sem_Ch12 is ------------------- procedure Inference_Msg - (Gen_Unit : Entity_Id; - Inferred_To, Inferred_From : Assoc_Rec; - Was_Inferred : Boolean) + (Gen_Unit : Entity_Id; + Inferred_To : Assoc_Rec; + Inferred_From : Assoc_Rec; + Was_Inferred : Boolean) is pragma Assert (Debug_Flag_Underscore_II); -- This is only for -gnatd_I @@ -2009,7 +2028,8 @@ package body Sem_Ch12 is ------------------------------ procedure Note_Potential_Inference - (I_Node : Node_Id; Gen_Assocs : Gen_Assocs_Rec) + (N : Node_Id; + Match : Match_Rec) is begin if not Debug_Flag_Underscore_II or else Serious_Errors_Detected > 0 @@ -2017,20 +2037,21 @@ package body Sem_Ch12 is return; end if; - for Index in Gen_Assocs.Assocs'Range loop + for Index in Match.Assocs'Range loop declare - Assoc : Assoc_Rec renames Gen_Assocs.Assocs (Index); + Assoc : Assoc_Rec renames Match.Assocs (Index); + begin if Assoc.Actual_Origin = From_Explicit_Actual and then Present (Assoc.Info_Inferred_Actual) - and then In_Extended_Main_Source_Unit (I_Node) - and then not In_Internal_Unit (I_Node) + and then In_Extended_Main_Source_Unit (N) + and then not In_Internal_Unit (N) then Inference_Msg - (Gen_Assocs.Gen_Unit, - Inferred_To => Assoc, - Inferred_From => Gen_Assocs.Assocs (Assoc.Inferred_From), - Was_Inferred => False); + (Match.Gen_Unit, + Inferred_To => Assoc, + Inferred_From => Match.Assocs (Assoc.Inferred_From), + Was_Inferred => False); end if; end; end loop; @@ -2041,11 +2062,12 @@ package body Sem_Ch12 is -------------- function Find_Assoc - (Gen_Assocs : Gen_Assocs_Rec; F : Entity_Id) return Assoc_Index + (Match : Match_Rec; + F : Entity_Id) return Assoc_Index is begin - for Index in Gen_Assocs.Assocs'Range loop - if Defining_Entity (Gen_Assocs.Assocs (Index).An_Formal) = F then + for Index in Match.Assocs'Range loop + if Defining_Entity (Match.Assocs (Index).An_Formal) = F then return Index; end if; end loop; @@ -2058,13 +2080,14 @@ package body Sem_Ch12 is --------------------- procedure Maybe_Infer_One - (Gen_Assocs : in out Gen_Assocs_Rec; - FF, AA : N_Entity_Id; Inferred_From : Assoc_Index; - Reason : Inference_Reason) + (Match : in out Match_Rec; + FF, AA : N_Entity_Id; + Inferred_From : Assoc_Index; + Reason : Inference_Reason) is begin if not (Is_Generic_Type (FF) - and then Scope (FF) = Gen_Assocs.Gen_Unit) + and then Scope (FF) = Match.Gen_Unit) then return; -- no inference if not a formal type of this generic end if; @@ -2074,12 +2097,12 @@ package body Sem_Ch12 is end if; declare - Index : constant Assoc_Index := Find_Assoc (Gen_Assocs, FF); - Assoc : Assoc_Rec renames Gen_Assocs.Assocs (Index); + Index : constant Assoc_Index := Find_Assoc (Match, FF); + Assoc : Assoc_Rec renames Match.Assocs (Index); pragma Assert (Defining_Entity (Assoc.An_Formal) = FF); From_Actual : constant Node_Id := - Gen_Assocs.Assocs (Inferred_From).Actual.Name_Exp; + Match.Assocs (Inferred_From).Actual.Name_Exp; begin Assoc.Info_Inferred_Actual := AA; @@ -2097,23 +2120,23 @@ package body Sem_Ch12 is if Debug_Flag_Underscore_II then Inference_Msg - (Gen_Assocs.Gen_Unit, - Inferred_To => Assoc, - Inferred_From => Gen_Assocs.Assocs (Assoc.Inferred_From), - Was_Inferred => True); + (Match.Gen_Unit, + Inferred_To => Assoc, + Inferred_From => Match.Assocs (Assoc.Inferred_From), + Was_Inferred => True); end if; end if; end; end Maybe_Infer_One; - ------------------- - -- Infer_Actuals -- - ------------------- + ----------------------- + -- Infer_From_Access -- + ----------------------- procedure Infer_From_Access - (Gen_Assocs : in out Gen_Assocs_Rec; - Index : Assoc_Index; - F : Node_Id; + (Match : in out Match_Rec; + Index : Assoc_Index; + F : Node_Id; A_Full : Entity_Id) is begin @@ -2124,7 +2147,7 @@ package body Sem_Ch12 is AA : constant Entity_Id := Designated_Type (A_Full); begin Maybe_Infer_One - (Gen_Assocs, + (Match, FF, AA, Inferred_From => Index, @@ -2133,10 +2156,14 @@ package body Sem_Ch12 is end if; end Infer_From_Access; + ---------------------- + -- Infer_From_Array -- + ---------------------- + procedure Infer_From_Array - (Gen_Assocs : in out Gen_Assocs_Rec; - Index : Assoc_Index; - F : Node_Id; + (Match : in out Match_Rec; + Index : Assoc_Index; + F : Node_Id; A_Full : Entity_Id) is begin @@ -2150,7 +2177,7 @@ package body Sem_Ch12 is while Present (F_Index_Type) and then Present (A_Index_Type) loop Maybe_Infer_One - (Gen_Assocs, + (Match, Etype (F_Index_Type), Etype (A_Index_Type), Inferred_From => Index, @@ -2168,7 +2195,7 @@ package body Sem_Ch12 is Component_Type (A_Full); begin Maybe_Infer_One - (Gen_Assocs, + (Match, F_Comp_Type, A_Comp_Type, Inferred_From => Index, @@ -2177,10 +2204,14 @@ package body Sem_Ch12 is end if; end Infer_From_Array; + ------------------------------ + -- Infer_From_Discriminated -- + ------------------------------ + procedure Infer_From_Discriminated - (Gen_Assocs : in out Gen_Assocs_Rec; - Index : Assoc_Index; - F : Node_Id; + (Match : in out Match_Rec; + Index : Assoc_Index; + F : Node_Id; A_Full : Entity_Id) is begin @@ -2196,7 +2227,7 @@ package body Sem_Ch12 is begin while Present (F_Discrim) loop Maybe_Infer_One - (Gen_Assocs, + (Match, Etype (F_Discrim), Etype (A_Discrim), Inferred_From => Index, @@ -2210,23 +2241,27 @@ package body Sem_Ch12 is end if; end Infer_From_Discriminated; - procedure Infer_Actuals (Gen_Assocs : in out Gen_Assocs_Rec) is - -- Note that we can infer FROM defaults, but we cannot infer TO a - -- parameter that has a default. We can also infer from inferred - -- types. + ------------------- + -- Infer_Actuals -- + ------------------- - -- We don't need to check that multiple inferences get the same - -- answer; the second one will get a type mismatch or nonstatically - -- matching error. + -- Note that we can infer FROM defaults, but we cannot infer TO a + -- parameter that has a default. We can also infer from inferred + -- types. - -- This code needs to be robust, in the sense of tolerating illegal - -- code, because we have not yet checked all legality rules. For - -- example, if a formal type F has a discriminant whose type is - -- another formal type, then we want to infer the type of the - -- discriminant from the actual for F. That actual must have - -- discriminants, but we have not checked that rule yet, so we - -- need to tolerate an actual for F that has no discriminants. + -- We don't need to check that multiple inferences get the same + -- answer; the second one will get a type mismatch or nonstatically + -- matching error. + -- This code needs to be robust, in the sense of tolerating illegal + -- code, because we have not yet checked all legality rules. For + -- example, if a formal type F has a discriminant whose type is + -- another formal type, then we want to infer the type of the + -- discriminant from the actual for F. That actual must have + -- discriminants, but we have not checked that rule yet, so we + -- need to tolerate an actual for F that has no discriminants. + + procedure Infer_Actuals (Match : in out Match_Rec) is begin -- For each parameter, check whether we can infer FROM that one TO -- other ones. @@ -2240,12 +2275,12 @@ package body Sem_Ch12 is -- designated type. The reverse loop implies that we will see the -- array type, then the access type, then the designated type. - for Index in reverse Gen_Assocs.Assocs'Range loop -- NB: "reverse" - if Gen_Assocs.Assocs (Index).Actual.Kind = Name_Exp then + for Index in reverse Match.Assocs'Range loop -- NB: "reverse" + if Match.Assocs (Index).Actual.Kind = Name_Exp then declare - F : constant Node_Id := Gen_Assocs.Assocs (Index).An_Formal; + F : constant Node_Id := Match.Assocs (Index).An_Formal; A_E : constant Node_Id := - Gen_Assocs.Assocs (Index).Actual.Name_Exp; + Match.Assocs (Index).Actual.Name_Exp; A_Full : Entity_Id := Empty; begin if Nkind (A_E) in N_Has_Entity then @@ -2264,7 +2299,7 @@ package body Sem_Ch12 is then case Ekind (Defining_Entity (F)) is when E_Access_Type | E_General_Access_Type => - Infer_From_Access (Gen_Assocs, Index, F, A_Full); + Infer_From_Access (Match, Index, F, A_Full); when E_Access_Subtype | E_Access_Attribute_Type @@ -2274,7 +2309,7 @@ package body Sem_Ch12 is raise Program_Error; when E_Array_Type | E_Array_Subtype => - Infer_From_Array (Gen_Assocs, Index, F, A_Full); + Infer_From_Array (Match, Index, F, A_Full); when E_String_Literal_Subtype => raise Program_Error; @@ -2283,13 +2318,12 @@ package body Sem_Ch12 is null; end case; - Infer_From_Discriminated (Gen_Assocs, Index, F, A_Full); + Infer_From_Discriminated (Match, Index, F, A_Full); end if; end; end if; end loop; end Infer_Actuals; - end Associations; --------------------------- @@ -2316,46 +2350,49 @@ package body Sem_Ch12 is -------------------------- function Analyze_Associations - (I_Node : Node_Id; + (N : Node_Id; Formals : List_Id; F_Copy : List_Id) return List_Id is use Associations; - Result_Renamings : constant List_Id := New_List; + Actuals_To_Freeze : constant Elist_Id := New_Elmt_List; + Default_Actuals : constant List_Id := New_List; + Result_Renamings : constant List_Id := New_List; -- To be returned. Includes "renamings" broadly interpreted -- (e.g. subtypes are used for types). - Actuals_To_Freeze : constant Elist_Id := New_Elmt_List; - Default_Actuals : constant List_Id := New_List; - - Gen_Assocs : constant Gen_Assocs_Rec := - Match_Assocs (I_Node, Formals, F_Copy); + Match : constant Match_Rec := Match_Assocs (N, Formals, F_Copy); begin - for Matching_Actual_Index in Gen_Assocs.Assocs'Range loop + for Index in Match.Assocs'Range loop declare - Assoc : Assoc_Rec renames - Gen_Assocs.Assocs (Matching_Actual_Index); + Assoc : Assoc_Rec renames Match.Assocs (Index); + begin if Nkind (Assoc.Un_Formal) = N_Formal_Package_Declaration and then Error_Posted (Assoc.An_Formal) then -- Restrict this to N_Formal_Package_Declaration, -- because otherwise we miss errors. + Abandon_Instantiation (Instantiation_Node); end if; - if Nkind (Assoc.Un_Formal) in - N_Use_Package_Clause | N_Use_Type_Clause + if Nkind (Assoc.Un_Formal) in N_Use_Package_Clause + | N_Use_Type_Clause then - -- Copy the use clause to where it belongs: + -- Copy the use clause to where it belongs + Append (New_Copy_Tree (Assoc.Un_Formal), Result_Renamings); else Analyze_One_Association - (I_Node, Assoc, - Result_Renamings, Default_Actuals, Actuals_To_Freeze); + (N, + Assoc, + Result_Renamings, + Default_Actuals, + Actuals_To_Freeze); end if; end; end loop; @@ -2366,9 +2403,10 @@ package body Sem_Ch12 is declare Elmt : Elmt_Id := First_Elmt (Actuals_To_Freeze); + begin while Present (Elmt) loop - Freeze_Before (I_Node, Node (Elmt)); + Freeze_Before (N, Node (Elmt)); Next_Elmt (Elmt); end loop; end; @@ -2388,17 +2426,17 @@ package body Sem_Ch12 is Next (Default); end loop; - if No (Generic_Associations (I_Node)) then - Set_Generic_Associations (I_Node, Default_Actuals); + if No (Generic_Associations (N)) then + Set_Generic_Associations (N, Default_Actuals); else - Append_List_To (Generic_Associations (I_Node), Default_Actuals); + Append_List_To (Generic_Associations (N), Default_Actuals); end if; end; end if; - Note_Potential_Inference (I_Node, Gen_Assocs); + Note_Potential_Inference (N, Match); - Check_Fixed_Point_Warning (Gen_Assocs, Result_Renamings); + Check_Fixed_Point_Warning (Match, Result_Renamings); return Result_Renamings; end Analyze_Associations; @@ -2408,9 +2446,8 @@ package body Sem_Ch12 is ----------------------------- procedure Analyze_One_Association - (I_Node : Node_Id; - Assoc : Associations.Assoc_Rec; - -- Logical 'in out' parameters: + (N : Node_Id; + Assoc : Associations.Assoc_Rec; Result_Renamings : List_Id; Default_Actuals : List_Id; Actuals_To_Freeze : Elist_Id) @@ -2482,11 +2519,11 @@ package body Sem_Ch12 is if No (Match) and then not Inside_A_Generic then Append_To (Default_Actuals, - Make_Generic_Association (Sloc (I_Node), + Make_Generic_Association (Sloc (N), Selector_Name => New_Occurrence_Of (Defining_Identifier - (Assoc.Un_Formal), Sloc (I_Node)), + (Assoc.Un_Formal), Sloc (N)), Explicit_Generic_Actual_Parameter => New_Copy_Tree (Default_Expression (Assoc.Un_Formal)))); end if; @@ -2607,7 +2644,7 @@ package body Sem_Ch12 is -- unless this is a rewritten formal package, or the -- formal is an Ada 2012 formal incomplete type. - if Nkind (I_Node) = N_Formal_Package_Declaration + if Nkind (N) = N_Formal_Package_Declaration or else (Ada_Version >= Ada_2012 and then @@ -2693,7 +2730,7 @@ package body Sem_Ch12 is -- An instantiation is a freeze point for the actuals, -- unless this is a rewritten formal package. - if Nkind (I_Node) /= N_Formal_Package_Declaration + if Nkind (N) /= N_Formal_Package_Declaration and then Nkind (Match) = N_Identifier and then Is_Subprogram (Entity (Match)) @@ -2711,7 +2748,7 @@ package body Sem_Ch12 is -- subprograms defined in Standard which are used -- as generic actuals. - and then In_Same_Code_Unit (Entity (Match), I_Node) + and then In_Same_Code_Unit (Entity (Match), N) and then Has_Fully_Defined_Profile (Entity (Match)) then -- Mark the subprogram as having a delayed freeze @@ -2734,11 +2771,11 @@ package body Sem_Ch12 is begin Append_To (Default_Actuals, - Make_Generic_Association (Sloc (I_Node), + Make_Generic_Association (Sloc (N), Selector_Name => - New_Occurrence_Of (Subp, Sloc (I_Node)), + New_Occurrence_Of (Subp, Sloc (N)), Explicit_Generic_Actual_Parameter => - New_Occurrence_Of (Subp, Sloc (I_Node)))); + New_Occurrence_Of (Subp, Sloc (N)))); end; end if; @@ -2851,13 +2888,13 @@ package body Sem_Ch12 is if not Expander_Active or else not Has_Completion (Actual) - or else not In_Same_Source_Unit (I_Node, Actual) + or else not In_Same_Source_Unit (N, Actual) or else Is_Frozen (Actual) or else (Present (Renamed_Entity (Actual)) and then not In_Same_Source_Unit - (I_Node, (Renamed_Entity (Actual)))) + (N, (Renamed_Entity (Actual)))) then null; @@ -2869,7 +2906,7 @@ package body Sem_Ch12 is Needs_Freezing := True; - P := Parent (I_Node); + P := Parent (N); while Nkind (P) /= N_Compilation_Unit loop if Nkind (P) = N_Handled_Sequence_Of_Statements then @@ -3586,7 +3623,7 @@ package body Sem_Ch12 is Decls := Analyze_Associations - (I_Node => Original_Node (N), + (N => Original_Node (N), Formals => Generic_Formal_Declarations (Act_Tree), F_Copy => Generic_Formal_Declarations (Gen_Decl)); @@ -3602,9 +3639,8 @@ package body Sem_Ch12 is if No (Visible_Declarations (Specification (Pack_Decl))) then Set_Visible_Declarations (Specification (Pack_Decl), Decls); else - Insert_List_Before - (First (Visible_Declarations (Specification (Pack_Decl))), - Decls); + Prepend_List_To + (Visible_Declarations (Specification (Pack_Decl)), Decls); end if; return Pack_Decl; @@ -4860,11 +4896,10 @@ package body Sem_Ch12 is -- Local declarations - Gen_Id : constant Node_Id := Name (N); - Inst_Id : constant Entity_Id := Defining_Entity (N); - Is_Actual_Pack : constant Boolean := Is_Internal (Inst_Id); - Loc : constant Source_Ptr := Sloc (N); - + Gen_Id : constant Node_Id := Name (N); + Loc : constant Source_Ptr := Sloc (N); + Is_Abbrev : constant Boolean := + Is_Abbreviated_Instance (Defining_Entity (N)); Saved_GM : constant Ghost_Mode_Type := Ghost_Mode; Saved_IGR : constant Node_Id := Ignored_Ghost_Region; Saved_ISMP : constant Boolean := @@ -4877,7 +4912,6 @@ package body Sem_Ch12 is -- Save style check mode for restore on exit Act_Decl : Node_Id; - Act_Decl_Name : Node_Id; Act_Decl_Id : Entity_Id; Act_Spec : Node_Id; Act_Tree : Node_Id; @@ -4918,29 +4952,7 @@ package body Sem_Ch12 is Instantiation_Node := N; - -- Case of instantiation of a generic package - - if Nkind (N) = N_Package_Instantiation then - Act_Decl_Id := New_Copy (Defining_Entity (N)); - - if Nkind (Defining_Unit_Name (N)) = N_Defining_Program_Unit_Name then - Act_Decl_Name := - Make_Defining_Program_Unit_Name (Loc, - Name => - New_Copy_Tree (Name (Defining_Unit_Name (N))), - Defining_Identifier => Act_Decl_Id); - else - Act_Decl_Name := Act_Decl_Id; - end if; - - -- Case of instantiation of a formal package - - else - Act_Decl_Id := Defining_Identifier (N); - Act_Decl_Name := Act_Decl_Id; - end if; - - Generate_Definition (Act_Decl_Id); + Act_Decl_Id := New_Copy (Defining_Entity (N)); Mutate_Ekind (Act_Decl_Id, E_Package); Set_Is_Not_Self_Hidden (Act_Decl_Id); @@ -4972,7 +4984,7 @@ package body Sem_Ch12 is -- Except for an abbreviated instance created to check a formal package, -- install the parent if this is a generic child unit. - if not Is_Abbreviated_Instance (Inst_Id) then + if not Is_Abbrev then Check_Generic_Child_Unit (Gen_Id, Parent_Installed); end if; @@ -5075,9 +5087,6 @@ package body Sem_Ch12 is goto Leave; else - Mutate_Ekind (Inst_Id, E_Package); - Set_Scope (Inst_Id, Current_Scope); - -- If the context of the instance is subject to SPARK_Mode "off" or -- the annotation is altogether missing, set the global flag which -- signals Analyze_Pragma to ignore all SPARK_Mode pragmas within @@ -5115,22 +5124,38 @@ package body Sem_Ch12 is -- If this is the instance created to validate an actual package, -- only the formals matter, do not examine the package spec itself. - if Is_Actual_Pack then + if Is_Abbrev then Set_Visible_Declarations (Act_Spec, New_List); Set_Private_Declarations (Act_Spec, New_List); end if; Renamings := Analyze_Associations - (I_Node => N, + (N => N, Formals => Generic_Formal_Declarations (Act_Tree), F_Copy => Generic_Formal_Declarations (Gen_Decl)); Vis_Prims_List := Check_Hidden_Primitives (Renamings); + -- Set minimal decoration on the original entity + + Mutate_Ekind (Defining_Entity (N), E_Package); + Set_Scope (Defining_Entity (N), Current_Scope); + Set_Instance_Env (Gen_Unit, Act_Decl_Id); - Set_Defining_Unit_Name (Act_Spec, Act_Decl_Name); Set_Is_Generic_Instance (Act_Decl_Id); + Generate_Definition (Act_Decl_Id); + + if Nkind (Defining_Unit_Name (N)) = N_Defining_Program_Unit_Name then + Set_Defining_Unit_Name (Act_Spec, + Make_Defining_Program_Unit_Name (Loc, + Name => + New_Copy_Tree (Name (Defining_Unit_Name (N))), + Defining_Identifier => Act_Decl_Id)); + else + Set_Defining_Unit_Name (Act_Spec, Act_Decl_Id); + end if; + Set_Generic_Parent (Act_Spec, Gen_Unit); -- References to the generic in its own declaration or its body are @@ -5274,7 +5299,7 @@ package body Sem_Ch12 is and then (not Is_Child_Unit (Gen_Unit) or else not Is_Generic_Unit (Scope (Gen_Unit))) and then Might_Inline_Subp (Gen_Unit) - and then not Is_Actual_Pack + and then not Is_Abbrev then if not Back_End_Inlining and then (Front_End_Inlining or else Has_Inline_Always) @@ -5319,7 +5344,7 @@ package body Sem_Ch12 is or else Enclosing_Body_Present or else Present (Corresponding_Body (Gen_Decl))) and then Needs_Body_Instantiated (Gen_Unit) - and then not Is_Actual_Pack + and then not Is_Abbrev and then not Inline_Now and then (Operating_Mode = Generate_Code or else (Operating_Mode = Check_Semantics @@ -6032,6 +6057,10 @@ package body Sem_Ch12 is if (Is_In_Main_Unit (N) or else Is_Inlined_Or_Child_Of_Inlined (Subp)) + -- No need to instantiate bodies in generic units + + and then not Is_Generic_Unit (Cunit_Entity (Main_Unit)) + -- Must be generating code or analyzing code in GNATprove mode and then (Operating_Mode = Generate_Code @@ -6451,7 +6480,7 @@ package body Sem_Ch12 is Renamings := Analyze_Associations - (I_Node => N, + (N => N, Formals => Generic_Formal_Declarations (Act_Tree), F_Copy => Generic_Formal_Declarations (Gen_Decl)); @@ -7559,14 +7588,15 @@ package body Sem_Ch12 is ------------------------------- procedure Check_Fixed_Point_Warning - (Gen_Assocs : Associations.Gen_Assocs_Rec; + (Match : Associations.Match_Rec; Renamings : List_Id) is use Associations; + begin - for Type_Index in Gen_Assocs.Assocs'Range loop + for Type_Index in Match.Assocs'Range loop declare - Assoc : Assoc_Rec renames Gen_Assocs.Assocs (Type_Index); + Assoc : Assoc_Rec renames Match.Assocs (Type_Index); begin if Nkind (Assoc.An_Formal) = N_Formal_Type_Declaration and then Is_Fixed_Point_Type (Defining_Entity (Assoc.An_Formal)) @@ -7595,9 +7625,9 @@ package body Sem_Ch12 is Op := Alias (Node (Elem)); for Op_Index in Type_Index + 1 .. - Gen_Assocs.Assocs'Last + Match.Assocs'Last loop - Formal := Gen_Assocs.Assocs (Op_Index).Un_Formal; + Formal := Match.Assocs (Op_Index).Un_Formal; if Nkind (Formal) = N_Formal_Concrete_Subprogram_Declaration @@ -9341,9 +9371,6 @@ package body Sem_Ch12 is and then Nkind (Ancestor_Type (N)) in N_Entity then declare - Root_Typ : constant Entity_Id := - Root_Type (Ancestor_Type (N)); - Typ : Entity_Id := Ancestor_Type (N); begin @@ -9352,7 +9379,7 @@ package body Sem_Ch12 is Switch_View (Typ); end if; - exit when Typ = Root_Typ; + exit when Etype (Typ) = Typ; Typ := Etype (Typ); end loop; @@ -10057,13 +10084,12 @@ package body Sem_Ch12 is -- the freeze node for Inst must be inserted after that of -- Parent_Inst. This relation is established by comparing -- the Slocs of Parent_Inst freeze node and Inst. - -- We examine the parents of the enclosing lists to handle + -- We examine the parents (of the enclosing lists) to handle -- the case where the parent instance is in the visible part -- of a package declaration, and the inner instance is in -- the corresponding private part. - if Parent (List_Containing (Freeze_Node (Par_Id))) - = Parent (List_Containing (N)) + if Parent (Freeze_Node (Par_Id)) = Parent (N) and then Sloc (Freeze_Node (Par_Id)) <= Sloc (N) then Insert_Freeze_Node_For_Instance (N, F_Node); @@ -10382,7 +10408,8 @@ package body Sem_Ch12 is -- investigated, and would allow this function to be significantly -- simplified. ??? - Inst := Package_Instantiation (A); + Inst := + (if Ekind (A) = E_Package then Package_Instantiation (A) else Empty); if Present (Inst) then if Nkind (Inst) = N_Package_Instantiation then @@ -10429,10 +10456,11 @@ package body Sem_Ch12 is else Inst := Next (Decl); - while Nkind (Inst) not in N_Formal_Package_Declaration - | N_Function_Instantiation - | N_Package_Instantiation - | N_Procedure_Instantiation + while Present (Inst) + and then Nkind (Inst) not in N_Formal_Package_Declaration + | N_Function_Instantiation + | N_Package_Instantiation + | N_Procedure_Instantiation loop Next (Inst); end loop; @@ -14129,6 +14157,16 @@ package body Sem_Ch12 is T2 := Etype (I2); end if; + -- In the case of a fixed-lower-bound subtype, we want to check + -- against the index type's range rather than the range of the + -- subtype (which will be seen as unconstrained, and whose bounds + -- won't generally match those of the formal unconstrained array + -- type's corresponding index type). + + if Is_Fixed_Lower_Bound_Index_Subtype (T2) then + T2 := Etype (Scalar_Range (T2)); + end if; + if not Subtypes_Match (Find_Actual_Type (Etype (I1), A_Gen_T), T2) then diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 76a8c0b..22575f9 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -6208,6 +6208,7 @@ package body Sem_Ch13 is declare Expr : constant Node_Id := Expression (N); O_Ent : Entity_Id; + O_Typ : Entity_Id; Off : Boolean; begin @@ -6220,7 +6221,7 @@ package body Sem_Ch13 is return; end if; - Find_Overlaid_Entity (N, O_Ent, Off); + Find_Overlaid_Entity (N, O_Ent, O_Typ, Off); if Present (O_Ent) then @@ -6273,10 +6274,10 @@ package body Sem_Ch13 is if (Is_Record_Type (Etype (U_Ent)) or else Is_Array_Type (Etype (U_Ent))) - and then (Is_Record_Type (Etype (O_Ent)) - or else Is_Array_Type (Etype (O_Ent))) + and then (Is_Record_Type (O_Typ) + or else Is_Array_Type (O_Typ)) and then Reverse_Storage_Order (Etype (U_Ent)) /= - Reverse_Storage_Order (Etype (O_Ent)) + Reverse_Storage_Order (O_Typ) then Error_Msg_N ("??overlay changes scalar storage order", Expr); diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 690d668..425d624 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -290,6 +290,15 @@ package body Sem_Ch3 is -- Check that the expression represented by E is suitable for use as a -- digits expression, i.e. it is of integer type, positive and static. + procedure Check_Discriminant_Conformance + (N : Node_Id; + Prev : Entity_Id; + Prev_Loc : Node_Id); + -- Check that the discriminants of a full type N fully conform to the + -- discriminants of the corresponding partial view Prev. Prev_Loc indicates + -- the source location of the partial view, which may be different than + -- Prev in the case of private types. + procedure Check_Initialization (T : Entity_Id; Exp : Node_Id); -- Validate the initialization of an object declaration. T is the required -- type, and Exp is the initialization expression. @@ -382,7 +391,7 @@ package body Sem_Ch3 is -- created in the procedure and attached to Related_Nod. procedure Constrain_Array - (Def_Id : in out Entity_Id; + (Def_Id : Entity_Id; SI : Node_Id; Related_Nod : Node_Id; Related_Id : Entity_Id; @@ -1414,7 +1423,9 @@ package body Sem_Ch3 is end if; else - Setup_Access_Type (Desig_Typ => Process_Subtype (S, P, T, 'P')); + Setup_Access_Type + (Desig_Typ => + Process_Subtype (S, P, T, 'P', Incomplete_Type_OK => True)); end if; if not Error_Posted (T) then @@ -1951,7 +1962,7 @@ package body Sem_Ch3 is procedure Analyze_Component_Declaration (N : Node_Id) is Id : constant Entity_Id := Defining_Identifier (N); E : constant Node_Id := Expression (N); - Typ : constant Node_Id := + Ind : constant Node_Id := Subtype_Indication (Component_Definition (N)); T : Entity_Id; P : Entity_Id; @@ -2046,10 +2057,11 @@ package body Sem_Ch3 is -- Start of processing for Analyze_Component_Declaration begin + Mutate_Ekind (Id, E_Component); Generate_Definition (Id); Enter_Name (Id); - if Present (Typ) then + if Present (Ind) then T := Find_Type_Of_Object (Subtype_Indication (Component_Definition (N)), N); @@ -3701,8 +3713,8 @@ package body Sem_Ch3 is Set_Is_Static_Expression (E, True); Set_Etype (E, Universal_Integer); - Set_Etype (Id, Universal_Integer); Mutate_Ekind (Id, E_Named_Integer); + Set_Etype (Id, Universal_Integer); Set_Is_Frozen (Id, True); Set_Debug_Info_Needed (Id); @@ -3762,8 +3774,8 @@ package body Sem_Ch3 is if Is_Integer_Type (T) then Resolve (E, T); - Set_Etype (Id, Universal_Integer); Mutate_Ekind (Id, E_Named_Integer); + Set_Etype (Id, Universal_Integer); elsif Is_Real_Type (T) then @@ -3794,15 +3806,15 @@ package body Sem_Ch3 is end if; Resolve (E, T); - Set_Etype (Id, Universal_Real); Mutate_Ekind (Id, E_Named_Real); + Set_Etype (Id, Universal_Real); else Wrong_Type (E, Any_Numeric); Resolve (E, T); - Set_Etype (Id, T); Mutate_Ekind (Id, E_Constant); + Set_Etype (Id, T); Set_Never_Set_In_Source (Id, True); Set_Is_True_Constant (Id, True); return; @@ -3951,7 +3963,7 @@ package body Sem_Ch3 is Data_Path_String : constant String := Absolute_Dir & System.OS_Lib.Directory_Separator - & Stringt.To_String (Strval (Def)); + & S; begin Data_Path := Name_Find (Data_Path_String); @@ -4364,6 +4376,12 @@ package body Sem_Ch3 is -- Start of processing for Analyze_Object_Declaration begin + if Constant_Present (N) then + Mutate_Ekind (Id, E_Constant); + else + Mutate_Ekind (Id, E_Variable); + end if; + -- There are three kinds of implicit types generated by an -- object declaration: @@ -4443,7 +4461,6 @@ package body Sem_Ch3 is T := Find_Type_Of_Object (Object_Definition (N), N); Set_Etype (Id, T); - Mutate_Ekind (Id, E_Variable); goto Leave; end if; @@ -4469,7 +4486,6 @@ package body Sem_Ch3 is if Error_Posted (Id) then Set_Etype (Id, T); - Mutate_Ekind (Id, E_Variable); goto Leave; end if; end if; @@ -4552,7 +4568,6 @@ package body Sem_Ch3 is Error_Msg_N ("\declaration requires an initialization expression", N); - Set_Constant_Present (N, False); -- In Ada 83, deferred constant must be of private type @@ -4659,9 +4674,7 @@ package body Sem_Ch3 is Set_Has_Completion (Id); end if; - -- Set type and resolve (type may be overridden later on). Note: - -- Ekind (Id) must still be E_Void at this point so that incorrect - -- early usage within E is properly diagnosed. + -- Set type and resolve (type may be overridden later on) Set_Etype (Id, T); @@ -4761,7 +4774,6 @@ package body Sem_Ch3 is and then In_Subrange_Of (Etype (Entity (E)), T) then Set_Is_Known_Valid (Id); - Mutate_Ekind (Id, E_Constant); Set_Actual_Subtype (Id, Etype (Entity (E))); end if; @@ -5010,12 +5022,6 @@ package body Sem_Ch3 is -- for discriminants and are thus not indefinite. elsif Is_Unchecked_Union (T) then - if Constant_Present (N) or else Nkind (E) = N_Function_Call then - Mutate_Ekind (Id, E_Constant); - else - Mutate_Ekind (Id, E_Variable); - end if; - -- If the expression is an aggregate it contains the required -- discriminant values but it has not been resolved yet, so do -- it now, and treat it as the initial expression of an object @@ -5076,10 +5082,8 @@ package body Sem_Ch3 is -- "X : Integer := X;". if Constant_Present (N) then - Mutate_Ekind (Id, E_Constant); Set_Is_True_Constant (Id); else - Mutate_Ekind (Id, E_Variable); if Present (E) then Set_Has_Initial_Value (Id); end if; @@ -5221,12 +5225,9 @@ package body Sem_Ch3 is end if; if Constant_Present (N) then - Mutate_Ekind (Id, E_Constant); Set_Is_True_Constant (Id); else - Mutate_Ekind (Id, E_Variable); - -- A variable is set as shared passive if it appears in a shared -- passive package, and is at the outer level. This is not done for -- entities generated during expansion, because those are always @@ -5779,7 +5780,15 @@ package body Sem_Ch3 is Enter_Name (Id); end if; - T := Process_Subtype (Subtype_Indication (N), N, Id, 'P'); + T := + Process_Subtype + (Subtype_Indication (N), + N, + Id, + 'P', + Excludes_Null => Null_Exclusion_Present (N), + Incomplete_Type_OK => + Ada_Version >= Ada_2005 or else Is_Itype (Id)); -- Class-wide equivalent types of records with unknown discriminants -- involve the generation of an itype which serves as the private view @@ -6459,12 +6468,15 @@ package body Sem_Ch3 is Priv : Entity_Id; Related_Id : Entity_Id; Has_FLB_Index : Boolean := False; + K : Entity_Kind; begin if Nkind (Def) = N_Constrained_Array_Definition then Index := First (Discrete_Subtype_Definitions (Def)); + K := E_Array_Subtype; else Index := First (Subtype_Marks (Def)); + K := E_Array_Type; end if; -- Find proper names for the implicit types which may be public. In case @@ -6596,7 +6608,13 @@ package body Sem_Ch3 is -- Process subtype indication if one is present if Present (Component_Typ) then - Element_Type := Process_Subtype (Component_Typ, P, Related_Id, 'C'); + Element_Type := + Process_Subtype + (Component_Typ, + P, + Related_Id, + 'C', + Excludes_Null => Null_Exclusion_Present (Component_Def)); Set_Etype (Component_Typ, Element_Type); -- Ada 2005 (AI-230): Access Definition case @@ -6637,7 +6655,7 @@ package body Sem_Ch3 is -- them unique suffixes, because GNATprove require distinct types to -- have different names. - T := Create_Itype (E_Void, P, Related_Id, 'T', Suffix_Index => -1); + T := Create_Itype (K, P, Related_Id, 'T', Suffix_Index => -1); end if; -- Constrained array case @@ -7212,7 +7230,11 @@ package body Sem_Ch3 is Set_Directly_Designated_Type (Derived_Type, Designated_Type (Parent_Type)); - Subt := Process_Subtype (S, N); + Subt := + Process_Subtype + (S, + N, + Excludes_Null => Null_Exclusion_Present (Type_Definition (N))); if Nkind (S) /= N_Subtype_Indication and then Subt /= Base_Type (Subt) @@ -8114,9 +8136,6 @@ package body Sem_Ch3 is Set_Non_Binary_Modulus (Implicit_Base, Non_Binary_Modulus (Parent_Base)); - Set_Is_Known_Valid - (Implicit_Base, Is_Known_Valid (Parent_Base)); - elsif Is_Floating_Point_Type (Parent_Type) then -- Digits of base type is always copied from the digits value of @@ -8489,11 +8508,19 @@ package body Sem_Ch3 is Analyze (Decl); - pragma Assert (Has_Discriminants (Full_Der) - and then not Has_Unknown_Discriminants (Full_Der)); + pragma + Assert + ((Has_Discriminants (Full_Der) + and then not Has_Unknown_Discriminants (Full_Der)) + or else Serious_Errors_Detected > 0); Uninstall_Declarations (Par_Scope); + if Etype (Full_Der) = Any_Type then + pragma Assert (Serious_Errors_Detected > 0); + return; + end if; + -- Freeze the underlying record view, to prevent generation of -- useless dispatching information, which is simply shared with -- the real derived type. @@ -9458,8 +9485,8 @@ package body Sem_Ch3 is if Constraint_Present then if not Has_Discriminants (Parent_Base) or else - (Has_Unknown_Discriminants (Parent_Base) - and then Is_Private_Type (Parent_Base)) + (Has_Unknown_Discriminants (Parent_Type) + and then Is_Private_Type (Parent_Type)) then Error_Msg_N ("invalid constraint: type has no discriminant", @@ -12668,6 +12695,249 @@ package body Sem_Ch3 is end Check_Digits_Expression; + ------------------------------------ + -- Check_Discriminant_Conformance -- + ------------------------------------ + + procedure Check_Discriminant_Conformance + (N : Node_Id; + Prev : Entity_Id; + Prev_Loc : Node_Id) + is + Old_Discr : Entity_Id := First_Discriminant (Prev); + New_Discr : Node_Id := First (Discriminant_Specifications (N)); + New_Discr_Id : Entity_Id; + New_Discr_Type : Entity_Id; + + procedure Conformance_Error (Msg : String; N : Node_Id); + -- Post error message for conformance error on given node. Two messages + -- are output. The first points to the previous declaration with a + -- general "no conformance" message. The second is the detailed reason, + -- supplied as Msg. The parameter N provide information for a possible + -- & insertion in the message. + + ----------------------- + -- Conformance_Error -- + ----------------------- + + procedure Conformance_Error (Msg : String; N : Node_Id) is + begin + Error_Msg_Sloc := Sloc (Prev_Loc); + Error_Msg_N -- CODEFIX + ("not fully conformant with declaration#!", N); + Error_Msg_NE (Msg, N, N); + end Conformance_Error; + + -- Start of processing for Check_Discriminant_Conformance + + begin + while Present (Old_Discr) and then Present (New_Discr) loop + New_Discr_Id := Defining_Identifier (New_Discr); + + -- The subtype mark of the discriminant on the full type has not + -- been analyzed so we do it here. For an access discriminant a new + -- type is created. + + if Nkind (Discriminant_Type (New_Discr)) = N_Access_Definition then + New_Discr_Type := + Access_Definition (N, Discriminant_Type (New_Discr)); + + else + Find_Type (Discriminant_Type (New_Discr)); + New_Discr_Type := Etype (Discriminant_Type (New_Discr)); + + -- Ada 2005: if the discriminant definition carries a null + -- exclusion, create an itype to check properly for consistency + -- with partial declaration. + + if Is_Access_Type (New_Discr_Type) + and then Null_Exclusion_Present (New_Discr) + then + New_Discr_Type := + Create_Null_Excluding_Itype + (T => New_Discr_Type, + Related_Nod => New_Discr, + Scope_Id => Current_Scope); + end if; + end if; + + if not Conforming_Types + (Etype (Old_Discr), New_Discr_Type, Fully_Conformant) + then + Conformance_Error ("type of & does not match!", New_Discr_Id); + return; + else + -- Treat the new discriminant as an occurrence of the old one, + -- for navigation purposes, and fill in some semantic + -- information, for completeness. + + Generate_Reference (Old_Discr, New_Discr_Id, 'r'); + Set_Etype (New_Discr_Id, Etype (Old_Discr)); + Set_Scope (New_Discr_Id, Scope (Old_Discr)); + end if; + + -- Names must match + + if Chars (Old_Discr) /= Chars (Defining_Identifier (New_Discr)) then + Conformance_Error ("name & does not match!", New_Discr_Id); + return; + end if; + + -- Default expressions must match + + declare + NewD : constant Boolean := + Present (Expression (New_Discr)); + OldD : constant Boolean := + Present (Expression (Parent (Old_Discr))); + + function Has_Tagged_Limited_Partial_View + (Typ : Entity_Id) return Boolean; + -- Returns True iff Typ has a tagged limited partial view. + + function Is_Derived_From_Immutably_Limited_Type + (Typ : Entity_Id) return Boolean; + -- Returns True iff Typ is a derived type (tagged or not) + -- whose ancestor type is immutably limited. The unusual + -- ("unusual" is one word for it) thing about this function + -- is that it handles the case where the ancestor name's Entity + -- attribute has not been set yet. + + ------------------------------------- + -- Has_Tagged_Limited_Partial_View -- + ------------------------------------- + + function Has_Tagged_Limited_Partial_View + (Typ : Entity_Id) return Boolean + is + Priv : constant Entity_Id := Incomplete_Or_Partial_View (Typ); + begin + return Present (Priv) + and then not Is_Incomplete_Type (Priv) + and then Is_Tagged_Type (Priv) + and then Limited_Present (Parent (Priv)); + end Has_Tagged_Limited_Partial_View; + + -------------------------------------------- + -- Is_Derived_From_Immutably_Limited_Type -- + -------------------------------------------- + + function Is_Derived_From_Immutably_Limited_Type + (Typ : Entity_Id) return Boolean + is + Type_Def : constant Node_Id := Type_Definition (Parent (Typ)); + Parent_Name : Node_Id; + begin + if Nkind (Type_Def) /= N_Derived_Type_Definition then + return False; + end if; + Parent_Name := Subtype_Indication (Type_Def); + if Nkind (Parent_Name) = N_Subtype_Indication then + Parent_Name := Subtype_Mark (Parent_Name); + end if; + if Parent_Name not in N_Has_Entity_Id + or else No (Entity (Parent_Name)) + then + Find_Type (Parent_Name); + end if; + return Is_Immutably_Limited_Type (Entity (Parent_Name)); + end Is_Derived_From_Immutably_Limited_Type; + + begin + if NewD or OldD then + + -- The old default value has been analyzed and expanded, + -- because the current full declaration will have frozen + -- everything before. The new default values have not been + -- expanded, so expand now to check conformance. + + if NewD then + Preanalyze_And_Resolve_Spec_Expression + (Expression (New_Discr), New_Discr_Type); + end if; + + if not (NewD and OldD) + or else not Fully_Conformant_Expressions + (Expression (Parent (Old_Discr)), + Expression (New_Discr)) + + then + Conformance_Error + ("default expression for & does not match!", + New_Discr_Id); + return; + end if; + + if NewD + and then Ada_Version >= Ada_2005 + and then Nkind (Discriminant_Type (New_Discr)) = + N_Access_Definition + and then not Is_Immutably_Limited_Type + (Defining_Identifier (N)) + + -- Check for a case that would be awkward to handle in + -- Is_Immutably_Limited_Type (because sem_aux can't + -- "with" sem_util). + + and then not Has_Tagged_Limited_Partial_View + (Defining_Identifier (N)) + + -- Check for another case that would be awkward to handle + -- in Is_Immutably_Limited_Type + + and then not Is_Derived_From_Immutably_Limited_Type + (Defining_Identifier (N)) + then + Error_Msg_N + ("(Ada 2005) default value for access discriminant " + & "requires immutably limited type", + Expression (New_Discr)); + return; + end if; + end if; + end; + + -- In Ada 83 case, grouping must match: (A,B : X) /= (A : X; B : X) + + if Ada_Version = Ada_83 then + declare + Old_Disc : constant Node_Id := Declaration_Node (Old_Discr); + + begin + -- Grouping (use of comma in param lists) must be the same + -- This is where we catch a misconformance like: + + -- A, B : Integer + -- A : Integer; B : Integer + + -- which are represented identically in the tree except + -- for the setting of the flags More_Ids and Prev_Ids. + + if More_Ids (Old_Disc) /= More_Ids (New_Discr) + or else Prev_Ids (Old_Disc) /= Prev_Ids (New_Discr) + then + Conformance_Error + ("grouping of & does not match!", New_Discr_Id); + return; + end if; + end; + end if; + + Next_Discriminant (Old_Discr); + Next (New_Discr); + end loop; + + if Present (Old_Discr) then + Conformance_Error ("too few discriminants!", Defining_Identifier (N)); + return; + + elsif Present (New_Discr) then + Conformance_Error + ("too many discriminants!", Defining_Identifier (New_Discr)); + return; + end if; + end Check_Discriminant_Conformance; + -------------------------- -- Check_Initialization -- -------------------------- @@ -13970,7 +14240,7 @@ package body Sem_Ch3 is --------------------- procedure Constrain_Array - (Def_Id : in out Entity_Id; + (Def_Id : Entity_Id; SI : Node_Id; Related_Nod : Node_Id; Related_Id : Entity_Id; @@ -14070,14 +14340,7 @@ package body Sem_Ch3 is end if; end if; - if No (Def_Id) then - Def_Id := - Create_Itype (E_Array_Subtype, Related_Nod, Related_Id, Suffix); - Set_Parent (Def_Id, Related_Nod); - - else - Mutate_Ekind (Def_Id, E_Array_Subtype); - end if; + Mutate_Ekind (Def_Id, E_Array_Subtype); Set_Size_Info (Def_Id, (T)); Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); @@ -14963,17 +15226,24 @@ package body Sem_Ch3 is R : Node_Id := Empty; T : constant Entity_Id := Etype (Index); Is_FLB_Index : Boolean := False; + Is_Range : constant Boolean := + Nkind (S) = N_Range + or else (Nkind (S) = N_Attribute_Reference + and then Attribute_Name (S) = Name_Range); + Is_Indic : constant Boolean := Nkind (S) = N_Subtype_Indication; + K : constant Entity_Kind := + (if Is_Modular_Integer_Type (T) then E_Modular_Integer_Subtype + elsif Is_Integer_Type (T) then E_Signed_Integer_Subtype + else E_Enumeration_Subtype); begin - Def_Id := - Create_Itype (E_Void, Related_Nod, Related_Id, Suffix, Suffix_Index); - Set_Etype (Def_Id, Base_Type (T)); + if Is_Range or else Is_Indic then + Def_Id := + Create_Itype (K, Related_Nod, Related_Id, Suffix, Suffix_Index); + Set_Etype (Def_Id, Base_Type (T)); + end if; - if Nkind (S) = N_Range - or else - (Nkind (S) = N_Attribute_Reference - and then Attribute_Name (S) = Name_Range) - then + if Is_Range then -- A Range attribute will be transformed into N_Range by Resolve -- If a range has an Empty upper bound, then remember that for later @@ -15008,7 +15278,7 @@ package body Sem_Ch3 is end if; end if; - elsif Nkind (S) = N_Subtype_Indication then + elsif Is_Indic then -- The parser has verified that this is a discrete indication @@ -15063,27 +15333,19 @@ package body Sem_Ch3 is S, Entity (S)); end if; - return; - else Error_Msg_N ("invalid index constraint", S); Rewrite (S, New_Occurrence_Of (T, Sloc (S))); - return; end if; + + return; end if; -- Complete construction of the Itype - if Is_Modular_Integer_Type (T) then - Mutate_Ekind (Def_Id, E_Modular_Integer_Subtype); - - elsif Is_Integer_Type (T) then - Mutate_Ekind (Def_Id, E_Signed_Integer_Subtype); - - else - Mutate_Ekind (Def_Id, E_Enumeration_Subtype); + if K = E_Enumeration_Subtype then Set_Is_Character_Type (Def_Id, Is_Character_Type (T)); - Set_First_Literal (Def_Id, First_Literal (T)); + Set_First_Literal (Def_Id, First_Literal (T)); end if; Set_Size_Info (Def_Id, (T)); @@ -15093,7 +15355,8 @@ package body Sem_Ch3 is -- If this is a range for a fixed-lower-bound subtype, then set the -- index itype's low bound to the FLB and the index itype's upper bound -- to the high bound of the parent array type's index subtype. Also, - -- mark the itype as an FLB index subtype. + -- set the Etype of the new scalar range and mark the itype as an FLB + -- index subtype. if Nkind (S) = N_Range and then Is_FLB_Index then Set_Scalar_Range @@ -15101,6 +15364,7 @@ package body Sem_Ch3 is Make_Range (Sloc (S), Low_Bound => Low_Bound (S), High_Bound => Type_High_Bound (T))); + Set_Etype (Scalar_Range (Def_Id), Etype (Index)); Set_Is_Fixed_Lower_Bound_Index_Subtype (Def_Id); else @@ -18833,10 +19097,15 @@ package body Sem_Ch3 is or else Nkind (P) /= N_Object_Declaration or else Is_Library_Level_Entity (Defining_Identifier (P))); - -- Otherwise, the object definition is just a subtype_mark + -- Otherwise, either the object definition is just a subtype_mark or we + -- are analyzing a component declaration. else - T := Process_Subtype (Obj_Def, Related_Nod); + T := + Process_Subtype + (Obj_Def, + Related_Nod, + Excludes_Null => Null_Exclusion_Present (Parent (Obj_Def))); end if; return T; @@ -19844,7 +20113,9 @@ package body Sem_Ch3 is -- Start of processing for Is_Visible_Component begin - if Ekind (C) in E_Component | E_Discriminant then + if Ekind (C) in E_Component | E_Discriminant + and then Is_Not_Self_Hidden (C) + then Original_Comp := Original_Record_Component (C); end if; @@ -20339,17 +20610,17 @@ package body Sem_Ch3 is if No (Def_Id) then Def_Id := - Create_Itype (E_Void, Related_Nod, Related_Id, 'D', Suffix_Index); + Create_Itype + ((if Is_Signed_Integer_Type (T) then E_Signed_Integer_Subtype + elsif Is_Modular_Integer_Type (T) then E_Modular_Integer_Subtype + else E_Enumeration_Subtype), + Related_Nod, + Related_Id, + 'D', + Suffix_Index); Set_Etype (Def_Id, Base_Type (T)); - if Is_Signed_Integer_Type (T) then - Mutate_Ekind (Def_Id, E_Signed_Integer_Subtype); - - elsif Is_Modular_Integer_Type (T) then - Mutate_Ekind (Def_Id, E_Modular_Integer_Subtype); - - else - Mutate_Ekind (Def_Id, E_Enumeration_Subtype); + if Ekind (Def_Id) = E_Enumeration_Subtype then Set_Is_Character_Type (Def_Id, Is_Character_Type (T)); Set_First_Literal (Def_Id, First_Literal (T)); end if; @@ -20983,6 +21254,12 @@ package body Sem_Ch3 is Discr := First (Discriminant_Specifications (N)); while Present (Discr) loop + if Ekind (Defining_Identifier (Discr)) = E_In_Parameter then + Reinit_Field_To_Zero + (Defining_Identifier (Discr), F_Discriminal_Link); + end if; + + Mutate_Ekind (Defining_Identifier (Discr), E_Discriminant); Enter_Name (Defining_Identifier (Discr)); -- For navigation purposes we add a reference to the discriminant @@ -21258,11 +21535,6 @@ package body Sem_Ch3 is while Present (Discr) loop Id := Defining_Identifier (Discr); - if Ekind (Id) = E_In_Parameter then - Reinit_Field_To_Zero (Id, F_Discriminal_Link); - end if; - - Mutate_Ekind (Id, E_Discriminant); Set_Is_Not_Self_Hidden (Id); Reinit_Component_Location (Id); Reinit_Esize (Id); @@ -22509,10 +22781,12 @@ package body Sem_Ch3 is --------------------- function Process_Subtype - (S : Node_Id; - Related_Nod : Node_Id; - Related_Id : Entity_Id := Empty; - Suffix : Character := ' ') return Entity_Id + (S : Node_Id; + Related_Nod : Node_Id; + Related_Id : Entity_Id := Empty; + Suffix : Character := ' '; + Excludes_Null : Boolean := False; + Incomplete_Type_OK : Boolean := False) return Entity_Id is procedure Check_Incomplete (T : Node_Id); -- Called to verify that an incomplete type is not used prematurely @@ -22526,13 +22800,7 @@ package body Sem_Ch3 is -- Ada 2005 (AI-412): Incomplete subtypes are legal if Ekind (Root_Type (Entity (T))) = E_Incomplete_Type - and then - not (Ada_Version >= Ada_2005 - and then - (Nkind (Parent (T)) = N_Subtype_Declaration - or else (Nkind (Parent (T)) = N_Subtype_Indication - and then Nkind (Parent (Parent (T))) = - N_Subtype_Declaration))) + and then not Incomplete_Type_OK then Error_Msg_N ("invalid use of type before its full declaration", T); end if; @@ -22540,126 +22808,91 @@ package body Sem_Ch3 is -- Local variables - P : Node_Id; + P : constant Node_Id := Parent (S); + Mark : Node_Id; Def_Id : Entity_Id; Error_Node : Node_Id; Full_View_Id : Entity_Id; Subtype_Mark_Id : Entity_Id; - May_Have_Null_Exclusion : Boolean; - -- Start of processing for Process_Subtype begin - -- Case of no constraints present - - if Nkind (S) /= N_Subtype_Indication then - Find_Type (S); - - -- No way to proceed if the subtype indication is malformed. This - -- will happen for example when the subtype indication in an object - -- declaration is missing altogether and the expression is analyzed - -- as if it were that indication. - - if not Is_Entity_Name (S) then - return Any_Type; - end if; + if Nkind (S) = N_Subtype_Indication then + Mark := Subtype_Mark (S); + else + Mark := S; + end if; - Check_Incomplete (S); - P := Parent (S); + Find_Type (Mark); - -- The following mirroring of assertion in Null_Exclusion_Present is - -- ugly, can't we have a range, a static predicate or even a flag??? + -- No way to proceed if the subtype indication is malformed. This will + -- happen for example when the subtype indication in an object + -- declaration is missing altogether and the expression is analyzed as + -- if it were that indication. - May_Have_Null_Exclusion := - Present (P) - and then - Nkind (P) in N_Access_Definition - | N_Access_Function_Definition - | N_Access_Procedure_Definition - | N_Access_To_Object_Definition - | N_Allocator - | N_Component_Definition - | N_Derived_Type_Definition - | N_Discriminant_Specification - | N_Formal_Object_Declaration - | N_Function_Specification - | N_Object_Declaration - | N_Object_Renaming_Declaration - | N_Parameter_Specification - | N_Subtype_Declaration; - - -- Ada 2005 (AI-231): Static check + if not Is_Entity_Name (Mark) then + return Any_Type; + end if; - if Ada_Version >= Ada_2005 - and then May_Have_Null_Exclusion - and then Null_Exclusion_Present (P) - and then Nkind (P) /= N_Access_To_Object_Definition - and then not Is_Access_Type (Entity (S)) - then - Error_Msg_N ("`NOT NULL` only allowed for an access type", S); - end if; + Check_Incomplete (Mark); - -- Create an Itype that is a duplicate of Entity (S) but with the - -- null-exclusion attribute. + -- Case of no constraints present - if May_Have_Null_Exclusion - and then Is_Access_Type (Entity (S)) - and then Null_Exclusion_Present (P) + if Nkind (S) /= N_Subtype_Indication then + if Excludes_Null then + -- Create an Itype that is a duplicate of Entity (S) but with the + -- null-exclusion attribute. + if Is_Access_Type (Entity (S)) then + if Can_Never_Be_Null (Entity (S)) then + case Nkind (Related_Nod) is + when N_Full_Type_Declaration => + if Nkind (Type_Definition (Related_Nod)) + in N_Array_Type_Definition + then + Error_Node := + Subtype_Indication + (Component_Definition + (Type_Definition (Related_Nod))); + else + Error_Node := + Subtype_Indication + (Type_Definition (Related_Nod)); + end if; - -- No need to check the case of an access to object definition. - -- It is correct to define double not-null pointers. + when N_Subtype_Declaration => + Error_Node := Subtype_Indication (Related_Nod); - -- Example: - -- type Not_Null_Int_Ptr is not null access Integer; - -- type Acc is not null access Not_Null_Int_Ptr; + when N_Object_Declaration => + Error_Node := Object_Definition (Related_Nod); - and then Nkind (P) /= N_Access_To_Object_Definition - then - if Can_Never_Be_Null (Entity (S)) then - case Nkind (Related_Nod) is - when N_Full_Type_Declaration => - if Nkind (Type_Definition (Related_Nod)) - in N_Array_Type_Definition - then + when N_Component_Declaration => Error_Node := Subtype_Indication - (Component_Definition - (Type_Definition (Related_Nod))); - else - Error_Node := - Subtype_Indication (Type_Definition (Related_Nod)); - end if; - - when N_Subtype_Declaration => - Error_Node := Subtype_Indication (Related_Nod); + (Component_Definition (Related_Nod)); - when N_Object_Declaration => - Error_Node := Object_Definition (Related_Nod); + when N_Allocator => + Error_Node := Expression (Related_Nod); - when N_Component_Declaration => - Error_Node := - Subtype_Indication (Component_Definition (Related_Nod)); + when others => + pragma Assert (False); + Error_Node := Related_Nod; + end case; - when N_Allocator => - Error_Node := Expression (Related_Nod); - - when others => - pragma Assert (False); - Error_Node := Related_Nod; - end case; + Error_Msg_NE + ("`NOT NULL` not allowed (& already excludes null)", + Error_Node, + Entity (S)); + end if; - Error_Msg_NE - ("`NOT NULL` not allowed (& already excludes null)", - Error_Node, - Entity (S)); + Set_Etype + (S, + Create_Null_Excluding_Itype + (T => Entity (S), Related_Nod => P)); + Set_Entity (S, Etype (S)); + elsif Ada_Version >= Ada_2005 then + Error_Msg_N ("`NOT NULL` only allowed for an access type", S); end if; - - Set_Etype (S, - Create_Null_Excluding_Itype - (T => Entity (S), - Related_Nod => P)); - Set_Entity (S, Etype (S)); end if; return Entity (S); @@ -22668,18 +22901,7 @@ package body Sem_Ch3 is -- node (this node is created only if constraints are present). else - Find_Type (Subtype_Mark (S)); - - if Nkind (Parent (S)) /= N_Access_To_Object_Definition - and then not - (Nkind (Parent (S)) = N_Subtype_Declaration - and then Is_Itype (Defining_Identifier (Parent (S)))) - then - Check_Incomplete (Subtype_Mark (S)); - end if; - - P := Parent (S); - Subtype_Mark_Id := Entity (Subtype_Mark (S)); + Subtype_Mark_Id := Entity (Mark); -- Explicit subtype declaration case @@ -22699,8 +22921,7 @@ package body Sem_Ch3 is -- has not yet been called to create Def_Id. else - if Is_Array_Type (Subtype_Mark_Id) - or else Is_Concurrent_Type (Subtype_Mark_Id) + if Is_Concurrent_Type (Subtype_Mark_Id) or else Is_Access_Type (Subtype_Mark_Id) then Def_Id := Empty; @@ -22733,7 +22954,14 @@ package body Sem_Ch3 is -- Make recursive call, having got rid of the bogus constraint - return Process_Subtype (S, Related_Nod, Related_Id, Suffix); + return + Process_Subtype + (S, + Related_Nod, + Related_Id, + Suffix, + Excludes_Null, + Incomplete_Type_OK); end if; -- Remaining processing depends on type. Select on Base_Type kind to @@ -22753,6 +22981,8 @@ package body Sem_Ch3 is Error_Msg_N ("constraint on class-wide type ignored??", Constraint (S)); + else + pragma Assert (False); end if; if Nkind (P) = N_Subtype_Declaration then @@ -22881,8 +23111,8 @@ package body Sem_Ch3 is -- Size, Alignment, Representation aspects and Convention are always -- inherited from the base type. - Set_Size_Info (Def_Id, (Subtype_Mark_Id)); - Set_Rep_Info (Def_Id, (Subtype_Mark_Id)); + Set_Size_Info (Def_Id, Subtype_Mark_Id); + Set_Rep_Info (Def_Id, Subtype_Mark_Id); Set_Convention (Def_Id, Convention (Subtype_Mark_Id)); -- The anonymous subtype created for the subtype indication @@ -23134,10 +23364,8 @@ package body Sem_Ch3 is Component := First_Entity (Current_Scope); while Present (Component) loop - if Ekind (Component) = E_Void - and then not Is_Itype (Component) + if Ekind (Component) = E_Component and then not Is_Itype (Component) then - Mutate_Ekind (Component, E_Component); Reinit_Component_Location (Component); Set_Is_Not_Self_Hidden (Component); end if; diff --git a/gcc/ada/sem_ch3.ads b/gcc/ada/sem_ch3.ads index 00a6fa77..a97393d 100644 --- a/gcc/ada/sem_ch3.ads +++ b/gcc/ada/sem_ch3.ads @@ -301,10 +301,12 @@ package Sem_Ch3 is -- in this case the bounds are captured if necessary using this name. function Process_Subtype - (S : Node_Id; - Related_Nod : Node_Id; - Related_Id : Entity_Id := Empty; - Suffix : Character := ' ') return Entity_Id; + (S : Node_Id; + Related_Nod : Node_Id; + Related_Id : Entity_Id := Empty; + Suffix : Character := ' '; + Excludes_Null : Boolean := False; + Incomplete_Type_OK : Boolean := False) return Entity_Id; -- Process a subtype indication S and return corresponding entity. -- Related_Nod is the node where the potential generated implicit types -- will be inserted. The Related_Id and Suffix parameters are used to diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 9a1784f..ec48edd 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -728,7 +728,8 @@ package body Sem_Ch4 is end; end if; - Type_Id := Process_Subtype (E, N); + Type_Id := + Process_Subtype (E, N, Excludes_Null => Null_Exclusion_Present (N)); Acc_Type := Create_Itype (E_Allocator_Type, N); Set_Etype (Acc_Type, Acc_Type); Set_Directly_Designated_Type (Acc_Type, Type_Id); diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 91321710..0ecc6d8 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -225,7 +225,10 @@ package body Sem_Ch6 is -- Create the declaration for an inequality operator that is implicitly -- created by a user-defined equality operator that yields a boolean. - procedure Set_Formal_Mode (Formal_Id : Entity_Id); + procedure Set_Formal_Mode + (Formal_Id : Entity_Id; + Spec : N_Parameter_Specification_Id; + Subp_Id : Entity_Id); -- Set proper Ekind to reflect formal mode (in, out, in out), and set -- miscellaneous other attributes. @@ -6463,249 +6466,6 @@ package body Sem_Ch6 is end if; end Check_Delayed_Subprogram; - ------------------------------------ - -- Check_Discriminant_Conformance -- - ------------------------------------ - - procedure Check_Discriminant_Conformance - (N : Node_Id; - Prev : Entity_Id; - Prev_Loc : Node_Id) - is - Old_Discr : Entity_Id := First_Discriminant (Prev); - New_Discr : Node_Id := First (Discriminant_Specifications (N)); - New_Discr_Id : Entity_Id; - New_Discr_Type : Entity_Id; - - procedure Conformance_Error (Msg : String; N : Node_Id); - -- Post error message for conformance error on given node. Two messages - -- are output. The first points to the previous declaration with a - -- general "no conformance" message. The second is the detailed reason, - -- supplied as Msg. The parameter N provide information for a possible - -- & insertion in the message. - - ----------------------- - -- Conformance_Error -- - ----------------------- - - procedure Conformance_Error (Msg : String; N : Node_Id) is - begin - Error_Msg_Sloc := Sloc (Prev_Loc); - Error_Msg_N -- CODEFIX - ("not fully conformant with declaration#!", N); - Error_Msg_NE (Msg, N, N); - end Conformance_Error; - - -- Start of processing for Check_Discriminant_Conformance - - begin - while Present (Old_Discr) and then Present (New_Discr) loop - New_Discr_Id := Defining_Identifier (New_Discr); - - -- The subtype mark of the discriminant on the full type has not - -- been analyzed so we do it here. For an access discriminant a new - -- type is created. - - if Nkind (Discriminant_Type (New_Discr)) = N_Access_Definition then - New_Discr_Type := - Access_Definition (N, Discriminant_Type (New_Discr)); - - else - Find_Type (Discriminant_Type (New_Discr)); - New_Discr_Type := Etype (Discriminant_Type (New_Discr)); - - -- Ada 2005: if the discriminant definition carries a null - -- exclusion, create an itype to check properly for consistency - -- with partial declaration. - - if Is_Access_Type (New_Discr_Type) - and then Null_Exclusion_Present (New_Discr) - then - New_Discr_Type := - Create_Null_Excluding_Itype - (T => New_Discr_Type, - Related_Nod => New_Discr, - Scope_Id => Current_Scope); - end if; - end if; - - if not Conforming_Types - (Etype (Old_Discr), New_Discr_Type, Fully_Conformant) - then - Conformance_Error ("type of & does not match!", New_Discr_Id); - return; - else - -- Treat the new discriminant as an occurrence of the old one, - -- for navigation purposes, and fill in some semantic - -- information, for completeness. - - Generate_Reference (Old_Discr, New_Discr_Id, 'r'); - Set_Etype (New_Discr_Id, Etype (Old_Discr)); - Set_Scope (New_Discr_Id, Scope (Old_Discr)); - end if; - - -- Names must match - - if Chars (Old_Discr) /= Chars (Defining_Identifier (New_Discr)) then - Conformance_Error ("name & does not match!", New_Discr_Id); - return; - end if; - - -- Default expressions must match - - declare - NewD : constant Boolean := - Present (Expression (New_Discr)); - OldD : constant Boolean := - Present (Expression (Parent (Old_Discr))); - - function Has_Tagged_Limited_Partial_View - (Typ : Entity_Id) return Boolean; - -- Returns True iff Typ has a tagged limited partial view. - - function Is_Derived_From_Immutably_Limited_Type - (Typ : Entity_Id) return Boolean; - -- Returns True iff Typ is a derived type (tagged or not) - -- whose ancestor type is immutably limited. The unusual - -- ("unusual" is one word for it) thing about this function - -- is that it handles the case where the ancestor name's Entity - -- attribute has not been set yet. - - ------------------------------------- - -- Has_Tagged_Limited_Partial_View -- - ------------------------------------- - - function Has_Tagged_Limited_Partial_View - (Typ : Entity_Id) return Boolean - is - Priv : constant Entity_Id := Incomplete_Or_Partial_View (Typ); - begin - return Present (Priv) - and then not Is_Incomplete_Type (Priv) - and then Is_Tagged_Type (Priv) - and then Limited_Present (Parent (Priv)); - end Has_Tagged_Limited_Partial_View; - - -------------------------------------------- - -- Is_Derived_From_Immutably_Limited_Type -- - -------------------------------------------- - - function Is_Derived_From_Immutably_Limited_Type - (Typ : Entity_Id) return Boolean - is - Type_Def : constant Node_Id := Type_Definition (Parent (Typ)); - Parent_Name : Node_Id; - begin - if Nkind (Type_Def) /= N_Derived_Type_Definition then - return False; - end if; - Parent_Name := Subtype_Indication (Type_Def); - if Nkind (Parent_Name) = N_Subtype_Indication then - Parent_Name := Subtype_Mark (Parent_Name); - end if; - if Parent_Name not in N_Has_Entity_Id - or else No (Entity (Parent_Name)) - then - Find_Type (Parent_Name); - end if; - return Is_Immutably_Limited_Type (Entity (Parent_Name)); - end Is_Derived_From_Immutably_Limited_Type; - - begin - if NewD or OldD then - - -- The old default value has been analyzed and expanded, - -- because the current full declaration will have frozen - -- everything before. The new default values have not been - -- expanded, so expand now to check conformance. - - if NewD then - Preanalyze_And_Resolve_Spec_Expression - (Expression (New_Discr), New_Discr_Type); - end if; - - if not (NewD and OldD) - or else not Fully_Conformant_Expressions - (Expression (Parent (Old_Discr)), - Expression (New_Discr)) - - then - Conformance_Error - ("default expression for & does not match!", - New_Discr_Id); - return; - end if; - - if NewD - and then Ada_Version >= Ada_2005 - and then Nkind (Discriminant_Type (New_Discr)) = - N_Access_Definition - and then not Is_Immutably_Limited_Type - (Defining_Identifier (N)) - - -- Check for a case that would be awkward to handle in - -- Is_Immutably_Limited_Type (because sem_aux can't - -- "with" sem_util). - - and then not Has_Tagged_Limited_Partial_View - (Defining_Identifier (N)) - - -- Check for another case that would be awkward to handle - -- in Is_Immutably_Limited_Type - - and then not Is_Derived_From_Immutably_Limited_Type - (Defining_Identifier (N)) - then - Error_Msg_N - ("(Ada 2005) default value for access discriminant " - & "requires immutably limited type", - Expression (New_Discr)); - return; - end if; - end if; - end; - - -- In Ada 83 case, grouping must match: (A,B : X) /= (A : X; B : X) - - if Ada_Version = Ada_83 then - declare - Old_Disc : constant Node_Id := Declaration_Node (Old_Discr); - - begin - -- Grouping (use of comma in param lists) must be the same - -- This is where we catch a misconformance like: - - -- A, B : Integer - -- A : Integer; B : Integer - - -- which are represented identically in the tree except - -- for the setting of the flags More_Ids and Prev_Ids. - - if More_Ids (Old_Disc) /= More_Ids (New_Discr) - or else Prev_Ids (Old_Disc) /= Prev_Ids (New_Discr) - then - Conformance_Error - ("grouping of & does not match!", New_Discr_Id); - return; - end if; - end; - end if; - - Next_Discriminant (Old_Discr); - Next (New_Discr); - end loop; - - if Present (Old_Discr) then - Conformance_Error ("too few discriminants!", Defining_Identifier (N)); - return; - - elsif Present (New_Discr) then - Conformance_Error - ("too many discriminants!", Defining_Identifier (New_Discr)); - return; - end if; - end Check_Discriminant_Conformance; - ----------------------------------------- -- Check_Formal_Subprogram_Conformance -- ----------------------------------------- @@ -13066,13 +12826,10 @@ package body Sem_Ch6 is -- Start of processing for Process_Formals begin - -- In order to prevent premature use of the formals in the same formal - -- part, the Ekind is left undefined until all default expressions are - -- analyzed. The Ekind is established in a separate loop at the end. - Param_Spec := First (T); while Present (Param_Spec) loop Formal := Defining_Identifier (Param_Spec); + Set_Formal_Mode (Formal, Param_Spec, Current_Scope); Set_Never_Set_In_Source (Formal, True); Enter_Name (Formal); @@ -13390,12 +13147,48 @@ package body Sem_Ch6 is Analyze_Return_Type (Related_Nod); end if; - -- Now set the kind (mode) of each formal - Param_Spec := First (T); while Present (Param_Spec) loop Formal := Defining_Identifier (Param_Spec); - Set_Formal_Mode (Formal); + Set_Is_Not_Self_Hidden (Formal); + + -- Set Is_Known_Non_Null for access parameters since the language + -- guarantees that access parameters are always non-null. We also set + -- Can_Never_Be_Null, since there is no way to change the value. + + if Nkind (Parameter_Type (Param_Spec)) = N_Access_Definition then + + -- Ada 2005 (AI-231): In Ada 95, access parameters are always non- + -- null; In Ada 2005, only if then null_exclusion is explicit. + + if Ada_Version < Ada_2005 + or else Can_Never_Be_Null (Etype (Formal)) + then + Set_Is_Known_Non_Null (Formal); + Set_Can_Never_Be_Null (Formal); + end if; + + -- Ada 2005 (AI-231): Null-exclusion access subtype + + elsif Is_Access_Type (Etype (Formal)) + and then Can_Never_Be_Null (Etype (Formal)) + then + Set_Is_Known_Non_Null (Formal); + + -- We can also set Can_Never_Be_Null (thus preventing some junk + -- access checks) for the case of an IN parameter, which cannot + -- be changed, or for an IN OUT parameter, which can be changed + -- but not to a null value. But for an OUT parameter, the initial + -- value passed in can be null, so we can't set this flag in that + -- case. + + if Ekind (Formal) /= E_Out_Parameter then + Set_Can_Never_Be_Null (Formal); + end if; + end if; + + Set_Mechanism (Formal, Default_Mechanism); + Set_Formal_Validity (Formal); if Ekind (Formal) = E_In_Parameter then Default := Expression (Param_Spec); @@ -13666,23 +13459,23 @@ package body Sem_Ch6 is -- Set_Formal_Mode -- --------------------- - procedure Set_Formal_Mode (Formal_Id : Entity_Id) is - Spec : constant Node_Id := Parent (Formal_Id); - Id : constant Entity_Id := Scope (Formal_Id); - + procedure Set_Formal_Mode + (Formal_Id : Entity_Id; + Spec : N_Parameter_Specification_Id; + Subp_Id : Entity_Id) is begin -- Note: we set Is_Known_Valid for IN parameters and IN OUT parameters -- since we ensure that corresponding actuals are always valid at the -- point of the call. if Out_Present (Spec) then - if Is_Entry (Id) - or else Is_Subprogram_Or_Generic_Subprogram (Id) + if Is_Entry (Subp_Id) + or else Is_Subprogram_Or_Generic_Subprogram (Subp_Id) then - Set_Has_Out_Or_In_Out_Parameter (Id, True); + Set_Has_Out_Or_In_Out_Parameter (Subp_Id, True); end if; - if Ekind (Id) in E_Function | E_Generic_Function then + if Ekind (Subp_Id) in E_Function | E_Generic_Function then -- [IN] OUT parameters allowed for functions in Ada 2012 @@ -13719,45 +13512,6 @@ package body Sem_Ch6 is else Mutate_Ekind (Formal_Id, E_In_Parameter); end if; - - Set_Is_Not_Self_Hidden (Formal_Id); - - -- Set Is_Known_Non_Null for access parameters since the language - -- guarantees that access parameters are always non-null. We also set - -- Can_Never_Be_Null, since there is no way to change the value. - - if Nkind (Parameter_Type (Spec)) = N_Access_Definition then - - -- Ada 2005 (AI-231): In Ada 95, access parameters are always non- - -- null; In Ada 2005, only if then null_exclusion is explicit. - - if Ada_Version < Ada_2005 - or else Can_Never_Be_Null (Etype (Formal_Id)) - then - Set_Is_Known_Non_Null (Formal_Id); - Set_Can_Never_Be_Null (Formal_Id); - end if; - - -- Ada 2005 (AI-231): Null-exclusion access subtype - - elsif Is_Access_Type (Etype (Formal_Id)) - and then Can_Never_Be_Null (Etype (Formal_Id)) - then - Set_Is_Known_Non_Null (Formal_Id); - - -- We can also set Can_Never_Be_Null (thus preventing some junk - -- access checks) for the case of an IN parameter, which cannot - -- be changed, or for an IN OUT parameter, which can be changed but - -- not to a null value. But for an OUT parameter, the initial value - -- passed in can be null, so we can't set this flag in that case. - - if Ekind (Formal_Id) /= E_Out_Parameter then - Set_Can_Never_Be_Null (Formal_Id); - end if; - end if; - - Set_Mechanism (Formal_Id, Default_Mechanism); - Set_Formal_Validity (Formal_Id); end Set_Formal_Mode; ------------------------- diff --git a/gcc/ada/sem_ch6.ads b/gcc/ada/sem_ch6.ads index bd4b730..1a78c27 100644 --- a/gcc/ada/sem_ch6.ads +++ b/gcc/ada/sem_ch6.ads @@ -68,15 +68,6 @@ package Sem_Ch6 is -- type in its profile depends on a private type without a full -- declaration, indicate that the subprogram or type is delayed. - procedure Check_Discriminant_Conformance - (N : Node_Id; - Prev : Entity_Id; - Prev_Loc : Node_Id); - -- Check that the discriminants of a full type N fully conform to the - -- discriminants of the corresponding partial view Prev. Prev_Loc indicates - -- the source location of the partial view, which may be different than - -- Prev in the case of private types. - procedure Check_Formal_Subprogram_Conformance (New_Id : Entity_Id; Old_Id : Entity_Id; diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index fe93288..db892d0 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -8404,7 +8404,8 @@ package body Sem_Ch8 is if Is_Overloaded (P) then - -- The prefix must resolve to a unique enclosing construct + -- The prefix must resolve to a unique enclosing construct, per + -- the last sentence of RM 4.1.3 (13). declare Found : Boolean := False; @@ -8418,6 +8419,7 @@ package body Sem_Ch8 is if Found then Error_Msg_N ( "prefix must be unique enclosing scope", N); + Change_Selected_Component_To_Expanded_Name (N); Set_Entity (N, Any_Id); Set_Etype (N, Any_Type); return; diff --git a/gcc/ada/sem_ch8.ads b/gcc/ada/sem_ch8.ads index 70fbcf2..f915f2c 100644 --- a/gcc/ada/sem_ch8.ads +++ b/gcc/ada/sem_ch8.ads @@ -100,11 +100,6 @@ package Sem_Ch8 is -- entries in the current scope, and that will give all homonyms that are -- declared before the point of call in the current scope. This is useful -- for example in the processing for pragma Inline. - -- - -- Flag Errors_OK should be set when error diagnostics are desired. Flag - -- Marker_OK should be set when a N_Variable_Reference_Marker needs to be - -- generated for a SPARK object in order to detect elaboration issues. Flag - -- Reference_OK should be set when N must generate a cross reference. procedure Find_Selected_Component (N : Node_Id); -- Resolve various cases of selected components, recognize expanded names diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 4090d0c..2fc3698 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -8087,10 +8087,26 @@ package body Sem_Prag is -- the test below also permits use in a configuration pragma file. function Is_Configuration_Pragma return Boolean is + function Is_Pragma_Node (Prg : Node_Id) return Boolean is + (Nkind (Prg) = N_Pragma + or else + (Present (Original_Node (Prg)) + and then Nkind (Original_Node (Prg)) = N_Pragma)); + -- Returns true whether the node is a pragma or was originally a + -- pragma. + -- + -- Note that some pragmas like Assertion_Policy are rewritten as + -- Null_Statment nodes but we still need to make sure here that the + -- original node was a pragma node. + + -- Local variables + Lis : List_Id; Par : constant Node_Id := Parent (N); Prg : Node_Id; + -- Start of processing for Is_Configuration_Pragma + begin -- Don't evaluate List_Containing (N) if Parent (N) could be -- an N_Aspect_Specification node. @@ -8119,7 +8135,7 @@ package body Sem_Prag is loop if Prg = N then return True; - elsif Nkind (Prg) /= N_Pragma then + elsif not Is_Pragma_Node (Prg) then return False; end if; @@ -14677,19 +14693,18 @@ package body Sem_Prag is D := Declaration_Node (E); - if (Nkind (D) = N_Full_Type_Declaration and then Is_Array_Type (E)) + if (Nkind (D) in N_Full_Type_Declaration + | N_Formal_Type_Declaration + and then Is_Array_Type (E)) or else (Nkind (D) = N_Object_Declaration and then Ekind (E) in E_Constant | E_Variable and then Nkind (Object_Definition (D)) = N_Constrained_Array_Definition) - or else - (Ada_Version >= Ada_2022 - and then Nkind (D) = N_Formal_Type_Declaration) then -- The flag is set on the base type, or on the object - if Nkind (D) = N_Full_Type_Declaration then + if Is_Array_Type (E) then E := Base_Type (E); end if; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 0ce9e95..679d0ee 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -333,7 +333,7 @@ package body Sem_Util is -- Add_Global_Declaration -- ---------------------------- - procedure Add_Global_Declaration (N : Node_Id) is + procedure Add_Global_Declaration (Decl : Node_Id) is Aux_Node : constant Node_Id := Aux_Decls_Node (Cunit (Current_Sem_Unit)); begin @@ -341,8 +341,8 @@ package body Sem_Util is Set_Declarations (Aux_Node, New_List); end if; - Append_To (Declarations (Aux_Node), N); - Analyze (N); + Append_To (Declarations (Aux_Node), Decl); + Analyze (Decl); end Add_Global_Declaration; -------------------------------- @@ -8026,6 +8026,7 @@ package body Sem_Util is -- but the error should be posted on it, not on the component. elsif Ekind (E) = E_Discriminant + and then Is_Not_Self_Hidden (E) and then Present (Scope (Def_Id)) and then Scope (Def_Id) /= Current_Scope then @@ -8051,7 +8052,10 @@ package body Sem_Util is -- Avoid cascaded messages with duplicate components in -- derived types. - if Ekind (E) in E_Component | E_Discriminant then + if Ekind (E) = E_Component + or else (Ekind (E) = E_Discriminant + and then Is_Not_Self_Hidden (E)) + then return; end if; end if; @@ -8082,20 +8086,7 @@ package body Sem_Util is -- If we fall through, declaration is OK, at least OK enough to continue - -- If Def_Id is a discriminant or a record component we are in the midst - -- of inheriting components in a derived record definition. Preserve - -- their Ekind and Etype. - - if Ekind (Def_Id) in E_Discriminant | E_Component then - null; - - -- If a type is already set, leave it alone (happens when a type - -- declaration is reanalyzed following a call to the optimizer). - - elsif Present (Etype (Def_Id)) then - null; - - else + if No (Etype (Def_Id)) then Set_Etype (Def_Id, Any_Type); -- avoid cascaded errors end if; @@ -8923,9 +8914,10 @@ package body Sem_Util is -------------------------- procedure Find_Overlaid_Entity - (N : Node_Id; - Ent : out Entity_Id; - Off : out Boolean) + (N : Node_Id; + Ent : out Entity_Id; + Ovrl_Typ : out Entity_Id; + Off : out Boolean) is pragma Assert (Nkind (N) = N_Attribute_Definition_Clause @@ -8947,8 +8939,9 @@ package body Sem_Util is -- In the second case, the expr is either Y'Address, or recursively a -- constant that eventually references Y'Address. - Ent := Empty; - Off := False; + Ent := Empty; + Ovrl_Typ := Empty; + Off := False; Expr := Expression (N); @@ -8978,6 +8971,8 @@ package body Sem_Util is end if; end loop; + Ovrl_Typ := Etype (Expr); + -- This loop checks the form of the prefix for an entity, using -- recursion to deal with intermediate components. @@ -8996,8 +8991,10 @@ package body Sem_Util is pragma Assert (not Expander_Active and then Is_Concurrent_Type (Scope (Ent))); - Ent := Empty; + Ent := Empty; + Ovrl_Typ := Empty; end if; + return; -- Check for components @@ -18382,6 +18379,7 @@ package body Sem_Util is case Nkind (N) is when N_Indexed_Component + | N_Selected_Component | N_Slice => return @@ -18393,13 +18391,6 @@ package body Sem_Util is when N_Attribute_Reference => return Attribute_Name (N) in Name_Input | Name_Old | Name_Result; - when N_Selected_Component => - return - Is_Name_Reference (Selector_Name (N)) - and then - (Is_Name_Reference (Prefix (N)) - or else Is_Access_Type (Etype (Prefix (N)))); - when N_Explicit_Dereference => return True; @@ -21907,7 +21898,7 @@ package body Sem_Util is Set_Last_Assignment (Ent, Empty); end if; - if Is_Object (Ent) then + if Is_Object (Ent) and then Ekind (Ent) not in Record_Field_Kind then if not Last_Assignment_Only then Kill_Checks (Ent); Set_Current_Value (Ent, Empty); @@ -25593,16 +25584,18 @@ package body Sem_Util is if Sure and then Modification_Comes_From_Source + and then Ekind (Ent) in E_Constant | E_Variable and then Overlays_Constant (Ent) and then Address_Clause_Overlay_Warnings then declare Addr : constant Node_Id := Address_Clause (Ent); O_Ent : Entity_Id; + O_Typ : Entity_Id; Off : Boolean; begin - Find_Overlaid_Entity (Addr, O_Ent, Off); + Find_Overlaid_Entity (Addr, O_Ent, O_Typ, Off); Error_Msg_Sloc := Sloc (Addr); Error_Msg_NE @@ -28522,12 +28515,6 @@ package body Sem_Util is return False; end if; - if Ekind (Entity (Selector_Name (N))) not in - E_Component | E_Discriminant - then - return False; - end if; - declare Comp : constant Entity_Id := Original_Record_Component (Entity (Selector_Name (N))); @@ -29050,9 +29037,10 @@ package body Sem_Util is ------------------------------ function Ultimate_Overlaid_Entity (E : Entity_Id) return Entity_Id is - Address : Node_Id; - Alias : Entity_Id := E; - Offset : Boolean; + Address : Node_Id; + Alias : Entity_Id := E; + Offset : Boolean; + Ovrl_Typ : Entity_Id; begin -- Currently this routine is only called for stand-alone objects that @@ -29064,7 +29052,7 @@ package body Sem_Util is loop Address := Address_Clause (Alias); if Present (Address) then - Find_Overlaid_Entity (Address, Alias, Offset); + Find_Overlaid_Entity (Address, Alias, Ovrl_Typ, Offset); if Present (Alias) then null; else diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 38e9676..8d5bda0 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -54,12 +54,12 @@ package Sem_Util is -- Add A to the list of access types to process when expanding the -- freeze node of E. - procedure Add_Global_Declaration (N : Node_Id); - -- These procedures adds a declaration N at the library level, to be + procedure Add_Global_Declaration (Decl : Node_Id); + -- This procedure adds a declaration Decl at the library level, to be -- elaborated before any other code in the unit. It is used for example -- for the entity that marks whether a unit has been elaborated. The -- declaration is added to the Declarations list of the Aux_Decls_Node - -- for the current unit. The declarations are added in the current scope, + -- for the current unit. The declared entity is added to current scope, -- so the caller should push a new scope as required before the call. function Add_Suffix (E : Entity_Id; Suffix : Character) return Name_Id; @@ -619,7 +619,21 @@ package Sem_Util is -- Find whether there is a previous definition for name or identifier N in -- the current scope. Because declarations for a scope are not necessarily -- contiguous (e.g. for packages) the first entry on the visibility chain - -- for N is not necessarily in the current scope. + -- for N is not necessarily in the current scope. Take, for example: + -- + -- package P is + -- X : constant := 13; + -- + -- package Q is + -- X : constant := 67; + -- end Q; + -- + -- Y : constant := X; + -- end P; + -- + -- When the declaration of Y is analyzed, the first entry on the visibility + -- chain is the X equal to 67, but Current_Entity_In_Scope returns the X + -- equal to 13. function Current_Scope return Entity_Id; -- Get entity representing current scope @@ -884,14 +898,18 @@ package Sem_Util is -- loop are nested within the block. procedure Find_Overlaid_Entity - (N : Node_Id; - Ent : out Entity_Id; - Off : out Boolean); + (N : Node_Id; + Ent : out Entity_Id; + Ovrl_Typ : out Entity_Id; + Off : out Boolean); -- The node N should be an address representation clause. Determines if the -- target expression is the address of an entity with an optional offset. -- If so, set Ent to the entity and, if there is an offset, set Off to -- True, otherwise to False. If it is not possible to determine that the -- address is of this form, then set Ent to Empty. + -- Ovrl_Typ is set to the type being overlaid and can be different than the + -- type of Ent, for example when the address clause is applied to a record + -- component or to an element of an array. function Find_Parameter_Type (Param : Node_Id) return Entity_Id; -- Return the type of formal parameter Param as determined by its diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb index 1bc97a8..74f9fe3 100644 --- a/gcc/ada/sem_warn.adb +++ b/gcc/ada/sem_warn.adb @@ -1712,17 +1712,11 @@ package body Sem_Warn is and then Ekind (E1) /= E_Class_Wide_Type - -- Objects other than parameters of task types are allowed to - -- be non-referenced, since they start up tasks. + -- Objects that are not parameters and whose types have tasks + -- are allowed to be non-referenced since they start up tasks. - and then ((Ekind (E1) /= E_Variable - and then Ekind (E1) /= E_Constant - and then Ekind (E1) /= E_Component) - - -- Check that E1T is not a task or a composite type - -- with a task component. - - or else not Has_Task (E1T)) + and then not (Ekind (E1) in E_Variable | E_Constant | E_Component + and then Has_Task (E1T)) -- For subunits, only place warnings on the main unit itself, -- since parent units are not completely compiled. diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index a0c7314..9b5d3c2 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -8172,7 +8172,7 @@ package Sinfo is -- An implicit label declaration is created for every occurrence of a -- label on a statement or a label on a block or loop. It is chained -- in the declarations of the innermost enclosing block as specified - -- in RM section 5.1 (3). + -- in RM section 5.1 (12). -- The Defining_Identifier is the actual identifier for the statement -- identifier. Note that the occurrence of the label is a reference, NOT diff --git a/gcc/ada/switch-c.adb b/gcc/ada/switch-c.adb index 1e54340..efad12c 100644 --- a/gcc/ada/switch-c.adb +++ b/gcc/ada/switch-c.adb @@ -1220,17 +1220,20 @@ package body Switch.C is List_Representation_Info := Character'Pos (C) - Character'Pos ('0'); - when 's' => - List_Representation_Info_To_File := True; + when 'e' => + List_Representation_Info_Extended := True; - when 'j' => - List_Representation_Info_To_JSON := True; + when 'h' => + List_Representation_Info_Holes := True; when 'm' => List_Representation_Info_Mechanisms := True; - when 'e' => - List_Representation_Info_Extended := True; + when 'j' => + List_Representation_Info_To_JSON := True; + + when 's' => + List_Representation_Info_To_File := True; when others => Bad_Switch ("-gnatR" & Switch_Chars (Ptr .. Max)); @@ -1245,6 +1248,12 @@ package body Switch.C is Osint.Fail ("-gnatRe is incompatible with -gnatRj"); end if; + if List_Representation_Info_To_JSON + and then List_Representation_Info_Holes + then + Osint.Fail ("-gnatRh is incompatible with -gnatRj"); + end if; + -- -gnats (syntax check only) when 's' => diff --git a/gcc/ada/switch.adb b/gcc/ada/switch.adb index b1abe1e..691abc0 100644 --- a/gcc/ada/switch.adb +++ b/gcc/ada/switch.adb @@ -93,7 +93,7 @@ package body Switch is Set_Standard_Output; Usage; Write_Eol; - Write_Line ("Report bugs to report@adacore.com"); + Write_Line ("Report bugs to support@adacore.com"); Exit_Program (E_Success); end if; end Check_Version_And_Help_G; diff --git a/gcc/ada/treepr.adb b/gcc/ada/treepr.adb index b1a2c34..16e2bc8 100644 --- a/gcc/ada/treepr.adb +++ b/gcc/ada/treepr.adb @@ -87,7 +87,7 @@ package body Treepr is procedure Destroy (Value : in out Nat) is null; pragma Annotate (CodePeer, False_Positive, "unassigned parameter", "in out parameter is required to instantiate generic"); - -- Dummy routine for destroing hashed values + -- Dummy routine for destroying hashed values package Serial_Numbers is new Dynamic_Hash_Tables (Key_Type => Int, diff --git a/gcc/ada/usage.adb b/gcc/ada/usage.adb index efa38b5..5b87bb5 100644 --- a/gcc/ada/usage.adb +++ b/gcc/ada/usage.adb @@ -92,17 +92,17 @@ begin -- Common switches available everywhere - Write_Switch_Char ("g ", ""); + Write_Switch_Char ("g ", ""); Write_Line ("Generate debugging information"); - Write_Switch_Char ("Idir ", ""); + Write_Switch_Char ("Idir ", ""); Write_Line ("Specify source files search path"); - Write_Switch_Char ("I- ", ""); + Write_Switch_Char ("I- ", ""); Write_Line ("Do not look for sources in current directory"); - Write_Switch_Char ("O[0123] ", ""); - Write_Line ("Control the optimization level"); + Write_Switch_Char ("O[?] ", ""); + Write_Line ("Control the optimization level (?=0/1/2/3/s/z/g)"); Write_Eol; @@ -402,7 +402,7 @@ begin Write_Switch_Char ("R?"); Write_Line - ("List rep info (?=0/1/2/3/4/e/m for none/types/all/sym/cg/ext/mech)"); + ("List rep info (?=1/2/3/4/e/h/m for types/all/sym/cg/ext/holes/mech)"); Write_Switch_Char ("R?j"); Write_Line ("List rep info in the JSON data interchange format"); Write_Switch_Char ("R?s"); diff --git a/gcc/ada/vast.adb b/gcc/ada/vast.adb index 302a89b..59470fd 100644 --- a/gcc/ada/vast.adb +++ b/gcc/ada/vast.adb @@ -23,18 +23,598 @@ -- -- ------------------------------------------------------------------------------ --- Dummy implementation +pragma Unsuppress (All_Checks); +pragma Assertion_Policy (Check); +-- Enable checking. This isn't really necessary, but it might come in handy if +-- we want to run VAST with a compiler built without checks. Anyway, it's +-- harmless, because VAST is not run by default. + +with Ada.Unchecked_Deallocation; + +with System.Case_Util; + +with Atree; use Atree; +with Debug; +with Einfo.Entities; use Einfo.Entities; +with Lib; use Lib; +with Namet; use Namet; +with Nlists; use Nlists; +with Opt; use Opt; +with Output; +with Sinfo.Nodes; use Sinfo.Nodes; +with Sinput; +with Table; +with Types; use Types; package body VAST is + -- ???Basic tree properties not yet checked: + -- - No dangling trees. Every node that is reachable at all is reachable + -- by some syntactic path. + -- - Basic properties of Nlists/Elists (next/prev pointers make sense, + -- for example). + + Force_Enable_VAST : constant Boolean := False; + -- Normally, VAST is enabled by the the -gnatd_V switch. + -- To force it to be enabled independent of any switches, + -- set this to True. + + type Check_Enum is + (Check_Other, + Check_Sloc, + Check_Analyzed, + Check_Error_Nodes, + Check_Sharing, + Check_Parent_Present, + Check_Parent_Correct); + + type Check_Status is + -- Action in case of check failure: + (Disabled, -- Do nothing + Enabled, -- Print messages, and raise an exception + Print_And_Continue); -- Print a message + + pragma Warnings (Off, "Status*could be declared constant"); + Status : array (Check_Enum) of Check_Status := + (Check_Other => Enabled, + Check_Sloc => Disabled, + Check_Analyzed => Disabled, + Check_Error_Nodes => Print_And_Continue, + Check_Sharing => Disabled, + Check_Parent_Present => Print_And_Continue, + Check_Parent_Correct => Disabled); +-- others => Print_And_Continue); +-- others => Enabled); +-- others => Disabled); + -- Passing checks are Check_Other, which should always be Enabled. + -- Currently-failing checks are different enumerals in Check_Enum, + -- which can be disabled individually until we fix the bugs, or enabled + -- when debugging particular bugs. Pass a nondefault Check_Enum to + -- Assert in order to deal with bugs we have not yet fixed, + -- and play around with the value of Status above for + -- testing and debugging. + -- + -- Note: Once a bug is fixed, and the check passes reliably, we may choose + -- to remove that check from Check_Enum and use Check_Other instead. + + type Node_Stack_Index is new Pos; + subtype Node_Stack_Count is + Node_Stack_Index'Base range 0 .. Node_Stack_Index'Last; + + package Node_Stack is new Table.Table + (Table_Component_Type => Node_Id, + Table_Index_Type => Node_Stack_Index'Base, + Table_Low_Bound => 1, + Table_Initial => 1, + Table_Increment => 100, + Table_Name => "Node_Stack"); + + procedure Assert + (Condition : Boolean; + Check : Check_Enum := Check_Other; + Detail : String := ""); + -- Check that the Condition is True. Status determines action on failure. + + function To_Mixed (A : String) return String; + -- Copied from System.Case_Util; old versions of that package do not have + -- this function, so this is needed for bootstrapping. + + function Image (Kind : Node_Kind) return String is (To_Mixed (Kind'Img)); + function Image (Kind : Entity_Kind) return String is (To_Mixed (Kind'Img)); + + procedure Put (S : String); + procedure Put_Line (S : String); + procedure Put_Node (N : Node_Id); + procedure Put_Node_Stack; + -- Output routines; print only if -gnatd_W (VAST in verbose mode) is + -- enabled. + + procedure Put_Indentation; + -- Print spaces to indicate nesting depth of Node_Stack + + procedure Enter_Node (N : Node_Id); + procedure Leave_Node (N : Node_Id); + -- Called for each node while walking the tree. + -- Push/pop N to/from Node_Stack. + -- Print enter/leave debugging messages. + -- ???Possible improvements to messages: + -- Walk subtrees in a better order. + -- Print field names. + -- Don't print boring fields (such as N_Empty nodes). + -- Print more info (value of literals, "A.B.C" for expanded names, etc.). + -- Share some code with Treepr. + + procedure Do_Tree (N : Node_Id); + -- Do VAST checking on a tree of nodes + + function Has_Subtrees (N : Node_Id) return Boolean; + -- True if N has one or more syntactic fields + + procedure Do_Subtrees (N : Node_Id); + -- Call Do_Tree on all the subtrees (i.e. syntactic fields) of N + + procedure Do_List (L : List_Id); + -- Call Do_Tree on the list elements + + procedure Do_Unit (U : Unit_Number_Type); + -- Call Do_Tree on the root node of a compilation unit + + function Ancestor_Node (Count : Node_Stack_Count) return Node_Id; + -- Nth ancestor on the Node_Stack. Ancestor_Node(0) is the current node, + -- Ancestor_Node(1) is its parent, Ancestor_Node(2) is its grandparent, + -- and so on. + + function Top_Node return Node_Id is (Ancestor_Node (0)); + + type Node_Set is array (Node_Id range <>) of Boolean; + pragma Pack (Node_Set); + type Node_Set_Ptr is access all Node_Set; + procedure Free is new Ada.Unchecked_Deallocation (Node_Set, Node_Set_Ptr); + + Visited : Node_Set_Ptr; + -- Giant array of Booleans; Visited (N) is True if and only if we have + -- visited N in the tree walk. Used to detect incorrect sharing of subtrees + -- or (worse) cycles. We don't allocate the set on the stack, for fear of + -- Storage_Error. + + function Get_Node_Field_Union is new + Atree.Atree_Private_Part.Get_32_Bit_Field (Union_Id) with Inline; + + -------------- + -- To_Mixed -- + -------------- + + function To_Mixed (A : String) return String is + Result : String := A; + begin + System.Case_Util.To_Mixed (Result); + return Result; + end To_Mixed; + + --------- + -- Put -- + --------- + + procedure Put (S : String) is + begin + if Debug.Debug_Flag_Underscore_WW then + Output.Write_Str (S); + end if; + end Put; + + -------------- + -- Put_Line -- + -------------- + + procedure Put_Line (S : String) is + begin + if Debug.Debug_Flag_Underscore_WW then + Output.Write_Line (S); + end if; + end Put_Line; + + -------------- + -- Put_Node -- + -------------- + + procedure Put_Node (N : Node_Id) is + begin + if Debug.Debug_Flag_Underscore_WW then + if Nkind (N) in N_Entity then + Put (Image (Ekind (N))); + else + Put (Image (Nkind (N))); + end if; + + Put (N'Img & " "); + Sinput.Write_Location (Sloc (N)); + + if Comes_From_Source (N) then + Put (" (s)"); + end if; + + case Nkind (N) is + when N_Has_Chars => + Put (" "); + Write_Name_For_Debug (Chars (N), Quote => """"); + when others => null; + end case; + + end if; + end Put_Node; + + --------------------- + -- Put_Indentation -- + --------------------- + + procedure Put_Indentation is + begin + Put (String'(Natural (Node_Stack.First) .. + Natural (Node_Stack.Last) * 2 => ' ')); + end Put_Indentation; + + ---------------- + -- Enter_Node -- + ---------------- + + procedure Enter_Node (N : Node_Id) is + begin + Node_Stack.Append (N); -- push + + if Has_Subtrees (N) then + Put ("-->"); + else + -- If no subtrees, just print one line for enter/leave + Put (" "); + end if; + Put_Indentation; + Put_Node (N); + Put_Line (""); + end Enter_Node; + ---------------- - -- Check_Tree -- + -- Leave_Node -- ---------------- - procedure Check_Tree (GNAT_Root : Node_Id) is - pragma Unreferenced (GNAT_Root); + procedure Leave_Node (N : Node_Id) is + begin + if Has_Subtrees (N) then + Put ("<--"); + Put_Indentation; + Put_Node (N); + Put_Line (""); + end if; + + Node_Stack.Decrement_Last; -- pop + end Leave_Node; + + -------------------- + -- Put_Node_Stack -- + -------------------- + + procedure Put_Node_Stack is + begin + for J in reverse Node_Stack.First .. Node_Stack.Last loop + Put_Node (Node_Stack.Table (J)); + Put_Line (""); + end loop; + end Put_Node_Stack; + + ------------------- + -- Ancestor_Node -- + ------------------- + + function Ancestor_Node (Count : Node_Stack_Count) return Node_Id is + begin + return Node_Stack.Table (Node_Stack.Last - Count); + end Ancestor_Node; + + ------------ + -- Assert -- + ------------ + + VAST_Failure : exception; + + procedure Assert + (Condition : Boolean; + Check : Check_Enum := Check_Other; + Detail : String := "") + is begin - null; - end Check_Tree; + if not Condition then + declare + Part1 : constant String := "VAST fail"; + Part2 : constant String := + (if Check = Check_Other then "" + else ": " & To_Mixed (Check'Img)); + Part3 : constant String := + (if Detail = "" then "" else " -- " & Detail); + Message : constant String := Part1 & Part2 & Part3; + Save : constant Boolean := Debug.Debug_Flag_Underscore_WW; + begin + case Status (Check) is + when Disabled => null; + when Enabled | Print_And_Continue => + Debug.Debug_Flag_Underscore_WW := True; + -- ???We should probably avoid changing the debug flag here + Put (Message & ": "); + Put_Node (Top_Node); + Put_Line (""); + + if Status (Check) = Enabled then + Put_Node_Stack; + raise VAST_Failure with Message; + end if; + + Debug.Debug_Flag_Underscore_WW := Save; + end case; + end; + end if; + end Assert; + + ------------- + -- Do_Tree -- + ------------- + + procedure Do_Tree (N : Node_Id) is + begin + Enter_Node (N); + + -- Skip the rest if empty. Check Sloc: + + case Nkind (N) is + when N_Empty => + Assert (No (Sloc (N))); + goto Done; -- --------------> + -- Don't do any further checks on Empty + + -- ???Some nodes, including exception handlers, have no Sloc; + -- it's unclear why. + + when N_Exception_Handler => + Assert (if Comes_From_Source (N) then Present (Sloc (N))); + when others => + Assert (Present (Sloc (N)), Check_Sloc); + end case; + + -- All reachable nodes should have been analyzed by the time we get + -- here: + + Assert (Analyzed (N), Check_Analyzed); + + -- If we visit the same node more than once, then there are shared + -- nodes; the "tree" is not a tree: + + Assert (not Visited (N), Check_Sharing); + Visited (N) := True; + + -- Misc checks based on node/entity kind: + + case Nkind (N) is + when N_Unused_At_Start | N_Unused_At_End => + Assert (False); + + when N_Error => + -- VAST doesn't do anything when Serious_Errors_Detected > 0 (at + -- least for now), so we shouldn't encounter any N_Error nodes. + Assert (False, Check_Error_Nodes); + + when N_Entity => + case Ekind (N) is + when others => + null; -- more to be done here + end case; + + when others => + null; -- more to be done here + end case; + + -- Check that N has a Parent, except in certain cases: + + case Nkind (N) is + when N_Empty => + raise Program_Error; -- can't get here + + when N_Error => + Assert (False, Check_Error_Nodes); + -- The error node has no parent, but we shouldn't even be seeing + -- error nodes in VAST at all. See earlier "when N_Error". + + when N_Compilation_Unit => + Assert (No (Parent (N))); + -- The parent of the root of each unit is empty. + + when N_Entity => + if not Is_Itype (N) then + -- An Itype might or might not have a parent + + Assert + (Present (Parent (N)), Detail => "missing parent of entity"); + Assert (Parent (N) = Ancestor_Node (1), Check_Parent_Correct); + end if; + + when others => + Assert (Present (Parent (N)), Check_Parent_Present); + -- All other nodes should have a parent + if Status (Check_Parent_Present) = Enabled then + Assert (Parent (N) = Ancestor_Node (1), Check_Parent_Correct); + end if; + end case; + + Do_Subtrees (N); + + <<Done>> + Leave_Node (N); + end Do_Tree; + + ----------------- + -- Has_Subtrees -- + ----------------- + + function Has_Subtrees (N : Node_Id) return Boolean is + Offsets : Traversed_Offset_Array renames + Traversed_Fields (Nkind (N)); + begin + -- True if sentinel comes first + return Offsets (Offsets'First) /= No_Field_Offset; + end Has_Subtrees; + + ----------------- + -- Do_Subtrees -- + ----------------- + + procedure Do_Subtrees (N : Node_Id) is + -- ???Do we need tail recursion elimination here, + -- as in Atree.Traverse_Func? + Offsets : Traversed_Offset_Array renames + Traversed_Fields (Nkind (N)); + begin + for Cur_Field in Offset_Array_Index loop + exit when Offsets (Cur_Field) = No_Field_Offset; + + declare + F : constant Union_Id := + Get_Node_Field_Union (N, Offsets (Cur_Field)); + begin + if F in Node_Range then + Do_Tree (Node_Id (F)); + elsif F in List_Range then + Do_List (List_Id (F)); + else + raise Program_Error; + end if; + end; + end loop; + end Do_Subtrees; + + ------------- + -- Do_List -- + ------------- + + procedure Do_List (L : List_Id) is + Elmt : Node_Id := First (L); + Len : constant String := List_Length (L)'Img; + begin + if Is_Non_Empty_List (L) then + Put ("-->"); + Put_Indentation; + Put_Line ("list len=" & Len); + + while Present (Elmt) loop + Do_Tree (Elmt); + Next (Elmt); + end loop; + + Put ("<--"); + Put_Indentation; + Put_Line ("list len=" & Len); + end if; + end Do_List; + + ------------- + -- Do_Unit -- + ------------- + + procedure Do_Unit (U : Unit_Number_Type) is + U_Name : constant Unit_Name_Type := Unit_Name (U); + U_Name_S : constant String := + (if U_Name = No_Unit_Name then "<No_Unit_Name>" + else Get_Name_String (U_Name)); + Predef : constant String := + (if Is_Predefined_Unit (U) then " (predef)" + elsif Is_Internal_Unit (U) then " (gnat)" + else ""); + Is_Main : constant String := + (if U = Main_Unit then " (main unit)" else ""); + Msg : constant String := + "VAST for unit" & U'Img & " " & U_Name_S & Predef & Is_Main; + + Is_Preprocessing_Dependency : constant Boolean := + U_Name = No_Unit_Name; + -- True if this is a bogus unit added by Add_Preprocessing_Dependency. + -- ???Not sure what that's about, but these units have no name and + -- no associated tree, so we had better not try to walk those trees. + + Root : constant Node_Id := Cunit (U); + begin + pragma Assert (Node_Stack.Last = 0); + Assert (No (Root) = Is_Preprocessing_Dependency); + -- All compilation units except these bogus ones should have a Cunit. + + Put_Line (Msg); + + if Is_Preprocessing_Dependency then + Put_Line ("Skipping preprocessing dependency"); + return; + end if; + + Assert (Present (Root)); + Do_Tree (Root); + Put_Line (Msg & " (done)"); + pragma Assert (Node_Stack.Last = 0); + end Do_Unit; + + ---------- + -- VAST -- + ---------- + + procedure VAST is + pragma Assert (Expander_Active = (Operating_Mode = Generate_Code)); + -- ???So why do we need both Operating_Mode and Expander_Active? + use Debug; + begin + -- Do nothing if we're not calling the back end; the main point of VAST + -- is to protect against code-generation bugs. This includes the + -- case where legality errors were detected; the tree is known to be + -- malformed in some error cases. + + if Operating_Mode /= Generate_Code then + return; + end if; + + -- If -gnatd_W (VAST in verbose mode) is enabled, then that should imply + -- -gnatd_V (enable VAST). + + if Debug_Flag_Underscore_WW then + Debug_Flag_Underscore_VV := True; + end if; + + -- Do nothing if VAST is disabled + + if not (Debug_Flag_Underscore_VV or Force_Enable_VAST) then + return; + end if; + + -- Turn off output unless verbose mode is enabled + + Put_Line ("VAST"); + + -- Operating_Mode = Generate_Code implies there are no legality errors: + + Assert (Serious_Errors_Detected = 0); + + Put_Line ("VAST checking" & Last_Unit'Img & " units"); + + declare + use Atree_Private_Part; + Last_Node : constant Node_Id := Node_Offsets.Last; + begin + pragma Assert (Visited = null); + Visited := new Node_Set'(Node_Id'First .. Last_Node => False); + + for U in Main_Unit .. Last_Unit loop + -- Main_Unit is the one passed to the back end, but here we are + -- walking all the units. + Do_Unit (U); + end loop; + + -- We shouldn't have allocated any new nodes during VAST: + + pragma Assert (Node_Offsets.Last = Last_Node); + Free (Visited); + end; + + Put_Line ("VAST done."); + end VAST; end VAST; diff --git a/gcc/ada/vast.ads b/gcc/ada/vast.ads index 031ea21..faecd9a 100644 --- a/gcc/ada/vast.ads +++ b/gcc/ada/vast.ads @@ -24,13 +24,10 @@ ------------------------------------------------------------------------------ -- This package is the entry point for VAST: Verifier for the Ada Semantic --- Tree. - -with Types; use Types; +-- Tree. It walks the expanded trees, and verifies their validity. package VAST is - procedure Check_Tree (GNAT_Root : Node_Id); - -- Check the validity of the given Root tree + procedure VAST; end VAST; |