From: Javier Miranda Date: Sat, 28 Mar 2020 18:52:14 +0000 (-0400) Subject: [Ada] Crash in tagged type constructor with task components X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=a7837c085aa5538430cdc9ffc04fcfa1f581656f;p=gcc.git [Ada] Crash in tagged type constructor with task components 2020-06-15 Javier Miranda gcc/ada/ * restrict.ads (Set_Global_No_Tasking, Global_No_Tasking): New subprograms. * restrict.adb (Set_Global_No_Tasking, Global_No_Tasking): New subprograms. * sem_ch3.adb (Access_Definition): Do not skip building masters since they may be required for BIP calls. (Analyze_Subtype_Declaration): Propagate attribute Is_Limited_Record in class-wide subtypes and subtypes with cloned subtype attribute; propagate attribute Is_Limited_Interface. * sem_ch6.adb (Check_Anonymous_Return): Do not skip building masters since they may be required for BIP calls. Use Build_Master_Declaration to declare the _master variable. (Create_Extra_Formals): Add decoration of Has_Master_Entity when the _master formal is added. * exp_ch3.adb (Init_Formals): Adding formal to decorate it with attribute Has_Master_Entity when the _master formal is added. (Build_Master): Do not skip building masters since they may be required for BIP calls. (Expand_N_Object_Declaration): Ensure activation chain and master entity for objects initialized with BIP function calls. * sem_prag.adb (Process_Restrictions_Or_Restriction_Warnings): Adding support to detect and save restriction No_Tasking when set in the run-time package System or in a global configuration pragmas file. * sem_util.adb (Current_Entity_In_Scope): Overload this subprogram to allow searching for an entity by its Name. * sem_util.ads (Current_Entity_In_Scope): Update comment. * exp_ch4.adb (Expand_N_Allocator): Do not skip building masters since they may be required for BIP calls. * exp_ch6.ads (Might_Have_Tasks): New subprogram. * exp_ch6.adb (Make_Build_In_Place_Call_In_Allocator): Add support for BIP calls returning objects that may have tasks. (Make_Build_In_Place_Call_In_Allocator): Build the activation chain if the result might have tasks. (Make_Build_In_Place_Iface_Call_In_Allocator): Build the class wide master for the result type. (Might_Have_Tasks): New subprogram. (Needs_BIP_Task_Actuals): Returns False when restriction No_Tasking is globally set. * exp_ch9.ads (Build_Master_Declaration): New subprogram. * exp_ch9.adb (Build_Activation_Chain_Entity): No action performed when restriction No_Tasking is globally set. (Build_Class_Wide_Master): No action performed when restriction No_Tasking is globally set; use Build_Master_Declaration to declare the _master variable. (Build_Master_Declaration): New subprogram. (Build_Master_Entity): No action performed when restriction No_Tasking is globally set; added support to handle transient scopes and _finalizer routines. (Build_Master_Renaming): No action performed when restriction No_Tasking is globally set. (Build_Task_Activation_Call): Skip generating the call when the chain is an ignored ghost entity. (Find_Master_Scope): Generalize the code that detects transient scopes with master entity. * einfo.ads (Has_Nested_Subprogram): Minor comment reformatting. --- diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 346a15eac5b..35efe5919f0 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -1813,8 +1813,8 @@ package Einfo is -- See documentation in backend for further details. -- Has_Nested_Subprogram (Flag282) --- Defined in subprogram entities. Set for a subprogram which contains at --- least one nested subprogram. +-- Defined in subprogram entities. Set for a subprogram which contains at +-- least one nested subprogram. -- Has_Non_Limited_View (synth) -- Defined in E_Incomplete_Type, E_Incomplete_Subtype, E_Class_Wide_Type, diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 7d13cd6cd2b..b207a1f1c92 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -184,11 +184,11 @@ package body Exp_Ch3 is -- E is a type, it has components that have no static initialization. -- if E is an entity, its initial expression is not compile-time known. - function Init_Formals (Typ : Entity_Id) return List_Id; + function Init_Formals (Typ : Entity_Id; Proc_Id : Entity_Id) return List_Id; -- This function builds the list of formals for an initialization routine. -- The first formal is always _Init with the given type. For task value -- record types and types containing tasks, three additional formals are - -- added: + -- added and Proc_Id is decorated with attribute Has_Master_Entity: -- -- _Master : Master_Id -- _Chain : in out Activation_Chain @@ -730,7 +730,7 @@ package body Exp_Ch3 is end if; Body_Stmts := Init_One_Dimension (1); - Parameters := Init_Formals (A_Type); + Parameters := Init_Formals (A_Type, Proc_Id); Discard_Node ( Make_Subprogram_Body (Loc, @@ -2438,7 +2438,7 @@ package body Exp_Ch3 is Proc_Spec_Node := New_Node (N_Procedure_Specification, Loc); Set_Defining_Unit_Name (Proc_Spec_Node, Proc_Id); - Parameters := Init_Formals (Rec_Type); + Parameters := Init_Formals (Rec_Type, Proc_Id); Append_List_To (Parameters, Build_Discriminant_Formals (Rec_Type, True)); @@ -5720,7 +5720,7 @@ package body Exp_Ch3 is -- record parameter for an entry declaration. No master is created -- for such a type. - if Comes_From_Source (N) and then Has_Task (Desig_Typ) then + if Has_Task (Desig_Typ) then Build_Master_Entity (Ptr_Typ); Build_Master_Renaming (Ptr_Typ); @@ -5734,12 +5734,11 @@ package body Exp_Ch3 is -- Suppress the master creation for access types created for entry -- formal parameters (parameter block component types). Seems like -- suppression should be more general for compiler-generated types, - -- but testing Comes_From_Source, like the code above does, may be - -- too general in this case (affects some test output)??? + -- but testing Comes_From_Source may be too general in this case + -- (affects some test output)??? elsif not Is_Param_Block_Component_Type (Ptr_Typ) and then Is_Limited_Class_Wide_Type (Desig_Typ) - and then Tasking_Allowed then Build_Class_Wide_Master (Ptr_Typ); end if; @@ -6666,14 +6665,39 @@ package body Exp_Ch3 is Init_After := Make_Shared_Var_Procs (N); end if; - -- If tasks being declared, make sure we have an activation chain + -- If tasks are being declared, make sure we have an activation chain -- defined for the tasks (has no effect if we already have one), and - -- also that a Master variable is established and that the appropriate - -- enclosing construct is established as a task master. + -- also that a Master variable is established (and that the appropriate + -- enclosing construct is established as a task master). - if Has_Task (Typ) then + if Has_Task (Typ) or else Might_Have_Tasks (Typ) then Build_Activation_Chain_Entity (N); - Build_Master_Entity (Def_Id); + + if Has_Task (Typ) then + Build_Master_Entity (Def_Id); + + -- Handle objects initialized with BIP function calls + + elsif Present (Expr) then + declare + Expr_Q : Node_Id := Expr; + + begin + if Nkind (Expr) = N_Qualified_Expression then + Expr_Q := Expression (Expr); + end if; + + if Is_Build_In_Place_Function_Call (Expr_Q) + or else Present (Unqual_BIP_Iface_Function_Call (Expr_Q)) + or else + (Nkind (Expr_Q) = N_Reference + and then + Is_Build_In_Place_Function_Call (Prefix (Expr_Q))) + then + Build_Master_Entity (Def_Id); + end if; + end; + end if; end if; -- If No_Implicit_Heap_Allocations or No_Implicit_Task_Allocations @@ -6691,7 +6715,7 @@ package body Exp_Ch3 is -- of the stacks in this scenario, the stacks of the first array are -- not counted. - if Has_Task (Typ) + if (Has_Task (Typ) or else Might_Have_Tasks (Typ)) and then not Restriction_Active (No_Secondary_Stack) and then (Restriction_Active (No_Implicit_Heap_Allocations) or else Restriction_Active (No_Implicit_Task_Allocations)) @@ -8862,7 +8886,8 @@ package body Exp_Ch3 is -- Init_Formals -- ------------------ - function Init_Formals (Typ : Entity_Id) return List_Id is + function Init_Formals (Typ : Entity_Id; Proc_Id : Entity_Id) return List_Id + is Loc : constant Source_Ptr := Sloc (Typ); Unc_Arr : constant Boolean := Is_Array_Type (Typ) and then not Is_Constrained (Typ); @@ -8871,9 +8896,11 @@ package body Exp_Ch3 is or else (Is_Record_Type (Typ) and then Is_Protected_Record_Type (Typ)); With_Task : constant Boolean := - Has_Task (Typ) - or else (Is_Record_Type (Typ) - and then Is_Task_Record_Type (Typ)); + not Global_No_Tasking + and then + (Has_Task (Typ) + or else (Is_Record_Type (Typ) + and then Is_Task_Record_Type (Typ))); Formals : List_Id; begin @@ -8902,6 +8929,8 @@ package body Exp_Ch3 is Parameter_Type => New_Occurrence_Of (RTE (RE_Master_Id), Loc))); + Set_Has_Master_Entity (Proc_Id); + -- Add _Chain (not done for sequential elaboration policy, see -- comment for Create_Restricted_Task_Sequential in s-tarest.ads). diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index bf882251732..27410ffe934 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -5031,20 +5031,18 @@ package body Exp_Ch4 is -- The designated type was an incomplete type, and the -- access type did not get expanded. Salvage it now. - if not Restriction_Active (No_Task_Hierarchy) then - if Present (Parent (Base_Type (PtrT))) then - Expand_N_Full_Type_Declaration - (Parent (Base_Type (PtrT))); + if Present (Parent (Base_Type (PtrT))) then + Expand_N_Full_Type_Declaration + (Parent (Base_Type (PtrT))); - -- The only other possibility is an itype. For this - -- case, the master must exist in the context. This is - -- the case when the allocator initializes an access - -- component in an init-proc. + -- The only other possibility is an itype. For this + -- case, the master must exist in the context. This is + -- the case when the allocator initializes an access + -- component in an init-proc. - else - pragma Assert (Is_Itype (PtrT)); - Build_Master_Renaming (PtrT, N); - end if; + else + pragma Assert (Is_Itype (PtrT)); + Build_Master_Renaming (PtrT, N); end if; end if; diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index b2b81eee9a1..1dd4493c785 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -8616,7 +8616,7 @@ package body Exp_Ch6 is -- rather than some outer chain. begin - if Has_Task (Result_Subt) then + if Has_Task (Result_Subt) or else Might_Have_Tasks (Result_Subt) then Actions := New_List; Build_Task_Allocate_Block_With_Init_Stmts (Actions, Allocator, Init_Stmts => New_List (Assign)); @@ -9393,6 +9393,7 @@ package body Exp_Ch6 is Anon_Type := Create_Itype (E_Anonymous_Access_Type, Function_Call); Set_Directly_Designated_Type (Anon_Type, Etype (BIP_Func_Call)); Set_Etype (Anon_Type, Anon_Type); + Build_Class_Wide_Master (Anon_Type); Tmp_Decl := Make_Object_Declaration (Loc, @@ -9627,6 +9628,18 @@ package body Exp_Ch6 is Analyze_And_Resolve (Allocator, Acc_Type); end Make_CPP_Constructor_Call_In_Allocator; + ---------------------- + -- Might_Have_Tasks -- + ---------------------- + + function Might_Have_Tasks (Typ : Entity_Id) return Boolean is + begin + return not Global_No_Tasking + and then not No_Run_Time_Mode + and then Is_Class_Wide_Type (Typ) + and then Is_Limited_Record (Typ); + end Might_Have_Tasks; + ---------------------------- -- Needs_BIP_Task_Actuals -- ---------------------------- @@ -9635,7 +9648,8 @@ package body Exp_Ch6 is pragma Assert (Is_Build_In_Place_Function (Func_Id)); Func_Typ : constant Entity_Id := Underlying_Type (Etype (Func_Id)); begin - return Has_Task (Func_Typ); + return not Global_No_Tasking + and then (Has_Task (Func_Typ) or else Might_Have_Tasks (Func_Typ)); end Needs_BIP_Task_Actuals; ----------------------------------- diff --git a/gcc/ada/exp_ch6.ads b/gcc/ada/exp_ch6.ads index b3dae148a55..1c30219cbad 100644 --- a/gcc/ada/exp_ch6.ads +++ b/gcc/ada/exp_ch6.ads @@ -234,6 +234,10 @@ package Exp_Ch6 is -- the constructor, and the allocator is rewritten to refer to that access -- object. Function_Call must denote a call to a CPP_Constructor function. + function Might_Have_Tasks (Typ : Entity_Id) return Boolean; + -- Return True if Typ is a limited class-wide type (or subtype), since it + -- might have task components. + function Needs_BIP_Alloc_Form (Func_Id : Entity_Id) return Boolean; -- Ada 2005 (AI-318-02): Return True if the function needs an implicit -- BIP_Alloc_Form parameter (see type BIP_Formal_Kind). diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index 5162118e46c..da6e3095b27 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -928,6 +928,12 @@ package body Exp_Ch9 is -- Start of processing for Build_Activation_Chain_Entity begin + -- No action needed if the run-time has no tasking support + + if Global_No_Tasking then + return; + end if; + -- Activation chain is never used for sequential elaboration policy, see -- comment for Create_Restricted_Task_Sequential in s-tarest.ads). @@ -1127,9 +1133,9 @@ package body Exp_Ch9 is Ren_Decl : Node_Id; begin - -- Nothing to do if there is no task hierarchy + -- No action needed if the run-time has no tasking support - if Restriction_Active (No_Task_Hierarchy) then + if Global_No_Tasking then return; end if; @@ -1168,21 +1174,7 @@ package body Exp_Ch9 is then begin Set_Has_Master_Entity (Master_Scope); - - -- Generate: - -- _master : constant Integer := Current_Master.all; - - Master_Decl := - Make_Object_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_uMaster), - Constant_Present => True, - Object_Definition => - New_Occurrence_Of (Standard_Integer, Loc), - Expression => - Make_Explicit_Dereference (Loc, - New_Occurrence_Of (RTE (RE_Current_Master), Loc))); - + Master_Decl := Build_Master_Declaration (Loc); Insert_Action (Find_Hook_Context (Related_Node), Master_Decl); Analyze (Master_Decl); @@ -1695,6 +1687,65 @@ package body Exp_Ch9 is return Ecount; end Build_Entry_Count_Expression; + ------------------------------ + -- Build_Master_Declaration -- + ------------------------------ + + function Build_Master_Declaration (Loc : Source_Ptr) return Node_Id is + Master_Decl : Node_Id; + + begin + -- Generate a dummy master if tasks or tasking hierarchies are + -- prohibited. + + -- _Master : constant Master_Id := 3; + + if not Tasking_Allowed + or else Restrictions.Set (No_Task_Hierarchy) + or else not RTE_Available (RE_Current_Master) + then + declare + Expr : Node_Id; + + begin + -- RE_Library_Task_Level is not always available in configurable + -- RunTime + + if not RTE_Available (RE_Library_Task_Level) then + Expr := Make_Integer_Literal (Loc, Uint_3); + else + Expr := New_Occurrence_Of (RTE (RE_Library_Task_Level), Loc); + end if; + + Master_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uMaster), + Constant_Present => True, + Object_Definition => + New_Occurrence_Of (Standard_Integer, Loc), + Expression => Expr); + end; + + -- Generate: + -- _master : constant Integer := Current_Master.all; + + else + Master_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uMaster), + Constant_Present => True, + Object_Definition => + New_Occurrence_Of (Standard_Integer, Loc), + Expression => + Make_Explicit_Dereference (Loc, + New_Occurrence_Of (RTE (RE_Current_Master), Loc))); + end if; + + return Master_Decl; + end Build_Master_Declaration; + --------------------------- -- Build_Parameter_Block -- --------------------------- @@ -3345,12 +3396,40 @@ package body Exp_Ch9 is Par : Node_Id; begin + -- No action needed if the run-time has no tasking support + + if Global_No_Tasking then + return; + end if; + if Is_Itype (Obj_Or_Typ) then Par := Associated_Node_For_Itype (Obj_Or_Typ); else Par := Parent (Obj_Or_Typ); end if; + -- For transient scopes check if the master entity is already defined + + if Is_Type (Obj_Or_Typ) + and then Ekind (Scope (Obj_Or_Typ)) = E_Block + and then Is_Internal (Scope (Obj_Or_Typ)) + then + declare + Master_Scope : constant Entity_Id := + Find_Master_Scope (Obj_Or_Typ); + begin + if Has_Master_Entity (Master_Scope) + or else Is_Finalizer (Master_Scope) + then + return; + end if; + + if Present (Current_Entity_In_Scope (Name_uMaster)) then + return; + end if; + end; + end if; + -- When creating a master for a record component which is either a task -- or access-to-task, the enclosing record is the master scope and the -- proper insertion point is the component list. @@ -3368,31 +3447,16 @@ package body Exp_Ch9 is Find_Enclosing_Context (Par, Context, Context_Id, Decls); end if; - -- Nothing to do if the context already has a master + -- Nothing to do if the context already has a master; internally build + -- finalizers don't need a master. - if Has_Master_Entity (Context_Id) then - return; - - -- Nothing to do if tasks or tasking hierarchies are prohibited - - elsif Restriction_Active (No_Tasking) - or else Restriction_Active (No_Task_Hierarchy) + if Has_Master_Entity (Context_Id) + or else Is_Finalizer (Context_Id) then return; end if; - -- Create a master, generate: - -- _Master : constant Master_Id := Current_Master.all; - - Decl := - Make_Object_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_uMaster), - Constant_Present => True, - Object_Definition => New_Occurrence_Of (RTE (RE_Master_Id), Loc), - Expression => - Make_Explicit_Dereference (Loc, - New_Occurrence_Of (RTE (RE_Current_Master), Loc))); + Decl := Build_Master_Declaration (Loc); -- The master is inserted at the start of the declarative list of the -- context. @@ -3448,11 +3512,9 @@ package body Exp_Ch9 is Master_Id : Entity_Id; begin - -- Nothing to do if tasks or tasking hierarchies are prohibited + -- No action needed if the run-time has no tasking support - if Restriction_Active (No_Tasking) - or else Restriction_Active (No_Task_Hierarchy) - then + if Global_No_Tasking then return; end if; @@ -4794,9 +4856,10 @@ package body Exp_Ch9 is Chain := Activation_Chain_Entity (Owner); -- Nothing to do when there are no tasks to activate. This is indicated - -- by a missing activation chain entity. + -- by a missing activation chain entity; skip also generating it when + -- it is a ghost entity. - if No (Chain) then + if No (Chain) or else Is_Ignored_Ghost_Entity (Chain) then return; end if; @@ -13312,8 +13375,7 @@ package body Exp_Ch9 is if Ada_Version >= Ada_2005 then while Is_Internal (S) loop if Nkind (Parent (S)) = N_Block_Statement - and then - Nkind (Original_Node (Parent (S))) = N_Procedure_Call_Statement + and then Has_Master_Entity (S) then exit; diff --git a/gcc/ada/exp_ch9.ads b/gcc/ada/exp_ch9.ads index 5ba5b9fdd07..3656ac7cdaa 100644 --- a/gcc/ada/exp_ch9.ads +++ b/gcc/ada/exp_ch9.ads @@ -55,6 +55,12 @@ package Exp_Ch9 is -- interface, ensure that the designated type has a _master and generate -- a renaming of the said master to service the access type. + function Build_Master_Declaration (Loc : Source_Ptr) return Node_Id; + -- For targets supporting tasks generate: + -- _Master : constant Integer := Current_Master.all; + -- For targets where tasks or tasking hierarchies are prohibited generate: + -- _Master : constant Master_Id := 3; + procedure Build_Master_Entity (Obj_Or_Typ : Entity_Id); -- Given the name of an object or a type which is either a task, contains -- tasks or designates tasks, create a _master in the appropriate scope diff --git a/gcc/ada/restrict.adb b/gcc/ada/restrict.adb index 2c812e81d14..ebdc7ce1c23 100644 --- a/gcc/ada/restrict.adb +++ b/gcc/ada/restrict.adb @@ -39,6 +39,10 @@ with Uname; use Uname; package body Restrict is + Global_Restriction_No_Tasking : Boolean := False; + -- Set to True when No_Tasking is set in the run-time package System + -- or in a configuration pragmas file (for example, gnat.adc). + -------------------------------- -- Package Local Declarations -- -------------------------------- @@ -898,6 +902,15 @@ package body Restrict is return Not_A_Restriction_Id; end Get_Restriction_Id; + ----------------------- + -- Global_No_Tasking -- + ----------------------- + + function Global_No_Tasking return Boolean is + begin + return Global_Restriction_No_Tasking; + end Global_No_Tasking; + ------------------------------- -- No_Exception_Handlers_Set -- ------------------------------- @@ -1574,6 +1587,15 @@ package body Restrict is No_Use_Of_Pragma_Warning (A_Id) := False; end Set_Restriction_No_Use_Of_Pragma; + --------------------------- + -- Set_Global_No_Tasking -- + --------------------------- + + procedure Set_Global_No_Tasking is + begin + Global_Restriction_No_Tasking := True; + end Set_Global_No_Tasking; + ---------------------------------- -- Suppress_Restriction_Message -- ---------------------------------- diff --git a/gcc/ada/restrict.ads b/gcc/ada/restrict.ads index e0c6bbacf10..bcea1158e9b 100644 --- a/gcc/ada/restrict.ads +++ b/gcc/ada/restrict.ads @@ -422,6 +422,10 @@ package Restrict is -- of individual Restrictions pragmas). Returns True only if all the -- required restrictions are set. + procedure Set_Global_No_Tasking; + -- Used in call from Sem_Prag when restriction No_Tasking is set in the + -- run-time package System or in a configuration pragmas file. + procedure Set_Profile_Restrictions (P : Profile_Name; N : Node_Id; @@ -505,6 +509,10 @@ package Restrict is -- Tests if tasking operations are allowed by the current restrictions -- settings. For tasking to be allowed Max_Tasks must be non-zero. + function Global_No_Tasking return Boolean; + -- Returns True if the restriction No_Tasking is set in the run-time + -- package System or in a configuration pragmas file. + ---------------------------------------------- -- Handling of Boolean Compilation Switches -- ---------------------------------------------- diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 2431b260e67..149776c212a 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -924,7 +924,6 @@ package body Sem_Ch3 is then if Is_Limited_Record (Desig_Type) and then Is_Class_Wide_Type (Desig_Type) - and then Tasking_Allowed then Build_Class_Wide_Master (Anon_Type); @@ -5418,6 +5417,7 @@ package body Sem_Ch3 is Set_Class_Wide_Type (Id, Class_Wide_Type (T)); Set_Cloned_Subtype (Id, T); Set_Is_Tagged_Type (Id, True); + Set_Is_Limited_Record (Id, Is_Limited_Record (T)); Set_Has_Unknown_Discriminants (Id, True); Set_No_Tagged_Streams_Pragma @@ -5701,6 +5701,7 @@ package body Sem_Ch3 is if Is_Interface (T) then Set_Is_Interface (Id); + Set_Is_Limited_Interface (Id, Is_Limited_Interface (T)); end if; if Present (Generic_Parent_Type (N)) @@ -12358,6 +12359,7 @@ package body Sem_Ch3 is -- Show Full is simply a renaming of Full_Base Set_Cloned_Subtype (Full, Full_Base); + Set_Is_Limited_Record (Full, Is_Limited_Record (Full_Base)); -- Propagate predicates @@ -12393,11 +12395,18 @@ package body Sem_Ch3 is if Is_Tagged_Type (Full_Base) then Set_Is_Tagged_Type (Full); + Set_Is_Limited_Record (Full, Is_Limited_Record (Full_Base)); + Set_Direct_Primitive_Operations (Full, Direct_Primitive_Operations (Full_Base)); Set_No_Tagged_Streams_Pragma (Full, No_Tagged_Streams_Pragma (Full_Base)); + if Is_Interface (Full_Base) then + Set_Is_Interface (Full); + Set_Is_Limited_Interface (Full, Is_Limited_Interface (Full_Base)); + end if; + -- Inherit class_wide type of full_base in case the partial view was -- not tagged. Otherwise it has already been created when the private -- subtype was analyzed. diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 51724ff0ea3..8ded5ad0553 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -51,7 +51,6 @@ with Nmake; use Nmake; with Opt; use Opt; with Output; use Output; with Restrict; use Restrict; -with Rident; use Rident; with Rtsfind; use Rtsfind; with Sem; use Sem; with Sem_Aux; use Sem_Aux; @@ -2928,22 +2927,8 @@ package body Sem_Ch6 is and then Is_Limited_Record (Designated_Type (Etype (Scop))))) and then Expander_Active - - -- Avoid cases with no tasking support - - and then RTE_Available (RE_Current_Master) - and then not Restriction_Active (No_Task_Hierarchy) then - Decl := - Make_Object_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_uMaster), - Constant_Present => True, - Object_Definition => - New_Occurrence_Of (RTE (RE_Master_Id), Loc), - Expression => - Make_Explicit_Dereference (Loc, - New_Occurrence_Of (RTE (RE_Current_Master), Loc))); + Decl := Build_Master_Declaration (Loc); if Present (Declarations (N)) then Prepend (Decl, Declarations (N)); @@ -8566,6 +8551,9 @@ package body Sem_Ch6 is Add_Extra_Formal (E, RTE (RE_Master_Id), E, BIP_Formal_Suffix (BIP_Task_Master)); + + Set_Has_Master_Entity (E); + Discard := Add_Extra_Formal (E, RTE (RE_Activation_Chain_Access), diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index a32bb9bf241..eb374c4bb7a 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -10679,6 +10679,55 @@ package body Sem_Prag is else Add_To_Config_Boolean_Restrictions (No_Elaboration_Code); end if; + + -- Special processing for No_Tasking restriction + + elsif R_Id = No_Tasking then + + -- Handle global configuration pragmas + + if No (Cunit (Main_Unit)) then + Set_Global_No_Tasking; + + -- Handle package System, which may be loaded by rtsfind as + -- a consequence of loading some other run-time unit. + + else + declare + C_Node : constant Entity_Id := + Cunit (Current_Sem_Unit); + C_Ent : constant Entity_Id := + Cunit_Entity (Current_Sem_Unit); + Loc_Str : constant String := + Build_Location_String (Sloc (C_Ent)); + Ref_Str : constant String := "system.ads"; + Ref_Len : constant Positive := Ref_Str'Length; + + begin + pragma Assert (Loc_Str'First = 1); + pragma Assert (Loc_Str'First = Ref_Str'First); + + if Nkind (Unit (C_Node)) = N_Package_Declaration + and then Chars (C_Ent) = Name_System + + -- Handle child packages named foo-system.ads + + and then Loc_Str'Length > Ref_Str'Length + and then Loc_Str (Loc_Str'First .. Ref_Len) + = Ref_Str (Ref_Str'First .. Ref_Len) + + -- ... and ensure that package System has not + -- been previously loaded. Done to ensure that + -- the above checks do not have any corner case + -- (since they are performed without semantic + -- information). + + and then not RTU_Loaded (Rtsfind.System) + then + Set_Global_No_Tasking; + end if; + end; + end if; end if; -- If this is a warning, then set the warning unless we already diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 203cada0956..31e03fda4dd 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -6119,14 +6119,14 @@ package body Sem_Util is -- Current_Entity_In_Scope -- ----------------------------- - function Current_Entity_In_Scope (N : Node_Id) return Entity_Id is + function Current_Entity_In_Scope (N : Name_Id) return Entity_Id is E : Entity_Id; CS : constant Entity_Id := Current_Scope; Transient_Case : constant Boolean := Scope_Is_Transient; begin - E := Get_Name_Entity_Id (Chars (N)); + E := Get_Name_Entity_Id (N); while Present (E) and then Scope (E) /= CS and then (not Transient_Case or else Scope (E) /= Scope (CS)) @@ -6137,6 +6137,15 @@ package body Sem_Util is return E; end Current_Entity_In_Scope; + ----------------------------- + -- Current_Entity_In_Scope -- + ----------------------------- + + function Current_Entity_In_Scope (N : Node_Id) return Entity_Id is + begin + return Current_Entity_In_Scope (Chars (N)); + end Current_Entity_In_Scope; + ------------------- -- Current_Scope -- ------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index ebc917512bf..a7ca0f7a092 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -574,9 +574,10 @@ package Sem_Util is -- Find the currently visible definition for a given identifier, that is to -- say the first entry in the visibility chain for the Chars of N. + function Current_Entity_In_Scope (N : Name_Id) return Entity_Id; function Current_Entity_In_Scope (N : Node_Id) return Entity_Id; - -- Find whether there is a previous definition for identifier N in the - -- current scope. Because declarations for a scope are not necessarily + -- 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.