From bcdb6b04a792df81eb09c535591e194fa1c91ca2 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Thu, 20 Nov 2014 16:54:31 +0100 Subject: [PATCH] [multiple changes] 2014-11-20 Thomas Quinot * sem_ch13.adb, freeze.adb: Minor reformatting. * gnat_rm.texi: Minor editing. 2014-11-20 Robert Dewar * sem_prag.adb (Analyze_Pragma): Minor reformatting. (Process_Suppress_Unsuppress): Ignore suppress Elaboration_Check in SPARK. 2014-11-20 Bob Duff * gnat_rm.texi: Correction to documentation of 'Unrestricted_Access in case of access to unconstrained array. * a-cofove.adb (Capacity): Fix bug -- was always returning Capacity_Range'Last. (Is_Sorted): Fix bug -- was always returning True, because Container.Last = Last. That test isn't even needed, because the loop will go around zero times in that case, so deleted that test rather than fixing it. (Reverse_Elements): Make sure to use the correct array bounds. 2014-11-20 Ed Schonberg * sem_ch12.adb (Analyze_Associations): In GNATProve mode, build wrappers for functions and operators that are actuals only if expander is enabled. Wrappers play no role within a generic unit. 2014-11-20 Hristian Kirtchev * sem_util.adb (Policy_In_Effect): Use the configuration level assertion flag. From-SVN: r217880 --- gcc/ada/ChangeLog | 34 +++++++++++++++++++++ gcc/ada/a-cofove.adb | 71 ++++++++++++++++++++------------------------ gcc/ada/freeze.adb | 7 ++--- gcc/ada/gnat_rm.texi | 22 +++++++------- gcc/ada/sem_ch12.adb | 9 ++++-- gcc/ada/sem_ch13.adb | 11 +++---- gcc/ada/sem_prag.adb | 15 ++++++++-- gcc/ada/sem_util.adb | 5 ++-- 8 files changed, 106 insertions(+), 68 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index ea570d92791..cf6060da437 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,37 @@ +2014-11-20 Thomas Quinot + + * sem_ch13.adb, freeze.adb: Minor reformatting. + * gnat_rm.texi: Minor editing. + +2014-11-20 Robert Dewar + + * sem_prag.adb (Analyze_Pragma): Minor reformatting. + (Process_Suppress_Unsuppress): Ignore suppress Elaboration_Check + in SPARK. + +2014-11-20 Bob Duff + + * gnat_rm.texi: Correction to documentation of + 'Unrestricted_Access in case of access to unconstrained array. + * a-cofove.adb (Capacity): Fix bug -- was always + returning Capacity_Range'Last. + (Is_Sorted): Fix bug -- was always returning True, because + Container.Last = Last. That test isn't even needed, because the + loop will go around zero times in that case, so deleted that + test rather than fixing it. + (Reverse_Elements): Make sure to use the correct array bounds. + +2014-11-20 Ed Schonberg + + * sem_ch12.adb (Analyze_Associations): In GNATProve mode, build + wrappers for functions and operators that are actuals only if + expander is enabled. Wrappers play no role within a generic unit. + +2014-11-20 Hristian Kirtchev + + * sem_util.adb (Policy_In_Effect): Use the + configuration level assertion flag. + 2014-11-20 Arnaud Charlet * s-parame-ae653.ads: Update comments. diff --git a/gcc/ada/a-cofove.adb b/gcc/ada/a-cofove.adb index 04895432356..df02dc01ee5 100644 --- a/gcc/ada/a-cofove.adb +++ b/gcc/ada/a-cofove.adb @@ -150,7 +150,9 @@ is function Capacity (Container : Vector) return Capacity_Range is begin - return Elemsc (Container)'Length; + return (if Container.Elements_Ptr = null + then Container.Elements'Length + else Container.Elements_Ptr.all'Length); end Capacity; ----------- @@ -160,8 +162,10 @@ is procedure Clear (Container : in out Vector) is begin Container.Last := No_Index; + + -- Free element, note that this is OK if Elements_Ptr is null + Free (Container.Elements_Ptr); - -- It's OK if Container.Elements_Ptr is null end Clear; -------------- @@ -211,8 +215,7 @@ is Current : Index_Type) return Vector is begin - return Result : Vector - (Count_Type (Container.Last - Current + 1)) + return Result : Vector (Count_Type (Container.Last - Current + 1)) do for X in Current .. Container.Last loop Append (Result, Element (Container, X)); @@ -268,16 +271,16 @@ is function Elems (Container : in out Vector) return Maximal_Array_Ptr is begin return (if Container.Elements_Ptr = null - then Container.Elements'Unrestricted_Access - else Container.Elements_Ptr.all'Unrestricted_Access); + then Container.Elements'Unrestricted_Access + else Container.Elements_Ptr.all'Unrestricted_Access); end Elems; function Elemsc (Container : Vector) return Maximal_Array_Ptr_Const is begin return (if Container.Elements_Ptr = null - then Container.Elements'Unrestricted_Access - else Container.Elements_Ptr.all'Unrestricted_Access); + then Container.Elements'Unrestricted_Access + else Container.Elements_Ptr.all'Unrestricted_Access); end Elemsc; ---------------- @@ -313,9 +316,9 @@ is begin if Is_Empty (Container) then raise Constraint_Error with "Container is empty"; + else + return Get_Element (Container, 1); end if; - - return Get_Element (Container, 1); end First_Element; ----------------- @@ -357,24 +360,15 @@ is --------------- function Is_Sorted (Container : Vector) return Boolean is - Last : constant Index_Type := Last_Index (Container); - + L : constant Capacity_Range := Length (Container); begin - if Container.Last <= Last then - return True; - end if; - - declare - L : constant Capacity_Range := Length (Container); - begin - for J in 1 .. L - 1 loop - if Get_Element (Container, J + 1) < - Get_Element (Container, J) - then - return False; - end if; - end loop; - end; + for J in 1 .. L - 1 loop + if Get_Element (Container, J + 1) < + Get_Element (Container, J) + then + return False; + end if; + end loop; return True; end Is_Sorted; @@ -396,9 +390,9 @@ is begin if Container.Last <= Index_Type'First then return; + else + Sort (Elems (Container) (1 .. Len)); end if; - - Sort (Elems (Container) (1 .. Len)); end Sort; end Generic_Sorting; @@ -442,9 +436,9 @@ is begin if Is_Empty (Container) then raise Constraint_Error with "Container is empty"; + else + return Get_Element (Container, Length (Container)); end if; - - return Get_Element (Container, Length (Container)); end Last_Element; ---------------- @@ -464,7 +458,6 @@ is L : constant Int := Int (Last_Index (Container)); F : constant Int := Int (Index_Type'First); N : constant Int'Base := L - F + 1; - begin return Capacity_Range (N); end Length; @@ -486,7 +479,6 @@ is declare II : constant Int'Base := Int (Index) - Int (No_Index); I : constant Capacity_Range := Capacity_Range (II); - begin Elems (Container) (I) := New_Item; end; @@ -509,8 +501,8 @@ is if Capacity > Formal_Vectors.Capacity (Container) then declare New_Elements : constant Elements_Array_Ptr := - new Elements_Array (1 .. Capacity); - L : constant Capacity_Range := Length (Container); + new Elements_Array (1 .. Capacity); + L : constant Capacity_Range := Length (Container); begin New_Elements (1 .. L) := Elemsc (Container) (1 .. L); Free (Container.Elements_Ptr); @@ -532,7 +524,8 @@ is declare I, J : Capacity_Range; - E : Elements_Array renames Elems (Container).all; + E : Elements_Array renames + Elems (Container) (1 .. Length (Container)); begin I := 1; @@ -640,8 +633,10 @@ is Last := Index_Type (Last_As_Int); - return (Capacity => Length, Last => Last, Elements_Ptr => <>, - Elements => (others => New_Item)); + return (Capacity => Length, + Last => Last, + Elements_Ptr => <>, + Elements => (others => New_Item)); end; end To_Vector; diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 8c8f019acfb..532bde9a146 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -7695,9 +7695,8 @@ package body Freeze is procedure Set_SSO_From_Default (T : Entity_Id) is begin - -- Set default SSO for an array or record base type, except in the case - -- of a type extension (which always inherits the SSO of its parent - -- type). + -- Set default SSO for an array or record base type, except in case of + -- a type extension (which always inherits the SSO of its parent type). if Is_Base_Type (T) and then (Is_Array_Type (T) @@ -7705,7 +7704,7 @@ package body Freeze is and then not (Is_Tagged_Type (T) and then Is_Derived_Type (T)))) then - if ((Bytes_Big_Endian and then SSO_Set_Low_By_Default (T)) + if ((Bytes_Big_Endian and then SSO_Set_Low_By_Default (T)) or else ((not Bytes_Big_Endian) and then SSO_Set_High_By_Default (T))) diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index 3824ee877fc..6bf94620be6 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -9994,17 +9994,17 @@ called after P2 returns, it would be an erroneous use of a dangling pointer. For objects, it is possible to use @code{Unrestricted_Access} for any -type, but care must be exercised if it is used to create pointers to -unconstrained array objects. In this case, the resulting pointer has -the same scope as the context of the attribute, and may not be -returned to some enclosing scope. For instance, a function cannot use -@code{Unrestricted_Access} to create a pointer to unconstrained and -then return that value to the caller. In addition, it is only valid -to create pointers to unconstrained arrays using this attribute if the -pointer has the normal default ``fat'' representation where a pointer -has two components, one points to the array and one points to the -bounds. If a size clause is used to force ``thin'' representation for -a pointer to unconstrained where there is only space for a single +type. However, if the result is of an access-to-unconstrained array +subtype, then the resulting pointer has the same scope as the context +of the attribute, and must not be returned to some enclosing scope. +For instance, if a function uses @code{Unrestricted_Access} to create +an access-to-unconstrained-array and returns that value to the caller, +the result will involve dangling pointers. In addition, it is only +valid to create pointers to unconstrained arrays using this attribute +if the pointer has the normal default ``fat'' representation where a +pointer has two components, one points to the array and one points to +the bounds. If a size clause is used to force ``thin'' representation +for a pointer to unconstrained where there is only space for a single pointer, then the resulting pointer is not usable. In the simple case where a direct use of Unrestricted_Access attempts diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 44a91b6c516..6062a88d60f 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -1087,7 +1087,8 @@ package body Sem_Ch12 is else Parm_Type := - Make_Identifier (Loc, Chars (Etype (Etype (Form_F)))); + Make_Identifier (Loc, + Chars => Chars (First_Subtype (Etype (Form_F)))); end if; -- If actual is present, use the type of its own formal @@ -1805,9 +1806,10 @@ package body Sem_Ch12 is E_Function then -- If actual is an entity (function or operator), - -- build wrapper for it. + -- and expander is active, build wrapper for it. + -- Note that wrappers play no role within a generic. - if Present (Match) then + if Present (Match) and then Expander_Active then if Nkind (Match) = N_Operator_Symbol then -- If the name is a default, find its visible @@ -1835,6 +1837,7 @@ package body Sem_Ch12 is elsif Box_Present (Formal) and then Nkind (Defining_Entity (Analyzed_Formal)) = N_Defining_Operator_Symbol + and then Expander_Active then Append_To (Assoc, Build_Operator_Wrapper diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index a0dd0be46d3..8443daf6fcd 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -10971,10 +10971,8 @@ package body Sem_Ch13 is -- in a flag of the base type! if (Is_Record_Type (Typ) or else Is_Array_Type (Typ)) - and then - Typ = Bas_Typ + and then Typ = Bas_Typ then - -- For a type extension, always inherit from parent; otherwise -- inherit if no default applies. Note: we do not check for -- an explicit rep item on the parent type when inheriting, @@ -10983,10 +10981,9 @@ package body Sem_Ch13 is if not Has_Rep_Item (First_Subtype (Typ), Name_Scalar_Storage_Order, False) and then (Is_Tagged_Type (Bas_Typ) - or else - not (SSO_Set_Low_By_Default (Bas_Typ) - or else - SSO_Set_High_By_Default (Bas_Typ))) + or else not (SSO_Set_Low_By_Default (Bas_Typ) + or else + SSO_Set_High_By_Default (Bas_Typ))) then Set_Reverse_Storage_Order (Bas_Typ, Reverse_Storage_Order diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 1ea8de824c7..7872328e063 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -2730,7 +2730,7 @@ package body Sem_Prag is procedure Check_Ada_83_Warning; -- Issues a warning message for the current pragma if operating in Ada -- 83 mode (used for language pragmas that are not a standard part of - -- Ada 83). This procedure does not raise Error_Pragma. Also notes use + -- Ada 83). This procedure does not raise Pragma_Exit. Also notes use -- of 95 pragma. procedure Check_Arg_Count (Required : Nat); @@ -9046,6 +9046,15 @@ package body Sem_Prag is ("argument of pragma% is not valid check name", Arg1); end if; + -- Warn that suppress of Elaboration_Check has no effect in SPARK + + if C = Elaboration_Check and then SPARK_Mode = On then + Error_Pragma_Arg + ("Suppress of Elaboration_Check ignored in SPARK??", Arg1); + end if; + + -- One-argument case + if Arg_Count = 1 then -- Make an entry in the local scope suppress table. This is the @@ -20282,7 +20291,7 @@ package body Sem_Prag is -- pragma Suppress (IDENTIFIER [, [On =>] NAME]); when Pragma_Suppress => - Process_Suppress_Unsuppress (True); + Process_Suppress_Unsuppress (Suppress_Case => True); ------------------ -- Suppress_All -- @@ -21120,7 +21129,7 @@ package body Sem_Prag is when Pragma_Unsuppress => Ada_2005_Pragma; - Process_Suppress_Unsuppress (False); + Process_Suppress_Unsuppress (Suppress_Case => False); ---------------------------- -- Unevaluated_Use_Of_Old -- diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 3ae7058c194..fced9783966 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -15726,10 +15726,11 @@ package body Sem_Util is end if; -- The context lacks policy pragmas, determine the mode based on whether - -- assertions are enabled. + -- assertions are enabled at the configuration level. This ensures that + -- the policy is preserved when analyzing generics. if Kind = No_Name then - if Assertions_Enabled then + if Assertions_Enabled_Config then Kind := Name_Check; else Kind := Name_Ignore; -- 2.30.2