From: Ed Schonberg Date: Tue, 20 Oct 2015 09:40:24 +0000 (+0000) Subject: sem_ch3.adb (Check_Nonoverridable_Aspects): New procedure within Analyze_Full_Type_... X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=b8a1821614cbf7e5c117bf0a7a215e3c3a81f8c3;p=gcc.git sem_ch3.adb (Check_Nonoverridable_Aspects): New procedure within Analyze_Full_Type_ Declaration... 2015-10-20 Ed Schonberg * sem_ch3.adb (Check_Nonoverridable_Aspects): New procedure within Analyze_Full_Type_ Declaration, used to apply legality rules in 13,1,1 (18.3.3) concerning aspects that cannot be overridden in a type extension. (Check_Duplicate_Aspects): It is not legal to specify the Implicit_Dereference aspect on a full view if partial view has known discriminants. * sem_ch13.adb (Analyze_Aspect_Implicit_Dereference): Verify that the specification of the aspect on a derived type confirms the value of the inherited one. * sem_util.adb (Reference_Discriminant): Return empty if none specified. From-SVN: r229026 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 4089992a48d..2bfc5079f54 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,18 @@ +2015-10-20 Ed Schonberg + + * sem_ch3.adb (Check_Nonoverridable_Aspects): New procedure within + Analyze_Full_Type_ Declaration, used to apply legality rules in + 13,1,1 (18.3.3) concerning aspects that cannot be overridden in + a type extension. + (Check_Duplicate_Aspects): It is not legal to specify the + Implicit_Dereference aspect on a full view if partial view has + known discriminants. + * sem_ch13.adb (Analyze_Aspect_Implicit_Dereference): Verify that + the specification of the aspect on a derived type confirms the + value of the inherited one. + * sem_util.adb (Reference_Discriminant): Return empty if none + specified. + 2015-10-20 Thomas Quinot * exp_ch5.adb, sem_ch3.adb: Minor reformatting. diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index c1c713202a9..5de48ddbfae 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -1444,35 +1444,56 @@ package body Sem_Ch13 is ----------------------------------------- procedure Analyze_Aspect_Implicit_Dereference is + Disc : Entity_Id; + Parent_Disc : Entity_Id; + + -- For a type extension, check whether parent has a + -- reference discriminant, to verify that use is proper. + begin if not Is_Type (E) or else not Has_Discriminants (E) then Error_Msg_N - ("aspect must apply to a type with discriminants", N); + ("aspect must apply to a type with discriminants", Expr); - else - declare - Disc : Entity_Id; + elsif not Is_Entity_Name (Expr) then + Error_Msg_N + ("aspect must name a discriminant of current type", Expr); - begin - Disc := First_Discriminant (E); - while Present (Disc) loop - if Chars (Expr) = Chars (Disc) - and then Ekind (Etype (Disc)) = - E_Anonymous_Access_Type - then - Set_Has_Implicit_Dereference (E); - Set_Has_Implicit_Dereference (Disc); - return; - end if; + else + Disc := First_Discriminant (E); + while Present (Disc) loop + if Chars (Expr) = Chars (Disc) + and then Ekind (Etype (Disc)) = + E_Anonymous_Access_Type + then + Set_Has_Implicit_Dereference (E); + Set_Has_Implicit_Dereference (Disc); + exit; + end if; - Next_Discriminant (Disc); - end loop; + Next_Discriminant (Disc); + end loop; - -- Error if no proper access discriminant. + -- Error if no proper access discriminant. + if No (Disc) then Error_Msg_NE ("not an access discriminant of&", Expr, E); - end; + return; + end if; + end if; + + if Is_Derived_Type (E) + and then Has_Discriminants (Etype (E)) + then + Parent_Disc := Get_Reference_Discriminant (Etype (E)); + + if Present (Parent_Disc) + and then Corresponding_Discriminant (Disc) /= Parent_Disc + then + Error_Msg_N ("reference discriminant does not match " & + "discriminant of parent type", Expr); + end if; end if; end Analyze_Aspect_Implicit_Dereference; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 1dce0faf82a..2000f425bfb 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -2567,6 +2567,10 @@ package body Sem_Ch3 is and then not (In_Private_Part (Current_Scope) or else In_Package_Body (Current_Scope)); + procedure Check_Nonoverridable_Aspects; + -- Apply the rule in RM 13.1.1(18.4/4) on iterator aspects that cannot + -- be overridden, and can only be confirmed on derivation. + procedure Check_Ops_From_Incomplete_Type; -- If there is a tagged incomplete partial view of the type, traverse -- the primitives of the incomplete view and change the type of any @@ -2575,6 +2579,90 @@ package body Sem_Ch3 is -- list later in Sem_Disp.Check_Operation_From_Incomplete_Type (which -- is called from Process_Incomplete_Dependents). + ---------------------------------- + -- Check_Nonoverridable_Aspects -- + ---------------------------------- + + procedure Check_Nonoverridable_Aspects is + Prev_Aspects : constant List_Id := + Aspect_Specifications (Parent (Def_Id)); + Par_Type : Entity_Id; + + function Has_Aspect_Spec + (Specs : List_Id; + Aspect_Name : Name_Id) return Boolean; + -- Check whether a list of aspect specifications includes an entry + -- for a specific aspect. The list is either that of a partial or + -- a full view. + + --------------------- + -- Has_Aspect_Spec -- + --------------------- + + function Has_Aspect_Spec + (Specs : List_Id; + Aspect_Name : Name_Id) return Boolean + is + Spec : Node_Id; + begin + Spec := First (Specs); + while Present (Spec) loop + if Chars (Identifier (Spec)) = Aspect_Name then + return True; + end if; + Next (Spec); + end loop; + return False; + end Has_Aspect_Spec; + + -- Start of processing for Check_Nonoverridable_Aspects + + begin + + -- Get parent type of derived type. Note that Prev is the entity + -- in the partial declaration, but its contents are now those of + -- full view, while Def_Id reflects the partial view. + + if Is_Private_Type (Def_Id) then + Par_Type := Etype (Full_View (Def_Id)); + else + Par_Type := Etype (Def_Id); + end if; + + -- If there is an inherited Implicit_Dereference, verify that it is + -- made explicit in the partial view. + + if Has_Discriminants (Base_Type (Par_Type)) + and then Nkind (Parent (Prev)) = N_Full_Type_Declaration + and then Present (Discriminant_Specifications (Parent (Prev))) + and then Present (Get_Reference_Discriminant (Par_Type)) + then + if + not Has_Aspect_Spec (Prev_Aspects, Name_Implicit_Dereference) + then + Error_Msg_N + ("type does not inherit implicit dereference", Prev); + + else + -- If one of the views has the aspect specified, verify that it + -- is consistent with that of the parent. + + declare + Par_Discr : constant Entity_Id := + Get_Reference_Discriminant (Par_Type); + Cur_Discr : constant Entity_Id := + Get_Reference_Discriminant (Prev); + begin + if Corresponding_Discriminant (Cur_Discr) /= Par_Discr then + Error_Msg_N ("aspect incosistent with that of parent", N); + end if; + end; + end if; + end if; + + -- TBD : other nonoverridable aspects. + end Check_Nonoverridable_Aspects; + ------------------------------------ -- Check_Ops_From_Incomplete_Type -- ------------------------------------ @@ -2894,6 +2982,12 @@ package body Sem_Ch3 is Analyze_Aspect_Specifications (N, Def_Id); end if; end if; + + if Is_Derived_Type (Prev) + and then Def_Id /= Prev + then + Check_Nonoverridable_Aspects; + end if; end Analyze_Full_Type_Declaration; ---------------------------------- @@ -16366,28 +16460,41 @@ package body Sem_Ch3 is ----------------------------- -- Check_Duplicate_Aspects -- ----------------------------- + procedure Check_Duplicate_Aspects is Prev_Aspects : constant List_Id := Aspect_Specifications (Prev_Par); Full_Aspects : constant List_Id := Aspect_Specifications (N); F_Spec, P_Spec : Node_Id; begin - if Present (Prev_Aspects) and then Present (Full_Aspects) then + if Present (Full_Aspects) then F_Spec := First (Full_Aspects); while Present (F_Spec) loop - P_Spec := First (Prev_Aspects); - while Present (P_Spec) loop - if Chars (Identifier (P_Spec)) = Chars (Identifier (F_Spec)) - then - Error_Msg_N - ("aspect already specified in private declaration", - F_Spec); - Remove (F_Spec); - return; - end if; + if Present (Prev_Aspects) then + P_Spec := First (Prev_Aspects); + while Present (P_Spec) loop + if Chars (Identifier (P_Spec)) = + Chars (Identifier (F_Spec)) + then + Error_Msg_N + ("aspect already specified in private declaration", + F_Spec); + Remove (F_Spec); + return; + end if; - Next (P_Spec); - end loop; + Next (P_Spec); + end loop; + end if; + + if Has_Discriminants (Prev) + and then not Has_Unknown_Discriminants (Prev) + and then Chars (Identifier (F_Spec)) = + Name_Implicit_Dereference + then + Error_Msg_N ("cannot specify aspect " & + "if partial view has known discriminants", F_Spec); + end if; Next (F_Spec); end loop; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index d182229922e..ce64755940d 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -7812,9 +7812,7 @@ package body Sem_Util is Next_Discriminant (D); end loop; - -- Type must have a proper access discriminant. - - pragma Assert (False); + return Empty; end Get_Reference_Discriminant; ---------------------------