diff options
Diffstat (limited to 'gcc/ada/sem_util.adb')
| -rw-r--r-- | gcc/ada/sem_util.adb | 188 |
1 files changed, 57 insertions, 131 deletions
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 4e6fef5..5c1368e 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -26,6 +26,7 @@ with Casing; use Casing; with Checks; use Checks; with Debug; use Debug; +with Einfo.Utils; use Einfo.Utils; with Elists; use Elists; with Errout; use Errout; with Erroutc; use Erroutc; @@ -58,7 +59,9 @@ with Sem_Prag; use Sem_Prag; with Sem_Res; use Sem_Res; with Sem_Warn; use Sem_Warn; with Sem_Type; use Sem_Type; -with Sinfo; use Sinfo; +with Sinfo; use Sinfo; +with Sinfo.Nodes; use Sinfo.Nodes; +with Sinfo.Utils; use Sinfo.Utils; with Sinput; use Sinput; with Stand; use Stand; with Style; @@ -6471,7 +6474,6 @@ package body Sem_Util is Remove (Op_List, Node (Second)); else - pragma Assert (False); raise Program_Error; end if; end if; @@ -13872,7 +13874,7 @@ package body Sem_Util is elsif Is_Record_Type (Typ) then Comp := First_Component (Typ); while Present (Comp) loop - if Is_Volatile_Object (Comp) then + if Is_Volatile_Object_Ref (Comp) then return True; end if; @@ -17225,7 +17227,8 @@ package body Sem_Util is function Is_Full_Access_Object (N : Node_Id) return Boolean is begin - return Is_Atomic_Object (N) or else Is_Volatile_Full_Access_Object (N); + return Is_Atomic_Object (N) + or else Is_Volatile_Full_Access_Object_Ref (N); end Is_Full_Access_Object; ------------------------------- @@ -20955,11 +20958,11 @@ package body Sem_Util is and then Scope (Scope (Scope (Root))) = Standard_Standard; end Is_Visibly_Controlled; - -------------------------------------- - -- Is_Volatile_Full_Access_Object -- - -------------------------------------- + ---------------------------------------- + -- Is_Volatile_Full_Access_Object_Ref -- + ---------------------------------------- - function Is_Volatile_Full_Access_Object (N : Node_Id) return Boolean is + function Is_Volatile_Full_Access_Object_Ref (N : Node_Id) return Boolean is function Is_VFA_Object_Entity (Id : Entity_Id) return Boolean; -- Determine whether arbitrary entity Id denotes an object that is -- Volatile_Full_Access. @@ -20977,7 +20980,7 @@ package body Sem_Util is Is_Volatile_Full_Access (Etype (Id))); end Is_VFA_Object_Entity; - -- Start of processing for Is_Volatile_Full_Access_Object + -- Start of processing for Is_Volatile_Full_Access_Object_Ref begin if Is_Entity_Name (N) then @@ -20992,7 +20995,7 @@ package body Sem_Util is else return False; end if; - end Is_Volatile_Full_Access_Object; + end Is_Volatile_Full_Access_Object_Ref; -------------------------- -- Is_Volatile_Function -- @@ -21024,11 +21027,11 @@ package body Sem_Util is end if; end Is_Volatile_Function; - ------------------------ - -- Is_Volatile_Object -- - ------------------------ + ---------------------------- + -- Is_Volatile_Object_Ref -- + ---------------------------- - function Is_Volatile_Object (N : Node_Id) return Boolean is + function Is_Volatile_Object_Ref (N : Node_Id) return Boolean is function Is_Volatile_Object_Entity (Id : Entity_Id) return Boolean; -- Determine whether arbitrary entity Id denotes an object that is -- Volatile. @@ -21074,7 +21077,7 @@ package body Sem_Util is then return True; - elsif Is_Volatile_Object (P) then + elsif Is_Volatile_Object_Ref (P) then return True; else @@ -21082,7 +21085,7 @@ package body Sem_Util is end if; end Prefix_Has_Volatile_Components; - -- Start of processing for Is_Volatile_Object + -- Start of processing for Is_Volatile_Object_Ref begin if Is_Entity_Name (N) then @@ -21101,7 +21104,7 @@ package body Sem_Util is else return False; end if; - end Is_Volatile_Object; + end Is_Volatile_Object_Ref; ----------------------------- -- Iterate_Call_Parameters -- @@ -22900,9 +22903,6 @@ package body Sem_Util is -- This routine performs low-level tree manipulations and needs access -- to the internals of the tree. - use Atree.Unchecked_Access; - use Atree_Private_Part; - EWA_Level : Nat := 0; -- This counter keeps track of how many N_Expression_With_Actions nodes -- are encountered during a depth-first traversal of the subtree. These @@ -23054,6 +23054,7 @@ package body Sem_Util is -- valid syntactic fields. Par_Nod is the expected parent of the -- syntactic field. Flag Semantic should be set when the input is a -- semantic field. + -- ????So it's visiting sem fields twice? procedure Visit_Itype (Itype : Entity_Id); -- Visit itype Itype. This action may create a new entity for Itype and @@ -23444,6 +23445,25 @@ package body Sem_Util is function Copy_Node_With_Replacement (N : Node_Id) return Node_Id is Result : Node_Id; + function Transform (U : Union_Id) return Union_Id; + -- Copies one field, replacing N with Result + + --------------- + -- Transform -- + --------------- + + function Transform (U : Union_Id) return Union_Id is + begin + return Copy_Field_With_Replacement + (Field => U, + Old_Par => N, + New_Par => Result); + end Transform; + + procedure Walk is new Walk_Sinfo_Fields_Pairwise (Transform); + + -- Start of processing for Copy_Node_With_Replacement + begin -- Assume that the node must be returned unchanged @@ -23454,35 +23474,7 @@ package body Sem_Util is Result := New_Copy (N); - Set_Field1 (Result, - Copy_Field_With_Replacement - (Field => Field1 (Result), - Old_Par => N, - New_Par => Result)); - - Set_Field2 (Result, - Copy_Field_With_Replacement - (Field => Field2 (Result), - Old_Par => N, - New_Par => Result)); - - Set_Field3 (Result, - Copy_Field_With_Replacement - (Field => Field3 (Result), - Old_Par => N, - New_Par => Result)); - - Set_Field4 (Result, - Copy_Field_With_Replacement - (Field => Field4 (Result), - Old_Par => N, - New_Par => Result)); - - Set_Field5 (Result, - Copy_Field_With_Replacement - (Field => Field5 (Result), - Old_Par => N, - New_Par => Result)); + Walk (Result, Result); -- Update the Comes_From_Source and Sloc attributes of the node -- in case the caller has supplied new values. @@ -23622,7 +23614,7 @@ package body Sem_Util is -- A new source location defaults the Comes_From_Source attribute if New_Sloc /= No_Location then - Set_Comes_From_Source (N, Default_Node.Comes_From_Source); + Set_Comes_From_Source (N, Get_Comes_From_Source_Default); Set_Sloc (N, New_Sloc); end if; end Update_CFS_Sloc; @@ -24229,25 +24221,17 @@ package body Sem_Util is EWA_Inner_Scope_Level := EWA_Inner_Scope_Level + 1; end if; - Visit_Field - (Field => Field1 (N), - Par_Nod => N); - - Visit_Field - (Field => Field2 (N), - Par_Nod => N); - - Visit_Field - (Field => Field3 (N), - Par_Nod => N); - - Visit_Field - (Field => Field4 (N), - Par_Nod => N); + declare + procedure Action (U : Union_Id); + procedure Action (U : Union_Id) is + begin + Visit_Field (Field => U, Par_Nod => N); + end Action; - Visit_Field - (Field => Field5 (N), - Par_Nod => N); + procedure Walk is new Walk_Sinfo_Fields (Action); + begin + Walk (N); + end; if EWA_Level > 0 and then Nkind (N) in N_Block_Statement @@ -26181,14 +26165,16 @@ package body Sem_Util is Partial_DIC_Proc := Partial_DIC_Procedure (From_Typ); -- The setting of the attributes is intentionally conservative. This - -- prevents accidental clobbering of enabled attributes. + -- prevents accidental clobbering of enabled attributes. We need to + -- call Base_Type twice, because it is sometimes not set to an actual + -- base type. if Has_Inherited_DIC (From_Typ) then - Set_Has_Inherited_DIC (Typ); + Set_Has_Inherited_DIC (Base_Type (Base_Type (Typ))); end if; if Has_Own_DIC (From_Typ) then - Set_Has_Own_DIC (Typ); + Set_Has_Own_DIC (Base_Type (Base_Type (Typ))); end if; if Present (DIC_Proc) and then No (DIC_Procedure (Typ)) then @@ -27336,66 +27322,6 @@ package body Sem_Util is return False; end Scope_Within_Or_Same; - -------------------- - -- Set_Convention -- - -------------------- - - procedure Set_Convention (E : Entity_Id; Val : Snames.Convention_Id) is - begin - Basic_Set_Convention (E, Val); - - if Is_Type (E) - and then Is_Access_Subprogram_Type (Base_Type (E)) - and then Has_Foreign_Convention (E) - then - Set_Can_Use_Internal_Rep (E, False); - end if; - - -- If E is an object, including a component, and the type of E is an - -- anonymous access type with no convention set, then also set the - -- convention of the anonymous access type. We do not do this for - -- anonymous protected types, since protected types always have the - -- default convention. - - if Present (Etype (E)) - and then (Is_Object (E) - - -- Allow E_Void (happens for pragma Convention appearing - -- in the middle of a record applying to a component) - - or else Ekind (E) = E_Void) - then - declare - Typ : constant Entity_Id := Etype (E); - - begin - if Ekind (Typ) in E_Anonymous_Access_Type - | E_Anonymous_Access_Subprogram_Type - and then not Has_Convention_Pragma (Typ) - then - Basic_Set_Convention (Typ, Val); - Set_Has_Convention_Pragma (Typ); - - -- And for the access subprogram type, deal similarly with the - -- designated E_Subprogram_Type, which is always internal. - - if Ekind (Typ) = E_Anonymous_Access_Subprogram_Type then - declare - Dtype : constant Entity_Id := Designated_Type (Typ); - begin - if Ekind (Dtype) = E_Subprogram_Type - and then not Has_Convention_Pragma (Dtype) - then - Basic_Set_Convention (Dtype, Val); - Set_Has_Convention_Pragma (Dtype); - end if; - end; - end if; - end if; - end; - end if; - end Set_Convention; - ------------------------ -- Set_Current_Entity -- ------------------------ |