diff options
Diffstat (limited to 'gcc/ada/tbuild.adb')
| -rw-r--r-- | gcc/ada/tbuild.adb | 148 |
1 files changed, 79 insertions, 69 deletions
diff --git a/gcc/ada/tbuild.adb b/gcc/ada/tbuild.adb index 3b33ee7..4d9c1c4 100644 --- a/gcc/ada/tbuild.adb +++ b/gcc/ada/tbuild.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2020, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2021, 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- -- @@ -23,22 +23,24 @@ -- -- ------------------------------------------------------------------------------ -with Atree; use Atree; -with Aspects; use Aspects; -with Csets; use Csets; -with Einfo; use Einfo; -with Elists; use Elists; -with Lib; use Lib; -with Nlists; use Nlists; -with Nmake; use Nmake; -with Opt; use Opt; -with Restrict; use Restrict; -with Rident; use Rident; -with Sem_Aux; use Sem_Aux; -with Snames; use Snames; -with Stand; use Stand; -with Stringt; use Stringt; -with Urealp; use Urealp; +with Atree; use Atree; +with Aspects; use Aspects; +with Csets; use Csets; +with Einfo; use Einfo; +with Einfo.Entities; use Einfo.Entities; +with Einfo.Utils; use Einfo.Utils; +with Lib; use Lib; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Opt; use Opt; +with Restrict; use Restrict; +with Rident; use Rident; +with Sinfo.Utils; use Sinfo.Utils; +with Sem_Util; use Sem_Util; +with Snames; use Snames; +with Stand; use Stand; +with Stringt; use Stringt; +with Urealp; use Urealp; package body Tbuild is @@ -113,6 +115,7 @@ package body Tbuild is ---------------- function Convert_To (Typ : Entity_Id; Expr : Node_Id) return Node_Id is + pragma Assert (Is_Type (Typ)); Result : Node_Id; begin @@ -181,32 +184,6 @@ package body Tbuild is return N; end Make_Byte_Aligned_Attribute_Reference; - -------------------- - -- Make_DT_Access -- - -------------------- - - function Make_DT_Access - (Loc : Source_Ptr; - Rec : Node_Id; - Typ : Entity_Id) return Node_Id - is - Full_Type : Entity_Id := Typ; - - begin - if Is_Private_Type (Typ) then - Full_Type := Underlying_Type (Typ); - end if; - - return - Unchecked_Convert_To ( - New_Occurrence_Of - (Etype (Node (First_Elmt (Access_Disp_Table (Full_Type)))), Loc), - Make_Selected_Component (Loc, - Prefix => New_Copy (Rec), - Selector_Name => - New_Occurrence_Of (First_Tag_Component (Full_Type), Loc))); - end Make_DT_Access; - ------------------------ -- Make_Float_Literal -- ------------------------ @@ -348,14 +325,42 @@ package body Tbuild is Has_Created_Identifier : Boolean := False; End_Label : Node_Id := Empty) return Node_Id is - begin - Check_Restriction (No_Implicit_Loops, Node); + P : Node_Id; + Check_Restrictions : Boolean := True; + begin + -- Do not check restrictions if the implicit loop statement is part + -- of a dead branch: False and then ... + -- This will occur in particular as part of the expansion of pragma + -- Assert when assertions are disabled. + + P := Parent (Node); + while Present (P) loop + if Nkind (P) = N_And_Then then + if Nkind (Left_Opnd (P)) = N_Identifier + and then Entity (Left_Opnd (P)) = Standard_False + then + Check_Restrictions := False; + exit; + end if; - if Present (Iteration_Scheme) - and then Nkind (Iteration_Scheme) /= N_Iterator_Specification - and then Present (Condition (Iteration_Scheme)) - then - Check_Restriction (No_Implicit_Conditionals, Node); + -- Prevent the search from going too far + + elsif Is_Body_Or_Package_Declaration (P) then + exit; + end if; + + P := Parent (P); + end loop; + + if Check_Restrictions then + Check_Restriction (No_Implicit_Loops, Node); + + if Present (Iteration_Scheme) + and then Nkind (Iteration_Scheme) /= N_Iterator_Specification + and then Present (Condition (Iteration_Scheme)) + then + Check_Restriction (No_Implicit_Conditionals, Node); + end if; end if; return Make_Loop_Statement (Sloc (Node), @@ -874,26 +879,34 @@ package body Tbuild is (Typ : Entity_Id; Expr : Node_Id) return Node_Id is + pragma Assert (Ekind (Typ) in E_Void | Type_Kind); + -- We don't really want to allow E_Void here, but existing code passes + -- it. + Loc : constant Source_Ptr := Sloc (Expr); Result : Node_Id; - Expr_Parent : Node_Id; begin -- If the expression is already of the correct type, then nothing - -- to do, except for relocating the node in case this is required. + -- to do, except for relocating the node if Present (Etype (Expr)) - and then (Base_Type (Etype (Expr)) = Typ - or else Etype (Expr) = Typ) + and then (Base_Type (Etype (Expr)) = Typ or else Etype (Expr) = Typ) then return Relocate_Node (Expr); - -- Case where the expression is itself an unchecked conversion to - -- the same type, and we can thus eliminate the outer conversion. + -- Case where the expression is already an unchecked conversion. We + -- replace the type being converted to, to avoid creating an unchecked + -- conversion of an unchecked conversion. Extra unchecked conversions + -- make the .dg output less readable. We can't do this in cases + -- involving bitfields, because the sizes might not match. The + -- Is_Composite_Type checks avoid such cases. elsif Nkind (Expr) = N_Unchecked_Type_Conversion - and then Entity (Subtype_Mark (Expr)) = Typ + and then Is_Composite_Type (Etype (Expr)) + and then Is_Composite_Type (Typ) then + Set_Subtype_Mark (Expr, New_Occurrence_Of (Typ, Loc)); Result := Relocate_Node (Expr); elsif Nkind (Expr) = N_Null @@ -906,18 +919,15 @@ package body Tbuild is -- All other cases else - -- Capture the parent of the expression before relocating it and - -- creating the conversion, so the conversion's parent can be set - -- to the original parent below. - - Expr_Parent := Parent (Expr); - - Result := - Make_Unchecked_Type_Conversion (Loc, - Subtype_Mark => New_Occurrence_Of (Typ, Loc), - Expression => Relocate_Node (Expr)); - - Set_Parent (Result, Expr_Parent); + declare + Expr_Parent : constant Node_Id := Parent (Expr); + begin + Result := + Make_Unchecked_Type_Conversion (Loc, + Subtype_Mark => New_Occurrence_Of (Typ, Loc), + Expression => Relocate_Node (Expr)); + Set_Parent (Result, Expr_Parent); + end; end if; Set_Etype (Result, Typ); |