+2014-11-20 Thomas Quinot <quinot@adacore.com>
+
+ * sem_ch13.adb, freeze.adb: Minor reformatting.
+ * gnat_rm.texi: Minor editing.
+
+2014-11-20 Robert Dewar <dewar@adacore.com>
+
+ * sem_prag.adb (Analyze_Pragma): Minor reformatting.
+ (Process_Suppress_Unsuppress): Ignore suppress Elaboration_Check
+ in SPARK.
+
+2014-11-20 Bob Duff <duff@adacore.com>
+
+ * 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 <schonberg@adacore.com>
+
+ * 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 <kirtchev@adacore.com>
+
+ * sem_util.adb (Policy_In_Effect): Use the
+ configuration level assertion flag.
+
2014-11-20 Arnaud Charlet <charlet@adacore.com>
* s-parame-ae653.ads: Update comments.
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;
-----------
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;
--------------
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));
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;
----------------
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;
-----------------
---------------
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;
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;
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;
----------------
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;
declare
II : constant Int'Base := Int (Index) - Int (No_Index);
I : constant Capacity_Range := Capacity_Range (II);
-
begin
Elems (Container) (I) := New_Item;
end;
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);
declare
I, J : Capacity_Range;
- E : Elements_Array renames Elems (Container).all;
+ E : Elements_Array renames
+ Elems (Container) (1 .. Length (Container));
begin
I := 1;
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;
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)
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)))
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
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
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
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
-- 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,
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
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);
("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
-- pragma Suppress (IDENTIFIER [, [On =>] NAME]);
when Pragma_Suppress =>
- Process_Suppress_Unsuppress (True);
+ Process_Suppress_Unsuppress (Suppress_Case => True);
------------------
-- Suppress_All --
when Pragma_Unsuppress =>
Ada_2005_Pragma;
- Process_Suppress_Unsuppress (False);
+ Process_Suppress_Unsuppress (Suppress_Case => False);
----------------------------
-- Unevaluated_Use_Of_Old --
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;
projects / gcc.git / commitdiff