diff options
Diffstat (limited to 'gcc/ada/sem_aux.adb')
| -rw-r--r-- | gcc/ada/sem_aux.adb | 163 |
1 files changed, 120 insertions, 43 deletions
diff --git a/gcc/ada/sem_aux.adb b/gcc/ada/sem_aux.adb index 3c5d2af59ba..d67517e2ceb 100644 --- a/gcc/ada/sem_aux.adb +++ b/gcc/ada/sem_aux.adb @@ -91,7 +91,7 @@ package body Sem_Aux is elsif Is_Class_Wide_Type (Typ) and then Is_Incomplete_Type (Etype (Typ)) - and then From_With_Type (Etype (Typ)) + and then From_Limited_With (Etype (Typ)) and then Present (Non_Limited_View (Etype (Typ))) then return Class_Wide_Type (Non_Limited_View (Etype (Typ))); @@ -865,48 +865,6 @@ package body Sem_Aux is elsif Is_Concurrent_Type (Btype) then return True; - elsif Is_Record_Type (Btype) then - - -- Note that we return True for all limited interfaces, even though - -- (unsynchronized) limited interfaces can have descendants that are - -- nonlimited, because this is a predicate on the type itself, and - -- things like functions with limited interface results need to be - -- handled as build in place even though they might return objects - -- of a type that is not inherently limited. - - if Is_Class_Wide_Type (Btype) then - return Is_Immutably_Limited_Type (Root_Type (Btype)); - - else - declare - C : Entity_Id; - - begin - C := First_Component (Btype); - while Present (C) loop - - -- Don't consider components with interface types (which can - -- only occur in the case of a _parent component anyway). - -- They don't have any components, plus it would cause this - -- function to return true for nonlimited types derived from - -- limited interfaces. - - if not Is_Interface (Etype (C)) - and then Is_Immutably_Limited_Type (Etype (C)) - then - return True; - end if; - - C := Next_Component (C); - end loop; - end; - - return False; - end if; - - elsif Is_Array_Type (Btype) then - return Is_Immutably_Limited_Type (Component_Type (Btype)); - else return False; end if; @@ -1024,6 +982,105 @@ package body Sem_Aux is end if; end Is_Limited_Type; + --------------------- + -- Is_Limited_View -- + --------------------- + + function Is_Limited_View (Ent : Entity_Id) return Boolean is + Btype : constant Entity_Id := Available_View (Base_Type (Ent)); + + begin + if Is_Limited_Record (Btype) then + return True; + + elsif Ekind (Btype) = E_Limited_Private_Type + and then Nkind (Parent (Btype)) = N_Formal_Type_Declaration + then + return not In_Package_Body (Scope ((Btype))); + + elsif Is_Private_Type (Btype) then + + -- AI05-0063: A type derived from a limited private formal type is + -- not immutably limited in a generic body. + + if Is_Derived_Type (Btype) + and then Is_Generic_Type (Etype (Btype)) + then + if not Is_Limited_Type (Etype (Btype)) then + return False; + + -- A descendant of a limited formal type is not immutably limited + -- in the generic body, or in the body of a generic child. + + elsif Ekind (Scope (Etype (Btype))) = E_Generic_Package then + return not In_Package_Body (Scope (Btype)); + + else + return False; + end if; + + else + declare + Utyp : constant Entity_Id := Underlying_Type (Btype); + begin + if No (Utyp) then + return False; + else + return Is_Limited_View (Utyp); + end if; + end; + end if; + + elsif Is_Concurrent_Type (Btype) then + return True; + + elsif Is_Record_Type (Btype) then + + -- Note that we return True for all limited interfaces, even though + -- (unsynchronized) limited interfaces can have descendants that are + -- nonlimited, because this is a predicate on the type itself, and + -- things like functions with limited interface results need to be + -- handled as build in place even though they might return objects + -- of a type that is not inherently limited. + + if Is_Class_Wide_Type (Btype) then + return Is_Limited_View (Root_Type (Btype)); + + else + declare + C : Entity_Id; + + begin + C := First_Component (Btype); + while Present (C) loop + + -- Don't consider components with interface types (which can + -- only occur in the case of a _parent component anyway). + -- They don't have any components, plus it would cause this + -- function to return true for nonlimited types derived from + -- limited interfaces. + + if not Is_Interface (Etype (C)) + and then Is_Limited_View (Etype (C)) + then + return True; + end if; + + C := Next_Component (C); + end loop; + end; + + return False; + end if; + + elsif Is_Array_Type (Btype) then + return Is_Limited_View (Component_Type (Btype)); + + else + return False; + end if; + end Is_Limited_View; + ---------------------- -- Nearest_Ancestor -- ---------------------- @@ -1151,6 +1208,26 @@ package body Sem_Aux is and then Has_Discriminants (Typ)); end Object_Type_Has_Constrained_Partial_View; + --------------------------- + -- Package_Specification -- + --------------------------- + + function Package_Specification (Pack_Id : Entity_Id) return Node_Id is + N : Node_Id; + + begin + N := Parent (Pack_Id); + while Nkind (N) /= N_Package_Specification loop + N := Parent (N); + + if No (N) then + raise Program_Error; + end if; + end loop; + + return N; + end Package_Specification; + --------------- -- Tree_Read -- --------------- |