From 7738270b0ceda07f89c1dd2d75e31ae7bb4f2053 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Tue, 25 Apr 2017 14:38:24 +0200 Subject: [PATCH] [multiple changes] 2017-04-25 Yannick Moy * freeze.adb (Freeze_Record_Type): Remove obsolete rule on volatile tagged record restriction on SPARK code. 2017-04-25 Yannick Moy * sem_prag.adb (minor) Fix SPARK RM reference. 2017-04-25 Yannick Moy * sem_util.adb, sem_util.ads (Unique_Defining_Entity): Update comment to reflect which entity is chosen as unique entity. (Unique_Entity): Return full view instead of private spec for protected type or task type. Fix possible incorrect access when called on entry. 2017-04-25 Eric Botcazou * sem_res.adb (Set_Slice_Subtype): Treat specially bit-packed array types only instead of all packed array types. 2017-04-25 Ed Schonberg * sem_ch6.adb (Conforming_Types): If type of formal as a specified dimension system, verify that dimensions of both match. (Check_Conformance): Add error message in case of dimension mismatch. * sem_dim.ads, sem_dim.adb (Dimensions_Match): New utility predicate. 2017-04-25 Arnaud Charlet * gnatxref.adb, gnatfind.adb: Avoid using the term project file, confusing. From-SVN: r247212 --- gcc/ada/ChangeLog | 36 +++++++++++++++++++++++++++++++++ gcc/ada/freeze.adb | 16 ++++----------- gcc/ada/gnatfind.adb | 4 ++-- gcc/ada/gnatxref.adb | 4 ++-- gcc/ada/sem_ch6.adb | 36 ++++++++++++++++++++++----------- gcc/ada/sem_dim.adb | 13 +++++++++++- gcc/ada/sem_dim.ads | 6 +++++- gcc/ada/sem_prag.adb | 2 +- gcc/ada/sem_res.adb | 8 ++++---- gcc/ada/sem_util.adb | 47 ++++++++++++++++++++++++++++++++------------ gcc/ada/sem_util.ads | 21 ++++++++++++++------ 11 files changed, 140 insertions(+), 53 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 8edaf572cc3..1cb5c4d1329 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,39 @@ +2017-04-25 Yannick Moy + + * freeze.adb (Freeze_Record_Type): Remove obsolete + rule on volatile tagged record restriction on SPARK code. + +2017-04-25 Yannick Moy + + * sem_prag.adb (minor) Fix SPARK RM reference. + +2017-04-25 Yannick Moy + + * sem_util.adb, sem_util.ads (Unique_Defining_Entity): Update + comment to reflect which entity is chosen as unique entity. + (Unique_Entity): Return full view instead of private spec for + protected type or task type. Fix possible incorrect access when + called on entry. + +2017-04-25 Eric Botcazou + + * sem_res.adb (Set_Slice_Subtype): Treat specially bit-packed + array types only instead of all packed array types. + +2017-04-25 Ed Schonberg + + * sem_ch6.adb (Conforming_Types): If type of formal as a specified + dimension system, verify that dimensions of both match. + (Check_Conformance): Add error message in case of dimension + mismatch. + * sem_dim.ads, sem_dim.adb (Dimensions_Match): New utility + predicate. + +2017-04-25 Arnaud Charlet + + * gnatxref.adb, gnatfind.adb: Avoid using the term project file, + confusing. + 2017-04-25 Yannick Moy * sem_util.adb: Minor refactoring. diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 7cfa2955d8e..571f4968a79 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -4622,21 +4622,13 @@ package body Freeze is -- they are not standard Ada legality rules. if SPARK_Mode = On then - if Is_Effectively_Volatile (Rec) then - -- A discriminated type cannot be effectively volatile - -- (SPARK RM 7.1.3(5)). + -- A discriminated type cannot be effectively volatile + -- (SPARK RM 7.1.3(5)). - if Has_Discriminants (Rec) - and then not Is_Protected_Type (Rec) - then + if Is_Effectively_Volatile (Rec) then + if Has_Discriminants (Rec) then Error_Msg_N ("discriminated type & cannot be volatile", Rec); - - -- A tagged type cannot be effectively volatile - -- (SPARK RM C.6(5)). - - elsif Is_Tagged_Type (Rec) then - Error_Msg_N ("tagged type & cannot be volatile", Rec); end if; -- A non-effectively volatile record type cannot contain diff --git a/gcc/ada/gnatfind.adb b/gcc/ada/gnatfind.adb index adde08407fb..0d030be6f00 100644 --- a/gcc/ada/gnatfind.adb +++ b/gcc/ada/gnatfind.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1998-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1998-2016, 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- -- @@ -322,7 +322,7 @@ procedure Gnatfind is Put_Line (" --ext=xxx Specify alternate ali file extension"); Put_Line (" --RTS=dir specify the default source and object search" & " path"); - Put_Line (" -p file Use file as the default project file"); + Put_Line (" -p file Use file as the configuration file"); Put_Line (" -r Find all references (default to find declaration" & " only)"); Put_Line (" -s Print source line"); diff --git a/gcc/ada/gnatxref.adb b/gcc/ada/gnatxref.adb index 7d2ec9ca37f..c24fd49341a 100644 --- a/gcc/ada/gnatxref.adb +++ b/gcc/ada/gnatxref.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1998-2015, Free Software Foundation, Inc. -- +-- Copyright (C) 1998-2016, 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- -- @@ -278,7 +278,7 @@ procedure Gnatxref is Put_Line (" --ext=xxx Specify alternate ali file extension"); Put_Line (" --RTS=dir specify the default source and object search" & " path"); - Put_Line (" -p file Use file as the default project file"); + Put_Line (" -p file Use file as the configuration file"); Put_Line (" -u List unused entities"); Put_Line (" -v Print a 'tags' file for vi"); New_Line; diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 5bd4a7c4ef1..da261e9107f 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -5300,6 +5300,11 @@ package body Sem_Ch6 is else Conformance_Error ("\type of & does not match!", New_Formal); + + if not Dimensions_Match (Old_Formal_Base, New_Formal_Base) + then + Error_Msg_N ("\dimensions mismatch!", New_Formal); + end if; end if; end if; @@ -7410,30 +7415,39 @@ package body Sem_Ch6 is return True; elsif Base_Types_Match (Type_1, Type_2) then - return Ctype <= Mode_Conformant - or else Subtypes_Statically_Match (Type_1, Type_2); + if Ctype <= Mode_Conformant then + return True; + + else + return + Subtypes_Statically_Match (Type_1, Type_2) + and then Dimensions_Match (Type_1, Type_2); + end if; elsif Is_Incomplete_Or_Private_Type (Type_1) and then Present (Full_View (Type_1)) and then Base_Types_Match (Full_View (Type_1), Type_2) then - return Ctype <= Mode_Conformant - or else Subtypes_Statically_Match (Full_View (Type_1), Type_2); + return + Ctype <= Mode_Conformant + or else Subtypes_Statically_Match (Full_View (Type_1), Type_2); elsif Ekind (Type_2) = E_Incomplete_Type and then Present (Full_View (Type_2)) and then Base_Types_Match (Type_1, Full_View (Type_2)) then - return Ctype <= Mode_Conformant - or else Subtypes_Statically_Match (Type_1, Full_View (Type_2)); + return + Ctype <= Mode_Conformant + or else Subtypes_Statically_Match (Type_1, Full_View (Type_2)); elsif Is_Private_Type (Type_2) and then In_Instance and then Present (Full_View (Type_2)) and then Base_Types_Match (Type_1, Full_View (Type_2)) then - return Ctype <= Mode_Conformant - or else Subtypes_Statically_Match (Type_1, Full_View (Type_2)); + return + Ctype <= Mode_Conformant + or else Subtypes_Statically_Match (Type_1, Full_View (Type_2)); -- Another confusion between views in a nested instance with an -- actual private type whose full view is not in scope. @@ -7527,9 +7541,9 @@ package body Sem_Ch6 is elsif Are_Anonymous_Access_To_Subprogram_Types then if Ada_Version < Ada_2005 then - return Ctype = Type_Conformant - or else - Subtypes_Statically_Match (Desig_1, Desig_2); + return + Ctype = Type_Conformant + or else Subtypes_Statically_Match (Desig_1, Desig_2); -- We must check the conformance of the signatures themselves diff --git a/gcc/ada/sem_dim.adb b/gcc/ada/sem_dim.adb index 1e956011d51..c5eda0c4f32 100644 --- a/gcc/ada/sem_dim.adb +++ b/gcc/ada/sem_dim.adb @@ -2347,7 +2347,7 @@ package body Sem_Dim is -- Copy_Dimensions -- --------------------- - procedure Copy_Dimensions (From, To : Node_Id) is + procedure Copy_Dimensions (From : Node_Id; To : Node_Id) is Dims_Of_From : constant Dimension_Type := Dimensions_Of (From); begin @@ -2593,6 +2593,17 @@ package body Sem_Dim is Error_Msg_N ("assumed to be%%??", N); end Dim_Warning_For_Numeric_Literal; + ---------------------- + -- Dimensions_Match -- + ---------------------- + + function Dimensions_Match (T1 : Entity_Id; T2 : Entity_Id) return Boolean is + begin + return + not Has_Dimension_System (Base_Type (T1)) + or else Dimensions_Of (T1) = Dimensions_Of (T2); + end Dimensions_Match; + ---------------------------------------- -- Eval_Op_Expon_For_Dimensioned_Type -- ---------------------------------------- diff --git a/gcc/ada/sem_dim.ads b/gcc/ada/sem_dim.ads index 44f4e86fced..fc484eaffdb 100644 --- a/gcc/ada/sem_dim.ads +++ b/gcc/ada/sem_dim.ads @@ -174,11 +174,15 @@ package Sem_Dim is -- resolution of the ultimate components to a separate phase, which forces -- this separate dimension verification. - procedure Copy_Dimensions (From, To : Node_Id); + procedure Copy_Dimensions (From : Node_Id; To : Node_Id); -- Copy dimension vector of node From to node To. Note that To must be a -- node that is allowed to contain a dimension (see OK_For_Dimension in -- body of Sem_Dim). + function Dimensions_Match (T1 : Entity_Id; T2 : Entity_Id) return Boolean; + -- If the common base type has a dimension system, verify that two + -- subtypes have the same dimensions. Used for conformance checking. + procedure Eval_Op_Expon_For_Dimensioned_Type (N : Node_Id; Btyp : Entity_Id); diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index acaacf88566..03da2473285 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -7084,7 +7084,7 @@ package body Sem_Prag is -- The following check is only relevant when SPARK_Mode is on as -- this is not a standard Ada legality rule. Pragma Volatile can -- only apply to a full type declaration or an object declaration - -- (SPARK RM C.6(1)). Original_Node is necessary to account for + -- (SPARK RM 7.1.3(2)). Original_Node is necessary to account for -- untagged derived types that are rewritten as subtypes of their -- respective root types. diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index b3e2c285e49..683686f5caa 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -11529,11 +11529,11 @@ package body Sem_Res is Set_Etype (N, Slice_Subtype); - -- For packed slice subtypes, freeze immediately (except in the case of - -- being in a "spec expression" where we never freeze when we first see - -- the expression). + -- For bit-packed slice subtypes, freeze immediately (except in the case + -- of being in a "spec expression" where we never freeze when we first + -- see the expression). - if Is_Packed (Slice_Subtype) and not In_Spec_Expression then + if Is_Bit_Packed_Array (Slice_Subtype) and not In_Spec_Expression then Freeze_Itype (Slice_Subtype, N); -- For all other cases insert an itype reference in the slice's actions diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 0c00fe25f5c..7f80ba6cb19 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -21320,22 +21320,35 @@ package body Sem_Util is Prot_Type := Scope (Scope (E)); end if; - pragma Assert (Ekind (Prot_Type) = E_Protected_Type); + -- A protected type may be declared as a private type, in + -- which case we need to get its full view. - -- Traverse the entity list of the protected type and locate - -- an entry declaration which matches the entry body. + if Is_Private_Type (Prot_Type) then + Prot_Type := Full_View (Prot_Type); + end if; - Prot_Item := First_Entity (Prot_Type); - while Present (Prot_Item) loop - if Ekind (Prot_Item) in Entry_Kind - and then Corresponding_Body (Parent (Prot_Item)) = E - then - U := Prot_Item; - exit; - end if; + -- Full view may not be present on error, in which case + -- return E by default. - Next_Entity (Prot_Item); - end loop; + if Present (Prot_Type) then + pragma Assert (Ekind (Prot_Type) = E_Protected_Type); + + -- Traverse the entity list of the protected type and + -- locate an entry declaration which matches the entry + -- body. + + Prot_Item := First_Entity (Prot_Type); + while Present (Prot_Item) loop + if Ekind (Prot_Item) in Entry_Kind + and then Corresponding_Body (Parent (Prot_Item)) = E + then + U := Prot_Item; + exit; + end if; + + Next_Entity (Prot_Item); + end loop; + end if; end; end if; @@ -21380,6 +21393,10 @@ package body Sem_Util is end if; end if; + if Is_Private_Type (U) then + U := Full_View (U); + end if; + when E_Subprogram_Body => P := Parent (E); @@ -21421,6 +21438,10 @@ package body Sem_Util is end if; end if; + if Is_Private_Type (U) then + U := Full_View (U); + end if; + when Type_Kind => if Present (Full_View (E)) then U := Full_View (E); diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 0d5de62d5fc..a1787554ac2 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -2425,13 +2425,22 @@ package Sem_Util is function Unique_Defining_Entity (N : Node_Id) return Entity_Id; -- Return the entity which represents declaration N, so that different -- views of the same entity have the same unique defining entity: - -- * entry declaration and entry body - -- * package spec, package body, and package body stub - -- * protected type declaration, protected body, and protected body stub -- * private view and full view of a deferred constant - -- * private view and full view of a type - -- * subprogram declaration, subprogram, and subprogram body stub - -- * task type declaration, task body, and task body stub + -- --> full view + -- * entry spec and entry body + -- --> entry spec + -- * formal parameter on spec and body + -- --> formal parameter on spec + -- * package spec, body, and body stub + -- --> package spec + -- * protected type, protected body, and protected body stub + -- --> protected type (full view if private) + -- * subprogram spec, body, and body stub + -- --> subprogram spec + -- * task type, task body, and task body stub + -- --> task type (full view if private) + -- * private or incomplete view and full view of a type + -- --> full view -- In other cases, return the defining entity for N. function Unique_Entity (E : Entity_Id) return Entity_Id; -- 2.30.2