From 0fbcb11c6251ed09ef715f9552e27321059cef35 Mon Sep 17 00:00:00 2001 From: Ed Schonberg Date: Tue, 23 Apr 2013 09:58:23 +0000 Subject: [PATCH] sem_aux.adb [...] (Effectively_has_Constrained_Partial_View): Rename subprogram as Object_Type_Has_Constrained_Partial_View... 2013-04-23 Ed Schonberg * sem_aux.adb sem_aux.ads (Effectively_has_Constrained_Partial_View): Rename subprogram as Object_Type_Has_Constrained_Partial_View, better description of purpose. * checks.adb (Apply_Discriminant_Check): Use above renaming. * sem_ch4.adb (Analyze_Allocator): Check Has_Constrained_Partial_View of the base type, rather than using the Object_Type predicate. * sem_attr.adb (Analyze_Attribute, case 'Access): Use above renaming. * sem_util.adb (Is_Dependent_Component_Of_Mutable_Object): ditto. * exp_attr.adb (Expand_N_Attribute_Reference, case 'Constrained): Ditto. * exp_ch4.adb (Expand_N_Allocator): Ditto. From-SVN: r198188 --- gcc/ada/ChangeLog | 13 ++++ gcc/ada/checks.adb | 2 +- gcc/ada/exp_attr.adb | 4 +- gcc/ada/exp_ch4.adb | 5 +- gcc/ada/sem_attr.adb | 2 +- gcc/ada/sem_aux.adb | 140 +++++++++++++++++++++---------------------- gcc/ada/sem_aux.ads | 29 ++++----- gcc/ada/sem_ch4.adb | 4 +- gcc/ada/sem_util.adb | 2 +- 9 files changed, 106 insertions(+), 95 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 4bdf9e6d747..793b02e7fde 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,16 @@ +2013-04-23 Ed Schonberg + + * sem_aux.adb sem_aux.ads (Effectively_has_Constrained_Partial_View): + Rename subprogram as Object_Type_Has_Constrained_Partial_View, better + description of purpose. + * checks.adb (Apply_Discriminant_Check): Use above renaming. + * sem_ch4.adb (Analyze_Allocator): Check Has_Constrained_Partial_View + of the base type, rather than using the Object_Type predicate. + * sem_attr.adb (Analyze_Attribute, case 'Access): Use above renaming. + * sem_util.adb (Is_Dependent_Component_Of_Mutable_Object): ditto. + * exp_attr.adb (Expand_N_Attribute_Reference, case 'Constrained): Ditto. + * exp_ch4.adb (Expand_N_Allocator): Ditto. + 2013-04-23 Robert Dewar * exp_prag.adb (Expand_Pragma_Check): Check for Assert rather diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 73aefb0698c..964aed59fe8 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -1479,7 +1479,7 @@ package body Checks is -- partial view that is constrained. elsif Ada_Version >= Ada_2005 - and then Effectively_Has_Constrained_Partial_View + and then Object_Type_Has_Constrained_Partial_View (Typ => Base_Type (T_Typ), Scop => Current_Scope) then diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index a55a32ccd7b..832d182414d 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -1791,7 +1791,7 @@ package body Exp_Attr is or else (Nkind (Obj) = N_Explicit_Dereference and then - not Effectively_Has_Constrained_Partial_View + not Object_Type_Has_Constrained_Partial_View (Typ => Base_Type (Etype (Obj)), Scop => Current_Scope))); end if; @@ -1915,7 +1915,7 @@ package body Exp_Attr is or else (Nkind (Pref) = N_Explicit_Dereference and then - not Effectively_Has_Constrained_Partial_View + not Object_Type_Has_Constrained_Partial_View (Typ => Base_Type (Ptyp), Scop => Current_Scope)) or else Is_Constrained (Underlying_Type (Ptyp)) diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 31c689e232b..76bf939898b 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -4673,9 +4673,8 @@ package body Exp_Ch4 is (First_Discriminant (Typ))) and then (Ada_Version < Ada_2005 or else not - Effectively_Has_Constrained_Partial_View - (Typ => Typ, - Scop => Current_Scope)) + Object_Type_Has_Constrained_Partial_View + (Typ, Current_Scope)) then Typ := Build_Default_Subtype (Typ, N); Set_Expression (N, New_Reference_To (Typ, Loc)); diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 974a57bcaed..f7fccfb031b 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -9530,7 +9530,7 @@ package body Sem_Attr is and then (Ada_Version < Ada_2005 or else - not Effectively_Has_Constrained_Partial_View + not Object_Type_Has_Constrained_Partial_View (Typ => Designated_Type (Base_Type (Typ)), Scop => Current_Scope)) then diff --git a/gcc/ada/sem_aux.adb b/gcc/ada/sem_aux.adb index 556156af08e..23b8f592aa9 100644 --- a/gcc/ada/sem_aux.adb +++ b/gcc/ada/sem_aux.adb @@ -151,25 +151,6 @@ package body Sem_Aux is end if; end Constant_Value; - ---------------------------------------------- - -- Effectively_Has_Constrained_Partial_View -- - ---------------------------------------------- - - function Effectively_Has_Constrained_Partial_View - (Typ : Entity_Id; - Scop : Entity_Id) return Boolean - is - begin - return Has_Constrained_Partial_View (Typ) - or else (In_Generic_Body (Scop) - and then Is_Generic_Type (Base_Type (Typ)) - and then Is_Private_Type (Base_Type (Typ)) - and then not Is_Tagged_Type (Typ) - and then not (Is_Array_Type (Typ) - and then not Is_Constrained (Typ)) - and then Has_Discriminants (Typ)); - end Effectively_Has_Constrained_Partial_View; - ----------------------------- -- Enclosing_Dynamic_Scope -- ----------------------------- @@ -630,25 +611,6 @@ package body Sem_Aux is return Present (Get_Rep_Pragma (E, Nam1, Nam2, Check_Parents)); end Has_Rep_Pragma; - ------------------------------- - -- Initialization_Suppressed -- - ------------------------------- - - function Initialization_Suppressed (Typ : Entity_Id) return Boolean is - begin - return Suppress_Initialization (Typ) - or else Suppress_Initialization (Base_Type (Typ)); - end Initialization_Suppressed; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize is - begin - Obsolescent_Warnings.Init; - end Initialize; - --------------------- -- In_Generic_Body -- --------------------- @@ -686,6 +648,25 @@ package body Sem_Aux is return False; end In_Generic_Body; + ------------------------------- + -- Initialization_Suppressed -- + ------------------------------- + + function Initialization_Suppressed (Typ : Entity_Id) return Boolean is + begin + return Suppress_Initialization (Typ) + or else Suppress_Initialization (Base_Type (Typ)); + end Initialization_Suppressed; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + begin + Obsolescent_Warnings.Init; + end Initialize; + --------------------- -- Is_By_Copy_Type -- --------------------- @@ -828,38 +809,6 @@ package body Sem_Aux is end if; end Is_Generic_Formal; - --------------------------- - -- Is_Indefinite_Subtype -- - --------------------------- - - function Is_Indefinite_Subtype (Ent : Entity_Id) return Boolean is - K : constant Entity_Kind := Ekind (Ent); - - begin - if Is_Constrained (Ent) then - return False; - - elsif K in Array_Kind - or else K in Class_Wide_Kind - or else Has_Unknown_Discriminants (Ent) - then - return True; - - -- Known discriminants: indefinite if there are no default values - - elsif K in Record_Kind - or else Is_Incomplete_Or_Private_Type (Ent) - or else Is_Concurrent_Type (Ent) - then - return (Has_Discriminants (Ent) - and then - No (Discriminant_Default_Value (First_Discriminant (Ent)))); - - else - return False; - end if; - end Is_Indefinite_Subtype; - ------------------------------- -- Is_Immutably_Limited_Type -- ------------------------------- @@ -959,6 +908,38 @@ package body Sem_Aux is end if; end Is_Immutably_Limited_Type; + --------------------------- + -- Is_Indefinite_Subtype -- + --------------------------- + + function Is_Indefinite_Subtype (Ent : Entity_Id) return Boolean is + K : constant Entity_Kind := Ekind (Ent); + + begin + if Is_Constrained (Ent) then + return False; + + elsif K in Array_Kind + or else K in Class_Wide_Kind + or else Has_Unknown_Discriminants (Ent) + then + return True; + + -- Known discriminants: indefinite if there are no default values + + elsif K in Record_Kind + or else Is_Incomplete_Or_Private_Type (Ent) + or else Is_Concurrent_Type (Ent) + then + return (Has_Discriminants (Ent) + and then + No (Discriminant_Default_Value (First_Discriminant (Ent)))); + + else + return False; + end if; + end Is_Indefinite_Subtype; + --------------------- -- Is_Limited_Type -- --------------------- @@ -1147,6 +1128,25 @@ package body Sem_Aux is return N; end Number_Discriminants; + ---------------------------------------------- + -- Object_Type_Has_Constrained_Partial_View -- + ---------------------------------------------- + + function Object_Type_Has_Constrained_Partial_View + (Typ : Entity_Id; + Scop : Entity_Id) return Boolean + is + begin + return Has_Constrained_Partial_View (Typ) + or else (In_Generic_Body (Scop) + and then Is_Generic_Type (Base_Type (Typ)) + and then Is_Private_Type (Base_Type (Typ)) + and then not Is_Tagged_Type (Typ) + and then not (Is_Array_Type (Typ) + and then not Is_Constrained (Typ)) + and then Has_Discriminants (Typ)); + end Object_Type_Has_Constrained_Partial_View; + --------------- -- Tree_Read -- --------------- diff --git a/gcc/ada/sem_aux.ads b/gcc/ada/sem_aux.ads index fafd70f7f45..e7086cc0ecc 100644 --- a/gcc/ada/sem_aux.ads +++ b/gcc/ada/sem_aux.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2013, 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- -- @@ -105,14 +105,6 @@ package Sem_Aux is -- constants from the point of view of constant folding. Empty is also -- returned for variables with no initialization expression. - function Effectively_Has_Constrained_Partial_View - (Typ : Entity_Id; - Scop : Entity_Id) return Boolean; - -- Return True if Typ has attribute Has_Constrained_Partial_View set to - -- True; in addition, within a generic body, return True if a subtype is - -- a descendant of an untagged generic formal private or derived type, and - -- the subtype is not an unconstrained array subtype (RM 3.3(23.10/3)). - function Enclosing_Dynamic_Scope (Ent : Entity_Id) return Entity_Id; -- For any entity, Ent, returns the closest dynamic scope in which the -- entity is declared or Standard_Standard for library-level entities. @@ -259,6 +251,12 @@ package Sem_Aux is function In_Generic_Body (Id : Entity_Id) return Boolean; -- Determine whether entity Id appears inside a generic body + function Initialization_Suppressed (Typ : Entity_Id) return Boolean; + pragma Inline (Initialization_Suppressed); + -- Returns True if initialization should be suppressed for the given type + -- or subtype. This is true if Suppress_Initialization is set either for + -- the subtype itself, or for the corresponding base type. + function Is_By_Copy_Type (Ent : Entity_Id) return Boolean; -- Ent is any entity. Returns True if Ent is a type entity where the type -- is required to be passed by copy, as defined in (RM 6.2(3)). @@ -329,11 +327,14 @@ package Sem_Aux is function Number_Discriminants (Typ : Entity_Id) return Pos; -- Typ is a type with discriminants, yields number of discriminants in type - function Initialization_Suppressed (Typ : Entity_Id) return Boolean; - pragma Inline (Initialization_Suppressed); - -- Returns True if initialization should be suppressed for the given type - -- or subtype. This is true if Suppress_Initialization is set either for - -- the subtype itself, or for the corresponding base type. + function Object_Type_Has_Constrained_Partial_View + (Typ : Entity_Id; + Scop : Entity_Id) return Boolean; + -- Return True if type of object has attribute Has_Constrained_Partial_View + -- set to True; in addition, within a generic body, return True if subtype + -- of the object is a descendant of an untagged generic formal private or + -- derived type, and the subtype is not an unconstrained array subtype + -- (RM 3.3(23.10/3)). function Ultimate_Alias (Prim : Entity_Id) return Entity_Id; pragma Inline (Ultimate_Alias); diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 83d71aa8aa2..af5da0a43fa 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -580,9 +580,7 @@ package body Sem_Ch4 is -- and the allocated object is unconstrained. elsif Ada_Version >= Ada_2005 - and then Effectively_Has_Constrained_Partial_View - (Typ => Base_Typ, - Scop => Current_Scope) + and then Has_Constrained_Partial_View (Base_Typ) then Error_Msg_N ("constraint not allowed when type " & diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 199c55121b8..83801144447 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -7980,7 +7980,7 @@ package body Sem_Util is -- designated object is known to be constrained. if Ekind (Prefix_Type) = E_Access_Type - and then not Effectively_Has_Constrained_Partial_View + and then not Object_Type_Has_Constrained_Partial_View (Typ => Designated_Type (Prefix_Type), Scop => Current_Scope) then