From f74a102b67862fc3e025afd545460e5b696d3cc4 Mon Sep 17 00:00:00 2001 From: charlet Date: Mon, 2 May 2016 10:05:03 +0000 Subject: [PATCH] 2016-05-02 Tristan Gingold * sem_ch3.adb (Analyze_Object_Declaration): Use Has_Protected to check for the no local protected objects restriction. 2016-05-02 Hristian Kirtchev * einfo.adb Anonymous_Master now uses Node35. (Anonymous_Master): Update the assertion and node reference. (Set_Anonymous_Master): Update the assertion and node reference. (Write_Field35_Name): Add output for Anonymous_Master. (Write_Field36_Name): The output is now undefined. * einfo.ads Update the node and description of attribute Anonymous_Master. Remove prior occurrences in entities as this is now a type attribute. * exp_ch3.adb (Expand_Freeze_Array_Type): Remove local variable Ins_Node. Anonymous access- to-controlled component types no longer need finalization masters. The master is now built when a related allocator is expanded. (Expand_Freeze_Record_Type): Remove local variable Has_AACC. Do not detect whether the record type has at least one component of anonymous access-to- controlled type. These types no longer need finalization masters. The master is now built when a related allocator is expanded. * exp_ch4.adb Remove with and use clauses for Lib and Sem_Ch8. (Current_Anonymous_Master): Removed. (Expand_N_Allocator): Call Build_Anonymous_Master to create a finalization master for an anonymous access-to-controlled type. * exp_ch6.adb (Add_Finalization_Master_Actual_To_Build_In_Place_Call): Call routine Build_Anonymous_Master to create a finalization master for an anonymous access-to-controlled type. * exp_ch7.adb (Allows_Finalization_Master): New routine. (Build_Anonymous_Master): New routine. (Build_Finalization_Master): Remove formal parameter For_Anonymous. Use Allows_Finalization_Master to determine whether circumstances warrant a finalization master. This routine no longer creates masters for anonymous access-to-controlled types. (In_Deallocation_Instance): Removed. * exp_ch7.ads (Build_Anonymous_Master): New routine. (Build_Finalization_Master): Remove formal parameter For_Anonymous and update the comment on usage. * sem_util.adb (Get_Qualified_Name): New routines. (Output_Name): Reimplemented. (Output_Scope): Removed. * sem_util.ads (Get_Qualified_Name): New routines. 2016-05-02 Hristian Kirtchev * debug.adb: Document the use of switch -gnatd.H. * gnat1drv.adb (Adjust_Global_Switches): Set ASIS_GNSA mode when -gnatd.H is present. (Gnat1drv): Suppress the call to gigi when ASIS_GNSA mode is active. * opt.ads: Add new option ASIS_GNSA_Mode. * sem_ch13.adb (Alignment_Error): New routine. (Analyze_Attribute_Definition_Clause): Suppress certain errors in ASIS mode for attribute clause Alignment, Machine_Radix, Size, and Stream_Size. (Check_Size): Use routine Size_Too_Small_Error to suppress certain errors in ASIS mode. (Get_Alignment_Value): Use routine Alignment_Error to suppress certain errors in ASIS mode. (Size_Too_Small_Error): New routine. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@235732 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/ada/ChangeLog | 62 +++++++ gcc/ada/debug.adb | 5 +- gcc/ada/einfo.adb | 36 ++--- gcc/ada/einfo.ads | 18 +-- gcc/ada/exp_ch3.adb | 157 ++---------------- gcc/ada/exp_ch4.adb | 207 +----------------------- gcc/ada/exp_ch6.adb | 6 +- gcc/ada/exp_ch7.adb | 443 ++++++++++++++++++++++++++++++++++++++++----------- gcc/ada/exp_ch7.ads | 24 +-- gcc/ada/gnat1drv.adb | 28 ++-- gcc/ada/opt.ads | 5 + gcc/ada/sem_ch13.adb | 193 ++++++++++++++-------- gcc/ada/sem_ch3.adb | 9 +- gcc/ada/sem_util.adb | 105 ++++++++---- gcc/ada/sem_util.ads | 14 ++ 15 files changed, 697 insertions(+), 615 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index eaab1b730d9..7627ad335a9 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,65 @@ +2016-05-02 Tristan Gingold + + * sem_ch3.adb (Analyze_Object_Declaration): Use Has_Protected + to check for the no local protected objects restriction. + +2016-05-02 Hristian Kirtchev + + * einfo.adb Anonymous_Master now uses Node35. + (Anonymous_Master): Update the assertion and node reference. + (Set_Anonymous_Master): Update the assertion and node reference. + (Write_Field35_Name): Add output for Anonymous_Master. + (Write_Field36_Name): The output is now undefined. + * einfo.ads Update the node and description of attribute + Anonymous_Master. Remove prior occurrences in entities as this + is now a type attribute. + * exp_ch3.adb (Expand_Freeze_Array_Type): Remove local variable + Ins_Node. Anonymous access- to-controlled component types no + longer need finalization masters. The master is now built when + a related allocator is expanded. + (Expand_Freeze_Record_Type): Remove local variable Has_AACC. Do not + detect whether the record type has at least one component of anonymous + access-to- controlled type. These types no longer need finalization + masters. The master is now built when a related allocator is expanded. + * exp_ch4.adb Remove with and use clauses for Lib and Sem_Ch8. + (Current_Anonymous_Master): Removed. + (Expand_N_Allocator): Call Build_Anonymous_Master to create a + finalization master for an anonymous access-to-controlled type. + * exp_ch6.adb (Add_Finalization_Master_Actual_To_Build_In_Place_Call): + Call routine Build_Anonymous_Master to create a finalization master + for an anonymous access-to-controlled type. + * exp_ch7.adb (Allows_Finalization_Master): New routine. + (Build_Anonymous_Master): New routine. + (Build_Finalization_Master): Remove formal parameter + For_Anonymous. Use Allows_Finalization_Master to determine whether + circumstances warrant a finalization master. This routine no + longer creates masters for anonymous access-to-controlled types. + (In_Deallocation_Instance): Removed. + * exp_ch7.ads (Build_Anonymous_Master): New routine. + (Build_Finalization_Master): Remove formal parameter For_Anonymous + and update the comment on usage. + * sem_util.adb (Get_Qualified_Name): New routines. + (Output_Name): Reimplemented. + (Output_Scope): Removed. + * sem_util.ads (Get_Qualified_Name): New routines. + +2016-05-02 Hristian Kirtchev + + * debug.adb: Document the use of switch -gnatd.H. + * gnat1drv.adb (Adjust_Global_Switches): Set ASIS_GNSA mode when + -gnatd.H is present. + (Gnat1drv): Suppress the call to gigi when ASIS_GNSA mode is active. + * opt.ads: Add new option ASIS_GNSA_Mode. + * sem_ch13.adb (Alignment_Error): New routine. + (Analyze_Attribute_Definition_Clause): Suppress certain errors in + ASIS mode for attribute clause Alignment, Machine_Radix, Size, and + Stream_Size. + (Check_Size): Use routine Size_Too_Small_Error to + suppress certain errors in ASIS mode. + (Get_Alignment_Value): Use routine Alignment_Error to suppress certain + errors in ASIS mode. + (Size_Too_Small_Error): New routine. + 2016-05-02 Arnaud Charlet * spark_xrefs.ads Description of the spark cross-references diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb index 543c399edbc..f39691304af 100644 --- a/gcc/ada/debug.adb +++ b/gcc/ada/debug.adb @@ -125,7 +125,7 @@ package body Debug is -- d.E Turn selected errors into warnings -- d.F Debug mode for GNATprove -- d.G Ignore calls through generic formal parameters for elaboration - -- d.H + -- d.H GNSA mode for ASIS -- d.I Do not ignore enum representation clauses in CodePeer mode -- d.J Disable parallel SCIL generation mode -- d.K @@ -630,6 +630,9 @@ package body Debug is -- now fixed, but we provide this debug flag to revert to the previous -- situation of ignoring such calls to aid in transition. + -- d.H Sets ASIS_GNSA_Mode to True. This signals the front end to suppress + -- the call to gigi in ASIS_Mode. + -- d.I Do not ignore enum representation clauses in CodePeer mode. -- The default of ignoring representation clauses for enumeration -- types in CodePeer is good for the majority of Ada code, but in some diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 6df97886d5d..378b75711ec 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -265,10 +265,9 @@ package body Einfo is -- Contract Node34 + -- Anonymous_Master Node35 -- Import_Pragma Node35 - -- Anonymous_Master Node36 - -- Class_Wide_Preconds List38 -- Class_Wide_Postconds List39 @@ -757,12 +756,8 @@ package body Einfo is function Anonymous_Master (Id : E) return E is begin - pragma Assert (Ekind_In (Id, E_Function, - E_Package, - E_Package_Body, - E_Procedure, - E_Subprogram_Body)); - return Node36 (Id); + pragma Assert (Is_Type (Id)); + return Node35 (Id); end Anonymous_Master; function Anonymous_Object (Id : E) return E is @@ -3682,12 +3677,8 @@ package body Einfo is procedure Set_Anonymous_Master (Id : E; V : E) is begin - pragma Assert (Ekind_In (Id, E_Function, - E_Package, - E_Package_Body, - E_Procedure, - E_Subprogram_Body)); - Set_Node36 (Id, V); + pragma Assert (Is_Type (Id)); + Set_Node35 (Id, V); end Set_Anonymous_Master; procedure Set_Anonymous_Object (Id : E; V : E) is @@ -10385,6 +10376,9 @@ package body Einfo is procedure Write_Field35_Name (Id : Entity_Id) is begin case Ekind (Id) is + when Type_Kind => + Write_Str ("Anonymous_Master"); + when Subprogram_Kind => Write_Str ("Import_Pragma"); @@ -10398,19 +10392,9 @@ package body Einfo is ------------------------ procedure Write_Field36_Name (Id : Entity_Id) is + pragma Unreferenced (Id); begin - case Ekind (Id) is - when E_Function | - E_Operator | - E_Package | - E_Package_Body | - E_Procedure | - E_Subprogram_Body => - Write_Str ("Anonymous_Master"); - - when others => - Write_Str ("Field36??"); - end case; + Write_Str ("Field36??"); end Write_Field36_Name; ------------------------ diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 98d5a53c46b..9e289592448 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -438,11 +438,11 @@ package Einfo is -- definition clause with an (obsolescent) mod clause is converted -- into an attribute definition clause for this purpose. --- Anonymous_Master (Node36) --- Defined in the entities of non-generic packages, subprograms and their --- corresponding bodies. Contains the entity of a special heterogeneous --- finalization master that services most anonymous access-to-controlled --- allocations that occur within the unit. +-- Anonymous_Master (Node35) +-- Defined in all types. Contains the entity of an anonymous finalization +-- master which services all anonymous access types associated with the +-- same designated type within the current semantic unit. The attribute +-- is set reactively during the expansion of allocators. -- Anonymous_Object (Node30) -- Present in protected and task type entities. Contains the entity of @@ -5468,6 +5468,7 @@ package Einfo is -- Derived_Type_Link (Node31) -- No_Tagged_Streams_Pragma (Node32) -- Linker_Section_Pragma (Node33) + -- Anonymous_Master (Node35) -- Depends_On_Private (Flag14) -- Disable_Controlled (Flag253) @@ -5668,8 +5669,8 @@ package Einfo is -- Cloned_Subtype (Node16) (subtype case only) -- First_Entity (Node17) -- Equivalent_Type (Node18) (always Empty for type) - -- Last_Entity (Node20) -- Non_Limited_View (Node19) + -- Last_Entity (Node20) -- SSO_Set_High_By_Default (Flag273) (base type only) -- SSO_Set_Low_By_Default (Flag272) (base type only) -- First_Component (synth) @@ -5919,7 +5920,6 @@ package Einfo is -- Linker_Section_Pragma (Node33) -- Contract (Node34) -- Import_Pragma (Node35) (non-generic case only) - -- Anonymous_Master (Node36) (non-generic case only) -- Class_Wide_Preconds (List38) -- Class_Wide_Postconds (List39) -- SPARK_Pragma (Node40) @@ -6141,7 +6141,6 @@ package Einfo is -- Current_Use_Clause (Node27) -- Finalizer (Node28) (non-generic case only) -- Contract (Node34) - -- Anonymous_Master (Node36) (non-generic case only) -- SPARK_Pragma (Node40) -- SPARK_Aux_Pragma (Node41) -- Delay_Subprogram_Descriptors (Flag50) @@ -6179,7 +6178,6 @@ package Einfo is -- Scope_Depth_Value (Uint22) -- Finalizer (Node28) (non-generic case only) -- Contract (Node34) - -- Anonymous_Master (Node36) -- SPARK_Pragma (Node40) -- SPARK_Aux_Pragma (Node41) -- Contains_Ignored_Ghost_Code (Flag279) @@ -6233,7 +6231,6 @@ package Einfo is -- Linker_Section_Pragma (Node33) -- Contract (Node34) -- Import_Pragma (Node35) (non-generic case only) - -- Anonymous_Master (Node36) (non-generic case only) -- Class_Wide_Preconds (List38) -- Class_Wide_Postconds (List39) -- SPARK_Pragma (Node40) @@ -6419,7 +6416,6 @@ package Einfo is -- Scope_Depth_Value (Uint22) -- Extra_Formals (Node28) -- Contract (Node34) - -- Anonymous_Master (Node36) -- SPARK_Pragma (Node40) -- Contains_Ignored_Ghost_Code (Flag279) -- SPARK_Pragma_Inherited (Flag265) diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 7df8b5fc236..74d3902f529 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -4600,8 +4600,6 @@ package body Exp_Ch3 is Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode; - Ins_Node : Node_Id; - begin -- Ensure that all freezing activities are properly flagged as Ghost @@ -4654,39 +4652,13 @@ package body Exp_Ch3 is end if; end if; - if Typ = Base then - if Has_Controlled_Component (Base) then - Build_Controlling_Procs (Base); - - if not Is_Limited_Type (Comp_Typ) - and then Number_Dimensions (Typ) = 1 - then - Build_Slice_Assignment (Typ); - end if; - end if; - - -- Create a finalization master to service the anonymous access - -- components of the array. + if Typ = Base and then Has_Controlled_Component (Base) then + Build_Controlling_Procs (Base); - if Ekind (Comp_Typ) = E_Anonymous_Access_Type - and then Needs_Finalization (Designated_Type (Comp_Typ)) + if not Is_Limited_Type (Comp_Typ) + and then Number_Dimensions (Typ) = 1 then - -- The finalization master is inserted before the declaration - -- of the array type. The only exception to this is when the - -- array type is an itype, in which case the master appears - -- before the related context. - - if Is_Itype (Typ) then - Ins_Node := Associated_Node_For_Itype (Typ); - else - Ins_Node := Parent (Typ); - end if; - - Build_Finalization_Master - (Typ => Comp_Typ, - For_Anonymous => True, - Context_Scope => Scope (Typ), - Insertion_Node => Ins_Node); + Build_Slice_Assignment (Typ); end if; end if; @@ -5044,13 +5016,12 @@ package body Exp_Ch3 is Append_To (Lst, Make_Case_Statement_Alternative (Loc, Discrete_Choices => New_List (Make_Others_Choice (Loc)), - Statements => New_List ( + Statements => New_List ( Make_Raise_Constraint_Error (Loc, Condition => Make_Identifier (Loc, Name_uF), Reason => CE_Invalid_Data), Make_Simple_Return_Statement (Loc, - Expression => - Make_Integer_Literal (Loc, -1))))); + Expression => Make_Integer_Literal (Loc, -1))))); -- If either of the restrictions No_Exceptions_Handlers/Propagation is -- active then return -1 (we cannot usefully raise Constraint_Error in @@ -5060,10 +5031,9 @@ package body Exp_Ch3 is Append_To (Lst, Make_Case_Statement_Alternative (Loc, Discrete_Choices => New_List (Make_Others_Choice (Loc)), - Statements => New_List ( + Statements => New_List ( Make_Simple_Return_Statement (Loc, - Expression => - Make_Integer_Literal (Loc, -1))))); + Expression => Make_Integer_Literal (Loc, -1))))); end if; -- Now we can build the function body @@ -5137,9 +5107,11 @@ package body Exp_Ch3 is Comp : Entity_Id; Comp_Typ : Entity_Id; - Has_AACC : Boolean; Predef_List : List_Id; + Wrapper_Decl_List : List_Id := No_List; + Wrapper_Body_List : List_Id := No_List; + Renamed_Eq : Node_Id := Empty; -- Defining unit name for the predefined equality function in the case -- where the type has a primitive operation that is a renaming of @@ -5147,9 +5119,6 @@ package body Exp_Ch3 is -- user-defined equality function). Used to pass this entity from -- Make_Predefined_Primitive_Specs to Predefined_Primitive_Bodies. - Wrapper_Decl_List : List_Id := No_List; - Wrapper_Body_List : List_Id := No_List; - -- Start of processing for Expand_Freeze_Record_Type begin @@ -5212,8 +5181,6 @@ package body Exp_Ch3 is -- of the component types may have been private at the point of the -- record declaration. Detect anonymous access-to-controlled components. - Has_AACC := False; - Comp := First_Component (Typ); while Present (Comp) loop Comp_Typ := Etype (Comp); @@ -5238,15 +5205,6 @@ package body Exp_Ch3 is Set_Has_Controlled_Component (Typ); end if; - -- Non-self-referential anonymous access-to-controlled component - - if Ekind (Comp_Typ) = E_Anonymous_Access_Type - and then Needs_Finalization (Designated_Type (Comp_Typ)) - and then Designated_Type (Comp_Typ) /= Typ - then - Has_AACC := True; - end if; - Next_Component (Comp); end loop; @@ -5595,97 +5553,6 @@ package body Exp_Ch3 is end; end if; - -- Create a heterogeneous finalization master to service the anonymous - -- access-to-controlled components of the record type. - - if Has_AACC then - declare - Encl_Scope : constant Entity_Id := Scope (Typ); - Ins_Node : constant Node_Id := Parent (Typ); - Loc : constant Source_Ptr := Sloc (Typ); - Fin_Mas_Id : Entity_Id; - - Attributes_Set : Boolean := False; - Master_Built : Boolean := False; - -- Two flags which control the creation and initialization of a - -- common heterogeneous master. - - begin - Comp := First_Component (Typ); - while Present (Comp) loop - Comp_Typ := Etype (Comp); - - -- A non-self-referential anonymous access-to-controlled - -- component. - - if Ekind (Comp_Typ) = E_Anonymous_Access_Type - and then Needs_Finalization (Designated_Type (Comp_Typ)) - and then Designated_Type (Comp_Typ) /= Typ - then - -- Build a homogeneous master for the first anonymous - -- access-to-controlled component. This master may be - -- converted into a heterogeneous collection if more - -- components are to follow. - - if not Master_Built then - Master_Built := True; - - -- All anonymous access-to-controlled types allocate - -- on the global pool. Note that the finalization - -- master and the associated storage pool must be set - -- on the root type (both are "root type only"). - - Set_Associated_Storage_Pool - (Root_Type (Comp_Typ), RTE (RE_Global_Pool_Object)); - - Build_Finalization_Master - (Typ => Root_Type (Comp_Typ), - For_Anonymous => True, - Context_Scope => Encl_Scope, - Insertion_Node => Ins_Node); - - Fin_Mas_Id := Finalization_Master (Comp_Typ); - - -- Subsequent anonymous access-to-controlled components - -- reuse the available master. - - else - -- All anonymous access-to-controlled types allocate - -- on the global pool. Note that both the finalization - -- master and the associated storage pool must be set - -- on the root type (both are "root type only"). - - Set_Associated_Storage_Pool - (Root_Type (Comp_Typ), RTE (RE_Global_Pool_Object)); - - -- Shared the master among multiple components - - Set_Finalization_Master - (Root_Type (Comp_Typ), Fin_Mas_Id); - - -- Convert the master into a heterogeneous collection. - -- Generate: - -- Set_Is_Heterogeneous (); - - if not Attributes_Set then - Attributes_Set := True; - - Insert_Action (Ins_Node, - Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of - (RTE (RE_Set_Is_Heterogeneous), Loc), - Parameter_Associations => New_List ( - New_Occurrence_Of (Fin_Mas_Id, Loc)))); - end if; - end if; - end if; - - Next_Component (Comp); - end loop; - end; - end if; - -- Check whether individual components have a defined invariant, and add -- the corresponding component invariant checks. diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 3a1b19a4e9a..ea59e6e73b4 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -44,7 +44,6 @@ with Exp_Tss; use Exp_Tss; with Exp_Util; use Exp_Util; with Freeze; use Freeze; with Inline; use Inline; -with Lib; use Lib; with Namet; use Namet; with Nlists; use Nlists; with Nmake; use Nmake; @@ -57,7 +56,6 @@ with Sem; use Sem; with Sem_Aux; use Sem_Aux; with Sem_Cat; use Sem_Cat; with Sem_Ch3; use Sem_Ch3; -with Sem_Ch8; use Sem_Ch8; with Sem_Ch13; use Sem_Ch13; with Sem_Eval; use Sem_Eval; with Sem_Res; use Sem_Res; @@ -92,12 +90,6 @@ package body Exp_Ch4 is -- If a boolean array assignment can be done in place, build call to -- corresponding library procedure. - function Current_Anonymous_Master return Entity_Id; - -- Return the entity of the heterogeneous finalization master belonging to - -- the current unit (either function, package or procedure). This master - -- services all anonymous access-to-controlled types. If the current unit - -- does not have such master, create one. - procedure Displace_Allocator_Pointer (N : Node_Id); -- Ada 2005 (AI-251): Subsidiary procedure to Expand_N_Allocator and -- Expand_Allocator_Expression. Allocating class-wide interface objects @@ -410,202 +402,6 @@ package body Exp_Ch4 is return; end Build_Boolean_Array_Proc_Call; - ------------------------------ - -- Current_Anonymous_Master -- - ------------------------------ - - function Current_Anonymous_Master return Entity_Id is - function Create_Anonymous_Master - (Unit_Id : Entity_Id; - Unit_Decl : Node_Id) return Entity_Id; - -- Create a new anonymous master for a compilation unit denoted by its - -- entity Unit_Id and declaration Unit_Decl. The declaration of the new - -- master along with any specialized initialization is inserted at the - -- top of the unit's declarations (see body for special cases). Return - -- the entity of the anonymous master. - - ----------------------------- - -- Create_Anonymous_Master -- - ----------------------------- - - function Create_Anonymous_Master - (Unit_Id : Entity_Id; - Unit_Decl : Node_Id) return Entity_Id - is - Insert_Nod : Node_Id := Empty; - -- The point of insertion into the declarative list of the unit. All - -- nodes are inserted before Insert_Nod. - - procedure Insert_And_Analyze (Decls : List_Id; N : Node_Id); - -- Insert arbitrary node N in declarative list Decls and analyze it - - ------------------------ - -- Insert_And_Analyze -- - ------------------------ - - procedure Insert_And_Analyze (Decls : List_Id; N : Node_Id) is - begin - -- The declarative list is already populated, the nodes are - -- inserted at the top of the list, preserving their order. - - if Present (Insert_Nod) then - Insert_Before (Insert_Nod, N); - - -- Otherwise append to the declarations to preserve order - - else - Append_To (Decls, N); - end if; - - Analyze (N); - end Insert_And_Analyze; - - -- Local variables - - Loc : constant Source_Ptr := Sloc (Unit_Id); - Spec_Id : constant Entity_Id := Unique_Defining_Entity (Unit_Decl); - Decls : List_Id; - FM_Id : Entity_Id; - Pref : Character; - Unit_Spec : Node_Id; - - -- Start of processing for Create_Anonymous_Master - - begin - -- Find the declarative list of the unit - - if Nkind (Unit_Decl) = N_Package_Declaration then - Unit_Spec := Specification (Unit_Decl); - Decls := Visible_Declarations (Unit_Spec); - - if No (Decls) then - Decls := New_List (Make_Null_Statement (Loc)); - Set_Visible_Declarations (Unit_Spec, Decls); - end if; - - -- Package or subprogram body - - -- ??? A subprogram declaration that acts as a compilation unit may - -- contain a formal parameter of an anonymous access-to-controlled - -- type initialized by an allocator. - - -- procedure Comp_Unit_Proc (Param : access Ctrl := new Ctrl); - - -- There is no suitable place to create the anonymous master as the - -- subprogram is not in a declarative list. - - else - Decls := Declarations (Unit_Decl); - - if No (Decls) then - Decls := New_List (Make_Null_Statement (Loc)); - Set_Declarations (Unit_Decl, Decls); - end if; - end if; - - -- The anonymous master and all initialization actions are inserted - -- before the first declaration (if any). - - Insert_Nod := First (Decls); - - -- Since the anonymous master and all its initialization actions are - -- inserted at top level, use the scope of the unit when analyzing. - - Push_Scope (Spec_Id); - - -- Step 1: Anonymous master creation - - -- Use a unique prefix in case the same unit requires two anonymous - -- masters, one for the spec (S) and one for the body (B). - - if Ekind_In (Unit_Id, E_Function, E_Package, E_Procedure) then - Pref := 'S'; - else - Pref := 'B'; - end if; - - FM_Id := - Make_Defining_Identifier (Loc, - New_External_Name - (Related_Id => Chars (Unit_Id), - Suffix => "AM", - Prefix => Pref)); - - Set_Anonymous_Master (Unit_Id, FM_Id); - - -- Generate: - -- : Finalization_Master; - - Insert_And_Analyze (Decls, - Make_Object_Declaration (Loc, - Defining_Identifier => FM_Id, - Object_Definition => - New_Occurrence_Of (RTE (RE_Finalization_Master), Loc))); - - -- Step 2: Initialization actions - - -- Generate: - -- Set_Base_Pool - -- (, Global_Pool_Object'Unrestricted_Access); - - Insert_And_Analyze (Decls, - Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (RTE (RE_Set_Base_Pool), Loc), - Parameter_Associations => New_List ( - New_Occurrence_Of (FM_Id, Loc), - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (RTE (RE_Global_Pool_Object), Loc), - Attribute_Name => Name_Unrestricted_Access)))); - - -- Generate: - -- Set_Is_Heterogeneous (); - - Insert_And_Analyze (Decls, - Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (RTE (RE_Set_Is_Heterogeneous), Loc), - Parameter_Associations => New_List ( - New_Occurrence_Of (FM_Id, Loc)))); - - Pop_Scope; - return FM_Id; - end Create_Anonymous_Master; - - -- Local declarations - - Unit_Decl : Node_Id; - Unit_Id : Entity_Id; - - -- Start of processing for Current_Anonymous_Master - - begin - Unit_Decl := Unit (Cunit (Current_Sem_Unit)); - Unit_Id := Defining_Entity (Unit_Decl); - - -- The compilation unit is a package instantiation. In this case the - -- anonymous master is associated with the package spec as both the - -- spec and body appear at the same level. - - if Nkind (Unit_Decl) = N_Package_Body - and then Nkind (Original_Node (Unit_Decl)) = N_Package_Instantiation - then - Unit_Id := Corresponding_Spec (Unit_Decl); - Unit_Decl := Unit_Declaration_Node (Unit_Id); - end if; - - if Present (Anonymous_Master (Unit_Id)) then - return Anonymous_Master (Unit_Id); - - -- Create a new anonymous master when allocating an object of anonymous - -- access-to-controlled type for the first time. - - else - return Create_Anonymous_Master (Unit_Id, Unit_Decl); - end if; - end Current_Anonymous_Master; - -------------------------------- -- Displace_Allocator_Pointer -- -------------------------------- @@ -4296,8 +4092,7 @@ package body Exp_Ch4 is Set_Finalization_Master (Root_Type (PtrT), Finalization_Master (Rel_Typ)); else - Set_Finalization_Master - (Root_Type (PtrT), Current_Anonymous_Master); + Build_Anonymous_Master (Root_Type (PtrT)); end if; end if; diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index c34f17d13ab..ad68f898f6c 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -422,11 +422,7 @@ package body Exp_Ch6 is if Ekind (Ptr_Typ) = E_Anonymous_Access_Type and then No (Finalization_Master (Ptr_Typ)) then - Build_Finalization_Master - (Typ => Ptr_Typ, - For_Anonymous => True, - Context_Scope => Scope (Ptr_Typ), - Insertion_Node => Associated_Node_For_Itype (Ptr_Typ)); + Build_Anonymous_Master (Ptr_Typ); end if; -- Access-to-controlled types should always have a master diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index 04b60b5c59d..8f498accf79 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -301,6 +301,9 @@ package body Exp_Ch7 is Finalize_Case => TSS_Deep_Finalize, Address_Case => TSS_Finalize_Address); + function Allows_Finalization_Master (Typ : Entity_Id) return Boolean; + -- Determine whether access type Typ may have a finalization master + procedure Build_Array_Deep_Procs (Typ : Entity_Id); -- Build the deep Initialize/Adjust/Finalize for a record Typ with -- Has_Controlled_Component set and store them using the TSS mechanism. @@ -427,6 +430,332 @@ package body Exp_Ch7 is -- [Deep_]Finalize (Acc_Typ (V).all); -- end; + -------------------------------- + -- Allows_Finalization_Master -- + -------------------------------- + + function Allows_Finalization_Master (Typ : Entity_Id) return Boolean is + function In_Deallocation_Instance (E : Entity_Id) return Boolean; + -- Determine whether entity E is inside a wrapper package created for + -- an instance of Ada.Unchecked_Deallocation. + + ------------------------------ + -- In_Deallocation_Instance -- + ------------------------------ + + function In_Deallocation_Instance (E : Entity_Id) return Boolean is + Pkg : constant Entity_Id := Scope (E); + Par : Node_Id := Empty; + + begin + if Ekind (Pkg) = E_Package + and then Present (Related_Instance (Pkg)) + and then Ekind (Related_Instance (Pkg)) = E_Procedure + then + Par := Generic_Parent (Parent (Related_Instance (Pkg))); + + return + Present (Par) + and then Chars (Par) = Name_Unchecked_Deallocation + and then Chars (Scope (Par)) = Name_Ada + and then Scope (Scope (Par)) = Standard_Standard; + end if; + + return False; + end In_Deallocation_Instance; + + -- Local variables + + Desig_Typ : constant Entity_Id := Designated_Type (Typ); + Ptr_Typ : constant Entity_Id := + Root_Type_Of_Full_View (Base_Type (Typ)); + + -- Start of processing for Allows_Finalization_Master + + begin + -- Certain run-time configurations and targets do not provide support + -- for controlled types and therefore do not need masters. + + if Restriction_Active (No_Finalization) then + return False; + + -- Do not consider C and C++ types since it is assumed that the non-Ada + -- side will handle their clean up. + + elsif Convention (Desig_Typ) = Convention_C + or else Convention (Desig_Typ) = Convention_CPP + then + return False; + + -- Do not consider types that return on the secondary stack + + elsif Present (Associated_Storage_Pool (Ptr_Typ)) + and then Is_RTE (Associated_Storage_Pool (Ptr_Typ), RE_SS_Pool) + then + return False; + + -- Do not consider types which may never allocate an object + + elsif No_Pool_Assigned (Ptr_Typ) then + return False; + + -- Do not consider access types coming from Ada.Unchecked_Deallocation + -- instances. Even though the designated type may be controlled, the + -- access type will never participate in allocation. + + elsif In_Deallocation_Instance (Ptr_Typ) then + return False; + + -- Do not consider non-library access types when restriction + -- No_Nested_Finalization is in effect since masters are controlled + -- objects. + + elsif Restriction_Active (No_Nested_Finalization) + and then not Is_Library_Level_Entity (Ptr_Typ) + then + return False; + + -- Do not create finalization masters in GNATprove mode because this + -- causes unwanted extra expansion. A compilation in this mode must + -- keep the tree as close as possible to the original sources. + + elsif GNATprove_Mode then + return False; + + -- Otherwise the access type may use a finalization master + + else + return True; + end if; + end Allows_Finalization_Master; + + ---------------------------- + -- Build_Anonymous_Master -- + ---------------------------- + + procedure Build_Anonymous_Master (Ptr_Typ : Entity_Id) is + function Create_Anonymous_Master + (Desig_Typ : Entity_Id; + Unit_Id : Entity_Id; + Unit_Decl : Node_Id) return Entity_Id; + -- Create a new anonymous finalization master for access type Ptr_Typ + -- with designated type Desig_Typ. The declaration of the master along + -- with its specialized initialization is inserted in the declarative + -- part of unit Unit_Decl. Unit_Id denotes the entity of Unit_Decl. + + function In_Subtree (N : Node_Id; Root : Node_Id) return Boolean; + -- Determine whether arbitrary node N appears within the subtree rooted + -- at node Root. + + ----------------------------- + -- Create_Anonymous_Master -- + ----------------------------- + + function Create_Anonymous_Master + (Desig_Typ : Entity_Id; + Unit_Id : Entity_Id; + Unit_Decl : Node_Id) return Entity_Id + is + Loc : constant Source_Ptr := Sloc (Unit_Id); + Spec_Id : constant Entity_Id := Unique_Defining_Entity (Unit_Decl); + Decls : List_Id; + FM_Decl : Node_Id; + FM_Id : Entity_Id; + FM_Init : Node_Id; + Pref : Character; + Unit_Spec : Node_Id; + + begin + -- Find the declarative list of the unit + + if Nkind (Unit_Decl) = N_Package_Declaration then + Unit_Spec := Specification (Unit_Decl); + Decls := Visible_Declarations (Unit_Spec); + + if No (Decls) then + Decls := New_List; + Set_Visible_Declarations (Unit_Spec, Decls); + end if; + + -- Package body or subprogram case + + -- ??? A subprogram spec or body that acts as a compilation unit may + -- contain a formal parameter of an anonymous access-to-controlled + -- type initialized by an allocator. + + -- procedure Comp_Unit_Proc (Param : access Ctrl := new Ctrl); + + -- There is no suitable place to create the anonymous master as the + -- subprogram is not in a declarative list. + + else + Decls := Declarations (Unit_Decl); + + if No (Decls) then + Decls := New_List; + Set_Declarations (Unit_Decl, Decls); + end if; + end if; + + -- Step 1: Anonymous master creation + + -- Use a unique prefix in case the same unit requires two anonymous + -- masters, one for the spec (S) and one for the body (B). + + if Ekind_In (Unit_Id, E_Function, E_Package, E_Procedure) then + Pref := 'S'; + else + Pref := 'B'; + end if; + + -- The name of the anonymous master has the following format: + + -- [BS]scopN__scop1__chars_of_desig_typAM + + -- The name utilizes the fully qualified name of the designated type + -- in case two controlled types with the same name are declared in + -- different scopes and both have anonymous access types. + + FM_Id := + Make_Defining_Identifier (Loc, + New_External_Name + (Related_Id => Get_Qualified_Name (Desig_Typ), + Suffix => "AM", + Prefix => Pref)); + + -- Associate the anonymous master with the designated type. This + -- ensures that any additional anonymous access types with the same + -- designated type will share the same anonymous paster within the + -- same unit. + + Set_Anonymous_Master (Desig_Typ, FM_Id); + + -- Generate: + -- : Finalization_Master; + + FM_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => FM_Id, + Object_Definition => + New_Occurrence_Of (RTE (RE_Finalization_Master), Loc)); + + -- Step 2: Initialization actions + + -- Generate: + -- Set_Base_Pool + -- (, Global_Pool_Object'Unrestricted_Access); + + FM_Init := + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Set_Base_Pool), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (FM_Id, Loc), + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (RTE (RE_Global_Pool_Object), Loc), + Attribute_Name => Name_Unrestricted_Access))); + + Prepend_To (Decls, FM_Init); + Prepend_To (Decls, FM_Decl); + + -- Since the anonymous master and all its initialization actions are + -- inserted at top level, use the scope of the unit when analyzing. + + Push_Scope (Spec_Id); + Analyze (FM_Decl); + Analyze (FM_Init); + Pop_Scope; + + return FM_Id; + end Create_Anonymous_Master; + + ---------------- + -- In_Subtree -- + ---------------- + + function In_Subtree (N : Node_Id; Root : Node_Id) return Boolean is + Par : Node_Id; + + begin + -- Traverse the parent chain until reaching the same root + + Par := N; + while Present (Par) loop + if Par = Root then + return True; + end if; + + Par := Parent (Par); + end loop; + + return False; + end In_Subtree; + + -- Local variables + + Desig_Typ : Entity_Id; + FM_Id : Entity_Id; + Priv_View : Entity_Id; + Unit_Decl : Node_Id; + Unit_Id : Entity_Id; + + -- Start of processing for Build_Anonymous_Master + + begin + -- Nothing to do if the circumstances do not allow for a finalization + -- master. + + if not Allows_Finalization_Master (Ptr_Typ) then + return; + end if; + + Unit_Decl := Unit (Cunit (Current_Sem_Unit)); + Unit_Id := Defining_Entity (Unit_Decl); + + -- The compilation unit is a package instantiation. In this case the + -- anonymous master is associated with the package spec as both the + -- spec and body appear at the same level. + + if Nkind (Unit_Decl) = N_Package_Body + and then Nkind (Original_Node (Unit_Decl)) = N_Package_Instantiation + then + Unit_Id := Corresponding_Spec (Unit_Decl); + Unit_Decl := Unit_Declaration_Node (Unit_Id); + end if; + + -- Use the initial declaration of the designated type when it denotes + -- the full view of an incomplete or private type. This ensures that + -- types with one and two views are treated the same. + + Desig_Typ := Directly_Designated_Type (Ptr_Typ); + Priv_View := Incomplete_Or_Partial_View (Desig_Typ); + + if Present (Priv_View) then + Desig_Typ := Priv_View; + end if; + + FM_Id := Anonymous_Master (Desig_Typ); + + -- The designated type already has at least one anonymous access type + -- pointing to it within the current unit. Reuse the anonymous master + -- because the designated type is the same. + + if Present (FM_Id) + and then In_Subtree (Declaration_Node (FM_Id), Root => Unit_Decl) + then + null; + + -- Otherwise the designated type lacks an anonymous master or it is + -- declared in a different unit. Create a brand new master. + + else + FM_Id := Create_Anonymous_Master (Desig_Typ, Unit_Id, Unit_Decl); + end if; + + Set_Finalization_Master (Ptr_Typ, FM_Id); + end Build_Anonymous_Master; + ---------------------------- -- Build_Array_Deep_Procs -- ---------------------------- @@ -762,7 +1091,6 @@ package body Exp_Ch7 is procedure Build_Finalization_Master (Typ : Entity_Id; - For_Anonymous : Boolean := False; For_Lib_Level : Boolean := False; For_Private : Boolean := False; Context_Scope : Entity_Id := Empty; @@ -773,10 +1101,6 @@ package body Exp_Ch7 is Ptr_Typ : Entity_Id); -- Add access type Ptr_Typ to the pending access type list for type Typ - function In_Deallocation_Instance (E : Entity_Id) return Boolean; - -- Determine whether entity E is inside a wrapper package created for - -- an instance of Ada.Unchecked_Deallocation. - ----------------------------- -- Add_Pending_Access_Type -- ----------------------------- @@ -798,31 +1122,6 @@ package body Exp_Ch7 is Prepend_Elmt (Ptr_Typ, List); end Add_Pending_Access_Type; - ------------------------------ - -- In_Deallocation_Instance -- - ------------------------------ - - function In_Deallocation_Instance (E : Entity_Id) return Boolean is - Pkg : constant Entity_Id := Scope (E); - Par : Node_Id := Empty; - - begin - if Ekind (Pkg) = E_Package - and then Present (Related_Instance (Pkg)) - and then Ekind (Related_Instance (Pkg)) = E_Procedure - then - Par := Generic_Parent (Parent (Related_Instance (Pkg))); - - return - Present (Par) - and then Chars (Par) = Name_Unchecked_Deallocation - and then Chars (Scope (Par)) = Name_Ada - and then Scope (Scope (Par)) = Standard_Standard; - end if; - - return False; - end In_Deallocation_Instance; - -- Local variables Desig_Typ : constant Entity_Id := Designated_Type (Typ); @@ -836,18 +1135,10 @@ package body Exp_Ch7 is -- Start of processing for Build_Finalization_Master begin - -- Certain run-time configurations and targets do not provide support - -- for controlled types. - - if Restriction_Active (No_Finalization) then - return; + -- Nothing to do if the circumstances do not allow for a finalization + -- master. - -- Do not process C, C++ types since it is assumed that the non-Ada side - -- will handle their clean up. - - elsif Convention (Desig_Typ) = Convention_C - or else Convention (Desig_Typ) = Convention_CPP - then + if not Allows_Finalization_Master (Typ) then return; -- Various machinery such as freezing may have already created a @@ -855,48 +1146,6 @@ package body Exp_Ch7 is elsif Present (Finalization_Master (Ptr_Typ)) then return; - - -- Do not process types that return on the secondary stack - - elsif Present (Associated_Storage_Pool (Ptr_Typ)) - and then Is_RTE (Associated_Storage_Pool (Ptr_Typ), RE_SS_Pool) - then - return; - - -- Do not process types which may never allocate an object - - elsif No_Pool_Assigned (Ptr_Typ) then - return; - - -- Do not process access types coming from Ada.Unchecked_Deallocation - -- instances. Even though the designated type may be controlled, the - -- access type will never participate in allocation. - - elsif In_Deallocation_Instance (Ptr_Typ) then - return; - - -- Ignore the general use of anonymous access types unless the context - -- requires a finalization master. - - elsif Ekind (Ptr_Typ) = E_Anonymous_Access_Type - and then not For_Anonymous - then - return; - - -- Do not process non-library access types when restriction No_Nested_ - -- Finalization is in effect since masters are controlled objects. - - elsif Restriction_Active (No_Nested_Finalization) - and then not Is_Library_Level_Entity (Ptr_Typ) - then - return; - - -- Do not create finalization masters in GNATprove mode because this - -- unwanted extra expansion. A compilation in this mode keeps the tree - -- as close as possible to the original sources. - - elsif GNATprove_Mode then - return; end if; declare @@ -1013,11 +1262,11 @@ package body Exp_Ch7 is Add_Pending_Access_Type (Desig_Typ, Ptr_Typ); end if; - -- A finalization master created for an anonymous access type or an - -- access designating a type with private components must be inserted - -- before a context-dependent node. + -- A finalization master created for an access designating a type + -- with private components is inserted before a context-dependent + -- node. - if For_Anonymous or For_Private then + if For_Private then -- At this point both the scope of the context and the insertion -- mode must be known. @@ -3693,15 +3942,6 @@ package body Exp_Ch7 is end if; end Check_Visibly_Controlled; - ------------------------------- - -- CW_Or_Has_Controlled_Part -- - ------------------------------- - - function CW_Or_Has_Controlled_Part (T : Entity_Id) return Boolean is - begin - return Is_Class_Wide_Type (T) or else Needs_Finalization (T); - end CW_Or_Has_Controlled_Part; - ------------------ -- Convert_View -- ------------------ @@ -3764,6 +4004,15 @@ package body Exp_Ch7 is end if; end Convert_View; + ------------------------------- + -- CW_Or_Has_Controlled_Part -- + ------------------------------- + + function CW_Or_Has_Controlled_Part (T : Entity_Id) return Boolean is + begin + return Is_Class_Wide_Type (T) or else Needs_Finalization (T); + end CW_Or_Has_Controlled_Part; + ------------------------ -- Enclosing_Function -- ------------------------ diff --git a/gcc/ada/exp_ch7.ads b/gcc/ada/exp_ch7.ads index 3f90f31580e..31369343781 100644 --- a/gcc/ada/exp_ch7.ads +++ b/gcc/ada/exp_ch7.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -35,6 +35,11 @@ package Exp_Ch7 is -- Finalization Management -- ----------------------------- + procedure Build_Anonymous_Master (Ptr_Typ : Entity_Id); + -- Build a finalization master for an anonymous access-to-controlled type + -- denoted by Ptr_Typ. The master is inserted in the declarations of the + -- current unit. + procedure Build_Controlling_Procs (Typ : Entity_Id); -- Typ is a record, and array type having controlled components. -- Create the procedures Deep_Initialize, Deep_Adjust and Deep_Finalize @@ -99,22 +104,19 @@ package Exp_Ch7 is procedure Build_Finalization_Master (Typ : Entity_Id; - For_Anonymous : Boolean := False; For_Lib_Level : Boolean := False; For_Private : Boolean := False; Context_Scope : Entity_Id := Empty; Insertion_Node : Node_Id := Empty); -- Build a finalization master for an access type. The designated type may -- not necessarely be controlled or need finalization actions depending on - -- the context. Flag For_Anonymous must be set when creating a master for - -- an anonymous access type. Flag For_Lib_Level must be set when creating - -- a master for a build-in-place function call access result type. Flag - -- For_Private must be set when the designated type contains a private - -- component. Parameters Context_Scope and Insertion_Node must be used in - -- conjunction with flags For_Anonymous and For_Private. Context_Scope is - -- the scope of the context where the finalization master must be analyzed. - -- Insertion_Node is the insertion point before which the master is to be - -- inserted. + -- the context. Flag For_Lib_Level must be set when creating a master for a + -- build-in-place function call access result type. Flag For_Private must + -- be set when the designated type contains a private component. Parameters + -- Context_Scope and Insertion_Node must be used in conjunction with flag + -- For_Private. Context_Scope is the scope of the context where the + -- finalization master must be analyzed. Insertion_Node is the insertion + -- point before which the master is to be inserted. procedure Build_Late_Proc (Typ : Entity_Id; Nam : Name_Id); -- Build one controlling procedure when a late body overrides one of diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb index 420482fbcaa..fdf8c8a086a 100644 --- a/gcc/ada/gnat1drv.adb +++ b/gcc/ada/gnat1drv.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -180,6 +180,12 @@ procedure Gnat1drv is if Operating_Mode = Check_Semantics and then Tree_Output then ASIS_Mode := True; + -- Set ASIS GNSA mode if -gnatd.H is set + + if Debug_Flag_Dot_HH then + ASIS_GNSA_Mode := True; + end if; + -- Turn off inlining in ASIS mode, since ASIS cannot handle the extra -- information in the trees caused by inlining being active. @@ -1054,7 +1060,7 @@ begin if GNATprove_Mode then declare Unused_E : constant Entity_Id := - Rtsfind.RTE (Rtsfind.RE_Interrupt_Priority); + Rtsfind.RTE (Rtsfind.RE_Interrupt_Priority); begin null; end; @@ -1176,13 +1182,11 @@ begin -- We can generate code for a package declaration or a subprogram -- declaration only if it does not required a body. - elsif Nkind_In (Main_Kind, - N_Package_Declaration, - N_Subprogram_Declaration) + elsif Nkind_In (Main_Kind, N_Package_Declaration, + N_Subprogram_Declaration) and then (not Body_Required (Main_Unit_Node) - or else - Distribution_Stub_Mode = Generate_Caller_Stub_Body) + or else Distribution_Stub_Mode = Generate_Caller_Stub_Body) then Back_End_Mode := Generate_Object; @@ -1247,8 +1251,7 @@ begin if Back_End_Mode = Skip then Set_Standard_Error; - Write_Str ("cannot generate code for "); - Write_Str ("file "); + Write_Str ("cannot generate code for file "); Write_Name (Unit_File_Name (Main_Unit)); if Subunits_Missing then @@ -1320,11 +1323,16 @@ begin -- Annotation is suppressed for targets where front-end layout is -- enabled, because the front end determines representations. + -- The back-end is not invoked in ASIS mode with GNSA because all type + -- representation information will be provided by the GNSA back-end, not + -- gigi. + if Back_End_Mode = Declarations_Only and then (not (Back_Annotate_Rep_Info or Generate_SCIL or GNATprove_Mode) or else Main_Kind = N_Subunit - or else Frontend_Layout_On_Target) + or else Frontend_Layout_On_Target + or else ASIS_GNSA_Mode) then Post_Compilation_Validation_Checks; Errout.Finalize (Last_Call => True); diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads index 6feb21c89a5..402a9e50e5e 100644 --- a/gcc/ada/opt.ads +++ b/gcc/ada/opt.ads @@ -208,6 +208,11 @@ package Opt is -- Set to non-null when Bind_Alternate_Main_Name is True. This value -- is modified as needed by Gnatbind.Scan_Bind_Arg. + ASIS_GNSA_Mode : Boolean := False; + -- GNAT + -- Enable GNSA back-end processing assuming ASIS_Mode is already set to + -- True. ASIS_GNSA mode suppresses the call to gigi. + ASIS_Mode : Boolean := False; -- GNAT -- Enable semantic checks and tree transformations that are important diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 875c1666700..8f078fd561a 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -4758,9 +4758,8 @@ package body Sem_Ch13 is elsif Is_Subprogram (U_Ent) then if Has_Homonym (U_Ent) then Error_Msg_N - ("address clause cannot be given " & - "for overloaded subprogram", - Nam); + ("address clause cannot be given for overloaded " + & "subprogram", Nam); return; end if; @@ -4802,8 +4801,8 @@ package body Sem_Ch13 is if Warn_On_Obsolescent_Feature then Error_Msg_N - ("?j?attaching interrupt to task entry is an " & - "obsolescent feature (RM J.7.1)", N); + ("?j?attaching interrupt to task entry is an obsolescent " + & "feature (RM J.7.1)", N); Error_Msg_N ("\?j?use interrupt procedure instead", N); end if; @@ -5022,12 +5021,17 @@ package body Sem_Ch13 is Set_Has_Alignment_Clause (U_Ent); -- Tagged type case, check for attempt to set alignment to a - -- value greater than Max_Align, and reset if so. + -- value greater than Max_Align, and reset if so. This error + -- is suppressed in ASIS mode to allow for different ASIS + -- back-ends or ASIS-based tools to query the illegal clause. - if Is_Tagged_Type (U_Ent) and then Align > Max_Align then + if Is_Tagged_Type (U_Ent) + and then Align > Max_Align + and then not ASIS_Mode + then Error_Msg_N ("alignment for & set to Maximum_Aligment??", Nam); - Set_Alignment (U_Ent, Max_Align); + Set_Alignment (U_Ent, Max_Align); -- All other cases @@ -5100,7 +5104,7 @@ package body Sem_Ch13 is end if; Btype := Base_Type (U_Ent); - Ctyp := Component_Type (Btype); + Ctyp := Component_Type (Btype); if Duplicate_Clause then null; @@ -5324,8 +5328,8 @@ package body Sem_Ch13 is Error_Msg_NE ("??non-unique external tag supplied for &", N, U_Ent); Error_Msg_N - ("\??same external tag applies to all " - & "subprogram calls", N); + ("\??same external tag applies to all subprogram calls", + N); Error_Msg_N ("\??corresponding internal tag cannot be obtained", N); end if; @@ -5363,8 +5367,8 @@ package body Sem_Ch13 is if From_Aspect_Specification (N) then if not Is_Concurrent_Type (U_Ent) then Error_Msg_N - ("Interrupt_Priority can only be defined for task " - & "and protected object", Nam); + ("Interrupt_Priority can only be defined for task and " + & "protected object", Nam); elsif Duplicate_Clause then null; @@ -5456,9 +5460,15 @@ package body Sem_Ch13 is if Radix = 2 then null; + elsif Radix = 10 then Set_Machine_Radix_10 (U_Ent); - else + + -- The following error is suppressed in ASIS mode to allow for + -- different ASIS back-ends or ASIS-based tools to query the + -- illegal clause. + + elsif not ASIS_Mode then Error_Msg_N ("machine radix value must be 2 or 10", Expr); end if; end if; @@ -5486,7 +5496,14 @@ package body Sem_Ch13 is else Check_Size (Expr, U_Ent, Size, Biased); - if Is_Scalar_Type (U_Ent) then + -- The following errors are suppressed in ASIS mode to allow + -- for different ASIS back-ends or ASIS-based tools to query + -- the illegal clause. + + if ASIS_Mode then + null; + + elsif Is_Scalar_Type (U_Ent) then if Size /= 8 and then Size /= 16 and then Size /= 32 and then UI_Mod (Size, 64) /= 0 then @@ -5573,8 +5590,8 @@ package body Sem_Ch13 is begin if not (Is_Record_Type (U_Ent) or else Is_Array_Type (U_Ent)) then Error_Msg_N - ("Scalar_Storage_Order can only be defined for " - & "record or array type", Nam); + ("Scalar_Storage_Order can only be defined for record or " + & "array type", Nam); elsif Duplicate_Clause then null; @@ -5598,8 +5615,8 @@ package body Sem_Ch13 is Set_Reverse_Storage_Order (Base_Type (U_Ent), True); else Error_Msg_N - ("non-default Scalar_Storage_Order " - & "not supported on target", Expr); + ("non-default Scalar_Storage_Order not supported on " + & "target", Expr); end if; end if; @@ -5696,21 +5713,22 @@ package body Sem_Ch13 is -- For objects, set Esize only else - if Is_Elementary_Type (Etyp) then - if Size /= System_Storage_Unit - and then - Size /= System_Storage_Unit * 2 - and then - Size /= System_Storage_Unit * 4 - and then - Size /= System_Storage_Unit * 8 - then - Error_Msg_Uint_1 := UI_From_Int (System_Storage_Unit); - Error_Msg_Uint_2 := Error_Msg_Uint_1 * 8; - Error_Msg_N - ("size for primitive object must be a power of 2" - & " in the range ^-^", N); - end if; + -- The following error is suppressed in ASIS mode to allow + -- for different ASIS back-ends or ASIS-based tools to query + -- the illegal clause. + + if Is_Elementary_Type (Etyp) + and then Size /= System_Storage_Unit + and then Size /= System_Storage_Unit * 2 + and then Size /= System_Storage_Unit * 4 + and then Size /= System_Storage_Unit * 8 + and then not ASIS_Mode + then + Error_Msg_Uint_1 := UI_From_Int (System_Storage_Unit); + Error_Msg_Uint_2 := Error_Msg_Uint_1 * 8; + Error_Msg_N + ("size for primitive object must be a power of 2 in " + & "the range ^-^", N); end if; Set_Esize (U_Ent, Size); @@ -5955,8 +5973,8 @@ package body Sem_Ch13 is if Warn_On_Obsolescent_Feature then Error_Msg_N - ("?j?storage size clause for task is an " & - "obsolescent feature (RM J.9)", N); + ("?j?storage size clause for task is an obsolescent " + & "feature (RM J.9)", N); Error_Msg_N ("\?j?use Storage_Size pragma instead", N); end if; end if; @@ -6024,24 +6042,29 @@ package body Sem_Ch13 is null; elsif Is_Elementary_Type (U_Ent) then - if Size /= System_Storage_Unit - and then - Size /= System_Storage_Unit * 2 - and then - Size /= System_Storage_Unit * 4 - and then - Size /= System_Storage_Unit * 8 + + -- The following errors are suppressed in ASIS mode to allow + -- for different ASIS back-ends or ASIS-based tools to query + -- the illegal clause. + + if ASIS_Mode then + null; + + elsif Size /= System_Storage_Unit + and then Size /= System_Storage_Unit * 2 + and then Size /= System_Storage_Unit * 4 + and then Size /= System_Storage_Unit * 8 then Error_Msg_Uint_1 := UI_From_Int (System_Storage_Unit); Error_Msg_N - ("stream size for elementary type must be a" - & " power of 2 and at least ^", N); + ("stream size for elementary type must be a power of 2 " + & "and at least ^", N); elsif RM_Size (U_Ent) > Size then Error_Msg_Uint_1 := RM_Size (U_Ent); Error_Msg_N - ("stream size for elementary type must be a" - & " power of 2 and at least ^", N); + ("stream size for elementary type must be a power of 2 " + & "and at least ^", N); end if; Set_Has_Stream_Size_Clause (U_Ent); @@ -6787,12 +6810,10 @@ package body Sem_Ch13 is and then Lbit /= No_Uint then if Posit < 0 then - Error_Msg_N - ("position cannot be negative", Position (CC)); + Error_Msg_N ("position cannot be negative", Position (CC)); elsif Fbit < 0 then - Error_Msg_N - ("first bit cannot be negative", First_Bit (CC)); + Error_Msg_N ("first bit cannot be negative", First_Bit (CC)); -- The Last_Bit specified in a component clause must not be -- less than the First_Bit minus one (RM-13.5.1(10)). @@ -6885,8 +6906,8 @@ package body Sem_Ch13 is Intval (Last_Bit (CC)) then Error_Msg_N - ("component clause inconsistent " - & "with representation of ancestor", CC); + ("component clause inconsistent with " + & "representation of ancestor", CC); elsif Warn_On_Redundant_Constructs then Error_Msg_N @@ -10870,13 +10891,36 @@ package body Sem_Ch13 is Siz : Uint; Biased : out Boolean) is + procedure Size_Too_Small_Error (Min_Siz : Uint); + -- Emit an error concerning illegal size Siz. Min_Siz denotes the + -- minimum size. + + -------------------------- + -- Size_Too_Small_Error -- + -------------------------- + + procedure Size_Too_Small_Error (Min_Siz : Uint) is + begin + -- This error is suppressed in ASIS mode to allow for different ASIS + -- back-ends or ASIS-based tools to query the illegal clause. + + if not ASIS_Mode then + Error_Msg_Uint_1 := Min_Siz; + Error_Msg_NE ("size for & too small, minimum allowed is ^", N, T); + end if; + end Size_Too_Small_Error; + + -- Local variables + UT : constant Entity_Id := Underlying_Type (T); M : Uint; + -- Start of processing for Check_Size + begin Biased := False; - -- Reject patently improper size values. + -- Reject patently improper size values if Is_Elementary_Type (T) and then Siz > UI_From_Int (Int'Last) @@ -10945,9 +10989,7 @@ package body Sem_Ch13 is return; else - Error_Msg_Uint_1 := Asiz; - Error_Msg_NE - ("size for& too small, minimum allowed is ^", N, T); + Size_Too_Small_Error (Asiz); Set_Esize (T, Asiz); Set_RM_Size (T, Asiz); end if; @@ -10962,9 +11004,7 @@ package body Sem_Ch13 is -- since we don't know all the characteristics of the type that can -- affect the size (e.g. a specified small) till freeze time. - elsif Is_Fixed_Point_Type (UT) - and then not Is_Frozen (UT) - then + elsif Is_Fixed_Point_Type (UT) and then not Is_Frozen (UT) then null; -- Cases for which a minimum check is required @@ -10988,10 +11028,8 @@ package body Sem_Ch13 is M := UI_From_Int (Minimum_Size (UT, Biased => True)); if Siz < M then - Error_Msg_Uint_1 := M; - Error_Msg_NE - ("size for& too small, minimum allowed is ^", N, T); - Set_Esize (T, M); + Size_Too_Small_Error (M); + Set_Esize (T, M); Set_RM_Size (T, M); else Biased := True; @@ -11513,14 +11551,36 @@ package body Sem_Ch13 is ------------------------- function Get_Alignment_Value (Expr : Node_Id) return Uint is + procedure Alignment_Error; + -- Issue an error concerning a negatize or zero alignment represented by + -- expression Expr. + + --------------------- + -- Alignment_Error -- + --------------------- + + procedure Alignment_Error is + begin + -- This error is suppressed in ASIS mode to allow for different ASIS + -- back-ends or ASIS-based tools to query the illegal clause. + + if not ASIS_Mode then + Error_Msg_N ("alignment value must be positive", Expr); + end if; + end Alignment_Error; + + -- Local variables + Align : constant Uint := Static_Integer (Expr); + -- Start of processing for Get_Alignment_Value + begin if Align = No_Uint then return No_Uint; elsif Align <= 0 then - Error_Msg_N ("alignment value must be positive", Expr); + Alignment_Error; return No_Uint; else @@ -11532,8 +11592,7 @@ package body Sem_Ch13 is exit when M = Align; if M > Align then - Error_Msg_N - ("alignment value must be power of 2", Expr); + Alignment_Error; return No_Uint; end if; end; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 9ed1301e45a..46079c5f6e9 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -3560,9 +3560,7 @@ package body Sem_Ch3 is -- Special checks for protected objects not at library level - if Is_Protected_Type (T) - and then not Is_Library_Level_Entity (Id) - then + if Has_Protected (T) and then not Is_Library_Level_Entity (Id) then Check_Restriction (No_Local_Protected_Objects, Id); -- Protected objects with interrupt handlers must be at library level @@ -3574,7 +3572,10 @@ package body Sem_Ch3 is -- AI05-0303: The AI is in fact a binding interpretation, and thus -- applies to the '95 version of the language as well. - if Has_Interrupt_Handler (T) and then Ada_Version < Ada_95 then + if Is_Protected_Type (T) + and then Has_Interrupt_Handler (T) + and then Ada_Version < Ada_95 + then Error_Msg_N ("interrupt object can only be declared at library level", Id); end if; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 34f3a203340..371c14733c5 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -8322,6 +8322,73 @@ package body Sem_Util is return Get_Pragma_Id (Pragma_Name (N)); end Get_Pragma_Id; + ------------------------ + -- Get_Qualified_Name -- + ------------------------ + + function Get_Qualified_Name + (Id : Entity_Id; + Suffix : Entity_Id := Empty) return Name_Id + is + Suffix_Nam : Name_Id := No_Name; + + begin + if Present (Suffix) then + Suffix_Nam := Chars (Suffix); + end if; + + return Get_Qualified_Name (Chars (Id), Suffix_Nam, Scope (Id)); + end Get_Qualified_Name; + + function Get_Qualified_Name + (Nam : Name_Id; + Suffix : Name_Id := No_Name; + Scop : Entity_Id := Current_Scope) return Name_Id + is + procedure Add_Scope (S : Entity_Id); + -- Add the fully qualified form of scope S to the name buffer. The + -- format is: + -- s-1__s__ + + --------------- + -- Add_Scope -- + --------------- + + procedure Add_Scope (S : Entity_Id) is + begin + if S = Empty then + null; + + elsif S = Standard_Standard then + null; + + else + Add_Scope (Scope (S)); + Get_Name_String_And_Append (Chars (S)); + Add_Str_To_Name_Buffer ("__"); + end if; + end Add_Scope; + + -- Start of processing for Get_Qualified_Name + + begin + Name_Len := 0; + Add_Scope (Scop); + + -- Append the base name after all scopes have been chained + + Get_Name_String_And_Append (Nam); + + -- Append the suffix (if present) + + if Suffix /= No_Name then + Add_Str_To_Name_Buffer ("__"); + Get_Name_String_And_Append (Suffix); + end if; + + return Name_Find; + end Get_Qualified_Name; + ----------------------- -- Get_Reason_String -- ----------------------- @@ -17762,39 +17829,13 @@ package body Sem_Util is ----------------- procedure Output_Name (Nam : Name_Id; Scop : Entity_Id := Current_Scope) is - procedure Output_Scope (S : Entity_Id); - -- Add the fully qualified form of scope S to the name buffer. The - -- qualification format is: - -- scope1__scopeN__ - - ------------------ - -- Output_Scope -- - ------------------ - - procedure Output_Scope (S : Entity_Id) is - begin - if S = Empty then - null; - - elsif S = Standard_Standard then - null; - - else - Output_Scope (Scope (S)); - Add_Str_To_Name_Buffer (Get_Name_String (Chars (S))); - Add_Str_To_Name_Buffer ("__"); - end if; - end Output_Scope; - - -- Start of processing for Output_Name - begin - Name_Len := 0; - Output_Scope (Scop); - - Add_Str_To_Name_Buffer (Get_Name_String (Nam)); - - Write_Str (Name_Buffer (1 .. Name_Len)); + Write_Str + (Get_Name_String + (Get_Qualified_Name + (Nam => Nam, + Suffix => No_Name, + Scop => Scop))); Write_Eol; end Output_Name; diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index fb049ef4551..c7fdc8181d5 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -950,6 +950,20 @@ package Sem_Util is pragma Inline (Get_Pragma_Id); -- Obtains the Pragma_Id from the Chars field of Pragma_Identifier (N) + function Get_Qualified_Name + (Id : Entity_Id; + Suffix : Entity_Id := Empty) return Name_Id; + -- Obtain the fully qualified form of entity Id. The format is: + -- scope_of_id-1__scope_of_id__chars_of_id__chars_of_suffix + + function Get_Qualified_Name + (Nam : Name_Id; + Suffix : Name_Id := No_Name; + Scop : Entity_Id := Current_Scope) return Name_Id; + -- Obtain the fully qualified form of name Nam assuming it appears in scope + -- Scop. The format is: + -- scop-1__scop__nam__suffix + procedure Get_Reason_String (N : Node_Id); -- Recursive routine to analyze reason argument for pragma Warnings. The -- value of the reason argument is appended to the current string using -- 2.11.4.GIT