diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 46 | ||||
| -rw-r--r-- | gcc/ada/a-cbhama.adb | 47 | ||||
| -rw-r--r-- | gcc/ada/a-cbhase.adb | 20 | ||||
| -rw-r--r-- | gcc/ada/einfo.adb | 17 | ||||
| -rw-r--r-- | gcc/ada/einfo.ads | 21 | ||||
| -rw-r--r-- | gcc/ada/exp_ch4.adb | 207 | ||||
| -rw-r--r-- | gcc/ada/exp_ch5.adb | 18 | ||||
| -rw-r--r-- | gcc/ada/prj-attr.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/s-taprop-linux.adb | 11 | ||||
| -rw-r--r-- | gcc/ada/sem_ch4.adb | 53 | ||||
| -rw-r--r-- | gcc/ada/sem_disp.adb | 8 | ||||
| -rw-r--r-- | gcc/ada/sem_res.adb | 14 |
12 files changed, 339 insertions, 125 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 53aed0db311..a2c2cd332dd 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,49 @@ +2011-08-31 Javier Miranda <miranda@adacore.com> + + * sem_ch4.adb (Try_Object_Operation): When a dispatching primitive is + found check if there is a class-wide subprogram covering the primitive. + +2011-08-31 Yannick Moy <moy@adacore.com> + + * sem_res.adb: Further cases where full expansion test is needed, + rather than expansion test. + +2011-08-31 Pascal Obry <obry@adacore.com> + + * prj-attr.adb: Fix Source_File_Switches attribute kind (must be a list) + +2011-08-31 Ed Schonberg <schonberg@adacore.com> + + * exp_ch5.adb: Handle iterators over derived container types. + +2011-08-31 Hristian Kirtchev <kirtchev@adacore.com> + + * einfo.ads, einfo.adb: Add new flag Has_Anonymous_Master. + (Has_Anonymous_Master): New routine. + (Set_Has_Anonymous_Master): New routine. + (Write_Entity_Flags): Add an entry for Has_Anonymous_Master. + * exp_ch4.adb: Add with and use clause for Sem_Ch8. + (Current_Anonymous_Master): New routine. + (Current_Unit_First_Declaration): Removed. + (Current_Unit_Scope): Removed. + (Expand_N_Allocator): Anonymous access-to-controlled types now chain + their objects on a per-unit heterogeneous finalization master. + +2011-08-31 Matthew Heaney <heaney@adacore.com> + + * a-cbhama.adb, a-cbhase.adb (Insert): Check for zero-length buckets + array. + +2011-08-31 Jose Ruiz <ruiz@adacore.com> + + * s-taprop-linux.adb (Create_Task): Avoid changing the affinity mask + when not needed. + +2011-08-31 Gary Dismukes <dismukes@adacore.com> + + * sem_disp.adb (Propagate_Tag): Return without propagating in the case + where the actual is an unexpanded call to 'Input. + 2011-08-31 Yannick Moy <moy@adacore.com> * sem_ch4.adb: Code clean up. diff --git a/gcc/ada/a-cbhama.adb b/gcc/ada/a-cbhama.adb index 629c1041ed9..d7c75d44aaf 100644 --- a/gcc/ada/a-cbhama.adb +++ b/gcc/ada/a-cbhama.adb @@ -513,6 +513,11 @@ package body Ada.Containers.Bounded_Hashed_Maps is procedure Assign_Key (Node : in out Node_Type) is begin Node.Key := Key; + + -- Note that we do not also assign the element component of the node + -- here, because this version of Insert does not accept an element + -- parameter. + -- Node.Element := New_Item; end Assign_Key; @@ -530,20 +535,17 @@ package body Ada.Containers.Bounded_Hashed_Maps is -- Start of processing for Insert begin - -- ??? - -- if HT_Ops.Capacity (HT) = 0 then - -- HT_Ops.Reserve_Capacity (HT, 1); - -- end if; + -- The buckets array length is specified by the user as a discriminant + -- of the container type, so it is possible for the buckets array to + -- have a length of zero. We must check for this case specifically, in + -- order to prevent divide-by-zero errors later, when we compute the + -- buckets array index value for a key, given its hash value. + + if Container.Buckets'Length = 0 then + raise Capacity_Error with "No capacity for insertion"; + end if; Local_Insert (Container, Key, Position.Node, Inserted); - - -- ??? - -- if Inserted - -- and then HT.Length > HT_Ops.Capacity (HT) - -- then - -- HT_Ops.Reserve_Capacity (HT, HT.Length); - -- end if; - Position.Container := Container'Unchecked_Access; end Insert; @@ -590,20 +592,17 @@ package body Ada.Containers.Bounded_Hashed_Maps is -- Start of processing for Insert begin - -- ?? - -- if HT_Ops.Capacity (HT) = 0 then - -- HT_Ops.Reserve_Capacity (HT, 1); - -- end if; + -- The buckets array length is specified by the user as a discriminant + -- of the container type, so it is possible for the buckets array to + -- have a length of zero. We must check for this case specifically, in + -- order to prevent divide-by-zero errors later, when we compute the + -- buckets array index value for a key, given its hash value. + + if Container.Buckets'Length = 0 then + raise Capacity_Error with "No capacity for insertion"; + end if; Local_Insert (Container, Key, Position.Node, Inserted); - - -- ??? - -- if Inserted - -- and then HT.Length > HT_Ops.Capacity (HT) - -- then - -- HT_Ops.Reserve_Capacity (HT, HT.Length); - -- end if; - Position.Container := Container'Unchecked_Access; end Insert; diff --git a/gcc/ada/a-cbhase.adb b/gcc/ada/a-cbhase.adb index faef78e9971..d2d5b6c53b5 100644 --- a/gcc/ada/a-cbhase.adb +++ b/gcc/ada/a-cbhase.adb @@ -710,19 +710,17 @@ package body Ada.Containers.Bounded_Hashed_Sets is -- Start of processing for Insert begin - -- ??? - -- if HT_Ops.Capacity (HT) = 0 then - -- HT_Ops.Reserve_Capacity (HT, 1); - -- end if; + -- The buckets array length is specified by the user as a discriminant + -- of the container type, so it is possible for the buckets array to + -- have a length of zero. We must check for this case specifically, in + -- order to prevent divide-by-zero errors later, when we compute the + -- buckets array index value for an element, given its hash value. + + if Container.Buckets'Length = 0 then + raise Capacity_Error with "No capacity for insertion"; + end if; Local_Insert (Container, New_Item, Node, Inserted); - - -- ??? - -- if Inserted - -- and then HT.Length > HT_Ops.Capacity (HT) - -- then - -- HT_Ops.Reserve_Capacity (HT, HT.Length); - -- end if; end Insert; ------------------ diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 03a97b66101..dbe5c261073 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -521,8 +521,8 @@ package body Einfo is -- Has_Implicit_Dereference Flag251 -- Is_Processed_Transient Flag252 + -- Has_Anonymous_Master Flag253 - -- (unused) Flag253 -- (unused) Flag254 ----------------------- @@ -1183,6 +1183,13 @@ package body Einfo is return Flag201 (Id); end Has_Anon_Block_Suffix; + function Has_Anonymous_Master (Id : E) return B is + begin + pragma Assert + (Ekind_In (Id, E_Function, E_Package, E_Package_Body, E_Procedure)); + return Flag253 (Id); + end Has_Anonymous_Master; + function Has_Atomic_Components (Id : E) return B is begin return Flag86 (Implementation_Base_Type (Id)); @@ -3662,6 +3669,13 @@ package body Einfo is Set_Flag201 (Id, V); end Set_Has_Anon_Block_Suffix; + procedure Set_Has_Anonymous_Master (Id : E; V : B := True) is + begin + pragma Assert + (Ekind_In (Id, E_Function, E_Package, E_Package_Body, E_Procedure)); + Set_Flag253 (Id, V); + end Set_Has_Anonymous_Master; + procedure Set_Has_Atomic_Components (Id : E; V : B := True) is begin pragma Assert (not Is_Type (Id) or else Is_Base_Type (Id)); @@ -7418,6 +7432,7 @@ package body Einfo is W ("Has_Alignment_Clause", Flag46 (Id)); W ("Has_All_Calls_Remote", Flag79 (Id)); W ("Has_Anon_Block_Suffix", Flag201 (Id)); + W ("Has_Anonymous_Master", Flag253 (Id)); W ("Has_Atomic_Components", Flag86 (Id)); W ("Has_Biased_Representation", Flag139 (Id)); W ("Has_Completion", Flag26 (Id)); diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 41ab2675af6..ca9f7fde540 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -1341,6 +1341,13 @@ package Einfo is -- more anonymous blocks and the Chars field contains a name with an -- anonymous block suffix (see Exp_Dbug for further details). +-- Has_Anonymous_Master (Flag253) +-- Present in units (top-level functions and procedures, library-level +-- packages). Set to True if the associated unit contains a heterogeneous +-- finalization master. The master's name is of the form <unit>AM and it +-- services anonymous access-to-controlled types with an undetermined +-- lifetime. + -- Has_Atomic_Components (Flag86) [implementation base type only] -- Present in all types and objects. Set only for an array type or -- an array object if a valid pragma Atomic_Components applies to the @@ -5239,6 +5246,7 @@ package Einfo is -- Delay_Cleanups (Flag114) -- Delay_Subprogram_Descriptors (Flag50) -- Discard_Names (Flag88) + -- Has_Anonymous_Master (Flag253) -- Has_Completion (Flag26) -- Has_Controlling_Result (Flag98) -- Has_Invariants (Flag232) @@ -5429,6 +5437,7 @@ package Einfo is -- Elaborate_Body_Desirable (Flag210) (non-generic case only) -- From_With_Type (Flag159) -- Has_All_Calls_Remote (Flag79) + -- Has_Anonymous_Master (Flag253) -- Has_Completion (Flag26) -- Has_Forward_Instantiation (Flag175) -- Has_Master_Entity (Flag21) @@ -5439,10 +5448,10 @@ package Einfo is -- Is_Instantiated (Flag126) -- Is_Private_Descendant (Flag53) -- Is_Visible_Child_Unit (Flag116) - -- Is_Wrapper_Package (synth) (non-generic case only) -- Renamed_In_Spec (Flag231) (non-generic case only) - -- Scope_Depth (synth) -- Static_Elaboration_Desired (Flag77) (non-generic case only) + -- Is_Wrapper_Package (synth) (non-generic case only) + -- Scope_Depth (synth) -- E_Package_Body -- Handler_Records (List10) (non-generic case only) @@ -5452,9 +5461,10 @@ package Einfo is -- Last_Entity (Node20) -- Scope_Depth_Value (Uint22) -- Finalizer (Node24) (non-generic case only) - -- Scope_Depth (synth) -- Delay_Subprogram_Descriptors (Flag50) + -- Has_Anonymous_Master (Flag253) -- Has_Subprogram_Descriptor (Flag93) + -- Scope_Depth (synth) -- E_Private_Type -- E_Private_Subtype @@ -5505,6 +5515,7 @@ package Einfo is -- Delay_Cleanups (Flag114) -- Delay_Subprogram_Descriptors (Flag50) -- Discard_Names (Flag88) + -- Has_Anonymous_Master (Flag253) -- Has_Completion (Flag26) -- Has_Invariants (Flag232) -- Has_Master_Entity (Flag21) @@ -6073,6 +6084,7 @@ package Einfo is function Has_Alignment_Clause (Id : E) return B; function Has_All_Calls_Remote (Id : E) return B; function Has_Anon_Block_Suffix (Id : E) return B; + function Has_Anonymous_Master (Id : E) return B; function Has_Atomic_Components (Id : E) return B; function Has_Biased_Representation (Id : E) return B; function Has_Completion (Id : E) return B; @@ -6660,6 +6672,7 @@ package Einfo is procedure Set_Has_Alignment_Clause (Id : E; V : B := True); procedure Set_Has_All_Calls_Remote (Id : E; V : B := True); procedure Set_Has_Anon_Block_Suffix (Id : E; V : B := True); + procedure Set_Has_Anonymous_Master (Id : E; V : B := True); procedure Set_Has_Atomic_Components (Id : E; V : B := True); procedure Set_Has_Biased_Representation (Id : E; V : B := True); procedure Set_Has_Completion (Id : E; V : B := True); @@ -7360,6 +7373,7 @@ package Einfo is pragma Inline (Has_Alignment_Clause); pragma Inline (Has_All_Calls_Remote); pragma Inline (Has_Anon_Block_Suffix); + pragma Inline (Has_Anonymous_Master); pragma Inline (Has_Atomic_Components); pragma Inline (Has_Biased_Representation); pragma Inline (Has_Completion); @@ -7803,6 +7817,7 @@ package Einfo is pragma Inline (Set_Has_Alignment_Clause); pragma Inline (Set_Has_All_Calls_Remote); pragma Inline (Set_Has_Anon_Block_Suffix); + pragma Inline (Set_Has_Anonymous_Master); pragma Inline (Set_Has_Atomic_Components); pragma Inline (Set_Has_Biased_Representation); pragma Inline (Set_Has_Completion); diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index f561733f284..1a1159b2a19 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -58,6 +58,7 @@ 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,13 +93,11 @@ package body Exp_Ch4 is -- If a boolean array assignment can be done in place, build call to -- corresponding library procedure. - function Current_Unit_First_Declaration return Node_Id; - -- Return the current unit's first declaration. If the declaration list is - -- empty, the routine generates a null statement and returns it. - - function Current_Unit_Scope return Entity_Id; - -- Return the scope of the current unit. If the current unit is a body, - -- return the scope of the spec. + 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 @@ -376,79 +375,166 @@ package body Exp_Ch4 is return; end Build_Boolean_Array_Proc_Call; - ------------------------------------ - -- Current_Unit_First_Declaration -- - ------------------------------------ + ------------------------------ + -- Current_Anonymous_Master -- + ------------------------------ - function Current_Unit_First_Declaration return Node_Id is - Sem_U : Node_Id := Unit (Cunit (Current_Sem_Unit)); - Decl : Node_Id; - Decls : List_Id; + function Current_Anonymous_Master return Entity_Id is + Decls : List_Id; + Fin_Mas_Id : Entity_Id; + Loc : Source_Ptr; + Subp_Body : Node_Id; + Unit_Decl : Node_Id; + Unit_Id : Entity_Id; begin - if Nkind (Sem_U) = N_Package_Declaration then - Sem_U := Specification (Sem_U); - Decls := Visible_Declarations (Sem_U); + Unit_Id := Cunit_Entity (Current_Sem_Unit); + + -- Find the entity of the current unit + + if Ekind (Unit_Id) = E_Subprogram_Body then + + -- When processing subprogram bodies, the proper scope is always that + -- of the spec. + + Subp_Body := Unit_Id; + while Present (Subp_Body) + and then Nkind (Subp_Body) /= N_Subprogram_Body + loop + Subp_Body := Parent (Subp_Body); + end loop; + + Unit_Id := Corresponding_Spec (Subp_Body); + end if; + + Loc := Sloc (Unit_Id); + Unit_Decl := Unit (Cunit (Current_Sem_Unit)); + + -- Find the declarations list of the current unit + + if Nkind (Unit_Decl) = N_Package_Declaration then + Unit_Decl := Specification (Unit_Decl); + Decls := Visible_Declarations (Unit_Decl); if No (Decls) then - Decl := Make_Null_Statement (Sloc (Sem_U)); - Decls := New_List (Decl); - Set_Visible_Declarations (Sem_U, Decls); + Decls := New_List (Make_Null_Statement (Loc)); + Set_Visible_Declarations (Unit_Decl, Decls); elsif Is_Empty_List (Decls) then - Decl := Make_Null_Statement (Sloc (Sem_U)); - Append_To (Decls, Decl); - - else - Decl := First (Decls); + Append_To (Decls, Make_Null_Statement (Loc)); end if; else - Decls := Declarations (Sem_U); + Decls := Declarations (Unit_Decl); if No (Decls) then - Decl := Make_Null_Statement (Sloc (Sem_U)); - Decls := New_List (Decl); - Set_Declarations (Sem_U, Decls); + Decls := New_List (Make_Null_Statement (Loc)); + Set_Declarations (Unit_Decl, Decls); elsif Is_Empty_List (Decls) then - Decl := Make_Null_Statement (Sloc (Sem_U)); - Append_To (Decls, Decl); - - else - Decl := First (Decls); + Append_To (Decls, Make_Null_Statement (Loc)); end if; end if; - return Decl; - end Current_Unit_First_Declaration; + -- The current unit has an existing anonymous master, traverse its + -- declarations and locate the entity. - ------------------------ - -- Current_Unit_Scope -- - ------------------------ + if Has_Anonymous_Master (Unit_Id) then + Fin_Mas_Id := First_Entity (Unit_Id); + while Present (Fin_Mas_Id) loop - function Current_Unit_Scope return Entity_Id is - Scop_Id : Entity_Id := Cunit_Entity (Current_Sem_Unit); - Subp_Bod : Node_Id; + -- Look for the first variable whose type is Finalization_Master - begin - if Ekind (Scop_Id) = E_Subprogram_Body then - - -- When processing subprogram bodies, the proper scope is always - -- that of the spec. + if Ekind (Fin_Mas_Id) = E_Variable + and then Etype (Fin_Mas_Id) = RTE (RE_Finalization_Master) + then + return Fin_Mas_Id; + end if; - Subp_Bod := Scop_Id; - while Present (Subp_Bod) - and then Nkind (Subp_Bod) /= N_Subprogram_Body - loop - Subp_Bod := Parent (Subp_Bod); + Next_Entity (Fin_Mas_Id); end loop; - Scop_Id := Corresponding_Spec (Subp_Bod); - end if; + raise Program_Error; + + -- Create a new anonymous master - return Scop_Id; - end Current_Unit_Scope; + else + declare + First_Decl : constant Node_Id := First (Decls); + Action : Node_Id; + + begin + -- Since the master and its associated initialization is inserted + -- at top level, use the scope of the unit when analyzing. + + Push_Scope (Unit_Id); + + -- Create the finalization master + + Fin_Mas_Id := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (Unit_Id), "AM")); + + -- Generate: + -- <Fin_Mas_Id> : Finalization_Master; + + Action := + Make_Object_Declaration (Loc, + Defining_Identifier => Fin_Mas_Id, + Object_Definition => + New_Reference_To (RTE (RE_Finalization_Master), Loc)); + + Insert_Before_And_Analyze (First_Decl, Action); + + -- Mark the unit to prevent the generation of multiple masters + + Set_Has_Anonymous_Master (Unit_Id); + + -- Do not set the base pool and mode of operation on .NET/JVM + -- since those targets do not support pools and all VM masters + -- are heterogeneous by default. + + if VM_Target = No_VM then + + -- Generate: + -- Set_Base_Pool + -- (<Fin_Mas_Id>, Global_Pool_Object'Unrestricted_Access); + + Action := + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To (RTE (RE_Set_Base_Pool), Loc), + + Parameter_Associations => New_List ( + New_Reference_To (Fin_Mas_Id, Loc), + Make_Attribute_Reference (Loc, + Prefix => + New_Reference_To (RTE (RE_Global_Pool_Object), Loc), + Attribute_Name => Name_Unrestricted_Access))); + + Insert_Before_And_Analyze (First_Decl, Action); + + -- Generate: + -- Set_Is_Heterogeneous (<Fin_Mas_Id>); + + Action := + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To (RTE (RE_Set_Is_Heterogeneous), Loc), + Parameter_Associations => New_List ( + New_Reference_To (Fin_Mas_Id, Loc))); + + Insert_Before_And_Analyze (First_Decl, Action); + end if; + + -- Restore the original state of the scope stack + + Pop_Scope; + + return Fin_Mas_Id; + end; + end if; + end Current_Anonymous_Master; -------------------------------- -- Displace_Allocator_Pointer -- @@ -3373,18 +3459,15 @@ package body Exp_Ch4 is if No (Associated_Storage_Pool (PtrT)) and then VM_Target = No_VM then - Set_Associated_Storage_Pool (PtrT, - Get_Global_Pool_For_Access_Type (PtrT)); + Set_Associated_Storage_Pool + (PtrT, Get_Global_Pool_For_Access_Type (PtrT)); end if; -- The finalization master must be inserted and analyzed as part of -- the current semantic unit. if No (Finalization_Master (PtrT)) then - Build_Finalization_Master - (Typ => PtrT, - Ins_Node => Current_Unit_First_Declaration, - Encl_Scope => Current_Unit_Scope); + Set_Finalization_Master (PtrT, Current_Anonymous_Master); end if; end if; diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 47af37ff649..9362d7df610 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -2985,7 +2985,7 @@ package body Exp_Ch5 is -- If "reverse" is present, then the initialization of the cursor -- uses Last and the step becomes Prev. Pack is the name of the - -- package which instantiates the container. + -- scope where the container package is instantiated. declare Element_Type : constant Entity_Id := Etype (Id); @@ -3007,13 +3007,23 @@ package body Exp_Ch5 is -- use-visible, so we introduce the name of the enclosing package -- in the declarations below. The Iterator type is declared in a -- an instance within the container package itself. + -- If the container type is a derived type, the cursor type is + -- found in the package of the parent type. Iter_Type := Etype (Name (I_Spec)); if Is_Iterator (Iter_Type) then - Pack := Scope (Scope (Etype (Container))); + if Is_Derived_Type (Container_Typ) then + Pack := Scope (Scope (Root_Type (Container_Typ))); + else + Pack := Scope (Scope (Container_Typ)); + end if; else - Pack := Scope (Etype (Container)); + if Is_Derived_Type (Container_Typ) then + Pack := Scope (Root_Type (Container_Typ)); + else + Pack := Scope (Container_Typ); + end if; end if; -- The "of" case uses an internally generated cursor whose type @@ -3128,7 +3138,7 @@ package body Exp_Ch5 is end; -- X in Iterate (S) : type of iterator is type of explicitly - -- given Iterate function. + -- given Iterate function, and the loop variable is the cursor. else Cursor := Id; diff --git a/gcc/ada/prj-attr.adb b/gcc/ada/prj-attr.adb index f8084619d89..4dad66d0213 100644 --- a/gcc/ada/prj-attr.adb +++ b/gcc/ada/prj-attr.adb @@ -190,7 +190,7 @@ package body Prj.Attr is "Latrailing_required_switches#" & "Lapic_option#" & "Sapath_syntax#" & - "Sasource_file_switches#" & + "Lasource_file_switches#" & "Saobject_file_suffix#" & "Laobject_file_switches#" & "Lamulti_unit_switches#" & diff --git a/gcc/ada/s-taprop-linux.adb b/gcc/ada/s-taprop-linux.adb index a47e4b1a0a0..2b4f54021c4 100644 --- a/gcc/ada/s-taprop-linux.adb +++ b/gcc/ada/s-taprop-linux.adb @@ -880,7 +880,16 @@ package body System.Task_Primitives.Operations is -- Handle dispatching domains - elsif T.Common.Domain /= null then + -- To avoid changing CPU affinities when not needed, we set the + -- affinity only when assigning to a domain other than the default + -- one, or when the default one has been modified. + + elsif T.Common.Domain /= null and then + (T.Common.Domain /= ST.System_Domain + or else T.Common.Domain.all /= + (Multiprocessors.CPU'First .. + Multiprocessors.Number_Of_CPUs => True)) + then declare CPU_Set : aliased cpu_set_t := (bits => (others => False)); diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 34df78348c6..2745389599a 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -6638,7 +6638,7 @@ package body Sem_Ch4 is Call : Node_Id; Subp : Entity_Id) return Entity_Id; -- If the subprogram is a valid interpretation, record it, and add - -- to the list of interpretations of Subprog. + -- to the list of interpretations of Subprog. Otherwise return Empty. procedure Complete_Object_Operation (Call_Node : Node_Id; @@ -7104,6 +7104,14 @@ package body Sem_Ch4 is and then N = Name (Parent (N)) then goto Next_Hom; + + -- If the context is a function call, ignore procedures + -- in the name of the call. + + elsif Ekind (Hom) = E_Procedure + and then Nkind (Parent (N)) /= N_Procedure_Call_Statement + then + goto Next_Hom; end if; Set_Etype (Call_Node, Any_Type); @@ -7271,16 +7279,39 @@ package body Sem_Ch4 is return; end if; - if Try_Primitive_Operation - (Call_Node => New_Call_Node, - Node_To_Replace => Node_To_Replace) - or else - Try_Class_Wide_Operation - (Call_Node => New_Call_Node, - Node_To_Replace => Node_To_Replace) - then - null; - end if; + declare + Dup_Call_Node : constant Node_Id := New_Copy (New_Call_Node); + CW_Result : Boolean; + Prim_Result : Boolean; + pragma Unreferenced (CW_Result); + + begin + Prim_Result := + Try_Primitive_Operation + (Call_Node => New_Call_Node, + Node_To_Replace => Node_To_Replace); + + -- Check if there is a class-wide subprogram covering the + -- primitive. This check must be done even if a candidate + -- was found in order to report ambiguous calls. + + if not (Prim_Result) then + CW_Result := + Try_Class_Wide_Operation + (Call_Node => New_Call_Node, + Node_To_Replace => Node_To_Replace); + + -- If we found a primitive we search for class-wide subprograms + -- using a duplicate of the call node (done to avoid missing its + -- decoration if there is no ambiguity). + + else + CW_Result := + Try_Class_Wide_Operation + (Call_Node => Dup_Call_Node, + Node_To_Replace => Node_To_Replace); + end if; + end; end Try_One_Prefix_Interpretation; ----------------------------- diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb index 7e0da64df67..7e64d98cd67 100644 --- a/gcc/ada/sem_disp.adb +++ b/gcc/ada/sem_disp.adb @@ -2262,6 +2262,14 @@ package body Sem_Disp is then return; + -- When expansion is suppressed, an unexpanded call to 'Input can occur, + -- and in that case we can simply return. + + elsif Nkind (Actual) = N_Attribute_Reference then + pragma Assert (Attribute_Name (Actual) = Name_Input); + + return; + -- Only other possibilities are parenthesized or qualified expression, -- or an expander-generated unchecked conversion of a function call to -- a stream Input attribute. diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 15feb5bc61e..3fe07196a45 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -1725,7 +1725,7 @@ package body Sem_Res is -- Start of processing for Replace_Actual_Discriminants begin - if not Expander_Active then + if not Full_Expander_Active then return; end if; @@ -1970,7 +1970,7 @@ package body Sem_Res is if (Attr = Attribute_Access or else Attr = Attribute_Unchecked_Access or else Attr = Attribute_Unrestricted_Access) - and then Expander_Active + and then Full_Expander_Active and then Get_PCS_Name /= Name_No_DSA then Check_Subtype_Conformant @@ -6833,7 +6833,7 @@ package body Sem_Res is -- Why the Expander_Active test here ??? - if Expander_Active + if Full_Expander_Active and then (Ekind_In (T, E_Anonymous_Access_Type, E_Anonymous_Access_Subprogram_Type) @@ -7148,7 +7148,7 @@ package body Sem_Res is -- We must preserve the original entity in a generic setting, so that -- the legality of the operation can be verified in an instance. - if not Expander_Active then + if not Full_Expander_Active then return; end if; @@ -8197,7 +8197,7 @@ package body Sem_Res is -- transformation while analyzing generic units, as type information -- would be lost when reanalyzing the constant node in the instance. - if Is_Discrete_Type (Typ) and then Expander_Active then + if Is_Discrete_Type (Typ) and then Full_Expander_Active then if Is_OK_Static_Expression (L) then Fold_Uint (L, Expr_Value (L), Is_Static_Expression (L)); end if; @@ -9345,7 +9345,7 @@ package body Sem_Res is -- expression coincides with the target type. if Ada_Version >= Ada_2005 - and then Expander_Active + and then Full_Expander_Active and then Operand_Typ /= Target_Typ then declare @@ -9844,7 +9844,7 @@ package body Sem_Res is -- premature (e.g. if the slice is within a transient scope). This needs -- to be done only if expansion is enabled. - elsif Expander_Active then + elsif Full_Expander_Active then Ensure_Defined (Typ => Slice_Subtype, N => N); end if; end Set_Slice_Subtype; |