diff options
Diffstat (limited to 'gcc/ada/sem_util.adb')
| -rw-r--r-- | gcc/ada/sem_util.adb | 101 |
1 files changed, 60 insertions, 41 deletions
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 74de26a..b2b4fed 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -35,6 +35,7 @@ with Exp_Ch11; use Exp_Ch11; with Exp_Util; use Exp_Util; with Fname; use Fname; with Freeze; use Freeze; +with Ghost; use Ghost; with Itypes; use Itypes; with Lib; use Lib; with Lib.Xref; use Lib.Xref; @@ -1923,6 +1924,10 @@ package body Sem_Util is -- Build_Elaboration_Entity -- ------------------------------ + -- WARNING: This routine manages Ghost regions. Return statements must be + -- replaced by gotos which jump to the end of the routine and restore the + -- Ghost mode. + procedure Build_Elaboration_Entity (N : Node_Id; Spec_Id : Entity_Id) is Loc : constant Source_Ptr := Sloc (N); Decl : Node_Id; @@ -1956,6 +1961,12 @@ package body Sem_Util is end if; end Set_Package_Name; + -- Local variables + + Saved_GM : constant Ghost_Mode_Type := Ghost_Mode; + Saved_IGR : constant Node_Id := Ignored_Ghost_Region; + -- Save the Ghost-related attributes to restore on exit + -- Start of processing for Build_Elaboration_Entity begin @@ -2003,6 +2014,11 @@ package body Sem_Util is return; end if; + -- Elaboration entity is never a ghost object, regardless of the context + -- in which this routine is called. + + Install_Ghost_Region (None, N); + -- Here we need the elaboration entity -- Construct name of elaboration entity as xxx_E, where xxx is the unit @@ -2043,6 +2059,8 @@ package body Sem_Util is Set_Has_Qualified_Name (Elab_Ent); Set_Has_Fully_Qualified_Name (Elab_Ent); + + Restore_Ghost_Region (Saved_GM, Saved_IGR); end Build_Elaboration_Entity; -------------------------------- @@ -3688,6 +3706,7 @@ package body Sem_Util is Aspect_Aggregate, Aspect_Max_Entry_Queue_Length -- , Aspect_No_Controlled_Parts + -- , Aspect_No_Task_Parts ); -- Note that none of these 8 aspects can be specified (for a type) @@ -10043,16 +10062,19 @@ package body Sem_Util is and then not Has_Unknown_Discriminants (Utyp) and then not (Ekind (Utyp) = E_String_Literal_Subtype) then - -- Nothing to do if in spec expression (why not???) + -- If the type has no discriminants, there is no subtype to build, + -- even if the underlying type is discriminated. - if In_Spec_Expression then + if Is_Private_Type (Typ) and then not Has_Discriminants (Typ) then return Typ; - elsif Is_Private_Type (Typ) and then not Has_Discriminants (Typ) then - - -- If the type has no discriminants, there is no subtype to - -- build, even if the underlying type is discriminated. + -- If we are performing preanalysis on a conjured-up copy of a name + -- (see calls to Preanalyze_Range in sem_ch5.adb) then we don't want + -- to freeze Atyp, now or ever. In this case, the tree we eventually + -- pass to the back end should contain no references to Atyp (and a + -- freeze node would contain such a reference). + elsif not (Expander_Active or GNATprove_Mode) then return Typ; -- Else build the actual subtype @@ -10068,42 +10090,21 @@ package body Sem_Util is Atyp := Defining_Identifier (Decl); - -- If Build_Actual_Subtype generated a new declaration then use it - - if Atyp /= Typ then - - -- The actual subtype is an Itype, so analyze the declaration, - -- but do not attach it to the tree, to get the type defined. - - Set_Parent (Decl, N); - Set_Is_Itype (Atyp); - Analyze (Decl, Suppress => All_Checks); - Set_Associated_Node_For_Itype (Atyp, N); - if Expander_Active then - Set_Has_Delayed_Freeze (Atyp, False); - - -- We need to freeze the actual subtype immediately. This is - -- needed because otherwise this Itype will not get frozen - -- at all; it is always safe to freeze on creation because - -- any associated types must be frozen at this point. + -- The actual subtype is an Itype, so analyze the declaration + -- after attaching it to the tree, to get the type defined. - -- On the other hand, if we are performing preanalysis on - -- a conjured-up copy of a name (see calls to - -- Preanalyze_Range in sem_ch5.adb) then we don't want - -- to freeze Atyp, now or ever. In this case, the tree - -- we eventually pass to the back end should contain no - -- references to Atyp (and a freeze node would contain - -- such a reference). That's why Expander_Active is tested. + Set_Parent (Decl, N); + Set_Is_Itype (Atyp); + Analyze (Decl, Suppress => All_Checks); + Set_Associated_Node_For_Itype (Atyp, N); - Freeze_Itype (Atyp, N); - end if; - return Atyp; - - -- Otherwise we did not build a declaration, so return original + -- We need to freeze the actual subtype immediately. This is + -- needed because otherwise this Itype will not get frozen + -- at all; it is always safe to freeze on creation because + -- any associated types must be frozen at this point. - else - return Typ; - end if; + Freeze_Itype (Atyp, N); + return Atyp; end if; -- For all remaining cases, the actual subtype is the same as @@ -15017,6 +15018,7 @@ package body Sem_Util is | Aspect_Iterator_Element | Aspect_Max_Entry_Queue_Length | Aspect_No_Controlled_Parts + | Aspect_No_Task_Parts => return; end case; @@ -16276,8 +16278,9 @@ package body Sem_Util is Names_Match (Assign_Indexed_1, Assign_Indexed_2); end; - -- Checking for this aspect is performed elsewhere during freezing - when Aspect_No_Controlled_Parts => + -- Checking for these aspects is performed elsewhere during freezing + when Aspect_No_Controlled_Parts + | Aspect_No_Task_Parts => return True; -- scalar-valued aspects; compare (static) values. @@ -21373,6 +21376,18 @@ package body Sem_Util is return False; end Is_Unchecked_Conversion_Instance; + --------------------------------- + -- Is_Unchecked_Union_Equality -- + --------------------------------- + + function Is_Unchecked_Union_Equality (Id : Entity_Id) return Boolean is + begin + return Ekind (Id) = E_Function + and then Present (First_Formal (Id)) + and then Is_Unchecked_Union (Etype (First_Formal (Id))) + and then Id = TSS (Etype (First_Formal (Id)), TSS_Composite_Equality); + end Is_Unchecked_Union_Equality; + ------------------------------- -- Is_Universal_Numeric_Type -- ------------------------------- @@ -26955,6 +26970,10 @@ package body Sem_Util is if Has_Relaxed_Finalization (From_Typ) then Set_Has_Relaxed_Finalization (Typ); end if; + + if Deriv and then Has_Destructor (From_Typ) then + Set_Has_Destructor (Typ); + end if; end Propagate_Controlled_Flags; ------------------------------ |