From a015ef67374d81c9468dfa5ca031ef0f8b394314 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Tue, 20 Oct 2015 14:13:11 +0200 Subject: [PATCH] [multiple changes] 2015-10-20 Tristan Gingold * sem_util.adb (Is_Protected_Self_Reference): Remove reference to UET_Address in comment. * sem_attr.adb (Check_Unit_Name): Adjust comment. (Analyze_Attribute): Remove handling of UET_Address. * sem_attr.ads (Attribute_Impl_Def): Remove Attribute_UET_Address. * snames.ads-tmpl Remove Name_UET_Address, Attribute_UET_Address. * exp_attr.adb (Expand_N_Attribute_Reference): Remove Attribute_UET_Address. 2015-10-20 Bob Duff * a-cbdlli.adb, a-cdlili.adb, a-chtgop.adb, a-cidlli.adb, * a-cobove.adb, a-coinve.adb, a-convec.adb, a-crbtgo.adb ("="): Avoid modifying the tampering counts unnecessarily. (Adjust): Zero tampering counts unconditionally. 2015-10-20 Jerome Lambourg * init.c: Fix build issue on arm-vx6 when building the RTP run-time. 2015-10-20 Ed Schonberg * sem_ch3.adb (Analyze_Object_Declaration): If the expression is an aggregate and compilation is in -gnatI mode (ignore rep clauses) do not delay resolution of aggregate, to prevent freeze actions out of order in the backend. 2015-10-20 Ed Schonberg * sem_prag.ads, sem_prag.adb (Build_Generic_Class_Condition): New procedure to construct a generic function for a class-wide precondition, to implement AI12-0113 concerning the new semantics of class-wide preconditions for overriding uperations. From-SVN: r229060 --- gcc/ada/ChangeLog | 37 +++++++ gcc/ada/a-cbdlli.adb | 45 ++++---- gcc/ada/a-cdlili.adb | 47 ++++---- gcc/ada/a-chtgop.adb | 86 ++++++++------- gcc/ada/a-cidlli.adb | 48 +++++---- gcc/ada/a-cobove.adb | 27 +++-- gcc/ada/a-coinve.adb | 46 +++++--- gcc/ada/a-convec.adb | 34 ++++-- gcc/ada/a-crbtgo.adb | 40 +++---- gcc/ada/exp_attr.adb | 43 -------- gcc/ada/init.c | 6 +- gcc/ada/sem_attr.adb | 25 +---- gcc/ada/sem_attr.ads | 10 -- gcc/ada/sem_ch3.adb | 11 +- gcc/ada/sem_prag.adb | 234 ++++++++++++++++++++++++++++++++++++++++ gcc/ada/sem_prag.ads | 11 ++ gcc/ada/sem_util.adb | 6 +- gcc/ada/snames.ads-tmpl | 2 - 18 files changed, 512 insertions(+), 246 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index e6c099a997b..5584a44eeef 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,40 @@ +2015-10-20 Tristan Gingold + + * sem_util.adb (Is_Protected_Self_Reference): Remove reference to + UET_Address in comment. + * sem_attr.adb (Check_Unit_Name): Adjust comment. + (Analyze_Attribute): Remove handling of UET_Address. + * sem_attr.ads (Attribute_Impl_Def): Remove Attribute_UET_Address. + * snames.ads-tmpl Remove Name_UET_Address, Attribute_UET_Address. + * exp_attr.adb (Expand_N_Attribute_Reference): Remove + Attribute_UET_Address. + +2015-10-20 Bob Duff + + * a-cbdlli.adb, a-cdlili.adb, a-chtgop.adb, a-cidlli.adb, + * a-cobove.adb, a-coinve.adb, a-convec.adb, a-crbtgo.adb ("="): Avoid + modifying the tampering counts unnecessarily. + (Adjust): Zero tampering counts unconditionally. + +2015-10-20 Jerome Lambourg + + * init.c: Fix build issue on arm-vx6 when building the RTP + run-time. + +2015-10-20 Ed Schonberg + + * sem_ch3.adb (Analyze_Object_Declaration): If the expression + is an aggregate and compilation is in -gnatI mode (ignore rep + clauses) do not delay resolution of aggregate, to prevent freeze + actions out of order in the backend. + +2015-10-20 Ed Schonberg + + * sem_prag.ads, sem_prag.adb (Build_Generic_Class_Condition): + New procedure to construct a generic function for a class-wide + precondition, to implement AI12-0113 concerning the new semantics + of class-wide preconditions for overriding uperations. + 2015-10-20 Hristian Kirtchev * sem_util.adb (Find_Actual): The routine is diff --git a/gcc/ada/a-cbdlli.adb b/gcc/ada/a-cbdlli.adb index 2d8cbdaaeed..14aad946d49 100644 --- a/gcc/ada/a-cbdlli.adb +++ b/gcc/ada/a-cbdlli.adb @@ -84,32 +84,37 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is --------- function "=" (Left, Right : List) return Boolean is - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - Lock_Left : With_Lock (Left.TC'Unrestricted_Access); - Lock_Right : With_Lock (Right.TC'Unrestricted_Access); - - LN : Node_Array renames Left.Nodes; - RN : Node_Array renames Right.Nodes; - - LI : Count_Type; - RI : Count_Type; begin if Left.Length /= Right.Length then return False; end if; - LI := Left.First; - RI := Right.First; - for J in 1 .. Left.Length loop - if LN (LI).Element /= RN (RI).Element then - return False; - end if; + if Left.Length = 0 then + return True; + end if; - LI := LN (LI).Next; - RI := RN (RI).Next; - end loop; + declare + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + Lock_Left : With_Lock (Left.TC'Unrestricted_Access); + Lock_Right : With_Lock (Right.TC'Unrestricted_Access); + + LN : Node_Array renames Left.Nodes; + RN : Node_Array renames Right.Nodes; + + LI : Count_Type := Left.First; + RI : Count_Type := Right.First; + begin + for J in 1 .. Left.Length loop + if LN (LI).Element /= RN (RI).Element then + return False; + end if; + + LI := LN (LI).Next; + RI := RN (RI).Next; + end loop; + end; return True; end "="; diff --git a/gcc/ada/a-cdlili.adb b/gcc/ada/a-cdlili.adb index 6cd1ae7e400..036f0aba169 100644 --- a/gcc/ada/a-cdlili.adb +++ b/gcc/ada/a-cdlili.adb @@ -73,30 +73,34 @@ package body Ada.Containers.Doubly_Linked_Lists is --------- function "=" (Left, Right : List) return Boolean is - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - Lock_Left : With_Lock (Left.TC'Unrestricted_Access); - Lock_Right : With_Lock (Right.TC'Unrestricted_Access); - - L : Node_Access; - R : Node_Access; - begin if Left.Length /= Right.Length then return False; end if; - L := Left.First; - R := Right.First; - for J in 1 .. Left.Length loop - if L.Element /= R.Element then - return False; - end if; + if Left.Length = 0 then + return True; + end if; - L := L.Next; - R := R.Next; - end loop; + declare + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + Lock_Left : With_Lock (Left.TC'Unrestricted_Access); + Lock_Right : With_Lock (Right.TC'Unrestricted_Access); + + L : Node_Access := Left.First; + R : Node_Access := Right.First; + begin + for J in 1 .. Left.Length loop + if L.Element /= R.Element then + return False; + end if; + + L := L.Next; + R := R.Next; + end loop; + end; return True; end "="; @@ -109,10 +113,15 @@ package body Ada.Containers.Doubly_Linked_Lists is Src : Node_Access := Container.First; begin + -- If the counts are nonzero, execution is technically erroneous, but + -- it seems friendly to allow things like concurrent "=" on shared + -- constants. + + Zero_Counts (Container.TC); + if Src = null then pragma Assert (Container.Last = null); pragma Assert (Container.Length = 0); - pragma Assert (Container.TC = (Busy => 0, Lock => 0)); return; end if; diff --git a/gcc/ada/a-chtgop.adb b/gcc/ada/a-chtgop.adb index 87a2e1eca83..0d7f88fa3fb 100644 --- a/gcc/ada/a-chtgop.adb +++ b/gcc/ada/a-chtgop.adb @@ -357,22 +357,7 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is function Generic_Equal (L, R : Hash_Table_Type) return Boolean is - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - Lock_L : With_Lock (L.TC'Unrestricted_Access); - Lock_R : With_Lock (R.TC'Unrestricted_Access); - - L_Index : Hash_Type; - L_Node : Node_Access; - - N : Count_Type; - begin - if L'Address = R'Address then - return True; - end if; - if L.Length /= R.Length then return False; end if; @@ -381,44 +366,57 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is return True; end if; - -- Find the first node of hash table L + declare + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. - L_Index := 0; - loop - L_Node := L.Buckets (L_Index); - exit when L_Node /= null; - L_Index := L_Index + 1; - end loop; + Lock_L : With_Lock (L.TC'Unrestricted_Access); + Lock_R : With_Lock (R.TC'Unrestricted_Access); - -- For each node of hash table L, search for an equivalent node in hash - -- table R. + L_Index : Hash_Type; + L_Node : Node_Access; - N := L.Length; - loop - if not Find (HT => R, Key => L_Node) then - return False; - end if; - - N := N - 1; + N : Count_Type; + begin + -- Find the first node of hash table L - L_Node := Next (L_Node); + L_Index := 0; + loop + L_Node := L.Buckets (L_Index); + exit when L_Node /= null; + L_Index := L_Index + 1; + end loop; - if L_Node = null then - -- We have exhausted the nodes in this bucket + -- For each node of hash table L, search for an equivalent node in + -- hash table R. - if N = 0 then - return True; + N := L.Length; + loop + if not Find (HT => R, Key => L_Node) then + return False; end if; - -- Find the next bucket + N := N - 1; - loop - L_Index := L_Index + 1; - L_Node := L.Buckets (L_Index); - exit when L_Node /= null; - end loop; - end if; - end loop; + L_Node := Next (L_Node); + + if L_Node = null then + -- We have exhausted the nodes in this bucket + + if N = 0 then + return True; + end if; + + -- Find the next bucket + + loop + L_Index := L_Index + 1; + L_Node := L.Buckets (L_Index); + exit when L_Node /= null; + end loop; + end if; + end loop; + end; end Generic_Equal; ----------------------- diff --git a/gcc/ada/a-cidlli.adb b/gcc/ada/a-cidlli.adb index d7995e3e98a..7cb4c87f611 100644 --- a/gcc/ada/a-cidlli.adb +++ b/gcc/ada/a-cidlli.adb @@ -76,30 +76,34 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is --------- function "=" (Left, Right : List) return Boolean is - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - Lock_Left : With_Lock (Left.TC'Unrestricted_Access); - Lock_Right : With_Lock (Right.TC'Unrestricted_Access); - - L : Node_Access; - R : Node_Access; - begin if Left.Length /= Right.Length then return False; end if; - L := Left.First; - R := Right.First; - for J in 1 .. Left.Length loop - if L.Element.all /= R.Element.all then - return False; - end if; + if Left.Length = 0 then + return True; + end if; - L := L.Next; - R := R.Next; - end loop; + declare + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + Lock_Left : With_Lock (Left.TC'Unrestricted_Access); + Lock_Right : With_Lock (Right.TC'Unrestricted_Access); + + L : Node_Access := Left.First; + R : Node_Access := Right.First; + begin + for J in 1 .. Left.Length loop + if L.Element.all /= R.Element.all then + return False; + end if; + + L := L.Next; + R := R.Next; + end loop; + end; return True; end "="; @@ -113,10 +117,15 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is Dst : Node_Access; begin + -- If the counts are nonzero, execution is technically erroneous, but + -- it seems friendly to allow things like concurrent "=" on shared + -- constants. + + Zero_Counts (Container.TC); + if Src = null then pragma Assert (Container.Last = null); pragma Assert (Container.Length = 0); - pragma Assert (Container.TC = (Busy => 0, Lock => 0)); return; end if; @@ -127,7 +136,6 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is Container.First := null; Container.Last := null; Container.Length := 0; - Zero_Counts (Container.TC); declare Element : Element_Access := new Element_Type'(Src.Element.all); diff --git a/gcc/ada/a-cobove.adb b/gcc/ada/a-cobove.adb index 4fa7ce8828d..fca300d41d6 100644 --- a/gcc/ada/a-cobove.adb +++ b/gcc/ada/a-cobove.adb @@ -269,21 +269,28 @@ package body Ada.Containers.Bounded_Vectors is --------- overriding function "=" (Left, Right : Vector) return Boolean is - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - Lock_Left : With_Lock (Left.TC'Unrestricted_Access); - Lock_Right : With_Lock (Right.TC'Unrestricted_Access); begin if Left.Last /= Right.Last then return False; end if; - for J in Count_Type range 1 .. Left.Length loop - if Left.Elements (J) /= Right.Elements (J) then - return False; - end if; - end loop; + if Left.Length = 0 then + return True; + end if; + + declare + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + Lock_Left : With_Lock (Left.TC'Unrestricted_Access); + Lock_Right : With_Lock (Right.TC'Unrestricted_Access); + begin + for J in Count_Type range 1 .. Left.Length loop + if Left.Elements (J) /= Right.Elements (J) then + return False; + end if; + end loop; + end; return True; end "="; diff --git a/gcc/ada/a-coinve.adb b/gcc/ada/a-coinve.adb index 106178a02bf..0053de0f442 100644 --- a/gcc/ada/a-coinve.adb +++ b/gcc/ada/a-coinve.adb @@ -103,29 +103,36 @@ package body Ada.Containers.Indefinite_Vectors is --------- overriding function "=" (Left, Right : Vector) return Boolean is - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - Lock_Left : With_Lock (Left.TC'Unrestricted_Access); - Lock_Right : With_Lock (Right.TC'Unrestricted_Access); begin if Left.Last /= Right.Last then return False; end if; - for J in Index_Type range Index_Type'First .. Left.Last loop - if Left.Elements.EA (J) = null then - if Right.Elements.EA (J) /= null then - return False; - end if; + if Left.Length = 0 then + return True; + end if; - elsif Right.Elements.EA (J) = null then - return False; + declare + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. - elsif Left.Elements.EA (J).all /= Right.Elements.EA (J).all then - return False; - end if; - end loop; + Lock_Left : With_Lock (Left.TC'Unrestricted_Access); + Lock_Right : With_Lock (Right.TC'Unrestricted_Access); + begin + for J in Index_Type range Index_Type'First .. Left.Last loop + if Left.Elements.EA (J) = null then + if Right.Elements.EA (J) /= null then + return False; + end if; + + elsif Right.Elements.EA (J) = null then + return False; + + elsif Left.Elements.EA (J).all /= Right.Elements.EA (J).all then + return False; + end if; + end loop; + end; return True; end "="; @@ -136,6 +143,12 @@ package body Ada.Containers.Indefinite_Vectors is procedure Adjust (Container : in out Vector) is begin + -- If the counts are nonzero, execution is technically erroneous, but + -- it seems friendly to allow things like concurrent "=" on shared + -- constants. + + Zero_Counts (Container.TC); + if Container.Last = No_Index then Container.Elements := null; return; @@ -149,7 +162,6 @@ package body Ada.Containers.Indefinite_Vectors is begin Container.Elements := null; Container.Last := No_Index; - Zero_Counts (Container.TC); Container.Elements := new Elements_Type (L); diff --git a/gcc/ada/a-convec.adb b/gcc/ada/a-convec.adb index cae5fa0180a..ff11fa95272 100644 --- a/gcc/ada/a-convec.adb +++ b/gcc/ada/a-convec.adb @@ -100,21 +100,28 @@ package body Ada.Containers.Vectors is --------- overriding function "=" (Left, Right : Vector) return Boolean is - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - Lock_Left : With_Lock (Left.TC'Unrestricted_Access); - Lock_Right : With_Lock (Right.TC'Unrestricted_Access); begin if Left.Last /= Right.Last then return False; end if; - for J in Index_Type range Index_Type'First .. Left.Last loop - if Left.Elements.EA (J) /= Right.Elements.EA (J) then - return False; - end if; - end loop; + if Left.Length = 0 then + return True; + end if; + + declare + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + Lock_Left : With_Lock (Left.TC'Unrestricted_Access); + Lock_Right : With_Lock (Right.TC'Unrestricted_Access); + begin + for J in Index_Type range Index_Type'First .. Left.Last loop + if Left.Elements.EA (J) /= Right.Elements.EA (J) then + return False; + end if; + end loop; + end; return True; end "="; @@ -125,6 +132,12 @@ package body Ada.Containers.Vectors is procedure Adjust (Container : in out Vector) is begin + -- If the counts are nonzero, execution is technically erroneous, but + -- it seems friendly to allow things like concurrent "=" on shared + -- constants. + + Zero_Counts (Container.TC); + if Container.Last = No_Index then Container.Elements := null; return; @@ -137,7 +150,6 @@ package body Ada.Containers.Vectors is begin Container.Elements := null; - Zero_Counts (Container.TC); -- Note: it may seem that the following assignment to Container.Last -- is useless, since we assign it to L below. However this code is diff --git a/gcc/ada/a-crbtgo.adb b/gcc/ada/a-crbtgo.adb index e656295f683..bfc0bcf3a42 100644 --- a/gcc/ada/a-crbtgo.adb +++ b/gcc/ada/a-crbtgo.adb @@ -514,9 +514,14 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is Root : constant Node_Access := Tree.Root; use type Helpers.Tamper_Counts; begin + -- If the counts are nonzero, execution is technically erroneous, but + -- it seems friendly to allow things like concurrent "=" on shared + -- constants. + + Zero_Counts (Tree.TC); + if N = 0 then pragma Assert (Root = null); - pragma Assert (Tree.TC = (Busy => 0, Lock => 0)); return; end if; @@ -623,16 +628,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is ------------------- function Generic_Equal (Left, Right : Tree_Type) return Boolean is - Lock_Left : With_Lock (Left.TC'Unrestricted_Access); - Lock_Right : With_Lock (Right.TC'Unrestricted_Access); - - L_Node : Node_Access; - R_Node : Node_Access; begin - if Left'Address = Right'Address then - return True; - end if; - if Left.Length /= Right.Length then return False; end if; @@ -644,16 +640,22 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is return True; end if; - L_Node := Left.First; - R_Node := Right.First; - while L_Node /= null loop - if not Is_Equal (L_Node, R_Node) then - return False; - end if; + declare + Lock_Left : With_Lock (Left.TC'Unrestricted_Access); + Lock_Right : With_Lock (Right.TC'Unrestricted_Access); - L_Node := Next (L_Node); - R_Node := Next (R_Node); - end loop; + L_Node : Node_Access := Left.First; + R_Node : Node_Access := Right.First; + begin + while L_Node /= null loop + if not Is_Equal (L_Node, R_Node) then + return False; + end if; + + L_Node := Next (L_Node); + R_Node := Next (R_Node); + end loop; + end; return True; end Generic_Equal; diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index f6f22f00473..781f3a92487 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -6152,49 +6152,6 @@ package body Exp_Attr is Expand_Fpt_Attribute_R (N); end if; - ----------------- - -- UET_Address -- - ----------------- - - when Attribute_UET_Address => UET_Address : declare - Ent : constant Entity_Id := Make_Temporary (Loc, 'T'); - - begin - Insert_Action (N, - Make_Object_Declaration (Loc, - Defining_Identifier => Ent, - Aliased_Present => True, - Object_Definition => - New_Occurrence_Of (RTE (RE_Address), Loc))); - - -- Construct name __gnat_xxx__SDP, where xxx is the unit name - -- in normal external form. - - Get_External_Unit_Name_String (Get_Unit_Name (Pref)); - Name_Buffer (1 + 7 .. Name_Len + 7) := Name_Buffer (1 .. Name_Len); - Name_Len := Name_Len + 7; - Name_Buffer (1 .. 7) := "__gnat_"; - Name_Buffer (Name_Len + 1 .. Name_Len + 5) := "__SDP"; - Name_Len := Name_Len + 5; - - Set_Is_Imported (Ent); - Set_Interface_Name (Ent, - Make_String_Literal (Loc, - Strval => String_From_Name_Buffer)); - - -- Set entity as internal to ensure proper Sprint output of its - -- implicit importation. - - Set_Is_Internal (Ent); - - Rewrite (N, - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Ent, Loc), - Attribute_Name => Name_Address)); - - Analyze_And_Resolve (N, Typ); - end UET_Address; - ------------ -- Update -- ------------ diff --git a/gcc/ada/init.c b/gcc/ada/init.c index e905a0b7335..443b3389379 100644 --- a/gcc/ada/init.c +++ b/gcc/ada/init.c @@ -1715,7 +1715,7 @@ __gnat_install_handler (void) #include #endif -#if defined (ARMEL) && (_WRS_VXWORKS_MAJOR == 6) +#if defined (ARMEL) && (_WRS_VXWORKS_MAJOR == 6) && !defined(__RTP__) #include #endif @@ -1862,7 +1862,7 @@ __gnat_map_signal (int sig, siginfo_t *si ATTRIBUTE_UNUSED, page if there's a match. Additionally we're are assured this is a genuine stack overflow condition and and set the message and exception to that effect. */ -#if defined (ARMEL) && (_WRS_VXWORKS_MAJOR == 6) +#if defined (ARMEL) && (_WRS_VXWORKS_MAJOR == 6) && !defined(__RTP__) /* We re-arm the guard page by marking it invalid */ @@ -1896,7 +1896,7 @@ __gnat_map_signal (int sig, siginfo_t *si ATTRIBUTE_UNUSED, } } } -#endif /* defined (ARMEL) && (_WRS_VXWORKS_MAJOR == 6) */ +#endif /* defined (ARMEL) && (_WRS_VXWORKS_MAJOR == 6) && !defined(__RTP__) */ __gnat_clear_exception_count (); Raise_From_Signal_Handler (exception, msg); diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index fc24b35fa9b..4d6bf7c5a18 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -388,8 +388,8 @@ package body Sem_Attr is -- itself of the form of a library unit name. Note that this is -- quite different from Check_Program_Unit, since it only checks -- the syntactic form of the name, not the semantic identity. This - -- is because it is used with attributes (Elab_Body, Elab_Spec, - -- UET_Address and Elaborated) which can refer to non-visible unit. + -- is because it is used with attributes (Elab_Body, Elab_Spec and + -- Elaborated) which can refer to non-visible unit. procedure Error_Attr (Msg : String; Error_Node : Node_Id); pragma No_Return (Error_Attr); @@ -2675,7 +2675,6 @@ package body Sem_Attr is if Aname /= Name_Elab_Body and then Aname /= Name_Elab_Spec and then Aname /= Name_Elab_Subp_Body and then - Aname /= Name_UET_Address and then Aname /= Name_Enabled and then Aname /= Name_Old then @@ -6026,15 +6025,6 @@ package body Sem_Attr is Analyze_And_Resolve (N, Standard_String); - ----------------- - -- UET_Address -- - ----------------- - - when Attribute_UET_Address => - Check_E0; - Check_Unit_Name (P); - Set_Etype (N, RTE (RE_Address)); - ----------------------- -- Unbiased_Rounding -- ----------------------- @@ -9710,7 +9700,6 @@ package body Sem_Attr is Attribute_Terminated | Attribute_To_Address | Attribute_Type_Key | - Attribute_UET_Address | Attribute_Unchecked_Access | Attribute_Universal_Literal_String | Attribute_Unrestricted_Access | @@ -11060,16 +11049,6 @@ package body Sem_Attr is when Attribute_Result => null; - ----------------- - -- UET_Address -- - ----------------- - - -- Prefix must not be resolved in this case, since it is not a - -- real entity reference. No action of any kind is require. - - when Attribute_UET_Address => - return; - ---------------------- -- Unchecked_Access -- ---------------------- diff --git a/gcc/ada/sem_attr.ads b/gcc/ada/sem_attr.ads index c1e592844fa..d71acb33140 100644 --- a/gcc/ada/sem_attr.ads +++ b/gcc/ada/sem_attr.ads @@ -508,16 +508,6 @@ package Sem_Attr is -- Aux_DEC into System, then the type Type_Class can be referenced -- as an entity within System, as can its enumeration literals. - ----------------- - -- UET_Address -- - ----------------- - - Attribute_UET_Address => True, - -- Unit'UET_Address, where Unit is a program unit, yields the address - -- of the unit exception table for the specified unit. This is only - -- used in the internal implementation of exception handling. See the - -- implementation of unit Ada.Exceptions for details on its use. - ------------------------------ -- Universal_Literal_String -- ------------------------------ diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index d91f831ec33..22e7cbb9d12 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -3883,11 +3883,18 @@ package body Sem_Ch3 is -- the possible presence of an address clause, and defer resolution -- and expansion of the aggregate to the freeze point of the entity. + -- This is not always legal because the aggregate may contain other + -- references that need freezing, e.g. references to other entities + -- with address clauses. In any case, when compiling with -gnatI the + -- presence of the address clause must be ignored. + if Comes_From_Source (N) and then Expander_Active and then Nkind (E) = N_Aggregate - and then (Present (Following_Address_Clause (N)) - or else Delayed_Aspect_Present) + and then + ((Present (Following_Address_Clause (N)) + and then not Ignore_Rep_Clauses) + or else Delayed_Aspect_Present) then Set_Etype (E, T); diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 2733dc39bd2..bb64634c2ad 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -22210,6 +22210,10 @@ package body Sem_Prag is end if; end if; + if Class_Present (N) then + Build_Generic_Class_Condition (Spec_Id, N); + end if; + Preanalyze_Assert_Expression (Expr, Standard_Boolean); -- For a class-wide condition, a reference to a controlling formal must @@ -25063,6 +25067,236 @@ package body Sem_Prag is return False; end Appears_In; + ----------------------------------- + -- Build_Generic_Class_Condition -- + ----------------------------------- + + procedure Build_Generic_Class_Condition + (Subp : Entity_Id; + Prag : Node_Id) + is + Expr : constant Node_Id := + Get_Pragma_Arg + (First (Pragma_Argument_Associations (Prag))); + Loc : constant Source_Ptr := Sloc (Prag); + Map : constant Elist_Id := New_Elmt_List; + New_Expr : constant Node_Id := New_Copy_Tree (Expr); + New_Pred : constant Entity_Id := + Make_Defining_Identifier (Loc, + New_External_Name (Chars (Subp), "Pre", -1)); + Typ : constant Entity_Id := Find_Dispatching_Type (Subp); + + function Replace_Formal (N : Node_Id) return Traverse_Result; + -- Replace an occurence of a formal parameter of the original expression + -- in the precondition, with the formal of the generic function created + -- for it. + + -------------------- + -- Replace_Formal -- + -------------------- + + function Replace_Formal (N : Node_Id) return Traverse_Result is + Loc : constant Source_Ptr := Sloc (N); + El : Elmt_Id; + F : Entity_Id; + New_F : Entity_Id; + + begin + if Nkind (N) = N_Identifier + and then (Nkind (Parent (N)) /= N_Parameter_Association + or else N /= Selector_Name (Parent (N))) + and then Present (Entity (N)) + and then Is_Formal (Entity (N)) + then + El := First_Elmt (Map); + while Present (El) loop + F := Node (El); + if Chars (F) = Chars (N) then + New_F := Node (Next_Elmt (El)); + + -- If this is a controlling formal, in the generic it + -- becomes a conversion to the controlling formal of the + -- operation with the classwide precondition. If the formal + -- is an access parameter, a reference to F becomes + -- Root (New_F.all)'access. + + if Is_Controlling_Formal (F) then + if Is_Access_Type (Etype (F)) then + Rewrite (N, + Make_Attribute_Reference (Loc, + Prefix => + Unchecked_Convert_To ( + Designated_Type (Etype (F)), + Make_Explicit_Dereference (Loc, + Prefix => New_Occurrence_Of (New_F, Loc))), + Attribute_Name => Name_Access)); + + else + Rewrite (N, + Unchecked_Convert_To + (Etype (F), New_Occurrence_Of (New_F, Sloc (N)))); + end if; + + -- Non-controlling formals retain their original type + + else + Rewrite (N, New_Occurrence_Of (New_F, Sloc (N))); + end if; + + return OK; + end if; + + Next_Elmt (El); + Next_Elmt (El); + end loop; + + elsif Nkind (N) = N_Parameter_Association then + Set_Next_Named_Actual (N, Empty); + + elsif Nkind (N) = N_Function_Call then + Set_First_Named_Actual (N, Empty); + end if; + + return OK; + end Replace_Formal; + + procedure Map_Formals is new Traverse_Proc (Replace_Formal); + + -- Local variables + + Bod : Node_Id; + Decl : Node_Id; + F : Entity_Id; + New_F : Entity_Id; + New_Form : List_Id; + New_Typ : Entity_Id; + Par_Typ : Entity_Id; + Spec : Node_Id; + + -- Start of processing for Build_Generic_Class_Pre + + begin + -- Nothing to do if previous error or expansion disabled. + + if not Expander_Active then + return; + end if; + + if Chars (Pragma_Identifier (Prag)) = Name_Postcondition then + return; + end if; + + -- Build list of controlling formals and their renamings in the new + -- generic operation. + + New_Form := New_List; + New_Typ := Empty; + + F := First_Formal (Subp); + while Present (F) loop + New_F := + Make_Defining_Identifier (Loc, New_External_Name (Chars (F), "GF")); + Set_Ekind (New_F, Ekind (F)); + Append_Elmt (F, Map); + Append_Elmt (New_F, Map); + + if Is_Controlling_Formal (F) then + if Is_Access_Type (Etype (F)) then + New_Typ := + Make_Defining_Identifier (Loc, + Chars => + New_External_Name + (Chars (Designated_Type (Etype (F))), "GT")); + Par_Typ := + Make_Access_Definition (Loc, + Subtype_Mark => New_Occurrence_Of (New_Typ, Loc)); + else + New_Typ := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (Etype (F)), "GT")); + Par_Typ := New_Occurrence_Of (New_Typ, Loc); + end if; + + Append_To (New_Form, + Make_Parameter_Specification (Loc, + Defining_Identifier => New_F, + Parameter_Type => Par_Typ)); + else + -- If formal has a class-wide type, build same attribute for new + -- formal. + + if Is_Class_Wide_Type (Etype (F)) then + Append_To (New_Form, + Make_Parameter_Specification (Loc, + Defining_Identifier => New_F, + Parameter_Type => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Etype (Etype (F)), Loc), + Attribute_Name => Name_Class))); + else + Append_To (New_Form, + Make_Parameter_Specification (Loc, + Defining_Identifier => New_F, + Parameter_Type => New_Occurrence_Of (Etype (F), Loc))); + end if; + end if; + + Next_Formal (F); + end loop; + + -- If no controlling formal found, pre/postcondition is incorrect. + + if No (New_Typ) then + return; + end if; + + Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => New_Pred, + Parameter_Specifications => New_Form, + Result_Definition => + New_Occurrence_Of (Standard_Boolean, Loc)); + + Decl := + Make_Generic_Subprogram_Declaration (Loc, + Specification => Spec, + Generic_Formal_Declarations => New_List ( + Make_Formal_Type_Declaration (Loc, + Defining_Identifier => New_Typ, + Formal_Type_Definition => + Make_Formal_Private_Type_Definition (Loc)))); + + Preanalyze (New_Expr); + Map_Formals (New_Expr); + + Bod := + Make_Subprogram_Body (Loc, + Specification => New_Copy_Tree (Spec), + Declarations => New_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Simple_Return_Statement (Loc, + Expression => New_Expr)))); + + -- Generic function must be analyzed after type is frozen, and will be + -- instantiated when subprogram contract for operation or any of its + -- overridings is expanded. + + Append_Freeze_Actions (Typ, New_List (Decl, Bod)); + + -- We need to convey the existence of the generic to the point at which + -- we expand the contract. We replace the expression in the pragma with + -- name of the generic function, to be instantiated when expanding the + -- contract for the subprogram or some overriding of it. See + -- Exp_ch6.Expand_Subprogram_Contract.Build_Pragma_Check_Equivalent. + -- (TBD) + + Set_Ekind (New_Pred, E_Generic_Function); + Set_Scope (New_Pred, Current_Scope); + end Build_Generic_Class_Condition; + ----------------------------- -- Check_Applicable_Policy -- ----------------------------- diff --git a/gcc/ada/sem_prag.ads b/gcc/ada/sem_prag.ads index cdd3657dfdf..862c564f0da 100644 --- a/gcc/ada/sem_prag.ads +++ b/gcc/ada/sem_prag.ads @@ -215,6 +215,17 @@ package Sem_Prag is procedure Analyze_Test_Case_In_Decl_Part (N : Node_Id); -- Perform preanalysis of pragma Test_Case + procedure Build_Generic_Class_Condition + (Subp : Entity_Id; + Prag : Node_Id); + -- AI12-113 modifies the semantics of classwide pre- and postconditions, + -- as well as type invariants, so that the expression used in an inherited + -- operation uses the actual type and is statically bound, rather than + -- using T'Class and dispatching. This new semantics is implemented by + -- building a generic function for the corresponding condition and + -- instantiating it for each descendant type. Checking the condition is + -- implemented as a call to that instantiation. + procedure Check_Applicable_Policy (N : Node_Id); -- N is either an N_Aspect or an N_Pragma node. There are two cases. If -- the name of the aspect or pragma is not one of those recognized as diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 8f93bcdb32e..e0c857b1177 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -12730,9 +12730,9 @@ package body Sem_Util is begin -- Verify that prefix is analyzed and has the proper form. Note that - -- the attributes Elab_Spec, Elab_Body, Elab_Subp_Body and UET_Address, - -- which also produce the address of an entity, do not analyze their - -- prefix because they denote entities that are not necessarily visible. + -- the attributes Elab_Spec, Elab_Body and Elab_Subp_Body which also + -- produce the address of an entity, do not analyze their prefix + -- because they denote entities that are not necessarily visible. -- Neither of them can apply to a protected type. return Ada_Version >= Ada_2005 diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index 7f252875cef..881f36589f8 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -938,7 +938,6 @@ package Snames is Name_To_Address : constant Name_Id := N + $; -- GNAT Name_Type_Class : constant Name_Id := N + $; -- GNAT Name_Type_Key : constant Name_Id := N + $; -- GNAT - Name_UET_Address : constant Name_Id := N + $; -- GNAT Name_Unbiased_Rounding : constant Name_Id := N + $; Name_Unchecked_Access : constant Name_Id := N + $; Name_Unconstrained_Array : constant Name_Id := N + $; -- GNAT @@ -1575,7 +1574,6 @@ package Snames is Attribute_To_Address, Attribute_Type_Class, Attribute_Type_Key, - Attribute_UET_Address, Attribute_Unbiased_Rounding, Attribute_Unchecked_Access, Attribute_Unconstrained_Array, -- 2.30.2